jpayne@68: # jpayne@68: # itcl.tcl jpayne@68: # ---------------------------------------------------------------------- jpayne@68: # Invoked automatically upon startup to customize the interpreter jpayne@68: # for [incr Tcl]. jpayne@68: # ---------------------------------------------------------------------- jpayne@68: # AUTHOR: Michael J. McLennan jpayne@68: # Bell Labs Innovations for Lucent Technologies jpayne@68: # mmclennan@lucent.com jpayne@68: # http://www.tcltk.com/itcl jpayne@68: # ---------------------------------------------------------------------- jpayne@68: # Copyright (c) 1993-1998 Lucent Technologies, Inc. jpayne@68: # ====================================================================== jpayne@68: # See the file "license.terms" for information on usage and jpayne@68: # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. jpayne@68: jpayne@68: proc ::itcl::delete_helper { name args } { jpayne@68: ::itcl::delete object $name jpayne@68: } jpayne@68: jpayne@68: # ---------------------------------------------------------------------- jpayne@68: # USAGE: local ? ...? jpayne@68: # jpayne@68: # Creates a new object called in class , passing jpayne@68: # the remaining 's to the constructor. Unlike the usual jpayne@68: # [incr Tcl] objects, however, an object created by this procedure jpayne@68: # will be automatically deleted when the local call frame is destroyed. jpayne@68: # This command is useful for creating objects that should only remain jpayne@68: # alive until a procedure exits. jpayne@68: # ---------------------------------------------------------------------- jpayne@68: proc ::itcl::local {class name args} { jpayne@68: set ptr [uplevel [list $class $name] $args] jpayne@68: uplevel [list set itcl-local-$ptr $ptr] jpayne@68: set cmd [uplevel namespace which -command $ptr] jpayne@68: uplevel [list trace variable itcl-local-$ptr u \ jpayne@68: "::itcl::delete_helper $cmd"] jpayne@68: return $ptr jpayne@68: } jpayne@68: jpayne@68: # ---------------------------------------------------------------------- jpayne@68: # auto_mkindex jpayne@68: # ---------------------------------------------------------------------- jpayne@68: # Define Itcl commands that will be recognized by the auto_mkindex jpayne@68: # parser in Tcl... jpayne@68: # jpayne@68: jpayne@68: # jpayne@68: # USAGE: itcl::class name body jpayne@68: # Adds an entry for the given class declaration. jpayne@68: # jpayne@68: foreach __cmd {itcl::class class itcl::type type ictl::widget widget itcl::widgetadaptor widgetadaptor itcl::extendedclass extendedclass} { jpayne@68: auto_mkindex_parser::command $__cmd {name body} { jpayne@68: variable index jpayne@68: variable scriptFile jpayne@68: append index "set [list auto_index([fullname $name])]" jpayne@68: append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n" jpayne@68: jpayne@68: variable parser jpayne@68: variable contextStack jpayne@68: set contextStack [linsert $contextStack 0 $name] jpayne@68: $parser eval $body jpayne@68: set contextStack [lrange $contextStack 1 end] jpayne@68: } jpayne@68: } jpayne@68: jpayne@68: # jpayne@68: # USAGE: itcl::body name arglist body jpayne@68: # Adds an entry for the given method/proc body. jpayne@68: # jpayne@68: foreach __cmd {itcl::body body} { jpayne@68: auto_mkindex_parser::command $__cmd {name arglist body} { jpayne@68: variable index jpayne@68: variable scriptFile jpayne@68: append index "set [list auto_index([fullname $name])]" jpayne@68: append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n" jpayne@68: } jpayne@68: } jpayne@68: jpayne@68: # jpayne@68: # USAGE: itcl::configbody name arglist body jpayne@68: # Adds an entry for the given method/proc body. jpayne@68: # jpayne@68: foreach __cmd {itcl::configbody configbody} { jpayne@68: auto_mkindex_parser::command $__cmd {name body} { jpayne@68: variable index jpayne@68: variable scriptFile jpayne@68: append index "set [list auto_index([fullname $name])]" jpayne@68: append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n" jpayne@68: } jpayne@68: } jpayne@68: jpayne@68: # jpayne@68: # USAGE: ensemble name ?body? jpayne@68: # Adds an entry to the auto index list for the given ensemble name. jpayne@68: # jpayne@68: foreach __cmd {itcl::ensemble ensemble} { jpayne@68: auto_mkindex_parser::command $__cmd {name {body ""}} { jpayne@68: variable index jpayne@68: variable scriptFile jpayne@68: append index "set [list auto_index([fullname $name])]" jpayne@68: append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n" jpayne@68: } jpayne@68: } jpayne@68: jpayne@68: # jpayne@68: # USAGE: public arg ?arg arg...? jpayne@68: # protected arg ?arg arg...? jpayne@68: # private arg ?arg arg...? jpayne@68: # jpayne@68: # Evaluates the arguments as commands, so we can recognize proc jpayne@68: # declarations within classes. jpayne@68: # jpayne@68: foreach __cmd {public protected private} { jpayne@68: auto_mkindex_parser::command $__cmd {args} { jpayne@68: variable parser jpayne@68: $parser eval $args jpayne@68: } jpayne@68: } jpayne@68: jpayne@68: # SF bug #246 unset variable __cmd to avoid problems in user programs!! jpayne@68: unset __cmd jpayne@68: jpayne@68: # ---------------------------------------------------------------------- jpayne@68: # auto_import jpayne@68: # ---------------------------------------------------------------------- jpayne@68: # This procedure overrides the usual "auto_import" function in the jpayne@68: # Tcl library. It is invoked during "namespace import" to make see jpayne@68: # if the imported commands reside in an autoloaded library. If so, jpayne@68: # stubs are created to represent the commands. Executing a stub jpayne@68: # later on causes the real implementation to be autoloaded. jpayne@68: # jpayne@68: # Arguments - jpayne@68: # pattern The pattern of commands being imported (like "foo::*") jpayne@68: # a canonical namespace as returned by [namespace current] jpayne@68: jpayne@68: proc auto_import {pattern} { jpayne@68: global auto_index jpayne@68: jpayne@68: set ns [uplevel namespace current] jpayne@68: set patternList [auto_qualify $pattern $ns] jpayne@68: jpayne@68: auto_load_index jpayne@68: jpayne@68: foreach pattern $patternList { jpayne@68: foreach name [array names auto_index $pattern] { jpayne@68: if {"" == [info commands $name]} { jpayne@68: ::itcl::import::stub create $name jpayne@68: } jpayne@68: } jpayne@68: } jpayne@68: }