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