|
| 1 | +# |
| 2 | +# itcl.tcl |
| 3 | +# ---------------------------------------------------------------------- |
| 4 | +# Invoked automatically upon startup to customize the interpreter |
| 5 | +# for [incr Tcl]. |
| 6 | +# ---------------------------------------------------------------------- |
| 7 | +# AUTHOR: Michael J. McLennan |
| 8 | +# Bell Labs Innovations for Lucent Technologies |
| 9 | +# mmclennan@lucent.com |
| 10 | +# http://www.tcltk.com/itcl |
| 11 | +# ---------------------------------------------------------------------- |
| 12 | +# Copyright (c) 1993-1998 Lucent Technologies, Inc. |
| 13 | +# ====================================================================== |
| 14 | +# See the file "license.terms" for information on usage and |
| 15 | +# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
| 16 | + |
| 17 | +proc ::itcl::delete_helper { name args } { |
| 18 | + ::itcl::delete object $name |
| 19 | +} |
| 20 | + |
| 21 | +# ---------------------------------------------------------------------- |
| 22 | +# USAGE: local <className> <objName> ?<arg> <arg>...? |
| 23 | +# |
| 24 | +# Creates a new object called <objName> in class <className>, passing |
| 25 | +# the remaining <arg>'s to the constructor. Unlike the usual |
| 26 | +# [incr Tcl] objects, however, an object created by this procedure |
| 27 | +# will be automatically deleted when the local call frame is destroyed. |
| 28 | +# This command is useful for creating objects that should only remain |
| 29 | +# alive until a procedure exits. |
| 30 | +# ---------------------------------------------------------------------- |
| 31 | +proc ::itcl::local {class name args} { |
| 32 | + set ptr [uplevel [list $class $name] $args] |
| 33 | + uplevel [list set itcl-local-$ptr $ptr] |
| 34 | + set cmd [uplevel namespace which -command $ptr] |
| 35 | + uplevel [list trace variable itcl-local-$ptr u \ |
| 36 | + "::itcl::delete_helper $cmd"] |
| 37 | + return $ptr |
| 38 | +} |
| 39 | + |
| 40 | +# ---------------------------------------------------------------------- |
| 41 | +# auto_mkindex |
| 42 | +# ---------------------------------------------------------------------- |
| 43 | +# Define Itcl commands that will be recognized by the auto_mkindex |
| 44 | +# parser in Tcl... |
| 45 | +# |
| 46 | + |
| 47 | +# |
| 48 | +# USAGE: itcl::class name body |
| 49 | +# Adds an entry for the given class declaration. |
| 50 | +# |
| 51 | +foreach cmd {itcl::class class itcl::type type ictl::widget widget itcl::widgetadaptor widgetadaptor itcl::extendedclass extendedclass} { |
| 52 | + auto_mkindex_parser::command $cmd {name body} { |
| 53 | + variable index |
| 54 | + variable scriptFile |
| 55 | + append index "set [list auto_index([fullname $name])]" |
| 56 | + append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n" |
| 57 | + |
| 58 | + variable parser |
| 59 | + variable contextStack |
| 60 | + set contextStack [linsert $contextStack 0 $name] |
| 61 | + $parser eval $body |
| 62 | + set contextStack [lrange $contextStack 1 end] |
| 63 | + } |
| 64 | +} |
| 65 | + |
| 66 | +# |
| 67 | +# USAGE: itcl::body name arglist body |
| 68 | +# Adds an entry for the given method/proc body. |
| 69 | +# |
| 70 | +foreach cmd {itcl::body body} { |
| 71 | + auto_mkindex_parser::command $cmd {name arglist body} { |
| 72 | + variable index |
| 73 | + variable scriptFile |
| 74 | + append index "set [list auto_index([fullname $name])]" |
| 75 | + append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n" |
| 76 | + } |
| 77 | +} |
| 78 | + |
| 79 | +# |
| 80 | +# USAGE: itcl::configbody name arglist body |
| 81 | +# Adds an entry for the given method/proc body. |
| 82 | +# |
| 83 | +foreach cmd {itcl::configbody configbody} { |
| 84 | + auto_mkindex_parser::command $cmd {name body} { |
| 85 | + variable index |
| 86 | + variable scriptFile |
| 87 | + append index "set [list auto_index([fullname $name])]" |
| 88 | + append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n" |
| 89 | + } |
| 90 | +} |
| 91 | + |
| 92 | +# |
| 93 | +# USAGE: ensemble name ?body? |
| 94 | +# Adds an entry to the auto index list for the given ensemble name. |
| 95 | +# |
| 96 | +foreach cmd {itcl::ensemble ensemble} { |
| 97 | + auto_mkindex_parser::command $cmd {name {body ""}} { |
| 98 | + variable index |
| 99 | + variable scriptFile |
| 100 | + append index "set [list auto_index([fullname $name])]" |
| 101 | + append index " \[list source \[file join \$dir [list $scriptFile]\]\]\n" |
| 102 | + } |
| 103 | +} |
| 104 | + |
| 105 | +# |
| 106 | +# USAGE: public arg ?arg arg...? |
| 107 | +# protected arg ?arg arg...? |
| 108 | +# private arg ?arg arg...? |
| 109 | +# |
| 110 | +# Evaluates the arguments as commands, so we can recognize proc |
| 111 | +# declarations within classes. |
| 112 | +# |
| 113 | +foreach cmd {public protected private} { |
| 114 | + auto_mkindex_parser::command $cmd {args} { |
| 115 | + variable parser |
| 116 | + $parser eval $args |
| 117 | + } |
| 118 | +} |
| 119 | + |
| 120 | +# ---------------------------------------------------------------------- |
| 121 | +# auto_import |
| 122 | +# ---------------------------------------------------------------------- |
| 123 | +# This procedure overrides the usual "auto_import" function in the |
| 124 | +# Tcl library. It is invoked during "namespace import" to make see |
| 125 | +# if the imported commands reside in an autoloaded library. If so, |
| 126 | +# stubs are created to represent the commands. Executing a stub |
| 127 | +# later on causes the real implementation to be autoloaded. |
| 128 | +# |
| 129 | +# Arguments - |
| 130 | +# pattern The pattern of commands being imported (like "foo::*") |
| 131 | +# a canonical namespace as returned by [namespace current] |
| 132 | + |
| 133 | +proc auto_import {pattern} { |
| 134 | + global auto_index |
| 135 | + |
| 136 | + set ns [uplevel namespace current] |
| 137 | + set patternList [auto_qualify $pattern $ns] |
| 138 | + |
| 139 | + auto_load_index |
| 140 | + |
| 141 | + foreach pattern $patternList { |
| 142 | + foreach name [array names auto_index $pattern] { |
| 143 | + if {"" == [info commands $name]} { |
| 144 | + ::itcl::import::stub create $name |
| 145 | + } |
| 146 | + } |
| 147 | + } |
| 148 | +} |
0 commit comments