1# interp.tcl 2# Some utility commands for interpreter creation 3# 4# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> 5# 6# See the file "license.terms" for information on usage and redistribution 7# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 8# 9# RCS: @(#) $Id: interp.tcl,v 1.3 2007/08/20 21:06:33 andreas_kupries Exp $ 10 11package require Tcl 8.3 12 13# ### ### ### ######### ######### ######### 14## Requisites 15 16namespace eval ::interp {} 17 18# ### ### ### ######### ######### ######### 19## Public API 20 21proc ::interp::createEmpty {args} { 22 # Create interpreter, predefined path or 23 # automatic naming. 24 25 if {[llength $args] > 1} { 26 return -code error "wrong#args: Expected ?path?" 27 } elseif {[llength $args] == 1} { 28 set i [interp create [lindex $args 0]] 29 } else { 30 set i [interp create] 31 } 32 33 # Clear out namespaces and commands, leaving an empty interpreter 34 # behind. Take care to delete the rename command last, as it is 35 # needed to perform the deletions. We have to keep the 'rename' 36 # command until last to allow us to delete all ocmmands. We also 37 # have to defer deletion of the ::tcl namespace (if present), as 38 # it may contain state for the auto-loader, which may be 39 # invoked. This also forces us to defer the deletion of the 40 # builtin command 'namespace' so that we can delete ::tcl at last. 41 42 foreach n [interp eval $i [list ::namespace children ::]] { 43 if {[string equal $n ::tcl]} continue 44 interp eval $i [list namespace delete $n] 45 } 46 foreach c [interp eval $i [list ::info commands]] { 47 if {[string equal $c rename]} continue 48 if {[string equal $c namespace]} continue 49 interp eval $i [list ::rename $c {}] 50 } 51 52 interp eval $i [list ::namespace delete ::tcl] 53 interp eval $i [list ::rename namespace {}] 54 interp eval $i [list ::rename rename {}] 55 56 # Done. Result is ready. 57 58 return $i 59} 60 61proc ::interp::snitLink {path methods} { 62 foreach m $methods { 63 set dst [uplevel 1 [linsert $m 0 mymethod]] 64 set alias [linsert $dst 0 interp alias $path [lindex $m 0] {}] 65 eval $alias 66 } 67 return 68} 69 70proc ::interp::snitDictLink {path methoddict} { 71 foreach {c m} $methoddict { 72 set dst [uplevel 1 [linsert $m 0 mymethod]] 73 set alias [linsert $dst 0 interp alias $path $c {}] 74 eval $alias 75 } 76 return 77} 78 79# ### ### ### ######### ######### ######### 80## Ready to go 81 82package provide interp 0.1.1 83