Tcl Source Code

Check-in [ac72bff2f1]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

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

Overview
Comment:merged auto_mkindex fix into the 8.0.5 release branch
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | core-8-0-5-branch | scriptics-tclpro-1-2-b2
Files: files | file ages | folders
SHA1: ac72bff2f12b1506cf2d8132335665057710e301
User & Date: stanton 1999-02-11 03:06:23
Context
1999-02-19
02:17
changed so helpfile generation can work from the build environment check-in: 29c3f02f33 user: stanton tags: core-8-0-5-branch
1999-02-11
03:06
merged auto_mkindex fix into the 8.0.5 release branch check-in: ac72bff2f1 user: stanton tags: core-8-0-5-branch, scriptics-tclpro-1-2-b2
1999-02-09
03:31
updated readmes for 8.0.5 release check-in: 8b5b3b65b5 user: stanton tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to library/init.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
...
717
718
719
720
721
722
723

724
725
726
727
728
729
730
...
803
804
805
806
807
808
809

810
811
812

813
814
815
816
817
818
819
...
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
...
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
....
1003
1004
1005
1006
1007
1008
1009
1010
1011





























1012
1013
1014
1015
1016
1017
1018
....
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
# init.tcl --
#
# Default system startup file for Tcl-based applications.  Defines
# "unknown" procedure and auto-load facilities.
#
# RCS: @(#) $Id: init.tcl,v 1.25 1999/02/02 22:28:10 stanton Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
................................................................................
	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 {$args == ""} {
	    set args *.tcl
	}

	auto_mkindex_parser::init
	foreach file [eval glob $args] {
	    if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} {
		append index $msg
	    } else {
		set code $errorCode
		set info $errorInfo
................................................................................
    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

	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
................................................................................
    # 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 "\$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.
................................................................................
	# 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} "_%@eval $alias \$args"
	    $parser alias $alias $fakeName
	} else {
	    $parser alias $name $fakeName
	}
	return
    }

................................................................................

    # 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
	append index "set [list auto_index([fullname $name])]"
	append index " \[list source \[file join \$dir [list $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...?
................................................................................
		variable parser
		variable contextStack

		set name [lindex $args 0]
		set args [lrange $args 1 end]

		set contextStack [linsert $contextStack 0 $name]
		if {[llength $args] == 1} {
		    $parser eval [lindex $args 0]
		} else {
		    eval $parser eval $args
		}
		set contextStack [lrange $contextStack 1 end]
	    }
	    import {
		variable parser
		variable imports
		foreach pattern $args {
		    if {$pattern != "-force"} {
			lappend imports $pattern
		    }
		}
		catch {$parser eval "_%@namespace import $args"}
	    }
	}
    }

# Close of the if ![interp issafe] block
}





|







 







>







 







>



>







 







|







 







|







 







|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







<
|
<
<
<










|







1
2
3
4
5
6
7
8
9
10
11
12
13
...
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
...
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
...
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
...
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
....
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
....
1061
1062
1063
1064
1065
1066
1067

1068



1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
# init.tcl --
#
# Default system startup file for Tcl-based applications.  Defines
# "unknown" procedure and auto-load facilities.
#
# RCS: @(#) $Id: init.tcl,v 1.25.2.1 1999/02/11 03:06:23 stanton Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
................................................................................
	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 {$args == ""} {
	    set args *.tcl
	}

	auto_mkindex_parser::init
	foreach file [eval glob $args] {
	    if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} {
		append index $msg
	    } else {
		set code $errorCode
		set info $errorInfo
................................................................................
    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

	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
................................................................................
    # 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.
................................................................................
	# 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
    }

................................................................................

    # 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
	append index [list set auto_index([fullname $name])] \
		" \[list source \[file join \$dir [list $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 {[info commands tbcload::bcproc] == ""} {
		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
		append index [list set auto_index([fullname $name])] \
			" \[list source \[file join \$dir [list $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...?
................................................................................
		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 != "-force"} {
			lappend imports $pattern
		    }
		}
		catch {$parser eval [list _%@namespace import] $args}
	    }
	}
    }

# Close of the if ![interp issafe] block
}