1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
|
# auto.tcl --
#
# utility procs formerly in init.tcl dealing with auto execution
# of commands and can be auto loaded themselves.
#
# RCS: @(#) $Id: auto.tcl,v 1.21.2.3 2005/08/02 18:16:14 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# auto_reset --
#
# Destroy all cached information for auto-loading and auto-execution,
# so that the information gets recomputed the next time it's needed.
# Also delete any commands that are listed in the auto-load index.
#
# Arguments:
# None.
proc auto_reset {} {
if {[array exists ::auto_index]} {
foreach cmdName [array names ::auto_index] {
set fqcn [namespace which $cmdName]
if {$fqcn eq ""} {continue}
rename $fqcn {}
}
}
unset -nocomplain ::auto_execs ::auto_index ::tcl::auto_oldpath
if {[catch {llength $::auto_path}]} {
set ::auto_path [list [info library]]
} else {
if {[info library] ni $::auto_path} {
lappend ::auto_path [info library]
}
}
}
# tcl_findLibrary --
#
# This is a utility for extensions that searches for a library directory
# using a canonical searching algorithm. A side effect is to source
# the initialization script and set a global library variable.
#
# Arguments:
# basename Prefix of the directory name, (e.g., "tk")
# version Version number of the package, (e.g., "8.0")
# patch Patchlevel of the package, (e.g., "8.0.3")
# initScript Initialization script to source (e.g., tk.tcl)
# enVarName environment variable to honor (e.g., TK_LIBRARY)
# varName Global variable to set when done (e.g., tk_library)
proc tcl_findLibrary {basename version patch initScript enVarName varName} {
upvar #0 $varName the_library
global env
set dirs {}
set errors {}
# The C application may have hardwired a path, which we honor
if {[info exists the_library] && $the_library ne ""} {
lappend dirs $the_library
} else {
# Do the canonical search
# 1. From an environment variable, if it exists.
# Placing this first gives the end-user ultimate control
# to work-around any bugs, or to customize.
if {[info exists env($enVarName)]} {
lappend dirs $env($enVarName)
}
# 2. In the package script directory registered within
# the configuration of the package itself.
if {[catch {
::${basename}::pkgconfig get scriptdir,runtime
} value] == 0} {
lappend dirs $value
}
# 3. Relative to auto_path directories. This checks relative to the
# Tcl library as well as allowing loading of libraries added to the
# auto_path that is not relative to the core library or binary paths.
foreach d $::auto_path {
lappend dirs [file join $d $basename$version]
if {$::tcl_platform(platform) eq "unix"
&& $::tcl_platform(os) eq "Darwin"} {
# 4. On MacOSX, check the Resources/Scripts subdir too
lappend dirs [file join $d $basename$version Resources Scripts]
}
}
# 3. Various locations relative to the executable
# ../lib/foo1.0 (From bin directory in install hierarchy)
# ../../lib/foo1.0 (From bin/arch directory in install hierarchy)
# ../library (From unix directory in build hierarchy)
#
# Remaining locations are out of date (when relevant, they ought
# to be covered by the $::auto_path seach above) and disabled.
#
# ../../library (From unix/arch directory in build hierarchy)
# ../../foo1.0.1/library
# (From unix directory in parallel build hierarchy)
# ../../../foo1.0.1/library
# (From unix/arch directory in parallel build hierarchy)
set parentDir [file dirname [file dirname [info nameofexecutable]]]
set grandParentDir [file dirname $parentDir]
lappend dirs [file join $parentDir lib $basename$version]
lappend dirs [file join $grandParentDir lib $basename$version]
lappend dirs [file join $parentDir library]
if {0} {
lappend dirs [file join $grandParentDir library]
lappend dirs [file join $grandParentDir $basename$patch library]
lappend dirs [file join [file dirname $grandParentDir] \
$basename$patch library]
}
}
# uniquify $dirs in order
array set seen {}
foreach i $dirs {
# Take note that the [file normalize] below has been noted to
# cause difficulties for the freewrap utility. See Bug 1072136.
# Until freewrap resolves the matter, one might work around the
# problem by disabling that branch.
if {[interp issafe]} {
set norm $i
} else {
set norm [file normalize $i]
}
if {[info exists seen($norm)]} { continue }
set seen($norm) ""
lappend uniqdirs $i
}
set dirs $uniqdirs
foreach i $dirs {
set the_library $i
set file [file join $i $initScript]
# source everything when in a safe interpreter because
# we have a source command, but no file exists command
if {[interp issafe] || [file exists $file]} {
if {![catch {uplevel #0 [list source $file]} msg opts]} {
return
} else {
append errors "$file: $msg\n"
append errors [dict get $opts -errorinfo]\n
}
}
}
unset -nocomplain the_library
set msg "Can't find a usable $initScript in the following directories: \n"
append msg " $dirs\n\n"
append msg "$errors\n\n"
append msg "This probably means that $basename wasn't installed properly.\n"
error $msg
}
# ----------------------------------------------------------------------
# auto_mkindex
# ----------------------------------------------------------------------
# The following procedures are used to generate the tclIndex file
# from Tcl source files. They use a special safe interpreter to
# parse Tcl source files, writing out index entries as "proc"
# commands are encountered. This implementation won't work in a
# safe interpreter, since a safe interpreter can't create the
# special parser and mess with its commands.
if {[interp issafe]} {
return ;# Stop sourcing the file here
}
# auto_mkindex --
# Regenerate a tclIndex file from Tcl source files. Takes as argument
# the name of the directory in which the tclIndex file is to be placed,
# followed by any number of glob patterns to use in that directory to
# locate all of the relevant files.
#
# Arguments:
# dir - Name of the directory in which to create an index.
# args - Any number of additional arguments giving the
# names of files within dir. If no additional
# are given auto_mkindex will look for *.tcl.
proc auto_mkindex {dir args} {
if {[interp issafe]} {
error "can't generate index within safe interpreter"
}
set oldDir [pwd]
cd $dir
set dir [pwd]
append index "# Tcl autoload index file, version 2.0\n"
append index "# This file is generated by the \"auto_mkindex\" command\n"
append index "# and sourced to set up indexing information for one or\n"
append index "# more commands. Typically each line is a command that\n"
append index "# sets an element in the auto_index array, where the\n"
append index "# element name is the name of a command and the value is\n"
append index "# a script that loads the command.\n\n"
if {[llength $args] == 0} {
set args *.tcl
}
auto_mkindex_parser::init
foreach file [glob -- {expand}$args] {
if {[catch {auto_mkindex_parser::mkindex $file} msg opts] == 0} {
append index $msg
} else {
cd $oldDir
return -options $opts $msg
}
}
auto_mkindex_parser::cleanup
set fid [open "tclIndex" w]
puts -nonewline $fid $index
close $fid
cd $oldDir
}
# Original version of auto_mkindex that just searches the source
# code for "proc" at the beginning of the line.
proc auto_mkindex_old {dir args} {
set oldDir [pwd]
cd $dir
set dir [pwd]
append index "# Tcl autoload index file, version 2.0\n"
append index "# This file is generated by the \"auto_mkindex\" command\n"
append index "# and sourced to set up indexing information for one or\n"
append index "# more commands. Typically each line is a command that\n"
append index "# sets an element in the auto_index array, where the\n"
append index "# element name is the name of a command and the value is\n"
append index "# a script that loads the command.\n\n"
if {[llength $args] == 0} {
set args *.tcl
}
foreach file [glob -- {expand}$args] {
set f ""
set error [catch {
set f [open $file]
while {[gets $f line] >= 0} {
if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} {
set procName [lindex [auto_qualify $procName "::"] 0]
append index "set [list auto_index($procName)]"
append index " \[list source \[file join \$dir [list $file]\]\]\n"
}
}
close $f
} msg opts]
if {$error} {
catch {close $f}
cd $oldDir
return -options $opts $msg
}
}
set f ""
set error [catch {
set f [open tclIndex w]
puts -nonewline $f $index
close $f
cd $oldDir
} msg opts]
if {$error} {
catch {close $f}
cd $oldDir
error $msg $info $code
return -options $opts $msg
}
}
# Create a safe interpreter that can be used to parse Tcl source files
# generate a tclIndex file for autoloading. This interp contains
# commands for things that need index entries. Each time a command
# is executed, it writes an entry out to the index file.
namespace eval auto_mkindex_parser {
variable parser "" ;# parser used to build index
variable index "" ;# maintains index as it is built
variable scriptFile "" ;# name of file being processed
variable contextStack "" ;# stack of namespace scopes
variable imports "" ;# keeps track of all imported cmds
variable initCommands ;# list of commands that create aliases
if {![info exists initCommands]} {
set initCommands [list]
}
proc init {} {
variable parser
variable initCommands
if {![interp issafe]} {
set parser [interp create -safe]
$parser hide info
$parser hide rename
$parser hide proc
$parser hide namespace
$parser hide eval
$parser hide puts
$parser invokehidden namespace delete ::
$parser invokehidden proc unknown {args} {}
# We'll need access to the "namespace" command within the
# interp. Put it back, but move it out of the way.
$parser expose namespace
$parser invokehidden rename namespace _%@namespace
$parser expose eval
$parser invokehidden rename eval _%@eval
# Install all the registered psuedo-command implementations
foreach cmd $initCommands {
eval $cmd
}
}
}
proc cleanup {} {
variable parser
interp delete $parser
unset parser
}
}
# auto_mkindex_parser::mkindex --
#
# Used by the "auto_mkindex" command to create a "tclIndex" file for
# the given Tcl source file. Executes the commands in the file, and
# handles things like the "proc" command by adding an entry for the
# index file. Returns a string that represents the index file.
#
# Arguments:
# file Name of Tcl source file to be indexed.
proc auto_mkindex_parser::mkindex {file} {
variable parser
variable index
variable scriptFile
variable contextStack
variable imports
set scriptFile $file
set fid [open $file]
set contents [read $fid]
close $fid
# There is one problem with sourcing files into the safe
# interpreter: references like "$x" will fail since code is not
# really being executed and variables do not really exist.
# To avoid this, we replace all $ with \0 (literally, the null char)
# later, when getting proc names we will have to reverse this replacement,
# in case there were any $ in the proc name. This will cause a problem
# if somebody actually tries to have a \0 in their proc name. Too bad
# for them.
set contents [string map [list \$ \0] $contents]
set index ""
set contextStack ""
set imports ""
$parser eval $contents
foreach name $imports {
catch {$parser eval [list _%@namespace forget $name]}
}
return $index
}
# auto_mkindex_parser::hook command
#
# Registers a Tcl command to evaluate when initializing the
# slave interpreter used by the mkindex parser.
# The command is evaluated in the master interpreter, and can
# use the variable auto_mkindex_parser::parser to get to the slave
proc auto_mkindex_parser::hook {cmd} {
variable initCommands
lappend initCommands $cmd
}
# auto_mkindex_parser::slavehook command
#
# Registers a Tcl command to evaluate when initializing the
# slave interpreter used by the mkindex parser.
# The command is evaluated in the slave interpreter.
proc auto_mkindex_parser::slavehook {cmd} {
variable initCommands
# The $parser variable is defined to be the name of the
# slave interpreter when this command is used later.
lappend initCommands "\$parser eval [list $cmd]"
}
# auto_mkindex_parser::command --
#
# Registers a new command with the "auto_mkindex_parser" interpreter
# that parses Tcl files. These commands are fake versions of things
# like the "proc" command. When you execute them, they simply write
# out an entry to a "tclIndex" file for auto-loading.
#
# This procedure allows extensions to register their own commands
# with the auto_mkindex facility. For example, a package like
# [incr Tcl] might register a "class" command so that class definitions
# could be added to a "tclIndex" file for auto-loading.
#
# Arguments:
# name Name of command recognized in Tcl files.
# arglist Argument list for command.
# body Implementation of command to handle indexing.
proc auto_mkindex_parser::command {name arglist body} {
hook [list auto_mkindex_parser::commandInit $name $arglist $body]
}
# auto_mkindex_parser::commandInit --
#
# This does the actual work set up by auto_mkindex_parser::command
# This is called when the interpreter used by the parser is created.
#
# Arguments:
# name Name of command recognized in Tcl files.
# arglist Argument list for command.
# body Implementation of command to handle indexing.
proc auto_mkindex_parser::commandInit {name arglist body} {
variable parser
set ns [namespace qualifiers $name]
set tail [namespace tail $name]
if {$ns eq ""} {
set fakeName [namespace current]::_%@fake_$tail
} else {
set fakeName [namespace current]::[string map {:: _} _%@fake_$name]
}
proc $fakeName $arglist $body
# YUK! Tcl won't let us alias fully qualified command names,
# so we can't handle names like "::itcl::class". Instead,
# we have to build procs with the fully qualified names, and
# have the procs point to the aliases.
if {[string match *::* $name]} {
set exportCmd [list _%@namespace export [namespace tail $name]]
$parser eval [list _%@namespace eval $ns $exportCmd]
# The following proc definition does not work if you
# want to tolerate space or something else diabolical
# in the procedure name, (i.e., space in $alias)
# The following does not work:
# "_%@eval {$alias} \$args"
# because $alias gets concat'ed to $args.
# The following does not work because $cmd is somehow undefined
# "set cmd {$alias} \; _%@eval {\$cmd} \$args"
# A gold star to someone that can make test
# autoMkindex-3.3 work properly
set alias [namespace tail $fakeName]
$parser invokehidden proc $name {args} "_%@eval {$alias} \$args"
$parser alias $alias $fakeName
} else {
$parser alias $name $fakeName
}
return
}
# auto_mkindex_parser::fullname --
# Used by commands like "proc" within the auto_mkindex parser.
# Returns the qualified namespace name for the "name" argument.
# If the "name" does not start with "::", elements are added from
# the current namespace stack to produce a qualified name. Then,
# the name is examined to see whether or not it should really be
# qualified. If the name has more than the leading "::", it is
# returned as a fully qualified name. Otherwise, it is returned
# as a simple name. That way, the Tcl autoloader will recognize
# it properly.
#
# Arguments:
# name - Name that is being added to index.
proc auto_mkindex_parser::fullname {name} {
variable contextStack
if {![string match ::* $name]} {
foreach ns $contextStack {
set name "${ns}::$name"
if {[string match ::* $name]} {
break
}
}
}
if {[namespace qualifiers $name] eq ""} {
set name [namespace tail $name]
} elseif {![string match ::* $name]} {
set name "::$name"
}
# Earlier, mkindex replaced all $'s with \0. Now, we have to reverse
# that replacement.
return [string map [list \0 \$] $name]
}
if {[llength $::auto_mkindex_parser::initCommands]} {
return
}
# Register all of the procedures for the auto_mkindex parser that
# will build the "tclIndex" file.
# AUTO MKINDEX: proc name arglist body
# Adds an entry to the auto index list for the given procedure name.
auto_mkindex_parser::command proc {name args} {
variable index
variable scriptFile
# Do some fancy reformatting on the "source" call to handle platform
# differences with respect to pathnames. Use format just so that the
# command is a little easier to read (otherwise it'd be full of
# backslashed dollar signs, etc.
append index [list set auto_index([fullname $name])] \
[format { [list source [file join $dir %s]]} \
[file split $scriptFile]] "\n"
}
# Conditionally add support for Tcl byte code files. There are some
# tricky details here. First, we need to get the tbcload library
# initialized in the current interpreter. We cannot load tbcload into the
# slave until we have done so because it needs access to the tcl_patchLevel
# variable. Second, because the package index file may defer loading the
# library until we invoke a command, we need to explicitly invoke auto_load
# to force it to be loaded. This should be a noop if the package has
# already been loaded
auto_mkindex_parser::hook {
if {![catch {package require tbcload}]} {
if {[namespace which -command tbcload::bcproc] eq ""} {
auto_load tbcload::bcproc
}
load {} tbcload $auto_mkindex_parser::parser
# AUTO MKINDEX: tbcload::bcproc name arglist body
# Adds an entry to the auto index list for the given pre-compiled
# procedure name.
auto_mkindex_parser::commandInit tbcload::bcproc {name args} {
variable index
variable scriptFile
# Do some nice reformatting of the "source" call, to get around
# path differences on different platforms. We use the format
# command just so that the code is a little easier to read.
append index [list set auto_index([fullname $name])] \
[format { [list source [file join $dir %s]]} \
[file split $scriptFile]] "\n"
}
}
}
# AUTO MKINDEX: namespace eval name command ?arg arg...?
# Adds the namespace name onto the context stack and evaluates the
# associated body of commands.
#
# AUTO MKINDEX: namespace import ?-force? pattern ?pattern...?
# Performs the "import" action in the parser interpreter. This is
# important for any commands contained in a namespace that affect
# the index. For example, a script may say "itcl::class ...",
# or it may import "itcl::*" and then say "class ...". This
# procedure does the import operation, but keeps track of imported
# patterns so we can remove the imports later.
auto_mkindex_parser::command namespace {op args} {
switch -- $op {
eval {
variable parser
variable contextStack
set name [lindex $args 0]
set args [lrange $args 1 end]
set contextStack [linsert $contextStack 0 $name]
$parser eval [list _%@namespace eval $name] $args
set contextStack [lrange $contextStack 1 end]
}
import {
variable parser
variable imports
foreach pattern $args {
if {$pattern ne "-force"} {
lappend imports $pattern
}
}
catch {$parser eval "_%@namespace import $args"}
}
}
}
return
|