Tcl Source Code

Check-in [293b4045fe]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Fixing quoting bugs in auto_mkindex slavehook: BUGID 1657
Downloads: Tarball | ZIP archive
Timelines: family | ancestors | descendants | both | core-8-1-branch-old
Files: files | file ages | folders
SHA1: 293b4045fe37e8adc334a241e05aed28dd27f919
User & Date: welch 1999-03-31 19:54:15.000
Context
1999-03-31
19:54
Tests for quoting bugs in auto_mkindex slavehook: BUGID 1657 check-in: f33978ea19 user: welch tags: core-8-1-branch-old
19:54
Fixing quoting bugs in auto_mkindex slavehook: BUGID 1657 check-in: 293b4045fe user: welch tags: core-8-1-branch-old
1999-03-30
23:56
* unix/Makefile.in: Removed trailing backslash that broke the "depend" target.

* unix/tclUnixInit.c... check-in: bffc3e18c7 user: stanton tags: core-8-1-branch-old

Changes
Unified Diff Show Whitespace Changes Patch
Changes to library/auto.tcl.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

16
17
18
19
20
21
22
# 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.1.2.7 1999/02/11 03:15:40 stanton 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 procedures that are listed in the auto-load index
# except those defined in this file.
#
# Arguments: 
# None.





|









>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
# 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.1.2.8 1999/03/31 19:54:15 welch 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 procedures that are listed in the auto-load index
# except those defined in this file.
#
# Arguments: 
# None.
32
33
34
35
36
37
38

39
40
41
42
43

44
45
46
47
48
49
50
	}
    }
    catch {unset auto_execs}
    catch {unset auto_index}
    catch {unset auto_oldpath}
}



# 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)







>
|
<



>







33
34
35
36
37
38
39
40
41

42
43
44
45
46
47
48
49
50
51
52
	}
    }
    catch {unset auto_execs}
    catch {unset auto_index}
    catch {unset auto_oldpath}
}

# 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)
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
	    $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







<


|




















>






|







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
	    $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
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
    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




    lappend initCommands [list \$parser eval $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.






proc auto_mkindex_parser::commandInit {name arglist body} {
    variable parser

    set ns [namespace qualifiers $name]
    set tail [namespace tail $name]
    if {$ns == ""} {
        set fakeName "[namespace current]::_%@fake_$tail"
    } else {
        set fakeName "_%@fake_$name"
        regsub -all {::} $fakeName "_" fakeName
        set fakeName "[namespace current]::$fakeName"
    }
    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 {[regexp {::} $name]} {
        set exportCmd [list _%@namespace export [namespace tail $name]]
        $parser eval [list _%@namespace eval $ns $exportCmd]












        set alias [namespace tail $fakeName]
        $parser invokehidden proc $name {args} [list _%@eval $alias \$args]
        $parser alias $alias $fakeName
    } else {
        $parser alias $name $fakeName
    }
    return
}








>












>







>
>
>
|



>











|
|
|






>


>
>
>
>
>















<




|



>
>
>
>
>
>
>
>
>
>
>
>

|







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
    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 == ""} {
        set fakeName "[namespace current]::_%@fake_$tail"
    } else {
        set fakeName "_%@fake_$name"
        regsub -all {::} $fakeName "_" fakeName
        set fakeName "[namespace current]::$fakeName"
    }
    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 {[regexp {::} $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
}