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 }
