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