1# safe.tcl -- 2# 3# This file provide a safe loading/sourcing mechanism for safe interpreters. 4# It implements a virtual path mecanism to hide the real pathnames from the 5# slave. It runs in a master interpreter and sets up data structure and 6# aliases that will be invoked when used from a slave interpreter. 7# 8# See the safe.n man page for details. 9# 10# Copyright (c) 1996-1997 Sun Microsystems, Inc. 11# 12# See the file "license.terms" for information on usage and redistribution of 13# this file, and for a DISCLAIMER OF ALL WARRANTIES. 14# 15# RCS: @(#) $Id: safe.tcl,v 1.16.4.8 2010/09/02 18:30:29 andreas_kupries Exp $ 16 17# 18# The implementation is based on namespaces. These naming conventions are 19# followed: 20# Private procs starts with uppercase. 21# Public procs are exported and starts with lowercase 22# 23 24# Needed utilities package 25package require opt 0.4.1 26 27# Create the safe namespace 28namespace eval ::safe { 29 # Exported API: 30 namespace export interpCreate interpInit interpConfigure interpDelete \ 31 interpAddToAccessPath interpFindInAccessPath setLogCmd 32} 33 34# Helper function to resolve the dual way of specifying staticsok (either 35# by -noStatics or -statics 0) 36proc ::safe::InterpStatics {} { 37 foreach v {Args statics noStatics} { 38 upvar $v $v 39 } 40 set flag [::tcl::OptProcArgGiven -noStatics] 41 if {$flag && (!$noStatics == !$statics) 42 && ([::tcl::OptProcArgGiven -statics])} { 43 return -code error\ 44 "conflicting values given for -statics and -noStatics" 45 } 46 if {$flag} { 47 return [expr {!$noStatics}] 48 } else { 49 return $statics 50 } 51} 52 53# Helper function to resolve the dual way of specifying nested loading 54# (either by -nestedLoadOk or -nested 1) 55proc ::safe::InterpNested {} { 56 foreach v {Args nested nestedLoadOk} { 57 upvar $v $v 58 } 59 set flag [::tcl::OptProcArgGiven -nestedLoadOk] 60 # note that the test here is the opposite of the "InterpStatics" one 61 # (it is not -noNested... because of the wanted default value) 62 if {$flag && (!$nestedLoadOk != !$nested) 63 && ([::tcl::OptProcArgGiven -nested])} { 64 return -code error\ 65 "conflicting values given for -nested and -nestedLoadOk" 66 } 67 if {$flag} { 68 # another difference with "InterpStatics" 69 return $nestedLoadOk 70 } else { 71 return $nested 72 } 73} 74 75#### 76# 77# API entry points that needs argument parsing : 78# 79#### 80 81# Interface/entry point function and front end for "Create" 82proc ::safe::interpCreate {args} { 83 set Args [::tcl::OptKeyParse ::safe::interpCreate $args] 84 InterpCreate $slave $accessPath \ 85 [InterpStatics] [InterpNested] $deleteHook 86} 87 88proc ::safe::interpInit {args} { 89 set Args [::tcl::OptKeyParse ::safe::interpIC $args] 90 if {![::interp exists $slave]} { 91 return -code error "\"$slave\" is not an interpreter" 92 } 93 InterpInit $slave $accessPath \ 94 [InterpStatics] [InterpNested] $deleteHook 95} 96 97# Check that the given slave is "one of us" 98proc ::safe::CheckInterp {slave} { 99 namespace upvar ::safe S$slave state 100 if {![info exists state] || ![::interp exists $slave]} { 101 return -code error \ 102 "\"$slave\" is not an interpreter managed by ::safe::" 103 } 104} 105 106# Interface/entry point function and front end for "Configure". This code 107# is awfully pedestrian because it would need more coupling and support 108# between the way we store the configuration values in safe::interp's and 109# the Opt package. Obviously we would like an OptConfigure to avoid 110# duplicating all this code everywhere. 111# -> TODO (the app should share or access easily the program/value stored 112# by opt) 113 114# This is even more complicated by the boolean flags with no values that 115# we had the bad idea to support for the sake of user simplicity in 116# create/init but which makes life hard in configure... 117# So this will be hopefully written and some integrated with opt1.0 118# (hopefully for tcl8.1 ?) 119proc ::safe::interpConfigure {args} { 120 switch [llength $args] { 121 1 { 122 # If we have exactly 1 argument the semantic is to return all 123 # the current configuration. We still call OptKeyParse though 124 # we know that "slave" is our given argument because it also 125 # checks for the "-help" option. 126 set Args [::tcl::OptKeyParse ::safe::interpIC $args] 127 CheckInterp $slave 128 namespace upvar ::safe S$slave state 129 130 return [join [list \ 131 [list -accessPath $state(access_path)] \ 132 [list -statics $state(staticsok)] \ 133 [list -nested $state(nestedok)] \ 134 [list -deleteHook $state(cleanupHook)]]] 135 } 136 2 { 137 # If we have exactly 2 arguments the semantic is a "configure 138 # get" 139 lassign $args slave arg 140 141 # get the flag sub program (we 'know' about Opt's internal 142 # representation of data) 143 set desc [lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2] 144 set hits [::tcl::OptHits desc $arg] 145 if {$hits > 1} { 146 return -code error [::tcl::OptAmbigous $desc $arg] 147 } elseif {$hits == 0} { 148 return -code error [::tcl::OptFlagUsage $desc $arg] 149 } 150 CheckInterp $slave 151 namespace upvar ::safe S$slave state 152 153 set item [::tcl::OptCurDesc $desc] 154 set name [::tcl::OptName $item] 155 switch -exact -- $name { 156 -accessPath {return [list -accessPath $state(access_path)]} 157 -statics {return [list -statics $state(staticsok)]} 158 -nested {return [list -nested $state(nestedok)]} 159 -deleteHook {return [list -deleteHook $state(cleanupHook)]} 160 -noStatics { 161 # it is most probably a set in fact but we would need 162 # then to jump to the set part and it is not *sure* 163 # that it is a set action that the user want, so force 164 # it to use the unambigous -statics ?value? instead: 165 return -code error\ 166 "ambigous query (get or set -noStatics ?)\ 167 use -statics instead" 168 } 169 -nestedLoadOk { 170 return -code error\ 171 "ambigous query (get or set -nestedLoadOk ?)\ 172 use -nested instead" 173 } 174 default { 175 return -code error "unknown flag $name (bug)" 176 } 177 } 178 } 179 default { 180 # Otherwise we want to parse the arguments like init and 181 # create did 182 set Args [::tcl::OptKeyParse ::safe::interpIC $args] 183 CheckInterp $slave 184 namespace upvar ::safe S$slave state 185 186 # Get the current (and not the default) values of whatever has 187 # not been given: 188 if {![::tcl::OptProcArgGiven -accessPath]} { 189 set doreset 1 190 set accessPath $state(access_path) 191 } else { 192 set doreset 0 193 } 194 if { 195 ![::tcl::OptProcArgGiven -statics] 196 && ![::tcl::OptProcArgGiven -noStatics] 197 } { 198 set statics $state(staticsok) 199 } else { 200 set statics [InterpStatics] 201 } 202 if { 203 [::tcl::OptProcArgGiven -nested] || 204 [::tcl::OptProcArgGiven -nestedLoadOk] 205 } { 206 set nested [InterpNested] 207 } else { 208 set nested $state(nestedok) 209 } 210 if {![::tcl::OptProcArgGiven -deleteHook]} { 211 set deleteHook $state(cleanupHook) 212 } 213 # we can now reconfigure : 214 InterpSetConfig $slave $accessPath $statics $nested $deleteHook 215 # auto_reset the slave (to completly synch the new access_path) 216 if {$doreset} { 217 if {[catch {::interp eval $slave {auto_reset}} msg]} { 218 Log $slave "auto_reset failed: $msg" 219 } else { 220 Log $slave "successful auto_reset" NOTICE 221 } 222 } 223 } 224 } 225} 226 227#### 228# 229# Functions that actually implements the exported APIs 230# 231#### 232 233# 234# safe::InterpCreate : doing the real job 235# 236# This procedure creates a safe slave and initializes it with the safe 237# base aliases. 238# NB: slave name must be simple alphanumeric string, no spaces, no (), no 239# {},... {because the state array is stored as part of the name} 240# 241# Returns the slave name. 242# 243# Optional Arguments : 244# + slave name : if empty, generated name will be used 245# + access_path: path list controlling where load/source can occur, 246# if empty: the master auto_path will be used. 247# + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx) 248# if 1 :static packages are ok. 249# + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub) 250# if 1 : multiple levels are ok. 251 252# use the full name and no indent so auto_mkIndex can find us 253proc ::safe::InterpCreate { 254 slave 255 access_path 256 staticsok 257 nestedok 258 deletehook 259 } { 260 # Create the slave. 261 if {$slave ne ""} { 262 ::interp create -safe $slave 263 } else { 264 # empty argument: generate slave name 265 set slave [::interp create -safe] 266 } 267 Log $slave "Created" NOTICE 268 269 # Initialize it. (returns slave name) 270 InterpInit $slave $access_path $staticsok $nestedok $deletehook 271} 272 273# 274# InterpSetConfig (was setAccessPath) : 275# Sets up slave virtual auto_path and corresponding structure within 276# the master. Also sets the tcl_library in the slave to be the first 277# directory in the path. 278# NB: If you change the path after the slave has been initialized you 279# probably need to call "auto_reset" in the slave in order that it gets 280# the right auto_index() array values. 281 282proc ::safe::InterpSetConfig {slave access_path staticsok nestedok deletehook} { 283 global auto_path 284 285 # determine and store the access path if empty 286 if {$access_path eq ""} { 287 set access_path $auto_path 288 289 # Make sure that tcl_library is in auto_path and at the first 290 # position (needed by setAccessPath) 291 set where [lsearch -exact $access_path [info library]] 292 if {$where == -1} { 293 # not found, add it. 294 set access_path [linsert $access_path 0 [info library]] 295 Log $slave "tcl_library was not in auto_path,\ 296 added it to slave's access_path" NOTICE 297 } elseif {$where != 0} { 298 # not first, move it first 299 set access_path [linsert \ 300 [lreplace $access_path $where $where] \ 301 0 [info library]] 302 Log $slave "tcl_libray was not in first in auto_path,\ 303 moved it to front of slave's access_path" NOTICE 304 } 305 306 # Add 1st level sub dirs (will searched by auto loading from tcl 307 # code in the slave using glob and thus fail, so we add them here 308 # so by default it works the same). 309 set access_path [AddSubDirs $access_path] 310 } 311 312 Log $slave "Setting accessPath=($access_path) staticsok=$staticsok\ 313 nestedok=$nestedok deletehook=($deletehook)" NOTICE 314 315 namespace upvar ::safe S$slave state 316 317 # clear old autopath if it existed 318 # build new one 319 # Extend the access list with the paths used to look for Tcl Modules. 320 # We save the virtual form separately as well, as syncing it with the 321 # slave has to be defered until the necessary commands are present for 322 # setup. 323 324 set norm_access_path {} 325 set slave_access_path {} 326 set map_access_path {} 327 set remap_access_path {} 328 set slave_tm_path {} 329 330 set i 0 331 foreach dir $access_path { 332 set token [PathToken $i] 333 lappend slave_access_path $token 334 lappend map_access_path $token $dir 335 lappend remap_access_path $dir $token 336 lappend norm_access_path [file normalize $dir] 337 incr i 338 } 339 340 set morepaths [::tcl::tm::list] 341 while {[llength $morepaths]} { 342 set addpaths $morepaths 343 set morepaths {} 344 345 foreach dir $addpaths { 346 # Prevent the addition of dirs on the tm list to the 347 # result if they are already known. 348 if {[dict exists $remap_access_path $dir]} { 349 continue 350 } 351 352 set token [PathToken $i] 353 lappend access_path $dir 354 lappend slave_access_path $token 355 lappend map_access_path $token $dir 356 lappend remap_access_path $dir $token 357 lappend norm_access_path [file normalize $dir] 358 lappend slave_tm_path $token 359 incr i 360 361 # [Bug 2854929] 362 # Recursively find deeper paths which may contain 363 # modules. Required to handle modules with names like 364 # 'platform::shell', which translate into 365 # 'platform/shell-X.tm', i.e arbitrarily deep 366 # subdirectories. 367 lappend morepaths {*}[glob -nocomplain -directory $dir -type d *] 368 } 369 } 370 371 set state(access_path) $access_path 372 set state(access_path,map) $map_access_path 373 set state(access_path,remap) $remap_access_path 374 set state(access_path,norm) $norm_access_path 375 set state(access_path,slave) $slave_access_path 376 set state(tm_path_slave) $slave_tm_path 377 set state(staticsok) $staticsok 378 set state(nestedok) $nestedok 379 set state(cleanupHook) $deletehook 380 381 SyncAccessPath $slave 382} 383 384# 385# 386# FindInAccessPath: 387# Search for a real directory and returns its virtual Id (including the 388# "$") 389proc ::safe::interpFindInAccessPath {slave path} { 390 namespace upvar ::safe S$slave state 391 392 if {![dict exists $state(access_path,remap) $path]} { 393 return -code error "$path not found in access path $access_path" 394 } 395 396 return [dict get $state(access_path,remap) $path] 397} 398 399# 400# addToAccessPath: 401# add (if needed) a real directory to access path and return its 402# virtual token (including the "$"). 403proc ::safe::interpAddToAccessPath {slave path} { 404 # first check if the directory is already in there 405 # (inlined interpFindInAccessPath). 406 namespace upvar ::safe S$slave state 407 408 if {[dict exists $state(access_path,remap) $path]} { 409 return [dict get $state(access_path,remap) $path] 410 } 411 412 # new one, add it: 413 set token [PathToken [llength $state(access_path)]] 414 415 lappend state(access_path) $path 416 lappend state(access_path,slave) $token 417 lappend state(access_path,map) $token $path 418 lappend state(access_path,remap) $path $token 419 lappend state(access_path,norm) [file normalize $path] 420 421 SyncAccessPath $slave 422 return $token 423} 424 425# This procedure applies the initializations to an already existing 426# interpreter. It is useful when you want to install the safe base aliases 427# into a preexisting safe interpreter. 428proc ::safe::InterpInit { 429 slave 430 access_path 431 staticsok 432 nestedok 433 deletehook 434 } { 435 # Configure will generate an access_path when access_path is empty. 436 InterpSetConfig $slave $access_path $staticsok $nestedok $deletehook 437 438 # NB we need to add [namespace current], aliases are always absolute 439 # paths. 440 441 # These aliases let the slave load files to define new commands 442 # This alias lets the slave use the encoding names, convertfrom, 443 # convertto, and system, but not "encoding system <name>" to set the 444 # system encoding. 445 # Handling Tcl Modules, we need a restricted form of Glob. 446 # This alias interposes on the 'exit' command and cleanly terminates 447 # the slave. 448 449 foreach {command alias} { 450 source AliasSource 451 load AliasLoad 452 encoding AliasEncoding 453 exit interpDelete 454 glob AliasGlob 455 } { 456 ::interp alias $slave $command {} [namespace current]::$alias $slave 457 } 458 459 # This alias lets the slave have access to a subset of the 'file' 460 # command functionality. 461 462 AliasSubset $slave file \ 463 file dir.* join root.* ext.* tail path.* split 464 465 # Subcommands of info 466 foreach {subcommand alias} { 467 nameofexecutable AliasExeName 468 } { 469 ::interp alias $slave ::tcl::info::$subcommand \ 470 {} [namespace current]::$alias $slave 471 } 472 473 # The allowed slave variables already have been set by Tcl_MakeSafe(3) 474 475 # Source init.tcl and tm.tcl into the slave, to get auto_load and 476 # other procedures defined: 477 478 if {[catch {::interp eval $slave { 479 source [file join $tcl_library init.tcl] 480 }} msg]} { 481 Log $slave "can't source init.tcl ($msg)" 482 return -code error "can't source init.tcl into slave $slave ($msg)" 483 } 484 485 if {[catch {::interp eval $slave { 486 source [file join $tcl_library tm.tcl] 487 }} msg]} { 488 Log $slave "can't source tm.tcl ($msg)" 489 return -code error "can't source tm.tcl into slave $slave ($msg)" 490 } 491 492 # Sync the paths used to search for Tcl modules. This can be done only 493 # now, after tm.tcl was loaded. 494 namespace upvar ::safe S$slave state 495 ::interp eval $slave [list \ 496 ::tcl::tm::add {*}$state(tm_path_slave)] 497 498 return $slave 499} 500 501# Add (only if needed, avoid duplicates) 1 level of sub directories to an 502# existing path list. Also removes non directories from the returned 503# list. 504proc ::safe::AddSubDirs {pathList} { 505 set res {} 506 foreach dir $pathList { 507 if {[file isdirectory $dir]} { 508 # check that we don't have it yet as a children of a previous 509 # dir 510 if {$dir ni $res} { 511 lappend res $dir 512 } 513 foreach sub [glob -directory $dir -nocomplain *] { 514 if {[file isdirectory $sub] && ($sub ni $res)} { 515 # new sub dir, add it ! 516 lappend res $sub 517 } 518 } 519 } 520 } 521 return $res 522} 523 524# This procedure deletes a safe slave managed by Safe Tcl and cleans up 525# associated state: 526 527proc ::safe::interpDelete {slave} { 528 Log $slave "About to delete" NOTICE 529 530 namespace upvar ::safe S$slave state 531 532 # If the slave has a cleanup hook registered, call it. Check the 533 # existance because we might be called to delete an interp which has 534 # not been registered with us at all 535 536 if {[info exists state(cleanupHook)]} { 537 set hook $state(cleanupHook) 538 if {[llength $hook]} { 539 # remove the hook now, otherwise if the hook calls us somehow, 540 # we'll loop 541 unset state(cleanupHook) 542 if {[catch { 543 {*}$hook $slave 544 } err]} { 545 Log $slave "Delete hook error ($err)" 546 } 547 } 548 } 549 550 # Discard the global array of state associated with the slave, and 551 # delete the interpreter. 552 553 if {[info exists state]} { 554 unset state 555 } 556 557 # if we have been called twice, the interp might have been deleted 558 # already 559 if {[::interp exists $slave]} { 560 ::interp delete $slave 561 Log $slave "Deleted" NOTICE 562 } 563 564 return 565} 566 567# Set (or get) the logging mecanism 568 569proc ::safe::setLogCmd {args} { 570 variable Log 571 set la [llength $args] 572 if {$la == 0} { 573 return $Log 574 } elseif {$la == 1} { 575 set Log [lindex $args 0] 576 } else { 577 set Log $args 578 } 579 580 if {$Log eq ""} { 581 # Disable logging completely. Calls to it will be compiled out 582 # of all users. 583 proc ::safe::Log {args} {} 584 } else { 585 # Activate logging, define proper command. 586 587 proc ::safe::Log {slave msg {type ERROR}} { 588 variable Log 589 {*}$Log "$type for slave $slave : $msg" 590 return 591 } 592 } 593} 594 595# ------------------- END OF PUBLIC METHODS ------------ 596 597# 598# Sets the slave auto_path to the master recorded value. Also sets 599# tcl_library to the first token of the virtual path. 600# 601proc ::safe::SyncAccessPath {slave} { 602 namespace upvar ::safe S$slave state 603 604 set slave_access_path $state(access_path,slave) 605 ::interp eval $slave [list set auto_path $slave_access_path] 606 607 Log $slave "auto_path in $slave has been set to $slave_access_path"\ 608 NOTICE 609 610 # This code assumes that info library is the first element in the 611 # list of auto_path's. See -> InterpSetConfig for the code which 612 # ensures this condition. 613 614 ::interp eval $slave [list \ 615 set tcl_library [lindex $slave_access_path 0]] 616} 617 618# Returns the virtual token for directory number N. 619proc ::safe::PathToken {n} { 620 # We need to have a ":" in the token string so [file join] on the 621 # mac won't turn it into a relative path. 622 return "\$p(:$n:)" ;# Form tested by case 7.2 623} 624 625# 626# translate virtual path into real path 627# 628proc ::safe::TranslatePath {slave path} { 629 namespace upvar ::safe S$slave state 630 631 # somehow strip the namespaces 'functionality' out (the danger is that 632 # we would strip valid macintosh "../" queries... : 633 if {[string match "*::*" $path] || [string match "*..*" $path]} { 634 return -code error "invalid characters in path $path" 635 } 636 637 # Use a cached map instead of computed local vars and subst. 638 639 return [string map $state(access_path,map) $path] 640} 641 642# file name control (limit access to files/resources that should be a 643# valid tcl source file) 644proc ::safe::CheckFileName {slave file} { 645 # This used to limit what can be sourced to ".tcl" and forbid files 646 # with more than 1 dot and longer than 14 chars, but I changed that 647 # for 8.4 as a safe interp has enough internal protection already to 648 # allow sourcing anything. - hobbs 649 650 if {![file exists $file]} { 651 # don't tell the file path 652 return -code error "no such file or directory" 653 } 654 655 if {![file readable $file]} { 656 # don't tell the file path 657 return -code error "not readable" 658 } 659} 660 661# AliasGlob is the target of the "glob" alias in safe interpreters. 662proc ::safe::AliasGlob {slave args} { 663 Log $slave "GLOB ! $args" NOTICE 664 set cmd {} 665 set at 0 666 array set got { 667 -directory 0 668 -nocomplain 0 669 -join 0 670 -tails 0 671 -- 0 672 } 673 674 if {$::tcl_platform(platform) eq "windows"} { 675 set dirPartRE {^(.*)[\\/]} 676 } else { 677 set dirPartRE {^(.*)/} 678 } 679 680 set dir {} 681 set virtualdir {} 682 683 while {$at < [llength $args]} { 684 switch -glob -- [set opt [lindex $args $at]] { 685 -nocomplain - -- - -join - -tails { 686 lappend cmd $opt 687 set got($opt) 1 688 incr at 689 } 690 -types - -type { 691 lappend cmd -types [lindex $args [incr at]] 692 incr at 693 } 694 -directory { 695 if {$got($opt)} { 696 return -code error \ 697 {"-directory" cannot be used with "-path"} 698 } 699 set got($opt) 1 700 set virtualdir [lindex $args [incr at]] 701 incr at 702 } 703 pkgIndex.tcl { 704 # Oops, this is globbing a subdirectory in regular package 705 # search. That is not wanted. Abort, handler does catch 706 # already (because glob was not defined before). See 707 # package.tcl, lines 484ff in tclPkgUnknown. 708 return -code error "unknown command glob" 709 } 710 -* { 711 Log $slave "Safe base rejecting glob option '$opt'" 712 return -code error "Safe base rejecting glob option '$opt'" 713 } 714 default { 715 break 716 } 717 } 718 if {$got(--)} break 719 } 720 721 # Get the real path from the virtual one and check that the path is in the 722 # access path of that slave. Done after basic argument processing so that 723 # we know if -nocomplain is set. 724 if {$got(-directory)} { 725 if {[catch { 726 set dir [TranslatePath $slave $virtualdir] 727 DirInAccessPath $slave $dir 728 } msg]} { 729 Log $slave $msg 730 if {!$got(-nocomplain)} { 731 return -code error "permission denied" 732 } else { 733 return 734 } 735 } 736 lappend cmd -directory $dir 737 } 738 739 # Apply the -join semantics ourselves 740 if {$got(-join)} { 741 set args [lreplace $args $at end [join [lrange $args $at end] "/"]] 742 } 743 744 # Process remaining pattern arguments 745 set firstPattern [llength $cmd] 746 while {$at < [llength $args]} { 747 set opt [lindex $args $at] 748 incr at 749 if {[regexp $dirPartRE $opt -> thedir] && [catch { 750 set thedir [file join $virtualdir $thedir] 751 DirInAccessPath $slave [TranslatePath $slave $thedir] 752 } msg]} { 753 Log $slave $msg 754 if {$got(-nocomplain)} { 755 continue 756 } else { 757 return -code error "permission denied" 758 } 759 } 760 lappend cmd $opt 761 } 762 763 Log $slave "GLOB = $cmd" NOTICE 764 765 if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} { 766 return 767 } 768 if {[catch { 769 ::interp invokehidden $slave glob {*}$cmd 770 } msg]} { 771 Log $slave $msg 772 return -code error "script error" 773 } 774 775 Log $slave "GLOB @ $msg" NOTICE 776 777 # Translate path back to what the slave should see. 778 set res {} 779 set l [string length $dir] 780 foreach p $msg { 781 if {[string equal -length $l $dir $p]} { 782 set p [string replace $p 0 [expr {$l-1}] $virtualdir] 783 } 784 lappend res $p 785 } 786 787 Log $slave "GLOB @ $res" NOTICE 788 return $res 789} 790 791# AliasSource is the target of the "source" alias in safe interpreters. 792 793proc ::safe::AliasSource {slave args} { 794 set argc [llength $args] 795 # Extended for handling of Tcl Modules to allow not only "source 796 # filename", but "source -encoding E filename" as well. 797 if {[lindex $args 0] eq "-encoding"} { 798 incr argc -2 799 set encoding [lindex $args 1] 800 set at 2 801 if {$encoding eq "identity"} { 802 Log $slave "attempt to use the identity encoding" 803 return -code error "permission denied" 804 } 805 } else { 806 set at 0 807 set encoding {} 808 } 809 if {$argc != 1} { 810 set msg "wrong # args: should be \"source ?-encoding E? fileName\"" 811 Log $slave "$msg ($args)" 812 return -code error $msg 813 } 814 set file [lindex $args $at] 815 816 # get the real path from the virtual one. 817 if {[catch { 818 set realfile [TranslatePath $slave $file] 819 } msg]} { 820 Log $slave $msg 821 return -code error "permission denied" 822 } 823 824 # check that the path is in the access path of that slave 825 if {[catch { 826 FileInAccessPath $slave $realfile 827 } msg]} { 828 Log $slave $msg 829 return -code error "permission denied" 830 } 831 832 # do the checks on the filename : 833 if {[catch { 834 CheckFileName $slave $realfile 835 } msg]} { 836 Log $slave "$realfile:$msg" 837 return -code error $msg 838 } 839 840 # Passed all the tests, lets source it. Note that we do this all manually 841 # because we want to control [info script] in the slave so information 842 # doesn't leak so much. [Bug 2913625] 843 set old [::interp eval $slave {info script}] 844 set code [catch { 845 set f [open $realfile] 846 fconfigure $f -eofchar \032 847 if {$encoding ne ""} { 848 fconfigure $f -encoding $encoding 849 } 850 set contents [read $f] 851 close $f 852 ::interp eval $slave [list info script $file] 853 ::interp eval $slave $contents 854 } msg opt] 855 catch {interp eval $slave [list info script $old]} 856 # Note that all non-errors are fine result codes from [source], so we must 857 # take a little care to do it properly. [Bug 2923613] 858 if {$code == 1} { 859 Log $slave $msg 860 return -code error "script error" 861 } 862 return -code $code -options $opt $msg 863} 864 865# AliasLoad is the target of the "load" alias in safe interpreters. 866 867proc ::safe::AliasLoad {slave file args} { 868 set argc [llength $args] 869 if {$argc > 2} { 870 set msg "load error: too many arguments" 871 Log $slave "$msg ($argc) {$file $args}" 872 return -code error $msg 873 } 874 875 # package name (can be empty if file is not). 876 set package [lindex $args 0] 877 878 namespace upvar ::safe S$slave state 879 880 # Determine where to load. load use a relative interp path and {} 881 # means self, so we can directly and safely use passed arg. 882 set target [lindex $args 1] 883 if {$target ne ""} { 884 # we will try to load into a sub sub interp; check that we want to 885 # authorize that. 886 if {!$state(nestedok)} { 887 Log $slave "loading to a sub interp (nestedok)\ 888 disabled (trying to load $package to $target)" 889 return -code error "permission denied (nested load)" 890 } 891 } 892 893 # Determine what kind of load is requested 894 if {$file eq ""} { 895 # static package loading 896 if {$package eq ""} { 897 set msg "load error: empty filename and no package name" 898 Log $slave $msg 899 return -code error $msg 900 } 901 if {!$state(staticsok)} { 902 Log $slave "static packages loading disabled\ 903 (trying to load $package to $target)" 904 return -code error "permission denied (static package)" 905 } 906 } else { 907 # file loading 908 909 # get the real path from the virtual one. 910 if {[catch { 911 set file [TranslatePath $slave $file] 912 } msg]} { 913 Log $slave $msg 914 return -code error "permission denied" 915 } 916 917 # check the translated path 918 if {[catch { 919 FileInAccessPath $slave $file 920 } msg]} { 921 Log $slave $msg 922 return -code error "permission denied (path)" 923 } 924 } 925 926 if {[catch { 927 ::interp invokehidden $slave load $file $package $target 928 } msg]} { 929 Log $slave $msg 930 return -code error $msg 931 } 932 933 return $msg 934} 935 936# FileInAccessPath raises an error if the file is not found in the list of 937# directories contained in the (master side recorded) slave's access path. 938 939# the security here relies on "file dirname" answering the proper 940# result... needs checking ? 941proc ::safe::FileInAccessPath {slave file} { 942 namespace upvar ::safe S$slave state 943 set access_path $state(access_path) 944 945 if {[file isdirectory $file]} { 946 return -code error "\"$file\": is a directory" 947 } 948 set parent [file dirname $file] 949 950 # Normalize paths for comparison since lsearch knows nothing of 951 # potential pathname anomalies. 952 set norm_parent [file normalize $parent] 953 954 namespace upvar ::safe S$slave state 955 if {$norm_parent ni $state(access_path,norm)} { 956 return -code error "\"$file\": not in access_path" 957 } 958} 959 960proc ::safe::DirInAccessPath {slave dir} { 961 namespace upvar ::safe S$slave state 962 set access_path $state(access_path) 963 964 if {[file isfile $dir]} { 965 return -code error "\"$dir\": is a file" 966 } 967 968 # Normalize paths for comparison since lsearch knows nothing of 969 # potential pathname anomalies. 970 set norm_dir [file normalize $dir] 971 972 namespace upvar ::safe S$slave state 973 if {$norm_dir ni $state(access_path,norm)} { 974 return -code error "\"$dir\": not in access_path" 975 } 976} 977 978# This procedure enables access from a safe interpreter to only a subset 979# of the subcommands of a command: 980 981proc ::safe::Subset {slave command okpat args} { 982 set subcommand [lindex $args 0] 983 if {[regexp $okpat $subcommand]} { 984 return [$command {*}$args] 985 } 986 set msg "not allowed to invoke subcommand $subcommand of $command" 987 Log $slave $msg 988 return -code error $msg 989} 990 991# This procedure installs an alias in a slave that invokes "safesubset" in 992# the master to execute allowed subcommands. It precomputes the pattern of 993# allowed subcommands; you can use wildcards in the pattern if you wish to 994# allow subcommand abbreviation. 995# 996# Syntax is: AliasSubset slave alias target subcommand1 subcommand2... 997 998proc ::safe::AliasSubset {slave alias target args} { 999 set pat "^([join $args |])\$" 1000 ::interp alias $slave $alias {}\ 1001 [namespace current]::Subset $slave $target $pat 1002} 1003 1004# AliasEncoding is the target of the "encoding" alias in safe interpreters. 1005 1006proc ::safe::AliasEncoding {slave option args} { 1007 # Careful; do not want empty option to get through to the [string equal] 1008 if {[regexp {^(name.*|convert.*|)$} $option]} { 1009 return [::interp invokehidden $slave encoding $option {*}$args] 1010 } 1011 1012 if {[string equal -length [string length $option] $option "system"]} { 1013 if {[llength $args] == 0} { 1014 # passed all the tests , lets source it: 1015 if {[catch { 1016 set sysenc [::interp invokehidden $slave encoding system] 1017 } msg]} { 1018 Log $slave $msg 1019 return -code error "script error" 1020 } 1021 return $sysenc 1022 } 1023 set msg "wrong # args: should be \"encoding system\"" 1024 set code {TCL WRONGARGS} 1025 } else { 1026 set msg "bad option \"$option\": must be convertfrom, convertto, names, or system" 1027 set code [list TCL LOOKUP INDEX option $option] 1028 } 1029 Log $slave $msg 1030 return -code error -errorcode $code $msg 1031} 1032 1033# Various minor hiding of platform features. [Bug 2913625] 1034 1035proc ::safe::AliasExeName {slave} { 1036 return "" 1037} 1038 1039proc ::safe::Setup {} { 1040 #### 1041 # 1042 # Setup the arguments parsing 1043 # 1044 #### 1045 1046 # Share the descriptions 1047 set temp [::tcl::OptKeyRegister { 1048 {-accessPath -list {} "access path for the slave"} 1049 {-noStatics "prevent loading of statically linked pkgs"} 1050 {-statics true "loading of statically linked pkgs"} 1051 {-nestedLoadOk "allow nested loading"} 1052 {-nested false "nested loading"} 1053 {-deleteHook -script {} "delete hook"} 1054 }] 1055 1056 # create case (slave is optional) 1057 ::tcl::OptKeyRegister { 1058 {?slave? -name {} "name of the slave (optional)"} 1059 } ::safe::interpCreate 1060 1061 # adding the flags sub programs to the command program (relying on Opt's 1062 # internal implementation details) 1063 lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp) 1064 1065 # init and configure (slave is needed) 1066 ::tcl::OptKeyRegister { 1067 {slave -name {} "name of the slave"} 1068 } ::safe::interpIC 1069 1070 # adding the flags sub programs to the command program (relying on Opt's 1071 # internal implementation details) 1072 lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp) 1073 1074 # temp not needed anymore 1075 ::tcl::OptKeyDelete $temp 1076 1077 #### 1078 # 1079 # Default: No logging. 1080 # 1081 #### 1082 1083 setLogCmd {} 1084 1085 # Log eventually. 1086 # To enable error logging, set Log to {puts stderr} for instance, 1087 # via setLogCmd. 1088 return 1089} 1090 1091namespace eval ::safe { 1092 # internal variables 1093 1094 # Log command, set via 'setLogCmd'. Logging is disabled when empty. 1095 variable Log {} 1096 1097 # The package maintains a state array per slave interp under its 1098 # control. The name of this array is S<interp-name>. This array is 1099 # brought into scope where needed, using 'namespace upvar'. The S 1100 # prefix is used to avoid that a slave interp called "Log" smashes 1101 # the "Log" variable. 1102 # 1103 # The array's elements are: 1104 # 1105 # access_path : List of paths accessible to the slave. 1106 # access_path,norm : Ditto, in normalized form. 1107 # access_path,slave : Ditto, as the path tokens as seen by the slave. 1108 # access_path,map : dict ( token -> path ) 1109 # access_path,remap : dict ( path -> token ) 1110 # tm_path_slave : List of TM root directories, as tokens seen by the slave. 1111 # staticsok : Value of option -statics 1112 # nestedok : Value of option -nested 1113 # cleanupHook : Value of option -deleteHook 1114} 1115 1116::safe::Setup 1117