diff options
Diffstat (limited to 'library')
| -rw-r--r-- | library/auto.tcl | 341 | ||||
| -rwxr-xr-x[-rw-r--r--] | library/clock.tcl | 1060 | ||||
| -rw-r--r-- | library/dde/pkgIndex.tcl | 10 | ||||
| -rw-r--r-- | library/history.tcl | 302 | ||||
| -rw-r--r-- | library/http/http.tcl | 323 | ||||
| -rw-r--r-- | library/http/pkgIndex.tcl | 6 | ||||
| -rw-r--r-- | library/http1.0/http.tcl | 6 | ||||
| -rw-r--r-- | library/init.tcl | 37 | ||||
| -rw-r--r-- | library/msgcat/msgcat.tcl | 731 | ||||
| -rw-r--r-- | library/msgcat/pkgIndex.tcl | 2 | ||||
| -rw-r--r-- | library/opt/optparse.tcl | 474 | ||||
| -rw-r--r-- | library/opt/pkgIndex.tcl | 2 | ||||
| -rw-r--r-- | library/package.tcl | 282 | ||||
| -rwxr-xr-x | library/reg/pkgIndex.tcl | 14 | ||||
| -rw-r--r-- | library/safe.tcl | 180 | ||||
| -rw-r--r-- | library/tclIndex | 20 | ||||
| -rw-r--r-- | library/tcltest/pkgIndex.tcl | 2 | ||||
| -rw-r--r-- | library/tcltest/tcltest.tcl | 78 | ||||
| -rw-r--r-- | library/tm.tcl | 230 |
19 files changed, 2287 insertions, 1813 deletions
diff --git a/library/auto.tcl b/library/auto.tcl index ec680de..02edcc4 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -1,20 +1,20 @@ # auto.tcl -- # -# utility procs formerly in init.tcl dealing with auto execution -# of commands and can be auto loaded themselves. +# utility procs formerly in init.tcl dealing with auto execution of commands +# and can be auto loaded themselves. # # 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. +# 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. +# 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. @@ -24,25 +24,25 @@ proc auto_reset {} { if {[array exists auto_index]} { foreach cmdName [array names auto_index] { set fqcn [namespace which $cmdName] - if {$fqcn eq ""} {continue} + 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] - } + } elseif {[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. +# 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") @@ -64,24 +64,21 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} { 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. + # 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. + # 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 + catch { + lappend dirs [::${basename}::pkgconfig get scriptdir,runtime] } # 3. Relative to auto_path directories. This checks relative to the @@ -101,8 +98,8 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} { # ../../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. + # 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 @@ -125,17 +122,19 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} { # 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. + # 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) "" + if {[info exists seen($norm)]} { + continue + } + set seen($norm) {} lappend uniqdirs $i } set dirs $uniqdirs @@ -143,16 +142,15 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} { 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 + # 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 } + append errors "$file: $msg\n" + append errors [dict get $opts -errorinfo]\n } } unset -nocomplain the_library @@ -167,28 +165,28 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} { # ---------------------------------------------------------------------- # 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. +# 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. +# 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. + +# 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]} { @@ -197,7 +195,6 @@ proc auto_mkindex {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" @@ -206,18 +203,18 @@ proc auto_mkindex {dir args} { 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} { + if {![llength $args]} { set args *.tcl } auto_mkindex_parser::init foreach file [glob -- {*}$args] { - if {[catch {auto_mkindex_parser::mkindex $file} msg opts] == 0} { - append index $msg - } else { - cd $oldDir + try { + append index [auto_mkindex_parser::mkindex $file] + } on error {msg opts} { + cd $oldDir return -options $opts $msg - } + } } auto_mkindex_parser::cleanup @@ -227,8 +224,8 @@ proc auto_mkindex {dir args} { cd $oldDir } -# Original version of auto_mkindex that just searches the source -# code for "proc" at the beginning of the line. +# 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] @@ -241,7 +238,7 @@ proc auto_mkindex_old {dir args} { 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} { + if {![llength $args]} { set args *.tcl } foreach file [glob -- {*}$args] { @@ -279,9 +276,9 @@ proc auto_mkindex_old {dir args} { } # 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. +# 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 @@ -306,7 +303,14 @@ namespace eval auto_mkindex_parser { $parser hide namespace $parser hide eval $parser hide puts - $parser invokehidden namespace delete :: + foreach ns [$parser invokehidden namespace children ::] { + # MUST NOT DELETE "::tcl" OR BAD THINGS HAPPEN! + if {$ns eq "::tcl"} continue + $parser invokehidden namespace delete $ns + } + foreach cmd [$parser invokehidden info commands ::*] { + $parser invokehidden rename $cmd {} + } $parser invokehidden proc unknown {args} {} # We'll need access to the "namespace" command within the @@ -333,10 +337,10 @@ namespace eval auto_mkindex_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. +# 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. @@ -354,14 +358,13 @@ proc auto_mkindex_parser::mkindex {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. + # 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 "" @@ -378,10 +381,10 @@ proc auto_mkindex_parser::mkindex {file} { # 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 +# 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 @@ -391,30 +394,30 @@ proc auto_mkindex_parser::hook {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. +# 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. + # 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. +# 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. +# 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. @@ -427,8 +430,8 @@ proc auto_mkindex_parser::command {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. +# 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. @@ -447,25 +450,23 @@ proc auto_mkindex_parser::commandInit {name arglist body} { } 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. + # 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: + # 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 + # 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 + # 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" @@ -477,15 +478,14 @@ proc auto_mkindex_parser::commandInit {name arglist body} { } # 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. +# +# 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. @@ -508,44 +508,65 @@ proc auto_mkindex_parser::fullname {name} { set name "::$name" } - # Earlier, mkindex replaced all $'s with \0. Now, we have to reverse - # that replacement. + # Earlier, mkindex replaced all $'s with \0. Now, we have to reverse that + # replacement. return [string map [list \0 \$] $name] } +# auto_mkindex_parser::indexEntry -- +# +# Used by commands like "proc" within the auto_mkindex parser to add a +# correctly-quoted entry to the index. This is shared code so it is done +# *right*, in one place. +# +# Arguments: +# name - Name that is being added to index. + +proc auto_mkindex_parser::indexEntry {name} { + variable index + variable scriptFile + + # We convert all metacharacters to their backslashed form, and pre-split + # the file name that we know about (which will be a proper list, and so + # correctly quoted). + + set name [string range [list \}[fullname $name]] 2 end] + set filenameParts [file split $scriptFile] + + append index [format \ + {set auto_index(%s) [list source [file join $dir %s]]%s} \ + $name $filenameParts \n] + return +} + if {[llength $::auto_mkindex_parser::initCommands]} { return } -# Register all of the procedures for the auto_mkindex parser that -# will build the "tclIndex" file. +# 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" + indexEntry $name } -# 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 +# 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}]} { + try { + package require tbcload + } on error {} { + # OK, don't have it so do nothing + } on ok {} { if {[namespace which -command tbcload::bcproc] eq ""} { auto_load tbcload::bcproc } @@ -556,29 +577,21 @@ auto_mkindex_parser::hook { # 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" + indexEntry $name } } } # AUTO MKINDEX: namespace eval name command ?arg arg...? -# Adds the namespace name onto the context stack and evaluates the -# associated body of commands. +# 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. +# 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 { @@ -608,6 +621,13 @@ auto_mkindex_parser::command namespace {op args} { variable contextStack if {[lindex $args 0] eq "create"} { set name ::[join [lreverse $contextStack] ::] + catch { + set name [dict get [lrange $args 1 end] -command] + if {![string match ::* $name]} { + set name ::[join [lreverse $contextStack] ::]$name + } + regsub -all ::+ $name :: name + } # create artifical proc to force an entry in the tclIndex $parser eval [list ::proc $name {} {}] } @@ -615,4 +635,17 @@ auto_mkindex_parser::command namespace {op args} { } } +# AUTO MKINDEX: oo::class create name ?definition? +# Adds an entry to the auto index list for the given class name. +auto_mkindex_parser::command oo::class {op name {body ""}} { + if {$op eq "create"} { + indexEntry $name + } +} +auto_mkindex_parser::command class {op name {body ""}} { + if {$op eq "create"} { + indexEntry $name + } +} + return diff --git a/library/clock.tcl b/library/clock.tcl index eb87251..8e4b657 100644..100755 --- a/library/clock.tcl +++ b/library/clock.tcl @@ -2,9 +2,9 @@ # # clock.tcl -- # -# This file implements the portions of the [clock] ensemble that -# are coded in Tcl. Refer to the users' manual to see the description -# of the [clock] command and its subcommands. +# This file implements the portions of the [clock] ensemble that are +# coded in Tcl. Refer to the users' manual to see the description of +# the [clock] command and its subcommands. # # #---------------------------------------------------------------------- @@ -15,11 +15,11 @@ # #---------------------------------------------------------------------- -# We must have message catalogs that support the root locale, and -# we need access to the Registry on Windows systems. +# We must have message catalogs that support the root locale, and we need +# access to the Registry on Windows systems. uplevel \#0 { - package require msgcat 1.4 + package require msgcat 1.6 if { $::tcl_platform(platform) eq {windows} } { if { [catch { package require registry 1.1 }] } { namespace eval ::tcl::clock [list variable NoRegistry {}] @@ -27,9 +27,8 @@ uplevel \#0 { } } -# Put the library directory into the namespace for the ensemble -# so that the library code can find message catalogs and time zone -# definition files. +# Put the library directory into the namespace for the ensemble so that the +# library code can find message catalogs and time zone definition files. namespace eval ::tcl::clock \ [list variable LibDir [file dirname [info script]]] @@ -40,8 +39,8 @@ namespace eval ::tcl::clock \ # # Manipulate times. # -# The 'clock' command manipulates time. Refer to the user documentation -# for the available subcommands and what they do. +# The 'clock' command manipulates time. Refer to the user documentation for +# the available subcommands and what they do. # #---------------------------------------------------------------------- @@ -61,6 +60,8 @@ namespace eval ::tcl::clock { namespace import ::msgcat::mcload namespace import ::msgcat::mclocale + namespace import ::msgcat::mc + namespace import ::msgcat::mcpackagelocale } @@ -76,11 +77,11 @@ namespace eval ::tcl::clock { # Side effects: # Namespace variable in the 'clock' subsystem are initialized. # -# The '::tcl::clock::Initialize' procedure initializes the namespace -# variables and root locale message catalog for the 'clock' subsystem. -# It is broken into a procedure rather than simply evaluated as a script -# so that it will be able to use local variables, avoiding the dangers -# of 'creative writing' as in Bug 1185933. +# The '::tcl::clock::Initialize' procedure initializes the namespace variables +# and root locale message catalog for the 'clock' subsystem. It is broken +# into a procedure rather than simply evaluated as a script so that it will be +# able to use local variables, avoiding the dangers of 'creative writing' as +# in Bug 1185933. # #---------------------------------------------------------------------- @@ -107,6 +108,11 @@ proc ::tcl::clock::Initialize {} { } InitTZData + mcpackagelocale set {} + ::msgcat::mcpackageconfig set mcfolder [file join $LibDir msgs] + ::msgcat::mcpackageconfig set unknowncmd "" + ::msgcat::mcpackageconfig set changecmd ChangeCurrentLocale + # Define the message catalog for the root locale. ::msgcat::mcmset {} { @@ -172,8 +178,8 @@ proc ::tcl::clock::Initialize {} { ::msgcat::mcset fr GREGORIAN_CHANGE_DATE 2299227 - # For Belgium, we follow Southern Netherlands; Liege Diocese - # changed several weeks later. + # For Belgium, we follow Southern Netherlands; Liege Diocese changed + # several weeks later. ::msgcat::mcset fr_BE GREGORIAN_CHANGE_DATE 2299238 ::msgcat::mcset nl_BE GREGORIAN_CHANGE_DATE 2299238 @@ -194,8 +200,8 @@ proc ::tcl::clock::Initialize {} { ::msgcat::mcset no GREGORIAN_CHANGE_DATE 2342032 ::msgcat::mcset da GREGORIAN_CHANGE_DATE 2342032 - # Holland (Brabant, Gelderland, Flanders, Friesland, etc. changed - # at various times) + # Holland (Brabant, Gelderland, Flanders, Friesland, etc. changed at + # various times) ::msgcat::mcset nl GREGORIAN_CHANGE_DATE 2342165 @@ -217,8 +223,8 @@ proc ::tcl::clock::Initialize {} { ::msgcat::mcset ru GREGORIAN_CHANGE_DATE 2421639 - # Romania (Transylvania changed earler - perhaps de_RO should show - # the earlier date?) + # Romania (Transylvania changed earler - perhaps de_RO should show the + # earlier date?) ::msgcat::mcset ro GREGORIAN_CHANGE_DATE 2422063 @@ -232,8 +238,8 @@ proc ::tcl::clock::Initialize {} { # #------------------------------------------------------------------ - # Paths at which binary time zone data for the Olson libraries - # are known to reside on various operating systems + # Paths at which binary time zone data for the Olson libraries are known + # to reside on various operating systems variable ZoneinfoPaths {} foreach path { @@ -250,7 +256,6 @@ proc ::tcl::clock::Initialize {} { # Define the directories for time zone data and message catalogs. variable DataDir [file join $LibDir tzdata] - variable MsgDir [file join $LibDir msgs] # Number of days in the months, in common years and leap years. @@ -282,10 +287,10 @@ proc ::tcl::clock::Initialize {} { variable FEB_28 58 - # Translation table to map Windows TZI onto cities, so that - # the Olson rules can apply. In some cases the mapping is ambiguous, - # so it's wise to specify $::env(TCL_TZ) rather than simply depending - # on the system time zone. + # Translation table to map Windows TZI onto cities, so that the Olson + # rules can apply. In some cases the mapping is ambiguous, so it's wise + # to specify $::env(TCL_TZ) rather than simply depending on the system + # time zone. # The keys are long lists of values obtained from the time zone # information in the Registry. In order, the list elements are: @@ -296,10 +301,10 @@ proc ::tcl::clock::Initialize {} { # DaylightDate.wYear DaylightDate.wMonth DaylightDate.wDayOfWeek # DaylightDate.wDay DaylightDate.wHour DaylightDate.wMinute # DaylightDate.wSecond DaylightDate.wMilliseconds - # The values are the names of time zones where those rules apply. - # There is considerable ambiguity in certain zones; an attempt has - # been made to make a reasonable guess, but this table needs to be - # taken with a grain of salt. + # The values are the names of time zones where those rules apply. There + # is considerable ambiguity in certain zones; an attempt has been made to + # make a reasonable guess, but this table needs to be taken with a grain + # of salt. variable WinZoneInfo [dict create {*}{ {-43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Kwajalein @@ -378,10 +383,10 @@ proc ::tcl::clock::Initialize {} { {46800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Tongatapu }] - # Groups of fields that specify the date, priorities, and - # code bursts that determine Julian Day Number given those groups. - # The code in [clock scan] will choose the highest priority - # (lowest numbered) set of fields that determines the date. + # Groups of fields that specify the date, priorities, and code bursts that + # determine Julian Day Number given those groups. The code in [clock + # scan] will choose the highest priority (lowest numbered) set of fields + # that determines the date. variable DateParseActions { @@ -485,8 +490,8 @@ proc ::tcl::clock::Initialize {} { } } - # Groups of fields that specify time of day, priorities, - # and code that processes them + # Groups of fields that specify time of day, priorities, and code that + # processes them variable TimeParseActions { @@ -624,11 +629,6 @@ proc ::tcl::clock::Initialize {} { # in the given locales and dictionaries # mapping the numerals to their numeric # values. - variable McLoaded {}; # Dictionary whose keys are locales - # in which [mcload] has been executed - # and whose values are second-level - # dictionaries indexed by message - # name and giving message text. # variable CachedSystemTimeZone; # If 'CachedSystemTimeZone' exists, # it contains the value of the # system time zone, as determined from @@ -652,11 +652,10 @@ proc ::tcl::clock::Initialize {} { # # clock format -- # -# Formats a count of seconds since the Posix Epoch as a time -# of day. +# Formats a count of seconds since the Posix Epoch as a time of day. # -# The 'clock format' command formats times of day for output. -# Refer to the user documentation to see what it does. +# The 'clock format' command formats times of day for output. Refer to the +# user documentation to see what it does. # #---------------------------------------------------------------------- @@ -681,9 +680,9 @@ proc ::tcl::clock::format { args } { } } - # Build a procedure to format the result. Cache the built procedure's - # name in the 'FormatProc' array to avoid losing its internal - # representation, which contains the name resolution. + # Build a procedure to format the result. Cache the built procedure's name + # in the 'FormatProc' array to avoid losing its internal representation, + # which contains the name resolution. set procName formatproc'$format'$locale set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName] @@ -721,38 +720,19 @@ proc ::tcl::clock::ParseClockFormatFormat {procName format locale} { # Map away the locale-dependent composite format groups - EnterLocale $locale oldLocale + EnterLocale $locale # Change locale if a fresh locale has been given on the command line. - set status [catch { - - ParseClockFormatFormat2 $format $locale $procName - - } result opts] - - # Restore the locale - - if { [info exists oldLocale] } { - mclocale $oldLocale - } - - # Return either the error or the proc name - - if { $status == 1 } { - if { [lindex [dict get $opts -errorcode] 0] eq {clock} } { - return -code error $result - } else { - return -options $opts $result - } - } else { - return $result + try { + return [ParseClockFormatFormat2 $format $locale $procName] + } trap CLOCK {result opts} { + dict unset opts -errorinfo + return -options $opts $result } - } proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { - set didLocaleEra 0 set didLocaleNumerals 0 set preFormatCode \ @@ -1191,11 +1171,10 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { # # clock scan -- # -# Inputs a count of seconds since the Posix Epoch as a time -# of day. +# Inputs a count of seconds since the Posix Epoch as a time of day. # -# The 'clock format' command scans times of day on input. -# Refer to the user documentation to see what it does. +# The 'clock format' command scans times of day on input. Refer to the user +# documentation to see what it does. # #---------------------------------------------------------------------- @@ -1247,8 +1226,8 @@ proc ::tcl::clock::scan { args } { } default { return -code error \ - -errorcode [list CLOCK badSwitch $flag] \ - "bad switch \"$flag\",\ + -errorcode [list CLOCK badOption $flag] \ + "bad option \"$flag\",\ must be -base, -format, -gmt, -locale or -timezone" } } @@ -1262,21 +1241,17 @@ proc ::tcl::clock::scan { args } { "cannot use -gmt and -timezone in same call" } if { [catch { expr { wide($base) } } result] } { - return -code error \ - "expected integer but got \"$base\"" + return -code error "expected integer but got \"$base\"" } - if { ![string is boolean $gmt] } { - return -code error \ - "expected boolean value but got \"$gmt\"" - } else { - if { $gmt } { - set timezone :GMT - } + if { ![string is boolean -strict $gmt] } { + return -code error "expected boolean value but got \"$gmt\"" + } elseif { $gmt } { + set timezone :GMT } if { ![info exists saw(-format)] } { - # Perhaps someday we'll localize the legacy code. Right now, - # it's not localized. + # Perhaps someday we'll localize the legacy code. Right now, it's not + # localized. if { [info exists saw(-locale)] } { return -code error \ -errorcode [list CLOCK flagWithLegacyFormat] \ @@ -1288,33 +1263,18 @@ proc ::tcl::clock::scan { args } { # Change locale if a fresh locale has been given on the command line. - EnterLocale $locale oldLocale - - set status [catch { + EnterLocale $locale + try { # Map away the locale-dependent composite format groups set scanner [ParseClockScanFormat $format $locale] - $scanner $string $base $timezone - - } result opts] - - # Restore the locale - - if { [info exists oldLocale] } { - mclocale $oldLocale - } - - if { $status == 1 } { - if { [lindex [dict get $opts -errorcode] 0] eq {clock} } { - return -code error $result - } else { - return -options $opts $result - } - } else { - return $result + return [$scanner $string $base $timezone] + } trap CLOCK {result opts} { + # Conceal location of generation of expected errors + dict unset opts -errorinfo + return -options $opts $result } - } #---------------------------------------------------------------------- @@ -1330,8 +1290,8 @@ proc ::tcl::clock::scan { args } { # locale - (Unused) Name of the locale where the time will be scanned. # # Results: -# Returns the date and time extracted from the string in seconds -# from the epoch +# Returns the date and time extracted from the string in seconds from +# the epoch # #---------------------------------------------------------------------- @@ -1341,41 +1301,40 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { # Get the data for time changes in the given zone - if {[catch {SetupTimeZone $timezone} retval opts]} { + try { + SetupTimeZone $timezone + } on error {retval opts} { dict unset opts -errorinfo return -options $opts $retval } - # Extract year, month and day from the base time for the - # parser to use as defaults - - set date [GetDateFields \ - $base \ - $TZData($timezone) \ - 2361222] - dict set date secondOfDay [expr { [dict get $date localSeconds] - % 86400 }] + # Extract year, month and day from the base time for the parser to use as + # defaults - # Parse the date. The parser will return a list comprising - # date, time, time zone, relative month/day/seconds, relative - # weekday, ordinal month. + set date [GetDateFields $base $TZData($timezone) 2361222] + dict set date secondOfDay [expr { + [dict get $date localSeconds] % 86400 + }] - set status [catch { - Oldscan $string \ - [dict get $date year] \ - [dict get $date month] \ - [dict get $date dayOfMonth] - } result] - if { $status != 0 } { - return -code error "unable to convert date-time string \"$string\": $result" + # Parse the date. The parser will return a list comprising date, time, + # time zone, relative month/day/seconds, relative weekday, ordinal month. + + try { + set scanned [Oldscan $string \ + [dict get $date year] \ + [dict get $date month] \ + [dict get $date dayOfMonth]] + lassign $scanned \ + parseDate parseTime parseZone parseRel \ + parseWeekday parseOrdinalMonth + } on error message { + return -code error \ + "unable to convert date-time string \"$string\": $message" } - lassign $result parseDate parseTime parseZone parseRel \ - parseWeekday parseOrdinalMonth - - # If the caller supplied a date in the string, update the 'date' dict - # with the value. If the caller didn't specify a time with the date, - # default to midnight. + # If the caller supplied a date in the string, update the 'date' dict with + # the value. If the caller didn't specify a time with the date, default to + # midnight. if { [llength $parseDate] > 0 } { lassign $parseDate y m d @@ -1395,11 +1354,11 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { } } - # If the caller supplied a time zone in the string, it comes back - # as a two-element list; the first element is the number of minutes - # east of Greenwich, and the second is a Daylight Saving Time - # indicator ( 1 == yes, 0 == no, -1 == unknown ). We make it into - # a time zone indicator of +-hhmm. + # If the caller supplied a time zone in the string, it comes back as a + # two-element list; the first element is the number of minutes east of + # Greenwich, and the second is a Daylight Saving Time indicator (1 == yes, + # 0 == no, -1 == unknown). We make it into a time zone indicator of + # +-hhmm. if { [llength $parseZone] > 0 } { lassign $parseZone minEast dstFlag @@ -1422,10 +1381,11 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { dict set date secondOfDay 0 } - dict set date localSeconds \ - [expr { -210866803200 - + ( 86400 * wide([dict get $date julianDay]) ) - + [dict get $date secondOfDay] }] + dict set date localSeconds [expr { + -210866803200 + + ( 86400 * wide([dict get $date julianDay]) ) + + [dict get $date secondOfDay] + }] dict set date tzName $timezone set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) 2361222] set seconds [dict get $date seconds] @@ -1442,13 +1402,12 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { # Do relative weekday if { [llength $parseWeekday] > 0 } { - lassign $parseWeekday dayOrdinal dayOfWeek set date2 [GetDateFields $seconds $TZData($timezone) 2361222] dict set date2 era CE - set jdwkday [WeekdayOnOrBefore $dayOfWeek \ - [expr { [dict get $date2 julianDay] - + 6 }]] + set jdwkday [WeekdayOnOrBefore $dayOfWeek [expr { + [dict get $date2 julianDay] + 6 + }]] incr jdwkday [expr { 7 * $dayOrdinal }] if { $dayOrdinal > 0 } { incr jdwkday -7 @@ -1456,10 +1415,11 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { dict set date2 secondOfDay \ [expr { [dict get $date2 localSeconds] % 86400 }] dict set date2 julianDay $jdwkday - dict set date2 localSeconds \ - [expr { -210866803200 - + ( 86400 * wide([dict get $date2 julianDay]) ) - + [dict get $date secondOfDay] }] + dict set date2 localSeconds [expr { + -210866803200 + + ( 86400 * wide([dict get $date2 julianDay]) ) + + [dict get $date secondOfDay] + }] dict set date2 tzName $timezone set date2 [ConvertLocalToUTC $date2[set date2 {}] $TZData($timezone) \ 2361222] @@ -1470,7 +1430,6 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { # Do relative month if { [llength $parseOrdinalMonth] > 0 } { - lassign $parseOrdinalMonth monthOrdinal monthNumber if { $monthOrdinal > 0 } { set monthDiff [expr { $monthNumber - [dict get $date month] }] @@ -1487,7 +1446,6 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { } set seconds [add $seconds $monthOrdinal years $monthDiff months \ -timezone $timezone -locale $locale] - } return $seconds @@ -1505,30 +1463,27 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { # locale - The current locale # # Results: -# Constructs and returns a procedure that accepts the -# string being scanned, the base time, and the time zone. -# The procedure will either return the scanned time or -# else throw an error that should be rethrown to the caller -# of [clock scan] +# Constructs and returns a procedure that accepts the string being +# scanned, the base time, and the time zone. The procedure will either +# return the scanned time or else throw an error that should be rethrown +# to the caller of [clock scan] # # Side effects: -# The given procedure is defined in the ::tcl::clock -# namespace. Scan procedures are not deleted once installed. -# -# Why do we parse dates by defining a procedure to parse them? -# The reason is that by doing so, we have one convenient place to -# cache all the information: the regular expressions that match the -# patterns (which will be compiled), the code that assembles the -# date information, everything lands in one place. In this way, -# when a given format is reused at run time, all the information +# The given procedure is defined in the ::tcl::clock namespace. Scan +# procedures are not deleted once installed. +# +# Why do we parse dates by defining a procedure to parse them? The reason is +# that by doing so, we have one convenient place to cache all the information: +# the regular expressions that match the patterns (which will be compiled), +# the code that assembles the date information, everything lands in one place. +# In this way, when a given format is reused at run time, all the information # of how to apply it is available in a single place. # #---------------------------------------------------------------------- proc ::tcl::clock::ParseClockScanFormat {formatString locale} { - - # Check whether the format has been parsed previously, and return - # the existing recognizer if it has. + # Check whether the format has been parsed previously, and return the + # existing recognizer if it has. set procName scanproc'$formatString'$locale set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName] @@ -1572,8 +1527,8 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { append re {[[:space:]]+} } else { if { ! [string is alnum $c] } { - append re \\ - } + append re "\\" + } append re $c } } @@ -1690,7 +1645,7 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { "::scan \$field" [incr captureCount] " %ld" \ "\]\n" } - m - N { # Month number + m - N { # Month number append re \\s*(\\d\\d?) dict set fieldSet month [incr fieldCount] append postcode "dict set date month \[" \ @@ -1733,10 +1688,9 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { \] \n } s { # Seconds from Posix Epoch - # This next case is insanely difficult, - # because it's problematic to determine - # whether the field is actually within - # the range of a wide integer. + # This next case is insanely difficult, because it's + # problematic to determine whether the field is + # actually within the range of a wide integer. append re {\s*([-+]?\d+)} dict set fieldSet seconds [incr fieldCount] append postcode {dict set date seconds } \[ \ @@ -1769,10 +1723,9 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { dict set date dayOfWeek $dow } } - U { # Week of year. The - # first Sunday of the year is the - # first day of week 01. No scan rule - # uses this group. + U { # Week of year. The first Sunday of + # the year is the first day of week + # 01. No scan rule uses this group. append re \\s*\\d\\d? } V { # Week of ISO8601 year @@ -1994,10 +1947,11 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { append procBody $postcode append procBody [list set changeover [mc GREGORIAN_CHANGE_DATE]] \n - # Get time zone if needed + # Set up the time zone before doing anything with a default base date + # that might need a timezone to interpret it. if { ![dict exists $fieldSet seconds] - && ![dict exists $fieldSet starDate] } { + && ![dict exists $fieldSet starDate] } { if { [dict exists $fieldSet tzName] } { append procBody { set timeZone [dict get $date tzName] @@ -2016,7 +1970,9 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { append procBody [MakeParseCodeFromFields $fieldSet $TimeParseActions] - # Assemble seconds, and convert local nominal time to UTC. + # Assemble seconds from the Julian day and second of the day. + # Convert to local time unless epoch seconds or stardate are + # being processed - they're always absolute if { ![dict exists $fieldSet seconds] && ![dict exists $fieldSet starDate] } { @@ -2025,15 +1981,18 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { return -code error -errorcode [list CLOCK dateTooLarge] \ "requested date too large to represent" } - dict set date localSeconds \ - [expr { -210866803200 - + ( 86400 * wide([dict get $date julianDay]) ) - + [dict get $date secondOfDay] }] + dict set date localSeconds [expr { + -210866803200 + + ( 86400 * wide([dict get $date julianDay]) ) + + [dict get $date secondOfDay] + }] } + + # Finally, convert the date to local time + append procBody { set date [::tcl::clock::ConvertLocalToUTC $date[set date {}] \ - $TZData($timeZone) \ - $changeover] + $TZData($timeZone) $changeover] } } @@ -2052,15 +2011,14 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { # # LocaleNumeralMatcher -- # -# Composes a regexp that captures the numerals in the given -# locale, and a dictionary to map them to conventional numerals. +# Composes a regexp that captures the numerals in the given locale, and +# a dictionary to map them to conventional numerals. # # Parameters: # locale - Name of the current locale # # Results: -# Returns a two-element list comprising the regexp and the -# dictionary. +# Returns a two-element list comprising the regexp and the dictionary. # # Side effects: # Caches the result. @@ -2068,7 +2026,6 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { #---------------------------------------------------------------------- proc ::tcl::clock::LocaleNumeralMatcher {l} { - variable LocaleNumeralCache if { ![dict exists $LocaleNumeralCache $l] } { @@ -2094,9 +2051,9 @@ proc ::tcl::clock::LocaleNumeralMatcher {l} { # # UniquePrefixRegexp -- # -# Composes a regexp that performs unique-prefix matching. The -# RE matches one of a supplied set of strings, or any unique -# prefix thereof. +# Composes a regexp that performs unique-prefix matching. The RE +# matches one of a supplied set of strings, or any unique prefix +# thereof. # # Parameters: # data - List of alternating match-strings and values. @@ -2104,10 +2061,10 @@ proc ::tcl::clock::LocaleNumeralMatcher {l} { # distinct. # # Results: -# Returns a two-element list. The first is a regexp that -# matches any unique prefix of any of the strings. The second -# is a dictionary whose keys are match values from the regexp -# and whose values are the corresponding values from 'data'. +# Returns a two-element list. The first is a regexp that matches any +# unique prefix of any of the strings. The second is a dictionary whose +# keys are match values from the regexp and whose values are the +# corresponding values from 'data'. # # Side effects: # None. @@ -2115,11 +2072,10 @@ proc ::tcl::clock::LocaleNumeralMatcher {l} { #---------------------------------------------------------------------- proc ::tcl::clock::UniquePrefixRegexp { data } { - - # The 'successors' dictionary will contain, for each string that - # is a prefix of any key, all characters that may follow that - # prefix. The 'prefixMapping' dictionary will have keys that - # are prefixes of keys and values that correspond to the keys. + # The 'successors' dictionary will contain, for each string that is a + # prefix of any key, all characters that may follow that prefix. The + # 'prefixMapping' dictionary will have keys that are prefixes of keys and + # values that correspond to the keys. set prefixMapping [dict create] set successors [dict create {} {}] @@ -2127,7 +2083,6 @@ proc ::tcl::clock::UniquePrefixRegexp { data } { # Walk the key-value pairs foreach { key value } $data { - # Construct all prefixes of the key; set prefix {} @@ -2146,8 +2101,8 @@ proc ::tcl::clock::UniquePrefixRegexp { data } { } } - # Identify those prefixes that designate unique values, and - # those that are the full keys + # Identify those prefixes that designate unique values, and those that are + # the full keys set uniquePrefixMapping {} dict for { key valueList } $prefixMapping { @@ -2170,8 +2125,8 @@ proc ::tcl::clock::UniquePrefixRegexp { data } { # # MakeUniquePrefixRegexp -- # -# Service procedure for 'UniquePrefixRegexp' that constructs -# a regular expresison that matches the unique prefixes. +# Service procedure for 'UniquePrefixRegexp' that constructs a regular +# expresison that matches the unique prefixes. # # Parameters: # successors - Dictionary whose keys are all prefixes @@ -2183,8 +2138,8 @@ proc ::tcl::clock::UniquePrefixRegexp { data } { # prefixString - Current prefix being processed. # # Results: -# Returns a constructed regular expression that matches the set -# of unique prefixes beginning with the 'prefixString'. +# Returns a constructed regular expression that matches the set of +# unique prefixes beginning with the 'prefixString'. # # Side effects: # None. @@ -2202,13 +2157,15 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors return {} } - # If there is more than one successor character, or if the current - # prefix is a unique prefix, surround the generated re with non-capturing + # If there is more than one successor character, or if the current prefix + # is a unique prefix, surround the generated re with non-capturing # parentheses. set re {} - if { [dict exists $uniquePrefixMapping $prefixString] - || [llength $schars] > 1 } { + if { + [dict exists $uniquePrefixMapping $prefixString] + || [llength $schars] > 1 + } then { append re "(?:" } @@ -2230,7 +2187,7 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors if { [dict exists $uniquePrefixMapping $prefixString] } { append re ")?" - } elseif { [llength $schars] > 1 } { + } elseif { [llength $schars] > 1 } { append re ")" } @@ -2241,8 +2198,8 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors # # MakeParseCodeFromFields -- # -# Composes Tcl code to extract the Julian Day Number from a -# dictionary containing date fields. +# Composes Tcl code to extract the Julian Day Number from a dictionary +# containing date fields. # # Parameters: # dateFields -- Dictionary whose keys are fields of the date, @@ -2253,8 +2210,8 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors # the list must be in ascending order by priority # # Results: -# Returns a burst of code that extracts the day number from the -# given date. +# Returns a burst of code that extracts the day number from the given +# date. # # Side effects: # None. @@ -2270,16 +2227,15 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { } foreach { fieldSet prio parseAction } $parseActions { - - # If we've found an answer that's better than any that follow, - # quit now. + # If we've found an answer that's better than any that follow, quit + # now. if { $prio > $currPrio } { break } - # Accumulate the field positions that are used in the current - # field grouping. + # Accumulate the field positions that are used in the current field + # grouping. set fieldPos [list] set ok true @@ -2302,9 +2258,11 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { if { $prio == $currPrio } { foreach currPos $currFieldPos newPos $fPos { - if { ![string is integer $newPos] - || ![string is integer $currPos] - || $newPos > $currPos } { + if { + ![string is integer $newPos] + || ![string is integer $currPos] + || $newPos > $currPos + } then { break } if { $newPos < $currPos } { @@ -2322,11 +2280,9 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { set currPrio $prio set currFieldPos $fPos set currCodeBurst $parseAction - } return $currCodeBurst - } #---------------------------------------------------------------------- @@ -2337,78 +2293,52 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { # # Parameters: # locale -- Desired locale -# oldLocaleVar -- Name of a variable in caller's scope that -# tracks the previous locale name. # # Results: # Returns the locale that was previously current. # # Side effects: -# Does [mclocale]. If necessary, uses [mcload] to load the -# designated locale's files, and tracks that it has done so -# in the 'McLoaded' variable. +# Does [mclocale]. If necessary, loades the designated locale's files. # #---------------------------------------------------------------------- -proc ::tcl::clock::EnterLocale { locale oldLocaleVar } { - - upvar 1 $oldLocaleVar oldLocale - - variable MsgDir - variable McLoaded - - set oldLocale [mclocale] +proc ::tcl::clock::EnterLocale { locale } { if { $locale eq {system} } { - if { $::tcl_platform(platform) ne {windows} } { - - # On a non-windows platform, the 'system' locale is - # the same as the 'current' locale + # On a non-windows platform, the 'system' locale is the same as + # the 'current' locale set locale current } else { + # On a windows platform, the 'system' locale is adapted from the + # 'current' locale by applying the date and time formats from the + # Control Panel. First, load the 'current' locale if it's not yet + # loaded - # On a windows platform, the 'system' locale is - # adapted from the 'current' locale by applying the - # date and time formats from the Control Panel. - # First, load the 'current' locale if it's not yet loaded - - if {![dict exists $McLoaded $oldLocale] } { - mcload $MsgDir - dict set McLoaded $oldLocale {} - } + mcpackagelocale set [mclocale] - # Make a new locale string for the system locale, and - # get the Control Panel information + # Make a new locale string for the system locale, and get the + # Control Panel information - set locale ${oldLocale}_windows - if { ![dict exists $McLoaded $locale] } { + set locale [mclocale]_windows + if { ! [mcpackagelocale present $locale] } { LoadWindowsDateTimeFormats $locale - dict set McLoaded $locale {} } } } if { $locale eq {current}} { - set locale $oldLocale - unset oldLocale - } elseif { $locale eq $oldLocale } { - unset oldLocale - } else { - mclocale $locale - } - if { ![dict exists $McLoaded $locale] } { - mcload $MsgDir - dict set McLoaded $locale {} + set locale [mclocale] } - + # Eventually load the locale + mcpackagelocale set $locale } #---------------------------------------------------------------------- # # LoadWindowsDateTimeFormats -- # -# Load the date/time formats from the Control Panel in Windows -# and convert them so that they're usable by Tcl. +# Load the date/time formats from the Control Panel in Windows and +# convert them so that they're usable by Tcl. # # Parameters: # locale - Name of the locale in whose message catalog @@ -2420,14 +2350,12 @@ proc ::tcl::clock::EnterLocale { locale oldLocaleVar } { # Side effects: # Updates the given message catalog with the locale strings. # -# Presumes that on entry, [mclocale] is set to the current locale, -# so that default strings can be obtained if the Registry query -# fails. +# Presumes that on entry, [mclocale] is set to the current locale, so that +# default strings can be obtained if the Registry query fails. # #---------------------------------------------------------------------- proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { - # Bail out if we can't find the Registry variable NoRegistry @@ -2544,8 +2472,8 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { # format -- Format supplied to [clock scan] or [clock format] # # Results: -# Returns the string with locale-dependent composite format -# groups substituted out. +# Returns the string with locale-dependent composite format groups +# substituted out. # # Side effects: # None. @@ -2554,13 +2482,12 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { proc ::tcl::clock::LocalizeFormat { locale format } { - variable McLoaded + # message catalog key to cache this format + set key FORMAT_$format - if { [dict exists $McLoaded $locale FORMAT $format] } { - return [dict get $McLoaded $locale FORMAT $format] + if { [::msgcat::mcexists -exactlocale -exactnamespace $key] } { + return [mc $key] } - set inFormat $format - # Handle locale-dependent format groups by mapping them out of the format # string. Note that the order of the [string map] operations is # significant because later formats can refer to later ones; for example @@ -2583,7 +2510,7 @@ proc ::tcl::clock::LocalizeFormat { locale format } { lappend list %Ec [string map $list [mc LOCALE_DATE_TIME_FORMAT]] set format [string map $list $format] - dict set McLoaded $locale FORMAT $inFormat $format + ::msgcat::mcset $locale $key $format return $format } @@ -2605,7 +2532,6 @@ proc ::tcl::clock::LocalizeFormat { locale format } { #---------------------------------------------------------------------- proc ::tcl::clock::FormatNumericTimeZone { z } { - if { $z < 0 } { set z [expr { - $z }] set retval - @@ -2620,7 +2546,6 @@ proc ::tcl::clock::FormatNumericTimeZone { z } { append retval [::format %02d $z] } return $retval - } #---------------------------------------------------------------------- @@ -2645,7 +2570,6 @@ proc ::tcl::clock::FormatNumericTimeZone { z } { #---------------------------------------------------------------------- proc ::tcl::clock::FormatStarDate { date } { - variable Roddenberry # Get day of year, zero based @@ -2696,7 +2620,6 @@ proc ::tcl::clock::FormatStarDate { date } { #---------------------------------------------------------------------- proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { - variable Roddenberry # Build a tentative date from year and fraction. @@ -2712,8 +2635,8 @@ proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { set lp [IsGregorianLeapYear $date] - # Reconvert the fractional year according to whether the given - # year is a leap year + # Reconvert the fractional year according to whether the given year is a + # leap year if { $lp } { dict set date dayOfYear \ @@ -2726,10 +2649,11 @@ proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { dict unset date gregorian set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]] - return [expr { 86400 * [dict get $date julianDay] - - 210866803200 - + ( 86400 / 10 ) * $fractDay }] - + return [expr { + 86400 * [dict get $date julianDay] + - 210866803200 + + ( 86400 / 10 ) * $fractDay + }] } #---------------------------------------------------------------------- @@ -2742,8 +2666,8 @@ proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { # str - String containing a decimal wide integer # # Results: -# Returns the string as a pure wide integer. Throws an error if -# the string is misformatted or out of range. +# Returns the string as a pure wide integer. Throws an error if the +# string is misformatted or out of range. # #---------------------------------------------------------------------- @@ -2764,8 +2688,8 @@ proc ::tcl::clock::ScanWide { str } { # # InterpretTwoDigitYear -- # -# Given a date that contains only the year of the century, -# determines the target value of a two-digit year. +# Given a date that contains only the year of the century, determines +# the target value of a two-digit year. # # Parameters: # date - Dictionary containing fields of the date. @@ -2782,18 +2706,17 @@ proc ::tcl::clock::ScanWide { str } { # Side effects: # None. # -# The current rule for interpreting a two-digit year is that the year -# shall be between 1937 and 2037, thus staying within the range of a -# 32-bit signed value for time. This rule may change to a sliding -# window in future versions, so the 'baseTime' parameter (which is -# currently ignored) is provided in the procedure signature. +# The current rule for interpreting a two-digit year is that the year shall be +# between 1937 and 2037, thus staying within the range of a 32-bit signed +# value for time. This rule may change to a sliding window in future +# versions, so the 'baseTime' parameter (which is currently ignored) is +# provided in the procedure signature. # #---------------------------------------------------------------------- proc ::tcl::clock::InterpretTwoDigitYear { date baseTime { twoDigitField yearOfCentury } { fourDigitField year } } { - set yr [dict get $date $twoDigitField] if { $yr <= 37 } { dict set date $fourDigitField [expr { $yr + 2000 }] @@ -2801,7 +2724,6 @@ proc ::tcl::clock::InterpretTwoDigitYear { date baseTime dict set date $fourDigitField [expr { $yr + 1900 }] } return $date - } #---------------------------------------------------------------------- @@ -2827,7 +2749,6 @@ proc ::tcl::clock::InterpretTwoDigitYear { date baseTime #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } { - variable TZData # Find the Julian Day Number corresponding to the base time, and @@ -2841,7 +2762,6 @@ proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } { dict set date year [dict get $date2 year] return $date - } #---------------------------------------------------------------------- @@ -2868,7 +2788,6 @@ proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } { #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} { - variable TZData # Find the Julian Day Number corresponding to the base time @@ -2905,7 +2824,6 @@ proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} { #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} { - variable TZData # Find the year and month corresponding to the base time @@ -2915,7 +2833,6 @@ proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} { dict set date year [dict get $date2 year] dict set date month [dict get $date2 month] return $date - } #---------------------------------------------------------------------- @@ -2941,7 +2858,6 @@ proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} { #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseWeek {date baseTime timeZone changeover} { - variable TZData # Find the Julian Day Number corresponding to the base time @@ -2978,7 +2894,6 @@ proc ::tcl::clock::AssignBaseWeek {date baseTime timeZone changeover} { #---------------------------------------------------------------------- proc ::tcl::clock::AssignBaseJulianDay { date baseTime timeZone changeover } { - variable TZData # Find the Julian Day Number corresponding to the base time @@ -3008,7 +2923,6 @@ proc ::tcl::clock::AssignBaseJulianDay { date baseTime timeZone changeover } { #---------------------------------------------------------------------- proc ::tcl::clock::InterpretHMSP { date } { - set hr [dict get $date hourAMPM] if { $hr == 12 } { set hr 0 @@ -3018,7 +2932,6 @@ proc ::tcl::clock::InterpretHMSP { date } { } dict set date hour $hr return [InterpretHMS $date[set date {}]] - } #---------------------------------------------------------------------- @@ -3041,11 +2954,11 @@ proc ::tcl::clock::InterpretHMSP { date } { #---------------------------------------------------------------------- proc ::tcl::clock::InterpretHMS { date } { - - return [expr { ( [dict get $date hour] * 60 - + [dict get $date minute] ) * 60 - + [dict get $date second] }] - + return [expr { + ( [dict get $date hour] * 60 + + [dict get $date minute] ) * 60 + + [dict get $date second] + }] } #---------------------------------------------------------------------- @@ -3068,7 +2981,6 @@ proc ::tcl::clock::InterpretHMS { date } { #---------------------------------------------------------------------- proc ::tcl::clock::GetSystemTimeZone {} { - variable CachedSystemTimeZone variable TimeZoneBad @@ -3101,76 +3013,69 @@ proc ::tcl::clock::GetSystemTimeZone {} { } else { return $timezone } - } #---------------------------------------------------------------------- # # ConvertLegacyTimeZone -- # -# Given an alphanumeric time zone identifier and the system -# time zone, convert the alphanumeric identifier to an -# unambiguous time zone. +# Given an alphanumeric time zone identifier and the system time zone, +# convert the alphanumeric identifier to an unambiguous time zone. # # Parameters: # tzname - Name of the time zone to convert # # Results: -# Returns a time zone name corresponding to tzname, but -# in an unambiguous form, generally +hhmm. +# Returns a time zone name corresponding to tzname, but in an +# unambiguous form, generally +hhmm. # -# This procedure is implemented primarily to allow the parsing of -# RFC822 date/time strings. Processing a time zone name on input -# is not recommended practice, because there is considerable room -# for ambiguity; for instance, is BST Brazilian Standard Time, or -# British Summer Time? +# This procedure is implemented primarily to allow the parsing of RFC822 +# date/time strings. Processing a time zone name on input is not recommended +# practice, because there is considerable room for ambiguity; for instance, is +# BST Brazilian Standard Time, or British Summer Time? # #---------------------------------------------------------------------- proc ::tcl::clock::ConvertLegacyTimeZone { tzname } { - variable LegacyTimeZone set tzname [string tolower $tzname] if { ![dict exists $LegacyTimeZone $tzname] } { return -code error -errorcode [list CLOCK badTZName $tzname] \ "time zone \"$tzname\" not found" - } else { - return [dict get $LegacyTimeZone $tzname] } - + return [dict get $LegacyTimeZone $tzname] } #---------------------------------------------------------------------- # # SetupTimeZone -- # -# Given the name or specification of a time zone, sets up -# its in-memory data. +# Given the name or specification of a time zone, sets up its in-memory +# data. # # Parameters: # tzname - Name of a time zone # # Results: -# Unless the time zone is ':localtime', sets the TZData array -# to contain the lookup table for local<->UTC conversion. -# Returns an error if the time zone cannot be parsed. +# Unless the time zone is ':localtime', sets the TZData array to contain +# the lookup table for local<->UTC conversion. Returns an error if the +# time zone cannot be parsed. # #---------------------------------------------------------------------- proc ::tcl::clock::SetupTimeZone { timezone } { - variable TZData if {! [info exists TZData($timezone)] } { variable MINWIDE if { $timezone eq {:localtime} } { - # Nothing to do, we'll convert using the localtime function - } elseif { [regexp {^([-+])(\d\d)(?::?(\d\d)(?::?(\d\d))?)?} $timezone \ - -> s hh mm ss] } { - + } elseif { + [regexp {^([-+])(\d\d)(?::?(\d\d)(?::?(\d\d))?)?} $timezone \ + -> s hh mm ss] + } then { # Make a fixed offset ::scan $hh %d hh @@ -3191,24 +3096,20 @@ proc ::tcl::clock::SetupTimeZone { timezone } { set TZData($timezone) [list [list $MINWIDE $offset -1 $timezone]] } elseif { [string index $timezone 0] eq {:} } { - # Convert using a time zone file if { [catch { LoadTimeZoneFile [string range $timezone 1 end] - }] - && [catch { + }] && [catch { LoadZoneinfoFile [string range $timezone 1 end] }] - } { + } then { return -code error \ -errorcode [list CLOCK badTimeZone $timezone] \ "time zone \"$timezone\" not found" } - } elseif { ![catch {ParsePosixTimeZone $timezone} tzfields] } { - # This looks like a POSIX time zone - try to process it if { [catch {ProcessPosixTimeZone $tzfields} data opts] } { @@ -3221,9 +3122,8 @@ proc ::tcl::clock::SetupTimeZone { timezone } { } } else { - - # We couldn't parse this as a POSIX time zone. Try - # again with a time zone file - this time without a colon + # We couldn't parse this as a POSIX time zone. Try again with a + # time zone file - this time without a colon if { [catch { LoadTimeZoneFile $timezone }] && [catch { LoadZoneinfoFile $timezone } - opts] } { @@ -3247,25 +3147,22 @@ proc ::tcl::clock::SetupTimeZone { timezone } { # None. # # Results: -# Returns a time zone specifier that corresponds to the system -# time zone information found in the Registry. +# Returns a time zone specifier that corresponds to the system time zone +# information found in the Registry. # # Bugs: -# Fixed dates for DST change are unimplemented at present, because -# no time zone information supplied with Windows actually uses -# them! +# Fixed dates for DST change are unimplemented at present, because no +# time zone information supplied with Windows actually uses them! # -# On a Windows system where neither $env(TCL_TZ) nor $env(TZ) is -# specified, GuessWindowsTimeZone looks in the Registry for the -# system time zone information. It then attempts to find an entry -# in WinZoneInfo for a time zone that uses the same rules. If -# it finds one, it returns it; otherwise, it constructs a Posix-style -# time zone string and returns that. +# On a Windows system where neither $env(TCL_TZ) nor $env(TZ) is specified, +# GuessWindowsTimeZone looks in the Registry for the system time zone +# information. It then attempts to find an entry in WinZoneInfo for a time +# zone that uses the same rules. If it finds one, it returns it; otherwise, +# it constructs a Posix-style time zone string and returns that. # #---------------------------------------------------------------------- proc ::tcl::clock::GuessWindowsTimeZone {} { - variable WinZoneInfo variable NoRegistry variable TimeZoneBad @@ -3296,16 +3193,14 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { lappend data $val } }] } { - # Missing values in the Registry - bail out return :localtime } - # Make up a Posix time zone specifier if we can't find one. - # Check here that the tzdata file exists, in case we're running - # in an environment (e.g. starpack) where tzdata is incomplete. - # (Bug 1237907) + # Make up a Posix time zone specifier if we can't find one. Check here + # that the tzdata file exists, in case we're running in an environment + # (e.g. starpack) where tzdata is incomplete. (Bug 1237907) if { [dict exists $WinZoneInfo $data] } { set tzname [dict get $WinZoneInfo $data] @@ -3353,11 +3248,11 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { if { $dstYear == 0 } { append tzname ,M $dstMonth . $dstDayOfMonth . $dstDayOfWeek } else { - # I have not been able to find any locale on which - # Windows converts time zone on a fixed day of the year, - # hence don't know how to interpret the fields. - # If someone can inform me, I'd be glad to code it up. - # For right now, we bail out in such a case. + # I have not been able to find any locale on which Windows + # converts time zone on a fixed day of the year, hence don't + # know how to interpret the fields. If someone can inform me, + # I'd be glad to code it up. For right now, we bail out in + # such a case. return :localtime } append tzname / [::format %02d $dstHour] \ @@ -3366,11 +3261,11 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { if { $stdYear == 0 } { append tzname ,M $stdMonth . $stdDayOfMonth . $stdDayOfWeek } else { - # I have not been able to find any locale on which - # Windows converts time zone on a fixed day of the year, - # hence don't know how to interpret the fields. - # If someone can inform me, I'd be glad to code it up. - # For right now, we bail out in such a case. + # I have not been able to find any locale on which Windows + # converts time zone on a fixed day of the year, hence don't + # know how to interpret the fields. If someone can inform me, + # I'd be glad to code it up. For right now, we bail out in + # such a case. return :localtime } append tzname / [::format %02d $stdHour] \ @@ -3381,7 +3276,6 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { } return [dict get $WinZoneInfo $data] - } #---------------------------------------------------------------------- @@ -3410,18 +3304,18 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } { return } - # Since an unsafe interp uses the [clock] command in the master, - # this code is security sensitive. Make sure that the path name - # cannot escape the given directory. + # Since an unsafe interp uses the [clock] command in the master, this code + # is security sensitive. Make sure that the path name cannot escape the + # given directory. if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } { return -code error \ -errorcode [list CLOCK badTimeZone $:fileName] \ "time zone \":$fileName\" not valid" } - if { [catch { + try { source -encoding utf-8 [file join $DataDir $fileName] - }] } { + } on error {} { return -code error \ -errorcode [list CLOCK badTimeZone :$fileName] \ "time zone \":$fileName\" not found" @@ -3439,8 +3333,8 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } { # fileName - Relative path name of the file to load. # # Results: -# Returns an empty result normally; returns an error if no -# Olson file was found or the file was malformed in some way. +# Returns an empty result normally; returns an error if no Olson file +# was found or the file was malformed in some way. # # Side effects: # TZData(:fileName) contains the time zone data @@ -3448,12 +3342,11 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } { #---------------------------------------------------------------------- proc ::tcl::clock::LoadZoneinfoFile { fileName } { - variable ZoneinfoPaths - # Since an unsafe interp uses the [clock] command in the master, - # this code is security sensitive. Make sure that the path name - # cannot escape the given directory. + # Since an unsafe interp uses the [clock] command in the master, this code + # is security sensitive. Make sure that the path name cannot escape the + # given directory. if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } { return -code error \ @@ -3482,15 +3375,14 @@ proc ::tcl::clock::LoadZoneinfoFile { fileName } { # fname - Absolute path name of the file. # # Results: -# Returns an empty result normally; returns an error if no -# Olson file was found or the file was malformed in some way. +# Returns an empty result normally; returns an error if no Olson file +# was found or the file was malformed in some way. # # Side effects: # TZData(:fileName) contains the time zone data # #---------------------------------------------------------------------- - proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { variable MINWIDE variable TZData @@ -3509,8 +3401,8 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { set d [read $f] close $f - # The file begins with a magic number, sixteen reserved bytes, - # and then six 4-byte integers giving counts of fileds in the file. + # The file begins with a magic number, sixteen reserved bytes, and then + # six 4-byte integers giving counts of fileds in the file. binary scan $d a4a1x15IIIIII \ magic version nIsGMT nIsStd nLeap nTime nType nChar @@ -3528,18 +3420,19 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { return -code error "$fileName contains leap seconds" } - # In a version 2 file, we use the second part of the file, which - # contains 64-bit transition times. + # In a version 2 file, we use the second part of the file, which contains + # 64-bit transition times. if {$version eq "2"} { - set seek [expr {44 - + 5 * $nTime - + 6 * $nType - + 4 * $nLeap - + $nIsStd - + $nIsGMT - + $nChar - }] + set seek [expr { + 44 + + 5 * $nTime + + 6 * $nType + + 4 * $nLeap + + $nIsStd + + $nIsGMT + + $nChar + }] binary scan $d @${seek}a4a1x15IIIIII \ magic version nIsGMT nIsStd nLeap nTime nType nChar if {$magic ne {TZif}} { @@ -3563,9 +3456,9 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { } set codes [linsert $codes 0 0] - # Next come ${nType} time type descriptions, each of which has an - # offset (seconds east of GMT), a DST indicator, and an index into - # the abbreviation text. + # Next come ${nType} time type descriptions, each of which has an offset + # (seconds east of GMT), a DST indicator, and an index into the + # abbreviation text. for { set i 0 } { $i < $nType } { incr i } { binary scan $d @${seek}Icc gmtOff isDst abbrInd @@ -3573,10 +3466,10 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { incr seek 6 } - # Next come $nChar characters of time zone name abbreviations, - # which are null-terminated. - # We build them up into a dictionary indexed by character index, - # because that's what's in the indices above. + # Next come $nChar characters of time zone name abbreviations, which are + # null-terminated. + # We build them up into a dictionary indexed by character index, because + # that's what's in the indices above. binary scan $d @${seek}a${nChar} abbrs incr seek ${nChar} @@ -3606,8 +3499,8 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { } # In a version 2 file, there is also a POSIX-style time zone description - # at the very end of the file. To get to it, skip over - # nLeap leap second values (8 bytes each), + # at the very end of the file. To get to it, skip over nLeap leap second + # values (8 bytes each), # nIsStd standard/DST indicators and nIsGMT UTC/local indicators. if {$version eq {2}} { @@ -3640,8 +3533,8 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { # tz Time zone specifier to be interpreted # # Results: -# Returns a dictionary whose values contain the various pieces of -# the time zone specification. +# Returns a dictionary whose values contain the various pieces of the +# time zone specification. # # Side effects: # None. @@ -3698,13 +3591,12 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { # Specify the end of DST in the same way that the start* fields # specify the beginning of DST. # -# This procedure serves only to break the time specifier into fields. -# No attempt is made to canonicalize the fields or supply default values. +# This procedure serves only to break the time specifier into fields. No +# attempt is made to canonicalize the fields or supply default values. # #---------------------------------------------------------------------- proc ::tcl::clock::ParsePosixTimeZone { tz } { - if {[regexp -expanded -nocase -- { ^ # 1 - Standard time zone name @@ -3796,27 +3688,21 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { x(endJ) x(endDayOfYear) \ x(endMonth) x(endWeekOfMonth) x(endDayOfWeek) \ x(endHours) x(endMinutes) x(endSeconds)] } { - # it's a good timezone return [array get x] - - } else { - - return -code error\ - -errorcode [list CLOCK badTimeZone $tz] \ - "unable to parse time zone specification \"$tz\"" - } + return -code error\ + -errorcode [list CLOCK badTimeZone $tz] \ + "unable to parse time zone specification \"$tz\"" } #---------------------------------------------------------------------- # # ProcessPosixTimeZone -- # -# Handle a Posix time zone after it's been broken out into -# fields. +# Handle a Posix time zone after it's been broken out into fields. # # Parameters: # z - Dictionary returned from 'ParsePosixTimeZone' @@ -3830,7 +3716,6 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { #---------------------------------------------------------------------- proc ::tcl::clock::ProcessPosixTimeZone { z } { - variable MINWIDE variable TZData @@ -3856,9 +3741,9 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { } else { set stdSeconds 0 } - set stdOffset [expr { ( ( $stdHours * 60 + $stdMinutes ) - * 60 + $stdSeconds ) - * $stdSignum }] + set stdOffset [expr { + (($stdHours * 60 + $stdMinutes) * 60 + $stdSeconds) * $stdSignum + }] set data [list [list $MINWIDE $stdOffset 0 $stdName]] # If there's no daylight zone, we're done @@ -3892,9 +3777,9 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { } else { set dstSeconds 0 } - set dstOffset [expr { ( ( $dstHours * 60 + $dstMinutes ) - * 60 + $dstSeconds ) - * $dstSignum }] + set dstOffset [expr { + (($dstHours*60 + $dstMinutes) * 60 + $dstSeconds) * $dstSignum + }] } # Fill in defaults for European or US DST rules @@ -3903,8 +3788,10 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { # US end time is the first Sunday in November. # EU end time is the last Sunday in October - if { [dict get $z startDayOfYear] eq {} - && [dict get $z startMonth] eq {} } { + if { + [dict get $z startDayOfYear] eq {} + && [dict get $z startMonth] eq {} + } then { if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} { # EU dict set z startWeekOfMonth 5 @@ -3923,8 +3810,10 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { dict set z startMinutes 0 dict set z startSeconds 0 } - if { [dict get $z endDayOfYear] eq {} - && [dict get $z endMonth] eq {} } { + if { + [dict get $z endDayOfYear] eq {} + && [dict get $z endMonth] eq {} + } then { if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} { # EU dict set z endMonth 10 @@ -3964,15 +3853,14 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { } return $data - } #---------------------------------------------------------------------- # # DeterminePosixDSTTime -- # -# Determines the time that Daylight Saving Time starts or ends -# from a Posix time zone specification. +# Determines the time that Daylight Saving Time starts or ends from a +# Posix time zone specification. # # Parameters: # z - Time zone data returned from ParsePosixTimeZone. @@ -3982,8 +3870,8 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { # y - The year for which the transition time is to be determined. # # Results: -# Returns the transition time as a count of seconds from -# the epoch. The time is relative to the wall clock, not UTC. +# Returns the transition time as a count of seconds from the epoch. The +# time is relative to the wall clock, not UTC. # #---------------------------------------------------------------------- @@ -4007,7 +3895,6 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { dict set date dayOfYear $doy set date [GetJulianDayFromEraYearDay $date[set date {}] 2361222] } else { - # Time was specified as a day of the week within a month dict set date month [dict get $z ${bound}Month] @@ -4022,8 +3909,9 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { } set jd [dict get $date julianDay] - set seconds [expr { wide($jd) * wide(86400) - - wide(210866803200) }] + set seconds [expr { + wide($jd) * wide(86400) - wide(210866803200) + }] set h [dict get $z ${bound}Hours] if { $h eq {} } { @@ -4045,7 +3933,6 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { } set tod [expr { ( $h * 60 + $m ) * 60 + $s }] return [expr { $seconds + $tod }] - } #---------------------------------------------------------------------- @@ -4063,26 +3950,26 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { # for the target locale. # # Results: -# Returns the dictionary, augmented with the keys, 'localeEra' -# and 'localeYear'. +# Returns the dictionary, augmented with the keys, 'localeEra' and +# 'localeYear'. # #---------------------------------------------------------------------- proc ::tcl::clock::GetLocaleEra { date etable } { - set index [BSearch $etable [dict get $date localSeconds]] if { $index < 0} { dict set date localeEra \ [::format %02d [expr { [dict get $date year] / 100 }]] - dict set date localeYear \ - [expr { [dict get $date year] % 100 }] + dict set date localeYear [expr { + [dict get $date year] % 100 + }] } else { dict set date localeEra [lindex $etable $index 1] - dict set date localeYear [expr { [dict get $date year] - - [lindex $etable $index 2] }] + dict set date localeYear [expr { + [dict get $date year] - [lindex $etable $index 2] + }] } return $date - } #---------------------------------------------------------------------- @@ -4100,10 +3987,9 @@ proc ::tcl::clock::GetLocaleEra { date etable } { # adopted in the current locale. # # Results: -# Returns the given dictionary augmented with a 'julianDay' key -# whose value is the desired Julian Day Number, and a 'gregorian' -# key that specifies whether the calendar is Gregorian (1) or -# Julian (0). +# Returns the given dictionary augmented with a 'julianDay' key whose +# value is the desired Julian Day Number, and a 'gregorian' key that +# specifies whether the calendar is Gregorian (1) or Julian (0). # # Side effects: # None. @@ -4114,7 +4000,6 @@ proc ::tcl::clock::GetLocaleEra { date etable } { #---------------------------------------------------------------------- proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} { - # Get absolute year number from the civil year switch -exact -- [dict get $date era] { @@ -4130,21 +4015,25 @@ proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} { # Try the Gregorian calendar first. dict set date gregorian 1 - set jd [expr { 1721425 - + [dict get $date dayOfYear] - + ( 365 * $ym1 ) - + ( $ym1 / 4 ) - - ( $ym1 / 100 ) - + ( $ym1 / 400 ) }] + set jd [expr { + 1721425 + + [dict get $date dayOfYear] + + ( 365 * $ym1 ) + + ( $ym1 / 4 ) + - ( $ym1 / 100 ) + + ( $ym1 / 400 ) + }] # If the date is before the Gregorian change, use the Julian calendar. if { $jd < $changeover } { dict set date gregorian 0 - set jd [expr { 1721423 - + [dict get $date dayOfYear] - + ( 365 * $ym1 ) - + ( $ym1 / 4 ) }] + set jd [expr { + 1721423 + + [dict get $date dayOfYear] + + ( 365 * $ym1 ) + + ( $ym1 / 4 ) + }] } dict set date julianDay $jd @@ -4155,8 +4044,8 @@ proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} { # # GetJulianDayFromEraYearMonthWeekDay -- # -# Determines the Julian Day number corresponding to the nth -# given day-of-the-week in a given month. +# Determines the Julian Day number corresponding to the nth given +# day-of-the-week in a given month. # # Parameters: # date - Dictionary containing the keys, 'era', 'year', 'month' @@ -4175,10 +4064,9 @@ proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} { #---------------------------------------------------------------------- proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} { - - # Come up with a reference day; either the zeroeth day of the - # given month (dayOfWeekInMonth >= 0) or the seventh day of the - # following month (dayOfWeekInMonth < 0) + # Come up with a reference day; either the zeroeth day of the given month + # (dayOfWeekInMonth >= 0) or the seventh day of the following month + # (dayOfWeekInMonth < 0) set date2 $date set week [dict get $date dayOfWeekInMonth] @@ -4194,7 +4082,6 @@ proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} { [dict get $date2 julianDay]] dict set date julianDay [expr { $wd0 + 7 * $week }] return $date - } #---------------------------------------------------------------------- @@ -4217,7 +4104,6 @@ proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} { #---------------------------------------------------------------------- proc ::tcl::clock::IsGregorianLeapYear { date } { - switch -exact -- [dict get $date era] { BCE { set year [expr { 1 - [dict get $date year]}] @@ -4237,15 +4123,14 @@ proc ::tcl::clock::IsGregorianLeapYear { date } { } else { return 1 } - } #---------------------------------------------------------------------- # # WeekdayOnOrBefore -- # -# Determine the nearest day of week (given by the 'weekday' -# parameter, Sunday==0) on or before a given Julian Day. +# Determine the nearest day of week (given by the 'weekday' parameter, +# Sunday==0) on or before a given Julian Day. # # Parameters: # weekday -- Day of the week @@ -4260,18 +4145,16 @@ proc ::tcl::clock::IsGregorianLeapYear { date } { #---------------------------------------------------------------------- proc ::tcl::clock::WeekdayOnOrBefore { weekday j } { - set k [expr { ( $weekday + 6 ) % 7 }] return [expr { $j - ( $j - $k ) % 7 }] - } #---------------------------------------------------------------------- # # BSearch -- # -# Service procedure that does binary search in several places -# inside the 'clock' command. +# Service procedure that does binary search in several places inside the +# 'clock' command. # # Parameters: # list - List of lists, sorted in ascending order by the @@ -4279,8 +4162,8 @@ proc ::tcl::clock::WeekdayOnOrBefore { weekday j } { # key - Value to search for # # Results: -# Returns the index of the greatest element in $list that is less -# than or equal to $key. +# Returns the index of the greatest element in $list that is less than +# or equal to $key. # # Side effects: # None. @@ -4288,7 +4171,6 @@ proc ::tcl::clock::WeekdayOnOrBefore { weekday j } { #---------------------------------------------------------------------- proc ::tcl::clock::BSearch { list key } { - if {[llength $list] == 0} { return -1 } @@ -4300,13 +4182,12 @@ proc ::tcl::clock::BSearch { list key } { set u [expr { [llength $list] - 1 }] while { $l < $u } { - # At this point, we know that # $k >= [lindex $list $l 0] # Either $u == [llength $list] or else $k < [lindex $list $u+1 0] # We find the midpoint of the interval {l,u} rounded UP, compare - # against it, and set l or u to maintain the invariant. Note - # that the interval shrinks at each step, guaranteeing convergence. + # against it, and set l or u to maintain the invariant. Note that the + # interval shrinks at each step, guaranteeing convergence. set m [expr { ( $l + $u + 1 ) / 2 }] if { $key >= [lindex $list $m 0] } { @@ -4350,15 +4231,14 @@ proc ::tcl::clock::BSearch { list key } { # order. # # Notes: -# It is possible that adding a number of months or years will adjust -# the day of the month as well. For instance, the time at -# one month after 31 January is either 28 or 29 February, because -# February has fewer than 31 days. +# It is possible that adding a number of months or years will adjust the +# day of the month as well. For instance, the time at one month after +# 31 January is either 28 or 29 February, because February has fewer +# than 31 days. # #---------------------------------------------------------------------- proc ::tcl::clock::add { clockval args } { - if { [llength $args] % 2 != 0 } { set cmdName "clock add" return -code error \ @@ -4377,15 +4257,10 @@ proc ::tcl::clock::add { clockval args } { set timezone [GetSystemTimeZone] foreach { a b } $args { - if { [string is integer -strict $a] } { - lappend offsets $a $b - } else { - switch -exact -- $a { - -g - -gm - -gmt { set gmt $b } @@ -4397,9 +4272,8 @@ proc ::tcl::clock::add { clockval args } { set timezone $b } default { - return -code error \ - -errorcode [list CLOCK badSwitch $a] \ - "bad switch \"$a\",\ + throw [list CLOCK badOption $a] \ + "bad option \"$a\",\ must be -gmt, -locale or -timezone" } } @@ -4414,19 +4288,15 @@ proc ::tcl::clock::add { clockval args } { "cannot use -gmt and -timezone in same call" } if { [catch { expr { wide($clockval) } } result] } { - return -code error \ - "expected integer but got \"$clockval\"" + return -code error "expected integer but got \"$clockval\"" } - if { ![string is boolean $gmt] } { - return -code error \ - "expected boolean value but got \"$gmt\"" - } else { - if { $gmt } { - set timezone :GMT - } + if { ![string is boolean -strict $gmt] } { + return -code error "expected boolean value but got \"$gmt\"" + } elseif { $gmt } { + set timezone :GMT } - EnterLocale $locale oldLocale + EnterLocale $locale set changeover [mc GREGORIAN_CHANGE_DATE] @@ -4435,29 +4305,25 @@ proc ::tcl::clock::add { clockval args } { return -options $opts $retval } - set status [catch { - + try { foreach { quantity unit } $offsets { - switch -exact -- $unit { - years - year { - set clockval \ - [AddMonths [expr { 12 * $quantity }] \ - $clockval $timezone $changeover] + set clockval [AddMonths [expr { 12 * $quantity }] \ + $clockval $timezone $changeover] } months - month { set clockval [AddMonths $quantity $clockval $timezone \ - $changeover] + $changeover] } weeks - week { set clockval [AddDays [expr { 7 * $quantity }] \ - $clockval $timezone $changeover] + $clockval $timezone $changeover] } days - day { set clockval [AddDays $quantity $clockval $timezone \ - $changeover] + $changeover] } hours - hour { @@ -4471,31 +4337,18 @@ proc ::tcl::clock::add { clockval args } { } default { - error "unknown unit \"$unit\", must be \ - years, months, weeks, days, hours, minutes or seconds" \ - "unknown unit \"$unit\", must be \ - years, months, weeks, days, hours, minutes or seconds" \ - [list CLOCK badUnit $unit] + throw [list CLOCK badUnit $unit] \ + "unknown unit \"$unit\", must be \ + years, months, weeks, days, hours, minutes or seconds" } } } - } result opts] - - # Restore the locale - - if { [info exists oldLocale] } { - mclocale $oldLocale - } - - if { $status == 1 } { - if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } { - dict unset opts -errorinfo - } - return -options $opts $result - } else { return $clockval + } trap CLOCK {result opts} { + # Conceal the innards of [clock] when it's an expected error + dict unset opts -errorinfo + return -options $opts $result } - } #---------------------------------------------------------------------- @@ -4520,7 +4373,6 @@ proc ::tcl::clock::add { clockval args } { #---------------------------------------------------------------------- proc ::tcl::clock::AddMonths { months clockval timezone changeover } { - variable DaysInRomanMonthInCommonYear variable DaysInRomanMonthInLeapYear variable TZData @@ -4528,8 +4380,9 @@ proc ::tcl::clock::AddMonths { months clockval timezone changeover } { # Convert the time to year, month, day, and fraction of day. set date [GetDateFields $clockval $TZData($timezone) $changeover] - dict set date secondOfDay [expr { [dict get $date localSeconds] - % 86400 }] + dict set date secondOfDay [expr { + [dict get $date localSeconds] % 86400 + }] dict set date tzName $timezone # Add the requisite number of months @@ -4558,10 +4411,11 @@ proc ::tcl::clock::AddMonths { months clockval timezone changeover } { set date [GetJulianDayFromEraYearMonthDay \ $date[set date {}]\ $changeover] - dict set date localSeconds \ - [expr { -210866803200 - + ( 86400 * wide([dict get $date julianDay]) ) - + [dict get $date secondOfDay] }] + dict set date localSeconds [expr { + -210866803200 + + ( 86400 * wide([dict get $date julianDay]) ) + + [dict get $date secondOfDay] + }] set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \ $changeover] @@ -4573,8 +4427,8 @@ proc ::tcl::clock::AddMonths { months clockval timezone changeover } { # # AddDays -- # -# Add a given number of days to a given clock value in a given -# time zone. +# Add a given number of days to a given clock value in a given time +# zone. # # Parameters: # days - Number of days to add (may be negative) @@ -4584,8 +4438,7 @@ proc ::tcl::clock::AddMonths { months clockval timezone changeover } { # in the target locale. # # Results: -# Returns the new clock value as a number of seconds since -# the epoch. +# Returns the new clock value as a number of seconds since the epoch. # # Side effects: # None. @@ -4593,14 +4446,14 @@ proc ::tcl::clock::AddMonths { months clockval timezone changeover } { #---------------------------------------------------------------------- proc ::tcl::clock::AddDays { days clockval timezone changeover } { - variable TZData # Convert the time to Julian Day set date [GetDateFields $clockval $TZData($timezone) $changeover] - dict set date secondOfDay [expr { [dict get $date localSeconds] - % 86400 }] + dict set date secondOfDay [expr { + [dict get $date localSeconds] % 86400 + }] dict set date tzName $timezone # Add the requisite number of days @@ -4609,10 +4462,11 @@ proc ::tcl::clock::AddDays { days clockval timezone changeover } { # Reconvert to a number of seconds - dict set date localSeconds \ - [expr { -210866803200 - + ( 86400 * wide([dict get $date julianDay]) ) - + [dict get $date secondOfDay] }] + dict set date localSeconds [expr { + -210866803200 + + ( 86400 * wide([dict get $date julianDay]) ) + + [dict get $date secondOfDay] + }] set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) \ $changeover] @@ -4622,35 +4476,37 @@ proc ::tcl::clock::AddDays { days clockval timezone changeover } { #---------------------------------------------------------------------- # -# mc -- +# ChangeCurrentLocale -- # -# Wrapper around ::msgcat::mc that caches the result according -# to the locale. +# The global locale was changed within msgcat. +# Clears the buffered parse functions of the current locale. # # Parameters: -# Accepts the name of the message to retrieve. +# loclist (ignored) # # Results: -# Returns the message text. +# None. # # Side effects: -# Caches the message text. -# -# Notes: -# Only the single-argument version of [mc] is supported. +# Buffered parse functions are cleared. # #---------------------------------------------------------------------- -proc ::tcl::clock::mc { name } { - variable McLoaded - set Locale [mclocale] - if { [dict exists $McLoaded $Locale $name] } { - return [dict get $McLoaded $Locale $name] - } else { - set val [::msgcat::mc $name] - dict set McLoaded $Locale $name $val - return $val +proc ::tcl::clock::ChangeCurrentLocale {args} { + variable FormatProc + variable LocaleNumeralCache + variable CachedSystemTimeZone + variable TimeZoneBad + + foreach p [info procs [namespace current]::scanproc'*'current] { + rename $p {} } + foreach p [info procs [namespace current]::formatproc'*'current] { + rename $p {} + } + + catch {array unset FormatProc *'current} + set LocaleNumeralCache {} } #---------------------------------------------------------------------- @@ -4671,10 +4527,8 @@ proc ::tcl::clock::mc { name } { #---------------------------------------------------------------------- proc ::tcl::clock::ClearCaches {} { - variable FormatProc variable LocaleNumeralCache - variable McLoaded variable CachedSystemTimeZone variable TimeZoneBad @@ -4687,9 +4541,7 @@ proc ::tcl::clock::ClearCaches {} { catch {unset FormatProc} set LocaleNumeralCache {} - set McLoaded {} catch {unset CachedSystemTimeZone} set TimeZoneBad {} InitTZData - } diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl index 114dee6..4cf73d0 100644 --- a/library/dde/pkgIndex.tcl +++ b/library/dde/pkgIndex.tcl @@ -1,7 +1,7 @@ -if {![package vsatisfies [package provide Tcl] 8]} return -if {[info sharedlibextension] != ".dll"} return -if {[info exists ::tcl_platform(debug)]} { - package ifneeded dde 1.3.3 [list load [file join $dir tcldde13g.dll] dde] +if {([info commands ::tcl::pkgconfig] eq "") + || ([info sharedlibextension] ne ".dll")} return +if {[::tcl::pkgconfig get debug]} { + package ifneeded dde 1.4.0 [list load [file join $dir tcldde14g.dll] dde] } else { - package ifneeded dde 1.3.3 [list load [file join $dir tcldde13.dll] dde] + package ifneeded dde 1.4.0 [list load [file join $dir tcldde14.dll] dde] } diff --git a/library/history.tcl b/library/history.tcl index 888d144..51d2404 100644 --- a/library/history.tcl +++ b/library/history.tcl @@ -4,18 +4,18 @@ # # Copyright (c) 1997 Sun Microsystems, Inc. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. # - -# The tcl::history array holds the history list and -# some additional bookkeeping variables. + +# The tcl::history array holds the history list and some additional +# bookkeeping variables. # # nextid the index used for the next history list item. # keep the max size of the history list # oldest the index of the oldest item in the history. -namespace eval tcl { +namespace eval ::tcl { variable history if {![info exists history]} { array set history { @@ -24,163 +24,78 @@ namespace eval tcl { oldest -20 } } -} + namespace ensemble create -command ::tcl::history -map { + add ::tcl::HistAdd + change ::tcl::HistChange + clear ::tcl::HistClear + event ::tcl::HistEvent + info ::tcl::HistInfo + keep ::tcl::HistKeep + nextid ::tcl::HistNextID + redo ::tcl::HistRedo + } +} + # history -- # # This is the main history command. See the man page for its interface. -# This does argument checking and calls helper procedures in the -# history namespace. - -proc history {args} { - set len [llength $args] - if {$len == 0} { - return [tcl::HistInfo] - } - set key [lindex $args 0] - set options "add, change, clear, event, info, keep, nextid, or redo" - switch -glob -- $key { - a* { # history add - - if {$len > 3} { - return -code error "wrong # args: should be \"history add event ?exec?\"" - } - if {![string match $key* add]} { - return -code error "bad option \"$key\": must be $options" - } - if {$len == 3} { - set arg [lindex $args 2] - if {! ([string match e* $arg] && [string match $arg* exec])} { - return -code error "bad argument \"$arg\": should be \"exec\"" - } - } - return [tcl::HistAdd [lindex $args 1] [lindex $args 2]] - } - ch* { # history change - - if {($len > 3) || ($len < 2)} { - return -code error "wrong # args: should be \"history change newValue ?event?\"" - } - if {![string match $key* change]} { - return -code error "bad option \"$key\": must be $options" - } - if {$len == 2} { - set event 0 - } else { - set event [lindex $args 2] - } - - return [tcl::HistChange [lindex $args 1] $event] - } - cl* { # history clear - - if {($len > 1)} { - return -code error "wrong # args: should be \"history clear\"" - } - if {![string match $key* clear]} { - return -code error "bad option \"$key\": must be $options" - } - return [tcl::HistClear] - } - e* { # history event - - if {$len > 2} { - return -code error "wrong # args: should be \"history event ?event?\"" - } - if {![string match $key* event]} { - return -code error "bad option \"$key\": must be $options" - } - if {$len == 1} { - set event -1 - } else { - set event [lindex $args 1] - } - return [tcl::HistEvent $event] - } - i* { # history info - - if {$len > 2} { - return -code error "wrong # args: should be \"history info ?count?\"" - } - if {![string match $key* info]} { - return -code error "bad option \"$key\": must be $options" - } - return [tcl::HistInfo [lindex $args 1]] - } - k* { # history keep +# This does some argument checking and calls the helper ensemble in the +# tcl namespace. - if {$len > 2} { - return -code error "wrong # args: should be \"history keep ?count?\"" - } - if {$len == 1} { - return [tcl::HistKeep] - } else { - set limit [lindex $args 1] - if {[catch {expr {~$limit}}] || ($limit < 0)} { - return -code error "illegal keep count \"$limit\"" - } - return [tcl::HistKeep $limit] - } - } - n* { # history nextid - - if {$len > 1} { - return -code error "wrong # args: should be \"history nextid\"" - } - if {![string match $key* nextid]} { - return -code error "bad option \"$key\": must be $options" - } - return [expr {$tcl::history(nextid) + 1}] - } - r* { # history redo +proc ::history {args} { + # If no command given, we're doing 'history info'. Can't be done with an + # ensemble unknown handler, as those don't fire when no subcommand is + # given at all. - if {$len > 2} { - return -code error "wrong # args: should be \"history redo ?event?\"" - } - if {![string match $key* redo]} { - return -code error "bad option \"$key\": must be $options" - } - return [tcl::HistRedo [lindex $args 1]] - } - default { - return -code error "bad option \"$key\": must be $options" - } + if {![llength $args]} { + set args info } -} + # Tricky stuff needed to make stack and errors come out right! + tailcall apply {arglist {tailcall history {*}$arglist} ::tcl} $args +} + # tcl::HistAdd -- # # Add an item to the history, and optionally eval it at the global scope # # Parameters: -# command the command to add -# exec (optional) a substring of "exec" causes the -# command to be evaled. +# event the command to add +# exec (optional) a substring of "exec" causes the command to +# be evaled. # Results: # If executing, then the results of the command are returned # # Side Effects: # Adds to the history list - proc tcl::HistAdd {command {exec {}}} { +proc ::tcl::HistAdd {event {exec {}}} { variable history + if { + [prefix longest {exec {}} $exec] eq "" + && [llength [info level 0]] == 3 + } then { + return -code error "bad argument \"$exec\": should be \"exec\"" + } + # Do not add empty commands to the history - if {[string trim $command] eq ""} { + if {[string trim $event] eq ""} { return "" } - set i [incr history(nextid)] - set history($i) $command - set j [incr history(oldest)] - unset -nocomplain history($j) - if {[string match e* $exec]} { - return [uplevel #0 $command] - } else { - return {} + # Maintain the history + set history([incr history(nextid)]) $event + unset -nocomplain history([incr history(oldest)]) + + # Only execute if 'exec' (or non-empty prefix of it) given + if {$exec eq ""} { + return "" } + tailcall eval $event } - + # tcl::HistKeep -- # # Set or query the limit on the length of the history list @@ -194,20 +109,22 @@ proc history {args} { # Side Effects: # Updates history(keep) if a limit is specified - proc tcl::HistKeep {{limit {}}} { +proc ::tcl::HistKeep {{count {}}} { variable history - if {$limit eq ""} { + if {[llength [info level 0]] == 1} { return $history(keep) - } else { - set oldold $history(oldest) - set history(oldest) [expr {$history(nextid) - $limit}] - for {} {$oldold <= $history(oldest)} {incr oldold} { - unset -nocomplain history($oldold) - } - set history(keep) $limit } + if {![string is integer -strict $count] || ($count < 0)} { + return -code error "illegal keep count \"$count\"" + } + set oldold $history(oldest) + set history(oldest) [expr {$history(nextid) - $count}] + for {} {$oldold <= $history(oldest)} {incr oldold} { + unset -nocomplain history($oldold) + } + set history(keep) $count } - + # tcl::HistClear -- # # Erase the history list @@ -221,7 +138,7 @@ proc history {args} { # Side Effects: # Resets the history array, except for the keep limit - proc tcl::HistClear {} { +proc ::tcl::HistClear {} { variable history set keep $history(keep) unset history @@ -231,7 +148,7 @@ proc history {args} { oldest -$keep \ ] } - + # tcl::HistInfo -- # # Return a pretty-printed version of the history list @@ -242,14 +159,16 @@ proc history {args} { # Results: # A formatted history list - proc tcl::HistInfo {{num {}}} { +proc ::tcl::HistInfo {{count {}}} { variable history - if {$num eq ""} { - set num [expr {$history(keep) + 1}] + if {[llength [info level 0]] == 1} { + set count [expr {$history(keep) + 1}] + } elseif {![string is integer -strict $count]} { + return -code error "bad integer \"$count\"" } set result {} set newline "" - for {set i [expr {$history(nextid) - $num + 1}]} \ + for {set i [expr {$history(nextid) - $count + 1}]} \ {$i <= $history(nextid)} {incr i} { if {![info exists history($i)]} { continue @@ -260,11 +179,11 @@ proc history {args} { } return $result } - + # tcl::HistRedo -- # -# Fetch the previous or specified event, execute it, and then -# replace the current history item with that event. +# Fetch the previous or specified event, execute it, and then replace +# the current history item with that event. # # Parameters: # event (optional) index of history item to redo. Defaults to -1, @@ -276,20 +195,18 @@ proc history {args} { # Side Effects: # Replaces the current history list item with the one being redone. - proc tcl::HistRedo {{event -1}} { +proc ::tcl::HistRedo {{event -1}} { variable history - if {$event eq ""} { - set event -1 - } + set i [HistIndex $event] if {$i == $history(nextid)} { return -code error "cannot redo the current event" } set cmd $history($i) HistChange $cmd 0 - uplevel #0 $cmd + tailcall eval $cmd } - + # tcl::HistIndex -- # # Map from an event specifier to an index in the history list. @@ -299,22 +216,22 @@ proc history {args} { # If this is a positive number, it is used directly. # If it is a negative number, then it counts back to a previous # event, where -1 is the most recent event. -# A string can be matched, either by being the prefix of -# a command or by matching a command with string match. +# A string can be matched, either by being the prefix of a +# command or by matching a command with string match. # # Results: # The index into history, or an error if the index didn't match. - proc tcl::HistIndex {event} { +proc ::tcl::HistIndex {event} { variable history - if {[catch {expr {~$event}}]} { + if {![string is integer -strict $event]} { for {set i [expr {$history(nextid)-1}]} {[info exists history($i)]} \ {incr i -1} { if {[string match $event* $history($i)]} { - return $i; + return $i } if {[string match $event $history($i)]} { - return $i; + return $i } } return -code error "no event matches \"$event\"" @@ -331,43 +248,64 @@ proc history {args} { } return $i } - + # tcl::HistEvent -- # # Map from an event specifier to the value in the history list. # # Parameters: -# event index of history item to redo. See index for a -# description of possible event patterns. +# event index of history item to redo. See index for a description of +# possible event patterns. # # Results: # The value from the history list. - proc tcl::HistEvent {event} { +proc ::tcl::HistEvent {{event -1}} { variable history set i [HistIndex $event] - if {[info exists history($i)]} { - return [string trimright $history($i) \ \n] - } else { - return ""; + if {![info exists history($i)]} { + return "" } + return [string trimright $history($i) \ \n] } - + # tcl::HistChange -- # # Replace a value in the history list. # # Parameters: -# cmd The new value to put into the history list. -# event (optional) index of history item to redo. See index for a -# description of possible event patterns. This defaults -# to 0, which specifies the current event. +# newValue The new value to put into the history list. +# event (optional) index of history item to redo. See index for a +# description of possible event patterns. This defaults to 0, +# which specifies the current event. # # Side Effects: # Changes the history list. - proc tcl::HistChange {cmd {event 0}} { +proc ::tcl::HistChange {newValue {event 0}} { variable history set i [HistIndex $event] - set history($i) $cmd + set history($i) $newValue } + +# tcl::HistNextID -- +# +# Returns the number of the next history event. +# +# Parameters: +# None. +# +# Side Effects: +# None. + +proc ::tcl::HistNextID {} { + variable history + return [expr {$history(nextid) + 1}] +} + +return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/library/http/http.tcl b/library/http/http.tcl index 4c99f62..5a05fa0 100644 --- a/library/http/http.tcl +++ b/library/http/http.tcl @@ -8,10 +8,10 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.4 +package require Tcl 8.6 # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.7.13 +package provide http 2.8.9 namespace eval http { # Allow resourcing to not clobber existing data @@ -25,7 +25,13 @@ namespace eval http { -proxyfilter http::ProxyRequired -urlencoding utf-8 } - set http(-useragent) "Tcl http client package [package provide http]" + # We need a useragent string of this style or various servers will refuse to + # send us compressed content even when we ask for it. This follows the + # de-facto layout of user-agent strings in current browsers. + set http(-useragent) "Mozilla/5.0\ + ([string totitle $::tcl_platform(platform)]; U;\ + $::tcl_platform(os) $::tcl_platform(osVersion))\ + http/[package provide http] Tcl/[package provide Tcl]" } proc init {} { @@ -92,7 +98,7 @@ namespace eval http { # Arguments: # msg Message to output # -proc http::Log {args} {} +if {[info command http::Log] eq {}} {proc http::Log {args} {}} # http::register -- # @@ -194,7 +200,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} { if { ($state(status) eq "timeout") || ($state(status) eq "error") || ([info exists state(connection)] && ($state(connection) eq "close")) - } then { + } { CloseSocket $state(sock) $token } if {[info exists state(after)]} { @@ -360,7 +366,7 @@ proc http::geturl {url args} { if { [info exists type($flag)] && ![string is $type($flag) -strict $value] - } then { + } { unset $token return -code error \ "Bad value for $flag ($value), must be $type($flag)" @@ -415,7 +421,6 @@ proc http::geturl {url args} { # Note that the RE actually combines the user and password parts, as # recommended in RFC 3986. Indeed, that RFC states that putting passwords # in URLs is a Really Bad Idea, something with which I would agree utterly. - # Also note that we do not currently support IPv6 addresses. # # From a validation perspective, we need to ensure that the parts of the # URL that are going to the server are correctly encoded. This is only @@ -430,7 +435,10 @@ proc http::geturl {url args} { [^@/\#?]+ # <userinfo part of authority> ) @ )? - ( [^/:\#?]+ ) # <host part of authority> + ( # <host part of authority> + [^/:\#?]+ | # host name or IPv4 address + \[ [^/\#?]+ \] # IPv6 address in square brackets + ) (?: : (\d+) )? # <port part of authority> )? ( [/\?] [^\#]*)? # <path> (including query) @@ -444,6 +452,7 @@ proc http::geturl {url args} { return -code error "Unsupported URL: $url" } # Phase two: validate + set host [string trim $host {[]}]; # strip square brackets from IPv6 address if {$host eq ""} { # Caller has to provide a host name; we do not have a "default host" # that would enable us to handle relative URLs. @@ -557,6 +566,10 @@ proc http::geturl {url args} { # Proxy connections aren't shared among different hosts. set state(socketinfo) $host:$port + # Save the accept types at this point to prevent a race condition. [Bug + # c11a51c482] + set state(accept-types) $http(-accept) + # See if we are supposed to use a previously opened channel. if {$state(-keepalive)} { variable socketmap @@ -628,8 +641,20 @@ proc http::geturl {url args} { return $token } +# http::Connected -- +# +# Callback used when the connection to the HTTP server is actually +# established. +# +# Arguments: +# token State token. +# proto What protocol (http, https, etc.) was used to connect. +# phost Are we using keep-alive? Non-empty if yes. +# srvurl Service-local URL that we're requesting +# Results: +# None. -proc http::Connected { token proto phost srvurl} { +proc http::Connected {token proto phost srvurl} { variable http variable urlTypes @@ -677,14 +702,17 @@ proc http::Connected { token proto phost srvurl} { if {[info exists state(-method)] && $state(-method) ne ""} { set how $state(-method) } - + # We cannot handle chunked encodings with -handler, so force HTTP/1.0 + # until we can manage this. + if {[info exists state(-handler)]} { + set state(-protocol) 1.0 + } + set accept_types_seen 0 if {[catch { puts $sock "$how $srvurl HTTP/$state(-protocol)" - puts $sock "Accept: $http(-accept)" - array set hdrs $state(-headers) - if {[info exists hdrs(Host)]} { + if {[dict exists $state(-headers) Host]} { # Allow Host spoofing. [Bug 928154] - puts $sock "Host: $hdrs(Host)" + puts $sock "Host: [dict get $state(-headers) Host]" } elseif {$port == $defport} { # Don't add port in this case, to handle broken servers. [Bug # #504508] @@ -692,7 +720,6 @@ proc http::Connected { token proto phost srvurl} { } else { puts $sock "Host: $host:$port" } - unset hdrs puts $sock "User-Agent: $http(-useragent)" if {$state(-protocol) == 1.0 && $state(-keepalive)} { puts $sock "Connection: keep-alive" @@ -705,18 +732,21 @@ proc http::Connected { token proto phost srvurl} { } set accept_encoding_seen 0 set content_type_seen 0 - foreach {key value} $state(-headers) { + dict for {key value} $state(-headers) { + set value [string map [list \n "" \r ""] $value] + set key [string map {" " -} [string trim $key]] if {[string equal -nocase $key "host"]} { continue } if {[string equal -nocase $key "accept-encoding"]} { set accept_encoding_seen 1 } + if {[string equal -nocase $key "accept"]} { + set accept_types_seen 1 + } if {[string equal -nocase $key "content-type"]} { set content_type_seen 1 } - set value [string map [list \n "" \r ""] $value] - set key [string trim $key] if {[string equal -nocase $key "content-length"]} { set contDone 1 set state(querylength) $value @@ -725,14 +755,13 @@ proc http::Connected { token proto phost srvurl} { puts $sock "$key: $value" } } - # Soft zlib dependency check - no package require - if { - !$accept_encoding_seen && - ([package vsatisfies [package provide Tcl] 8.6] - || [llength [package provide zlib]]) && - !([info exists state(-channel)] || [info exists state(-handler)]) - } then { - puts $sock "Accept-Encoding: gzip, identity, *;q=0.1" + # Allow overriding the Accept header on a per-connection basis. Useful + # for working with REST services. [Bug c11a51c482] + if {!$accept_types_seen} { + puts $sock "Accept: $state(accept-types)" + } + if {!$accept_encoding_seen && ![info exists state(-handler)]} { + puts $sock "Accept-Encoding: gzip,deflate,compress" } if {$isQueryChannel && $state(querylength) == 0} { # Try to determine size of data in channel. If we cannot seek, the @@ -756,7 +785,7 @@ proc http::Connected { token proto phost srvurl} { # versions TclHttpd in various error cases). Depending on the # platform, the client may or may not be able to get the response from # the server because of the error it will get trying to write the post - # data. Having both fileevents active changes the timing and the + # data. Having both fileevents active changes the timing and the # behavior, but no two platforms (among Solaris, Linux, and NT) behave # the same, and none behave all that well in any case. Servers should # always read their POST data if they expect the client to read their @@ -778,7 +807,7 @@ proc http::Connected { token proto phost srvurl} { fileevent $sock readable [list http::Event $sock $token] } - } err]} then { + } err]} { # The socket probably was never connected, or the connection dropped # later. @@ -788,7 +817,6 @@ proc http::Connected { token proto phost srvurl} { Finish $token $err } } - } # Data access functions: @@ -879,7 +907,7 @@ proc http::Connect {token proto phost srvurl} { if { [eof $state(sock)] || [set err [fconfigure $state(sock) -error]] ne "" - } then { + } { Finish $token "connect failed $err" } else { fileevent $state(sock) writable {} @@ -930,7 +958,7 @@ proc http::Write {token} { set done 1 } } - } err]} then { + } err]} { # Do not call Finish here, but instead let the read half of the socket # process whatever server reply there is to get. @@ -1009,7 +1037,7 @@ proc http::Event {sock token} { && ($state(connection) eq "close")) || [info exists state(transfer)]) && ($state(totalsize) == 0) - } then { + } { Log "body size is 0 and no events likely - complete." Eof $token return @@ -1020,26 +1048,20 @@ proc http::Event {sock token} { if { $state(-binary) || ![string match -nocase text* $state(type)] - } then { + } { # Turn off conversions for non-text data set state(binary) 1 } - if { - $state(binary) || [string match *gzip* $state(coding)] || - [string match *compress* $state(coding)] - } then { - if {[info exists state(-channel)]} { + if {[info exists state(-channel)]} { + if {$state(binary) || [llength [ContentEncoding $token]]} { fconfigure $state(-channel) -translation binary } - } - if { - [info exists state(-channel)] && - ![info exists state(-handler)] - } then { - # Initiate a sequence of background fcopies - fileevent $sock readable {} - CopyStart $sock $token - return + if {![info exists state(-handler)]} { + # Initiate a sequence of background fcopies + fileevent $sock readable {} + CopyStart $sock $token + return + } } } elseif {$n > 0} { # Process header lines @@ -1094,7 +1116,7 @@ proc http::Event {sock token} { } elseif { [info exists state(transfer)] && $state(transfer) eq "chunked" - } then { + } { set size 0 set chunk [getTextLine $sock] set n [string length $chunk] @@ -1134,11 +1156,11 @@ proc http::Event {sock token} { if { ($state(totalsize) > 0) && ($state(currentsize) >= $state(totalsize)) - } then { + } { Eof $token } } - } err]} then { + } err]} { return [Finish $token $err] } else { if {[info exists state(-progress)]} { @@ -1191,14 +1213,54 @@ proc http::getTextLine {sock} { # Side Effects # This closes the connection upon error -proc http::CopyStart {sock token} { - variable $token +proc http::CopyStart {sock token {initial 1}} { + upvar #0 $token state + if {[info exists state(transfer)] && $state(transfer) eq "chunked"} { + foreach coding [ContentEncoding $token] { + lappend state(zlib) [zlib stream $coding] + } + make-transformation-chunked $sock [namespace code [list CopyChunk $token]] + } else { + if {$initial} { + foreach coding [ContentEncoding $token] { + zlib push $coding $sock + } + } + if {[catch { + fcopy $sock $state(-channel) -size $state(-blocksize) -command \ + [list http::CopyDone $token] + } err]} { + Finish $token $err + } + } +} + +proc http::CopyChunk {token chunk} { upvar 0 $token state - if {[catch { - fcopy $sock $state(-channel) -size $state(-blocksize) -command \ - [list http::CopyDone $token] - } err]} then { - Finish $token $err + if {[set count [string length $chunk]]} { + incr state(currentsize) $count + if {[info exists state(zlib)]} { + foreach stream $state(zlib) { + set chunk [$stream add $chunk] + } + } + puts -nonewline $state(-channel) $chunk + if {[info exists state(-progress)]} { + eval [linsert $state(-progress) end \ + $token $state(totalsize) $state(currentsize)] + } + } else { + Log "CopyChunk Finish $token" + if {[info exists state(zlib)]} { + set excess "" + foreach stream $state(zlib) { + catch {set excess [$stream add -finalize $excess]} + } + puts -nonewline $state(-channel) $excess + foreach stream $state(zlib) { $stream close } + unset state(zlib) + } + Eof $token ;# FIX ME: pipelining. } } @@ -1228,7 +1290,7 @@ proc http::CopyDone {token count {error {}}} { } elseif {[catch {eof $sock} iseof] || $iseof} { Eof $token } else { - CopyStart $sock $token + CopyStart $sock $token 0 } } @@ -1252,34 +1314,31 @@ proc http::Eof {token {force 0}} { set state(status) ok } - if {($state(coding) eq "gzip") && [string length $state(body)] > 0} { - if {[catch { - if {[package vsatisfies [package present Tcl] 8.6]} { - # The zlib integration into 8.6 includes proper gzip support - set state(body) [zlib gunzip $state(body)] - } else { - set state(body) [Gunzip $state(body)] + if {[string length $state(body)] > 0} { + if {[catch { + foreach coding [ContentEncoding $token] { + set state(body) [zlib $coding $state(body)] } - } err]} then { + } err]} { + Log "error doing decompression: $err" return [Finish $token $err] - } - } + } - if {!$state(binary)} { - # If we are getting text, set the incoming channel's encoding - # correctly. iso8859-1 is the RFC default, but this could be any IANA - # charset. However, we only know how to convert what we have - # encodings for. + if {!$state(binary)} { + # If we are getting text, set the incoming channel's encoding + # correctly. iso8859-1 is the RFC default, but this could be any IANA + # charset. However, we only know how to convert what we have + # encodings for. - set enc [CharsetToEncoding $state(charset)] - if {$enc ne "binary"} { - set state(body) [encoding convertfrom $enc $state(body)] - } + set enc [CharsetToEncoding $state(charset)] + if {$enc ne "binary"} { + set state(body) [encoding convertfrom $enc $state(body)] + } - # Translate text line endings. - set state(body) [string map {\r\n \n \r \n} $state(body)] + # Translate text line endings. + set state(body) [string map {\r\n \n \r \n} $state(body)] + } } - Finish $token } @@ -1355,7 +1414,7 @@ proc http::mapReply {string} { } set converted [string map $formMap $string] if {[string match "*\[\u0100-\uffff\]*" $converted]} { - regexp {[\u0100-\uffff]} $converted badChar + regexp "\[\u0100-\uffff\]" $converted badChar # Return this error message for maximum compatability... :^/ return -code error \ "can't read \"formMap($badChar)\": no such element in array" @@ -1378,7 +1437,7 @@ proc http::ProxyRequired {host} { if { ![info exists http(-proxyport)] || ![string length $http(-proxyport)] - } then { + } { set http(-proxyport) 8080 } return [list $http(-proxyhost) $http(-proxyport)] @@ -1424,59 +1483,57 @@ proc http::CharsetToEncoding {charset} { } } -# http::Gunzip -- -# -# Decompress data transmitted using the gzip transfer coding. -# - -# FIX ME: redo using zlib sinflate -proc http::Gunzip {data} { - binary scan $data Scb5icc magic method flags time xfl os - set pos 10 - if {$magic != 0x1f8b} { - return -code error "invalid data: supplied data is not in gzip format" - } - if {$method != 8} { - return -code error "invalid compression method" - } - - # lassign [split $flags ""] f_text f_crc f_extra f_name f_comment - foreach {f_text f_crc f_extra f_name f_comment} [split $flags ""] break - set extra "" - if {$f_extra} { - binary scan $data @${pos}S xlen - incr pos 2 - set extra [string range $data $pos $xlen] - set pos [incr xlen] - } - - set name "" - if {$f_name} { - set ndx [string first \0 $data $pos] - set name [string range $data $pos $ndx] - set pos [incr ndx] - } - - set comment "" - if {$f_comment} { - set ndx [string first \0 $data $pos] - set comment [string range $data $pos $ndx] - set pos [incr ndx] - } - - set fcrc "" - if {$f_crc} { - set fcrc [string range $data $pos [incr pos]] - incr pos +# Return the list of content-encoding transformations we need to do in order. +proc http::ContentEncoding {token} { + upvar 0 $token state + set r {} + if {[info exists state(coding)]} { + foreach coding [split $state(coding) ,] { + switch -exact -- $coding { + deflate { lappend r inflate } + gzip - x-gzip { lappend r gunzip } + compress - x-compress { lappend r decompress } + identity {} + default { + return -code error "unsupported content-encoding \"$coding\"" + } + } + } } + return $r +} - binary scan [string range $data end-7 end] ii crc size - set inflated [zlib inflate [string range $data $pos end-8]] - set chk [zlib crc32 $inflated] - if {($crc & 0xffffffff) != ($chk & 0xffffffff)} { - return -code error "invalid data: checksum mismatch $crc != $chk" - } - return $inflated +proc http::make-transformation-chunked {chan command} { + set lambda {{chan command} { + set data "" + set size -1 + yield + while {1} { + chan configure $chan -translation {crlf binary} + while {[gets $chan line] < 1} { yield } + chan configure $chan -translation {binary binary} + if {[scan $line %x size] != 1} { return -code error "invalid size: \"$line\"" } + set chunk "" + while {$size && ![chan eof $chan]} { + set part [chan read $chan $size] + incr size -[string length $part] + append chunk $part + } + if {[catch { + uplevel #0 [linsert $command end $chunk] + }]} { + http::Log "Error in callback: $::errorInfo" + } + if {[string length $chunk] == 0} { + # channel might have been closed in the callback + catch {chan event $chan readable {}} + return + } + } + }} + coroutine dechunk$chan ::apply $lambda $chan $command + chan event $chan readable [namespace origin dechunk$chan] + return } # Local variables: diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index be8b883..6e0301a 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,4 +1,2 @@ -# Tcl package index file, version 1.1 - -if {![package vsatisfies [package provide Tcl] 8.4]} {return} -package ifneeded http 2.7.13 [list tclPkgSetup $dir http 2.7.13 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +if {![package vsatisfies [package provide Tcl] 8.6]} {return} +package ifneeded http 2.8.9 [list tclPkgSetup $dir http 2.8.9 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] diff --git a/library/http1.0/http.tcl b/library/http1.0/http.tcl index 8041ee4..8329de4 100644 --- a/library/http1.0/http.tcl +++ b/library/http1.0/http.tcl @@ -339,12 +339,12 @@ proc http_formatQuery {args} { # 2 Convert every other character to an array lookup # 3 Escape constructs that are "special" to the tcl parser # 4 "subst" the result, doing all the array substitutions - + proc httpMapReply {string} { global httpFormMap set alphanumeric a-zA-Z0-9 if {![info exists httpFormMap]} { - + for {set i 1} {$i <= 256} {incr i} { set c [format %c $i] if {![string match \[$alphanumeric\] $c]} { @@ -363,7 +363,7 @@ proc http_formatQuery {args} { return [subst $string] } -# Default proxy filter. +# Default proxy filter. proc httpProxyRequired {host} { global http if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} { diff --git a/library/init.tcl b/library/init.tcl index aaf148b..9fd2170 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -16,7 +16,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 8.5.19 +package require -exact Tcl 8.6.5 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: @@ -142,11 +142,7 @@ if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} { } } if {![info exists env(COMSPEC)]} { - if {$tcl_platform(os) eq "Windows NT"} { - set env(COMSPEC) cmd.exe - } else { - set env(COMSPEC) command.com - } + set env(COMSPEC) cmd.exe } } InitWinEnv @@ -218,11 +214,9 @@ if {[namespace which -command tclLog] eq ""} { # exist in the interpreter. It takes the following steps to make the # command available: # -# 1. See if the command has the form "namespace inscope ns cmd" and -# if so, concatenate its arguments onto the end and evaluate it. -# 2. See if the autoload facility can locate the command in a +# 1. See if the autoload facility can locate the command in a # Tcl script file. If so, load it and execute it. -# 3. If the command was invoked interactively at top-level: +# 2. If the command was invoked interactively at top-level: # (a) see if the command exists as an executable UNIX program. # If so, "exec" the command. # (b) see if the command requests csh-like history substitution @@ -239,22 +233,14 @@ proc unknown args { variable ::tcl::UnknownPending global auto_noexec auto_noload env tcl_interactive errorInfo errorCode - # If the command word has the form "namespace inscope ns cmd" - # then concatenate its arguments onto the end and evaluate it. - - set cmd [lindex $args 0] - if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} { - #return -code error "You need an {*}" - set arglist [lrange $args 1 end] - set ret [catch {uplevel 1 ::$cmd $arglist} result opts] - dict unset opts -errorinfo - dict incr opts -level - return -options $opts $result + if {[info exists errorInfo]} { + set savedErrorInfo $errorInfo + } + if {[info exists errorCode]} { + set savedErrorCode $errorCode } - catch {set savedErrorInfo $errorInfo} - catch {set savedErrorCode $errorCode} - set name $cmd + set name [lindex $args 0] if {![info exists auto_noload]} { # # Make sure we're not trying to load the same proc twice. @@ -412,7 +398,8 @@ proc unknown args { return -code error "ambiguous command name \"$name\": [lsort $cmds]" } } - return -code error "invalid command name \"$name\"" + return -code error -errorcode [list TCL LOOKUP COMMAND $name] \ + "invalid command name \"$name\"" } # auto_load -- diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl index cf3b9d7..a43f13e 100644 --- a/library/msgcat/msgcat.tcl +++ b/library/msgcat/msgcat.tcl @@ -4,6 +4,7 @@ # message catalog facility for Tcl programs. It should be # loaded with the command "package require msgcat". # +# Copyright (c) 2010-2015 by Harald Oehlmann. # Copyright (c) 1998-2000 by Ajuba Solutions. # Copyright (c) 1998 by Mark Harrison. # @@ -13,23 +14,30 @@ package require Tcl 8.5 # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. -package provide msgcat 1.5.2 +package provide msgcat 1.6.0 namespace eval msgcat { - namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \ - mcunknown mcflset mcflmset - - # Records the current locale as passed to mclocale - variable Locale "" + namespace export mc mcexists mcload mclocale mcmax mcmset mcpreferences mcset\ + mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\ + mcpackageconfig mcpackagelocale # Records the list of locales to search variable Loclist {} + # List of currently loaded locales + variable LoadedLocales {} + # Records the locale of the currently sourced message catalogue file variable FileLocale + # Configuration values per Package (e.g. client namespace). + # The dict key is of the form "<option> <namespace>" and the value is the + # configuration option. A nonexisting key is an unset option. + variable PackageConfig [dict create mcfolder {} loadcmd {} changecmd {}\ + unknowncmd {} loadedlocales {} loclist {}] + # Records the mapping between source strings and translated strings. The - # dict key is of the form "<locale> <namespace> <src>", where locale and + # dict key is of the form "<namespace> <locale> <src>", where locale and # namespace should be themselves dict values and the value is # the translated string. variable Msgs [dict create] @@ -173,6 +181,8 @@ namespace eval msgcat { # parent namespace until the source is found. If additional args are # specified, use the format command to work them into the traslated # string. +# If no catalog item is found, mcunknown is called in the caller frame +# and its result is returned. # # Arguments: # src The string to translate. @@ -183,30 +193,86 @@ namespace eval msgcat { # format command. proc msgcat::mc {src args} { + # this may be replaced by: + # return [mcget -namespace [uplevel 1 [list ::namespace current]] --\ + # $src {*}$args] + # Check for the src in each namespace starting from the local and # ending in the global. variable Msgs variable Loclist - variable Locale set ns [uplevel 1 [list ::namespace current]] + set loclist [PackagePreferences $ns] - while {$ns != ""} { - foreach loc $Loclist { - if {[dict exists $Msgs $loc $ns $src]} { - if {[llength $args] == 0} { - return [dict get $Msgs $loc $ns $src] - } else { - return [format [dict get $Msgs $loc $ns $src] {*}$args] - } + set nscur $ns + while {$nscur != ""} { + foreach loc $loclist { + if {[dict exists $Msgs $nscur $loc $src]} { + return [DefaultUnknown "" [dict get $Msgs $nscur $loc $src]\ + {*}$args] + } + } + set nscur [namespace parent $nscur] + } + # call package local or default unknown command + set args [linsert $args 0 [lindex $loclist 0] $src] + switch -exact -- [Invoke unknowncmd $args $ns result 1] { + 0 { return [uplevel 1 [linsert $args 0 [namespace origin mcunknown]]] } + 1 { return [DefaultUnknown {*}$args] } + default { return $result } + } +} + +# msgcat::mcexists -- +# +# Check if a catalog item is set or if mc would invoke mcunknown. +# +# Arguments: +# -exactnamespace Only check the exact namespace and no +# parent namespaces +# -exactlocale Only check the exact locale and not all members +# of the preferences list +# src Message catalog key +# +# Results: +# true if an adequate catalog key was found + +proc msgcat::mcexists {args} { + + variable Msgs + variable Loclist + variable PackageConfig + + set ns [uplevel 1 [list ::namespace current]] + set loclist [PackagePreferences $ns] + + while {[llength $args] != 1} { + set args [lassign $args option] + switch -glob -- $option { + -exactnamespace { set exactnamespace 1 } + -exactlocale { set loclist [lrange $loclist 0 0] } + -* { return -code error "unknown option \"$option\"" } + default { + return -code error "wrong # args: should be\ + \"[lindex [info level 0] 0] ?-exactnamespace?\ + ?-exactlocale? src\"" } } + } + set src [lindex $args 0] + + while {$ns ne ""} { + foreach loc $loclist { + if {[dict exists $Msgs $ns $loc $src]} { + return 1 + } + } + if {[info exists exactnamespace]} {return 0} set ns [namespace parent $ns] } - # we have not found the translation - return [uplevel 1 [list [namespace origin mcunknown] \ - $Locale $src {*}$args]] + return 0 } # msgcat::mclocale -- @@ -219,11 +285,11 @@ proc msgcat::mc {src args} { # separated by underscores (e.g. en_US). # # Results: -# Returns the current locale. +# Returns the normalized set locale. proc msgcat::mclocale {args} { variable Loclist - variable Locale + variable LoadedLocales set len [llength $args] if {$len > 1} { @@ -232,24 +298,49 @@ proc msgcat::mclocale {args} { } if {$len == 1} { - set newLocale [lindex $args 0] + set newLocale [string tolower [lindex $args 0]] if {$newLocale ne [file tail $newLocale]} { return -code error "invalid newLocale value \"$newLocale\":\ could be path to unsafe code." } - set Locale [string tolower $newLocale] - set Loclist {} - set word "" - foreach part [split $Locale _] { - set word [string trim "${word}_${part}" _] - if {$word ne [lindex $Loclist 0]} { - set Loclist [linsert $Loclist 0 $word] - } + if {[lindex $Loclist 0] ne $newLocale} { + set Loclist [GetPreferences $newLocale] + + # locale not loaded jet + LoadAll $Loclist + # Invoke callback + Invoke changecmd $Loclist + } + } + return [lindex $Loclist 0] +} + +# msgcat::GetPreferences -- +# +# Get list of locales from a locale. +# The first element is always the lowercase locale. +# Other elements have one component separated by "_" less. +# Multiple "_" are seen as one separator: de__ch_spec de__ch de {} +# +# Arguments: +# Locale. +# +# Results: +# Locale list + +proc msgcat::GetPreferences {locale} { + set locale [string tolower $locale] + set loclist [list $locale] + while {-1 !=[set pos [string last "_" $locale]]} { + set locale [string range $locale 0 $pos-1] + if { "_" ne [string index $locale end] } { + lappend loclist $locale } - lappend Loclist {} - set Locale [lindex $Loclist 0] } - return $Locale + if {"" ne [lindex $loclist end]} { + lappend loclist {} + } + return $loclist } # msgcat::mcpreferences -- @@ -268,6 +359,391 @@ proc msgcat::mcpreferences {} { return $Loclist } +# msgcat::mcloadedlocales -- +# +# Get or change the list of currently loaded default locales +# +# The following subcommands are available: +# loaded +# Get the current list of loaded locales +# clear +# Remove all loaded locales not present in mcpreferences. +# +# Arguments: +# subcommand One of loaded or clear +# +# Results: +# Empty string, if not stated differently for the subcommand + +proc msgcat::mcloadedlocales {subcommand} { + variable Loclist + variable LoadedLocales + variable Msgs + variable PackageConfig + switch -exact -- $subcommand { + clear { + # Remove all locales not contained in Loclist + # skip any packages with package locale + set LoadedLocales $Loclist + foreach ns [dict keys $Msgs] { + if {![dict exists $PackageConfig loclist $ns]} { + foreach locale [dict keys [dict get $Msgs $ns]] { + if {$locale ni $Loclist} { + dict unset Msgs $ns $locale + } + } + } + } + } + loaded { return $LoadedLocales } + default { + return -code error "unknown subcommand \"$subcommand\": must be\ + clear, or loaded" + } + } + return +} + +# msgcat::mcpackagelocale -- +# +# Get or change the package locale of the calling package. +# +# The following subcommands are available: +# set +# Set a package locale. +# This may load message catalog files and may clear message catalog +# items, if the former locale was the default locale. +# Returns the normalized set locale. +# The default locale is taken, if locale is not given. +# get +# Get the locale valid for this package. +# isset +# Returns true, if a package locale is set +# unset +# Unset the package locale and activate the default locale. +# This loads message catalog file which where missing in the package +# locale. +# preferences +# Return locale preference list valid for the package. +# loaded +# Return loaded locale list valid for the current package. +# clear +# If the current package has a package locale, remove all package +# locales not containes in package mcpreferences. +# It is an error to call this without a package locale set. +# +# The subcommands get, preferences and loaded return the corresponding +# default data, if no package locale is set. +# +# Arguments: +# subcommand see list above +# locale package locale (only set subcommand) +# +# Results: +# Empty string, if not stated differently for the subcommand + +proc msgcat::mcpackagelocale {subcommand {locale ""}} { + # todo: implement using an ensemble + variable Loclist + variable LoadedLocales + variable Msgs + variable PackageConfig + # Check option + # check if required item is exactly provided + if {[llength [info level 0]] == 2} { + # locale not given + unset locale + } else { + # locale given + if {$subcommand in + {"get" "isset" "unset" "preferences" "loaded" "clear"} } { + return -code error "wrong # args: should be\ + \"[lrange [info level 0] 0 1]\"" + } + set locale [string tolower $locale] + } + set ns [uplevel 1 {::namespace current}] + + switch -exact -- $subcommand { + get { return [lindex [PackagePreferences $ns] 0] } + preferences { return [PackagePreferences $ns] } + loaded { return [PackageLocales $ns] } + present { return [expr {$locale in [PackageLocales $ns]} ]} + isset { return [dict exists $PackageConfig loclist $ns] } + set { # set a package locale or add a package locale + + # Copy the default locale if no package locale set so far + if {![dict exists $PackageConfig loclist $ns]} { + dict set PackageConfig loclist $ns $Loclist + dict set PackageConfig loadedlocales $ns $LoadedLocales + } + + # Check if changed + set loclist [dict get $PackageConfig loclist $ns] + if {! [info exists locale] || $locale eq [lindex $loclist 0] } { + return [lindex $loclist 0] + } + + # Change loclist + set loclist [GetPreferences $locale] + set locale [lindex $loclist 0] + dict set PackageConfig loclist $ns $loclist + + # load eventual missing locales + set loadedLocales [dict get $PackageConfig loadedlocales $ns] + if {$locale in $loadedLocales} { return $locale } + set loadLocales [ListComplement $loadedLocales $loclist] + dict set PackageConfig loadedlocales $ns\ + [concat $loadedLocales $loadLocales] + Load $ns $loadLocales + return $locale + } + clear { # Remove all locales not contained in Loclist + if {![dict exists $PackageConfig loclist $ns]} { + return -code error "clear only when package locale set" + } + set loclist [dict get $PackageConfig loclist $ns] + dict set PackageConfig loadedlocales $ns $loclist + if {[dict exists $Msgs $ns]} { + foreach locale [dict keys [dict get $Msgs $ns]] { + if {$locale ni $loclist} { + dict unset Msgs $ns $locale + } + } + } + } + unset { # unset package locale and restore default locales + + if { ![dict exists $PackageConfig loclist $ns] } { return } + + # unset package locale + set loadLocales [ListComplement\ + [dict get $PackageConfig loadedlocales $ns] $LoadedLocales] + dict unset PackageConfig loadedlocales $ns + dict unset PackageConfig loclist $ns + + # unset keys not in global loaded locales + if {[dict exists $Msgs $ns]} { + foreach locale [dict keys [dict get $Msgs $ns]] { + if {$locale ni $LoadedLocales} { + dict unset Msgs $ns $locale + } + } + } + + # Add missing locales + Load $ns $loadLocales + } + default { + return -code error "unknown subcommand \"$subcommand\": must be\ + clear, get, isset, loaded, present, set, or unset" + } + } + return +} + +# msgcat::mcforgetpackage -- +# +# Remove any data of the calling package from msgcat +# + +proc msgcat::mcforgetpackage {} { + # todo: this may be implemented using an ensemble + variable PackageConfig + variable Msgs + set ns [uplevel 1 {::namespace current}] + # Remove MC items + dict unset Msgs $ns + # Remove config items + foreach key [dict keys $PackageConfig] { + dict unset PackageConfig $key $ns + } + return +} + +# msgcat::mcpackageconfig -- +# +# Get or modify the per caller namespace (e.g. packages) config options. +# +# Available subcommands are: +# +# get get the current value or an error if not set. +# isset return true, if the option is set +# set set the value (see also distinct option). +# Returns the number of loaded message files. +# unset Clear option. return "". +# +# Available options are: +# +# mcfolder +# The message catalog folder of the package. +# This is automatically set by mcload. +# If the value is changed using the set subcommand, an evntual +# loadcmd is invoked and all message files of the package locale are +# loaded. +# +# loadcmd +# The command gets executed before a message file would be +# sourced for this module. +# The command is invoked with the expanded locale list to load. +# The command is not invoked if the registering package namespace +# is not present. +# This callback might also be used as an alternative to message +# files. +# If the value is changed using the set subcommand, the callback is +# directly invoked with the current file locale list. No file load is +# executed. +# +# changecmd +# The command is invoked, after an executed locale change. +# Appended argument is expanded mcpreferences. +# +# unknowncmd +# Use a package locale mcunknown procedure instead the global one. +# The appended arguments are identical to mcunknown. +# A default unknown handler is used if set to the empty string. +# This consists in returning the key if no arguments are given. +# With given arguments, format is used to process the arguments. +# +# Arguments: +# subcommand Operation on the package +# option The package option to get or set. +# ?value? Eventual value for the subcommand +# +# Results: +# Depends on the subcommand and option and is described there + +proc msgcat::mcpackageconfig {subcommand option {value ""}} { + variable PackageConfig + # get namespace + set ns [uplevel 1 {::namespace current}] + + if {$option ni {"mcfolder" "loadcmd" "changecmd" "unknowncmd"}} { + return -code error "bad option \"$option\": must be mcfolder, loadcmd,\ + changecmd, or unknowncmd" + } + + # check if value argument is exactly provided + if {[llength [info level 0]] == 4 } { + # value provided + if {$subcommand in {"get" "isset" "unset"}} { + return -code error "wrong # args: should be\ + \"[lrange [info level 0] 0 2] value\"" + } + } elseif {$subcommand eq "set"} { + return -code error\ + "wrong # args: should be \"[lrange [info level 0] 0 2]\"" + } + + # Execute subcommands + switch -exact -- $subcommand { + get { # Operation get return current value + if {![dict exists $PackageConfig $option $ns]} { + return -code error "package option \"$option\" not set" + } + return [dict get $PackageConfig $option $ns] + } + isset { return [dict exists $PackageConfig $option $ns] } + unset { dict unset PackageConfig $option $ns } + set { # Set option + + if {$option eq "mcfolder"} { + set value [file normalize $value] + } + # Check if changed + if { [dict exists $PackageConfig $option $ns] + && $value eq [dict get $PackageConfig $option $ns] } { + return 0 + } + + # set new value + dict set PackageConfig $option $ns $value + + # Reload pending message catalogs + switch -exact -- $option { + mcfolder { return [Load $ns [PackageLocales $ns]] } + loadcmd { return [Load $ns [PackageLocales $ns] 1] } + } + return 0 + } + default { + return -code error "unknown subcommand \"$subcommand\":\ + must be get, isset, set, or unset" + } + } + return +} + +# msgcat::PackagePreferences -- +# +# Return eventual present package preferences or the default list if not +# present. +# +# Arguments: +# ns Package namespace +# +# Results: +# locale list + +proc msgcat::PackagePreferences {ns} { + variable PackageConfig + if {[dict exists $PackageConfig loclist $ns]} { + return [dict get $PackageConfig loclist $ns] + } + variable Loclist + return $Loclist +} + +# msgcat::PackageLocales -- +# +# Return eventual present package locales or the default list if not +# present. +# +# Arguments: +# ns Package namespace +# +# Results: +# locale list + +proc msgcat::PackageLocales {ns} { + variable PackageConfig + if {[dict exists $PackageConfig loadedlocales $ns]} { + return [dict get $PackageConfig loadedlocales $ns] + } + variable LoadedLocales + return $LoadedLocales +} + +# msgcat::ListComplement -- +# +# Build the complement of two lists. +# Return a list with all elements in list2 but not in list1. +# Optionally return the intersection. +# +# Arguments: +# list1 excluded list +# list2 included list +# inlistname If not "", write in this variable the intersection list +# +# Results: +# list with all elements in list2 but not in list1 + +proc msgcat::ListComplement {list1 list2 {inlistname ""}} { + if {"" ne $inlistname} { + upvar 1 $inlistname inlist + } + set inlist {} + set outlist {} + foreach item $list2 { + if {$item in $list1} { + lappend inlist $item + } else { + lappend outlist $item + } + } + return $outlist +} + # msgcat::mcload -- # # Attempt to load message catalogs for each locale in the @@ -280,24 +756,88 @@ proc msgcat::mcpreferences {} { # Returns the number of message catalogs that were loaded. proc msgcat::mcload {langdir} { + return [uplevel 1 [list\ + [namespace origin mcpackageconfig] set mcfolder $langdir]] +} + +# msgcat::LoadAll -- +# +# Load a list of locales for all packages not having a package locale +# list. +# +# Arguments: +# langdir The directory to search. +# +# Results: +# Returns the number of message catalogs that were loaded. + +proc msgcat::LoadAll {locales} { + variable PackageConfig + variable LoadedLocales + if {0 == [llength $locales]} { return {} } + # filter jet unloaded locales + set locales [ListComplement $LoadedLocales $locales] + if {0 == [llength $locales]} { return {} } + lappend LoadedLocales {*}$locales + + set packages [lsort -unique [concat\ + [dict keys [dict get $PackageConfig loadcmd]]\ + [dict keys [dict get $PackageConfig mcfolder]]]] + foreach ns $packages { + if {! [dict exists $PackageConfig loclist $ns] } { + Load $ns $locales + } + } + return $locales +} + +# msgcat::Load -- +# +# Invoke message load callback and load message catalog files. +# +# Arguments: +# ns Namespace (equal package) to load the message catalog. +# locales List of locales to load. +# callbackonly true if only callback should be invoked +# +# Results: +# Returns the number of message catalogs that were loaded. + +proc msgcat::Load {ns locales {callbackonly 0}} { variable FileLocale + variable PackageConfig + variable LoadedLocals + + if {0 == [llength $locales]} { return 0 } + + # Invoke callback + Invoke loadcmd $locales $ns + + if {$callbackonly || ![dict exists $PackageConfig mcfolder $ns]} { + return 0 + } + + # Invoke file load + set langdir [dict get $PackageConfig mcfolder $ns] + # Save the file locale if we are recursively called if {[info exists FileLocale]} { set nestedFileLocale $FileLocale } set x 0 - foreach p [mcpreferences] { + foreach p $locales { if {$p eq {}} { set p ROOT } set langfile [file join $langdir $p.msg] if {[file exists $langfile]} { incr x - set FileLocale [string tolower [file tail [file rootname $langfile]]] + set FileLocale [string tolower\ + [file tail [file rootname $langfile]]] if {"root" eq $FileLocale} { set FileLocale "" } - uplevel 1 [list ::source -encoding utf-8 $langfile] + namespace inscope $ns [list ::source -encoding utf-8 $langfile] unset FileLocale } } @@ -307,6 +847,63 @@ proc msgcat::mcload {langdir} { return $x } +# msgcat::Invoke -- +# +# Invoke a set of registered callbacks. +# The callback is only invoked, if its registered namespace exists. +# +# Arguments: +# index Index into PackageConfig to get callback command +# arglist parameters to the callback invocation +# ns (Optional) package to call. +# If not given or empty, check all registered packages. +# resultname Variable to save the callback result of the last called +# callback to. May be set to "" to discard the result. +# failerror (0) Fail on error if true. Otherwise call bgerror. +# +# Results: +# Possible values: +# - 0: no valid command registered +# - 1: registered command was the empty string +# - 2: registered command called, resultname is set +# - 3: registered command failed +# If multiple commands are called, the maximum of all results is returned. + +proc msgcat::Invoke {index arglist {ns ""} {resultname ""} {failerror 0}} { + variable PackageConfig + variable Config + if {"" ne $resultname} { + upvar 1 $resultname result + } + if {"" eq $ns} { + set packageList [dict keys [dict get $PackageConfig $index]] + } else { + set packageList [list $ns] + } + set ret 0 + foreach ns $packageList { + if {[dict exists $PackageConfig $index $ns] && [namespace exists $ns]} { + set cmd [dict get $PackageConfig $index $ns] + if {"" eq $cmd} { + if {$ret == 0} {set ret 1} + } else { + if {$failerror} { + set result [namespace inscope $ns $cmd {*}$arglist] + set ret 2 + } elseif {1 == [catch { + set result [namespace inscope $ns $cmd {*}$arglist] + if {$ret < 2} {set ret 2} + } err derr]} { + after idle [concat [::interp bgerror ""]\ + [list $err $derr]] + set ret 3 + } + } + } + } + return $ret +} + # msgcat::mcset -- # # Set the translation for a given string in a specified locale. @@ -330,7 +927,7 @@ proc msgcat::mcset {locale src {dest ""}} { set locale [string tolower $locale] - dict set Msgs $locale $ns $src $dest + dict set Msgs $ns $locale $src $dest return $dest } @@ -351,16 +948,10 @@ proc msgcat::mcflset {src {dest ""}} { variable Msgs if {![info exists FileLocale]} { - return -code error \ - "must only be used inside a message catalog loaded with ::msgcat::mcload" + return -code error "must only be used inside a message catalog loaded\ + with ::msgcat::mcload" } - if {[llength [info level 0]] == 2} { ;# dest not specified - set dest $src - } - - set ns [uplevel 1 [list ::namespace current]] - dict set Msgs $FileLocale $ns $src $dest - return $dest + return [uplevel 1 [list [namespace origin mcset] $FileLocale $src $dest]] } # msgcat::mcmset -- @@ -380,14 +971,14 @@ proc msgcat::mcmset {locale pairs} { set length [llength $pairs] if {$length % 2} { return -code error "bad translation list:\ - should be \"[lindex [info level 0] 0] locale {src dest ...}\"" + should be \"[lindex [info level 0] 0] locale {src dest ...}\"" } set locale [string tolower $locale] set ns [uplevel 1 [list ::namespace current]] foreach {src dest} $pairs { - dict set Msgs $locale $ns $src $dest + dict set Msgs $ns $locale $src $dest } return [expr {$length / 2}] @@ -408,26 +999,17 @@ proc msgcat::mcflmset {pairs} { variable Msgs if {![info exists FileLocale]} { - return -code error \ - "must only be used inside a message catalog loaded with ::msgcat::mcload" + return -code error "must only be used inside a message catalog loaded\ + with ::msgcat::mcload" } - set length [llength $pairs] - if {$length % 2} { - return -code error "bad translation list:\ - should be \"[lindex [info level 0] 0] locale {src dest ...}\"" - } - - set ns [uplevel 1 [list ::namespace current]] - foreach {src dest} $pairs { - dict set Msgs $FileLocale $ns $src $dest - } - return [expr {$length / 2}] + return [uplevel 1 [list [namespace origin mcmset] $FileLocale $pairs]] } # msgcat::mcunknown -- # # This routine is called by msgcat::mc if a translation cannot -# be found for a string. This routine is intended to be replaced +# be found for a string and no unknowncmd is set for the current +# package. This routine is intended to be replaced # by an application specific routine for error reporting # purposes. The default behavior is to return the source string. # If additional args are specified, the format command will be used @@ -441,7 +1023,30 @@ proc msgcat::mcflmset {pairs} { # Results: # Returns the translated value. -proc msgcat::mcunknown {locale src args} { +proc msgcat::mcunknown {args} { + return [uplevel 1 [list [namespace origin DefaultUnknown] {*}$args]] +} + +# msgcat::DefaultUnknown -- +# +# This routine is called by msgcat::mc if a translation cannot +# be found for a string in the following circumstances: +# - Default global handler, if mcunknown is not redefined. +# - Per package handler, if the package sets unknowncmd to the empty +# string. +# It returna the source string if the argument list is empty. +# If additional args are specified, the format command will be used +# to work them into the traslated string. +# +# Arguments: +# locale (unused) The current locale. +# src The string to be translated. +# args Args to pass to the format command +# +# Results: +# Returns the translated value. + +proc msgcat::DefaultUnknown {locale src args} { if {[llength $args]} { return [format $src {*}$args] } else { diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl index 5fabfe3..7399c92 100644 --- a/library/msgcat/pkgIndex.tcl +++ b/library/msgcat/pkgIndex.tcl @@ -1,2 +1,2 @@ if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded msgcat 1.5.2 [list source [file join $dir msgcat.tcl]] +package ifneeded msgcat 1.6.0 [list source [file join $dir msgcat.tcl]] diff --git a/library/opt/optparse.tcl b/library/opt/optparse.tcl index c9438a0..869a2b6 100644 --- a/library/opt/optparse.tcl +++ b/library/opt/optparse.tcl @@ -11,7 +11,7 @@ package require Tcl 8.2 # When this version number changes, update the pkgIndex.tcl file # and the install directory in the Makefiles. -package provide opt 0.4.5 +package provide opt 0.4.6 namespace eval ::tcl { @@ -33,7 +33,7 @@ namespace eval ::tcl { # Every OptProc give usage information on "procname -help". # Try "tcl::OptParseTest -help" and "tcl::OptParseTest -a" and # then other arguments. - # + # # example of 'valid' call: # ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\ # -nostatics false ch1 @@ -69,10 +69,10 @@ namespace eval ::tcl { ################### No User serviceable part below ! ############### # Array storing the parsed descriptions - variable OptDesc; - array set OptDesc {}; + variable OptDesc + array set OptDesc {} # Next potentially free key id (numeric) - variable OptDescN 0; + variable OptDescN 0 # Inside algorithm/mechanism description: # (not for the faint hearted ;-) @@ -84,8 +84,8 @@ namespace eval ::tcl { # # The general structure of a "program" is # notation (pseudo bnf like) -# name :== definition defines "name" as being "definition" -# { x y z } means list of x, y, and z +# name :== definition defines "name" as being "definition" +# { x y z } means list of x, y, and z # x* means x repeated 0 or more time # x+ means "x x*" # x? means optionally x @@ -110,7 +110,7 @@ namespace eval ::tcl { # # And for this application: # -# singleStep :== { instruction varname {hasBeenSet currentValue} type +# singleStep :== { instruction varname {hasBeenSet currentValue} type # typeArgs help } # instruction :== "flags" | "value" # type :== knowType | anyword @@ -143,54 +143,54 @@ namespace eval ::tcl { # generate a unused keyid if not given # proc ::tcl::OptKeyRegister {desc {key ""}} { - variable OptDesc; - variable OptDescN; + variable OptDesc + variable OptDescN if {[string equal $key ""]} { # in case a key given to us as a parameter was a number while {[info exists OptDesc($OptDescN)]} {incr OptDescN} - set key $OptDescN; - incr OptDescN; + set key $OptDescN + incr OptDescN } # program counter - set program [list [list "P" 1]]; + set program [list [list "P" 1]] # are we processing flags (which makes a single program step) - set inflags 0; + set inflags 0 - set state {}; + set state {} # flag used to detect that we just have a single (flags set) subprogram. - set empty 1; + set empty 1 foreach item $desc { if {$state == "args"} { # more items after 'args'... - return -code error "'args' special argument must be the last one"; + return -code error "'args' special argument must be the last one" } - set res [OptNormalizeOne $item]; - set state [lindex $res 0]; + set res [OptNormalizeOne $item] + set state [lindex $res 0] if {$inflags} { if {$state == "flags"} { # add to 'subprogram' - lappend flagsprg $res; + lappend flagsprg $res } else { # put in the flags # structure for flag programs items is a list of # {subprgcounter {prg flag 1} {prg flag 2} {...}} - lappend program $flagsprg; + lappend program $flagsprg # put the other regular stuff - lappend program $res; - set inflags 0; - set empty 0; + lappend program $res + set inflags 0 + set empty 0 } } else { if {$state == "flags"} { - set inflags 1; + set inflags 1 # sub program counter + first sub program - set flagsprg [list [list "P" 1] $res]; + set flagsprg [list [list "P" 1] $res] } else { - lappend program $res; - set empty 0; + lappend program $res + set empty 0 } } } @@ -198,32 +198,32 @@ proc ::tcl::OptKeyRegister {desc {key ""}} { if {$empty} { # We just have the subprogram, optimize and remove # unneeded level: - set program $flagsprg; + set program $flagsprg } else { - lappend program $flagsprg; + lappend program $flagsprg } } - set OptDesc($key) $program; + set OptDesc($key) $program - return $key; + return $key } # # Free the storage for that given key # proc ::tcl::OptKeyDelete {key} { - variable OptDesc; - unset OptDesc($key); + variable OptDesc + unset OptDesc($key) } # Get the parsed description stored under the given key. proc OptKeyGetDesc {descKey} { - variable OptDesc; + variable OptDesc if {![info exists OptDesc($descKey)]} { - return -code error "Unknown option description key \"$descKey\""; + return -code error "Unknown option description key \"$descKey\"" } - set OptDesc($descKey); + set OptDesc($descKey) } # Parse entry point for ppl who don't want to register with a key, @@ -232,10 +232,10 @@ proc ::tcl::OptKeyDelete {key} { # as it is way faster or simply OptProc which does it all) # Assign a temporary key, call OptKeyParse and then free the storage proc ::tcl::OptParse {desc arglist} { - set tempkey [OptKeyRegister $desc]; - set ret [catch {uplevel 1 [list ::tcl::OptKeyParse $tempkey $arglist]} res]; - OptKeyDelete $tempkey; - return -code $ret $res; + set tempkey [OptKeyRegister $desc] + set ret [catch {uplevel 1 [list ::tcl::OptKeyParse $tempkey $arglist]} res] + OptKeyDelete $tempkey + return -code $ret $res } # Helper function, replacement for proc that both @@ -246,22 +246,22 @@ proc ::tcl::OptParse {desc arglist} { # (the other will be sets to their default value) # into local variable named "Args". proc ::tcl::OptProc {name desc body} { - set namespace [uplevel 1 [list ::namespace current]]; + set namespace [uplevel 1 [list ::namespace current]] if {[string match "::*" $name] || [string equal $namespace "::"]} { # absolute name or global namespace, name is the key - set key $name; + set key $name } else { # we are relative to some non top level namespace: - set key "${namespace}::${name}"; + set key "${namespace}::${name}" } - OptKeyRegister $desc $key; - uplevel 1 [list ::proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"]; - return $key; + OptKeyRegister $desc $key + uplevel 1 [list ::proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"] + return $key } # Check that a argument has been given # assumes that "OptProc" has been used as it will check in "Args" list proc ::tcl::OptProcArgGiven {argname} { - upvar Args alist; + upvar Args alist expr {[lsearch $alist $argname] >=0} } @@ -270,7 +270,7 @@ proc ::tcl::OptProcArgGiven {argname} { # Return the instruction word/list of a given step/(sub)program proc OptInstr {lst} { - lindex $lst 0; + lindex $lst 0 } # Is a (sub) program or a plain instruction ? proc OptIsPrg {lst} { @@ -286,56 +286,56 @@ proc ::tcl::OptProcArgGiven {argname} { } # Current program counter (2nd word of first word) proc OptSetPrgCounter {lstName newValue} { - upvar $lstName lst; - set lst [lreplace $lst 0 0 [concat "P" $newValue]]; + upvar $lstName lst + set lst [lreplace $lst 0 0 [concat "P" $newValue]] } # returns a list of currently selected items. proc OptSelection {lst} { - set res {}; + set res {} foreach idx [lrange [lindex $lst 0] 1 end] { - lappend res [Lget $lst $idx]; + lappend res [Lget $lst $idx] } - return $res; + return $res } # Advance to next description proc OptNextDesc {descName} { - uplevel 1 [list Lvarincr $descName {0 1}]; + uplevel 1 [list Lvarincr $descName {0 1}] } # Get the current description, eventually descend proc OptCurDesc {descriptions} { - lindex $descriptions [OptGetPrgCounter $descriptions]; + lindex $descriptions [OptGetPrgCounter $descriptions] } # get the current description, eventually descend # through sub programs as needed. proc OptCurDescFinal {descriptions} { - set item [OptCurDesc $descriptions]; + set item [OptCurDesc $descriptions] # Descend untill we get the actual item and not a sub program while {[OptIsPrg $item]} { - set item [OptCurDesc $item]; + set item [OptCurDesc $item] } - return $item; + return $item } # Current final instruction adress proc OptCurAddr {descriptions {start {}}} { - set adress [OptGetPrgCounter $descriptions]; - lappend start $adress; - set item [lindex $descriptions $adress]; + set adress [OptGetPrgCounter $descriptions] + lappend start $adress + set item [lindex $descriptions $adress] if {[OptIsPrg $item]} { - return [OptCurAddr $item $start]; + return [OptCurAddr $item $start] } else { - return $start; + return $start } } # Set the value field of the current instruction proc OptCurSetValue {descriptionsName value} { upvar $descriptionsName descriptions # get the current item full adress - set adress [OptCurAddr $descriptions]; + set adress [OptCurAddr $descriptions] # use the 3th field of the item (see OptValue / OptNewInst) lappend adress 2 - Lvarset descriptions $adress [list 1 $value]; + Lvarset descriptions $adress [list 1 $value] # ^hasBeenSet flag } @@ -343,10 +343,10 @@ proc ::tcl::OptProcArgGiven {argname} { proc OptState {item} { lindex $item 0 } - + # current state proc OptCurState {descriptions} { - OptState [OptCurDesc $descriptions]; + OptState [OptCurDesc $descriptions] } ####### @@ -354,11 +354,11 @@ proc ::tcl::OptProcArgGiven {argname} { # Returns the argument that has to be processed now proc OptCurrentArg {lst} { - lindex $lst 0; + lindex $lst 0 } # Advance to next argument proc OptNextArg {argsName} { - uplevel 1 [list Lvarpop1 $argsName]; + uplevel 1 [list Lvarpop1 $argsName] } ####### @@ -370,49 +370,49 @@ proc ::tcl::OptProcArgGiven {argname} { # eventually eat all the arguments. proc OptDoAll {descriptionsName argumentsName} { upvar $descriptionsName descriptions - upvar $argumentsName arguments; -# puts "entered DoAll"; + upvar $argumentsName arguments +# puts "entered DoAll" # Nb: the places where "state" can be set are tricky to figure # because DoOne sets the state to flagsValue and return -continue # when needed... - set state [OptCurState $descriptions]; + set state [OptCurState $descriptions] # We'll exit the loop in "OptDoOne" or when state is empty. while 1 { - set curitem [OptCurDesc $descriptions]; + set curitem [OptCurDesc $descriptions] # Do subprograms if needed, call ourselves on the sub branch while {[OptIsPrg $curitem]} { OptDoAll curitem arguments -# puts "done DoAll sub"; - # Insert back the results in current tree; +# puts "done DoAll sub" + # Insert back the results in current tree Lvarset1nc descriptions [OptGetPrgCounter $descriptions]\ - $curitem; - OptNextDesc descriptions; - set curitem [OptCurDesc $descriptions]; - set state [OptCurState $descriptions]; + $curitem + OptNextDesc descriptions + set curitem [OptCurDesc $descriptions] + set state [OptCurState $descriptions] } -# puts "state = \"$state\" - arguments=($arguments)"; +# puts "state = \"$state\" - arguments=($arguments)" if {[Lempty $state]} { # Nothing left to do, we are done in this branch: - break; + break } # The following statement can make us terminate/continue # as it use return -code {break, continue, return and error} # codes - OptDoOne descriptions state arguments; + OptDoOne descriptions state arguments # If we are here, no special return code where issued, # we'll step to next instruction : -# puts "new state = \"$state\""; - OptNextDesc descriptions; - set state [OptCurState $descriptions]; +# puts "new state = \"$state\"" + OptNextDesc descriptions + set state [OptCurState $descriptions] } } # Process one step for the state machine, # eventually consuming the current argument. proc OptDoOne {descriptionsName stateName argumentsName} { - upvar $argumentsName arguments; - upvar $descriptionsName descriptions; - upvar $stateName state; + upvar $argumentsName arguments + upvar $descriptionsName descriptions + upvar $stateName state # the special state/instruction "args" eats all # the remaining args (if any) @@ -420,27 +420,27 @@ proc ::tcl::OptProcArgGiven {argname} { if {![Lempty $arguments]} { # If there is no additional arguments, leave the default value # in. - OptCurSetValue descriptions $arguments; - set arguments {}; + OptCurSetValue descriptions $arguments + set arguments {} } # puts "breaking out ('args' state: consuming every reminding args)" - return -code break; + return -code break } if {[Lempty $arguments]} { if {$state == "flags"} { # no argument and no flags : we're done -# puts "returning to previous (sub)prg (no more args)"; - return -code return; +# puts "returning to previous (sub)prg (no more args)" + return -code return } elseif {$state == "optValue"} { set state next; # not used, for debug only # go to next state - return ; + return } else { - return -code error [OptMissingValue $descriptions]; + return -code error [OptMissingValue $descriptions] } } else { - set arg [OptCurrentArg $arguments]; + set arg [OptCurrentArg $arguments] } switch $state { @@ -450,62 +450,62 @@ proc ::tcl::OptProcArgGiven {argname} { # Still a flag ? if {![OptIsFlag $arg]} { # don't consume the argument, return to previous prg - return -code return; + return -code return } # consume the flag - OptNextArg arguments; + OptNextArg arguments if {[string equal "--" $arg]} { # return from 'flags' state - return -code return; + return -code return } - set hits [OptHits descriptions $arg]; + set hits [OptHits descriptions $arg] if {$hits > 1} { return -code error [OptAmbigous $descriptions $arg] } elseif {$hits == 0} { return -code error [OptFlagUsage $descriptions $arg] } - set item [OptCurDesc $descriptions]; + set item [OptCurDesc $descriptions] if {[OptNeedValue $item]} { # we need a value, next state is - set state flagValue; + set state flagValue } else { - OptCurSetValue descriptions 1; + OptCurSetValue descriptions 1 } # continue - return -code continue; + return -code continue } flagValue - value { - set item [OptCurDesc $descriptions]; + set item [OptCurDesc $descriptions] # Test the values against their required type if {[catch {OptCheckType $arg\ [OptType $item] [OptTypeArgs $item]} val]} { return -code error [OptBadValue $item $arg $val] } # consume the value - OptNextArg arguments; + OptNextArg arguments # set the value - OptCurSetValue descriptions $val; + OptCurSetValue descriptions $val # go to next state if {$state == "flagValue"} { set state flags - return -code continue; + return -code continue } else { set state next; # not used, for debug only return ; # will go on next step } } optValue { - set item [OptCurDesc $descriptions]; + set item [OptCurDesc $descriptions] # Test the values against their required type if {![catch {OptCheckType $arg\ [OptType $item] [OptTypeArgs $item]} val]} { # right type, so : # consume the value - OptNextArg arguments; + OptNextArg arguments # set the value - OptCurSetValue descriptions $val; + OptCurSetValue descriptions $val } # go to next state set state next; # not used, for debug only @@ -516,39 +516,39 @@ proc ::tcl::OptProcArgGiven {argname} { # state as been entered ! return -code error "Bug! unknown state in DoOne \"$state\"\ (prg counter [OptGetPrgCounter $descriptions]:\ - [OptCurDesc $descriptions])"; + [OptCurDesc $descriptions])" } # Parse the options given the key to previously registered description # and arguments list proc ::tcl::OptKeyParse {descKey arglist} { - set desc [OptKeyGetDesc $descKey]; + set desc [OptKeyGetDesc $descKey] # make sure -help always give usage if {[string equal -nocase "-help" $arglist]} { - return -code error [OptError "Usage information:" $desc 1]; + return -code error [OptError "Usage information:" $desc 1] } - OptDoAll desc arglist; + OptDoAll desc arglist if {![Lempty $arglist]} { - return -code error [OptTooManyArgs $desc $arglist]; + return -code error [OptTooManyArgs $desc $arglist] } - + # Analyse the result # Walk through the tree: - OptTreeVars $desc "#[expr {[info level]-1}]" ; + OptTreeVars $desc "#[expr {[info level]-1}]" } # determine string length for nice tabulated output proc OptTreeVars {desc level {vnamesLst {}}} { foreach item $desc { - if {[OptIsCounter $item]} continue; + if {[OptIsCounter $item]} continue if {[OptIsPrg $item]} { - set vnamesLst [OptTreeVars $item $level $vnamesLst]; + set vnamesLst [OptTreeVars $item $level $vnamesLst] } else { - set vname [OptVarName $item]; + set vname [OptVarName $item] upvar $level $vname var if {[OptHasBeenSet $item]} { # puts "adding $vname" @@ -556,10 +556,10 @@ proc ::tcl::OptKeyParse {descKey arglist} { # it is more usefull, for instance you can check that # no flags at all was given with expr # {![string match "*-*" $Args]} - lappend vnamesLst [OptName $item]; - set var [OptValue $item]; + lappend vnamesLst [OptName $item] + set var [OptValue $item] } else { - set var [OptDefaultValue $item]; + set var [OptDefaultValue $item] } } } @@ -571,7 +571,7 @@ proc ::tcl::OptKeyParse {descKey arglist} { # and emit an error if arg is not of the correct type # otherwise returns the canonical value of that arg (ie 0/1 for booleans) proc ::tcl::OptCheckType {arg type {typeArgs ""}} { -# puts "checking '$arg' against '$type' ($typeArgs)"; +# puts "checking '$arg' against '$type' ($typeArgs)" # only types "any", "choice", and numbers can have leading "-" @@ -580,7 +580,7 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { if {![string is integer -strict $arg]} { error "not an integer" } - return $arg; + return $arg } float { return [expr {double($arg)}] @@ -591,7 +591,7 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { if {[llength $arg]==0 && [OptIsFlag $arg]} { error "no values with leading -" } - return $arg; + return $arg } boolean { if {![string is boolean -strict $arg]} { @@ -604,10 +604,10 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { if {[lsearch -exact $typeArgs $arg] < 0} { error "invalid choice" } - return $arg; + return $arg } any { - return $arg; + return $arg } string - default { @@ -617,7 +617,7 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { return $arg } } - return neverReached; + return neverReached } # internal utilities @@ -625,34 +625,34 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { # returns the number of flags matching the given arg # sets the (local) prg counter to the list of matches proc OptHits {descName arg} { - upvar $descName desc; + upvar $descName desc set hits 0 set hitems {} - set i 1; + set i 1 - set larg [string tolower $arg]; - set len [string length $larg]; - set last [expr {$len-1}]; + set larg [string tolower $arg] + set len [string length $larg] + set last [expr {$len-1}] foreach item [lrange $desc 1 end] { set flag [OptName $item] # lets try to match case insensitively # (string length ought to be cheap) - set lflag [string tolower $flag]; + set lflag [string tolower $flag] if {$len == [string length $lflag]} { if {[string equal $larg $lflag]} { # Exact match case - OptSetPrgCounter desc $i; - return 1; + OptSetPrgCounter desc $i + return 1 } } elseif {[string equal $larg [string range $lflag 0 $last]]} { - lappend hitems $i; - incr hits; + lappend hitems $i + incr hits } - incr i; + incr i } if {$hits} { - OptSetPrgCounter desc $hitems; + OptSetPrgCounter desc $hitems } return $hits } @@ -660,29 +660,29 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { # Extract fields from the list structure: proc OptName {item} { - lindex $item 1; + lindex $item 1 } proc OptHasBeenSet {item} { - Lget $item {2 0}; + Lget $item {2 0} } proc OptValue {item} { - Lget $item {2 1}; + Lget $item {2 1} } proc OptIsFlag {name} { - string match "-*" $name; + string match "-*" $name } proc OptIsOpt {name} { - string match {\?*} $name; + string match {\?*} $name } proc OptVarName {item} { - set name [OptName $item]; + set name [OptName $item] if {[OptIsFlag $name]} { - return [string range $name 1 end]; + return [string range $name 1 end] } elseif {[OptIsOpt $name]} { - return [string trim $name "?"]; + return [string trim $name "?"] } else { - return $name; + return $name } } proc OptType {item} { @@ -719,13 +719,13 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { proc OptOptUsage {item {what ""}} { return -code error "invalid description format$what: $item\n\ should be a list of {varname|-flagname ?-type? ?defaultvalue?\ - ?helpstring?}"; + ?helpstring?}" } # Generate a canonical form single instruction proc OptNewInst {state varname type typeArgs help} { - list $state $varname [list 0 {}] $type $typeArgs $help; + list $state $varname [list 0 {}] $type $typeArgs $help # ^ ^ # | | # hasBeenSet=+ +=currentValue @@ -733,18 +733,18 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { # Translate one item to canonical form proc OptNormalizeOne {item} { - set lg [Lassign $item varname arg1 arg2 arg3]; -# puts "called optnormalizeone '$item' v=($varname), lg=$lg"; - set isflag [OptIsFlag $varname]; - set isopt [OptIsOpt $varname]; + set lg [Lassign $item varname arg1 arg2 arg3] +# puts "called optnormalizeone '$item' v=($varname), lg=$lg" + set isflag [OptIsFlag $varname] + set isopt [OptIsOpt $varname] if {$isflag} { - set state "flags"; + set state "flags" } elseif {$isopt} { - set state "optValue"; + set state "optValue" } elseif {![string equal $varname "args"]} { - set state "value"; + set state "value" } else { - set state "args"; + set state "args" } # apply 'smart' 'fuzzy' logic to try to make @@ -754,9 +754,9 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { switch $lg { 1 { if {$isflag} { - return [OptNewInst $state $varname boolflag false ""]; + return [OptNewInst $state $varname boolflag false ""] } else { - return [OptNewInst $state $varname any "" ""]; + return [OptNewInst $state $varname any "" ""] } } 2 { @@ -776,20 +776,20 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { set help "" set def $arg1 } - return [OptNewInst $state $varname $type $def $help]; + return [OptNewInst $state $varname $type $def $help] } 3 { # varname type value # varname value comment - + if {[regexp {^-(.+)$} $arg1 x type]} { # flags/optValue as they are optional, need a "value", # on the contrary, for a variable (non optional), # default value is pointless, 'cept for choices : if {$isflag || $isopt || ($type == "choice")} { - return [OptNewInst $state $varname $type $arg2 ""]; + return [OptNewInst $state $varname $type $arg2 ""] } else { - return [OptNewInst $state $varname $type "" $arg2]; + return [OptNewInst $state $varname $type "" $arg2] } } else { return [OptNewInst $state $varname\ @@ -798,13 +798,13 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { } 4 { if {[regexp {^-(.+)$} $arg1 x type]} { - return [OptNewInst $state $varname $type $arg2 $arg3]; + return [OptNewInst $state $varname $type $arg2 $arg3] } else { - return -code error [OptOptUsage $item]; + return -code error [OptOptUsage $item] } } default { - return -code error [OptOptUsage $item]; + return -code error [OptOptUsage $item] } } } @@ -829,7 +829,7 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc] } proc OptFlagUsage {desc arg} { - OptError "bad flag \"$arg\", must be one of" $desc; + OptError "bad flag \"$arg\", must be one of" $desc } proc OptTooManyArgs {desc arguments} { OptError "too many arguments (unexpected argument(s): $arguments),\ @@ -838,45 +838,45 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} { } proc OptParamType {item} { if {[OptIsFlag $item]} { - return "flag"; + return "flag" } else { - return "parameter"; + return "parameter" } } proc OptBadValue {item arg {err {}}} { -# puts "bad val err = \"$err\""; +# puts "bad val err = \"$err\"" OptError "bad value \"$arg\" for [OptParamType $item]"\ [list $item] } proc OptMissingValue {descriptions} { -# set item [OptCurDescFinal $descriptions]; - set item [OptCurDesc $descriptions]; +# set item [OptCurDescFinal $descriptions] + set item [OptCurDesc $descriptions] OptError "no value given for [OptParamType $item] \"[OptName $item]\"\ (use -help for full usage) :"\ [list $item] } proc ::tcl::OptKeyError {prefix descKey {header 0}} { - OptError $prefix [OptKeyGetDesc $descKey] $header; + OptError $prefix [OptKeyGetDesc $descKey] $header } # determine string length for nice tabulated output proc OptLengths {desc nlName tlName dlName} { - upvar $nlName nl; - upvar $tlName tl; - upvar $dlName dl; + upvar $nlName nl + upvar $tlName tl + upvar $dlName dl foreach item $desc { - if {[OptIsCounter $item]} continue; + if {[OptIsCounter $item]} continue if {[OptIsPrg $item]} { OptLengths $item nl tl dl } else { SetMax nl [string length [OptName $item]] SetMax tl [string length [OptType $item]] - set dv [OptTypeArgs $item]; + set dv [OptTypeArgs $item] if {[OptState $item] != "header"} { - set dv "($dv)"; + set dv "($dv)" } - set l [string length $dv]; + set l [string length $dv] # limit the space allocated to potentially big "choices" if {([OptType $item] != "choice") || ($l<=12)} { SetMax dl $l @@ -890,22 +890,22 @@ proc ::tcl::OptKeyError {prefix descKey {header 0}} { } # output the tree proc OptTree {desc nl tl dl} { - set res ""; + set res "" foreach item $desc { - if {[OptIsCounter $item]} continue; + if {[OptIsCounter $item]} continue if {[OptIsPrg $item]} { - append res [OptTree $item $nl $tl $dl]; + append res [OptTree $item $nl $tl $dl] } else { - set dv [OptTypeArgs $item]; + set dv [OptTypeArgs $item] if {[OptState $item] != "header"} { - set dv "($dv)"; + set dv "($dv)" } - append res [format "\n %-*s %-*s %-*s %s" \ + append res [string trimright [format "\n %-*s %-*s %-*s %s" \ $nl [OptName $item] $tl [OptType $item] \ - $dl $dv [OptHelp $item]] + $dl $dv [OptHelp $item]]] } } - return $res; + return $res } # Give nice usage string @@ -913,13 +913,13 @@ proc ::tcl::OptError {prefix desc {header 0}} { # determine length if {$header} { # add faked instruction - set h [list [OptNewInst header Var/FlagName Type Value Help]]; - lappend h [OptNewInst header ------------ ---- ----- ----]; - lappend h [OptNewInst header {( -help} "" "" {gives this help )}] + set h [list [OptNewInst header Var/FlagName Type Value Help]] + lappend h [OptNewInst header ------------ ---- ----- ----] + lappend h [OptNewInst header {(-help} "" "" {gives this help)}] set desc [concat $h $desc] } OptLengths $desc nl tl dl - # actually output + # actually output return "$prefix[OptTree $desc $nl $tl $dl]" } @@ -943,105 +943,105 @@ proc ::tcl::Lempty {list} { # Gets the value of one leaf of a lists tree proc ::tcl::Lget {list indexLst} { if {[llength $indexLst] <= 1} { - return [lindex $list $indexLst]; + return [lindex $list $indexLst] } - Lget [lindex $list [lindex $indexLst 0]] [lrange $indexLst 1 end]; + Lget [lindex $list [lindex $indexLst 0]] [lrange $indexLst 1 end] } # Sets the value of one leaf of a lists tree # (we use the version that does not create the elements because # it would be even slower... needs to be written in C !) # (nb: there is a non trivial recursive problem with indexes 0, # which appear because there is no difference between a list -# of 1 element and 1 element alone : [list "a"] == "a" while +# of 1 element and 1 element alone : [list "a"] == "a" while # it should be {a} and [listp a] should be 0 while [listp {a b}] would be 1 # and [listp "a b"] maybe 0. listp does not exist either...) proc ::tcl::Lvarset {listName indexLst newValue} { - upvar $listName list; + upvar $listName list if {[llength $indexLst] <= 1} { - Lvarset1nc list $indexLst $newValue; + Lvarset1nc list $indexLst $newValue } else { - set idx [lindex $indexLst 0]; - set targetList [lindex $list $idx]; + set idx [lindex $indexLst 0] + set targetList [lindex $list $idx] # reduce refcount on targetList (not really usefull now, # could be with optimizing compiler) -# Lvarset1 list $idx {}; +# Lvarset1 list $idx {} # recursively replace in targetList - Lvarset targetList [lrange $indexLst 1 end] $newValue; + Lvarset targetList [lrange $indexLst 1 end] $newValue # put updated sub list back in the tree - Lvarset1nc list $idx $targetList; + Lvarset1nc list $idx $targetList } } # Set one cell to a value, eventually create all the needed elements # (on level-1 of lists) variable emptyList {} proc ::tcl::Lvarset1 {listName index newValue} { - upvar $listName list; + upvar $listName list if {$index < 0} {return -code error "invalid negative index"} - set lg [llength $list]; + set lg [llength $list] if {$index >= $lg} { - variable emptyList; + variable emptyList for {set i $lg} {$i<$index} {incr i} { - lappend list $emptyList; + lappend list $emptyList } - lappend list $newValue; + lappend list $newValue } else { - set list [lreplace $list $index $index $newValue]; + set list [lreplace $list $index $index $newValue] } } # same as Lvarset1 but no bound checking / creation proc ::tcl::Lvarset1nc {listName index newValue} { - upvar $listName list; - set list [lreplace $list $index $index $newValue]; + upvar $listName list + set list [lreplace $list $index $index $newValue] } # Increments the value of one leaf of a lists tree # (which must exists) proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} { - upvar $listName list; + upvar $listName list if {[llength $indexLst] <= 1} { - Lvarincr1 list $indexLst $howMuch; + Lvarincr1 list $indexLst $howMuch } else { - set idx [lindex $indexLst 0]; - set targetList [lindex $list $idx]; + set idx [lindex $indexLst 0] + set targetList [lindex $list $idx] # reduce refcount on targetList - Lvarset1nc list $idx {}; + Lvarset1nc list $idx {} # recursively replace in targetList - Lvarincr targetList [lrange $indexLst 1 end] $howMuch; + Lvarincr targetList [lrange $indexLst 1 end] $howMuch # put updated sub list back in the tree - Lvarset1nc list $idx $targetList; + Lvarset1nc list $idx $targetList } } # Increments the value of one cell of a list proc ::tcl::Lvarincr1 {listName index {howMuch 1}} { - upvar $listName list; - set newValue [expr {[lindex $list $index]+$howMuch}]; - set list [lreplace $list $index $index $newValue]; - return $newValue; + upvar $listName list + set newValue [expr {[lindex $list $index]+$howMuch}] + set list [lreplace $list $index $index $newValue] + return $newValue } # Removes the first element of a list # and returns the new list value proc ::tcl::Lvarpop1 {listName} { - upvar $listName list; - set list [lrange $list 1 end]; + upvar $listName list + set list [lrange $list 1 end] } # Same but returns the removed element # (Like the tclX version) proc ::tcl::Lvarpop {listName} { - upvar $listName list; - set el [lindex $list 0]; - set list [lrange $list 1 end]; - return $el; + upvar $listName list + set el [lindex $list 0] + set list [lrange $list 1 end] + return $el } # Assign list elements to variables and return the length of the list proc ::tcl::Lassign {list args} { # faster than direct blown foreach (which does not byte compile) - set i 0; - set lg [llength $list]; + set i 0 + set lg [llength $list] foreach vname $args { if {$i>=$lg} break - uplevel 1 [list ::set $vname [lindex $list $i]]; - incr i; + uplevel 1 [list ::set $vname [lindex $list $i]] + incr i } - return $lg; + return $lg } # Misc utilities diff --git a/library/opt/pkgIndex.tcl b/library/opt/pkgIndex.tcl index c5d3635..107d4c6 100644 --- a/library/opt/pkgIndex.tcl +++ b/library/opt/pkgIndex.tcl @@ -9,4 +9,4 @@ # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.2]} {return} -package ifneeded opt 0.4.5 [list source [file join $dir optparse.tcl]] +package ifneeded opt 0.4.6 [list source [file join $dir optparse.tcl]] diff --git a/library/package.tcl b/library/package.tcl index 3783722..44e3b28 100644 --- a/library/package.tcl +++ b/library/package.tcl @@ -14,9 +14,9 @@ namespace eval tcl::Pkg {} # ::tcl::Pkg::CompareExtension -- # -# Used internally by pkg_mkIndex to compare the extension of a file to -# a given extension. On Windows, it uses a case-insensitive comparison -# because the file system can be file insensitive. +# Used internally by pkg_mkIndex to compare the extension of a file to a given +# extension. On Windows, it uses a case-insensitive comparison because the +# file system can be file insensitive. # # Arguments: # fileName name of a file whose extension is compared @@ -27,7 +27,7 @@ namespace eval tcl::Pkg {} # Results: # Returns 1 if the extension matches, 0 otherwise -proc tcl::Pkg::CompareExtension { fileName {ext {}} } { +proc tcl::Pkg::CompareExtension {fileName {ext {}}} { global tcl_platform if {$ext eq ""} {set ext [info sharedlibextension]} if {$tcl_platform(platform) eq "windows"} { @@ -48,7 +48,7 @@ proc tcl::Pkg::CompareExtension { fileName {ext {}} } { # tcl::Pkg::CompareExtension foo.so.bar .so # which should not match. - if { ![string is integer -strict [string range $currExt 1 end]] } { + if {![string is integer -strict [string range $currExt 1 end]]} { return 0 } set root [file rootname $root] @@ -57,11 +57,10 @@ proc tcl::Pkg::CompareExtension { fileName {ext {}} } { } # pkg_mkIndex -- -# This procedure creates a package index in a given directory. The -# package index consists of a "pkgIndex.tcl" file whose contents are -# a Tcl script that sets up package information with "package require" -# commands. The commands describe all of the packages defined by the -# files given as arguments. +# This procedure creates a package index in a given directory. The package +# index consists of a "pkgIndex.tcl" file whose contents are a Tcl script that +# sets up package information with "package require" commands. The commands +# describe all of the packages defined by the files given as arguments. # # Arguments: # -direct (optional) If this flag is present, the generated @@ -82,7 +81,7 @@ proc tcl::Pkg::CompareExtension { fileName {ext {}} } { # dir. proc pkg_mkIndex {args} { - set usage {"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"}; + set usage {"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"} set argCount [llength $args] if {$argCount < 1} { @@ -128,20 +127,21 @@ proc pkg_mkIndex {args} { set dir [lindex $args $idx] set patternList [lrange $args [expr {$idx + 1}] end] - if {[llength $patternList] == 0} { + if {![llength $patternList]} { set patternList [list "*.tcl" "*[info sharedlibextension]"] } - if {[catch { - glob -directory $dir -tails -types {r f} -- {*}$patternList - } fileList o]} { - return -options $o $fileList + try { + set fileList [glob -directory $dir -tails -types {r f} -- \ + {*}$patternList] + } on error {msg opt} { + return -options $opt $msg } foreach file $fileList { # For each file, figure out what commands and packages it provides. # To do this, create a child interpreter, load the file into the - # interpreter, and get a list of the new commands and packages - # that are defined. + # interpreter, and get a list of the new commands and packages that + # are defined. if {$file eq "pkgIndex.tcl"} { continue @@ -163,20 +163,23 @@ proc pkg_mkIndex {args} { } } foreach pkg [info loaded] { - if {! [string match -nocase $loadPat [lindex $pkg 1]]} { + if {![string match -nocase $loadPat [lindex $pkg 1]]} { continue } if {$doVerbose} { tclLog "package [lindex $pkg 1] matches '$loadPat'" } - if {[catch { + try { load [lindex $pkg 0] [lindex $pkg 1] $c - } err]} { + } on error err { if {$doVerbose} { - tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err" + tclLog "warning: load [lindex $pkg 0]\ + [lindex $pkg 1]\nfailed with: $err" + } + } on ok {} { + if {$doVerbose} { + tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]" } - } elseif {$doVerbose} { - tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]" } if {[lindex $pkg 1] eq "Tk"} { # Withdraw . if Tk was loaded, to avoid showing a window. @@ -185,21 +188,25 @@ proc pkg_mkIndex {args} { } $c eval { - # Stub out the package command so packages can - # require other packages. + # Stub out the package command so packages can require other + # packages. rename package __package_orig proc package {what args} { switch -- $what { - require { return ; # ignore transitive requires } - default { __package_orig $what {*}$args } + require { + return; # Ignore transitive requires + } + default { + __package_orig $what {*}$args + } } } proc tclPkgUnknown args {} package unknown tclPkgUnknown - # Stub out the unknown command so package can call - # into each other during their initialilzation. + # Stub out the unknown command so package can call into each other + # during their initialilzation. proc unknown {args} {} @@ -207,9 +214,9 @@ proc pkg_mkIndex {args} { proc auto_import {args} {} - # reserve the ::tcl namespace for support procs - # and temporary variables. This might make it awkward - # to generate a pkgIndex.tcl file for the ::tcl namespace. + # reserve the ::tcl namespace for support procs and temporary + # variables. This might make it awkward to generate a + # pkgIndex.tcl file for the ::tcl namespace. namespace eval ::tcl { variable dir ;# Current directory being processed @@ -230,22 +237,22 @@ proc pkg_mkIndex {args} { $c eval [list set ::tcl::file $file] $c eval [list set ::tcl::direct $direct] - # Download needed procedures into the slave because we've - # just deleted the unknown procedure. This doesn't handle - # procedures with default arguments. + # Download needed procedures into the slave because we've just deleted + # the unknown procedure. This doesn't handle procedures with default + # arguments. foreach p {::tcl::Pkg::CompareExtension} { $c eval [list namespace eval [namespace qualifiers $p] {}] $c eval [list proc $p [info args $p] [info body $p]] } - if {[catch { + try { $c eval { set ::tcl::debug "loading or sourcing" - # we need to track command defined by each package even in - # the -direct case, because they are needed internally by - # the "partial pkgIndex.tcl" step above. + # we need to track command defined by each package even in the + # -direct case, because they are needed internally by the + # "partial pkgIndex.tcl" step above. proc ::tcl::GetAllNamespaces {{root ::}} { set list $root @@ -267,18 +274,17 @@ proc pkg_mkIndex {args} { } set ::tcl::origCmds [info commands] - # Try to load the file if it has the shared library - # extension, otherwise source it. It's important not to - # try to load files that aren't shared libraries, because - # on some systems (like SunOS) the loader will abort the - # whole application when it gets an error. + # Try to load the file if it has the shared library extension, + # otherwise source it. It's important not to try to load + # files that aren't shared libraries, because on some systems + # (like SunOS) the loader will abort the whole application + # when it gets an error. if {[::tcl::Pkg::CompareExtension $::tcl::file [info sharedlibextension]]} { - # The "file join ." command below is necessary. - # Without it, if the file name has no \'s and we're - # on UNIX, the load command will invoke the - # LD_LIBRARY_PATH search mechanism, which could cause - # the wrong file to be used. + # The "file join ." command below is necessary. Without + # it, if the file name has no \'s and we're on UNIX, the + # load command will invoke the LD_LIBRARY_PATH search + # mechanism, which could cause the wrong file to be used. set ::tcl::debug loading load [file join $::tcl::dir $::tcl::file] @@ -289,17 +295,16 @@ proc pkg_mkIndex {args} { set ::tcl::type source } - # As a performance optimization, if we are creating - # direct load packages, don't bother figuring out the - # set of commands created by the new packages. We - # only need that list for setting up the autoloading - # used in the non-direct case. - if { !$::tcl::direct } { + # As a performance optimization, if we are creating direct + # load packages, don't bother figuring out the set of commands + # created by the new packages. We only need that list for + # setting up the autoloading used in the non-direct case. + if {!$::tcl::direct} { # See what new namespaces appeared, and import commands # from them. Only exported commands go into the index. foreach ::tcl::x [::tcl::GetAllNamespaces] { - if {! [info exists ::tcl::namespaces($::tcl::x)]} { + if {![info exists ::tcl::namespaces($::tcl::x)]} { namespace import -force ${::tcl::x}::* } @@ -316,8 +321,9 @@ proc pkg_mkIndex {args} { set ::tcl::abs [namespace origin $::tcl::x] - # special case so that global names have no leading - # ::, this is required by the unknown command + # special case so that global names have no + # leading ::, this is required by the unknown + # command set ::tcl::abs \ [lindex [auto_qualify $::tcl::abs ::] 0] @@ -332,8 +338,8 @@ proc pkg_mkIndex {args} { } } - # Look through the packages that appeared, and if there is - # a version provided, then record it + # Look through the packages that appeared, and if there is a + # version provided, then record it foreach ::tcl::x [package names] { if {[package provide $::tcl::x] ne "" @@ -343,12 +349,12 @@ proc pkg_mkIndex {args} { } } } - } msg] == 1} { + } on error msg { set what [$c eval set ::tcl::debug] if {$doVerbose} { tclLog "warning: error while $what $file: $msg" } - } else { + } on ok {} { set what [$c eval set ::tcl::debug] if {$doVerbose} { tclLog "successful $what of $file" @@ -357,7 +363,7 @@ proc pkg_mkIndex {args} { set cmds [lsort [$c eval array names ::tcl::newCmds]] set pkgs [$c eval set ::tcl::newPkgs] if {$doVerbose} { - if { !$direct } { + if {!$direct} { tclLog "commands provided were $cmds" } tclLog "packages provided were $pkgs" @@ -393,7 +399,7 @@ proc pkg_mkIndex {args} { lappend cmd ::tcl::Pkg::Create -name $name -version $version foreach spec [lsort -index 0 $files($pkg)] { foreach {file type procs} $spec { - if { $direct } { + if {$direct} { set procs {} } lappend cmd "-$type" [list $file $procs] @@ -408,11 +414,10 @@ proc pkg_mkIndex {args} { } # tclPkgSetup -- -# This is a utility procedure use by pkgIndex.tcl files. It is invoked -# as part of a "package ifneeded" script. It calls "package provide" -# to indicate that a package is available, then sets entries in the -# auto_index array so that the package's files will be auto-loaded when -# the commands are used. +# This is a utility procedure use by pkgIndex.tcl files. It is invoked as +# part of a "package ifneeded" script. It calls "package provide" to indicate +# that a package is available, then sets entries in the auto_index array so +# that the package's files will be auto-loaded when the commands are used. # # Arguments: # dir - Directory containing all the files for this package. @@ -443,12 +448,12 @@ proc tclPkgSetup {dir pkg version files} { } # tclPkgUnknown -- -# This procedure provides the default for the "package unknown" function. -# It is invoked when a package that's needed can't be found. It scans -# the auto_path directories and their immediate children looking for -# pkgIndex.tcl files and sources any such files that are found to setup -# the package database. As it searches, it will recognize changes -# to the auto_path and scan any new directories. +# This procedure provides the default for the "package unknown" function. It +# is invoked when a package that's needed can't be found. It scans the +# auto_path directories and their immediate children looking for pkgIndex.tcl +# files and sources any such files that are found to setup the package +# database. As it searches, it will recognize changes to the auto_path and +# scan any new directories. # # Arguments: # name - Name of desired package. Not used. @@ -461,8 +466,8 @@ proc tclPkgUnknown {name args} { if {![info exists auto_path]} { return } - # Cache the auto_path, because it may change while we run through - # the first set of pkgIndex.tcl files + # Cache the auto_path, because it may change while we run through the + # first set of pkgIndex.tcl files set old_path [set use_path $auto_path] while {[llength $use_path]} { set dir [lindex $use_path end] @@ -474,24 +479,22 @@ proc tclPkgUnknown {name args} { } set tclSeenPath($dir) 1 - # we can't use glob in safe interps, so enclose the following - # in a catch statement, where we get the pkgIndex files out - # of the subdirectories + # we can't use glob in safe interps, so enclose the following in a + # catch statement, where we get the pkgIndex files out of the + # subdirectories catch { foreach file [glob -directory $dir -join -nocomplain \ * pkgIndex.tcl] { set dir [file dirname $file] if {![info exists procdDirs($dir)]} { - set code [catch {source $file} msg opt] - if {$code == 1 && - [lindex [dict get $opt -errorcode] 0] eq "POSIX" && - [lindex [dict get $opt -errorcode] 1] eq "EACCES"} { + try { + source $file + } trap {POSIX EACCES} {} { # $file was not readable; silently ignore continue - } - if {$code} { + } on error msg { tclLog "error reading package index file $file: $msg" - } else { + } on ok {} { set procdDirs($dir) 1 } } @@ -502,16 +505,14 @@ proc tclPkgUnknown {name args} { set file [file join $dir pkgIndex.tcl] # safe interps usually don't have "file exists", if {([interp issafe] || [file exists $file])} { - set code [catch {source $file} msg opt] - if {$code == 1 && - [lindex [dict get $opt -errorcode] 0] eq "POSIX" && - [lindex [dict get $opt -errorcode] 1] eq "EACCES"} { + try { + source $file + } trap {POSIX EACCES} {} { # $file was not readable; silently ignore continue - } - if {$code} { + } on error msg { tclLog "error reading package index file $file: $msg" - } else { + } on ok {} { set procdDirs($dir) 1 } } @@ -519,12 +520,11 @@ proc tclPkgUnknown {name args} { set use_path [lrange $use_path 0 end-1] - # Check whether any of the index scripts we [source]d above - # set a new value for $::auto_path. If so, then find any - # new directories on the $::auto_path, and lappend them to - # the $use_path we are working from. This gives index scripts - # the (arguably unwise) power to expand the index script search - # path while the search is in progress. + # Check whether any of the index scripts we [source]d above set a new + # value for $::auto_path. If so, then find any new directories on the + # $::auto_path, and lappend them to the $use_path we are working from. + # This gives index scripts the (arguably unwise) power to expand the + # index script search path while the search is in progress. set index 0 if {[llength $old_path] == [llength $auto_path]} { foreach dir $auto_path old $old_path { @@ -536,11 +536,11 @@ proc tclPkgUnknown {name args} { } } - # $index now points to the first element of $auto_path that - # has changed, or the beginning if $auto_path has changed length - # Scan the new elements of $auto_path for directories to add to - # $use_path. Don't add directories we've already seen, or ones - # already on the $use_path. + # $index now points to the first element of $auto_path that has + # changed, or the beginning if $auto_path has changed length Scan the + # new elements of $auto_path for directories to add to $use_path. + # Don't add directories we've already seen, or ones already on the + # $use_path. foreach dir [lrange $auto_path $index end] { if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} { lappend use_path $dir @@ -551,9 +551,9 @@ proc tclPkgUnknown {name args} { } # tcl::MacOSXPkgUnknown -- -# This procedure extends the "package unknown" function for MacOSX. -# It scans the Resources/Scripts directories of the immediate children -# of the auto_path directories for pkgIndex files. +# This procedure extends the "package unknown" function for MacOSX. It scans +# the Resources/Scripts directories of the immediate children of the auto_path +# directories for pkgIndex files. # # Arguments: # original - original [package unknown] procedure @@ -562,7 +562,6 @@ proc tclPkgUnknown {name args} { # exact - Either "-exact" or omitted. Not used. proc tcl::MacOSXPkgUnknown {original name args} { - # First do the cross-platform default search uplevel 1 $original [linsert $args 0 $name] @@ -572,8 +571,8 @@ proc tcl::MacOSXPkgUnknown {original name args} { if {![info exists auto_path]} { return } - # Cache the auto_path, because it may change while we run through - # the first set of pkgIndex.tcl files + # Cache the auto_path, because it may change while we run through the + # first set of pkgIndex.tcl files set old_path [set use_path $auto_path] while {[llength $use_path]} { set dir [lindex $use_path end] @@ -590,28 +589,25 @@ proc tcl::MacOSXPkgUnknown {original name args} { * Resources Scripts pkgIndex.tcl] { set dir [file dirname $file] if {![info exists procdDirs($dir)]} { - set code [catch {source $file} msg opt] - if {$code == 1 && - [lindex [dict get $opt -errorcode] 0] eq "POSIX" && - [lindex [dict get $opt -errorcode] 1] eq "EACCES"} { + try { + source $file + } trap {POSIX EACCES} {} { # $file was not readable; silently ignore continue - } - if {$code} { + } on error msg { tclLog "error reading package index file $file: $msg" - } else { + } on ok {} { set procdDirs($dir) 1 } } } set use_path [lrange $use_path 0 end-1] - # Check whether any of the index scripts we [source]d above - # set a new value for $::auto_path. If so, then find any - # new directories on the $::auto_path, and lappend them to - # the $use_path we are working from. This gives index scripts - # the (arguably unwise) power to expand the index script search - # path while the search is in progress. + # Check whether any of the index scripts we [source]d above set a new + # value for $::auto_path. If so, then find any new directories on the + # $::auto_path, and lappend them to the $use_path we are working from. + # This gives index scripts the (arguably unwise) power to expand the + # index script search path while the search is in progress. set index 0 if {[llength $old_path] == [llength $auto_path]} { foreach dir $auto_path old $old_path { @@ -623,11 +619,11 @@ proc tcl::MacOSXPkgUnknown {original name args} { } } - # $index now points to the first element of $auto_path that - # has changed, or the beginning if $auto_path has changed length - # Scan the new elements of $auto_path for directories to add to - # $use_path. Don't add directories we've already seen, or ones - # already on the $use_path. + # $index now points to the first element of $auto_path that has + # changed, or the beginning if $auto_path has changed length Scan the + # new elements of $auto_path for directories to add to $use_path. + # Don't add directories we've already seen, or ones already on the + # $use_path. foreach dir [lrange $auto_path $index end] { if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} { lappend use_path $dir @@ -653,12 +649,12 @@ proc tcl::MacOSXPkgUnknown {original name args} { # # Any number of -load and -source parameters may be # specified, so long as there is at least one -load or -# -source parameter. If the procs component of a -# module specifier is left off, that module will be -# set up for direct loading; otherwise, it will be -# set up for lazy loading. If both -source and -load -# are specified, the -load'ed files will be loaded -# first, followed by the -source'd files. +# -source parameter. If the procs component of a module +# specifier is left off, that module will be set up for +# direct loading; otherwise, it will be set up for lazy +# loading. If both -source and -load are specified, the +# -load'ed files will be loaded first, followed by the +# -source'd files. # # Results: # An appropriate "package ifneeded" statement for the package. @@ -676,7 +672,7 @@ proc ::tcl::Pkg::Create {args} { # process arguments set len [llength $args] - if { $len < 6 } { + if {$len < 6} { error $err(wrongNumArgs) } @@ -690,14 +686,14 @@ proc ::tcl::Pkg::Create {args} { switch -glob -- $flag { "-name" - "-version" { - if { $i >= $len } { + if {$i >= $len} { error [format $err(valueMissing) $flag] } set opts($flag) [lindex $args $i] } "-source" - "-load" { - if { $i >= $len } { + if {$i >= $len} { error [format $err(valueMissing) $flag] } lappend opts($flag) [lindex $args $i] @@ -709,14 +705,14 @@ proc ::tcl::Pkg::Create {args} { } # Validate the parameters - if { [llength $opts(-name)] == 0 } { + if {![llength $opts(-name)]} { error [format $err(valueMissing) "-name"] } - if { [llength $opts(-version)] == 0 } { + if {![llength $opts(-version)]} { error [format $err(valueMissing) "-version"] } - if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } { + if {!([llength $opts(-source)] || [llength $opts(-load)])} { error $err(noLoadOrSource) } @@ -740,7 +736,7 @@ proc ::tcl::Pkg::Create {args} { } } - if { [llength $lazyFileList] > 0 } { + if {[llength $lazyFileList]} { lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\ $opts(-version) [list $lazyFileList]\]" } diff --git a/library/reg/pkgIndex.tcl b/library/reg/pkgIndex.tcl index 1241f2a..b1fe234 100755 --- a/library/reg/pkgIndex.tcl +++ b/library/reg/pkgIndex.tcl @@ -1,9 +1,9 @@ -if {![package vsatisfies [package provide Tcl] 8]} return -if {[info sharedlibextension] != ".dll"} return -if {[info exists ::tcl_platform(debug)]} { - package ifneeded registry 1.2.2 \ - [list load [file join $dir tclreg12g.dll] registry] +if {([info commands ::tcl::pkgconfig] eq "") + || ([info sharedlibextension] ne ".dll")} return +if {[::tcl::pkgconfig get debug]} { + package ifneeded registry 1.3.2 \ + [list load [file join $dir tclreg13g.dll] registry] } else { - package ifneeded registry 1.2.2 \ - [list load [file join $dir tclreg12.dll] registry] + package ifneeded registry 1.3.2 \ + [list load [file join $dir tclreg13.dll] registry] } diff --git a/library/safe.tcl b/library/safe.tcl index 2dd4aed..ea6391d 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -151,10 +151,18 @@ proc ::safe::interpConfigure {args} { set item [::tcl::OptCurDesc $desc] set name [::tcl::OptName $item] switch -exact -- $name { - -accessPath {return [list -accessPath $state(access_path)]} - -statics {return [list -statics $state(staticsok)]} - -nested {return [list -nested $state(nestedok)]} - -deleteHook {return [list -deleteHook $state(cleanupHook)]} + -accessPath { + return [list -accessPath $state(access_path)] + } + -statics { + return [list -statics $state(staticsok)] + } + -nested { + return [list -nested $state(nestedok)] + } + -deleteHook { + return [list -deleteHook $state(cleanupHook)] + } -noStatics { # it is most probably a set in fact but we would need # then to jump to the set part and it is not *sure* @@ -192,7 +200,7 @@ proc ::safe::interpConfigure {args} { if { ![::tcl::OptProcArgGiven -statics] && ![::tcl::OptProcArgGiven -noStatics] - } { + } then { set statics $state(staticsok) } else { set statics [InterpStatics] @@ -200,7 +208,7 @@ proc ::safe::interpConfigure {args} { if { [::tcl::OptProcArgGiven -nested] || [::tcl::OptProcArgGiven -nestedLoadOk] - } { + } then { set nested [InterpNested] } else { set nested $state(nestedok) @@ -457,8 +465,19 @@ proc ::safe::InterpInit { # This alias lets the slave have access to a subset of the 'file' # command functionality. - AliasSubset $slave file \ - file dir.* join root.* ext.* tail path.* split + ::interp expose $slave file + foreach subcommand {dirname extension rootname tail} { + ::interp alias $slave ::tcl::file::$subcommand {} \ + ::safe::AliasFileSubcommand $slave $subcommand + } + foreach subcommand { + atime attributes copy delete executable exists isdirectory isfile + link lstat mtime mkdir nativename normalize owned readable readlink + rename size stat tempfile type volumes writable + } { + ::interp alias $slave ::tcl::file::$subcommand {} \ + ::safe::BadSubcommand $slave file $subcommand + } # Subcommands of info foreach {subcommand alias} { @@ -475,16 +494,16 @@ proc ::safe::InterpInit { if {[catch {::interp eval $slave { source [file join $tcl_library init.tcl] - }} msg]} { + }} msg opt]} { Log $slave "can't source init.tcl ($msg)" - return -code error "can't source init.tcl into slave $slave ($msg)" + return -options $opt "can't source init.tcl into slave $slave ($msg)" } if {[catch {::interp eval $slave { source [file join $tcl_library tm.tcl] - }} msg]} { + }} msg opt]} { Log $slave "can't source tm.tcl ($msg)" - return -code error "can't source tm.tcl into slave $slave ($msg)" + return -options $opt "can't source tm.tcl into slave $slave ($msg)" } # Sync the paths used to search for Tcl modules. This can be done only @@ -538,9 +557,9 @@ proc ::safe::interpDelete {slave} { # remove the hook now, otherwise if the hook calls us somehow, # we'll loop unset state(cleanupHook) - if {[catch { + try { {*}$hook $slave - } err]} { + } on error err { Log $slave "Delete hook error ($err)" } } @@ -657,7 +676,19 @@ proc ::safe::CheckFileName {slave file} { } } +# AliasFileSubcommand handles selected subcommands of [file] in safe +# interpreters that are *almost* safe. In particular, it just acts to +# prevent discovery of what home directories exist. + +proc ::safe::AliasFileSubcommand {slave subcommand name} { + if {[string match ~* $name]} { + set name ./$name + } + tailcall ::interp invokehidden $slave tcl:file:$subcommand $name +} + # AliasGlob is the target of the "glob" alias in safe interpreters. + proc ::safe::AliasGlob {slave args} { Log $slave "GLOB ! $args" NOTICE set cmd {} @@ -721,14 +752,12 @@ proc ::safe::AliasGlob {slave args} { # access path of that slave. Done after basic argument processing so that # we know if -nocomplain is set. if {$got(-directory)} { - if {[catch { + try { set dir [TranslatePath $slave $virtualdir] DirInAccessPath $slave $dir - } msg]} { + } on error msg { Log $slave $msg - if {$got(-nocomplain)} { - return - } + if {$got(-nocomplain)} return return -code error "permission denied" } lappend cmd -directory $dir @@ -744,26 +773,27 @@ proc ::safe::AliasGlob {slave args} { foreach opt [lrange $args $at end] { if {![regexp $dirPartRE $opt -> thedir thefile]} { set thedir . + } elseif {[string match ~* $thedir]} { + set thedir ./$thedir } - if {$thedir eq "*"} { + if {$thedir eq "*" && + ($thefile eq "pkgIndex.tcl" || $thefile eq "*.tm")} { set mapped 0 foreach d [glob -directory [TranslatePath $slave $virtualdir] \ -types d -tails *] { catch { DirInAccessPath $slave \ [TranslatePath $slave [file join $virtualdir $d]] - if {$thefile eq "pkgIndex.tcl" || $thefile eq "*.tm"} { - lappend cmd [file join $d $thefile] - set mapped 1 - } + lappend cmd [file join $d $thefile] + set mapped 1 } } if {$mapped} continue } - if {[catch { - set thedir [file join $virtualdir $thedir] - DirInAccessPath $slave [TranslatePath $slave $thedir] - } msg]} { + try { + DirInAccessPath $slave [TranslatePath $slave \ + [file join $virtualdir $thedir]] + } on error msg { Log $slave $msg if {$got(-nocomplain)} continue return -code error "permission denied" @@ -776,19 +806,19 @@ proc ::safe::AliasGlob {slave args} { if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} { return } - if {[catch { - ::interp invokehidden $slave glob {*}$cmd - } msg]} { + try { + set entries [::interp invokehidden $slave glob {*}$cmd] + } on error msg { Log $slave $msg return -code error "script error" } - Log $slave "GLOB < $msg" NOTICE + Log $slave "GLOB < $entries" NOTICE # Translate path back to what the slave should see. set res {} set l [string length $dir] - foreach p $msg { + foreach p $entries { if {[string equal -length $l $dir $p]} { set p [string replace $p 0 [expr {$l-1}] $virtualdir] } @@ -852,6 +882,7 @@ proc ::safe::AliasSource {slave args} { # because we want to control [info script] in the slave so information # doesn't leak so much. [Bug 2913625] set old [::interp eval $slave {info script}] + set replacementMsg "script error" set code [catch { set f [open $realfile] fconfigure $f -eofchar \032 @@ -861,14 +892,17 @@ proc ::safe::AliasSource {slave args} { set contents [read $f] close $f ::interp eval $slave [list info script $file] - ::interp eval $slave $contents } msg opt] + if {$code == 0} { + set code [catch {::interp eval $slave $contents} msg opt] + set replacementMsg $msg + } catch {interp eval $slave [list info script $old]} # Note that all non-errors are fine result codes from [source], so we must # take a little care to do it properly. [Bug 2923613] if {$code == 1} { Log $slave $msg - return -code error "script error" + return -code error $replacementMsg } return -code $code -options $opt $msg } @@ -918,30 +952,28 @@ proc ::safe::AliasLoad {slave file args} { # file loading # get the real path from the virtual one. - if {[catch { + try { set file [TranslatePath $slave $file] - } msg]} { + } on error msg { Log $slave $msg return -code error "permission denied" } # check the translated path - if {[catch { + try { FileInAccessPath $slave $file - } msg]} { + } on error msg { Log $slave $msg return -code error "permission denied (path)" } } - if {[catch { - ::interp invokehidden $slave load $file $package $target - } msg]} { + try { + return [::interp invokehidden $slave load $file $package $target] + } on error msg { Log $slave $msg return -code error $msg } - - return $msg } # FileInAccessPath raises an error if the file is not found in the list of @@ -986,59 +1018,33 @@ proc ::safe::DirInAccessPath {slave dir} { } } -# This procedure enables access from a safe interpreter to only a subset -# of the subcommands of a command: +# This procedure is used to report an attempt to use an unsafe member of an +# ensemble command. -proc ::safe::Subset {slave command okpat args} { - set subcommand [lindex $args 0] - if {[regexp $okpat $subcommand]} { - return [$command {*}$args] - } +proc ::safe::BadSubcommand {slave command subcommand args} { set msg "not allowed to invoke subcommand $subcommand of $command" Log $slave $msg - return -code error $msg -} - -# This procedure installs an alias in a slave that invokes "safesubset" in -# the master to execute allowed subcommands. It precomputes the pattern of -# allowed subcommands; you can use wildcards in the pattern if you wish to -# allow subcommand abbreviation. -# -# Syntax is: AliasSubset slave alias target subcommand1 subcommand2... - -proc ::safe::AliasSubset {slave alias target args} { - set pat "^([join $args |])\$" - ::interp alias $slave $alias {}\ - [namespace current]::Subset $slave $target $pat + return -code error -errorcode {TCL SAFE SUBCOMMAND} $msg } # AliasEncoding is the target of the "encoding" alias in safe interpreters. proc ::safe::AliasEncoding {slave option args} { - # Careful; do not want empty option to get through to the [string equal] - if {[regexp {^(name.*|convert.*|)$} $option]} { - return [::interp invokehidden $slave encoding $option {*}$args] - } - - if {[string equal -length [string length $option] $option "system"]} { - if {[llength $args] == 0} { - # passed all the tests , lets source it: - if {[catch { - set sysenc [::interp invokehidden $slave encoding system] - } msg]} { - Log $slave $msg - return -code error "script error" - } - return $sysenc + # Note that [encoding dirs] is not supported in safe slaves at all + set subcommands {convertfrom convertto names system} + try { + set option [tcl::prefix match -error [list -level 1 -errorcode \ + [list TCL LOOKUP INDEX option $option]] $subcommands $option] + # Special case: [encoding system] ok, but [encoding system foo] not + if {$option eq "system" && [llength $args]} { + return -code error -errorcode {TCL WRONGARGS} \ + "wrong # args: should be \"encoding system\"" } - set msg "wrong # args: should be \"encoding system\"" - set code {TCL WRONGARGS} - } else { - set msg "bad option \"$option\": must be convertfrom, convertto, names, or system" - set code [list TCL LOOKUP INDEX option $option] + } on error {msg options} { + Log $slave $msg + return -options $options $msg } - Log $slave $msg - return -code error -errorcode $code $msg + tailcall ::interp invokehidden $slave encoding $option {*}$args } # Various minor hiding of platform features. [Bug 2913625] diff --git a/library/tclIndex b/library/tclIndex index 010616f..26603c1 100644 --- a/library/tclIndex +++ b/library/tclIndex @@ -1,4 +1,5 @@ # Tcl autoload index file, version 2.0 +# -*- tcl -*- # This file is generated by the "auto_mkindex" command # and sourced to set up indexing information for one or # more commands. Typically each line is a command that @@ -48,29 +49,15 @@ set auto_index(::safe::AddSubDirs) [list source [file join $dir safe.tcl]] set auto_index(::safe::interpDelete) [list source [file join $dir safe.tcl]] set auto_index(::safe::setLogCmd) [list source [file join $dir safe.tcl]] set auto_index(::safe::SyncAccessPath) [list source [file join $dir safe.tcl]] -set auto_index(::safe::InterpStateName) [list source [file join $dir safe.tcl]] -set auto_index(::safe::IsInterp) [list source [file join $dir safe.tcl]] set auto_index(::safe::PathToken) [list source [file join $dir safe.tcl]] -set auto_index(::safe::PathListName) [list source [file join $dir safe.tcl]] -set auto_index(::safe::VirtualPathListName) [list source [file join $dir safe.tcl]] -set auto_index(::safe::PathNumberName) [list source [file join $dir safe.tcl]] -set auto_index(::safe::StaticsOkName) [list source [file join $dir safe.tcl]] -set auto_index(::safe::NestedOkName) [list source [file join $dir safe.tcl]] -set auto_index(::safe::Toplevel) [list source [file join $dir safe.tcl]] -set auto_index(::safe::Set) [list source [file join $dir safe.tcl]] -set auto_index(::safe::Lappend) [list source [file join $dir safe.tcl]] -set auto_index(::safe::Unset) [list source [file join $dir safe.tcl]] -set auto_index(::safe::Exists) [list source [file join $dir safe.tcl]] -set auto_index(::safe::GetAccessPath) [list source [file join $dir safe.tcl]] -set auto_index(::safe::StaticsOk) [list source [file join $dir safe.tcl]] -set auto_index(::safe::NestedOk) [list source [file join $dir safe.tcl]] -set auto_index(::safe::DeleteHookName) [list source [file join $dir safe.tcl]] set auto_index(::safe::TranslatePath) [list source [file join $dir safe.tcl]] set auto_index(::safe::Log) [list source [file join $dir safe.tcl]] set auto_index(::safe::CheckFileName) [list source [file join $dir safe.tcl]] +set auto_index(::safe::AliasGlob) [list source [file join $dir safe.tcl]] set auto_index(::safe::AliasSource) [list source [file join $dir safe.tcl]] set auto_index(::safe::AliasLoad) [list source [file join $dir safe.tcl]] set auto_index(::safe::FileInAccessPath) [list source [file join $dir safe.tcl]] +set auto_index(::safe::DirInAccessPath) [list source [file join $dir safe.tcl]] set auto_index(::safe::Subset) [list source [file join $dir safe.tcl]] set auto_index(::safe::AliasSubset) [list source [file join $dir safe.tcl]] set auto_index(::safe::AliasEncoding) [list source [file join $dir safe.tcl]] @@ -82,6 +69,7 @@ set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]] set auto_index(::tcl::tm::add) [list source [file join $dir tm.tcl]] set auto_index(::tcl::tm::remove) [list source [file join $dir tm.tcl]] set auto_index(::tcl::tm::list) [list source [file join $dir tm.tcl]] +set auto_index(::tcl::tm::Defaults) [list source [file join $dir tm.tcl]] set auto_index(::tcl::tm::UnknownHandler) [list source [file join $dir tm.tcl]] set auto_index(::tcl::tm::roots) [list source [file join $dir tm.tcl]] set auto_index(::tcl::tm::path) [list source [file join $dir tm.tcl]] diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index 987725f..5ac8823 100644 --- a/library/tcltest/pkgIndex.tcl +++ b/library/tcltest/pkgIndex.tcl @@ -9,4 +9,4 @@ # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5]} {return} -package ifneeded tcltest 2.3.8 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.4.0 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 8e43859..cde2660 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -22,7 +22,7 @@ namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. - variable Version 2.3.8 + variable Version 2.4.0 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] @@ -347,7 +347,7 @@ namespace eval tcltest { # This is very subtle and tricky, so let me try to explain. # (Hopefully this longer comment will be clear when I come # back in a few months, unlike its predecessor :) ) - # + # # The [outputChannel] command (and underlying variable) have to # be kept in sync with the [configure -outfile] configuration # option ( and underlying variable Option(-outfile) ). This is @@ -362,12 +362,12 @@ namespace eval tcltest { # configuration options to parse the command line option the first # time they are read. These traces are cancelled whenever the # program itself calls [configure]. - # + # # OK, then so to support tcltest 1 compatibility, it seems we want # to get the return from [outputFile] to trigger the read traces, # just in case. # - # BUT! A little known feature of Tcl variable traces is that + # BUT! A little known feature of Tcl variable traces is that # traces are disabled during the handling of other traces. So, # if we trigger read traces on Option(-outfile) and that triggers # command line parsing which turns around and sets an initial @@ -608,19 +608,30 @@ namespace eval tcltest { set code [catch {Configure {*}$args} msg] return -code $code $msg } - + proc AcceptVerbose { level } { set level [AcceptList $level] + set levelMap { + l list + p pass + b body + s skip + t start + e error + l line + m msec + u usec + } + set levelRegexp "^([join [dict values $levelMap] |])\$" if {[llength $level] == 1} { - if {![regexp {^(pass|body|skip|start|error|line)$} $level]} { + if {![regexp $levelRegexp $level]} { # translate single characters abbreviations to expanded list - set level [string map {p pass b body s skip t start e error l line} \ - [split $level {}]] + set level [string map $levelMap [split $level {}]] } } set valid [list] foreach v $level { - if {[regexp {^(pass|body|skip|start|error|line)$} $v]} { + if {[regexp $levelRegexp $v]} { lappend valid $v } } @@ -639,7 +650,7 @@ namespace eval tcltest { skipped tests if 's' is specified, the bodies of failed tests if 'b' is specified, and when tests start if 't' is specified. ErrorInfo is displayed if 'e' is specified. Source file line - information of failed tests is displayed if 'l' is specified. + information of failed tests is displayed if 'l' is specified. } AcceptVerbose verbose # Match and skip patterns default to the empty list, except for @@ -687,7 +698,7 @@ namespace eval tcltest { # some additional output regarding operations of the test harness. # The tcltest package currently implements only up to debug level 3. Option -debug 0 { - Internal debug level + Internal debug level } AcceptInteger debug proc SetSelectedConstraints args { @@ -715,7 +726,7 @@ namespace eval tcltest { } Option -limitconstraints 0 { whether to run only tests with the constraints - } AcceptBoolean limitConstraints + } AcceptBoolean limitConstraints trace add variable Option(-limitconstraints) write \ [namespace code {ClearUnselectedConstraints ;#}] @@ -728,7 +739,7 @@ namespace eval tcltest { # Default is to run each test file in a separate process Option -singleproc 0 { whether to run all tests in one process - } AcceptBoolean singleProcess + } AcceptBoolean singleProcess proc AcceptTemporaryDirectory { directory } { set directory [AcceptAbsolutePath $directory] @@ -1257,7 +1268,7 @@ proc tcltest::DefineConstraintInitializers {} { # setting files into nonblocking mode. ConstraintInitializer nonBlockFiles { - set code [expr {[catch {set f [open defs r]}] + set code [expr {[catch {set f [open defs r]}] || [catch {chan configure $f -blocking off}]}] catch {close $f} set code @@ -1271,7 +1282,7 @@ proc tcltest::DefineConstraintInitializers {} { # (Mark Diekhans). ConstraintInitializer asyncPipeClose {expr { - !([string equal unix $::tcl_platform(platform)] + !([string equal unix $::tcl_platform(platform)] && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}} # Test to see if we have a broken version of sprintf with respect @@ -1954,7 +1965,7 @@ proc tcltest::test {name description args} { return } - # Save information about the core file. + # Save information about the core file. if {[preserveCore]} { if {[file exists [file join [workingDirectory] core]]} { set coreModTime [file mtime [file join [workingDirectory] core]] @@ -1972,6 +1983,11 @@ proc tcltest::test {name description args} { # Only run the test body if the setup was successful if {!$setupFailure} { + # Register startup time + if {[IsVerbose msec] || [IsVerbose usec]} { + set timeStart [clock microseconds] + } + # Verbose notification of $body start if {[IsVerbose start]} { puts [outputChannel] "---- $name start" @@ -2060,7 +2076,7 @@ proc tcltest::test {name description args} { } else { set coreFailure 1 } - + if {([preserveCore] > 1) && ($coreFailure)} { append coreMsg "\nMoving file to:\ [file join [temporaryDirectory] core-$name]" @@ -2076,6 +2092,16 @@ proc tcltest::test {name description args} { } } + if {[IsVerbose msec] || [IsVerbose usec]} { + set t [expr {[clock microseconds] - $timeStart}] + if {[IsVerbose usec]} { + puts [outputChannel] "++++ $name took $t μs" + } + if {[IsVerbose msec]} { + puts [outputChannel] "++++ $name took [expr {round($t/1000.)}] ms" + } + } + # if we didn't experience any failures, then we passed variable numTests if {!($setupFailure || $cleanupFailure || $coreFailure @@ -2100,7 +2126,7 @@ proc tcltest::test {name description args} { variable currentFailure true if {![IsVerbose body]} { set body "" - } + } puts [outputChannel] "\n" if {[IsVerbose line]} { if {![catch {set testFrame [info frame -1]}] && @@ -2121,7 +2147,7 @@ proc tcltest::test {name description args} { puts [outputChannel] "$testFile:$testLine: error: test failed:\ $name [string trim $description]" } - } + } puts [outputChannel] "==== $name\ [string trim $description] FAILED" if {[string length $body]} { @@ -2277,7 +2303,7 @@ proc tcltest::Skipped {name constraints} { } } } - + if {!$doTest} { if {[IsVerbose skip]} { puts [outputChannel] "++++ $name SKIPPED: $constraints" @@ -2683,7 +2709,7 @@ proc tcltest::GetMatchingDirectories {rootdir} { DebugPuts 1 "No test directories remain after applying match\ and skip patterns!" } - return $matchDirs + return [lsort $matchDirs] } # tcltest::runAllTests -- @@ -2834,9 +2860,9 @@ proc tcltest::runAllTests { {shell ""} } { set dir [file tail $directory] puts [outputChannel] [string repeat ~ 44] puts [outputChannel] "$dir test began at [eval $timeCmd]\n" - + uplevel 1 [list ::source [file join $directory all.tcl]] - + set endTime [eval $timeCmd] puts [outputChannel] "\n$dir test ended at $endTime" puts [outputChannel] "" @@ -3019,7 +3045,7 @@ proc tcltest::removeFile {name {directory ""}} { DebugDo 1 { Warn "removeFile removing \"$fullName\":\n not created by makeFile" } - } + } if {![file isfile $fullName]} { DebugDo 1 { Warn "removeFile removing \"$fullName\":\n not a file" @@ -3090,7 +3116,7 @@ proc tcltest::removeDirectory {name {directory ""}} { Warn "removeDirectory removing \"$fullName\":\n not created\ by makeDirectory" } - } + } if {![file isdirectory $fullName]} { DebugDo 1 { Warn "removeDirectory removing \"$fullName\":\n not a directory" @@ -3285,7 +3311,7 @@ proc tcltest::threadReap {} { testthread errorproc ThreadError return [llength [testthread names]] } elseif {[info commands thread::id] ne {}} { - + # Thread extension thread::errorproc ThreadNullError diff --git a/library/tm.tcl b/library/tm.tcl index 87db0df..66c56a1 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -1,48 +1,44 @@ # -*- tcl -*- # -# Searching for Tcl Modules. Defines a procedure, declares it as the -# primary command for finding packages, however also uses the former -# 'package unknown' command as a fallback. +# Searching for Tcl Modules. Defines a procedure, declares it as the primary +# command for finding packages, however also uses the former 'package unknown' +# command as a fallback. # -# Locates all possible packages in a directory via a less restricted -# glob. The targeted directory is derived from the name of the -# requested package. I.e. the TM scan will look only at directories -# which can contain the requested package. It will register all -# packages it found in the directory so that future requests have a -# higher chance of being fulfilled by the ifneeded database without -# having to come to us again. +# Locates all possible packages in a directory via a less restricted glob. The +# targeted directory is derived from the name of the requested package, i.e. +# the TM scan will look only at directories which can contain the requested +# package. It will register all packages it found in the directory so that +# future requests have a higher chance of being fulfilled by the ifneeded +# database without having to come to us again. # -# We do not remember where we have been and simply rescan targeted -# directories when invoked again. The reasoning is this: +# We do not remember where we have been and simply rescan targeted directories +# when invoked again. The reasoning is this: # -# - The only way we get back to the same directory is if someone is -# trying to [package require] something that wasn't there on the -# first scan. +# - The only way we get back to the same directory is if someone is trying to +# [package require] something that wasn't there on the first scan. # # Either # 1) It is there now: If we rescan, you get it; if not you don't. # -# This covers the possibility that the application asked for a -# package late, and the package was actually added to the -# installation after the application was started. It shoukld -# still be able to find it. +# This covers the possibility that the application asked for a package +# late, and the package was actually added to the installation after the +# application was started. It shoukld still be able to find it. # -# 2) It still is not there: Either way, you don't get it, but the -# rescan takes time. This is however an error case and we dont't -# care that much about it +# 2) It still is not there: Either way, you don't get it, but the rescan +# takes time. This is however an error case and we dont't care that much +# about it # -# 3) It was there the first time; but for some reason a "package -# forget" has been run, and "package" doesn't know about it -# anymore. +# 3) It was there the first time; but for some reason a "package forget" has +# been run, and "package" doesn't know about it anymore. # -# This can be an indication that the application wishes to reload -# some functionality. And should work as well. +# This can be an indication that the application wishes to reload some +# functionality. And should work as well. # -# Note that this also strikes a balance between doing a glob targeting -# a single package, and thus most likely requiring multiple globs of -# the same directory when the application is asking for many packages, -# and trying to glob for _everything_ in all subdirectories when -# looking for a package, which comes with a heavy startup cost. +# Note that this also strikes a balance between doing a glob targeting a +# single package, and thus most likely requiring multiple globs of the same +# directory when the application is asking for many packages, and trying to +# glob for _everything_ in all subdirectories when looking for a package, +# which comes with a heavy startup cost. # # We scan for regular packages only if no satisfying module was found. @@ -71,46 +67,43 @@ namespace eval ::tcl::tm { # path with 'list'. # # Results -# No result for subcommands 'add' and 'remove'. A list of paths -# for 'list'. +# No result for subcommands 'add' and 'remove'. A list of paths for +# 'list'. # # Sideeffects -# The subcommands 'add' and 'remove' manipulate the list of -# paths to search for Tcl Modules. The subcommand 'list' has no -# sideeffects. +# The subcommands 'add' and 'remove' manipulate the list of paths to +# search for Tcl Modules. The subcommand 'list' has no sideeffects. -proc ::tcl::tm::add {path args} { +proc ::tcl::tm::add {args} { # PART OF THE ::tcl::tm::path ENSEMBLE # # The path is added at the head to the list of module paths. # - # The command enforces the restriction that no path may be an - # ancestor directory of any other path on the list. If the new - # path violates this restriction an error wil be raised. + # The command enforces the restriction that no path may be an ancestor + # directory of any other path on the list. If the new path violates this + # restriction an error wil be raised. # - # If the path is already present as is no error will be raised and - # no action will be taken. + # If the path is already present as is no error will be raised and no + # action will be taken. variable paths - # We use a copy of the path as source during validation, and - # extend it as well. Because we not only have to detect if the new - # paths are bogus with respect to the existing paths, but also - # between themselves. Otherwise we can still add bogus paths, by - # specifying them in a single call. This makes the use of the new - # paths simpler as well, a trivial assignment of the collected - # paths to the official state var. + # We use a copy of the path as source during validation, and extend it as + # well. Because we not only have to detect if the new paths are bogus with + # respect to the existing paths, but also between themselves. Otherwise we + # can still add bogus paths, by specifying them in a single call. This + # makes the use of the new paths simpler as well, a trivial assignment of + # the collected paths to the official state var. set newpaths $paths - foreach p [linsert $args 0 $path] { + foreach p $args { if {$p in $newpaths} { # Ignore a path already on the list. continue } - # Search for paths which are subdirectories of the new one. If - # there are any then the new path violates the restriction - # about ancestors. + # Search for paths which are subdirectories of the new one. If there + # are any then the new path violates the restriction about ancestors. set pos [lsearch -glob $newpaths ${p}/*] # Cannot use "in", we need the position for the message. @@ -119,10 +112,9 @@ proc ::tcl::tm::add {path args} { "$p is ancestor of existing module path [lindex $newpaths $pos]." } - # Now look for existing paths which are ancestors of the new - # one. This reverse question forces us to loop over the - # existing paths, as each element is the pattern, not the new - # path :( + # Now look for existing paths which are ancestors of the new one. This + # reverse question forces us to loop over the existing paths, as each + # element is the pattern, not the new path :( foreach ep $newpaths { if {[string match ${ep}/* $p]} { @@ -134,24 +126,23 @@ proc ::tcl::tm::add {path args} { set newpaths [linsert $newpaths 0 $p] } - # The validation of the input is complete and successful, and - # everything in newpaths is either an old path, or added. We can - # now extend the official list of paths, a simple assignment is - # sufficient. + # The validation of the input is complete and successful, and everything + # in newpaths is either an old path, or added. We can now extend the + # official list of paths, a simple assignment is sufficient. set paths $newpaths return } -proc ::tcl::tm::remove {path args} { +proc ::tcl::tm::remove {args} { # PART OF THE ::tcl::tm::path ENSEMBLE # - # Removes the path from the list of module paths. The command is - # silently ignored if the path is not on the list. + # Removes the path from the list of module paths. The command is silently + # ignored if the path is not on the list. variable paths - foreach p [linsert $args 0 $path] { + foreach p $args { set pos [lsearch -exact $paths $p] if {$pos >= 0} { set paths [lreplace $paths $pos $pos] @@ -177,17 +168,16 @@ proc ::tcl::tm::list {} { # empty string. # exact - Either -exact or ommitted. # -# Name, version, and exact are used to determine -# satisfaction. The original is called iff no satisfaction was -# achieved. The name is also used to compute the directory to -# target in the search. +# Name, version, and exact are used to determine satisfaction. The +# original is called iff no satisfaction was achieved. The name is also +# used to compute the directory to target in the search. # # Results # None. # # Sideeffects -# May populate the package ifneeded database with additional -# provide scripts. +# May populate the package ifneeded database with additional provide +# scripts. proc ::tcl::tm::UnknownHandler {original name args} { # Import the list of paths to search for packages in module form. @@ -196,8 +186,8 @@ proc ::tcl::tm::UnknownHandler {original name args} { variable paths variable pkgpattern - # Without paths to search we can do nothing. (Except falling back - # to the regular search). + # Without paths to search we can do nothing. (Except falling back to the + # regular search). if {[llength $paths]} { set pkgpath [string map {:: /} $name] @@ -206,11 +196,10 @@ proc ::tcl::tm::UnknownHandler {original name args} { set pkgroot "" } - # We don't remember a copy of the paths while looping. Tcl - # Modules are unable to change the list while we are searching - # for them. This also simplifies the loop, as we cannot get - # additional directories while iterating over the list. A - # simple foreach is sufficient. + # We don't remember a copy of the paths while looping. Tcl Modules are + # unable to change the list while we are searching for them. This also + # simplifies the loop, as we cannot get additional directories while + # iterating over the list. A simple foreach is sufficient. set satisfied 0 foreach path $paths { @@ -223,12 +212,11 @@ proc ::tcl::tm::UnknownHandler {original name args} { } set strip [llength [file split $path]] - # We can't use glob in safe interps, so enclose the following - # in a catch statement, where we get the module files out - # of the subdirectories. In other words, Tcl Modules are - # not-functional in such an interpreter. This is the same - # as for the command "tclPkgUnknown", i.e. the search for - # regular packages. + # We can't use glob in safe interps, so enclose the following in a + # catch statement, where we get the module files out of the + # subdirectories. In other words, Tcl Modules are not-functional + # in such an interpreter. This is the same as for the command + # "tclPkgUnknown", i.e. the search for regular packages. catch { # We always look for _all_ possible modules in the current @@ -238,13 +226,15 @@ proc ::tcl::tm::UnknownHandler {original name args} { set pkgfilename [join [lrange [file split $file] $strip end] ::] if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} { - # Ignore everything not matching our pattern - # for package names. + # Ignore everything not matching our pattern for + # package names. continue } - if {[catch {package vcompare $pkgversion 0}]} { - # Ignore everything where the version part is - # not acceptable to "package vcompare". + try { + package vcompare $pkgversion 0 + } on error {} { + # Ignore everything where the version part is not + # acceptable to "package vcompare". continue } @@ -257,38 +247,36 @@ proc ::tcl::tm::UnknownHandler {original name args} { continue } - # We have found a candidate, generate a "provide - # script" for it, and remember it. Note that we - # are using ::list to do this; locally [list] - # means something else without the namespace - # specifier. - - # NOTE. When making changes to the format of the - # provide command generated below CHECK that the - # 'LOCATE' procedure in core file - # 'platform/shell.tcl' still understands it, or, - # if not, update its implementation appropriately. + # We have found a candidate, generate a "provide script" + # for it, and remember it. Note that we are using ::list + # to do this; locally [list] means something else without + # the namespace specifier. + + # NOTE. When making changes to the format of the provide + # command generated below CHECK that the 'LOCATE' + # procedure in core file 'platform/shell.tcl' still + # understands it, or, if not, update its implementation + # appropriately. # - # Right now LOCATE's implementation assumes that - # the path of the package file is the last element - # in the list. + # Right now LOCATE's implementation assumes that the path + # of the package file is the last element in the list. package ifneeded $pkgname $pkgversion \ "[::list package provide $pkgname $pkgversion];[::list source -encoding utf-8 $file]" - # We abort in this unknown handler only if we got - # a satisfying candidate for the requested - # package. Otherwise we still have to fallback to - # the regular package search to complete the - # processing. + # We abort in this unknown handler only if we got a + # satisfying candidate for the requested package. + # Otherwise we still have to fallback to the regular + # package search to complete the processing. if {($pkgname eq $name) && [package vsatisfies $pkgversion {*}$args]} { set satisfied 1 - # We do not abort the loop, and keep adding - # provide scripts for every candidate in the - # directory, just remember to not fall back to - # the regular search anymore. + + # We do not abort the loop, and keep adding provide + # scripts for every candidate in the directory, just + # remember to not fall back to the regular search + # anymore. } } } @@ -299,8 +287,8 @@ proc ::tcl::tm::UnknownHandler {original name args} { } } - # Fallback to previous command, if existing. See comment above - # about ::list... + # Fallback to previous command, if existing. See comment above about + # ::list... if {[llength $original]} { uplevel 1 $original [::linsert $args 0 $name] @@ -366,22 +354,22 @@ proc ::tcl::tm::Defaults {} { # Calls 'path add' to paths to the list of module search paths. proc ::tcl::tm::roots {paths} { - lassign [split [package present Tcl] .] major minor + regexp {^(\d+)\.(\d+)} [package present Tcl] - major minor foreach pa $paths { set p [file join $pa tcl$major] for {set n $minor} {$n >= 0} {incr n -1} { set px [file join $p ${major}.${n}] - if {![interp issafe]} { set px [file normalize $px] } + if {![interp issafe]} {set px [file normalize $px]} path add $px } set px [file join $p site-tcl] - if {![interp issafe]} { set px [file normalize $px] } + if {![interp issafe]} {set px [file normalize $px]} path add $px } return } -# Initialization. Set up the default paths, then insert the new -# handler into the chain. +# Initialization. Set up the default paths, then insert the new handler into +# the chain. -if {![interp issafe]} { ::tcl::tm::Defaults } +if {![interp issafe]} {::tcl::tm::Defaults} |