00001 # TKE - Advanced Programmer's Editor 00002 # Copyright (C) 2014-2019 Trevor Williams (phase1geo@gmail.com) 00003 # 00004 # This program is free software; you can redistribute it and/or modify 00005 # it under the terms of the GNU General Public License as published by 00006 # the Free Software Foundation; either version 2 of the License, or 00007 # (at your option) any later version. 00008 # 00009 # This program is distributed in the hope that it will be useful, 00010 # but WITHOUT ANY WARRANTY; without even the implied warranty of 00011 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 00012 # GNU General Public License for more details. 00013 # 00014 # You should have received a copy of the GNU General Public License along 00015 # with this program; if not, write to the Free Software Foundation, Inc., 00016 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. 00017 00018 ###################################################################### 00019 # Name: interpreter.tcl 00020 # Author: Trevor Williams (phase1geo@gmail.com) 00021 # Date: 8/1/2014 00022 # Brief: Namespace to support a plugin interpreter. 00023 ###################################################################### 00024 00025 namespace eval interpreter { 00026 00027 array set interps {} 00028 00029 ###################################################################### 00030 # Check the given file's accessibility (the file should be translated 00031 # prior to calling this procedure). 00032 proc check_file_access {pname fname} { 00033 00034 variable interps 00035 00036 if {[$interps($pname,interp) issafe]} { 00037 00038 # Normalize the file name 00039 set fname [file normalize $fname] 00040 00041 # Verify that the directory is within the access paths 00042 foreach access_dir [lindex [::safe::interpConfigure $interps($pname,interp) -accessPath] 1] { 00043 if {[string compare -length [string length $access_dir] $access_dir $fname] == 0} { 00044 return $fname 00045 } 00046 } 00047 00048 return "" 00049 00050 } else { 00051 00052 return $fname 00053 00054 } 00055 00056 } 00057 00058 ###################################################################### 00059 # Checks to make sure that the given directory is within the allowed 00060 # directory paths. Returns the name of the file if the directory is 00061 # okay to process; otherwise, returns the empty string. 00062 proc check_file {pname fname} { 00063 00064 variable interps 00065 00066 # We only need to check the file if we are in safe mode. 00067 if {[$interps($pname,interp) issafe]} { 00068 00069 # Translate the directory 00070 if {[catch {::safe::TranslatePath $interps($pname,interp) $fname} fname]} { 00071 return "" 00072 } 00073 00074 return [check_file_access $pname $fname] 00075 00076 } else { 00077 00078 return $fname 00079 00080 } 00081 00082 } 00083 00084 ###################################################################### 00085 # Encodes the given filename, replacing the lower portion of the filename 00086 # with the appropriate encoded symbol which matches a value in the safe 00087 # interpreter directory list. 00088 proc encode_file {pname fname} { 00089 00090 variable interps 00091 00092 foreach access_dir [lindex [::safe::interpConfigure $interps($pname,interp) -accessPath] 1] { 00093 set access_len [string length $access_dir] 00094 if {[string compare -length $access_len $access_dir $fname] == 0} { 00095 return [file join [::safe::interpFindInAccessPath $interps($pname,interp) $access_dir] [string range $fname [expr $access_len + 1] end]] 00096 } 00097 } 00098 00099 return "" 00100 00101 } 00102 00103 ###################################################################### 00104 # Adds a ctext widget to the list of wins (however, destroying the 00105 # interpreter will not destroy the ctext widgets). 00106 proc add_ctext {interp pname txt} { 00107 00108 variable interps 00109 00110 # Remember the text widget 00111 lappend interps($pname,wins) [list $txt 0] [list $txt.t 0] 00112 00113 # Create the alias 00114 $interp alias $txt interpreter::widget_win $pname $txt 00115 $interp alias $txt.t interpreter::widget_win $pname $txt.t 00116 00117 } 00118 00119 ###################################################################### 00120 # Creates a widget on behalf of the plugin, records and returns its value. 00121 proc widget_command {pname widget win args} { 00122 00123 variable interps 00124 00125 set command_args [list \ 00126 -command -postcommand -validatecommand -invalidcommand -xscrollcommand \ 00127 -yscrollcommand -acceptchildcommand -acceptdropcommand -collapsecommand \ 00128 -colorizecommand -editstartcommand -editendcommand -expandcommand -forceeditendcommand \ 00129 -labelcommand -labelcommand2 -populatecommand -sortcommand -tooltipaddcommand \ 00130 -tooltipdelcommand \ 00131 ] 00132 set variable_args [list -variable -textvariable] 00133 00134 # Substitute any commands with the appropriate interpreter eval statement 00135 set opts [list] 00136 foreach {opt value} $args { 00137 if {[lsearch $command_args $opt] != -1} { 00138 set value [list $interps($pname,interp) eval $value] 00139 } 00140 if {[lsearch $variable_args $opt] != -1} { 00141 set interps($pname,var,$value) [$interps($pname,interp) eval [list set $value]] 00142 trace variable interpreter::interps($pname,var,$value) w [list interpreter::set_variable $pname $value] 00143 set value "interpreter::interps($pname,var,$value)" 00144 } 00145 lappend opts $opt $value 00146 } 00147 00148 # Create the widget 00149 $widget $win {*}$opts 00150 00151 # Allow the interpreter to do things with the element 00152 $interps($pname,interp) alias $win interpreter::widget_win $pname $win 00153 00154 # Record the widget 00155 lappend interps($pname,wins) [list $win 1] 00156 00157 return $win 00158 00159 } 00160 00161 ###################################################################### 00162 # Called whenever the variable changes -- updates the matching variable 00163 # in the plugin interpreter. 00164 proc set_variable {pname varname name1 name2 op} { 00165 00166 variable interps 00167 00168 $interps($pname,interp) eval [list set $varname $interps($name2)] 00169 00170 } 00171 00172 ###################################################################### 00173 # Handles any widget calls to cget/configure commands. 00174 proc widget_win {pname win cmd args} { 00175 00176 variable interps 00177 00178 set command_args { 00179 -command -postcommand -validatecommand -invalidcommand -xscrollcommand 00180 -yscrollcommand 00181 } 00182 00183 switch $cmd { 00184 00185 cget { 00186 set opt [lindex $args 0] 00187 if {[lsearch $command_args $opt] != -1} { 00188 return [lrange [$win cget $opt] 2 end] 00189 } else { 00190 return [$win cget $opt] 00191 } 00192 } 00193 00194 entrycget { 00195 lassign $args entry_index opt 00196 if {[lsearch $command_args $opt] != -1} { 00197 return [lrange [$win entrycget $entry_index $opt] 2 end] 00198 } else { 00199 return [$win entrycget $entry_index $opt] 00200 } 00201 } 00202 00203 configure { 00204 set retval [list] 00205 switch [llength $args] { 00206 0 { 00207 foreach opt [$win configure] { 00208 if {[lsearch $command_args [lindex $opt 0]] != -1} { 00209 lset opt 4 [lrange [lindex $opt 4] 2 end] 00210 } 00211 lappend retval $opt 00212 } 00213 return $retval 00214 } 00215 1 { 00216 set opt [lindex $args 0] 00217 set retval [$win configure $opt] 00218 if {[lsearch $command_args $opt] != -1} { 00219 lset retval 4 [lrange [lindex $retval 4] 2 end] 00220 } 00221 return $retval 00222 } 00223 default { 00224 foreach {opt value} $args { 00225 if {[lsearch $command_args $opt] != -1} { 00226 set value [list $interps($pname,interp) eval $value] 00227 } 00228 lappend retval $opt $value 00229 } 00230 return [$win configure {*}$retval] 00231 } 00232 } 00233 } 00234 00235 entryconfigure { 00236 set retval [list] 00237 set args [lassign $args entry_index] 00238 switch [llength $args] { 00239 0 { 00240 foreach opt [$win entryconfigure $entry_index] { 00241 if {[lsearch $command_args [lindex $opt 0]] != -1} { 00242 lset opt 4 [lrange [lindex $opt 4] 2 end] 00243 } 00244 lappend retval $opt 00245 } 00246 return $retval 00247 } 00248 1 { 00249 set opt [lindex $args 0] 00250 set retval [$win entryconfigure $entry_index $opt] 00251 if {[lsearch $command_args $opt] != -1} { 00252 lset retval 4 [lrange [lindex $retval 4] 2 end] 00253 } 00254 return $retval 00255 } 00256 default { 00257 foreach {opt value} $args { 00258 if {[lsearch $command_args $opt] != -1} { 00259 set value [list $interps($pname,interp) eval $value] 00260 } 00261 lappend retval $opt $value 00262 } 00263 return [$win entryconfigure $entry_index {*}$retval] 00264 } 00265 } 00266 } 00267 00268 add { 00269 # Handle adding commands to menus 00270 set args [lassign $args retval] 00271 foreach {opt value} $args { 00272 if {[lsearch $command_args $opt] != -1} { 00273 set value [list $interps($pname,interp) eval $value] 00274 } 00275 lappend retval $opt $value 00276 } 00277 return [$win add {*}$retval] 00278 } 00279 00280 search { 00281 if {[set index [lsearch $args -count]] != -1} { 00282 set count_name [lindex $args [expr $index + 1]] 00283 set search_lengths [list] 00284 lset args [expr $index + 1] search_lengths 00285 set retval [$win search {*}$args] 00286 $interps($pname,interp) eval [list set $count_name $search_lengths] 00287 return $retval 00288 } else { 00289 return [$win search {*}$args] 00290 } 00291 } 00292 00293 tag { 00294 # Handle adding bindings to text/ctext widgets 00295 set args [lassign $args subcmd] 00296 if {$subcmd eq "bind"} { 00297 switch [llength $args] { 00298 3 { 00299 if {[string index [lindex $args end] 0] == "+"} { 00300 return [$win tag bind {*}[lrange $args 0 end-1] [list +$interps($pname,interp) eval {*}[lindex $args end]]] 00301 } else { 00302 return [$win tag bind {*}[lrange $args 0 end-1] [list $interps($pname,interp) eval {*}[lindex $args end]]] 00303 } 00304 } 00305 default { 00306 return [$win tag bind {*}$args] 00307 } 00308 } 00309 } else { 00310 return [$win tag $subcmd {*}$args] 00311 } 00312 } 00313 00314 default { 00315 return [$win $cmd {*}$args] 00316 } 00317 } 00318 00319 } 00320 00321 ###################################################################### 00322 # Destroys the specified widget (if it was created by the interpreter 00323 # specified by pname). 00324 proc destroy_command {pname win} { 00325 00326 variable interps 00327 00328 if {[set win_index [lsearch $interps($pname,wins) [list $win 1]]] != -1} { 00329 set interps($pname,wins) [lreplace $interps($pname,wins) $win_index $win_index] 00330 catch { ::destroy $win } 00331 } 00332 00333 } 00334 00335 ###################################################################### 00336 # Binds an event to a widget owned by the slave interpreter. 00337 proc bind_command {pname tag args} { 00338 00339 variable interps 00340 00341 switch [llength $args] { 00342 1 { return [bind $tag [lindex $args 0]] } 00343 2 { 00344 if {[string index [lindex $args 1] 0] eq "+"} { 00345 return [bind $tag [lindex $args 0] [list +interp eval $interps($pname,interp) {*}[lrange [lindex $args 1] 1 end]]] 00346 } else { 00347 return [bind $tag [lindex $args 0] [list interp eval $interps($pname,interp) {*}[lindex $args 1]]] 00348 } 00349 } 00350 } 00351 00352 } 00353 00354 ###################################################################### 00355 # Executes a safe winfo command. 00356 proc winfo_command {pname subcmd args} { 00357 00358 variable interps 00359 00360 switch $subcmd { 00361 atom - 00362 atomname - 00363 cells - 00364 children - 00365 class - 00366 colormapfull - 00367 depth - 00368 exists - 00369 fpixels - 00370 geometry - 00371 height - 00372 id - 00373 ismapped - 00374 manager - 00375 name - 00376 pixels - 00377 pointerx - 00378 pointerxy - 00379 pointery - 00380 reqheight - 00381 reqwidth - 00382 rgb - 00383 rootx - 00384 rooty - 00385 screen - 00386 screencells - 00387 screendepth - 00388 screenheight - 00389 screenmmheight - 00390 screenmmwidth - 00391 screenvisual - 00392 screenwidth - 00393 viewable - 00394 visual - 00395 visualsavailable - 00396 vrootheight - 00397 vrootwidth - 00398 vrootx - 00399 vrooty - 00400 width - 00401 x - 00402 y { 00403 #if {[lsearch -index 0 $interps($pname,wins) [lindex $args 0]] == -1} { 00404 # return -code error "permission error" 00405 #} 00406 return [winfo $subcmd {*}$args] 00407 } 00408 containing - 00409 parent - 00410 pathname - 00411 toplevel { 00412 set win [winfo $subcmd {*}$args] 00413 #if {[lsearch -index 0 $interps($pname,wins) $win] == -1} { 00414 # return -code error "permission error" 00415 #} 00416 return $win 00417 } 00418 default { 00419 return -code error "permission error" 00420 } 00421 } 00422 00423 } 00424 00425 ###################################################################### 00426 # Executes a safe wm command. 00427 proc wm_command {pname subcmd win args} { 00428 00429 variable interps 00430 00431 if {[lsearch $interps($pname,wins) [list $win 1]] != -1} { 00432 return [wm $subcmd $win {*}$args] 00433 } else { 00434 return "" 00435 } 00436 00437 } 00438 00439 ###################################################################### 00440 # Executes a safe image command. 00441 proc image_command {pname subcmd args} { 00442 00443 variable interps 00444 00445 switch $subcmd { 00446 00447 create { 00448 00449 # Find any -file or -maskfile options and convert the filename and check it 00450 set i 0 00451 while {$i < [llength $args]} { 00452 switch [lindex $args $i] { 00453 -file - 00454 -maskfile { 00455 if {[set fname [check_file $pname [lindex $args [incr i]]]] eq ""} { 00456 return -error code "permission error" 00457 } 00458 lset args $i $fname 00459 } 00460 } 00461 incr i 00462 } 00463 00464 # Create the image 00465 set img [image create {*}$args] 00466 00467 # Create an alias for the image so that it can be used in cget/configure calls 00468 $interps($pname,interp) alias $img interpreter::image_win $pname $img 00469 00470 # Hang onto the generated image 00471 lappend interps($pname,images) $img 00472 00473 return $img 00474 00475 } 00476 00477 delete { 00478 00479 foreach name $args { 00480 if {[set img_index [lsearch $interps($pname,images) $name]] != -1} { 00481 set interps($pname,images) [lreplace $interps($pname,images) $img_index $img_index] 00482 image delete $name 00483 } 00484 } 00485 00486 } 00487 00488 default { 00489 00490 return [image $subcmd {*}$args] 00491 00492 } 00493 00494 } 00495 00496 } 00497 00498 ###################################################################### 00499 # Handles a call to manipulate the image. 00500 proc image_win {pname img cmd args} { 00501 00502 variable interps 00503 00504 # Probably unnecessary, but it can't hurt to check that the image is part of this plugin 00505 if {[lsearch $interps($pname,images) $img] == -1} { 00506 return -code error "permission error" 00507 } 00508 00509 switch $cmd { 00510 00511 cget { 00512 00513 switch [lindex $args 0] { 00514 -file - 00515 -maskfile { 00516 set fname [$img cget [lindex $args 0]] 00517 return [encode_file $pname $fname] 00518 } 00519 } 00520 00521 } 00522 00523 configure { 00524 00525 set i 0 00526 while {$i < [llength $args]} { 00527 switch [lindex $args $i] { 00528 -file - 00529 -maskfile { 00530 if {[set fname [check_file $pname [lindex $args [incr i]]]] eq ""} { 00531 return -code error "permission error" 00532 } 00533 lset args $i $fname 00534 } 00535 } 00536 incr i 00537 } 00538 00539 return [$img configure {*}$args] 00540 00541 } 00542 00543 } 00544 00545 } 00546 00547 ###################################################################### 00548 # Handles the creation of a tablelist command. 00549 proc tablelist_command {pname win args} { 00550 00551 variable interps 00552 00553 set command_args [list \ 00554 -xscrollcommand -yscrollcommand -acceptchildcommand -acceptdropcommand -collapsecommand \ 00555 -colorizecommand -editstartcommand -editendcommand -expandcommand -forceeditendcommand \ 00556 -labelcommand -labelcommand2 -populatecommand -sortcommand -tooltipaddcommand \ 00557 -tooltipdelcommand \ 00558 ] 00559 set variable_args [list -variable -textvariable] 00560 00561 # Substitute any commands with the appropriate interpreter eval statement 00562 set opts [list] 00563 foreach {opt value} $args { 00564 if {[lsearch $command_args $opt] != -1} { 00565 set value [list $interps($pname,interp) eval $value] 00566 } 00567 if {[lsearch $variable_args $opt] != -1} { 00568 set interps($pname,var,$value) [$interps($pname,interp) eval [list set $value]] 00569 trace variable interpreter::interps($pname,var,$value) w [list interpreter::set_variable $pname $value] 00570 set value "interpreter::interps($pname,var,$value)" 00571 } 00572 lappend opts $opt $value 00573 } 00574 00575 # Create the widget 00576 tablelist::tablelist $win {*}$opts 00577 00578 # Allow the interpreter to do things with the element 00579 $interps($pname,interp) alias $win interpreter::tablelist_win $pname $win 00580 00581 # Record the widget 00582 lappend interps($pname,wins) [list $win 1] 00583 00584 return $win 00585 00586 } 00587 00588 ###################################################################### 00589 proc tablelist_win {pname win cmd args} { 00590 00591 variable interps 00592 00593 set command_args { 00594 -xscrollcommand -yscrollcommand -acceptchildcommand -acceptdropcommand -collapsecommand 00595 -colorizecommand -editstartcommand -editendcommand -expandcommand -forceeditendcommand 00596 -labelcommand -labelcommand2 -populatecommand -sortcommand -tooltipaddcommand 00597 -tooltipdelcommand 00598 } 00599 00600 set tbl_commands { 00601 -formatcommand -labelcommand -labelcommand2 -sortcommand -window -windowdestroy -windowupdate 00602 } 00603 00604 switch $cmd { 00605 00606 cget { 00607 set opt [lindex $args 0] 00608 if {[lsearch $command_args $opt] != -1} { 00609 return [lindex [$win cget $opt] 2] 00610 } else { 00611 return [$win cget $opt] 00612 } 00613 } 00614 00615 configure { 00616 set retval [list] 00617 switch [llength $args] { 00618 0 { 00619 foreach opt [$win configure] { 00620 if {[lsearch $command_args [lindex $opt 0]] != -1} { 00621 lset opt 4 [lindex [lindex $opt 4] 2] 00622 } 00623 lappend retval $opt 00624 } 00625 return $retval 00626 } 00627 1 { 00628 set opt [lindex $args 0] 00629 set retval [$win configure $opt] 00630 if {[lsearch $command_args $opt] != -1} { 00631 lset retval 4 [lrange [lindex $retval 4] 2 end] 00632 } 00633 return $retval 00634 } 00635 default { 00636 foreach {opt value} $args { 00637 if {[lsearch $command_args $opt] != -1} { 00638 set value [list interpreter::tablelist_do $pname $value] 00639 } 00640 lappend retval $opt $value 00641 } 00642 return [$win configure {*}$retval] 00643 } 00644 } 00645 } 00646 00647 cellcget - 00648 columncget { 00649 lassign $args key opt 00650 if {[lsearch $command_args $opt] != -1} { 00651 return [lindex [$win $cmd $key $opt] 2] 00652 } else { 00653 return [$win $cmd $key $opt] 00654 } 00655 00656 } 00657 00658 cellconfigure - 00659 columnconfigure { 00660 set retval [list] 00661 set args [lassign $args key] 00662 switch [llength $args] { 00663 0 { 00664 foreach opt [$win $cmd $key] { 00665 if {[lsearch $tbl_commands [lindex $opt 0]] != -1} { 00666 lset opt 4 [lindex [lindex $opt 4] 2] 00667 } 00668 lappend retval $opt 00669 } 00670 return $retval 00671 } 00672 1 { 00673 set opt [lindex $args 0] 00674 set retval [$win $cmd $key $opt] 00675 if {[lsearch $tbl_commands $opt] != -1} { 00676 lset retval 4 [lindex [lindex $retval 4] 2] 00677 } 00678 return $retval 00679 } 00680 default { 00681 foreach {opt value} $args { 00682 if {[lsearch $tbl_commands $opt] != -1} { 00683 set value [list interpreter::tablelist_do $pname $value] 00684 } elseif {($opt eq "-text") && [winfo exists [$win windowpath $key].ckbtn]} { 00685 set [[$win windowpath $key].ckbtn cget -variable] $value 00686 } 00687 lappend retval $opt $value 00688 } 00689 return [$win $cmd $key {*}$retval] 00690 } 00691 } 00692 } 00693 00694 embedcheckbutton - 00695 embedcheckbuttons - 00696 embedttkcheckbutton - 00697 embedttkcheckbuttons { 00698 if {[llength $args] == 2} { 00699 $win $cmd [lindex $args 0] [list interpreter::tablelist_do $pname [lindex $args 1]] 00700 } else { 00701 $win $cmd [lindex $args 0] 00702 } 00703 } 00704 00705 header { 00706 set args [lassign $args subcmd] 00707 switch $subcmd { 00708 embedcheckbutton - 00709 embedcheckbuttons - 00710 embedttkcheckbutton - 00711 embedttkcheckbuttons { 00712 if {[llength $args] == 2} { 00713 $win header $subcmd [lindex $args 0] [list interpreter::tablelist_do $pname [lindex $args 1]] 00714 } else { 00715 $win header $subcmd [lindex $args 0] 00716 } 00717 } 00718 } 00719 } 00720 00721 default { 00722 return [$win $cmd {*}$args] 00723 } 00724 } 00725 00726 } 00727 00728 ###################################################################### 00729 # Performs the given tablelist command, adding any appending arguments to 00730 # the given command. 00731 proc tablelist_do {pname cmd args} { 00732 00733 variable interps 00734 00735 return [$interps($pname,interp) eval [list {*}$cmd {*}$args]] 00736 00737 } 00738 00739 ###################################################################### 00740 # Executes the open command. 00741 proc open_command {pname fname args} { 00742 00743 variable interps 00744 00745 # Make sure that the given filename is valid 00746 if {[set fname [check_file $pname $fname]] eq ""} { 00747 return -code error "permission error" 00748 } 00749 00750 # Open the file 00751 if {[catch { open $fname {*}$args } rc]} { 00752 return -code error $rc 00753 } 00754 00755 # Save the file descriptor 00756 lappend interps($pname,files) $rc 00757 00758 return $rc 00759 00760 } 00761 00762 ###################################################################### 00763 # Executes the close command. 00764 proc close_command {pname channel args} { 00765 00766 variable interps 00767 00768 if {[set index [lsearch $interps($pname,files) $channel]] != -1} { 00769 close $channel {*}$args 00770 set interps($pname,files) [lreplace $interps($pname,files) $index $index] 00771 } else { 00772 return -code error "permission error" 00773 } 00774 00775 } 00776 00777 ###################################################################### 00778 # Executes the flush command. 00779 proc flush_command {pname channel} { 00780 00781 variable interps 00782 00783 if {[lsearch $interps($pname,files) $channel] != -1} { 00784 flush $channel 00785 } else { 00786 return -code error "permission error" 00787 } 00788 00789 } 00790 00791 ###################################################################### 00792 # Executes the read command. 00793 proc read_command {pname args} { 00794 00795 variable interps 00796 00797 if {[lindex $args 0] eq "-nonewline"} { 00798 set channel [lindex $args 1] 00799 } else { 00800 set channel [lindex $args 0] 00801 } 00802 00803 if {[lsearch $interps($pname,files) $channel] != -1} { 00804 return [read {*}$args] 00805 } else { 00806 return -code error "permission error" 00807 } 00808 00809 } 00810 00811 ###################################################################### 00812 # Executes the puts command with a channel identifier. 00813 proc puts_command {pname args} { 00814 00815 variable interps 00816 00817 if {[lindex $args 0] eq "-nonewline"} { 00818 set channel [lindex $args 1] 00819 } else { 00820 set channel [lindex $args 0] 00821 } 00822 00823 if {[lsearch $interps($pname,files) $channel] != -1} { 00824 puts {*}$args 00825 } else { 00826 return -code error "permission error" 00827 } 00828 00829 } 00830 00831 ###################################################################### 00832 # Executes the fconfigure command. 00833 proc fconfigure_command {pname args} { 00834 00835 variable interps 00836 00837 if {[lsearch $interps($pname,files) [lindex $args 0]] != -1} { 00838 return [fconfigure {*}$args] 00839 } else { 00840 return -code error "permission error" 00841 } 00842 00843 } 00844 00845 ###################################################################### 00846 # Executes the exec command. 00847 proc exec_command {pname args} { 00848 00849 variable interps 00850 00851 if {![$interps($pname,interp) issafe]} { 00852 return [exec {*}$args] 00853 } else { 00854 return -code error "permission error" 00855 } 00856 00857 } 00858 00859 ###################################################################### 00860 # Executes the file command. 00861 proc file_command {pname subcmd args} { 00862 00863 variable interps 00864 00865 switch $subcmd { 00866 00867 atime - 00868 attributes - 00869 exists - 00870 executable - 00871 isdirectory - 00872 isfile - 00873 mtime - 00874 owned - 00875 readable - 00876 size - 00877 type - 00878 writable { 00879 if {[set fname [check_file $pname [lindex $args 0]]] eq ""} { 00880 return -code error "permission error" 00881 } 00882 return [file $subcmd $fname {*}[lrange $args 1 end]] 00883 } 00884 00885 delete - 00886 copy - 00887 rename { 00888 set opts [list] 00889 set fnames [list] 00890 set double_dash_seen 0 00891 foreach arg $args { 00892 if {!$double_dash_seen && [string index $arg 0] eq "-"} { 00893 if {$arg eq "--"} { 00894 set double_dash_seen 1 00895 } 00896 lappend opts $arg 00897 } elseif {[set fname [check_file $pname $arg]] ne ""} { 00898 lappend fnames $fname 00899 } else { 00900 return -code error "permission error" 00901 } 00902 } 00903 return [file $subcmd {*}$opts {*}$fnames] 00904 } 00905 00906 dirname { 00907 if {[set fname [check_file $pname [lindex $args 0]]] eq ""} { 00908 return -code error "permission error" 00909 } 00910 if {[set fname [check_file_access $pname [file dirname $fname]]] eq ""} { 00911 return -code error "permission error" 00912 } 00913 return [encode_file $pname $fname] 00914 } 00915 00916 mkdir { 00917 set dnames [list] 00918 foreach arg $args { 00919 if {[set dname [check_file $pname $arg]] ne ""} { 00920 lappend dnames $dname 00921 } 00922 } 00923 if {[llength $dnames] > 0} { 00924 return [file mkdir {*}$dnames] 00925 } else { 00926 return -code error "permission error" 00927 } 00928 } 00929 00930 join - 00931 extension - 00932 rootname - 00933 tail - 00934 separator - 00935 split { 00936 return [file $subcmd {*}$args] 00937 } 00938 00939 default { 00940 if {![$interps($pname,interp) issafe]} { 00941 return [file $subcmd {*}$args] 00942 } 00943 return -code error "file command $subcmd is not allowed by a plugin" 00944 } 00945 } 00946 00947 } 00948 00949 ###################################################################### 00950 # Executes the glob command. 00951 proc glob_command {pname args} { 00952 00953 variable interps 00954 00955 set i 0 00956 set new_args [list] 00957 00958 # Parse the options 00959 while {$i < [llength $args]} { 00960 switch -exact [set opt [lindex $args $i]] { 00961 -directory - 00962 -path { 00963 if {[set dname [check_file $pname [lindex $args [incr i]]]] eq ""} { 00964 return -code error "permission error" 00965 } 00966 lappend new_args $opt $dname 00967 } 00968 default { 00969 lappend new_args $opt 00970 } 00971 } 00972 incr i 00973 } 00974 00975 # Encode the returned filenames 00976 set fnames [list] 00977 foreach fname [glob {*}$new_args] { 00978 if {[set ename [encode_file $pname $fname]] eq ""} { 00979 lappend fnames $fname 00980 } else { 00981 lappend fnames $ename 00982 } 00983 } 00984 00985 return $fnames 00986 00987 } 00988 00989 ###################################################################### 00990 # Creates and sets up a safe interpreter for a plugin. 00991 proc create {pname trust_granted} { 00992 00993 variable interps 00994 00995 # Setup the access paths 00996 lappend access_path $::tcl_library 00997 lappend access_path [file join $::tke_home plugins $pname] 00998 lappend access_path [file join $::tke_home iplugins $pname] 00999 lappend access_path [file join $::tke_dir plugins $pname] 01000 lappend access_path [file join $::tke_dir plugins images] 01001 01002 # Create the interpreter 01003 if {$trust_granted} { 01004 set interp [interp create] 01005 } else { 01006 set interp [::safe::interpCreate -nested true -accessPath $access_path] 01007 } 01008 01009 # Save the interpreter and initialize the structure 01010 set interps($pname,interp) $interp 01011 set interps($pname,wins) [list] 01012 set interps($pname,files) [list] 01013 set interps($pname,images) [list] 01014 01015 # If we are in development mode, share standard output for debug purposes 01016 if {[::tke_development]} { 01017 interp share {} stdout $interp 01018 } 01019 01020 # Create Tcl command aliases if we are running in untrusted mode 01021 if {!$trust_granted} { 01022 foreach cmd [list close exec file flush glob open puts fconfigure read] { 01023 $interp alias $cmd interpreter::${cmd}_command $pname 01024 } 01025 $interp hide exit my_exit 01026 } 01027 01028 # Create raw ttk widget aliases 01029 foreach widget [list canvas listbox menu text toplevel ttk::button ttk::checkbutton ttk::combobox \ 01030 ttk::entry ttk::frame ttk::label ttk::labelframe ttk::menubutton ttk::notebook \ 01031 ttk::panedwindow ttk::progressbar ttk::radiobutton ttk::scale ttk::scrollbar \ 01032 ttk::separator ttk::spinbox ttk::treeview ctext tokenentry::tokenentry \ 01033 wmarkentry::wmarkentry tabbar::tabbar] { 01034 $interp alias $widget interpreter::widget_command $pname $widget 01035 } 01036 01037 # Create Tcl/Tk commands 01038 foreach cmd [list clipboard event focus font grid pack place tk_messageBox \ 01039 tk_chooseColor fontchooser tk_getOpenFile tk_getSaveFile \ 01040 tk_chooseDirectory tk::TextSetCursor tk::TextUpDownLine \ 01041 tk::PlaceWindow tk::SetFocusGrab tk::RestoreFocusGrab \ 01042 tkwait base64::encode base64::decode] { 01043 $interp alias $cmd $cmd 01044 } 01045 01046 # Specialized Tk commands 01047 foreach cmd [list destroy bind winfo wm image tablelist] { 01048 $interp alias $cmd interpreter::${cmd}_command $pname 01049 } 01050 01051 # Recursively add all commands that are within the api namespace 01052 foreach pattern [list ::api::* {*}[join [namespace children ::api]::* {::* }]] { 01053 foreach cmd [info commands $pattern] { 01054 if {$cmd ne "::api::ns"} { 01055 $interp alias $cmd $cmd $interp $pname 01056 } 01057 } 01058 } 01059 01060 # Create TKE command aliases 01061 $interp alias api::register plugins::register 01062 $interp alias api::get_default_foreground utils::get_default_foreground 01063 $interp alias api::get_default_background utils::get_default_background 01064 $interp alias api::color_to_rgb utils::color_to_rgb 01065 $interp alias api::get_complementary_mono_color utils::get_complementary_mono_color 01066 $interp alias api::rgb_to_hsv utils::rgb_to_hsv 01067 $interp alias api::hsv_to_rgb utils::hsv_to_rgb 01068 $interp alias api::rgb_to_hsl utils::rgb_to_hsl 01069 $interp alias api::hsl_to_rgb utils::hsl_to_rgb 01070 $interp alias api::get_color_values utils::get_color_values 01071 $interp alias api::auto_adjust_color utils::auto_adjust_color 01072 $interp alias api::auto_mix_colors utils::auto_mix_colors 01073 $interp alias api::color_difference utils::color_difference 01074 $interp alias api::set_xscrollbar utils::set_xscrollbar 01075 $interp alias api::set_yscrollbar utils::set_yscrollbar 01076 $interp alias api::export utils::export 01077 01078 # Add ctext calls 01079 $interp alias ctext::getLang ctext::getLang 01080 $interp alias ctext::getNextBracket ctext::getNextBracket 01081 $interp alias ctext::getPrevBracket ctext::getPrevBracket 01082 $interp alias ctext::getMatchBracket ctext::getMatchBracket 01083 $interp alias ctext::getTagInRange ctext::getTagInRange 01084 01085 return $interp 01086 01087 } 01088 01089 ###################################################################### 01090 # Destroys the interpreter at the given index. 01091 proc destroy {pname} { 01092 01093 variable interps 01094 01095 # Destroy any existing windows 01096 foreach win $interps($pname,wins) { 01097 if {[lindex $win 1]} { 01098 catch { ::destroy [lindex $win 0] } 01099 } 01100 } 01101 01102 # Close any opened files 01103 foreach channel $interps($pname,files) { 01104 catch { close $channel } 01105 } 01106 01107 # Destroy any images 01108 foreach img $interps($pname,images) { 01109 catch { image delete $img } 01110 } 01111 01112 # Finally, destroy the interpreter 01113 catch { ::safe::interpDelete $interps($pname,interp) } 01114 01115 # Destroy the interpreter for the given plugin name 01116 array unset interps $pname,* 01117 01118 } 01119 01120 }