interp.tcl

Go to the documentation of this file.

/*  interp.tcl*/
/*  Some utility commands for interpreter creation*/
/* */
/*  Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>*/
/* */
/*  See the file "license.terms" for information on usage and redistribution*/
/*  of this file, and for a DISCLAIMER OF ALL WARRANTIES.*/
/*  */
/*  RCS: @(#) $Id: interp.tcl,v 1.3 2007/08/20 21:06:33 andreas_kupries Exp $*/

package require Tcl 8.3

/*  ### ### ### ######### ######### #########*/
/*  Requisites*/

namespace ::interp {}

/*  ### ### ### ######### ######### #########*/
/*  Public API*/

ret  ::interp::createEmpty (type args) {
    # Create interpreter, predefined path or
    # automatic naming.

    if {[llength $args] > 1} {
    return -code error "wrong#args: Expected ?path?"
    } elseif {[llength $args] == 1} {
    set i [interp create [lindex $args 0]]
    } else {
    set i [interp create]
    }

    # Clear out namespaces and commands, leaving an empty interpreter
    # behind. Take care to delete the rename command last, as it is
    # needed to perform the deletions. We have to keep the 'rename'
    # command until last to allow us to delete all ocmmands. We also
    # have to defer deletion of the ::tcl namespace (if present), as
    # it may contain state for the auto-loader, which may be
    # invoked. This also forces us to defer the deletion of the
    # builtin command 'namespace' so that we can delete ::tcl at last.

    foreach n [interp eval $i [list ::namespace children ::]] {
    if {[string equal $n ::tcl]} continue
    interp eval $i [list namespace delete $n]
    }
    foreach c [interp eval $i [list ::info commands]] {
    if {[string equal $c rename]}    continue
    if {[string equal $c namespace]} continue
    interp eval $i [list ::rename $c {}]
    }

    interp eval $i [list ::namespace delete ::tcl]
    interp eval $i [list ::rename namespace {}]
    interp eval $i [list ::rename rename    {}]

    # Done. Result is ready.

    return $i
}

ret  ::interp::snitLink (type path , type methods) {
    foreach m $methods {
    set dst   [uplevel 1 [linsert $m 0 mymethod]]
    set alias [linsert $dst 0 interp alias $path [lindex $m 0] {}]
    eval $alias
    }
    return
}

ret  ::interp::snitDictLink (type path , type methoddict) {
    foreach {c m} $methoddict {
    set dst   [uplevel 1 [linsert $m 0 mymethod]]
    set alias [linsert $dst 0 interp alias $path $c {}]
    eval $alias
    }
    return
}

/*  ### ### ### ######### ######### #########*/
/*  Ready to go*/

package provide interp 0.1.1