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