TKE  3.6
Advanced code editor for programmers
Functions
interpreter Namespace Reference

Functions

 check_file_access pname fname
 
 check_file pname fname
 
 encode_file pname fname
 
 add_ctext interp pname txt
 
 widget_command pname widget win args
 
 set_variable pname varname name1 name2 op
 
 widget_win pname win cmd args
 
 destroy_command pname win
 
 bind_command pname tag args
 
 winfo_command pname subcmd args
 
 wm_command pname subcmd win args
 
 image_command pname subcmd args
 
 image_win pname img cmd args
 
 tablelist_command pname win args
 
 tablelist_win pname win cmd args
 
 tablelist_do pname cmd args
 
 open_command pname fname args
 
 close_command pname channel args
 
 flush_command pname channel
 
 read_command pname args
 
 puts_command pname args
 
 fconfigure_command pname args
 
 exec_command pname args
 
 file_command pname subcmd args
 
 glob_command pname args
 
 create pname trust_granted
 
 destroy pname
 

Function Documentation

§ add_ctext()

interpreter::add_ctext   interp pname txt  

Definition at line 106 of file interpreter.tcl.

106  proc add_ctext {interp pname txt} {
107 
108  variable interps
109 
110  # Remember the text widget
111  lappend interps($pname,wins) [list $txt 0] [list $txt.t 0]
112 
113  # Create the alias
114  $interp alias $txt interpreter::widget_win $pname $txt
115  $interp alias $txt.t interpreter::widget_win $pname $txt.t
116 
117  }

§ bind_command()

interpreter::bind_command   pname tag args  

Definition at line 337 of file interpreter.tcl.

337  proc bind_command {pname tag args} {
338 
339  variable interps
340 
341  switch [llength $args] {
342  1 { return [bind $tag [lindex $args 0]]}
343  2 {
344  if {[string index [lindex $args 1] 0] eq "+"} {
345  return [bind $tag [lindex $args 0] [list +interp eval $interps($pname,interp) {*}[lrange [lindex $args 1] 1 end]]]
346  } else {
347  return [bind $tag [lindex $args 0] [list interp eval $interps($pname,interp) {*}[lindex $args 1]]]
348  }
349  }
350  }
351 
352  }

§ check_file()

interpreter::check_file   pname fname  

Definition at line 62 of file interpreter.tcl.

62  proc check_file {pname fname} {
63 
64  variable interps
65 
66  # We only need to check the file if we are in safe mode.
67  if {[$interps($pname,interp) issafe]} {
68 
69  # Translate the directory
70  if {[catch {::safe::TranslatePath $interps($pname,interp) $fname} fname]} {
71  return ""
72  }
73 
74  return [check_file_access $pname $fname]
75 
76  } else {
77 
78  return $fname
79 
80  }
81 
82  }

§ check_file_access()

interpreter::check_file_access   pname fname  

Definition at line 32 of file interpreter.tcl.

32  proc check_file_access {pname fname} {
33 
34  variable interps
35 
36  if {[$interps($pname,interp) issafe]} {
37 
38  # Normalize the file name
39  set fname [file normalize $fname]
40 
41  # Verify that the directory is within the access paths
42  foreach access_dir [lindex [::safe::interpConfigure $interps($pname,interp) -accessPath] 1] {
43  if {[string compare -length [string length $access_dir] $access_dir $fname] == 0} {
44  return $fname
45  }
46  }
47 
48  return ""
49 
50  } else {
51 
52  return $fname
53 
54  }
55 
56  }

§ close_command()

interpreter::close_command   pname channel args  

Definition at line 764 of file interpreter.tcl.

764  proc close_command {pname channel args} {
765 
766  variable interps
767 
768  if {[set index [lsearch $interps($pname,files) $channel]] != -1} {
769  close $channel {*}$args
770  set interps($pname,files) [lreplace $interps($pname,files) $index $index]
771  } else {
772  return -code error "permission error"
773  }
774 
775  }

§ create()

interpreter::create   pname trust_granted  

Definition at line 991 of file interpreter.tcl.

991  proc create {pname trust_granted} {
992 
993  variable interps
994 
995  # Setup the access paths
996  lappend access_path $::tcl_library
997  lappend access_path [file join $::tke_home plugins $pname]
998  lappend access_path [file join $::tke_home iplugins $pname]
999  lappend access_path [file join $::tke_dir plugins $pname]
1000  lappend access_path [file join $::tke_dir plugins images]
1001 
1002  # Create the interpreter
1003  if {$trust_granted} {
1004  set interp [interp create]
1005  } else {
1006  set interp [::safe::interpCreate -nested true -accessPath $access_path]
1007  }
1008 
1009  # Save the interpreter and initialize the structure
1010  set interps($pname,interp) $interp
1011  set interps($pname,wins) [list]
1012  set interps($pname,files) [list]
1013  set interps($pname,images) [list]
1014 
1015  # If we are in development mode, share standard output for debug purposes
1016  if {[::tke_development]} {
1017  interp share {} stdout $interp
1018  }
1019 
1020  # Create Tcl command aliases if we are running in untrusted mode
1021  if {!$trust_granted} {
1022  foreach cmd [list close exec file flush glob open puts fconfigure read] {
1023  $interp alias $cmd interpreter::${cmd}_command $pname
1024  }
1025  $interp hide exit my_exit
1026  }
1027 
1028  # Create raw ttk widget aliases
1029  foreach widget [list canvas listbox menu text toplevel ttk::button ttk::checkbutton ttk::combobox \
1030  ttk::entry ttk::frame ttk::label ttk::labelframe ttk::menubutton ttk::notebook \
1031  ttk::panedwindow ttk::progressbar ttk::radiobutton ttk::scale ttk::scrollbar \
1032  ttk::separator ttk::spinbox ttk::treeview ctext tokenentry::tokenentry \
1033  wmarkentry::wmarkentry tabbar::tabbar] {
1034  $interp alias $widget interpreter::widget_command $pname $widget
1035  }
1036 
1037  # Create Tcl/Tk commands
1038  foreach cmd [list clipboard event focus font grid pack place tk_messageBox \
1039  tk_chooseColor fontchooser tk_getOpenFile tk_getSaveFile \
1040  tk_chooseDirectory tk::TextSetCursor tk::TextUpDownLine \
1041  tk::PlaceWindow tk::SetFocusGrab tk::RestoreFocusGrab \
1042  tkwait base64::encode base64::decode] {
1043  $interp alias $cmd $cmd
1044  }
1045 
1046  # Specialized Tk commands
1047  foreach cmd [list destroy bind winfo wm image tablelist] {
1048  $interp alias $cmd interpreter::${cmd}_command $pname
1049  }
1050 
1051  # Recursively add all commands that are within the api namespace
1052  foreach pattern [list ::api::* {*}[join [namespace children ::api]::* {::* }]] {
1053  foreach cmd [info commands $pattern] {
1054  if {$cmd ne "::api::ns"} {
1055  $interp alias $cmd $cmd $interp $pname
1056  }
1057  }
1058  }
1059 
1060  # Create TKE command aliases
1061  $interp alias api::register plugins::register
1062  $interp alias api::get_default_foreground utils::get_default_foreground
1063  $interp alias api::get_default_background utils::get_default_background
1064  $interp alias api::color_to_rgb utils::color_to_rgb
1065  $interp alias api::get_complementary_mono_color utils::get_complementary_mono_color
1066  $interp alias api::rgb_to_hsv utils::rgb_to_hsv
1067  $interp alias api::hsv_to_rgb utils::hsv_to_rgb
1068  $interp alias api::rgb_to_hsl utils::rgb_to_hsl
1069  $interp alias api::hsl_to_rgb utils::hsl_to_rgb
1070  $interp alias api::get_color_values utils::get_color_values
1071  $interp alias api::auto_adjust_color utils::auto_adjust_color
1072  $interp alias api::auto_mix_colors utils::auto_mix_colors
1073  $interp alias api::color_difference utils::color_difference
1074  $interp alias api::set_xscrollbar utils::set_xscrollbar
1075  $interp alias api::set_yscrollbar utils::set_yscrollbar
1076  $interp alias api::export utils::export
1077 
1078  # Add ctext calls
1079  $interp alias ctext::getLang ctext::getLang
1080  $interp alias ctext::getNextBracket ctext::getNextBracket
1081  $interp alias ctext::getPrevBracket ctext::getPrevBracket
1082  $interp alias ctext::getMatchBracket ctext::getMatchBracket
1083  $interp alias ctext::getTagInRange ctext::getTagInRange
1084 
1085  return $interp
1086 
1087  }

§ destroy()

interpreter::destroy   pname  

Definition at line 1091 of file interpreter.tcl.

1091  proc destroy {pname} {
1092 
1093  variable interps
1094 
1095  # Destroy any existing windows
1096  foreach win $interps($pname,wins) {
1097  if {[lindex $win 1]} {
1098  catch { ::destroy [lindex $win 0]}
1099  }
1100  }
1101 
1102  # Close any opened files
1103  foreach channel $interps($pname,files) {
1104  catch { close $channel}
1105  }
1106 
1107  # Destroy any images
1108  foreach img $interps($pname,images) {
1109  catch { image delete $img}
1110  }
1111 
1112  # Finally, destroy the interpreter
1113  catch { ::safe::interpDelete $interps($pname,interp)}
1114 
1115  # Destroy the interpreter for the given plugin name
1116  array unset interps $pname,*
1117 
1118  }

§ destroy_command()

interpreter::destroy_command   pname win  

Definition at line 324 of file interpreter.tcl.

324  proc destroy_command {pname win} {
325 
326  variable interps
327 
328  if {[set win_index [lsearch $interps($pname,wins) [list $win 1]]] != -1} {
329  set interps($pname,wins) [lreplace $interps($pname,wins) $win_index $win_index]
330  catch { ::destroy $win}
331  }
332 
333  }

§ encode_file()

interpreter::encode_file   pname fname  

Definition at line 88 of file interpreter.tcl.

88  proc encode_file {pname fname} {
89 
90  variable interps
91 
92  foreach access_dir [lindex [::safe::interpConfigure $interps($pname,interp) -accessPath] 1] {
93  set access_len [string length $access_dir]
94  if {[string compare -length $access_len $access_dir $fname] == 0} {
95  return [file join [::safe::interpFindInAccessPath $interps($pname,interp) $access_dir] [string range $fname [expr $access_len + 1] end]]
96  }
97  }
98 
99  return ""
100 
101  }

§ exec_command()

interpreter::exec_command   pname args  

Definition at line 847 of file interpreter.tcl.

847  proc exec_command {pname args} {
848 
849  variable interps
850 
851  if {![$interps($pname,interp) issafe]} {
852  return [exec {*}$args]
853  } else {
854  return -code error "permission error"
855  }
856 
857  }

§ fconfigure_command()

interpreter::fconfigure_command   pname args  

Definition at line 833 of file interpreter.tcl.

833  proc fconfigure_command {pname args} {
834 
835  variable interps
836 
837  if {[lsearch $interps($pname,files) [lindex $args 0]] != -1} {
838  return [fconfigure {*}$args]
839  } else {
840  return -code error "permission error"
841  }
842 
843  }

§ file_command()

interpreter::file_command   pname subcmd args  

Definition at line 861 of file interpreter.tcl.

861  proc file_command {pname subcmd args} {
862 
863  variable interps
864 
865  switch $subcmd {
866 
867  atime -
868  attributes -
869  exists -
870  executable -
871  isdirectory -
872  isfile -
873  mtime -
874  owned -
875  readable -
876  size -
877  type -
878  writable {
879  if {[set fname [check_file $pname [lindex $args 0]]] eq ""} {
880  return -code error "permission error"
881  }
882  return [file $subcmd $fname {*}[lrange $args 1 end]]
883  }
884 
885  delete -
886  copy -
887  rename {
888  set opts [list]
889  set fnames [list]
890  set double_dash_seen 0
891  foreach arg $args {
892  if {!$double_dash_seen && [string index $arg 0] eq "-"} {
893  if {$arg eq "--"} {
894  set double_dash_seen 1
895  }
896  lappend opts $arg
897  } elseif {[set fname [check_file $pname $arg]] ne ""} {
898  lappend fnames $fname
899  } else {
900  return -code error "permission error"
901  }
902  }
903  return [file $subcmd {*}$opts {*}$fnames]
904  }
905 
906  dirname {
907  if {[set fname [check_file $pname [lindex $args 0]]] eq ""} {
908  return -code error "permission error"
909  }
910  if {[set fname [check_file_access $pname [file dirname $fname]]] eq ""} {
911  return -code error "permission error"
912  }
913  return [encode_file $pname $fname]
914  }
915 
916  mkdir {
917  set dnames [list]
918  foreach arg $args {
919  if {[set dname [check_file $pname $arg]] ne ""} {
920  lappend dnames $dname
921  }
922  }
923  if {[llength $dnames] > 0} {
924  return [file mkdir {*}$dnames]
925  } else {
926  return -code error "permission error"
927  }
928  }
929 
930  join -
931  extension -
932  rootname -
933  tail -
934  separator -
935  split {
936  return [file $subcmd {*}$args]
937  }
938 
939  default {
940  if {![$interps($pname,interp) issafe]} {
941  return [file $subcmd {*}$args]
942  }
943  return -code error "file command $subcmd is not allowed by a plugin"
944  }
945  }
946 
947  }

§ flush_command()

interpreter::flush_command   pname channel  

Definition at line 779 of file interpreter.tcl.

779  proc flush_command {pname channel} {
780 
781  variable interps
782 
783  if {[lsearch $interps($pname,files) $channel] != -1} {
784  flush $channel
785  } else {
786  return -code error "permission error"
787  }
788 
789  }

§ glob_command()

interpreter::glob_command   pname args  

Definition at line 951 of file interpreter.tcl.

951  proc glob_command {pname args} {
952 
953  variable interps
954 
955  set i 0
956  set new_args [list]
957 
958  # Parse the options
959  while {$i < [llength $args]} {
960  switch -exact [set opt [lindex $args $i]] {
961  -directory -
962  -path {
963  if {[set dname [check_file $pname [lindex $args [incr i]]]] eq ""} {
964  return -code error "permission error"
965  }
966  lappend new_args $opt $dname
967  }
968  default {
969  lappend new_args $opt
970  }
971  }
972  incr i
973  }
974 
975  # Encode the returned filenames
976  set fnames [list]
977  foreach fname [glob {*}$new_args] {
978  if {[set ename [encode_file $pname $fname]] eq ""} {
979  lappend fnames $fname
980  } else {
981  lappend fnames $ename
982  }
983  }
984 
985  return $fnames
986 
987  }

§ image_command()

interpreter::image_command   pname subcmd args  

Definition at line 441 of file interpreter.tcl.

441  proc image_command {pname subcmd args} {
442 
443  variable interps
444 
445  switch $subcmd {
446 
447  create {
448 
449  # Find any -file or -maskfile options and convert the filename and check it
450  set i 0
451  while {$i < [llength $args]} {
452  switch [lindex $args $i] {
453  -file -
454  -maskfile {
455  if {[set fname [check_file $pname [lindex $args [incr i]]]] eq ""} {
456  return -error code "permission error"
457  }
458  lset args $i $fname
459  }
460  }
461  incr i
462  }
463 
464  # Create the image
465  set img [image create {*}$args]
466 
467  # Create an alias for the image so that it can be used in cget/configure calls
468  $interps($pname,interp) alias $img interpreter::image_win $pname $img
469 
470  # Hang onto the generated image
471  lappend interps($pname,images) $img
472 
473  return $img
474 
475  }
476 
477  delete {
478 
479  foreach name $args {
480  if {[set img_index [lsearch $interps($pname,images) $name]] != -1} {
481  set interps($pname,images) [lreplace $interps($pname,images) $img_index $img_index]
482  image delete $name
483  }
484  }
485 
486  }
487 
488  default {
489 
490  return [image $subcmd {*}$args]
491 
492  }
493 
494  }
495 
496  }

§ image_win()

interpreter::image_win   pname img cmd args  

Definition at line 500 of file interpreter.tcl.

500  proc image_win {pname img cmd args} {
501 
502  variable interps
503 
504  # Probably unnecessary, but it can't hurt to check that the image is part of this plugin
505  if {[lsearch $interps($pname,images) $img] == -1} {
506  return -code error "permission error"
507  }
508 
509  switch $cmd {
510 
511  cget {
512 
513  switch [lindex $args 0] {
514  -file -
515  -maskfile {
516  set fname [$img cget [lindex $args 0]]
517  return [encode_file $pname $fname]
518  }
519  }
520 
521  }
522 
523  configure {
524 
525  set i 0
526  while {$i < [llength $args]} {
527  switch [lindex $args $i] {
528  -file -
529  -maskfile {
530  if {[set fname [check_file $pname [lindex $args [incr i]]]] eq ""} {
531  return -code error "permission error"
532  }
533  lset args $i $fname
534  }
535  }
536  incr i
537  }
538 
539  return [$img configure {*}$args]
540 
541  }
542 
543  }
544 
545  }

§ open_command()

interpreter::open_command   pname fname args  

Definition at line 741 of file interpreter.tcl.

741  proc open_command {pname fname args} {
742 
743  variable interps
744 
745  # Make sure that the given filename is valid
746  if {[set fname [check_file $pname $fname]] eq ""} {
747  return -code error "permission error"
748  }
749 
750  # Open the file
751  if {[catch { open $fname {*}$args} rc]} {
752  return -code error $rc
753  }
754 
755  # Save the file descriptor
756  lappend interps($pname,files) $rc
757 
758  return $rc
759 
760  }

§ puts_command()

interpreter::puts_command   pname args  

Definition at line 813 of file interpreter.tcl.

813  proc puts_command {pname args} {
814 
815  variable interps
816 
817  if {[lindex $args 0] eq "-nonewline"} {
818  set channel [lindex $args 1]
819  } else {
820  set channel [lindex $args 0]
821  }
822 
823  if {[lsearch $interps($pname,files) $channel] != -1} {
824  puts {*}$args
825  } else {
826  return -code error "permission error"
827  }
828 
829  }

§ read_command()

interpreter::read_command   pname args  

Definition at line 793 of file interpreter.tcl.

793  proc read_command {pname args} {
794 
795  variable interps
796 
797  if {[lindex $args 0] eq "-nonewline"} {
798  set channel [lindex $args 1]
799  } else {
800  set channel [lindex $args 0]
801  }
802 
803  if {[lsearch $interps($pname,files) $channel] != -1} {
804  return [read {*}$args]
805  } else {
806  return -code error "permission error"
807  }
808 
809  }

§ set_variable()

interpreter::set_variable   pname varname name1 name2 op  

Definition at line 164 of file interpreter.tcl.

164  proc set_variable {pname varname name1 name2 op} {
165 
166  variable interps
167 
168  $interps($pname,interp) eval [list set $varname $interps($name2)]
169 
170  }

§ tablelist_command()

interpreter::tablelist_command   pname win args  

Definition at line 549 of file interpreter.tcl.

549  proc tablelist_command {pname win args} {
550 
551  variable interps
552 
553  set command_args [list \
554  -xscrollcommand -yscrollcommand -acceptchildcommand -acceptdropcommand -collapsecommand \
555  -colorizecommand -editstartcommand -editendcommand -expandcommand -forceeditendcommand \
556  -labelcommand -labelcommand2 -populatecommand -sortcommand -tooltipaddcommand \
557  -tooltipdelcommand]
558  set variable_args [list -variable -textvariable]
559 
560  # Substitute any commands with the appropriate interpreter eval statement
561  set opts [list]
562  foreach {opt value} $args {
563  if {[lsearch $command_args $opt] != -1} {
564  set value [list $interps($pname,interp) eval $value]
565  }
566  if {[lsearch $variable_args $opt] != -1} {
567  set interps($pname,var,$value) [$interps($pname,interp) eval [list set $value]]
568  trace variable interpreter::interps($pname,var,$value) w [list interpreter::set_variable $pname $value]
569  set value "interpreter::interps($pname,var,$value)"
570  }
571  lappend opts $opt $value
572  }
573 
574  # Create the widget
575  tablelist::tablelist $win {*}$opts
576 
577  # Allow the interpreter to do things with the element
578  $interps($pname,interp) alias $win interpreter::tablelist_win $pname $win
579 
580  # Record the widget
581  lappend interps($pname,wins) [list $win 1]
582 
583  return $win
584 
585  }

§ tablelist_do()

interpreter::tablelist_do   pname cmd args  

Definition at line 731 of file interpreter.tcl.

731  proc tablelist_do {pname cmd args} {
732 
733  variable interps
734 
735  return [$interps($pname,interp) eval [list {*}$cmd {*}$args]]
736 
737  }

§ tablelist_win()

interpreter::tablelist_win   pname win cmd args  

Definition at line 589 of file interpreter.tcl.

589  proc tablelist_win {pname win cmd args} {
590 
591  variable interps
592 
593  set command_args {
594  -xscrollcommand -yscrollcommand -acceptchildcommand -acceptdropcommand -collapsecommand
595  -colorizecommand -editstartcommand -editendcommand -expandcommand -forceeditendcommand
596  -labelcommand -labelcommand2 -populatecommand -sortcommand -tooltipaddcommand
597  -tooltipdelcommand
598  }
599 
600  set tbl_commands {
601  -formatcommand -labelcommand -labelcommand2 -sortcommand -window -windowdestroy -windowupdate
602  }
603 
604  switch $cmd {
605 
606  cget {
607  set opt [lindex $args 0]
608  if {[lsearch $command_args $opt] != -1} {
609  return [lindex [$win cget $opt] 2]
610  } else {
611  return [$win cget $opt]
612  }
613  }
614 
615  configure {
616  set retval [list]
617  switch [llength $args] {
618  0 {
619  foreach opt [$win configure] {
620  if {[lsearch $command_args [lindex $opt 0]] != -1} {
621  lset opt 4 [lindex [lindex $opt 4] 2]
622  }
623  lappend retval $opt
624  }
625  return $retval
626  }
627  1 {
628  set opt [lindex $args 0]
629  set retval [$win configure $opt]
630  if {[lsearch $command_args $opt] != -1} {
631  lset retval 4 [lrange [lindex $retval 4] 2 end]
632  }
633  return $retval
634  }
635  default {
636  foreach {opt value} $args {
637  if {[lsearch $command_args $opt] != -1} {
638  set value [list interpreter::tablelist_do $pname $value]
639  }
640  lappend retval $opt $value
641  }
642  return [$win configure {*}$retval]
643  }
644  }
645  }
646 
647  cellcget -
648  columncget {
649  lassign $args key opt
650  if {[lsearch $command_args $opt] != -1} {
651  return [lindex [$win $cmd $key $opt] 2]
652  } else {
653  return [$win $cmd $key $opt]
654  }
655 
656  }
657 
658  cellconfigure -
659  columnconfigure {
660  set retval [list]
661  set args [lassign $args key]
662  switch [llength $args] {
663  0 {
664  foreach opt [$win $cmd $key] {
665  if {[lsearch $tbl_commands [lindex $opt 0]] != -1} {
666  lset opt 4 [lindex [lindex $opt 4] 2]
667  }
668  lappend retval $opt
669  }
670  return $retval
671  }
672  1 {
673  set opt [lindex $args 0]
674  set retval [$win $cmd $key $opt]
675  if {[lsearch $tbl_commands $opt] != -1} {
676  lset retval 4 [lindex [lindex $retval 4] 2]
677  }
678  return $retval
679  }
680  default {
681  foreach {opt value} $args {
682  if {[lsearch $tbl_commands $opt] != -1} {
683  set value [list interpreter::tablelist_do $pname $value]
684  } elseif {($opt eq "-text") && [winfo exists [$win windowpath $key].ckbtn]} {
685  set [[$win windowpath $key].ckbtn cget -variable] $value
686  }
687  lappend retval $opt $value
688  }
689  return [$win $cmd $key {*}$retval]
690  }
691  }
692  }
693 
694  embedcheckbutton -
695  embedcheckbuttons -
696  embedttkcheckbutton -
697  embedttkcheckbuttons {
698  if {[llength $args] == 2} {
699  $win $cmd [lindex $args 0] [list interpreter::tablelist_do $pname [lindex $args 1]]
700  } else {
701  $win $cmd [lindex $args 0]
702  }
703  }
704 
705  header {
706  set args [lassign $args subcmd]
707  switch $subcmd {
708  embedcheckbutton -
709  embedcheckbuttons -
710  embedttkcheckbutton -
711  embedttkcheckbuttons {
712  if {[llength $args] == 2} {
713  $win header $subcmd [lindex $args 0] [list interpreter::tablelist_do $pname [lindex $args 1]]
714  } else {
715  $win header $subcmd [lindex $args 0]
716  }
717  }
718  }
719  }
720 
721  default {
722  return [$win $cmd {*}$args]
723  }
724  }
725 
726  }

§ widget_command()

interpreter::widget_command   pname widget win args  

Definition at line 121 of file interpreter.tcl.

121  proc widget_command {pname widget win args} {
122 
123  variable interps
124 
125  set command_args [list \
126  -command -postcommand -validatecommand -invalidcommand -xscrollcommand \
127  -yscrollcommand -acceptchildcommand -acceptdropcommand -collapsecommand \
128  -colorizecommand -editstartcommand -editendcommand -expandcommand -forceeditendcommand \
129  -labelcommand -labelcommand2 -populatecommand -sortcommand -tooltipaddcommand \
130  -tooltipdelcommand]
131  set variable_args [list -variable -textvariable]
132 
133  # Substitute any commands with the appropriate interpreter eval statement
134  set opts [list]
135  foreach {opt value} $args {
136  if {[lsearch $command_args $opt] != -1} {
137  set value [list $interps($pname,interp) eval $value]
138  }
139  if {[lsearch $variable_args $opt] != -1} {
140  set interps($pname,var,$value) [$interps($pname,interp) eval [list set $value]]
141  trace variable interpreter::interps($pname,var,$value) w [list interpreter::set_variable $pname $value]
142  set value "interpreter::interps($pname,var,$value)"
143  }
144  lappend opts $opt $value
145  }
146 
147  # Create the widget
148  $widget $win {*}$opts
149 
150  # Allow the interpreter to do things with the element
151  $interps($pname,interp) alias $win interpreter::widget_win $pname $win
152 
153  # Record the widget
154  lappend interps($pname,wins) [list $win 1]
155 
156  return $win
157 
158  }

§ widget_win()

interpreter::widget_win   pname win cmd args  

Definition at line 174 of file interpreter.tcl.

174  proc widget_win {pname win cmd args} {
175 
176  variable interps
177 
178  set command_args {
179  -command -postcommand -validatecommand -invalidcommand -xscrollcommand
180  -yscrollcommand
181  }
182 
183  switch $cmd {
184 
185  cget {
186  set opt [lindex $args 0]
187  if {[lsearch $command_args $opt] != -1} {
188  return [lrange [$win cget $opt] 2 end]
189  } else {
190  return [$win cget $opt]
191  }
192  }
193 
194  entrycget {
195  lassign $args entry_index opt
196  if {[lsearch $command_args $opt] != -1} {
197  return [lrange [$win entrycget $entry_index $opt] 2 end]
198  } else {
199  return [$win entrycget $entry_index $opt]
200  }
201  }
202 
203  configure {
204  set retval [list]
205  switch [llength $args] {
206  0 {
207  foreach opt [$win configure] {
208  if {[lsearch $command_args [lindex $opt 0]] != -1} {
209  lset opt 4 [lrange [lindex $opt 4] 2 end]
210  }
211  lappend retval $opt
212  }
213  return $retval
214  }
215  1 {
216  set opt [lindex $args 0]
217  set retval [$win configure $opt]
218  if {[lsearch $command_args $opt] != -1} {
219  lset retval 4 [lrange [lindex $retval 4] 2 end]
220  }
221  return $retval
222  }
223  default {
224  foreach {opt value} $args {
225  if {[lsearch $command_args $opt] != -1} {
226  set value [list $interps($pname,interp) eval $value]
227  }
228  lappend retval $opt $value
229  }
230  return [$win configure {*}$retval]
231  }
232  }
233  }
234 
235  entryconfigure {
236  set retval [list]
237  set args [lassign $args entry_index]
238  switch [llength $args] {
239  0 {
240  foreach opt [$win entryconfigure $entry_index] {
241  if {[lsearch $command_args [lindex $opt 0]] != -1} {
242  lset opt 4 [lrange [lindex $opt 4] 2 end]
243  }
244  lappend retval $opt
245  }
246  return $retval
247  }
248  1 {
249  set opt [lindex $args 0]
250  set retval [$win entryconfigure $entry_index $opt]
251  if {[lsearch $command_args $opt] != -1} {
252  lset retval 4 [lrange [lindex $retval 4] 2 end]
253  }
254  return $retval
255  }
256  default {
257  foreach {opt value} $args {
258  if {[lsearch $command_args $opt] != -1} {
259  set value [list $interps($pname,interp) eval $value]
260  }
261  lappend retval $opt $value
262  }
263  return [$win entryconfigure $entry_index {*}$retval]
264  }
265  }
266  }
267 
268  add {
269  # Handle adding commands to menus
270  set args [lassign $args retval]
271  foreach {opt value} $args {
272  if {[lsearch $command_args $opt] != -1} {
273  set value [list $interps($pname,interp) eval $value]
274  }
275  lappend retval $opt $value
276  }
277  return [$win add {*}$retval]
278  }
279 
280  search {
281  if {[set index [lsearch $args -count]] != -1} {
282  set count_name [lindex $args [expr $index + 1]]
283  set search_lengths [list]
284  lset args [expr $index + 1] search_lengths
285  set retval [$win search {*}$args]
286  $interps($pname,interp) eval [list set $count_name $search_lengths]
287  return $retval
288  } else {
289  return [$win search {*}$args]
290  }
291  }
292 
293  tag {
294  # Handle adding bindings to text/ctext widgets
295  set args [lassign $args subcmd]
296  if {$subcmd eq "bind"} {
297  switch [llength $args] {
298  3 {
299  if {[string index [lindex $args end] 0] == "+"} {
300  return [$win tag bind {*}[lrange $args 0 end-1] [list +$interps($pname,interp) eval {*}[lindex $args end]]]
301  } else {
302  return [$win tag bind {*}[lrange $args 0 end-1] [list $interps($pname,interp) eval {*}[lindex $args end]]]
303  }
304  }
305  default {
306  return [$win tag bind {*}$args]
307  }
308  }
309  } else {
310  return [$win tag $subcmd {*}$args]
311  }
312  }
313 
314  default {
315  return [$win $cmd {*}$args]
316  }
317  }
318 
319  }

§ winfo_command()

interpreter::winfo_command   pname subcmd args  

Definition at line 356 of file interpreter.tcl.

356  proc winfo_command {pname subcmd args} {
357 
358  variable interps
359 
360  switch $subcmd {
361  atom -
362  atomname -
363  cells -
364  children -
365  class -
366  colormapfull -
367  depth -
368  exists -
369  fpixels -
370  geometry -
371  height -
372  id -
373  ismapped -
374  manager -
375  name -
376  pixels -
377  pointerx -
378  pointerxy -
379  pointery -
380  reqheight -
381  reqwidth -
382  rgb -
383  rootx -
384  rooty -
385  screen -
386  screencells -
387  screendepth -
388  screenheight -
389  screenmmheight -
390  screenmmwidth -
391  screenvisual -
392  screenwidth -
393  viewable -
394  visual -
395  visualsavailable -
396  vrootheight -
397  vrootwidth -
398  vrootx -
399  vrooty -
400  width -
401  x -
402  y {
403  #if {[lsearch -index 0 $interps($pname,wins) [lindex $args 0]] == -1} {
404  # return -code error "permission error"
405  #}
406  return [winfo $subcmd {*}$args]
407  }
408  containing -
409  parent -
410  pathname -
411  toplevel {
412  set win [winfo $subcmd {*}$args]
413  #if {[lsearch -index 0 $interps($pname,wins) $win] == -1} {
414  # return -code error "permission error"
415  #}
416  return $win
417  }
418  default {
419  return -code error "permission error"
420  }
421  }
422 
423  }

§ wm_command()

interpreter::wm_command   pname subcmd win args  

Definition at line 427 of file interpreter.tcl.

427  proc wm_command {pname subcmd win args} {
428 
429  variable interps
430 
431  if {[lsearch $interps($pname,wins) [list $win 1]] != -1} {
432  return [wm $subcmd $win {*}$args]
433  } else {
434  return ""
435  }
436 
437  }