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