diff options
Diffstat (limited to 'library')
| -rw-r--r-- | library/auto.tcl | 288 | ||||
| -rw-r--r-- | library/clock.tcl | 1116 | ||||
| -rw-r--r-- | library/dde/pkgIndex.tcl | 10 | ||||
| -rw-r--r-- | library/history.tcl | 302 | ||||
| -rw-r--r-- | library/http/http.tcl | 282 | ||||
| -rw-r--r-- | library/http/pkgIndex.tcl | 6 | ||||
| -rw-r--r-- | library/http1.0/http.tcl | 6 | ||||
| -rw-r--r-- | library/init.tcl | 94 | ||||
| -rw-r--r-- | library/opt/optparse.tcl | 474 | ||||
| -rw-r--r-- | library/opt/pkgIndex.tcl | 2 | ||||
| -rw-r--r-- | library/package.tcl | 312 | ||||
| -rw-r--r-- | library/platform/pkgIndex.tcl | 2 | ||||
| -rwxr-xr-x | library/reg/pkgIndex.tcl | 14 | ||||
| -rw-r--r-- | library/safe.tcl | 194 | ||||
| -rw-r--r-- | library/tclIndex | 20 | ||||
| -rw-r--r-- | library/tm.tcl | 230 |
16 files changed, 1766 insertions, 1586 deletions
diff --git a/library/auto.tcl b/library/auto.tcl index 0848bb1..f7cf5f0 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -1,22 +1,22 @@ # 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: +# Arguments: # None. proc auto_reset {} { @@ -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]] - } elseif {[info library] ni $auto_path} { - lappend auto_path [info library] + } else { + if {[info library] ni $auto_path} { + lappend auto_path [info library] + } } } # tcl_findLibrary -- # # This is a utility for extensions that searches for a library directory -# using a canonical searching algorithm. A side effect is to source the -# initialization script and set a global library variable. +# 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,21 +64,24 @@ 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. - catch { - lappend dirs [::${basename}::pkgconfig get scriptdir,runtime] + if {[catch { + ::${basename}::pkgconfig get scriptdir,runtime + } value] == 0} { + lappend dirs $value } # 3. Relative to auto_path directories. This checks relative to the @@ -98,8 +101,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 @@ -122,19 +125,17 @@ 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 @@ -142,15 +143,16 @@ 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 @@ -165,28 +167,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: +# 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]} { @@ -195,6 +197,7 @@ 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" @@ -203,18 +206,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]} { + if {[llength $args] == 0} { set args *.tcl } auto_mkindex_parser::init foreach file [glob -- {*}$args] { - try { - append index [auto_mkindex_parser::mkindex $file] - } on error {msg opts} { - cd $oldDir + if {[catch {auto_mkindex_parser::mkindex $file} msg opts] == 0} { + append index $msg + } else { + cd $oldDir return -options $opts $msg - } + } } auto_mkindex_parser::cleanup @@ -224,8 +227,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] @@ -238,7 +241,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]} { + if {[llength $args] == 0} { set args *.tcl } foreach file [glob -- {*}$args] { @@ -276,9 +279,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 @@ -303,14 +306,7 @@ namespace eval auto_mkindex_parser { $parser hide namespace $parser hide eval $parser hide puts - 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 namespace delete :: $parser invokehidden proc unknown {args} {} # We'll need access to the "namespace" command within the @@ -337,12 +333,12 @@ 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: +# Arguments: # file Name of Tcl source file to be indexed. proc auto_mkindex_parser::mkindex {file} { @@ -358,13 +354,14 @@ 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 "" @@ -381,10 +378,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 @@ -394,30 +391,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. @@ -430,8 +427,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. @@ -450,23 +447,25 @@ 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" @@ -478,14 +477,15 @@ 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,8 +508,8 @@ 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] } @@ -517,8 +517,8 @@ 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. @@ -528,27 +528,24 @@ auto_mkindex_parser::command proc {name args} { 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 + # command is a little easier to read (otherwise it'd be full of # backslashed dollar signs, etc. append index [list set auto_index([fullname $name])] \ [format { [list source [file join $dir %s]]} \ [file split $scriptFile]] "\n" } -# Conditionally add support for Tcl byte code files. There are some tricky -# details here. First, we need to get the tbcload library initialized in the -# current interpreter. We cannot load tbcload into the slave until we have -# done so because it needs access to the tcl_patchLevel variable. Second, -# because the package index file may defer loading the library until we invoke -# a command, we need to explicitly invoke auto_load to force it to be loaded. -# This should be a noop if the package has already been loaded +# 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 { - try { - package require tbcload - } on error {} { - # OK, don't have it so do nothing - } on ok {} { + if {![catch {package require tbcload}]} { if {[namespace which -command tbcload::bcproc] eq ""} { auto_load tbcload::bcproc } @@ -556,7 +553,7 @@ auto_mkindex_parser::hook { # AUTO MKINDEX: tbcload::bcproc name arglist body # Adds an entry to the auto index list for the given pre-compiled - # procedure name. + # procedure name. auto_mkindex_parser::commandInit tbcload::bcproc {name args} { variable index @@ -572,15 +569,16 @@ auto_mkindex_parser::hook { } # 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 { diff --git a/library/clock.tcl b/library/clock.tcl index 0696c47..32911b3 100644 --- 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,8 +15,8 @@ # #---------------------------------------------------------------------- -# 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 @@ -27,8 +27,9 @@ 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]]] @@ -39,10 +40,10 @@ 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. # -#---------------------------------------------------------------------- +#---------------------------------------------------------------------- namespace eval ::tcl::clock { @@ -75,11 +76,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. # #---------------------------------------------------------------------- @@ -171,8 +172,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 @@ -188,13 +189,13 @@ proc ::tcl::clock::Initialize {} { # Germany, Norway, Denmark (Catholic Germany changed earlier) ::msgcat::mcset de_DE GREGORIAN_CHANGE_DATE 2342032 - ::msgcat::mcset nb GREGORIAN_CHANGE_DATE 2342032 + ::msgcat::mcset nb GREGORIAN_CHANGE_DATE 2342032 ::msgcat::mcset nn GREGORIAN_CHANGE_DATE 2342032 ::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 @@ -216,23 +217,23 @@ 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 # Greece ::msgcat::mcset el GREGORIAN_CHANGE_DATE 2423480 - + #------------------------------------------------------------------ # # CONSTANTS # #------------------------------------------------------------------ - # 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 { @@ -281,10 +282,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: @@ -295,10 +296,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 @@ -377,10 +378,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 { @@ -484,8 +485,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 { @@ -651,14 +652,16 @@ 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. # #---------------------------------------------------------------------- proc ::tcl::clock::format { args } { + variable FormatProc variable TZData @@ -667,7 +670,7 @@ proc ::tcl::clock::format { args } { set clockval [lindex $args 0] # Get the data for time changes in the given zone - + if {$timezone eq ""} { set timezone [GetSystemTimeZone] } @@ -677,11 +680,11 @@ proc ::tcl::clock::format { args } { return -options $opts $retval } } - - # 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] if {[info exists FormatProc($procName)]} { @@ -690,8 +693,9 @@ proc ::tcl::clock::format { args } { set FormatProc($procName) \ [ParseClockFormatFormat $procName $format $locale] } - + return [$procName $clockval $timezone] + } #---------------------------------------------------------------------- @@ -710,31 +714,45 @@ proc ::tcl::clock::format { args } { #---------------------------------------------------------------------- proc ::tcl::clock::ParseClockFormatFormat {procName format locale} { + if {[namespace which $procName] ne {}} { return $procName } # Map away the locale-dependent composite format groups - + EnterLocale $locale oldLocale # Change locale if a fresh locale has been given on the command line. - try { - return [ParseClockFormatFormat2 $format $locale $procName] - } trap CLOCK {result opts} { - dict unset opts -errorinfo - return -options $opts $result - } finally { - # Restore the locale + set status [catch { + + ParseClockFormatFormat2 $format $locale $procName - if { [info exists oldLocale] } { - mclocale $oldLocale + } 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 } + } proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { + set didLocaleEra 0 set didLocaleNumerals 0 set preFormatCode \ @@ -749,7 +767,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { set formatString {} set substituents {} set state {} - + set format [LocalizeFormat $locale $format] foreach char [split $format {}] { @@ -776,7 +794,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { { [lindex @DAYS_OF_WEEK_ABBREV@ \ [expr {[dict get $date dayOfWeek] \ % 7}]]}] - } + } A { # Day of week, spelt out. append formatString %s append substituents \ @@ -877,7 +895,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { k { # Hour (0-23), no leading zero append formatString %2d append substituents \ - { [expr { [dict get $date localSeconds] + { [expr { [dict get $date localSeconds] / 3600 % 24 }]} } @@ -898,7 +916,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { M { # Minute of the hour, leading zero append formatString %02d append substituents \ - { [expr { [dict get $date localSeconds] + { [expr { [dict get $date localSeconds] / 60 % 60 }]} } @@ -939,7 +957,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { { [expr {(([dict get $date localSeconds] % 86400) < 43200) ? $am : $pm}]} - + } Q { # Hi, Jeff! append formatString %s @@ -949,11 +967,11 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { append formatString %s append substituents { [dict get $date seconds]} } - S { # Second of the minute, with + S { # Second of the minute, with # leading zero append formatString %02d append substituents \ - { [expr { [dict get $date localSeconds] + { [expr { [dict get $date localSeconds] % 60 }]} } t { # A literal tab character @@ -974,7 +992,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { } incr dow set UweekNumber \ - [expr { ( [dict get $date dayOfYear] + [expr { ( [dict get $date dayOfYear] - $dow + 7 ) / 7 }] } @@ -997,7 +1015,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { set WweekNumber \ [expr { ( [dict get $date dayOfYear] - [dict get $date dayOfWeek] - + 7 ) + + 7 ) / 7 }] } append formatString %02d @@ -1066,7 +1084,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { percentO { # Character following %O set state {} switch -exact -- $char { - d - e { # Day of the month in alternative + d - e { # Day of the month in alternative # numerals append formatString %s append substituents \ @@ -1078,7 +1096,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { append formatString %s append substituents \ { [lindex $localeNumerals \ - [expr { [dict get $date localSeconds] + [expr { [dict get $date localSeconds] / 3600 % 24 }]]} } @@ -1104,7 +1122,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { append formatString %s append substituents \ { [lindex $localeNumerals \ - [expr { [dict get $date localSeconds] + [expr { [dict get $date localSeconds] / 60 % 60 }]]} } @@ -1113,7 +1131,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { append formatString %s append substituents \ { [lindex $localeNumerals \ - [expr { [dict get $date localSeconds] + [expr { [dict get $date localSeconds] % 60 }]]} } u { # Day of the week (Monday=1,Sunday=7) @@ -1144,9 +1162,9 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { } } } - + # Clean up any improperly terminated groups - + switch -exact -- $state { percent { append formatString %% @@ -1173,14 +1191,16 @@ 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. # #---------------------------------------------------------------------- proc ::tcl::clock::scan { args } { + set format {} # Check the count of args @@ -1242,17 +1262,21 @@ 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 -strict $gmt] } { - return -code error "expected boolean value but got \"$gmt\"" - } elseif { $gmt } { - set timezone :GMT + if { ![string is boolean $gmt] } { + return -code error \ + "expected boolean value but got \"$gmt\"" + } else { + if { $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] \ @@ -1266,23 +1290,31 @@ proc ::tcl::clock::scan { args } { EnterLocale $locale oldLocale - try { + set status [catch { + # Map away the locale-dependent composite format groups set scanner [ParseClockScanFormat $format $locale] - return [$scanner $string $base $timezone] - } trap CLOCK {result opts} { - # Conceal location of generation of expected errors + $scanner $string $base $timezone - dict unset opts -errorinfo - return -options $opts $result - } finally { - # Restore the locale + } result opts] + + # Restore the locale + + if { [info exists oldLocale] } { + mclocale $oldLocale + } - 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 } + } #---------------------------------------------------------------------- @@ -1298,50 +1330,52 @@ 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 # #---------------------------------------------------------------------- proc ::tcl::clock::FreeScan { string base timezone locale } { + variable TZData # Get the data for time changes in the given zone - - try { - SetupTimeZone $timezone - } on error {retval opts} { + + if {[catch {SetupTimeZone $timezone} 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 + # 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 - }] + set date [GetDateFields \ + $base \ + $TZData($timezone) \ + 2361222] + dict set date secondOfDay [expr { [dict get $date localSeconds] + % 86400 }] - # 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" + # Parse the date. The parser will return a list comprising + # date, time, time zone, relative month/day/seconds, relative + # weekday, ordinal month. + + 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" } - # 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. + 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 { [llength $parseDate] > 0 } { lassign $parseDate y m d @@ -1361,12 +1395,12 @@ 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 set timezone [FormatNumericTimeZone \ @@ -1380,19 +1414,18 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { set date [GetJulianDayFromEraYearMonthDay $date[set date {}] 2361222] if { $parseTime ne {} } { dict set date secondOfDay $parseTime - } elseif { [llength $parseWeekday] != 0 - || [llength $parseOrdinalMonth] != 0 - || ( [llength $parseRel] != 0 + } elseif { [llength $parseWeekday] != 0 + || [llength $parseOrdinalMonth] != 0 + || ( [llength $parseRel] != 0 && ( [lindex $parseRel 0] != 0 || [lindex $parseRel 1] != 0 ) ) } { 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] @@ -1404,17 +1437,18 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { set seconds [add $seconds \ $relMonth months $relDay days $relSecond seconds \ -timezone $timezone -locale $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 @@ -1422,20 +1456,21 @@ 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] set seconds [dict get $date2 seconds] + } # Do relative month if { [llength $parseOrdinalMonth] > 0 } { + lassign $parseOrdinalMonth monthOrdinal monthNumber if { $monthOrdinal > 0 } { set monthDiff [expr { $monthNumber - [dict get $date month] }] @@ -1452,6 +1487,7 @@ proc ::tcl::clock::FreeScan { string base timezone locale } { } set seconds [add $seconds $monthOrdinal years $monthDiff months \ -timezone $timezone -locale $locale] + } return $seconds @@ -1469,27 +1505,30 @@ 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] @@ -1533,8 +1572,8 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { append re {[[:space:]]+} } else { if { ! [string is alnum $c] } { - append re "\\" - } + append re \\ + } append re $c } } @@ -1651,7 +1690,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 \[" \ @@ -1694,9 +1733,10 @@ 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 } \[ \ @@ -1729,13 +1769,14 @@ 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 - + append re \\s*(\\d\\d?) dict set fieldSet iso8601Week [incr fieldCount] append postcode "dict set date iso8601Week \[" \ @@ -1907,7 +1948,7 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { "day of week is greater than 7" } dict set date dayOfWeek $dow - } + } } y { lassign [LocaleNumeralMatcher $locale] regex lookup @@ -1953,11 +1994,10 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { append procBody $postcode append procBody [list set changeover [mc GREGORIAN_CHANGE_DATE]] \n - # Set up the time zone before doing anything with a default base date - # that might need a timezone to interpret it. + # Get time zone if needed - if { ![dict exists $fieldSet seconds] - && ![dict exists $fieldSet starDate] } { + if { ![dict exists $fieldSet seconds] + && ![dict exists $fieldSet starDate] } { if { [dict exists $fieldSet tzName] } { append procBody { set timeZone [dict get $date tzName] @@ -1976,29 +2016,24 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { append procBody [MakeParseCodeFromFields $fieldSet $TimeParseActions] - # 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 + # Assemble seconds, and convert local nominal time to UTC. - if { ![dict exists $fieldSet seconds] + if { ![dict exists $fieldSet seconds] && ![dict exists $fieldSet starDate] } { append procBody { if { [dict get $date julianDay] > 5373484 } { 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] } } @@ -2012,19 +2047,20 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { return $procName } - + #---------------------------------------------------------------------- # # 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. @@ -2032,6 +2068,7 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} { #---------------------------------------------------------------------- proc ::tcl::clock::LocaleNumeralMatcher {l} { + variable LocaleNumeralCache if { ![dict exists $LocaleNumeralCache $l] } { @@ -2050,16 +2087,16 @@ proc ::tcl::clock::LocaleNumeralMatcher {l} { } return [dict get $LocaleNumeralCache $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. @@ -2067,10 +2104,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. @@ -2078,10 +2115,11 @@ 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 {} {}] @@ -2089,7 +2127,8 @@ proc ::tcl::clock::UniquePrefixRegexp { data } { # Walk the key-value pairs foreach { key value } $data { - # Construct all prefixes of the key; + + # Construct all prefixes of the key; set prefix {} foreach char [split $key {}] { @@ -2107,8 +2146,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 { @@ -2131,8 +2170,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 @@ -2144,17 +2183,18 @@ 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. # #---------------------------------------------------------------------- -proc ::tcl::clock::MakeUniquePrefixRegexp { successors +proc ::tcl::clock::MakeUniquePrefixRegexp { successors uniquePrefixMapping prefixString } { + # Get the characters that may follow the current prefix string set schars [lsort -ascii [dict keys [dict get $successors $prefixString]]] @@ -2162,15 +2202,13 @@ 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 - } then { + if { [dict exists $uniquePrefixMapping $prefixString] + || [llength $schars] > 1 } { append re "(?:" } @@ -2192,7 +2230,7 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors if { [dict exists $uniquePrefixMapping $prefixString] } { append re ")?" - } elseif { [llength $schars] > 1 } { + } elseif { [llength $schars] > 1 } { append re ")" } @@ -2203,8 +2241,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, @@ -2215,8 +2253,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. @@ -2224,6 +2262,7 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors #---------------------------------------------------------------------- proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { + set currPrio 999 set currFieldPos [list] set currCodeBurst { @@ -2231,15 +2270,16 @@ 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 @@ -2262,11 +2302,9 @@ 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 - } then { + if { ![string is integer $newPos] + || ![string is integer $currPos] + || $newPos > $currPos } { break } if { $newPos < $currPos } { @@ -2284,9 +2322,11 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { set currPrio $prio set currFieldPos $fPos set currCodeBurst $parseAction + } return $currCodeBurst + } #---------------------------------------------------------------------- @@ -2304,13 +2344,14 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { # 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, uses [mcload] to load the +# designated locale's files, and tracks that it has done so +# in the 'McLoaded' variable. # #---------------------------------------------------------------------- proc ::tcl::clock::EnterLocale { locale oldLocaleVar } { + upvar 1 $oldLocaleVar oldLocale variable MsgDir @@ -2318,24 +2359,27 @@ proc ::tcl::clock::EnterLocale { locale oldLocaleVar } { set oldLocale [mclocale] 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 {} } - # 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] } { @@ -2356,14 +2400,15 @@ proc ::tcl::clock::EnterLocale { locale oldLocaleVar } { mcload $MsgDir dict set McLoaded $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 @@ -2375,12 +2420,14 @@ 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 @@ -2482,6 +2529,7 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { } return + } #---------------------------------------------------------------------- @@ -2496,8 +2544,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. @@ -2505,6 +2553,7 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { #---------------------------------------------------------------------- proc ::tcl::clock::LocalizeFormat { locale format } { + variable McLoaded if { [dict exists $McLoaded $locale FORMAT $format] } { @@ -2516,7 +2565,7 @@ proc ::tcl::clock::LocalizeFormat { locale format } { # string. Note that the order of the [string map] operations is # significant because later formats can refer to later ones; for example # %c can refer to %X, which in turn can refer to %T. - + set list { %% %% %D %m/%d/%Y @@ -2533,7 +2582,7 @@ proc ::tcl::clock::LocalizeFormat { locale format } { lappend list %c [string map $list [mc DATE_TIME_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 return $format } @@ -2556,6 +2605,7 @@ proc ::tcl::clock::LocalizeFormat { locale format } { #---------------------------------------------------------------------- proc ::tcl::clock::FormatNumericTimeZone { z } { + if { $z < 0 } { set z [expr { - $z }] set retval - @@ -2570,6 +2620,7 @@ proc ::tcl::clock::FormatNumericTimeZone { z } { append retval [::format %02d $z] } return $retval + } #---------------------------------------------------------------------- @@ -2594,6 +2645,7 @@ proc ::tcl::clock::FormatNumericTimeZone { z } { #---------------------------------------------------------------------- proc ::tcl::clock::FormatStarDate { date } { + variable Roddenberry # Get day of year, zero based @@ -2644,6 +2696,7 @@ proc ::tcl::clock::FormatStarDate { date } { #---------------------------------------------------------------------- proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { + variable Roddenberry # Build a tentative date from year and fraction. @@ -2659,8 +2712,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 \ @@ -2673,11 +2726,10 @@ 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 }] + } #---------------------------------------------------------------------- @@ -2690,8 +2742,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. # #---------------------------------------------------------------------- @@ -2712,8 +2764,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. @@ -2730,17 +2782,18 @@ 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 +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 }] @@ -2748,6 +2801,7 @@ proc ::tcl::clock::InterpretTwoDigitYear { date baseTime dict set date $fourDigitField [expr { $yr + 1900 }] } return $date + } #---------------------------------------------------------------------- @@ -2773,6 +2827,7 @@ 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 @@ -2786,6 +2841,7 @@ proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } { dict set date year [dict get $date2 year] return $date + } #---------------------------------------------------------------------- @@ -2812,6 +2868,7 @@ 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 @@ -2829,7 +2886,7 @@ proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} { # # AssignBaseMonth -- # -# Places the number of the current year and month into a +# Places the number of the current year and month into a # dictionary. # # Parameters: @@ -2848,6 +2905,7 @@ 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 @@ -2857,6 +2915,7 @@ 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 + } #---------------------------------------------------------------------- @@ -2882,6 +2941,7 @@ 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 @@ -2918,6 +2978,7 @@ 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 @@ -2947,6 +3008,7 @@ 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 @@ -2956,6 +3018,7 @@ proc ::tcl::clock::InterpretHMSP { date } { } dict set date hour $hr return [InterpretHMS $date[set date {}]] + } #---------------------------------------------------------------------- @@ -2978,11 +3041,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] }] + } #---------------------------------------------------------------------- @@ -3005,6 +3068,7 @@ proc ::tcl::clock::InterpretHMS { date } { #---------------------------------------------------------------------- proc ::tcl::clock::GetSystemTimeZone {} { + variable CachedSystemTimeZone variable TimeZoneBad @@ -3037,69 +3101,76 @@ 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] - } then { + } elseif { [regexp {^([-+])(\d\d)(?::?(\d\d)(?::?(\d\d))?)?} $timezone \ + -> s hh mm ss] } { + # Make a fixed offset ::scan $hh %d hh @@ -3120,21 +3191,24 @@ 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 { + 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] } { @@ -3147,8 +3221,9 @@ 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] } { @@ -3172,22 +3247,25 @@ 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 @@ -3218,14 +3296,16 @@ 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] @@ -3273,11 +3353,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] \ @@ -3286,11 +3366,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] \ @@ -3298,9 +3378,10 @@ proc ::tcl::clock::GuessWindowsTimeZone {} { : [::format %02d $stdSecond] } dict set WinZoneInfo $data $tzname - } + } return [dict get $WinZoneInfo $data] + } #---------------------------------------------------------------------- @@ -3329,18 +3410,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" } - try { + if { [catch { source -encoding utf-8 [file join $DataDir $fileName] - } on error {} { + }] } { return -code error \ -errorcode [list CLOCK badTimeZone :$fileName] \ "time zone \":$fileName\" not found" @@ -3358,8 +3439,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 @@ -3367,11 +3448,12 @@ 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 \ @@ -3400,14 +3482,15 @@ 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 @@ -3426,8 +3509,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 @@ -3445,19 +3528,18 @@ 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}} { @@ -3481,9 +3563,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 @@ -3491,10 +3573,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} @@ -3524,8 +3606,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}} { @@ -3558,8 +3640,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. @@ -3570,7 +3652,7 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { # The following keys are present in the dictionary: # stdName - Name of the time zone when Daylight Saving Time # is not in effect. -# stdSignum - Sign (+, -, or empty) of the offset from Greenwich +# stdSignum - Sign (+, -, or empty) of the offset from Greenwich # to the given (non-DST) time zone. + and the empty # string denote zones west of Greenwich, - denotes east # of Greenwich; this is contrary to the ISO convention @@ -3615,13 +3697,14 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { # endHours, endMinutes, endSeconds - # 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 @@ -3632,8 +3715,8 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { ([[:digit:]]{1,2}) (?: # 4 - Standard time zone offset, minutes - : ([[:digit:]]{1,2}) - (?: + : ([[:digit:]]{1,2}) + (?: # 5 - Standard time zone offset, seconds : ([[:digit:]]{1,2} ) )? @@ -3649,8 +3732,8 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { ([[:digit:]]{1,2}) (?: # 9 - DST time zone offset, minutes - : ([[:digit:]]{1,2}) - (?: + : ([[:digit:]]{1,2}) + (?: # 10 - DST time zone offset, seconds : ([[:digit:]]{1,2}) )? @@ -3663,8 +3746,8 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { ( J ? ) ( [[:digit:]]+ ) | M # 13 - Month number 14 - Week of month 15 - Day of week - ( [[:digit:]] + ) - [.] ( [[:digit:]] + ) + ( [[:digit:]] + ) + [.] ( [[:digit:]] + ) [.] ( [[:digit:]] + ) ) (?: @@ -3685,8 +3768,8 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { ( J ? ) ( [[:digit:]]+ ) | M # 21 - Month number 22 - Week of month 23 - Day of week - ( [[:digit:]] + ) - [.] ( [[:digit:]] + ) + ( [[:digit:]] + ) + [.] ( [[:digit:]] + ) [.] ( [[:digit:]] + ) ) (?: @@ -3713,21 +3796,27 @@ 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' @@ -3741,6 +3830,7 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } { #---------------------------------------------------------------------- proc ::tcl::clock::ProcessPosixTimeZone { z } { + variable MINWIDE variable TZData @@ -3755,20 +3845,20 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { } else { set stdSignum -1 } - set stdHours [lindex [::scan [dict get $z stdHours] %d] 0] + set stdHours [lindex [::scan [dict get $z stdHours] %d] 0] if { [dict get $z stdMinutes] ne {} } { - set stdMinutes [lindex [::scan [dict get $z stdMinutes] %d] 0] + set stdMinutes [lindex [::scan [dict get $z stdMinutes] %d] 0] } else { set stdMinutes 0 } if { [dict get $z stdSeconds] ne {} } { - set stdSeconds [lindex [::scan [dict get $z stdSeconds] %d] 0] + set stdSeconds [lindex [::scan [dict get $z stdSeconds] %d] 0] } 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 @@ -3791,20 +3881,20 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } { if { [dict get $z dstHours] eq {} } { set dstOffset [expr { 3600 + $stdOffset }] } else { - set dstHours [lindex [::scan [dict get $z dstHours] %d] 0] + set dstHours [lindex [::scan [dict get $z dstHours] %d] 0] if { [dict get $z dstMinutes] ne {} } { - set dstMinutes [lindex [::scan [dict get $z dstMinutes] %d] 0] + set dstMinutes [lindex [::scan [dict get $z dstMinutes] %d] 0] } else { set dstMinutes 0 } if { [dict get $z dstSeconds] ne {} } { - set dstSeconds [lindex [::scan [dict get $z dstSeconds] %d] 0] + set dstSeconds [lindex [::scan [dict get $z dstSeconds] %d] 0] } 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 @@ -3813,10 +3903,8 @@ 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 {} - } then { + if { [dict get $z startDayOfYear] eq {} + && [dict get $z startMonth] eq {} } { if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} { # EU dict set z startWeekOfMonth 5 @@ -3835,10 +3923,8 @@ 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 {} - } then { + if { [dict get $z endDayOfYear] eq {} + && [dict get $z endMonth] eq {} } { if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} { # EU dict set z endMonth 10 @@ -3878,14 +3964,15 @@ 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. @@ -3895,12 +3982,13 @@ 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. # #---------------------------------------------------------------------- proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { + variable FEB_28 # Determine the start or end day of DST @@ -3908,16 +3996,18 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { set date [dict create era CE year $y] set doy [dict get $z ${bound}DayOfYear] if { $doy ne {} } { + # Time was specified as a day of the year if { [dict get $z ${bound}J] ne {} - && [IsGregorianLeapYear $y] + && [IsGregorianLeapYear $y] && ( $doy > $FEB_28 ) } { incr doy } 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] @@ -3932,9 +4022,8 @@ 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 {} } { @@ -3956,6 +4045,7 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { } set tod [expr { ( $h * 60 + $m ) * 60 + $s }] return [expr { $seconds + $tod }] + } #---------------------------------------------------------------------- @@ -3973,26 +4063,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 + } #---------------------------------------------------------------------- @@ -4010,9 +4100,10 @@ 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. @@ -4023,6 +4114,7 @@ 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] { @@ -4038,25 +4130,21 @@ 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 @@ -4067,8 +4155,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' @@ -4087,9 +4175,10 @@ 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] @@ -4105,6 +4194,7 @@ proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} { [dict get $date2 julianDay]] dict set date julianDay [expr { $wd0 + 7 * $week }] return $date + } #---------------------------------------------------------------------- @@ -4127,8 +4217,9 @@ proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} { #---------------------------------------------------------------------- proc ::tcl::clock::IsGregorianLeapYear { date } { + switch -exact -- [dict get $date era] { - BCE { + BCE { set year [expr { 1 - [dict get $date year]}] } CE { @@ -4146,14 +4237,15 @@ 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 @@ -4168,16 +4260,18 @@ 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 @@ -4185,8 +4279,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. @@ -4194,6 +4288,7 @@ proc ::tcl::clock::WeekdayOnOrBefore { weekday j } { #---------------------------------------------------------------------- proc ::tcl::clock::BSearch { list key } { + if {[llength $list] == 0} { return -1 } @@ -4205,12 +4300,13 @@ 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] } { @@ -4254,14 +4350,15 @@ 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 \ @@ -4280,10 +4377,15 @@ 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 } @@ -4295,7 +4397,8 @@ proc ::tcl::clock::add { clockval args } { set timezone $b } default { - throw [list CLOCK badSwitch $a] \ + return -code error \ + -errorcode [list CLOCK badSwitch $a] \ "bad switch \"$a\",\ must be -gmt, -locale or -timezone" } @@ -4311,16 +4414,20 @@ 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 -strict $gmt] } { - return -code error "expected boolean value but got \"$gmt\"" - } elseif { $gmt } { - set timezone :GMT + if { ![string is boolean $gmt] } { + return -code error \ + "expected boolean value but got \"$gmt\"" + } else { + if { $gmt } { + set timezone :GMT + } } EnterLocale $locale oldLocale - + set changeover [mc GREGORIAN_CHANGE_DATE] if {[catch {SetupTimeZone $timezone} retval opts]} { @@ -4328,25 +4435,29 @@ proc ::tcl::clock::add { clockval args } { return -options $opts $retval } - try { + set status [catch { + 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 { @@ -4360,24 +4471,31 @@ proc ::tcl::clock::add { clockval args } { } default { - throw [list CLOCK badUnit $unit] \ - "unknown unit \"$unit\", must be \ - years, months, weeks, days, hours, minutes or seconds" + 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] } } } - 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 - } finally { - # Restore the locale + } result opts] + + # Restore the locale + + if { [info exists oldLocale] } { + mclocale $oldLocale + } - 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 } + } #---------------------------------------------------------------------- @@ -4402,6 +4520,7 @@ proc ::tcl::clock::add { clockval args } { #---------------------------------------------------------------------- proc ::tcl::clock::AddMonths { months clockval timezone changeover } { + variable DaysInRomanMonthInCommonYear variable DaysInRomanMonthInLeapYear variable TZData @@ -4409,9 +4528,8 @@ 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 @@ -4440,23 +4558,23 @@ 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] return [dict get $date seconds] + } #---------------------------------------------------------------------- # # 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) @@ -4466,7 +4584,8 @@ 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. @@ -4474,14 +4593,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 @@ -4490,23 +4609,23 @@ 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] return [dict get $date seconds] + } #---------------------------------------------------------------------- # # mc -- # -# Wrapper around ::msgcat::mc that caches the result according to the -# locale. +# Wrapper around ::msgcat::mc that caches the result according +# to the locale. # # Parameters: # Accepts the name of the message to retrieve. @@ -4527,10 +4646,11 @@ proc ::tcl::clock::mc { name } { 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 } - set val [::msgcat::mc $name] - dict set McLoaded $Locale $name $val - return $val } #---------------------------------------------------------------------- @@ -4551,6 +4671,7 @@ proc ::tcl::clock::mc { name } { #---------------------------------------------------------------------- proc ::tcl::clock::ClearCaches {} { + variable FormatProc variable LocaleNumeralCache variable McLoaded @@ -4570,4 +4691,5 @@ proc ::tcl::clock::ClearCaches {} { catch {unset CachedSystemTimeZone} set TimeZoneBad {} InitTZData + } diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl index 4cf73d0..114dee6 100644 --- a/library/dde/pkgIndex.tcl +++ b/library/dde/pkgIndex.tcl @@ -1,7 +1,7 @@ -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] +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] } else { - package ifneeded dde 1.4.0 [list load [file join $dir tcldde14.dll] dde] + package ifneeded dde 1.3.3 [list load [file join $dir tcldde13.dll] dde] } diff --git a/library/history.tcl b/library/history.tcl index 51d2404..888d144 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,78 +24,163 @@ 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 some argument checking and calls the helper ensemble in the -# tcl namespace. - -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. +# This does argument checking and calls helper procedures in the +# history namespace. - if {![llength $args]} { - set args info +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 + + 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 - # Tricky stuff needed to make stack and errors come out right! - tailcall apply {arglist {tailcall history {*}$arglist} ::tcl} $args + 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" + } + } } - + # tcl::HistAdd -- # # Add an item to the history, and optionally eval it at the global scope # # Parameters: -# event the command to add -# exec (optional) a substring of "exec" causes the command to -# be evaled. +# command 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 {event {exec {}}} { + proc tcl::HistAdd {command {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 $event] eq ""} { + if {[string trim $command] eq ""} { 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 "" + 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 {} } - tailcall eval $event } - + # tcl::HistKeep -- # # Set or query the limit on the length of the history list @@ -109,22 +194,20 @@ proc ::tcl::HistAdd {event {exec {}}} { # Side Effects: # Updates history(keep) if a limit is specified -proc ::tcl::HistKeep {{count {}}} { + proc tcl::HistKeep {{limit {}}} { variable history - if {[llength [info level 0]] == 1} { + if {$limit eq ""} { 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 @@ -138,7 +221,7 @@ proc ::tcl::HistKeep {{count {}}} { # 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 @@ -148,7 +231,7 @@ proc ::tcl::HistClear {} { oldest -$keep \ ] } - + # tcl::HistInfo -- # # Return a pretty-printed version of the history list @@ -159,16 +242,14 @@ proc ::tcl::HistClear {} { # Results: # A formatted history list -proc ::tcl::HistInfo {{count {}}} { + proc tcl::HistInfo {{num {}}} { variable history - if {[llength [info level 0]] == 1} { - set count [expr {$history(keep) + 1}] - } elseif {![string is integer -strict $count]} { - return -code error "bad integer \"$count\"" + if {$num eq ""} { + set num [expr {$history(keep) + 1}] } set result {} set newline "" - for {set i [expr {$history(nextid) - $count + 1}]} \ + for {set i [expr {$history(nextid) - $num + 1}]} \ {$i <= $history(nextid)} {incr i} { if {![info exists history($i)]} { continue @@ -179,11 +260,11 @@ proc ::tcl::HistInfo {{count {}}} { } 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, @@ -195,18 +276,20 @@ proc ::tcl::HistInfo {{count {}}} { # 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 - tailcall eval $cmd + uplevel #0 $cmd } - + # tcl::HistIndex -- # # Map from an event specifier to an index in the history list. @@ -216,22 +299,22 @@ proc ::tcl::HistRedo {{event -1}} { # 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 {![string is integer -strict $event]} { + if {[catch {expr {~$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\"" @@ -248,64 +331,43 @@ proc ::tcl::HistIndex {event} { } 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 -1}} { + proc tcl::HistEvent {event} { variable history set i [HistIndex $event] - if {![info exists history($i)]} { - return "" + if {[info exists history($i)]} { + return [string trimright $history($i) \ \n] + } else { + return ""; } - return [string trimright $history($i) \ \n] } - + # tcl::HistChange -- # # Replace a value in the history list. # # Parameters: -# 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. +# 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. # # Side Effects: # Changes the history list. -proc ::tcl::HistChange {newValue {event 0}} { + proc tcl::HistChange {cmd {event 0}} { variable history set i [HistIndex $event] - set history($i) $newValue + set history($i) $cmd } - -# 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 3754f71..98d2c5d 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.6 +package require Tcl 8.4 # Keep this in sync with pkgIndex.tcl and with the install directories in # Makefiles -package provide http 2.8.7 +package provide http 2.7.12 namespace eval http { # Allow resourcing to not clobber existing data @@ -25,13 +25,7 @@ namespace eval http { -proxyfilter http::ProxyRequired -urlencoding utf-8 } - # 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]" + set http(-useragent) "Tcl http client package [package provide http]" } proc init {} { @@ -98,7 +92,7 @@ namespace eval http { # Arguments: # msg Message to output # -if {[info command http::Log] eq {}} {proc http::Log {args} {}} +proc http::Log {args} {} # http::register -- # @@ -199,7 +193,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)]} { @@ -365,7 +359,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)" @@ -420,6 +414,7 @@ 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 @@ -434,10 +429,7 @@ proc http::geturl {url args} { [^@/\#?]+ # <userinfo part of authority> ) @ )? - ( # <host part of authority> - [^/:\#?]+ | # host name or IPv4 address - \[ [^/\#?]+ \] # IPv6 address in square brackets - ) + ( [^/:\#?]+ ) # <host part of authority> (?: : (\d+) )? # <port part of authority> )? ( [/\?] [^\#]*)? # <path> (including query) @@ -451,7 +443,6 @@ 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. @@ -683,11 +674,7 @@ 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 - } + if {[catch { puts $sock "$how $srvurl HTTP/$state(-protocol)" puts $sock "Accept: $http(-accept)" @@ -735,8 +722,14 @@ proc http::Connected { token proto phost srvurl} { puts $sock "$key: $value" } } - if {!$accept_encoding_seen && ![info exists state(-handler)]} { - puts $sock "Accept-Encoding: deflate,gzip,compress" + # 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" } if {$isQueryChannel && $state(querylength) == 0} { # Try to determine size of data in channel. If we cannot seek, the @@ -760,7 +753,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 @@ -782,7 +775,7 @@ proc http::Connected { token proto phost srvurl} { fileevent $sock readable [list http::Event $sock $token] } - } err]} { + } err]} then { # The socket probably was never connected, or the connection dropped # later. @@ -883,7 +876,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 {} @@ -934,7 +927,7 @@ proc http::Write {token} { set done 1 } } - } err]} { + } err]} then { # Do not call Finish here, but instead let the read half of the socket # process whatever server reply there is to get. @@ -1013,7 +1006,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 @@ -1024,20 +1017,26 @@ 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 {[info exists state(-channel)]} { - if {$state(binary) || [llength [ContentEncoding $token]]} { + if { + $state(binary) || [string match *gzip* $state(coding)] || + [string match *compress* $state(coding)] + } then { + if {[info exists state(-channel)]} { fconfigure $state(-channel) -translation binary } - if {![info exists state(-handler)]} { - # Initiate a sequence of background fcopies - fileevent $sock readable {} - CopyStart $sock $token - return - } + } + if { + [info exists state(-channel)] && + ![info exists state(-handler)] + } then { + # Initiate a sequence of background fcopies + fileevent $sock readable {} + CopyStart $sock $token + return } } elseif {$n > 0} { # Process header lines @@ -1092,7 +1091,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] @@ -1132,11 +1131,11 @@ proc http::Event {sock token} { if { ($state(totalsize) > 0) && ($state(currentsize) >= $state(totalsize)) - } { + } then { Eof $token } } - } err]} { + } err]} then { return [Finish $token $err] } else { if {[info exists state(-progress)]} { @@ -1189,54 +1188,14 @@ proc http::getTextLine {sock} { # Side Effects # This closes the connection upon error -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} { +proc http::CopyStart {sock token} { + variable $token upvar 0 $token state - 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. + if {[catch { + fcopy $sock $state(-channel) -size $state(-blocksize) -command \ + [list http::CopyDone $token] + } err]} then { + Finish $token $err } } @@ -1266,7 +1225,7 @@ proc http::CopyDone {token count {error {}}} { } elseif {[catch {eof $sock} iseof] || $iseof} { Eof $token } else { - CopyStart $sock $token 0 + CopyStart $sock $token } } @@ -1290,31 +1249,34 @@ proc http::Eof {token {force 0}} { set state(status) ok } - if {[string length $state(body)] > 0} { - if {[catch { - foreach coding [ContentEncoding $token] { - set state(body) [zlib $coding $state(body)] + 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)] } - } err]} { - Log "error doing $coding '$state(body)'" + } err]} then { 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 } @@ -1390,7 +1352,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" @@ -1413,7 +1375,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)] @@ -1459,57 +1421,59 @@ proc http::CharsetToEncoding {charset} { } } -# 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\"" - } - } - } +# 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" } - return $r -} -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 + # 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 + } + + 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 } # Local variables: diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl index aaa3e85..0157b3c 100644 --- a/library/http/pkgIndex.tcl +++ b/library/http/pkgIndex.tcl @@ -1,2 +1,4 @@ -if {![package vsatisfies [package provide Tcl] 8.6]} {return} -package ifneeded http 2.8.7 [list tclPkgSetup $dir http 2.8.7 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}] +# Tcl package index file, version 1.1 + +if {![package vsatisfies [package provide Tcl] 8.4]} {return} +package ifneeded http 2.7.12 [list tclPkgSetup $dir http 2.7.12 {{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 8329de4..8041ee4 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 bedc06e..071e6df 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.6.0 +package require -exact Tcl 8.5.14 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: @@ -77,7 +77,7 @@ namespace eval tcl { # TIP #255 min and max functions namespace eval mathfunc { proc min {args} { - if {![llength $args]} { + if {[llength $args] == 0} { return -code error \ "too few arguments to math function \"min\"" } @@ -88,12 +88,12 @@ namespace eval tcl { if {[catch {expr {double($arg)}} err]} { return -code error $err } - if {$arg < $val} {set val $arg} + if {$arg < $val} { set val $arg } } return $val } proc max {args} { - if {![llength $args]} { + if {[llength $args] == 0} { return -code error \ "too few arguments to math function \"max\"" } @@ -104,7 +104,7 @@ namespace eval tcl { if {[catch {expr {double($arg)}} err]} { return -code error $err } - if {$arg > $val} {set val $arg} + if {$arg > $val} { set val $arg } } return $val } @@ -179,9 +179,9 @@ if {[interp issafe]} { -subcommands { add clicks format microseconds milliseconds scan seconds }] - + # Auto-loading stubs for 'clock.tcl' - + foreach cmd {add format scan} { proc ::tcl::clock::$cmd args { variable TclLibDir @@ -218,9 +218,11 @@ if {[namespace which -command tclLog] eq ""} { # exist in the interpreter. It takes the following steps to make the # command available: # -# 1. See if the autoload facility can locate the command in a +# 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 # Tcl script file. If so, load it and execute it. -# 2. If the command was invoked interactively at top-level: +# 3. 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 @@ -237,27 +239,35 @@ proc unknown args { variable ::tcl::UnknownPending global auto_noexec auto_noload env tcl_interactive errorInfo errorCode - if {[info exists errorInfo]} { - set savedErrorInfo $errorInfo - } - if {[info exists errorCode]} { - set savedErrorCode $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 } - set name [lindex $args 0] + catch {set savedErrorInfo $errorInfo} + catch {set savedErrorCode $errorCode} + set name $cmd if {![info exists auto_noload]} { # # Make sure we're not trying to load the same proc twice. # if {[info exists UnknownPending($name)]} { return -code error "self-referential recursion\ - in \"unknown\" for command \"$name\"" + in \"unknown\" for command \"$name\""; } - set UnknownPending($name) pending + set UnknownPending($name) pending; set ret [catch { auto_load $name [uplevel 1 {::namespace current}] } msg opts] - unset UnknownPending($name) + unset UnknownPending($name); if {$ret != 0} { dict append opts -errorinfo "\n (autoloading \"$name\")" return -options $opts $msg @@ -280,7 +290,7 @@ proc unknown args { if {$code == 1} { # # Compute stack trace contribution from the [uplevel]. - # Note the dependence on how Tcl_AddErrorInfo, etc. + # Note the dependence on how Tcl_AddErrorInfo, etc. # construct the stack trace. # set errInfo [dict get $opts -errorinfo] @@ -411,7 +421,7 @@ proc unknown args { # library file to create the procedure. Returns 1 if it successfully # loaded the procedure, 0 otherwise. # -# Arguments: +# Arguments: # cmd - Name of the command to find and load. # namespace (optional) The namespace where the command is being used - must be # a canonical namespace as returned [namespace current] @@ -435,7 +445,7 @@ proc auto_load {cmd {namespace {}}} { # info commands $name # Unfortunately, if the name has glob-magic chars in it like * # or [], it may not match. For our purposes here, a better - # route is to use + # route is to use # namespace which -command $name if {[namespace which -command $name] ne ""} { return 1 @@ -466,7 +476,7 @@ proc auto_load {cmd {namespace {}}} { # of available commands. Returns 1 if the index is loaded, and 0 if # the index is already loaded and up to date. # -# Arguments: +# Arguments: # None. proc auto_load_index {} { @@ -545,34 +555,34 @@ proc auto_qualify {cmd namespace} { # Before each return case we give an example of which category it is # with the following form : - # (inputCmd, inputNameSpace) -> output + # ( inputCmd, inputNameSpace) -> output if {[string match ::* $cmd]} { if {$n > 1} { - # (::foo::bar , *) -> ::foo::bar + # ( ::foo::bar , * ) -> ::foo::bar return [list $cmd] } else { - # (::global , *) -> global + # ( ::global , * ) -> global return [list [string range $cmd 2 end]] } } - + # Potentially returning 2 elements to try : # (if the current namespace is not the global one) if {$n == 0} { if {$namespace eq "::"} { - # (nocolons , ::) -> nocolons + # ( nocolons , :: ) -> nocolons return [list $cmd] } else { - # (nocolons , ::sub) -> ::sub::nocolons nocolons + # ( nocolons , ::sub ) -> ::sub::nocolons nocolons return [list ${namespace}::$cmd $cmd] } } elseif {$namespace eq "::"} { - # (foo::bar , ::) -> ::foo::bar + # ( foo::bar , :: ) -> ::foo::bar return [list ::$cmd] } else { - # (foo::bar , ::sub) -> ::sub::foo::bar ::foo::bar + # ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar return [list ${namespace}::$cmd ::$cmd] } } @@ -614,13 +624,13 @@ proc auto_import {pattern} { # auto_execok -- # -# Returns string that indicates name of program to execute if +# Returns string that indicates name of program to execute if # name corresponds to a shell builtin or an executable in the -# Windows search path, or "" otherwise. Builds an associative -# array auto_execs that caches information about previous checks, +# Windows search path, or "" otherwise. Builds an associative +# array auto_execs that caches information about previous checks, # for speed. # -# Arguments: +# Arguments: # name - Name of a command. if {$tcl_platform(platform) eq "windows"} { @@ -675,7 +685,7 @@ proc auto_execok name { set path "[file dirname [info nameof]];.;" if {[info exists env(WINDIR)]} { - set windir $env(WINDIR) + set windir $env(WINDIR) } if {[info exists windir]} { if {$tcl_platform(os) eq "Windows NT"} { @@ -694,7 +704,7 @@ proc auto_execok name { unset -nocomplain checked foreach dir [split $path {;}] { # Skip already checked directories - if {[info exists checked($dir)] || ($dir eq "")} { + if {[info exists checked($dir)] || ($dir eq {})} { continue } set checked($dir) {} @@ -743,13 +753,13 @@ proc auto_execok name { # This procedure is called by Tcl's core when attempts to call the # filesystem's copydirectory function fail. The semantics of the call # are that 'dest' does not yet exist, i.e. dest should become the exact -# image of src. If dest does exist, we throw an error. -# +# image of src. If dest does exist, we throw an error. +# # Note that making changes to this procedure can change the results # of running Tcl's tests. # -# Arguments: -# action - "renaming" or "copying" +# Arguments: +# action - "renaming" or "copying" # src - source directory # dest - destination directory proc tcl::CopyDirectory {action src dest} { @@ -777,7 +787,7 @@ proc tcl::CopyDirectory {action src dest} { # exists, then we should only call this function if -force # is true, which means we just want to over-write. So, # the following code is now commented out. - # + # # return -code error "error $action \"$src\" to\ # \"$dest\": file already exists" } else { @@ -810,7 +820,7 @@ proc tcl::CopyDirectory {action src dest} { # Have to be careful to capture both visible and hidden files. # We will also be more generous to the file system and not # assume the hidden and non-hidden lists are non-overlapping. - # + # # On Unix 'hidden' files begin with '.'. On other platforms # or filesystems hidden files may have other interpretations. set filelist [concat [glob -nocomplain -directory $src *] \ diff --git a/library/opt/optparse.tcl b/library/opt/optparse.tcl index fc77fa1..c9438a0 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.6 +package provide opt 0.4.5 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 [string trimright [format "\n %-*s %-*s %-*s %s" \ + append res [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 107d4c6..c5d3635 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.6 [list source [file join $dir optparse.tcl]] +package ifneeded opt 0.4.5 [list source [file join $dir optparse.tcl]] diff --git a/library/package.tcl b/library/package.tcl index 52daa0e..06f619c 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"} { @@ -40,7 +40,7 @@ proc tcl::Pkg::CompareExtension {fileName {ext {}}} { set currExt [file extension $root] if {$currExt eq $ext} { return 1 - } + } # The current extension does not match; if it is not a numeric # value, quit, as we are only looking to ignore version number @@ -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,10 +57,11 @@ 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 @@ -81,7 +82,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} { @@ -127,21 +128,20 @@ proc pkg_mkIndex {args} { set dir [lindex $args $idx] set patternList [lrange $args [expr {$idx + 1}] end] - if {![llength $patternList]} { + if {[llength $patternList] == 0} { set patternList [list "*.tcl" "*[info sharedlibextension]"] } - try { - set fileList [glob -directory $dir -tails -types {r f} -- \ - {*}$patternList] - } on error {msg opt} { - return -options $opt $msg + if {[catch { + glob -directory $dir -tails -types {r f} -- {*}$patternList + } fileList o]} { + return -options $o $fileList } 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,23 +163,20 @@ 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'" } - try { + if {[catch { load [lindex $pkg 0] [lindex $pkg 1] $c - } on error err { + } err]} { if {$doVerbose} { - tclLog "warning: load [lindex $pkg 0]\ - [lindex $pkg 1]\nfailed with: $err" - } - } on ok {} { - if {$doVerbose} { - tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]" + tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err" } + } 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. @@ -188,25 +185,21 @@ 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} {} @@ -214,9 +207,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 @@ -237,22 +230,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]] } - try { + if {[catch { $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 @@ -274,17 +267,18 @@ 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] @@ -295,21 +289,22 @@ 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}::* } # Figure out what commands appeared - + foreach ::tcl::x [info commands] { set ::tcl::newCmds($::tcl::x) 1 } @@ -318,19 +313,18 @@ proc pkg_mkIndex {args} { } foreach ::tcl::x [array names ::tcl::newCmds] { # determine which namespace a command comes from - + 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] - + if {$::tcl::x ne $::tcl::abs} { # Name changed during qualification - + set ::tcl::newCmds($::tcl::abs) 1 unset ::tcl::newCmds($::tcl::x) } @@ -338,8 +332,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 "" @@ -349,12 +343,12 @@ proc pkg_mkIndex {args} { } } } - } on error msg { + } msg] == 1} { set what [$c eval set ::tcl::debug] if {$doVerbose} { tclLog "warning: error while $what $file: $msg" } - } on ok {} { + } else { set what [$c eval set ::tcl::debug] if {$doVerbose} { tclLog "successful $what of $file" @@ -363,7 +357,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" @@ -399,7 +393,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] @@ -414,10 +408,11 @@ 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. @@ -442,18 +437,18 @@ proc tclPkgSetup {dir pkg version files} { set auto_index($cmd) [list load [file join $dir $f] $pkg] } else { set auto_index($cmd) [list source [file join $dir $f]] - } + } } } } # 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. @@ -466,12 +461,12 @@ 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] - + # Make sure we only scan each directory one time. if {[info exists tclSeenPath($dir)]} { set use_path [lrange $use_path 0 end-1] @@ -479,22 +474,24 @@ 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)]} { - try { - source $file - } trap {POSIX EACCES} {} { + 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"} { # $file was not readable; silently ignore continue - } on error msg { + } + if {$code} { tclLog "error reading package index file $file: $msg" - } on ok {} { + } else { set procdDirs($dir) 1 } } @@ -503,16 +500,18 @@ proc tclPkgUnknown {name args} { set dir [lindex $use_path end] if {![info exists procdDirs($dir)]} { set file [file join $dir pkgIndex.tcl] - # safe interps usually don't have "file exists", + # safe interps usually don't have "file exists", if {([interp issafe] || [file exists $file])} { - try { - source $file - } trap {POSIX EACCES} {} { + 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"} { # $file was not readable; silently ignore continue - } on error msg { + } + if {$code} { tclLog "error reading package index file $file: $msg" - } on ok {} { + } else { set procdDirs($dir) 1 } } @@ -520,11 +519,12 @@ 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,6 +562,7 @@ 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] @@ -571,8 +572,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] @@ -589,25 +590,28 @@ proc tcl::MacOSXPkgUnknown {original name args} { * Resources Scripts pkgIndex.tcl] { set dir [file dirname $file] if {![info exists procdDirs($dir)]} { - try { - source $file - } trap {POSIX EACCES} {} { + 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"} { # $file was not readable; silently ignore continue - } on error msg { + } + if {$code} { tclLog "error reading package index file $file: $msg" - } on ok {} { + } else { 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 { @@ -619,11 +623,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 @@ -649,12 +653,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. @@ -672,10 +676,10 @@ proc ::tcl::Pkg::Create {args} { # process arguments set len [llength $args] - if {$len < 6} { + if { $len < 6 } { error $err(wrongNumArgs) } - + # Initialize parameters array set opts {-name {} -version {} -source {} -load {}} @@ -686,14 +690,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] @@ -705,20 +709,20 @@ proc ::tcl::Pkg::Create {args} { } # Validate the parameters - if {![llength $opts(-name)]} { + if { [llength $opts(-name)] == 0 } { error [format $err(valueMissing) "-name"] } - if {![llength $opts(-version)]} { + if { [llength $opts(-version)] == 0 } { error [format $err(valueMissing) "-version"] } - - if {!([llength $opts(-source)] || [llength $opts(-load)])} { + + if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } { error $err(noLoadOrSource) } # OK, now everything is good. Generate the package ifneeded statment. set cmdline "package ifneeded $opts(-name) $opts(-version) " - + set cmdList {} set lazyFileList {} @@ -736,7 +740,7 @@ proc ::tcl::Pkg::Create {args} { } } - if {[llength $lazyFileList]} { + if { [llength $lazyFileList] > 0 } { lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\ $opts(-version) [list $lazyFileList]\]" } @@ -744,4 +748,4 @@ proc ::tcl::Pkg::Create {args} { return $cmdline } -interp alias {} ::pkg::create {} ::tcl::Pkg::Create +interp alias {} ::pkg::create {} ::tcl::Pkg::Create diff --git a/library/platform/pkgIndex.tcl b/library/platform/pkgIndex.tcl index b882e4f..23a3408 100644 --- a/library/platform/pkgIndex.tcl +++ b/library/platform/pkgIndex.tcl @@ -1,3 +1,3 @@ -package ifneeded platform 1.0.11 [list source [file join $dir platform.tcl]] +package ifneeded platform 1.0.12 [list source [file join $dir platform.tcl]] package ifneeded platform::shell 1.1.4 [list source [file join $dir shell.tcl]] diff --git a/library/reg/pkgIndex.tcl b/library/reg/pkgIndex.tcl index 55af4b3..1241f2a 100755 --- a/library/reg/pkgIndex.tcl +++ b/library/reg/pkgIndex.tcl @@ -1,9 +1,9 @@ -if {([info commands ::tcl::pkgconfig] eq "") - || ([info sharedlibextension] ne ".dll")} return -if {[::tcl::pkgconfig get debug]} { - package ifneeded registry 1.3.0 \ - [list load [file join $dir tclreg13g.dll] registry] +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] } else { - package ifneeded registry 1.3.0 \ - [list load [file join $dir tclreg13.dll] registry] + package ifneeded registry 1.2.2 \ + [list load [file join $dir tclreg12.dll] registry] } diff --git a/library/safe.tcl b/library/safe.tcl index 394aa97..1a340a1 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -4,7 +4,7 @@ # It implements a virtual path mecanism to hide the real pathnames from the # slave. It runs in a master interpreter and sets up data structure and # aliases that will be invoked when used from a slave interpreter. -# +# # See the safe.n man page for details. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. @@ -36,7 +36,7 @@ proc ::safe::InterpStatics {} { upvar $v $v } set flag [::tcl::OptProcArgGiven -noStatics] - if {$flag && (!$noStatics == !$statics) + if {$flag && (!$noStatics == !$statics) && ([::tcl::OptProcArgGiven -statics])} { return -code error\ "conflicting values given for -statics and -noStatics" @@ -57,7 +57,7 @@ proc ::safe::InterpNested {} { set flag [::tcl::OptProcArgGiven -nestedLoadOk] # note that the test here is the opposite of the "InterpStatics" one # (it is not -noNested... because of the wanted default value) - if {$flag && (!$nestedLoadOk != !$nested) + if {$flag && (!$nestedLoadOk != !$nested) && ([::tcl::OptProcArgGiven -nested])} { return -code error\ "conflicting values given for -nested and -nestedLoadOk" @@ -151,18 +151,10 @@ 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* @@ -200,7 +192,7 @@ proc ::safe::interpConfigure {args} { if { ![::tcl::OptProcArgGiven -statics] && ![::tcl::OptProcArgGiven -noStatics] - } then { + } { set statics $state(staticsok) } else { set statics [InterpStatics] @@ -208,7 +200,7 @@ proc ::safe::interpConfigure {args} { if { [::tcl::OptProcArgGiven -nested] || [::tcl::OptProcArgGiven -nestedLoadOk] - } then { + } { set nested [InterpNested] } else { set nested $state(nestedok) @@ -246,7 +238,7 @@ proc ::safe::interpConfigure {args} { # # Returns the slave name. # -# Optional Arguments : +# Optional Arguments : # + slave name : if empty, generated name will be used # + access_path: path list controlling where load/source can occur, # if empty: the master auto_path will be used. @@ -257,7 +249,7 @@ proc ::safe::interpConfigure {args} { # use the full name and no indent so auto_mkIndex can find us proc ::safe::InterpCreate { - slave + slave access_path staticsok nestedok @@ -432,7 +424,7 @@ proc ::safe::interpAddToAccessPath {slave path} { # interpreter. It is useful when you want to install the safe base aliases # into a preexisting safe interpreter. proc ::safe::InterpInit { - slave + slave access_path staticsok nestedok @@ -465,19 +457,8 @@ proc ::safe::InterpInit { # This alias lets the slave have access to a subset of the 'file' # command functionality. - ::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 - } + AliasSubset $slave file \ + file dir.* join root.* ext.* tail path.* split # Subcommands of info foreach {subcommand alias} { @@ -494,16 +475,16 @@ proc ::safe::InterpInit { if {[catch {::interp eval $slave { source [file join $tcl_library init.tcl] - }} msg opt]} { + }} msg]} { Log $slave "can't source init.tcl ($msg)" - return -options $opt "can't source init.tcl into slave $slave ($msg)" + return -code error "can't source init.tcl into slave $slave ($msg)" } if {[catch {::interp eval $slave { source [file join $tcl_library tm.tcl] - }} msg opt]} { + }} msg]} { Log $slave "can't source tm.tcl ($msg)" - return -options $opt "can't source tm.tcl into slave $slave ($msg)" + return -code error "can't source tm.tcl into slave $slave ($msg)" } # Sync the paths used to search for Tcl modules. This can be done only @@ -557,9 +538,9 @@ proc ::safe::interpDelete {slave} { # remove the hook now, otherwise if the hook calls us somehow, # we'll loop unset state(cleanupHook) - try { + if {[catch { {*}$hook $slave - } on error err { + } err]} { Log $slave "Delete hook error ($err)" } } @@ -582,7 +563,7 @@ proc ::safe::interpDelete {slave} { return } -# Set (or get) the logging mecanism +# Set (or get) the logging mecanism proc ::safe::setLogCmd {args} { variable Log @@ -676,19 +657,7 @@ 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 {} @@ -752,12 +721,14 @@ 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)} { - try { + if {[catch { set dir [TranslatePath $slave $virtualdir] DirInAccessPath $slave $dir - } on error msg { + } msg]} { Log $slave $msg - if {$got(-nocomplain)} return + if {$got(-nocomplain)} { + return + } return -code error "permission denied" } lappend cmd -directory $dir @@ -773,27 +744,26 @@ 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 "*" && - ($thefile eq "pkgIndex.tcl" || $thefile eq "*.tm")} { + if {$thedir eq "*"} { set mapped 0 foreach d [glob -directory [TranslatePath $slave $virtualdir] \ -types d -tails *] { catch { DirInAccessPath $slave \ [TranslatePath $slave [file join $virtualdir $d]] - lappend cmd [file join $d $thefile] - set mapped 1 + if {$thefile eq "pkgIndex.tcl" || $thefile eq "*.tm"} { + lappend cmd [file join $d $thefile] + set mapped 1 + } } } if {$mapped} continue } - try { - DirInAccessPath $slave [TranslatePath $slave \ - [file join $virtualdir $thedir]] - } on error msg { + if {[catch { + set thedir [file join $virtualdir $thedir] + DirInAccessPath $slave [TranslatePath $slave $thedir] + } msg]} { Log $slave $msg if {$got(-nocomplain)} continue return -code error "permission denied" @@ -806,19 +776,19 @@ proc ::safe::AliasGlob {slave args} { if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} { return } - try { - set entries [::interp invokehidden $slave glob {*}$cmd] - } on error msg { + if {[catch { + ::interp invokehidden $slave glob {*}$cmd + } msg]} { Log $slave $msg return -code error "script error" } - Log $slave "GLOB < $entries" NOTICE + Log $slave "GLOB < $msg" NOTICE # Translate path back to what the slave should see. set res {} set l [string length $dir] - foreach p $entries { + foreach p $msg { if {[string equal -length $l $dir $p]} { set p [string replace $p 0 [expr {$l-1}] $virtualdir] } @@ -882,7 +852,6 @@ 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 @@ -892,17 +861,14 @@ 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 $replacementMsg + return -code error "script error" } return -code $code -options $opt $msg } @@ -952,28 +918,30 @@ proc ::safe::AliasLoad {slave file args} { # file loading # get the real path from the virtual one. - try { + if {[catch { set file [TranslatePath $slave $file] - } on error msg { + } msg]} { Log $slave $msg return -code error "permission denied" } # check the translated path - try { + if {[catch { FileInAccessPath $slave $file - } on error msg { + } msg]} { Log $slave $msg return -code error "permission denied (path)" } } - try { - return [::interp invokehidden $slave load $file $package $target] - } on error msg { + if {[catch { + ::interp invokehidden $slave load $file $package $target + } msg]} { Log $slave $msg return -code error $msg } + + return $msg } # FileInAccessPath raises an error if the file is not found in the list of @@ -1018,33 +986,59 @@ proc ::safe::DirInAccessPath {slave dir} { } } -# This procedure is used to report an attempt to use an unsafe member of an -# ensemble command. +# This procedure enables access from a safe interpreter to only a subset +# of the subcommands of a command: -proc ::safe::BadSubcommand {slave command subcommand args} { +proc ::safe::Subset {slave command okpat args} { + set subcommand [lindex $args 0] + if {[regexp $okpat $subcommand]} { + return [$command {*}$args] + } set msg "not allowed to invoke subcommand $subcommand of $command" Log $slave $msg - return -code error -errorcode {TCL SAFE SUBCOMMAND} $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 } # AliasEncoding is the target of the "encoding" alias in safe interpreters. proc ::safe::AliasEncoding {slave option args} { - # 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\"" + # 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 } - } on error {msg options} { - Log $slave $msg - return -options $options $msg + 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] } - tailcall ::interp invokehidden $slave encoding $option {*}$args + Log $slave $msg + return -code error -errorcode $code $msg } # Various minor hiding of platform features. [Bug 2913625] diff --git a/library/tclIndex b/library/tclIndex index 26603c1..010616f 100644 --- a/library/tclIndex +++ b/library/tclIndex @@ -1,5 +1,4 @@ # 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 @@ -49,15 +48,29 @@ 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]] @@ -69,7 +82,6 @@ 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/tm.tcl b/library/tm.tcl index d2af4f5..baa268d 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -1,44 +1,48 @@ # -*- 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. @@ -67,43 +71,46 @@ 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 {args} { +proc ::tcl::tm::add {path 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 $args { + foreach p [linsert $args 0 $path] { 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. @@ -112,9 +119,10 @@ proc ::tcl::tm::add {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]} { @@ -126,23 +134,24 @@ proc ::tcl::tm::add {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 {args} { +proc ::tcl::tm::remove {path 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 $args { + foreach p [linsert $args 0 $path] { set pos [lsearch -exact $paths $p] if {$pos >= 0} { set paths [lreplace $paths $pos $pos] @@ -168,26 +177,27 @@ 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. - # Import the pattern used to check package names in detail. + # Import the pattern used to check package names in detail. 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] @@ -196,10 +206,11 @@ 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 { @@ -212,11 +223,12 @@ 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 @@ -226,48 +238,48 @@ 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 } - try { - package vcompare $pkgversion 0 - } on error {} { - # Ignore everything where the version part is not - # acceptable to "package vcompare". + if {[catch {package vcompare $pkgversion 0}]} { + # Ignore everything where the version part is + # not acceptable to "package vcompare". 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. } } } @@ -278,8 +290,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] @@ -350,17 +362,17 @@ proc ::tcl::tm::roots {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 } |