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