summaryrefslogtreecommitdiffstats
path: root/library
diff options
context:
space:
mode:
Diffstat (limited to 'library')
-rw-r--r--library/auto.tcl351
-rw-r--r--library/clock.tcl1122
-rw-r--r--library/dde/pkgIndex.tcl10
-rw-r--r--library/history.tcl302
-rw-r--r--library/http/http.tcl282
-rw-r--r--library/http/pkgIndex.tcl6
-rw-r--r--library/http1.0/http.tcl6
-rw-r--r--library/init.tcl37
-rw-r--r--library/opt/optparse.tcl474
-rw-r--r--library/opt/pkgIndex.tcl2
-rw-r--r--library/package.tcl312
-rwxr-xr-xlibrary/reg/pkgIndex.tcl14
-rw-r--r--library/safe.tcl194
-rw-r--r--library/tclIndex20
-rw-r--r--library/tm.tcl230
15 files changed, 1605 insertions, 1757 deletions
diff --git a/library/auto.tcl b/library/auto.tcl
index f7cf5f0..02edcc4 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]]
- } else {
- if {[info library] ni $auto_path} {
- lappend auto_path [info library]
- }
+ } elseif {[info library] ni $auto_path} {
+ lappend auto_path [info library]
}
}
# tcl_findLibrary --
#
# This is a utility for extensions that searches for a library directory
-# using a canonical searching algorithm. A side effect is to source
-# the initialization script and set a global library variable.
+# using a canonical searching algorithm. A side effect is to source the
+# initialization script and set a global library variable.
#
# Arguments:
# basename Prefix of the directory name, (e.g., "tk")
@@ -64,24 +64,21 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
if {[info exists the_library] && $the_library ne ""} {
lappend dirs $the_library
} else {
-
# Do the canonical search
- # 1. From an environment variable, if it exists.
- # Placing this first gives the end-user ultimate control
- # to work-around any bugs, or to customize.
+ # 1. From an environment variable, if it exists. Placing this first
+ # gives the end-user ultimate control to work-around any bugs, or
+ # to customize.
if {[info exists env($enVarName)]} {
lappend dirs $env($enVarName)
}
- # 2. In the package script directory registered within
- # the configuration of the package itself.
+ # 2. In the package script directory registered within the
+ # configuration of the package itself.
- if {[catch {
- ::${basename}::pkgconfig get scriptdir,runtime
- } value] == 0} {
- lappend dirs $value
+ catch {
+ lappend dirs [::${basename}::pkgconfig get scriptdir,runtime]
}
# 3. Relative to auto_path directories. This checks relative to the
@@ -101,8 +98,8 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
# ../../lib/foo1.0 (From bin/arch directory in install hierarchy)
# ../library (From unix directory in build hierarchy)
#
- # Remaining locations are out of date (when relevant, they ought
- # to be covered by the $::auto_path seach above) and disabled.
+ # Remaining locations are out of date (when relevant, they ought to be
+ # covered by the $::auto_path seach above) and disabled.
#
# ../../library (From unix/arch directory in build hierarchy)
# ../../foo1.0.1/library
@@ -125,17 +122,19 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
# uniquify $dirs in order
array set seen {}
foreach i $dirs {
- # Take note that the [file normalize] below has been noted to
- # cause difficulties for the freewrap utility. See Bug 1072136.
- # Until freewrap resolves the matter, one might work around the
- # problem by disabling that branch.
+ # Take note that the [file normalize] below has been noted to cause
+ # difficulties for the freewrap utility. See Bug 1072136. Until
+ # freewrap resolves the matter, one might work around the problem by
+ # disabling that branch.
if {[interp issafe]} {
set norm $i
} else {
set norm [file normalize $i]
}
- if {[info exists seen($norm)]} { continue }
- set seen($norm) ""
+ if {[info exists seen($norm)]} {
+ continue
+ }
+ set seen($norm) {}
lappend uniqdirs $i
}
set dirs $uniqdirs
@@ -143,16 +142,15 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
set the_library $i
set file [file join $i $initScript]
- # source everything when in a safe interpreter because
- # we have a source command, but no file exists command
+ # source everything when in a safe interpreter because we have a
+ # source command, but no file exists command
if {[interp issafe] || [file exists $file]} {
if {![catch {uplevel #0 [list source $file]} msg opts]} {
return
- } else {
- append errors "$file: $msg\n"
- append errors [dict get $opts -errorinfo]\n
}
+ append errors "$file: $msg\n"
+ append errors [dict get $opts -errorinfo]\n
}
}
unset -nocomplain the_library
@@ -167,28 +165,28 @@ proc tcl_findLibrary {basename version patch initScript enVarName varName} {
# ----------------------------------------------------------------------
# auto_mkindex
# ----------------------------------------------------------------------
-# The following procedures are used to generate the tclIndex file
-# from Tcl source files. They use a special safe interpreter to
-# parse Tcl source files, writing out index entries as "proc"
-# commands are encountered. This implementation won't work in a
-# safe interpreter, since a safe interpreter can't create the
-# special parser and mess with its commands.
+# The following procedures are used to generate the tclIndex file from Tcl
+# source files. They use a special safe interpreter to parse Tcl source
+# files, writing out index entries as "proc" commands are encountered. This
+# implementation won't work in a safe interpreter, since a safe interpreter
+# can't create the special parser and mess with its commands.
if {[interp issafe]} {
return ;# Stop sourcing the file here
}
# auto_mkindex --
-# Regenerate a tclIndex file from Tcl source files. Takes as argument
-# the name of the directory in which the tclIndex file is to be placed,
-# followed by any number of glob patterns to use in that directory to
-# locate all of the relevant files.
+# Regenerate a tclIndex file from Tcl source files. Takes as argument the
+# name of the directory in which the tclIndex file is to be placed, followed
+# by any number of glob patterns to use in that directory to locate all of the
+# relevant files.
#
-# Arguments:
+# Arguments:
# dir - Name of the directory in which to create an index.
-# args - Any number of additional arguments giving the
-# names of files within dir. If no additional
-# are given auto_mkindex will look for *.tcl.
+
+# args - Any number of additional arguments giving the names of files
+# within dir. If no additional are given auto_mkindex will look
+# for *.tcl.
proc auto_mkindex {dir args} {
if {[interp issafe]} {
@@ -197,7 +195,6 @@ proc auto_mkindex {dir args} {
set oldDir [pwd]
cd $dir
- set dir [pwd]
append index "# Tcl autoload index file, version 2.0\n"
append index "# This file is generated by the \"auto_mkindex\" command\n"
@@ -206,18 +203,18 @@ proc auto_mkindex {dir args} {
append index "# sets an element in the auto_index array, where the\n"
append index "# element name is the name of a command and the value is\n"
append index "# a script that loads the command.\n\n"
- if {[llength $args] == 0} {
+ if {![llength $args]} {
set args *.tcl
}
auto_mkindex_parser::init
foreach file [glob -- {*}$args] {
- if {[catch {auto_mkindex_parser::mkindex $file} msg opts] == 0} {
- append index $msg
- } else {
- cd $oldDir
+ try {
+ append index [auto_mkindex_parser::mkindex $file]
+ } on error {msg opts} {
+ cd $oldDir
return -options $opts $msg
- }
+ }
}
auto_mkindex_parser::cleanup
@@ -227,8 +224,8 @@ proc auto_mkindex {dir args} {
cd $oldDir
}
-# Original version of auto_mkindex that just searches the source
-# code for "proc" at the beginning of the line.
+# Original version of auto_mkindex that just searches the source code for
+# "proc" at the beginning of the line.
proc auto_mkindex_old {dir args} {
set oldDir [pwd]
@@ -241,7 +238,7 @@ proc auto_mkindex_old {dir args} {
append index "# sets an element in the auto_index array, where the\n"
append index "# element name is the name of a command and the value is\n"
append index "# a script that loads the command.\n\n"
- if {[llength $args] == 0} {
+ if {![llength $args]} {
set args *.tcl
}
foreach file [glob -- {*}$args] {
@@ -279,9 +276,9 @@ proc auto_mkindex_old {dir args} {
}
# Create a safe interpreter that can be used to parse Tcl source files
-# generate a tclIndex file for autoloading. This interp contains
-# commands for things that need index entries. Each time a command
-# is executed, it writes an entry out to the index file.
+# generate a tclIndex file for autoloading. This interp contains commands for
+# things that need index entries. Each time a command is executed, it writes
+# an entry out to the index file.
namespace eval auto_mkindex_parser {
variable parser "" ;# parser used to build index
@@ -306,7 +303,14 @@ namespace eval auto_mkindex_parser {
$parser hide namespace
$parser hide eval
$parser hide puts
- $parser invokehidden namespace delete ::
+ foreach ns [$parser invokehidden namespace children ::] {
+ # MUST NOT DELETE "::tcl" OR BAD THINGS HAPPEN!
+ if {$ns eq "::tcl"} continue
+ $parser invokehidden namespace delete $ns
+ }
+ foreach cmd [$parser invokehidden info commands ::*] {
+ $parser invokehidden rename $cmd {}
+ }
$parser invokehidden proc unknown {args} {}
# We'll need access to the "namespace" command within the
@@ -333,12 +337,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} {
@@ -354,14 +358,13 @@ proc auto_mkindex_parser::mkindex {file} {
set contents [read $fid]
close $fid
- # There is one problem with sourcing files into the safe
- # interpreter: references like "$x" will fail since code is not
- # really being executed and variables do not really exist.
- # To avoid this, we replace all $ with \0 (literally, the null char)
- # later, when getting proc names we will have to reverse this replacement,
- # in case there were any $ in the proc name. This will cause a problem
- # if somebody actually tries to have a \0 in their proc name. Too bad
- # for them.
+ # There is one problem with sourcing files into the safe interpreter:
+ # references like "$x" will fail since code is not really being executed
+ # and variables do not really exist. To avoid this, we replace all $ with
+ # \0 (literally, the null char) later, when getting proc names we will
+ # have to reverse this replacement, in case there were any $ in the proc
+ # name. This will cause a problem if somebody actually tries to have a \0
+ # in their proc name. Too bad for them.
set contents [string map [list \$ \0] $contents]
set index ""
@@ -378,10 +381,10 @@ proc auto_mkindex_parser::mkindex {file} {
# auto_mkindex_parser::hook command
#
-# Registers a Tcl command to evaluate when initializing the
-# slave interpreter used by the mkindex parser.
-# The command is evaluated in the master interpreter, and can
-# use the variable auto_mkindex_parser::parser to get to the slave
+# Registers a Tcl command to evaluate when initializing the slave interpreter
+# used by the mkindex parser. The command is evaluated in the master
+# interpreter, and can use the variable auto_mkindex_parser::parser to get to
+# the slave
proc auto_mkindex_parser::hook {cmd} {
variable initCommands
@@ -391,30 +394,30 @@ proc auto_mkindex_parser::hook {cmd} {
# auto_mkindex_parser::slavehook command
#
-# Registers a Tcl command to evaluate when initializing the
-# slave interpreter used by the mkindex parser.
-# The command is evaluated in the slave interpreter.
+# Registers a Tcl command to evaluate when initializing the slave interpreter
+# used by the mkindex parser. The command is evaluated in the slave
+# interpreter.
proc auto_mkindex_parser::slavehook {cmd} {
variable initCommands
- # The $parser variable is defined to be the name of the
- # slave interpreter when this command is used later.
+ # The $parser variable is defined to be the name of the slave interpreter
+ # when this command is used later.
lappend initCommands "\$parser eval [list $cmd]"
}
# auto_mkindex_parser::command --
#
-# Registers a new command with the "auto_mkindex_parser" interpreter
-# that parses Tcl files. These commands are fake versions of things
-# like the "proc" command. When you execute them, they simply write
-# out an entry to a "tclIndex" file for auto-loading.
+# Registers a new command with the "auto_mkindex_parser" interpreter that
+# parses Tcl files. These commands are fake versions of things like the
+# "proc" command. When you execute them, they simply write out an entry to a
+# "tclIndex" file for auto-loading.
#
-# This procedure allows extensions to register their own commands
-# with the auto_mkindex facility. For example, a package like
-# [incr Tcl] might register a "class" command so that class definitions
-# could be added to a "tclIndex" file for auto-loading.
+# This procedure allows extensions to register their own commands with the
+# auto_mkindex facility. For example, a package like [incr Tcl] might
+# register a "class" command so that class definitions could be added to a
+# "tclIndex" file for auto-loading.
#
# Arguments:
# name Name of command recognized in Tcl files.
@@ -427,8 +430,8 @@ proc auto_mkindex_parser::command {name arglist body} {
# auto_mkindex_parser::commandInit --
#
-# This does the actual work set up by auto_mkindex_parser::command
-# This is called when the interpreter used by the parser is created.
+# This does the actual work set up by auto_mkindex_parser::command. This is
+# called when the interpreter used by the parser is created.
#
# Arguments:
# name Name of command recognized in Tcl files.
@@ -447,25 +450,23 @@ proc auto_mkindex_parser::commandInit {name arglist body} {
}
proc $fakeName $arglist $body
- # YUK! Tcl won't let us alias fully qualified command names,
- # so we can't handle names like "::itcl::class". Instead,
- # we have to build procs with the fully qualified names, and
- # have the procs point to the aliases.
+ # YUK! Tcl won't let us alias fully qualified command names, so we can't
+ # handle names like "::itcl::class". Instead, we have to build procs with
+ # the fully qualified names, and have the procs point to the aliases.
if {[string match *::* $name]} {
set exportCmd [list _%@namespace export [namespace tail $name]]
$parser eval [list _%@namespace eval $ns $exportCmd]
-
- # The following proc definition does not work if you
- # want to tolerate space or something else diabolical
- # in the procedure name, (i.e., space in $alias)
- # The following does not work:
+
+ # The following proc definition does not work if you want to tolerate
+ # space or something else diabolical in the procedure name, (i.e.,
+ # space in $alias). The following does not work:
# "_%@eval {$alias} \$args"
- # because $alias gets concat'ed to $args.
- # The following does not work because $cmd is somehow undefined
+ # because $alias gets concat'ed to $args. The following does not work
+ # because $cmd is somehow undefined
# "set cmd {$alias} \; _%@eval {\$cmd} \$args"
- # A gold star to someone that can make test
- # autoMkindex-3.3 work properly
+ # A gold star to someone that can make test autoMkindex-3.3 work
+ # properly
set alias [namespace tail $fakeName]
$parser invokehidden proc $name {args} "_%@eval {$alias} \$args"
@@ -477,15 +478,14 @@ proc auto_mkindex_parser::commandInit {name arglist body} {
}
# auto_mkindex_parser::fullname --
-# Used by commands like "proc" within the auto_mkindex parser.
-# Returns the qualified namespace name for the "name" argument.
-# If the "name" does not start with "::", elements are added from
-# the current namespace stack to produce a qualified name. Then,
-# the name is examined to see whether or not it should really be
-# qualified. If the name has more than the leading "::", it is
-# returned as a fully qualified name. Otherwise, it is returned
-# as a simple name. That way, the Tcl autoloader will recognize
-# it properly.
+#
+# Used by commands like "proc" within the auto_mkindex parser. Returns the
+# qualified namespace name for the "name" argument. If the "name" does not
+# start with "::", elements are added from the current namespace stack to
+# produce a qualified name. Then, the name is examined to see whether or not
+# it should really be qualified. If the name has more than the leading "::",
+# it is returned as a fully qualified name. Otherwise, it is returned as a
+# simple name. That way, the Tcl autoloader will recognize it properly.
#
# Arguments:
# name - Name that is being added to index.
@@ -508,44 +508,65 @@ proc auto_mkindex_parser::fullname {name} {
set name "::$name"
}
- # Earlier, mkindex replaced all $'s with \0. Now, we have to reverse
- # that replacement.
+ # Earlier, mkindex replaced all $'s with \0. Now, we have to reverse that
+ # replacement.
return [string map [list \0 \$] $name]
}
+# auto_mkindex_parser::indexEntry --
+#
+# Used by commands like "proc" within the auto_mkindex parser to add a
+# correctly-quoted entry to the index. This is shared code so it is done
+# *right*, in one place.
+#
+# Arguments:
+# name - Name that is being added to index.
+
+proc auto_mkindex_parser::indexEntry {name} {
+ variable index
+ variable scriptFile
+
+ # We convert all metacharacters to their backslashed form, and pre-split
+ # the file name that we know about (which will be a proper list, and so
+ # correctly quoted).
+
+ set name [string range [list \}[fullname $name]] 2 end]
+ set filenameParts [file split $scriptFile]
+
+ append index [format \
+ {set auto_index(%s) [list source [file join $dir %s]]%s} \
+ $name $filenameParts \n]
+ return
+}
+
if {[llength $::auto_mkindex_parser::initCommands]} {
return
}
-# Register all of the procedures for the auto_mkindex parser that
-# will build the "tclIndex" file.
+# Register all of the procedures for the auto_mkindex parser that will build
+# the "tclIndex" file.
# AUTO MKINDEX: proc name arglist body
# Adds an entry to the auto index list for the given procedure name.
auto_mkindex_parser::command proc {name args} {
- variable index
- variable scriptFile
- # Do some fancy reformatting on the "source" call to handle platform
- # differences with respect to pathnames. Use format just so that the
- # command is a little easier to read (otherwise it'd be full of
- # backslashed dollar signs, etc.
- append index [list set auto_index([fullname $name])] \
- [format { [list source [file join $dir %s]]} \
- [file split $scriptFile]] "\n"
+ indexEntry $name
}
-# Conditionally add support for Tcl byte code files. There are some
-# tricky details here. First, we need to get the tbcload library
-# initialized in the current interpreter. We cannot load tbcload into the
-# slave until we have done so because it needs access to the tcl_patchLevel
-# variable. Second, because the package index file may defer loading the
-# library until we invoke a command, we need to explicitly invoke auto_load
-# to force it to be loaded. This should be a noop if the package has
-# already been loaded
+# Conditionally add support for Tcl byte code files. There are some tricky
+# details here. First, we need to get the tbcload library initialized in the
+# current interpreter. We cannot load tbcload into the slave until we have
+# done so because it needs access to the tcl_patchLevel variable. Second,
+# because the package index file may defer loading the library until we invoke
+# a command, we need to explicitly invoke auto_load to force it to be loaded.
+# This should be a noop if the package has already been loaded
auto_mkindex_parser::hook {
- if {![catch {package require tbcload}]} {
+ try {
+ package require tbcload
+ } on error {} {
+ # OK, don't have it so do nothing
+ } on ok {} {
if {[namespace which -command tbcload::bcproc] eq ""} {
auto_load tbcload::bcproc
}
@@ -553,32 +574,24 @@ 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
- variable scriptFile
- # Do some nice reformatting of the "source" call, to get around
- # path differences on different platforms. We use the format
- # command just so that the code is a little easier to read.
- append index [list set auto_index([fullname $name])] \
- [format { [list source [file join $dir %s]]} \
- [file split $scriptFile]] "\n"
+ indexEntry $name
}
}
}
# AUTO MKINDEX: namespace eval name command ?arg arg...?
-# Adds the namespace name onto the context stack and evaluates the
-# associated body of commands.
+# Adds the namespace name onto the context stack and evaluates the associated
+# body of commands.
#
# AUTO MKINDEX: namespace import ?-force? pattern ?pattern...?
-# Performs the "import" action in the parser interpreter. This is
-# important for any commands contained in a namespace that affect
-# the index. For example, a script may say "itcl::class ...",
-# or it may import "itcl::*" and then say "class ...". This
-# procedure does the import operation, but keeps track of imported
-# patterns so we can remove the imports later.
+# Performs the "import" action in the parser interpreter. This is important
+# for any commands contained in a namespace that affect the index. For
+# example, a script may say "itcl::class ...", or it may import "itcl::*" and
+# then say "class ...". This procedure does the import operation, but keeps
+# track of imported patterns so we can remove the imports later.
auto_mkindex_parser::command namespace {op args} {
switch -- $op {
@@ -608,6 +621,13 @@ auto_mkindex_parser::command namespace {op args} {
variable contextStack
if {[lindex $args 0] eq "create"} {
set name ::[join [lreverse $contextStack] ::]
+ catch {
+ set name [dict get [lrange $args 1 end] -command]
+ if {![string match ::* $name]} {
+ set name ::[join [lreverse $contextStack] ::]$name
+ }
+ regsub -all ::+ $name :: name
+ }
# create artifical proc to force an entry in the tclIndex
$parser eval [list ::proc $name {} {}]
}
@@ -615,4 +635,17 @@ auto_mkindex_parser::command namespace {op args} {
}
}
+# AUTO MKINDEX: oo::class create name ?definition?
+# Adds an entry to the auto index list for the given class name.
+auto_mkindex_parser::command oo::class {op name {body ""}} {
+ if {$op eq "create"} {
+ indexEntry $name
+ }
+}
+auto_mkindex_parser::command class {op name {body ""}} {
+ if {$op eq "create"} {
+ indexEntry $name
+ }
+}
+
return
diff --git a/library/clock.tcl b/library/clock.tcl
index 1f83716..67d15b1 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,9 +27,8 @@ uplevel \#0 {
}
}
-# Put the library directory into the namespace for the ensemble
-# so that the library code can find message catalogs and time zone
-# definition files.
+# Put the library directory into the namespace for the ensemble so that the
+# library code can find message catalogs and time zone definition files.
namespace eval ::tcl::clock \
[list variable LibDir [file dirname [info script]]]
@@ -40,10 +39,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 {
@@ -76,11 +75,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.
#
#----------------------------------------------------------------------
@@ -172,8 +171,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
@@ -189,13 +188,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
@@ -217,23 +216,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 {
@@ -282,10 +281,10 @@ proc ::tcl::clock::Initialize {} {
variable FEB_28 58
- # Translation table to map Windows TZI onto cities, so that
- # the Olson rules can apply. In some cases the mapping is ambiguous,
- # so it's wise to specify $::env(TCL_TZ) rather than simply depending
- # on the system time zone.
+ # Translation table to map Windows TZI onto cities, so that the Olson
+ # rules can apply. In some cases the mapping is ambiguous, so it's wise
+ # to specify $::env(TCL_TZ) rather than simply depending on the system
+ # time zone.
# The keys are long lists of values obtained from the time zone
# information in the Registry. In order, the list elements are:
@@ -296,10 +295,10 @@ proc ::tcl::clock::Initialize {} {
# DaylightDate.wYear DaylightDate.wMonth DaylightDate.wDayOfWeek
# DaylightDate.wDay DaylightDate.wHour DaylightDate.wMinute
# DaylightDate.wSecond DaylightDate.wMilliseconds
- # The values are the names of time zones where those rules apply.
- # There is considerable ambiguity in certain zones; an attempt has
- # been made to make a reasonable guess, but this table needs to be
- # taken with a grain of salt.
+ # The values are the names of time zones where those rules apply. There
+ # is considerable ambiguity in certain zones; an attempt has been made to
+ # make a reasonable guess, but this table needs to be taken with a grain
+ # of salt.
variable WinZoneInfo [dict create {*}{
{-43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Kwajalein
@@ -378,10 +377,10 @@ proc ::tcl::clock::Initialize {} {
{46800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Tongatapu
}]
- # Groups of fields that specify the date, priorities, and
- # code bursts that determine Julian Day Number given those groups.
- # The code in [clock scan] will choose the highest priority
- # (lowest numbered) set of fields that determines the date.
+ # Groups of fields that specify the date, priorities, and code bursts that
+ # determine Julian Day Number given those groups. The code in [clock
+ # scan] will choose the highest priority (lowest numbered) set of fields
+ # that determines the date.
variable DateParseActions {
@@ -485,8 +484,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 {
@@ -652,16 +651,14 @@ 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
@@ -670,7 +667,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]
}
@@ -680,11 +677,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)]} {
@@ -693,9 +690,8 @@ proc ::tcl::clock::format { args } {
set FormatProc($procName) \
[ParseClockFormatFormat $procName $format $locale]
}
-
- return [$procName $clockval $timezone]
+ return [$procName $clockval $timezone]
}
#----------------------------------------------------------------------
@@ -714,45 +710,31 @@ 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.
- set status [catch {
-
- ParseClockFormatFormat2 $format $locale $procName
-
- } result opts]
-
- # Restore the locale
-
- if { [info exists oldLocale] } {
- mclocale $oldLocale
- }
-
- # Return either the error or the proc name
+ try {
+ return [ParseClockFormatFormat2 $format $locale $procName]
+ } trap CLOCK {result opts} {
+ dict unset opts -errorinfo
+ return -options $opts $result
+ } finally {
+ # Restore the locale
- if { $status == 1 } {
- if { [lindex [dict get $opts -errorcode] 0] eq {clock} } {
- return -code error $result
- } else {
- return -options $opts $result
+ if { [info exists oldLocale] } {
+ mclocale $oldLocale
}
- } else {
- return $result
}
-
}
proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} {
-
set didLocaleEra 0
set didLocaleNumerals 0
set preFormatCode \
@@ -767,7 +749,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} {
set formatString {}
set substituents {}
set state {}
-
+
set format [LocalizeFormat $locale $format]
foreach char [split $format {}] {
@@ -794,7 +776,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 \
@@ -895,7 +877,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 }]}
}
@@ -916,7 +898,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 }]}
}
@@ -957,7 +939,7 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} {
{ [expr {(([dict get $date localSeconds]
% 86400) < 43200) ?
$am : $pm}]}
-
+
}
Q { # Hi, Jeff!
append formatString %s
@@ -967,11 +949,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
@@ -992,7 +974,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 }]
}
@@ -1015,7 +997,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
@@ -1084,7 +1066,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 \
@@ -1096,7 +1078,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 }]]}
}
@@ -1122,7 +1104,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 }]]}
}
@@ -1131,7 +1113,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)
@@ -1162,9 +1144,9 @@ proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} {
}
}
}
-
+
# Clean up any improperly terminated groups
-
+
switch -exact -- $state {
percent {
append formatString %%
@@ -1191,16 +1173,14 @@ 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
@@ -1247,8 +1227,8 @@ proc ::tcl::clock::scan { args } {
}
default {
return -code error \
- -errorcode [list CLOCK badSwitch $flag] \
- "bad switch \"$flag\",\
+ -errorcode [list CLOCK badOption $flag] \
+ "bad option \"$flag\",\
must be -base, -format, -gmt, -locale or -timezone"
}
}
@@ -1262,21 +1242,17 @@ proc ::tcl::clock::scan { args } {
"cannot use -gmt and -timezone in same call"
}
if { [catch { expr { wide($base) } } result] } {
- return -code error \
- "expected integer but got \"$base\""
+ return -code error "expected integer but got \"$base\""
}
- if { ![string is boolean $gmt] } {
- return -code error \
- "expected boolean value but got \"$gmt\""
- } else {
- if { $gmt } {
- set timezone :GMT
- }
+ if { ![string is boolean -strict $gmt] } {
+ return -code error "expected boolean value but got \"$gmt\""
+ } elseif { $gmt } {
+ set timezone :GMT
}
if { ![info exists saw(-format)] } {
- # Perhaps someday we'll localize the legacy code. Right now,
- # it's not localized.
+ # Perhaps someday we'll localize the legacy code. Right now, it's not
+ # localized.
if { [info exists saw(-locale)] } {
return -code error \
-errorcode [list CLOCK flagWithLegacyFormat] \
@@ -1290,31 +1266,23 @@ proc ::tcl::clock::scan { args } {
EnterLocale $locale oldLocale
- set status [catch {
-
+ try {
# Map away the locale-dependent composite format groups
set scanner [ParseClockScanFormat $format $locale]
- $scanner $string $base $timezone
-
- } result opts]
-
- # Restore the locale
+ return [$scanner $string $base $timezone]
+ } trap CLOCK {result opts} {
+ # Conceal location of generation of expected errors
- if { [info exists oldLocale] } {
- mclocale $oldLocale
- }
+ dict unset opts -errorinfo
+ return -options $opts $result
+ } finally {
+ # Restore the locale
- if { $status == 1 } {
- if { [lindex [dict get $opts -errorcode] 0] eq {clock} } {
- return -code error $result
- } else {
- return -options $opts $result
+ if { [info exists oldLocale] } {
+ mclocale $oldLocale
}
- } else {
- return $result
}
-
}
#----------------------------------------------------------------------
@@ -1330,52 +1298,50 @@ 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
-
- if {[catch {SetupTimeZone $timezone} retval opts]} {
+
+ try {
+ SetupTimeZone $timezone
+ } on error {retval opts} {
dict unset opts -errorinfo
return -options $opts $retval
}
- # Extract year, month and day from the base time for the
- # parser to use as defaults
-
- set date [GetDateFields \
- $base \
- $TZData($timezone) \
- 2361222]
- dict set date secondOfDay [expr { [dict get $date localSeconds]
- % 86400 }]
+ # Extract year, month and day from the base time for the parser to use as
+ # defaults
- # Parse the date. The parser will return a list comprising
- # date, time, time zone, relative month/day/seconds, relative
- # weekday, ordinal month.
+ set date [GetDateFields $base $TZData($timezone) 2361222]
+ dict set date secondOfDay [expr {
+ [dict get $date localSeconds] % 86400
+ }]
- set status [catch {
- Oldscan $string \
- [dict get $date year] \
- [dict get $date month] \
- [dict get $date dayOfMonth]
- } result]
- if { $status != 0 } {
- return -code error "unable to convert date-time string \"$string\": $result"
+ # Parse the date. The parser will return a list comprising date, time,
+ # time zone, relative month/day/seconds, relative weekday, ordinal month.
+
+ try {
+ set scanned [Oldscan $string \
+ [dict get $date year] \
+ [dict get $date month] \
+ [dict get $date dayOfMonth]]
+ lassign $scanned \
+ parseDate parseTime parseZone parseRel \
+ parseWeekday parseOrdinalMonth
+ } on error message {
+ return -code error \
+ "unable to convert date-time string \"$string\": $message"
}
- lassign $result parseDate parseTime parseZone parseRel \
- parseWeekday parseOrdinalMonth
-
- # If the caller supplied a date in the string, update the 'date' dict
- # with the value. If the caller didn't specify a time with the date,
- # default to midnight.
+ # If the caller supplied a date in the string, update the 'date' dict with
+ # the value. If the caller didn't specify a time with the date, default to
+ # midnight.
if { [llength $parseDate] > 0 } {
lassign $parseDate y m d
@@ -1395,12 +1361,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 \
@@ -1414,18 +1380,19 @@ 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]
@@ -1437,18 +1404,17 @@ 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 } {
+ if { [llength $parseWeekday] > 0 } {
lassign $parseWeekday dayOrdinal dayOfWeek
set date2 [GetDateFields $seconds $TZData($timezone) 2361222]
dict set date2 era CE
- set jdwkday [WeekdayOnOrBefore $dayOfWeek \
- [expr { [dict get $date2 julianDay]
- + 6 }]]
+ set jdwkday [WeekdayOnOrBefore $dayOfWeek [expr {
+ [dict get $date2 julianDay] + 6
+ }]]
incr jdwkday [expr { 7 * $dayOrdinal }]
if { $dayOrdinal > 0 } {
incr jdwkday -7
@@ -1456,21 +1422,20 @@ 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] }]
@@ -1487,7 +1452,6 @@ proc ::tcl::clock::FreeScan { string base timezone locale } {
}
set seconds [add $seconds $monthOrdinal years $monthDiff months \
-timezone $timezone -locale $locale]
-
}
return $seconds
@@ -1505,30 +1469,27 @@ proc ::tcl::clock::FreeScan { string base timezone locale } {
# locale - The current locale
#
# Results:
-# Constructs and returns a procedure that accepts the
-# string being scanned, the base time, and the time zone.
-# The procedure will either return the scanned time or
-# else throw an error that should be rethrown to the caller
-# of [clock scan]
+# Constructs and returns a procedure that accepts the string being
+# scanned, the base time, and the time zone. The procedure will either
+# return the scanned time or else throw an error that should be rethrown
+# to the caller of [clock scan]
#
# Side effects:
-# The given procedure is defined in the ::tcl::clock
-# namespace. Scan procedures are not deleted once installed.
-#
-# Why do we parse dates by defining a procedure to parse them?
-# The reason is that by doing so, we have one convenient place to
-# cache all the information: the regular expressions that match the
-# patterns (which will be compiled), the code that assembles the
-# date information, everything lands in one place. In this way,
-# when a given format is reused at run time, all the information
+# The given procedure is defined in the ::tcl::clock namespace. Scan
+# procedures are not deleted once installed.
+#
+# Why do we parse dates by defining a procedure to parse them? The reason is
+# that by doing so, we have one convenient place to cache all the information:
+# the regular expressions that match the patterns (which will be compiled),
+# the code that assembles the date information, everything lands in one place.
+# In this way, when a given format is reused at run time, all the information
# of how to apply it is available in a single place.
#
#----------------------------------------------------------------------
proc ::tcl::clock::ParseClockScanFormat {formatString locale} {
-
- # Check whether the format has been parsed previously, and return
- # the existing recognizer if it has.
+ # Check whether the format has been parsed previously, and return the
+ # existing recognizer if it has.
set procName scanproc'$formatString'$locale
set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName]
@@ -1572,8 +1533,8 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} {
append re {[[:space:]]+}
} else {
if { ! [string is alnum $c] } {
- append re \\
- }
+ append re "\\"
+ }
append re $c
}
}
@@ -1690,7 +1651,7 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} {
"::scan \$field" [incr captureCount] " %ld" \
"\]\n"
}
- m - N { # Month number
+ m - N { # Month number
append re \\s*(\\d\\d?)
dict set fieldSet month [incr fieldCount]
append postcode "dict set date month \[" \
@@ -1733,10 +1694,9 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} {
\] \n
}
s { # Seconds from Posix Epoch
- # This next case is insanely difficult,
- # because it's problematic to determine
- # whether the field is actually within
- # the range of a wide integer.
+ # This next case is insanely difficult, because it's
+ # problematic to determine whether the field is
+ # actually within the range of a wide integer.
append re {\s*([-+]?\d+)}
dict set fieldSet seconds [incr fieldCount]
append postcode {dict set date seconds } \[ \
@@ -1769,14 +1729,13 @@ 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 \[" \
@@ -1948,7 +1907,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
@@ -1994,10 +1953,11 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} {
append procBody $postcode
append procBody [list set changeover [mc GREGORIAN_CHANGE_DATE]] \n
- # Get time zone if needed
+ # Set up the time zone before doing anything with a default base date
+ # that might need a timezone to interpret it.
- if { ![dict exists $fieldSet seconds]
- && ![dict exists $fieldSet starDate] } {
+ if { ![dict exists $fieldSet seconds]
+ && ![dict exists $fieldSet starDate] } {
if { [dict exists $fieldSet tzName] } {
append procBody {
set timeZone [dict get $date tzName]
@@ -2016,24 +1976,29 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} {
append procBody [MakeParseCodeFromFields $fieldSet $TimeParseActions]
- # Assemble seconds, and convert local nominal time to UTC.
+ # Assemble seconds from the Julian day and second of the day.
+ # Convert to local time unless epoch seconds or stardate are
+ # being processed - they're always absolute
- if { ![dict exists $fieldSet seconds]
+ 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]
}
}
@@ -2047,20 +2012,19 @@ 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.
@@ -2068,7 +2032,6 @@ proc ::tcl::clock::ParseClockScanFormat {formatString locale} {
#----------------------------------------------------------------------
proc ::tcl::clock::LocaleNumeralMatcher {l} {
-
variable LocaleNumeralCache
if { ![dict exists $LocaleNumeralCache $l] } {
@@ -2087,16 +2050,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.
@@ -2104,10 +2067,10 @@ proc ::tcl::clock::LocaleNumeralMatcher {l} {
# distinct.
#
# Results:
-# Returns a two-element list. The first is a regexp that
-# matches any unique prefix of any of the strings. The second
-# is a dictionary whose keys are match values from the regexp
-# and whose values are the corresponding values from 'data'.
+# Returns a two-element list. The first is a regexp that matches any
+# unique prefix of any of the strings. The second is a dictionary whose
+# keys are match values from the regexp and whose values are the
+# corresponding values from 'data'.
#
# Side effects:
# None.
@@ -2115,11 +2078,10 @@ proc ::tcl::clock::LocaleNumeralMatcher {l} {
#----------------------------------------------------------------------
proc ::tcl::clock::UniquePrefixRegexp { data } {
-
- # The 'successors' dictionary will contain, for each string that
- # is a prefix of any key, all characters that may follow that
- # prefix. The 'prefixMapping' dictionary will have keys that
- # are prefixes of keys and values that correspond to the keys.
+ # The 'successors' dictionary will contain, for each string that is a
+ # prefix of any key, all characters that may follow that prefix. The
+ # 'prefixMapping' dictionary will have keys that are prefixes of keys and
+ # values that correspond to the keys.
set prefixMapping [dict create]
set successors [dict create {} {}]
@@ -2127,8 +2089,7 @@ 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 {}] {
@@ -2146,8 +2107,8 @@ proc ::tcl::clock::UniquePrefixRegexp { data } {
}
}
- # Identify those prefixes that designate unique values, and
- # those that are the full keys
+ # Identify those prefixes that designate unique values, and those that are
+ # the full keys
set uniquePrefixMapping {}
dict for { key valueList } $prefixMapping {
@@ -2170,8 +2131,8 @@ proc ::tcl::clock::UniquePrefixRegexp { data } {
#
# MakeUniquePrefixRegexp --
#
-# Service procedure for 'UniquePrefixRegexp' that constructs
-# a regular expresison that matches the unique prefixes.
+# Service procedure for 'UniquePrefixRegexp' that constructs a regular
+# expresison that matches the unique prefixes.
#
# Parameters:
# successors - Dictionary whose keys are all prefixes
@@ -2183,18 +2144,17 @@ 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]]]
@@ -2202,13 +2162,15 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors
return {}
}
- # If there is more than one successor character, or if the current
- # prefix is a unique prefix, surround the generated re with non-capturing
+ # If there is more than one successor character, or if the current prefix
+ # is a unique prefix, surround the generated re with non-capturing
# parentheses.
set re {}
- if { [dict exists $uniquePrefixMapping $prefixString]
- || [llength $schars] > 1 } {
+ if {
+ [dict exists $uniquePrefixMapping $prefixString]
+ || [llength $schars] > 1
+ } then {
append re "(?:"
}
@@ -2230,7 +2192,7 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors
if { [dict exists $uniquePrefixMapping $prefixString] } {
append re ")?"
- } elseif { [llength $schars] > 1 } {
+ } elseif { [llength $schars] > 1 } {
append re ")"
}
@@ -2241,8 +2203,8 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors
#
# MakeParseCodeFromFields --
#
-# Composes Tcl code to extract the Julian Day Number from a
-# dictionary containing date fields.
+# Composes Tcl code to extract the Julian Day Number from a dictionary
+# containing date fields.
#
# Parameters:
# dateFields -- Dictionary whose keys are fields of the date,
@@ -2253,8 +2215,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.
@@ -2262,7 +2224,6 @@ proc ::tcl::clock::MakeUniquePrefixRegexp { successors
#----------------------------------------------------------------------
proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } {
-
set currPrio 999
set currFieldPos [list]
set currCodeBurst {
@@ -2270,16 +2231,15 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } {
}
foreach { fieldSet prio parseAction } $parseActions {
-
- # If we've found an answer that's better than any that follow,
- # quit now.
+ # If we've found an answer that's better than any that follow, quit
+ # now.
if { $prio > $currPrio } {
break
}
- # Accumulate the field positions that are used in the current
- # field grouping.
+ # Accumulate the field positions that are used in the current field
+ # grouping.
set fieldPos [list]
set ok true
@@ -2302,9 +2262,11 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } {
if { $prio == $currPrio } {
foreach currPos $currFieldPos newPos $fPos {
- if { ![string is integer $newPos]
- || ![string is integer $currPos]
- || $newPos > $currPos } {
+ if {
+ ![string is integer $newPos]
+ || ![string is integer $currPos]
+ || $newPos > $currPos
+ } then {
break
}
if { $newPos < $currPos } {
@@ -2322,11 +2284,9 @@ proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } {
set currPrio $prio
set currFieldPos $fPos
set currCodeBurst $parseAction
-
}
return $currCodeBurst
-
}
#----------------------------------------------------------------------
@@ -2344,14 +2304,13 @@ 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
@@ -2359,27 +2318,24 @@ 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] } {
@@ -2400,15 +2356,14 @@ 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
@@ -2420,14 +2375,12 @@ proc ::tcl::clock::EnterLocale { locale oldLocaleVar } {
# Side effects:
# Updates the given message catalog with the locale strings.
#
-# Presumes that on entry, [mclocale] is set to the current locale,
-# so that default strings can be obtained if the Registry query
-# fails.
+# Presumes that on entry, [mclocale] is set to the current locale, so that
+# default strings can be obtained if the Registry query fails.
#
#----------------------------------------------------------------------
proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } {
-
# Bail out if we can't find the Registry
variable NoRegistry
@@ -2529,7 +2482,6 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } {
}
return
-
}
#----------------------------------------------------------------------
@@ -2544,8 +2496,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.
@@ -2553,7 +2505,6 @@ proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } {
#----------------------------------------------------------------------
proc ::tcl::clock::LocalizeFormat { locale format } {
-
variable McLoaded
if { [dict exists $McLoaded $locale FORMAT $format] } {
@@ -2565,7 +2516,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
@@ -2582,7 +2533,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
}
@@ -2605,7 +2556,6 @@ proc ::tcl::clock::LocalizeFormat { locale format } {
#----------------------------------------------------------------------
proc ::tcl::clock::FormatNumericTimeZone { z } {
-
if { $z < 0 } {
set z [expr { - $z }]
set retval -
@@ -2620,7 +2570,6 @@ proc ::tcl::clock::FormatNumericTimeZone { z } {
append retval [::format %02d $z]
}
return $retval
-
}
#----------------------------------------------------------------------
@@ -2645,7 +2594,6 @@ proc ::tcl::clock::FormatNumericTimeZone { z } {
#----------------------------------------------------------------------
proc ::tcl::clock::FormatStarDate { date } {
-
variable Roddenberry
# Get day of year, zero based
@@ -2696,7 +2644,6 @@ proc ::tcl::clock::FormatStarDate { date } {
#----------------------------------------------------------------------
proc ::tcl::clock::ParseStarDate { year fractYear fractDay } {
-
variable Roddenberry
# Build a tentative date from year and fraction.
@@ -2712,8 +2659,8 @@ proc ::tcl::clock::ParseStarDate { year fractYear fractDay } {
set lp [IsGregorianLeapYear $date]
- # Reconvert the fractional year according to whether the given
- # year is a leap year
+ # Reconvert the fractional year according to whether the given year is a
+ # leap year
if { $lp } {
dict set date dayOfYear \
@@ -2726,10 +2673,11 @@ proc ::tcl::clock::ParseStarDate { year fractYear fractDay } {
dict unset date gregorian
set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]]
- return [expr { 86400 * [dict get $date julianDay]
- - 210866803200
- + ( 86400 / 10 ) * $fractDay }]
-
+ return [expr {
+ 86400 * [dict get $date julianDay]
+ - 210866803200
+ + ( 86400 / 10 ) * $fractDay
+ }]
}
#----------------------------------------------------------------------
@@ -2742,8 +2690,8 @@ proc ::tcl::clock::ParseStarDate { year fractYear fractDay } {
# str - String containing a decimal wide integer
#
# Results:
-# Returns the string as a pure wide integer. Throws an error if
-# the string is misformatted or out of range.
+# Returns the string as a pure wide integer. Throws an error if the
+# string is misformatted or out of range.
#
#----------------------------------------------------------------------
@@ -2764,8 +2712,8 @@ proc ::tcl::clock::ScanWide { str } {
#
# InterpretTwoDigitYear --
#
-# Given a date that contains only the year of the century,
-# determines the target value of a two-digit year.
+# Given a date that contains only the year of the century, determines
+# the target value of a two-digit year.
#
# Parameters:
# date - Dictionary containing fields of the date.
@@ -2782,18 +2730,17 @@ proc ::tcl::clock::ScanWide { str } {
# Side effects:
# None.
#
-# The current rule for interpreting a two-digit year is that the year
-# shall be between 1937 and 2037, thus staying within the range of a
-# 32-bit signed value for time. This rule may change to a sliding
-# window in future versions, so the 'baseTime' parameter (which is
-# currently ignored) is provided in the procedure signature.
+# The current rule for interpreting a two-digit year is that the year shall be
+# between 1937 and 2037, thus staying within the range of a 32-bit signed
+# value for time. This rule may change to a sliding window in future
+# versions, so the 'baseTime' parameter (which is currently ignored) is
+# provided in the procedure signature.
#
#----------------------------------------------------------------------
-proc ::tcl::clock::InterpretTwoDigitYear { date baseTime
+proc ::tcl::clock::InterpretTwoDigitYear { date baseTime
{ twoDigitField yearOfCentury }
{ fourDigitField year } } {
-
set yr [dict get $date $twoDigitField]
if { $yr <= 37 } {
dict set date $fourDigitField [expr { $yr + 2000 }]
@@ -2801,7 +2748,6 @@ proc ::tcl::clock::InterpretTwoDigitYear { date baseTime
dict set date $fourDigitField [expr { $yr + 1900 }]
}
return $date
-
}
#----------------------------------------------------------------------
@@ -2827,7 +2773,6 @@ proc ::tcl::clock::InterpretTwoDigitYear { date baseTime
#----------------------------------------------------------------------
proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } {
-
variable TZData
# Find the Julian Day Number corresponding to the base time, and
@@ -2841,7 +2786,6 @@ proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } {
dict set date year [dict get $date2 year]
return $date
-
}
#----------------------------------------------------------------------
@@ -2868,7 +2812,6 @@ proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } {
#----------------------------------------------------------------------
proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} {
-
variable TZData
# Find the Julian Day Number corresponding to the base time
@@ -2886,7 +2829,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:
@@ -2905,7 +2848,6 @@ proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} {
#----------------------------------------------------------------------
proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} {
-
variable TZData
# Find the year and month corresponding to the base time
@@ -2915,7 +2857,6 @@ proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} {
dict set date year [dict get $date2 year]
dict set date month [dict get $date2 month]
return $date
-
}
#----------------------------------------------------------------------
@@ -2941,7 +2882,6 @@ proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} {
#----------------------------------------------------------------------
proc ::tcl::clock::AssignBaseWeek {date baseTime timeZone changeover} {
-
variable TZData
# Find the Julian Day Number corresponding to the base time
@@ -2978,7 +2918,6 @@ proc ::tcl::clock::AssignBaseWeek {date baseTime timeZone changeover} {
#----------------------------------------------------------------------
proc ::tcl::clock::AssignBaseJulianDay { date baseTime timeZone changeover } {
-
variable TZData
# Find the Julian Day Number corresponding to the base time
@@ -3008,7 +2947,6 @@ proc ::tcl::clock::AssignBaseJulianDay { date baseTime timeZone changeover } {
#----------------------------------------------------------------------
proc ::tcl::clock::InterpretHMSP { date } {
-
set hr [dict get $date hourAMPM]
if { $hr == 12 } {
set hr 0
@@ -3018,7 +2956,6 @@ proc ::tcl::clock::InterpretHMSP { date } {
}
dict set date hour $hr
return [InterpretHMS $date[set date {}]]
-
}
#----------------------------------------------------------------------
@@ -3041,11 +2978,11 @@ proc ::tcl::clock::InterpretHMSP { date } {
#----------------------------------------------------------------------
proc ::tcl::clock::InterpretHMS { date } {
-
- return [expr { ( [dict get $date hour] * 60
- + [dict get $date minute] ) * 60
- + [dict get $date second] }]
-
+ return [expr {
+ ( [dict get $date hour] * 60
+ + [dict get $date minute] ) * 60
+ + [dict get $date second]
+ }]
}
#----------------------------------------------------------------------
@@ -3068,7 +3005,6 @@ proc ::tcl::clock::InterpretHMS { date } {
#----------------------------------------------------------------------
proc ::tcl::clock::GetSystemTimeZone {} {
-
variable CachedSystemTimeZone
variable TimeZoneBad
@@ -3101,76 +3037,69 @@ proc ::tcl::clock::GetSystemTimeZone {} {
} else {
return $timezone
}
-
}
#----------------------------------------------------------------------
#
# ConvertLegacyTimeZone --
#
-# Given an alphanumeric time zone identifier and the system
-# time zone, convert the alphanumeric identifier to an
-# unambiguous time zone.
+# Given an alphanumeric time zone identifier and the system time zone,
+# convert the alphanumeric identifier to an unambiguous time zone.
#
# Parameters:
# tzname - Name of the time zone to convert
#
# Results:
-# Returns a time zone name corresponding to tzname, but
-# in an unambiguous form, generally +hhmm.
+# Returns a time zone name corresponding to tzname, but in an
+# unambiguous form, generally +hhmm.
#
-# This procedure is implemented primarily to allow the parsing of
-# RFC822 date/time strings. Processing a time zone name on input
-# is not recommended practice, because there is considerable room
-# for ambiguity; for instance, is BST Brazilian Standard Time, or
-# British Summer Time?
+# This procedure is implemented primarily to allow the parsing of RFC822
+# date/time strings. Processing a time zone name on input is not recommended
+# practice, because there is considerable room for ambiguity; for instance, is
+# BST Brazilian Standard Time, or British Summer Time?
#
#----------------------------------------------------------------------
proc ::tcl::clock::ConvertLegacyTimeZone { tzname } {
-
variable LegacyTimeZone
set tzname [string tolower $tzname]
if { ![dict exists $LegacyTimeZone $tzname] } {
return -code error -errorcode [list CLOCK badTZName $tzname] \
"time zone \"$tzname\" not found"
- } else {
- return [dict get $LegacyTimeZone $tzname]
}
-
+ return [dict get $LegacyTimeZone $tzname]
}
#----------------------------------------------------------------------
#
# SetupTimeZone --
#
-# Given the name or specification of a time zone, sets up
-# its in-memory data.
+# Given the name or specification of a time zone, sets up its in-memory
+# data.
#
# Parameters:
# tzname - Name of a time zone
#
# Results:
-# Unless the time zone is ':localtime', sets the TZData array
-# to contain the lookup table for local<->UTC conversion.
-# Returns an error if the time zone cannot be parsed.
+# Unless the time zone is ':localtime', sets the TZData array to contain
+# the lookup table for local<->UTC conversion. Returns an error if the
+# time zone cannot be parsed.
#
#----------------------------------------------------------------------
proc ::tcl::clock::SetupTimeZone { timezone } {
-
variable TZData
if {! [info exists TZData($timezone)] } {
variable MINWIDE
if { $timezone eq {:localtime} } {
-
# Nothing to do, we'll convert using the localtime function
- } elseif { [regexp {^([-+])(\d\d)(?::?(\d\d)(?::?(\d\d))?)?} $timezone \
- -> s hh mm ss] } {
-
+ } elseif {
+ [regexp {^([-+])(\d\d)(?::?(\d\d)(?::?(\d\d))?)?} $timezone \
+ -> s hh mm ss]
+ } then {
# Make a fixed offset
::scan $hh %d hh
@@ -3191,24 +3120,21 @@ 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] } {
@@ -3221,9 +3147,8 @@ proc ::tcl::clock::SetupTimeZone { timezone } {
}
} else {
-
- # We couldn't parse this as a POSIX time zone. Try
- # again with a time zone file - this time without a colon
+ # We couldn't parse this as a POSIX time zone. Try again with a
+ # time zone file - this time without a colon
if { [catch { LoadTimeZoneFile $timezone }]
&& [catch { LoadZoneinfoFile $timezone } - opts] } {
@@ -3247,25 +3172,22 @@ proc ::tcl::clock::SetupTimeZone { timezone } {
# None.
#
# Results:
-# Returns a time zone specifier that corresponds to the system
-# time zone information found in the Registry.
+# Returns a time zone specifier that corresponds to the system time zone
+# information found in the Registry.
#
# Bugs:
-# Fixed dates for DST change are unimplemented at present, because
-# no time zone information supplied with Windows actually uses
-# them!
+# Fixed dates for DST change are unimplemented at present, because no
+# time zone information supplied with Windows actually uses them!
#
-# On a Windows system where neither $env(TCL_TZ) nor $env(TZ) is
-# specified, GuessWindowsTimeZone looks in the Registry for the
-# system time zone information. It then attempts to find an entry
-# in WinZoneInfo for a time zone that uses the same rules. If
-# it finds one, it returns it; otherwise, it constructs a Posix-style
-# time zone string and returns that.
+# On a Windows system where neither $env(TCL_TZ) nor $env(TZ) is specified,
+# GuessWindowsTimeZone looks in the Registry for the system time zone
+# information. It then attempts to find an entry in WinZoneInfo for a time
+# zone that uses the same rules. If it finds one, it returns it; otherwise,
+# it constructs a Posix-style time zone string and returns that.
#
#----------------------------------------------------------------------
proc ::tcl::clock::GuessWindowsTimeZone {} {
-
variable WinZoneInfo
variable NoRegistry
variable TimeZoneBad
@@ -3296,16 +3218,14 @@ proc ::tcl::clock::GuessWindowsTimeZone {} {
lappend data $val
}
}] } {
-
# Missing values in the Registry - bail out
return :localtime
}
- # Make up a Posix time zone specifier if we can't find one.
- # Check here that the tzdata file exists, in case we're running
- # in an environment (e.g. starpack) where tzdata is incomplete.
- # (Bug 1237907)
+ # Make up a Posix time zone specifier if we can't find one. Check here
+ # that the tzdata file exists, in case we're running in an environment
+ # (e.g. starpack) where tzdata is incomplete. (Bug 1237907)
if { [dict exists $WinZoneInfo $data] } {
set tzname [dict get $WinZoneInfo $data]
@@ -3353,11 +3273,11 @@ proc ::tcl::clock::GuessWindowsTimeZone {} {
if { $dstYear == 0 } {
append tzname ,M $dstMonth . $dstDayOfMonth . $dstDayOfWeek
} else {
- # I have not been able to find any locale on which
- # Windows converts time zone on a fixed day of the year,
- # hence don't know how to interpret the fields.
- # If someone can inform me, I'd be glad to code it up.
- # For right now, we bail out in such a case.
+ # I have not been able to find any locale on which Windows
+ # converts time zone on a fixed day of the year, hence don't
+ # know how to interpret the fields. If someone can inform me,
+ # I'd be glad to code it up. For right now, we bail out in
+ # such a case.
return :localtime
}
append tzname / [::format %02d $dstHour] \
@@ -3366,11 +3286,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] \
@@ -3378,10 +3298,9 @@ proc ::tcl::clock::GuessWindowsTimeZone {} {
: [::format %02d $stdSecond]
}
dict set WinZoneInfo $data $tzname
- }
+ }
return [dict get $WinZoneInfo $data]
-
}
#----------------------------------------------------------------------
@@ -3410,18 +3329,18 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } {
return
}
- # Since an unsafe interp uses the [clock] command in the master,
- # this code is security sensitive. Make sure that the path name
- # cannot escape the given directory.
+ # Since an unsafe interp uses the [clock] command in the master, this code
+ # is security sensitive. Make sure that the path name cannot escape the
+ # given directory.
if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } {
return -code error \
-errorcode [list CLOCK badTimeZone $:fileName] \
"time zone \":$fileName\" not valid"
}
- if { [catch {
+ try {
source -encoding utf-8 [file join $DataDir $fileName]
- }] } {
+ } on error {} {
return -code error \
-errorcode [list CLOCK badTimeZone :$fileName] \
"time zone \":$fileName\" not found"
@@ -3439,8 +3358,8 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } {
# fileName - Relative path name of the file to load.
#
# Results:
-# Returns an empty result normally; returns an error if no
-# Olson file was found or the file was malformed in some way.
+# Returns an empty result normally; returns an error if no Olson file
+# was found or the file was malformed in some way.
#
# Side effects:
# TZData(:fileName) contains the time zone data
@@ -3448,12 +3367,11 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } {
#----------------------------------------------------------------------
proc ::tcl::clock::LoadZoneinfoFile { fileName } {
-
variable ZoneinfoPaths
- # Since an unsafe interp uses the [clock] command in the master,
- # this code is security sensitive. Make sure that the path name
- # cannot escape the given directory.
+ # Since an unsafe interp uses the [clock] command in the master, this code
+ # is security sensitive. Make sure that the path name cannot escape the
+ # given directory.
if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } {
return -code error \
@@ -3482,15 +3400,14 @@ proc ::tcl::clock::LoadZoneinfoFile { fileName } {
# fname - Absolute path name of the file.
#
# Results:
-# Returns an empty result normally; returns an error if no
-# Olson file was found or the file was malformed in some way.
+# Returns an empty result normally; returns an error if no Olson file
+# was found or the file was malformed in some way.
#
# Side effects:
# TZData(:fileName) contains the time zone data
#
#----------------------------------------------------------------------
-
proc ::tcl::clock::ReadZoneinfoFile {fileName fname} {
variable MINWIDE
variable TZData
@@ -3509,8 +3426,8 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} {
set d [read $f]
close $f
- # The file begins with a magic number, sixteen reserved bytes,
- # and then six 4-byte integers giving counts of fileds in the file.
+ # The file begins with a magic number, sixteen reserved bytes, and then
+ # six 4-byte integers giving counts of fileds in the file.
binary scan $d a4a1x15IIIIII \
magic version nIsGMT nIsStd nLeap nTime nType nChar
@@ -3528,18 +3445,19 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} {
return -code error "$fileName contains leap seconds"
}
- # In a version 2 file, we use the second part of the file, which
- # contains 64-bit transition times.
+ # In a version 2 file, we use the second part of the file, which contains
+ # 64-bit transition times.
if {$version eq "2"} {
- set seek [expr {44
- + 5 * $nTime
- + 6 * $nType
- + 4 * $nLeap
- + $nIsStd
- + $nIsGMT
- + $nChar
- }]
+ set seek [expr {
+ 44
+ + 5 * $nTime
+ + 6 * $nType
+ + 4 * $nLeap
+ + $nIsStd
+ + $nIsGMT
+ + $nChar
+ }]
binary scan $d @${seek}a4a1x15IIIIII \
magic version nIsGMT nIsStd nLeap nTime nType nChar
if {$magic ne {TZif}} {
@@ -3563,9 +3481,9 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} {
}
set codes [linsert $codes 0 0]
- # Next come ${nType} time type descriptions, each of which has an
- # offset (seconds east of GMT), a DST indicator, and an index into
- # the abbreviation text.
+ # Next come ${nType} time type descriptions, each of which has an offset
+ # (seconds east of GMT), a DST indicator, and an index into the
+ # abbreviation text.
for { set i 0 } { $i < $nType } { incr i } {
binary scan $d @${seek}Icc gmtOff isDst abbrInd
@@ -3573,10 +3491,10 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} {
incr seek 6
}
- # Next come $nChar characters of time zone name abbreviations,
- # which are null-terminated.
- # We build them up into a dictionary indexed by character index,
- # because that's what's in the indices above.
+ # Next come $nChar characters of time zone name abbreviations, which are
+ # null-terminated.
+ # We build them up into a dictionary indexed by character index, because
+ # that's what's in the indices above.
binary scan $d @${seek}a${nChar} abbrs
incr seek ${nChar}
@@ -3606,8 +3524,8 @@ proc ::tcl::clock::ReadZoneinfoFile {fileName fname} {
}
# In a version 2 file, there is also a POSIX-style time zone description
- # at the very end of the file. To get to it, skip over
- # nLeap leap second values (8 bytes each),
+ # at the very end of the file. To get to it, skip over nLeap leap second
+ # values (8 bytes each),
# nIsStd standard/DST indicators and nIsGMT UTC/local indicators.
if {$version eq {2}} {
@@ -3640,8 +3558,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.
@@ -3652,7 +3570,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
@@ -3697,14 +3615,13 @@ 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
@@ -3715,8 +3632,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} )
)?
@@ -3732,8 +3649,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})
)?
@@ -3746,8 +3663,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:]] + )
)
(?:
@@ -3768,8 +3685,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:]] + )
)
(?:
@@ -3796,27 +3713,21 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } {
x(endJ) x(endDayOfYear) \
x(endMonth) x(endWeekOfMonth) x(endDayOfWeek) \
x(endHours) x(endMinutes) x(endSeconds)] } {
-
# it's a good timezone
return [array get x]
-
- } else {
-
- return -code error\
- -errorcode [list CLOCK badTimeZone $tz] \
- "unable to parse time zone specification \"$tz\""
-
}
+ return -code error\
+ -errorcode [list CLOCK badTimeZone $tz] \
+ "unable to parse time zone specification \"$tz\""
}
#----------------------------------------------------------------------
#
# ProcessPosixTimeZone --
#
-# Handle a Posix time zone after it's been broken out into
-# fields.
+# Handle a Posix time zone after it's been broken out into fields.
#
# Parameters:
# z - Dictionary returned from 'ParsePosixTimeZone'
@@ -3830,7 +3741,6 @@ proc ::tcl::clock::ParsePosixTimeZone { tz } {
#----------------------------------------------------------------------
proc ::tcl::clock::ProcessPosixTimeZone { z } {
-
variable MINWIDE
variable TZData
@@ -3845,20 +3755,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
@@ -3881,20 +3791,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
@@ -3903,8 +3813,10 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } {
# US end time is the first Sunday in November.
# EU end time is the last Sunday in October
- if { [dict get $z startDayOfYear] eq {}
- && [dict get $z startMonth] eq {} } {
+ if {
+ [dict get $z startDayOfYear] eq {}
+ && [dict get $z startMonth] eq {}
+ } then {
if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} {
# EU
dict set z startWeekOfMonth 5
@@ -3923,8 +3835,10 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } {
dict set z startMinutes 0
dict set z startSeconds 0
}
- if { [dict get $z endDayOfYear] eq {}
- && [dict get $z endMonth] eq {} } {
+ if {
+ [dict get $z endDayOfYear] eq {}
+ && [dict get $z endMonth] eq {}
+ } then {
if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} {
# EU
dict set z endMonth 10
@@ -3964,15 +3878,14 @@ proc ::tcl::clock::ProcessPosixTimeZone { z } {
}
return $data
-
-}
+}
#----------------------------------------------------------------------
#
# DeterminePosixDSTTime --
#
-# Determines the time that Daylight Saving Time starts or ends
-# from a Posix time zone specification.
+# Determines the time that Daylight Saving Time starts or ends from a
+# Posix time zone specification.
#
# Parameters:
# z - Time zone data returned from ParsePosixTimeZone.
@@ -3982,13 +3895,12 @@ 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
@@ -3996,18 +3908,16 @@ 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]
@@ -4022,8 +3932,9 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } {
}
set jd [dict get $date julianDay]
- set seconds [expr { wide($jd) * wide(86400)
- - wide(210866803200) }]
+ set seconds [expr {
+ wide($jd) * wide(86400) - wide(210866803200)
+ }]
set h [dict get $z ${bound}Hours]
if { $h eq {} } {
@@ -4045,7 +3956,6 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } {
}
set tod [expr { ( $h * 60 + $m ) * 60 + $s }]
return [expr { $seconds + $tod }]
-
}
#----------------------------------------------------------------------
@@ -4063,26 +3973,26 @@ proc ::tcl::clock::DeterminePosixDSTTime { z bound y } {
# for the target locale.
#
# Results:
-# Returns the dictionary, augmented with the keys, 'localeEra'
-# and 'localeYear'.
+# Returns the dictionary, augmented with the keys, 'localeEra' and
+# 'localeYear'.
#
#----------------------------------------------------------------------
proc ::tcl::clock::GetLocaleEra { date etable } {
-
set index [BSearch $etable [dict get $date localSeconds]]
if { $index < 0} {
dict set date localeEra \
[::format %02d [expr { [dict get $date year] / 100 }]]
- dict set date localeYear \
- [expr { [dict get $date year] % 100 }]
+ dict set date localeYear [expr {
+ [dict get $date year] % 100
+ }]
} else {
dict set date localeEra [lindex $etable $index 1]
- dict set date localeYear [expr { [dict get $date year]
- - [lindex $etable $index 2] }]
+ dict set date localeYear [expr {
+ [dict get $date year] - [lindex $etable $index 2]
+ }]
}
return $date
-
}
#----------------------------------------------------------------------
@@ -4100,10 +4010,9 @@ proc ::tcl::clock::GetLocaleEra { date etable } {
# adopted in the current locale.
#
# Results:
-# Returns the given dictionary augmented with a 'julianDay' key
-# whose value is the desired Julian Day Number, and a 'gregorian'
-# key that specifies whether the calendar is Gregorian (1) or
-# Julian (0).
+# Returns the given dictionary augmented with a 'julianDay' key whose
+# value is the desired Julian Day Number, and a 'gregorian' key that
+# specifies whether the calendar is Gregorian (1) or Julian (0).
#
# Side effects:
# None.
@@ -4114,7 +4023,6 @@ proc ::tcl::clock::GetLocaleEra { date etable } {
#----------------------------------------------------------------------
proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} {
-
# Get absolute year number from the civil year
switch -exact -- [dict get $date era] {
@@ -4130,21 +4038,25 @@ proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} {
# Try the Gregorian calendar first.
dict set date gregorian 1
- set jd [expr { 1721425
- + [dict get $date dayOfYear]
- + ( 365 * $ym1 )
- + ( $ym1 / 4 )
- - ( $ym1 / 100 )
- + ( $ym1 / 400 ) }]
-
+ set jd [expr {
+ 1721425
+ + [dict get $date dayOfYear]
+ + ( 365 * $ym1 )
+ + ( $ym1 / 4 )
+ - ( $ym1 / 100 )
+ + ( $ym1 / 400 )
+ }]
+
# If the date is before the Gregorian change, use the Julian calendar.
if { $jd < $changeover } {
dict set date gregorian 0
- set jd [expr { 1721423
- + [dict get $date dayOfYear]
- + ( 365 * $ym1 )
- + ( $ym1 / 4 ) }]
+ set jd [expr {
+ 1721423
+ + [dict get $date dayOfYear]
+ + ( 365 * $ym1 )
+ + ( $ym1 / 4 )
+ }]
}
dict set date julianDay $jd
@@ -4155,8 +4067,8 @@ proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} {
#
# GetJulianDayFromEraYearMonthWeekDay --
#
-# Determines the Julian Day number corresponding to the nth
-# given day-of-the-week in a given month.
+# Determines the Julian Day number corresponding to the nth given
+# day-of-the-week in a given month.
#
# Parameters:
# date - Dictionary containing the keys, 'era', 'year', 'month'
@@ -4175,10 +4087,9 @@ proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} {
#----------------------------------------------------------------------
proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} {
-
- # Come up with a reference day; either the zeroeth day of the
- # given month (dayOfWeekInMonth >= 0) or the seventh day of the
- # following month (dayOfWeekInMonth < 0)
+ # Come up with a reference day; either the zeroeth day of the given month
+ # (dayOfWeekInMonth >= 0) or the seventh day of the following month
+ # (dayOfWeekInMonth < 0)
set date2 $date
set week [dict get $date dayOfWeekInMonth]
@@ -4194,7 +4105,6 @@ proc ::tcl::clock::GetJulianDayFromEraYearMonthWeekDay {date changeover} {
[dict get $date2 julianDay]]
dict set date julianDay [expr { $wd0 + 7 * $week }]
return $date
-
}
#----------------------------------------------------------------------
@@ -4217,9 +4127,8 @@ 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 {
@@ -4237,15 +4146,14 @@ proc ::tcl::clock::IsGregorianLeapYear { date } {
} else {
return 1
}
-
}
#----------------------------------------------------------------------
#
# WeekdayOnOrBefore --
#
-# Determine the nearest day of week (given by the 'weekday'
-# parameter, Sunday==0) on or before a given Julian Day.
+# Determine the nearest day of week (given by the 'weekday' parameter,
+# Sunday==0) on or before a given Julian Day.
#
# Parameters:
# weekday -- Day of the week
@@ -4260,18 +4168,16 @@ proc ::tcl::clock::IsGregorianLeapYear { date } {
#----------------------------------------------------------------------
proc ::tcl::clock::WeekdayOnOrBefore { weekday j } {
-
set k [expr { ( $weekday + 6 ) % 7 }]
return [expr { $j - ( $j - $k ) % 7 }]
-
}
#----------------------------------------------------------------------
#
# BSearch --
#
-# Service procedure that does binary search in several places
-# inside the 'clock' command.
+# Service procedure that does binary search in several places inside the
+# 'clock' command.
#
# Parameters:
# list - List of lists, sorted in ascending order by the
@@ -4279,8 +4185,8 @@ proc ::tcl::clock::WeekdayOnOrBefore { weekday j } {
# key - Value to search for
#
# Results:
-# Returns the index of the greatest element in $list that is less
-# than or equal to $key.
+# Returns the index of the greatest element in $list that is less than
+# or equal to $key.
#
# Side effects:
# None.
@@ -4288,7 +4194,6 @@ proc ::tcl::clock::WeekdayOnOrBefore { weekday j } {
#----------------------------------------------------------------------
proc ::tcl::clock::BSearch { list key } {
-
if {[llength $list] == 0} {
return -1
}
@@ -4300,13 +4205,12 @@ proc ::tcl::clock::BSearch { list key } {
set u [expr { [llength $list] - 1 }]
while { $l < $u } {
-
# At this point, we know that
# $k >= [lindex $list $l 0]
# Either $u == [llength $list] or else $k < [lindex $list $u+1 0]
# We find the midpoint of the interval {l,u} rounded UP, compare
- # against it, and set l or u to maintain the invariant. Note
- # that the interval shrinks at each step, guaranteeing convergence.
+ # against it, and set l or u to maintain the invariant. Note that the
+ # interval shrinks at each step, guaranteeing convergence.
set m [expr { ( $l + $u + 1 ) / 2 }]
if { $key >= [lindex $list $m 0] } {
@@ -4350,15 +4254,14 @@ proc ::tcl::clock::BSearch { list key } {
# order.
#
# Notes:
-# It is possible that adding a number of months or years will adjust
-# the day of the month as well. For instance, the time at
-# one month after 31 January is either 28 or 29 February, because
-# February has fewer than 31 days.
+# It is possible that adding a number of months or years will adjust the
+# day of the month as well. For instance, the time at one month after
+# 31 January is either 28 or 29 February, because February has fewer
+# than 31 days.
#
#----------------------------------------------------------------------
proc ::tcl::clock::add { clockval args } {
-
if { [llength $args] % 2 != 0 } {
set cmdName "clock add"
return -code error \
@@ -4377,15 +4280,10 @@ proc ::tcl::clock::add { clockval args } {
set timezone [GetSystemTimeZone]
foreach { a b } $args {
-
if { [string is integer -strict $a] } {
-
lappend offsets $a $b
-
} else {
-
switch -exact -- $a {
-
-g - -gm - -gmt {
set gmt $b
}
@@ -4397,9 +4295,8 @@ proc ::tcl::clock::add { clockval args } {
set timezone $b
}
default {
- return -code error \
- -errorcode [list CLOCK badSwitch $a] \
- "bad switch \"$a\",\
+ throw [list CLOCK badOption $a] \
+ "bad option \"$a\",\
must be -gmt, -locale or -timezone"
}
}
@@ -4414,20 +4311,16 @@ proc ::tcl::clock::add { clockval args } {
"cannot use -gmt and -timezone in same call"
}
if { [catch { expr { wide($clockval) } } result] } {
- return -code error \
- "expected integer but got \"$clockval\""
+ return -code error "expected integer but got \"$clockval\""
}
- if { ![string is boolean $gmt] } {
- return -code error \
- "expected boolean value but got \"$gmt\""
- } else {
- if { $gmt } {
- set timezone :GMT
- }
+ if { ![string is boolean -strict $gmt] } {
+ return -code error "expected boolean value but got \"$gmt\""
+ } elseif { $gmt } {
+ set timezone :GMT
}
EnterLocale $locale oldLocale
-
+
set changeover [mc GREGORIAN_CHANGE_DATE]
if {[catch {SetupTimeZone $timezone} retval opts]} {
@@ -4435,29 +4328,25 @@ proc ::tcl::clock::add { clockval args } {
return -options $opts $retval
}
- set status [catch {
-
+ try {
foreach { quantity unit } $offsets {
-
switch -exact -- $unit {
-
years - year {
- set clockval \
- [AddMonths [expr { 12 * $quantity }] \
- $clockval $timezone $changeover]
+ set clockval [AddMonths [expr { 12 * $quantity }] \
+ $clockval $timezone $changeover]
}
months - month {
set clockval [AddMonths $quantity $clockval $timezone \
- $changeover]
+ $changeover]
}
weeks - week {
set clockval [AddDays [expr { 7 * $quantity }] \
- $clockval $timezone $changeover]
+ $clockval $timezone $changeover]
}
days - day {
set clockval [AddDays $quantity $clockval $timezone \
- $changeover]
+ $changeover]
}
hours - hour {
@@ -4471,31 +4360,24 @@ proc ::tcl::clock::add { clockval args } {
}
default {
- error "unknown unit \"$unit\", must be \
- years, months, weeks, days, hours, minutes or seconds" \
- "unknown unit \"$unit\", must be \
- years, months, weeks, days, hours, minutes or seconds" \
- [list CLOCK badUnit $unit]
+ throw [list CLOCK badUnit $unit] \
+ "unknown unit \"$unit\", must be \
+ years, months, weeks, days, hours, minutes or seconds"
}
}
}
- } result opts]
-
- # Restore the locale
-
- if { [info exists oldLocale] } {
- mclocale $oldLocale
- }
+ 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
- if { $status == 1 } {
- if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } {
- dict unset opts -errorinfo
+ if { [info exists oldLocale] } {
+ mclocale $oldLocale
}
- return -options $opts $result
- } else {
- return $clockval
}
-
}
#----------------------------------------------------------------------
@@ -4520,7 +4402,6 @@ proc ::tcl::clock::add { clockval args } {
#----------------------------------------------------------------------
proc ::tcl::clock::AddMonths { months clockval timezone changeover } {
-
variable DaysInRomanMonthInCommonYear
variable DaysInRomanMonthInLeapYear
variable TZData
@@ -4528,8 +4409,9 @@ proc ::tcl::clock::AddMonths { months clockval timezone changeover } {
# Convert the time to year, month, day, and fraction of day.
set date [GetDateFields $clockval $TZData($timezone) $changeover]
- dict set date secondOfDay [expr { [dict get $date localSeconds]
- % 86400 }]
+ dict set date secondOfDay [expr {
+ [dict get $date localSeconds] % 86400
+ }]
dict set date tzName $timezone
# Add the requisite number of months
@@ -4558,23 +4440,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)
@@ -4584,8 +4466,7 @@ proc ::tcl::clock::AddMonths { months clockval timezone changeover } {
# in the target locale.
#
# Results:
-# Returns the new clock value as a number of seconds since
-# the epoch.
+# Returns the new clock value as a number of seconds since the epoch.
#
# Side effects:
# None.
@@ -4593,14 +4474,14 @@ proc ::tcl::clock::AddMonths { months clockval timezone changeover } {
#----------------------------------------------------------------------
proc ::tcl::clock::AddDays { days clockval timezone changeover } {
-
variable TZData
# Convert the time to Julian Day
set date [GetDateFields $clockval $TZData($timezone) $changeover]
- dict set date secondOfDay [expr { [dict get $date localSeconds]
- % 86400 }]
+ dict set date secondOfDay [expr {
+ [dict get $date localSeconds] % 86400
+ }]
dict set date tzName $timezone
# Add the requisite number of days
@@ -4609,23 +4490,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.
@@ -4646,11 +4527,10 @@ 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
}
#----------------------------------------------------------------------
@@ -4671,7 +4551,6 @@ proc ::tcl::clock::mc { name } {
#----------------------------------------------------------------------
proc ::tcl::clock::ClearCaches {} {
-
variable FormatProc
variable LocaleNumeralCache
variable McLoaded
@@ -4691,5 +4570,4 @@ proc ::tcl::clock::ClearCaches {} {
catch {unset CachedSystemTimeZone}
set TimeZoneBad {}
InitTZData
-
}
diff --git a/library/dde/pkgIndex.tcl b/library/dde/pkgIndex.tcl
index 114dee6..4cf73d0 100644
--- a/library/dde/pkgIndex.tcl
+++ b/library/dde/pkgIndex.tcl
@@ -1,7 +1,7 @@
-if {![package vsatisfies [package provide Tcl] 8]} return
-if {[info sharedlibextension] != ".dll"} return
-if {[info exists ::tcl_platform(debug)]} {
- package ifneeded dde 1.3.3 [list load [file join $dir tcldde13g.dll] dde]
+if {([info commands ::tcl::pkgconfig] eq "")
+ || ([info sharedlibextension] ne ".dll")} return
+if {[::tcl::pkgconfig get debug]} {
+ package ifneeded dde 1.4.0 [list load [file join $dir tcldde14g.dll] dde]
} else {
- package ifneeded dde 1.3.3 [list load [file join $dir tcldde13.dll] dde]
+ package ifneeded dde 1.4.0 [list load [file join $dir tcldde14.dll] dde]
}
diff --git a/library/history.tcl b/library/history.tcl
index 888d144..51d2404 100644
--- a/library/history.tcl
+++ b/library/history.tcl
@@ -4,18 +4,18 @@
#
# Copyright (c) 1997 Sun Microsystems, Inc.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-
-# The tcl::history array holds the history list and
-# some additional bookkeeping variables.
+
+# The tcl::history array holds the history list and some additional
+# bookkeeping variables.
#
# nextid the index used for the next history list item.
# keep the max size of the history list
# oldest the index of the oldest item in the history.
-namespace eval tcl {
+namespace eval ::tcl {
variable history
if {![info exists history]} {
array set history {
@@ -24,163 +24,78 @@ namespace eval tcl {
oldest -20
}
}
-}
+ namespace ensemble create -command ::tcl::history -map {
+ add ::tcl::HistAdd
+ change ::tcl::HistChange
+ clear ::tcl::HistClear
+ event ::tcl::HistEvent
+ info ::tcl::HistInfo
+ keep ::tcl::HistKeep
+ nextid ::tcl::HistNextID
+ redo ::tcl::HistRedo
+ }
+}
+
# history --
#
# This is the main history command. See the man page for its interface.
-# This does argument checking and calls helper procedures in the
-# history namespace.
-
-proc history {args} {
- set len [llength $args]
- if {$len == 0} {
- return [tcl::HistInfo]
- }
- set key [lindex $args 0]
- set options "add, change, clear, event, info, keep, nextid, or redo"
- switch -glob -- $key {
- a* { # history add
-
- if {$len > 3} {
- return -code error "wrong # args: should be \"history add event ?exec?\""
- }
- if {![string match $key* add]} {
- return -code error "bad option \"$key\": must be $options"
- }
- if {$len == 3} {
- set arg [lindex $args 2]
- if {! ([string match e* $arg] && [string match $arg* exec])} {
- return -code error "bad argument \"$arg\": should be \"exec\""
- }
- }
- return [tcl::HistAdd [lindex $args 1] [lindex $args 2]]
- }
- ch* { # history change
-
- if {($len > 3) || ($len < 2)} {
- return -code error "wrong # args: should be \"history change newValue ?event?\""
- }
- if {![string match $key* change]} {
- return -code error "bad option \"$key\": must be $options"
- }
- if {$len == 2} {
- set event 0
- } else {
- set event [lindex $args 2]
- }
-
- return [tcl::HistChange [lindex $args 1] $event]
- }
- cl* { # history clear
-
- if {($len > 1)} {
- return -code error "wrong # args: should be \"history clear\""
- }
- if {![string match $key* clear]} {
- return -code error "bad option \"$key\": must be $options"
- }
- return [tcl::HistClear]
- }
- e* { # history event
-
- if {$len > 2} {
- return -code error "wrong # args: should be \"history event ?event?\""
- }
- if {![string match $key* event]} {
- return -code error "bad option \"$key\": must be $options"
- }
- if {$len == 1} {
- set event -1
- } else {
- set event [lindex $args 1]
- }
- return [tcl::HistEvent $event]
- }
- i* { # history info
-
- if {$len > 2} {
- return -code error "wrong # args: should be \"history info ?count?\""
- }
- if {![string match $key* info]} {
- return -code error "bad option \"$key\": must be $options"
- }
- return [tcl::HistInfo [lindex $args 1]]
- }
- k* { # history keep
+# This does some argument checking and calls the helper ensemble in the
+# tcl namespace.
- if {$len > 2} {
- return -code error "wrong # args: should be \"history keep ?count?\""
- }
- if {$len == 1} {
- return [tcl::HistKeep]
- } else {
- set limit [lindex $args 1]
- if {[catch {expr {~$limit}}] || ($limit < 0)} {
- return -code error "illegal keep count \"$limit\""
- }
- return [tcl::HistKeep $limit]
- }
- }
- n* { # history nextid
-
- if {$len > 1} {
- return -code error "wrong # args: should be \"history nextid\""
- }
- if {![string match $key* nextid]} {
- return -code error "bad option \"$key\": must be $options"
- }
- return [expr {$tcl::history(nextid) + 1}]
- }
- r* { # history redo
+proc ::history {args} {
+ # If no command given, we're doing 'history info'. Can't be done with an
+ # ensemble unknown handler, as those don't fire when no subcommand is
+ # given at all.
- if {$len > 2} {
- return -code error "wrong # args: should be \"history redo ?event?\""
- }
- if {![string match $key* redo]} {
- return -code error "bad option \"$key\": must be $options"
- }
- return [tcl::HistRedo [lindex $args 1]]
- }
- default {
- return -code error "bad option \"$key\": must be $options"
- }
+ if {![llength $args]} {
+ set args info
}
-}
+ # Tricky stuff needed to make stack and errors come out right!
+ tailcall apply {arglist {tailcall history {*}$arglist} ::tcl} $args
+}
+
# tcl::HistAdd --
#
# Add an item to the history, and optionally eval it at the global scope
#
# Parameters:
-# command the command to add
-# exec (optional) a substring of "exec" causes the
-# command to be evaled.
+# event the command to add
+# exec (optional) a substring of "exec" causes the command to
+# be evaled.
# Results:
# If executing, then the results of the command are returned
#
# Side Effects:
# Adds to the history list
- proc tcl::HistAdd {command {exec {}}} {
+proc ::tcl::HistAdd {event {exec {}}} {
variable history
+ if {
+ [prefix longest {exec {}} $exec] eq ""
+ && [llength [info level 0]] == 3
+ } then {
+ return -code error "bad argument \"$exec\": should be \"exec\""
+ }
+
# Do not add empty commands to the history
- if {[string trim $command] eq ""} {
+ if {[string trim $event] eq ""} {
return ""
}
- set i [incr history(nextid)]
- set history($i) $command
- set j [incr history(oldest)]
- unset -nocomplain history($j)
- if {[string match e* $exec]} {
- return [uplevel #0 $command]
- } else {
- return {}
+ # Maintain the history
+ set history([incr history(nextid)]) $event
+ unset -nocomplain history([incr history(oldest)])
+
+ # Only execute if 'exec' (or non-empty prefix of it) given
+ if {$exec eq ""} {
+ return ""
}
+ tailcall eval $event
}
-
+
# tcl::HistKeep --
#
# Set or query the limit on the length of the history list
@@ -194,20 +109,22 @@ proc history {args} {
# Side Effects:
# Updates history(keep) if a limit is specified
- proc tcl::HistKeep {{limit {}}} {
+proc ::tcl::HistKeep {{count {}}} {
variable history
- if {$limit eq ""} {
+ if {[llength [info level 0]] == 1} {
return $history(keep)
- } else {
- set oldold $history(oldest)
- set history(oldest) [expr {$history(nextid) - $limit}]
- for {} {$oldold <= $history(oldest)} {incr oldold} {
- unset -nocomplain history($oldold)
- }
- set history(keep) $limit
}
+ if {![string is integer -strict $count] || ($count < 0)} {
+ return -code error "illegal keep count \"$count\""
+ }
+ set oldold $history(oldest)
+ set history(oldest) [expr {$history(nextid) - $count}]
+ for {} {$oldold <= $history(oldest)} {incr oldold} {
+ unset -nocomplain history($oldold)
+ }
+ set history(keep) $count
}
-
+
# tcl::HistClear --
#
# Erase the history list
@@ -221,7 +138,7 @@ proc history {args} {
# Side Effects:
# Resets the history array, except for the keep limit
- proc tcl::HistClear {} {
+proc ::tcl::HistClear {} {
variable history
set keep $history(keep)
unset history
@@ -231,7 +148,7 @@ proc history {args} {
oldest -$keep \
]
}
-
+
# tcl::HistInfo --
#
# Return a pretty-printed version of the history list
@@ -242,14 +159,16 @@ proc history {args} {
# Results:
# A formatted history list
- proc tcl::HistInfo {{num {}}} {
+proc ::tcl::HistInfo {{count {}}} {
variable history
- if {$num eq ""} {
- set num [expr {$history(keep) + 1}]
+ if {[llength [info level 0]] == 1} {
+ set count [expr {$history(keep) + 1}]
+ } elseif {![string is integer -strict $count]} {
+ return -code error "bad integer \"$count\""
}
set result {}
set newline ""
- for {set i [expr {$history(nextid) - $num + 1}]} \
+ for {set i [expr {$history(nextid) - $count + 1}]} \
{$i <= $history(nextid)} {incr i} {
if {![info exists history($i)]} {
continue
@@ -260,11 +179,11 @@ proc history {args} {
}
return $result
}
-
+
# tcl::HistRedo --
#
-# Fetch the previous or specified event, execute it, and then
-# replace the current history item with that event.
+# Fetch the previous or specified event, execute it, and then replace
+# the current history item with that event.
#
# Parameters:
# event (optional) index of history item to redo. Defaults to -1,
@@ -276,20 +195,18 @@ proc history {args} {
# Side Effects:
# Replaces the current history list item with the one being redone.
- proc tcl::HistRedo {{event -1}} {
+proc ::tcl::HistRedo {{event -1}} {
variable history
- if {$event eq ""} {
- set event -1
- }
+
set i [HistIndex $event]
if {$i == $history(nextid)} {
return -code error "cannot redo the current event"
}
set cmd $history($i)
HistChange $cmd 0
- uplevel #0 $cmd
+ tailcall eval $cmd
}
-
+
# tcl::HistIndex --
#
# Map from an event specifier to an index in the history list.
@@ -299,22 +216,22 @@ proc history {args} {
# If this is a positive number, it is used directly.
# If it is a negative number, then it counts back to a previous
# event, where -1 is the most recent event.
-# A string can be matched, either by being the prefix of
-# a command or by matching a command with string match.
+# A string can be matched, either by being the prefix of a
+# command or by matching a command with string match.
#
# Results:
# The index into history, or an error if the index didn't match.
- proc tcl::HistIndex {event} {
+proc ::tcl::HistIndex {event} {
variable history
- if {[catch {expr {~$event}}]} {
+ if {![string is integer -strict $event]} {
for {set i [expr {$history(nextid)-1}]} {[info exists history($i)]} \
{incr i -1} {
if {[string match $event* $history($i)]} {
- return $i;
+ return $i
}
if {[string match $event $history($i)]} {
- return $i;
+ return $i
}
}
return -code error "no event matches \"$event\""
@@ -331,43 +248,64 @@ proc history {args} {
}
return $i
}
-
+
# tcl::HistEvent --
#
# Map from an event specifier to the value in the history list.
#
# Parameters:
-# event index of history item to redo. See index for a
-# description of possible event patterns.
+# event index of history item to redo. See index for a description of
+# possible event patterns.
#
# Results:
# The value from the history list.
- proc tcl::HistEvent {event} {
+proc ::tcl::HistEvent {{event -1}} {
variable history
set i [HistIndex $event]
- if {[info exists history($i)]} {
- return [string trimright $history($i) \ \n]
- } else {
- return "";
+ if {![info exists history($i)]} {
+ return ""
}
+ return [string trimright $history($i) \ \n]
}
-
+
# tcl::HistChange --
#
# Replace a value in the history list.
#
# Parameters:
-# cmd The new value to put into the history list.
-# event (optional) index of history item to redo. See index for a
-# description of possible event patterns. This defaults
-# to 0, which specifies the current event.
+# newValue The new value to put into the history list.
+# event (optional) index of history item to redo. See index for a
+# description of possible event patterns. This defaults to 0,
+# which specifies the current event.
#
# Side Effects:
# Changes the history list.
- proc tcl::HistChange {cmd {event 0}} {
+proc ::tcl::HistChange {newValue {event 0}} {
variable history
set i [HistIndex $event]
- set history($i) $cmd
+ set history($i) $newValue
}
+
+# tcl::HistNextID --
+#
+# Returns the number of the next history event.
+#
+# Parameters:
+# None.
+#
+# Side Effects:
+# None.
+
+proc ::tcl::HistNextID {} {
+ variable history
+ return [expr {$history(nextid) + 1}]
+}
+
+return
+
+# Local Variables:
+# mode: tcl
+# fill-column: 78
+# End:
diff --git a/library/http/http.tcl b/library/http/http.tcl
index 4c99f62..a6b2bfd 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -8,10 +8,10 @@
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
-package require Tcl 8.4
+package require Tcl 8.6
# Keep this in sync with pkgIndex.tcl and with the install directories in
# Makefiles
-package provide http 2.7.13
+package provide http 2.8.8
namespace eval http {
# Allow resourcing to not clobber existing data
@@ -25,7 +25,13 @@ namespace eval http {
-proxyfilter http::ProxyRequired
-urlencoding utf-8
}
- set http(-useragent) "Tcl http client package [package provide http]"
+ # We need a useragent string of this style or various servers will refuse to
+ # send us compressed content even when we ask for it. This follows the
+ # de-facto layout of user-agent strings in current browsers.
+ set http(-useragent) "Mozilla/5.0\
+ ([string totitle $::tcl_platform(platform)]; U;\
+ $::tcl_platform(os) $::tcl_platform(osVersion))\
+ http/[package provide http] Tcl/[package provide Tcl]"
}
proc init {} {
@@ -92,7 +98,7 @@ namespace eval http {
# Arguments:
# msg Message to output
#
-proc http::Log {args} {}
+if {[info command http::Log] eq {}} {proc http::Log {args} {}}
# http::register --
#
@@ -194,7 +200,7 @@ proc http::Finish {token {errormsg ""} {skipCB 0}} {
if {
($state(status) eq "timeout") || ($state(status) eq "error") ||
([info exists state(connection)] && ($state(connection) eq "close"))
- } then {
+ } {
CloseSocket $state(sock) $token
}
if {[info exists state(after)]} {
@@ -360,7 +366,7 @@ proc http::geturl {url args} {
if {
[info exists type($flag)] &&
![string is $type($flag) -strict $value]
- } then {
+ } {
unset $token
return -code error \
"Bad value for $flag ($value), must be $type($flag)"
@@ -415,7 +421,6 @@ proc http::geturl {url args} {
# Note that the RE actually combines the user and password parts, as
# recommended in RFC 3986. Indeed, that RFC states that putting passwords
# in URLs is a Really Bad Idea, something with which I would agree utterly.
- # Also note that we do not currently support IPv6 addresses.
#
# From a validation perspective, we need to ensure that the parts of the
# URL that are going to the server are correctly encoded. This is only
@@ -430,7 +435,10 @@ proc http::geturl {url args} {
[^@/\#?]+ # <userinfo part of authority>
) @
)?
- ( [^/:\#?]+ ) # <host part of authority>
+ ( # <host part of authority>
+ [^/:\#?]+ | # host name or IPv4 address
+ \[ [^/\#?]+ \] # IPv6 address in square brackets
+ )
(?: : (\d+) )? # <port part of authority>
)?
( [/\?] [^\#]*)? # <path> (including query)
@@ -444,6 +452,7 @@ proc http::geturl {url args} {
return -code error "Unsupported URL: $url"
}
# Phase two: validate
+ set host [string trim $host {[]}]; # strip square brackets from IPv6 address
if {$host eq ""} {
# Caller has to provide a host name; we do not have a "default host"
# that would enable us to handle relative URLs.
@@ -677,7 +686,11 @@ 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)"
@@ -725,14 +738,8 @@ proc http::Connected { token proto phost srvurl} {
puts $sock "$key: $value"
}
}
- # Soft zlib dependency check - no package require
- if {
- !$accept_encoding_seen &&
- ([package vsatisfies [package provide Tcl] 8.6]
- || [llength [package provide zlib]]) &&
- !([info exists state(-channel)] || [info exists state(-handler)])
- } then {
- puts $sock "Accept-Encoding: gzip, identity, *;q=0.1"
+ if {!$accept_encoding_seen && ![info exists state(-handler)]} {
+ puts $sock "Accept-Encoding: deflate,gzip,compress"
}
if {$isQueryChannel && $state(querylength) == 0} {
# Try to determine size of data in channel. If we cannot seek, the
@@ -756,7 +763,7 @@ proc http::Connected { token proto phost srvurl} {
# versions TclHttpd in various error cases). Depending on the
# platform, the client may or may not be able to get the response from
# the server because of the error it will get trying to write the post
- # data. Having both fileevents active changes the timing and the
+ # data. Having both fileevents active changes the timing and the
# behavior, but no two platforms (among Solaris, Linux, and NT) behave
# the same, and none behave all that well in any case. Servers should
# always read their POST data if they expect the client to read their
@@ -778,7 +785,7 @@ proc http::Connected { token proto phost srvurl} {
fileevent $sock readable [list http::Event $sock $token]
}
- } err]} then {
+ } err]} {
# The socket probably was never connected, or the connection dropped
# later.
@@ -879,7 +886,7 @@ proc http::Connect {token proto phost srvurl} {
if {
[eof $state(sock)] ||
[set err [fconfigure $state(sock) -error]] ne ""
- } then {
+ } {
Finish $token "connect failed $err"
} else {
fileevent $state(sock) writable {}
@@ -930,7 +937,7 @@ proc http::Write {token} {
set done 1
}
}
- } err]} then {
+ } err]} {
# Do not call Finish here, but instead let the read half of the socket
# process whatever server reply there is to get.
@@ -1009,7 +1016,7 @@ proc http::Event {sock token} {
&& ($state(connection) eq "close"))
|| [info exists state(transfer)])
&& ($state(totalsize) == 0)
- } then {
+ } {
Log "body size is 0 and no events likely - complete."
Eof $token
return
@@ -1020,26 +1027,20 @@ proc http::Event {sock token} {
if {
$state(-binary) || ![string match -nocase text* $state(type)]
- } then {
+ } {
# Turn off conversions for non-text data
set state(binary) 1
}
- if {
- $state(binary) || [string match *gzip* $state(coding)] ||
- [string match *compress* $state(coding)]
- } then {
- if {[info exists state(-channel)]} {
+ if {[info exists state(-channel)]} {
+ if {$state(binary) || [llength [ContentEncoding $token]]} {
fconfigure $state(-channel) -translation binary
}
- }
- if {
- [info exists state(-channel)] &&
- ![info exists state(-handler)]
- } then {
- # Initiate a sequence of background fcopies
- fileevent $sock readable {}
- CopyStart $sock $token
- return
+ if {![info exists state(-handler)]} {
+ # Initiate a sequence of background fcopies
+ fileevent $sock readable {}
+ CopyStart $sock $token
+ return
+ }
}
} elseif {$n > 0} {
# Process header lines
@@ -1094,7 +1095,7 @@ proc http::Event {sock token} {
} elseif {
[info exists state(transfer)]
&& $state(transfer) eq "chunked"
- } then {
+ } {
set size 0
set chunk [getTextLine $sock]
set n [string length $chunk]
@@ -1134,11 +1135,11 @@ proc http::Event {sock token} {
if {
($state(totalsize) > 0)
&& ($state(currentsize) >= $state(totalsize))
- } then {
+ } {
Eof $token
}
}
- } err]} then {
+ } err]} {
return [Finish $token $err]
} else {
if {[info exists state(-progress)]} {
@@ -1191,14 +1192,54 @@ proc http::getTextLine {sock} {
# Side Effects
# This closes the connection upon error
-proc http::CopyStart {sock token} {
- variable $token
+proc http::CopyStart {sock token {initial 1}} {
+ upvar #0 $token state
+ if {[info exists state(transfer)] && $state(transfer) eq "chunked"} {
+ foreach coding [ContentEncoding $token] {
+ lappend state(zlib) [zlib stream $coding]
+ }
+ make-transformation-chunked $sock [namespace code [list CopyChunk $token]]
+ } else {
+ if {$initial} {
+ foreach coding [ContentEncoding $token] {
+ zlib push $coding $sock
+ }
+ }
+ if {[catch {
+ fcopy $sock $state(-channel) -size $state(-blocksize) -command \
+ [list http::CopyDone $token]
+ } err]} {
+ Finish $token $err
+ }
+ }
+}
+
+proc http::CopyChunk {token chunk} {
upvar 0 $token state
- if {[catch {
- fcopy $sock $state(-channel) -size $state(-blocksize) -command \
- [list http::CopyDone $token]
- } err]} then {
- Finish $token $err
+ if {[set count [string length $chunk]]} {
+ incr state(currentsize) $count
+ if {[info exists state(zlib)]} {
+ foreach stream $state(zlib) {
+ set chunk [$stream add $chunk]
+ }
+ }
+ puts -nonewline $state(-channel) $chunk
+ if {[info exists state(-progress)]} {
+ eval [linsert $state(-progress) end \
+ $token $state(totalsize) $state(currentsize)]
+ }
+ } else {
+ Log "CopyChunk Finish $token"
+ if {[info exists state(zlib)]} {
+ set excess ""
+ foreach stream $state(zlib) {
+ catch {set excess [$stream add -finalize $excess]}
+ }
+ puts -nonewline $state(-channel) $excess
+ foreach stream $state(zlib) { $stream close }
+ unset state(zlib)
+ }
+ Eof $token ;# FIX ME: pipelining.
}
}
@@ -1228,7 +1269,7 @@ proc http::CopyDone {token count {error {}}} {
} elseif {[catch {eof $sock} iseof] || $iseof} {
Eof $token
} else {
- CopyStart $sock $token
+ CopyStart $sock $token 0
}
}
@@ -1252,34 +1293,31 @@ proc http::Eof {token {force 0}} {
set state(status) ok
}
- if {($state(coding) eq "gzip") && [string length $state(body)] > 0} {
- if {[catch {
- if {[package vsatisfies [package present Tcl] 8.6]} {
- # The zlib integration into 8.6 includes proper gzip support
- set state(body) [zlib gunzip $state(body)]
- } else {
- set state(body) [Gunzip $state(body)]
+ if {[string length $state(body)] > 0} {
+ if {[catch {
+ foreach coding [ContentEncoding $token] {
+ set state(body) [zlib $coding $state(body)]
}
- } err]} then {
+ } err]} {
+ Log "error doing $coding '$state(body)'"
return [Finish $token $err]
- }
- }
+ }
- if {!$state(binary)} {
- # If we are getting text, set the incoming channel's encoding
- # correctly. iso8859-1 is the RFC default, but this could be any IANA
- # charset. However, we only know how to convert what we have
- # encodings for.
+ if {!$state(binary)} {
+ # If we are getting text, set the incoming channel's encoding
+ # correctly. iso8859-1 is the RFC default, but this could be any IANA
+ # charset. However, we only know how to convert what we have
+ # encodings for.
- set enc [CharsetToEncoding $state(charset)]
- if {$enc ne "binary"} {
- set state(body) [encoding convertfrom $enc $state(body)]
- }
+ set enc [CharsetToEncoding $state(charset)]
+ if {$enc ne "binary"} {
+ set state(body) [encoding convertfrom $enc $state(body)]
+ }
- # Translate text line endings.
- set state(body) [string map {\r\n \n \r \n} $state(body)]
+ # Translate text line endings.
+ set state(body) [string map {\r\n \n \r \n} $state(body)]
+ }
}
-
Finish $token
}
@@ -1355,7 +1393,7 @@ proc http::mapReply {string} {
}
set converted [string map $formMap $string]
if {[string match "*\[\u0100-\uffff\]*" $converted]} {
- regexp {[\u0100-\uffff]} $converted badChar
+ regexp "\[\u0100-\uffff\]" $converted badChar
# Return this error message for maximum compatability... :^/
return -code error \
"can't read \"formMap($badChar)\": no such element in array"
@@ -1378,7 +1416,7 @@ proc http::ProxyRequired {host} {
if {
![info exists http(-proxyport)] ||
![string length $http(-proxyport)]
- } then {
+ } {
set http(-proxyport) 8080
}
return [list $http(-proxyhost) $http(-proxyport)]
@@ -1424,59 +1462,57 @@ proc http::CharsetToEncoding {charset} {
}
}
-# http::Gunzip --
-#
-# Decompress data transmitted using the gzip transfer coding.
-#
-
-# FIX ME: redo using zlib sinflate
-proc http::Gunzip {data} {
- binary scan $data Scb5icc magic method flags time xfl os
- set pos 10
- if {$magic != 0x1f8b} {
- return -code error "invalid data: supplied data is not in gzip format"
- }
- if {$method != 8} {
- return -code error "invalid compression method"
- }
-
- # lassign [split $flags ""] f_text f_crc f_extra f_name f_comment
- foreach {f_text f_crc f_extra f_name f_comment} [split $flags ""] break
- set extra ""
- if {$f_extra} {
- binary scan $data @${pos}S xlen
- incr pos 2
- set extra [string range $data $pos $xlen]
- set pos [incr xlen]
- }
-
- set name ""
- if {$f_name} {
- set ndx [string first \0 $data $pos]
- set name [string range $data $pos $ndx]
- set pos [incr ndx]
- }
-
- set comment ""
- if {$f_comment} {
- set ndx [string first \0 $data $pos]
- set comment [string range $data $pos $ndx]
- set pos [incr ndx]
- }
-
- set fcrc ""
- if {$f_crc} {
- set fcrc [string range $data $pos [incr pos]]
- incr pos
+# Return the list of content-encoding transformations we need to do in order.
+proc http::ContentEncoding {token} {
+ upvar 0 $token state
+ set r {}
+ if {[info exists state(coding)]} {
+ foreach coding [split $state(coding) ,] {
+ switch -exact -- $coding {
+ deflate { lappend r inflate }
+ gzip - x-gzip { lappend r gunzip }
+ compress - x-compress { lappend r decompress }
+ identity {}
+ default {
+ return -code error "unsupported content-encoding \"$coding\""
+ }
+ }
+ }
}
+ return $r
+}
- binary scan [string range $data end-7 end] ii crc size
- set inflated [zlib inflate [string range $data $pos end-8]]
- set chk [zlib crc32 $inflated]
- if {($crc & 0xffffffff) != ($chk & 0xffffffff)} {
- return -code error "invalid data: checksum mismatch $crc != $chk"
- }
- return $inflated
+proc http::make-transformation-chunked {chan command} {
+ set lambda {{chan command} {
+ set data ""
+ set size -1
+ yield
+ while {1} {
+ chan configure $chan -translation {crlf binary}
+ while {[gets $chan line] < 1} { yield }
+ chan configure $chan -translation {binary binary}
+ if {[scan $line %x size] != 1} { return -code error "invalid size: \"$line\"" }
+ set chunk ""
+ while {$size && ![chan eof $chan]} {
+ set part [chan read $chan $size]
+ incr size -[string length $part]
+ append chunk $part
+ }
+ if {[catch {
+ uplevel #0 [linsert $command end $chunk]
+ }]} {
+ http::Log "Error in callback: $::errorInfo"
+ }
+ if {[string length $chunk] == 0} {
+ # channel might have been closed in the callback
+ catch {chan event $chan readable {}}
+ return
+ }
+ }
+ }}
+ coroutine dechunk$chan ::apply $lambda $chan $command
+ chan event $chan readable [namespace origin dechunk$chan]
+ return
}
# Local variables:
diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl
index be8b883..27ba795 100644
--- a/library/http/pkgIndex.tcl
+++ b/library/http/pkgIndex.tcl
@@ -1,4 +1,2 @@
-# Tcl package index file, version 1.1
-
-if {![package vsatisfies [package provide Tcl] 8.4]} {return}
-package ifneeded http 2.7.13 [list tclPkgSetup $dir http 2.7.13 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
+if {![package vsatisfies [package provide Tcl] 8.6]} {return}
+package ifneeded http 2.8.8 [list tclPkgSetup $dir http 2.8.8 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
diff --git a/library/http1.0/http.tcl b/library/http1.0/http.tcl
index 8041ee4..8329de4 100644
--- a/library/http1.0/http.tcl
+++ b/library/http1.0/http.tcl
@@ -339,12 +339,12 @@ proc http_formatQuery {args} {
# 2 Convert every other character to an array lookup
# 3 Escape constructs that are "special" to the tcl parser
# 4 "subst" the result, doing all the array substitutions
-
+
proc httpMapReply {string} {
global httpFormMap
set alphanumeric a-zA-Z0-9
if {![info exists httpFormMap]} {
-
+
for {set i 1} {$i <= 256} {incr i} {
set c [format %c $i]
if {![string match \[$alphanumeric\] $c]} {
@@ -363,7 +363,7 @@ proc http_formatQuery {args} {
return [subst $string]
}
-# Default proxy filter.
+# Default proxy filter.
proc httpProxyRequired {host} {
global http
if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} {
diff --git a/library/init.tcl b/library/init.tcl
index 38c6bb3..bb17319 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -16,7 +16,7 @@
if {[info commands package] == ""} {
error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
}
-package require -exact Tcl 8.5.15
+package require -exact Tcl 8.6.1
# Compute the auto path to use in this interpreter.
# The values on the path come from several locations:
@@ -142,11 +142,7 @@ if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} {
}
}
if {![info exists env(COMSPEC)]} {
- if {$tcl_platform(os) eq "Windows NT"} {
- set env(COMSPEC) cmd.exe
- } else {
- set env(COMSPEC) command.com
- }
+ set env(COMSPEC) cmd.exe
}
}
InitWinEnv
@@ -218,11 +214,9 @@ if {[namespace which -command tclLog] eq ""} {
# exist in the interpreter. It takes the following steps to make the
# command available:
#
-# 1. See if the command has the form "namespace inscope ns cmd" and
-# if so, concatenate its arguments onto the end and evaluate it.
-# 2. See if the autoload facility can locate the command in a
+# 1. See if the autoload facility can locate the command in a
# Tcl script file. If so, load it and execute it.
-# 3. If the command was invoked interactively at top-level:
+# 2. If the command was invoked interactively at top-level:
# (a) see if the command exists as an executable UNIX program.
# If so, "exec" the command.
# (b) see if the command requests csh-like history substitution
@@ -239,22 +233,14 @@ proc unknown args {
variable ::tcl::UnknownPending
global auto_noexec auto_noload env tcl_interactive errorInfo errorCode
- # If the command word has the form "namespace inscope ns cmd"
- # then concatenate its arguments onto the end and evaluate it.
-
- set cmd [lindex $args 0]
- if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
- #return -code error "You need an {*}"
- set arglist [lrange $args 1 end]
- set ret [catch {uplevel 1 ::$cmd $arglist} result opts]
- dict unset opts -errorinfo
- dict incr opts -level
- return -options $opts $result
+ if {[info exists errorInfo]} {
+ set savedErrorInfo $errorInfo
+ }
+ if {[info exists errorCode]} {
+ set savedErrorCode $errorCode
}
- catch {set savedErrorInfo $errorInfo}
- catch {set savedErrorCode $errorCode}
- set name $cmd
+ set name [lindex $args 0]
if {![info exists auto_noload]} {
#
# Make sure we're not trying to load the same proc twice.
@@ -412,7 +398,8 @@ proc unknown args {
return -code error "ambiguous command name \"$name\": [lsort $cmds]"
}
}
- return -code error "invalid command name \"$name\""
+ return -code error -errorcode [list TCL LOOKUP COMMAND $name] \
+ "invalid command name \"$name\""
}
# auto_load --
diff --git a/library/opt/optparse.tcl b/library/opt/optparse.tcl
index c9438a0..fc77fa1 100644
--- a/library/opt/optparse.tcl
+++ b/library/opt/optparse.tcl
@@ -11,7 +11,7 @@
package require Tcl 8.2
# When this version number changes, update the pkgIndex.tcl file
# and the install directory in the Makefiles.
-package provide opt 0.4.5
+package provide opt 0.4.6
namespace eval ::tcl {
@@ -33,7 +33,7 @@ namespace eval ::tcl {
# Every OptProc give usage information on "procname -help".
# Try "tcl::OptParseTest -help" and "tcl::OptParseTest -a" and
# then other arguments.
- #
+ #
# example of 'valid' call:
# ::tcl::OptParseTest save -4 -pr 23 -libsok SybTcl\
# -nostatics false ch1
@@ -69,10 +69,10 @@ namespace eval ::tcl {
################### No User serviceable part below ! ###############
# Array storing the parsed descriptions
- variable OptDesc;
- array set OptDesc {};
+ variable OptDesc
+ array set OptDesc {}
# Next potentially free key id (numeric)
- variable OptDescN 0;
+ variable OptDescN 0
# Inside algorithm/mechanism description:
# (not for the faint hearted ;-)
@@ -84,8 +84,8 @@ namespace eval ::tcl {
#
# The general structure of a "program" is
# notation (pseudo bnf like)
-# name :== definition defines "name" as being "definition"
-# { x y z } means list of x, y, and z
+# name :== definition defines "name" as being "definition"
+# { x y z } means list of x, y, and z
# x* means x repeated 0 or more time
# x+ means "x x*"
# x? means optionally x
@@ -110,7 +110,7 @@ namespace eval ::tcl {
#
# And for this application:
#
-# singleStep :== { instruction varname {hasBeenSet currentValue} type
+# singleStep :== { instruction varname {hasBeenSet currentValue} type
# typeArgs help }
# instruction :== "flags" | "value"
# type :== knowType | anyword
@@ -143,54 +143,54 @@ namespace eval ::tcl {
# generate a unused keyid if not given
#
proc ::tcl::OptKeyRegister {desc {key ""}} {
- variable OptDesc;
- variable OptDescN;
+ variable OptDesc
+ variable OptDescN
if {[string equal $key ""]} {
# in case a key given to us as a parameter was a number
while {[info exists OptDesc($OptDescN)]} {incr OptDescN}
- set key $OptDescN;
- incr OptDescN;
+ set key $OptDescN
+ incr OptDescN
}
# program counter
- set program [list [list "P" 1]];
+ set program [list [list "P" 1]]
# are we processing flags (which makes a single program step)
- set inflags 0;
+ set inflags 0
- set state {};
+ set state {}
# flag used to detect that we just have a single (flags set) subprogram.
- set empty 1;
+ set empty 1
foreach item $desc {
if {$state == "args"} {
# more items after 'args'...
- return -code error "'args' special argument must be the last one";
+ return -code error "'args' special argument must be the last one"
}
- set res [OptNormalizeOne $item];
- set state [lindex $res 0];
+ set res [OptNormalizeOne $item]
+ set state [lindex $res 0]
if {$inflags} {
if {$state == "flags"} {
# add to 'subprogram'
- lappend flagsprg $res;
+ lappend flagsprg $res
} else {
# put in the flags
# structure for flag programs items is a list of
# {subprgcounter {prg flag 1} {prg flag 2} {...}}
- lappend program $flagsprg;
+ lappend program $flagsprg
# put the other regular stuff
- lappend program $res;
- set inflags 0;
- set empty 0;
+ lappend program $res
+ set inflags 0
+ set empty 0
}
} else {
if {$state == "flags"} {
- set inflags 1;
+ set inflags 1
# sub program counter + first sub program
- set flagsprg [list [list "P" 1] $res];
+ set flagsprg [list [list "P" 1] $res]
} else {
- lappend program $res;
- set empty 0;
+ lappend program $res
+ set empty 0
}
}
}
@@ -198,32 +198,32 @@ proc ::tcl::OptKeyRegister {desc {key ""}} {
if {$empty} {
# We just have the subprogram, optimize and remove
# unneeded level:
- set program $flagsprg;
+ set program $flagsprg
} else {
- lappend program $flagsprg;
+ lappend program $flagsprg
}
}
- set OptDesc($key) $program;
+ set OptDesc($key) $program
- return $key;
+ return $key
}
#
# Free the storage for that given key
#
proc ::tcl::OptKeyDelete {key} {
- variable OptDesc;
- unset OptDesc($key);
+ variable OptDesc
+ unset OptDesc($key)
}
# Get the parsed description stored under the given key.
proc OptKeyGetDesc {descKey} {
- variable OptDesc;
+ variable OptDesc
if {![info exists OptDesc($descKey)]} {
- return -code error "Unknown option description key \"$descKey\"";
+ return -code error "Unknown option description key \"$descKey\""
}
- set OptDesc($descKey);
+ set OptDesc($descKey)
}
# Parse entry point for ppl who don't want to register with a key,
@@ -232,10 +232,10 @@ proc ::tcl::OptKeyDelete {key} {
# as it is way faster or simply OptProc which does it all)
# Assign a temporary key, call OptKeyParse and then free the storage
proc ::tcl::OptParse {desc arglist} {
- set tempkey [OptKeyRegister $desc];
- set ret [catch {uplevel 1 [list ::tcl::OptKeyParse $tempkey $arglist]} res];
- OptKeyDelete $tempkey;
- return -code $ret $res;
+ set tempkey [OptKeyRegister $desc]
+ set ret [catch {uplevel 1 [list ::tcl::OptKeyParse $tempkey $arglist]} res]
+ OptKeyDelete $tempkey
+ return -code $ret $res
}
# Helper function, replacement for proc that both
@@ -246,22 +246,22 @@ proc ::tcl::OptParse {desc arglist} {
# (the other will be sets to their default value)
# into local variable named "Args".
proc ::tcl::OptProc {name desc body} {
- set namespace [uplevel 1 [list ::namespace current]];
+ set namespace [uplevel 1 [list ::namespace current]]
if {[string match "::*" $name] || [string equal $namespace "::"]} {
# absolute name or global namespace, name is the key
- set key $name;
+ set key $name
} else {
# we are relative to some non top level namespace:
- set key "${namespace}::${name}";
+ set key "${namespace}::${name}"
}
- OptKeyRegister $desc $key;
- uplevel 1 [list ::proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"];
- return $key;
+ OptKeyRegister $desc $key
+ uplevel 1 [list ::proc $name args "set Args \[::tcl::OptKeyParse $key \$args\]\n$body"]
+ return $key
}
# Check that a argument has been given
# assumes that "OptProc" has been used as it will check in "Args" list
proc ::tcl::OptProcArgGiven {argname} {
- upvar Args alist;
+ upvar Args alist
expr {[lsearch $alist $argname] >=0}
}
@@ -270,7 +270,7 @@ proc ::tcl::OptProcArgGiven {argname} {
# Return the instruction word/list of a given step/(sub)program
proc OptInstr {lst} {
- lindex $lst 0;
+ lindex $lst 0
}
# Is a (sub) program or a plain instruction ?
proc OptIsPrg {lst} {
@@ -286,56 +286,56 @@ proc ::tcl::OptProcArgGiven {argname} {
}
# Current program counter (2nd word of first word)
proc OptSetPrgCounter {lstName newValue} {
- upvar $lstName lst;
- set lst [lreplace $lst 0 0 [concat "P" $newValue]];
+ upvar $lstName lst
+ set lst [lreplace $lst 0 0 [concat "P" $newValue]]
}
# returns a list of currently selected items.
proc OptSelection {lst} {
- set res {};
+ set res {}
foreach idx [lrange [lindex $lst 0] 1 end] {
- lappend res [Lget $lst $idx];
+ lappend res [Lget $lst $idx]
}
- return $res;
+ return $res
}
# Advance to next description
proc OptNextDesc {descName} {
- uplevel 1 [list Lvarincr $descName {0 1}];
+ uplevel 1 [list Lvarincr $descName {0 1}]
}
# Get the current description, eventually descend
proc OptCurDesc {descriptions} {
- lindex $descriptions [OptGetPrgCounter $descriptions];
+ lindex $descriptions [OptGetPrgCounter $descriptions]
}
# get the current description, eventually descend
# through sub programs as needed.
proc OptCurDescFinal {descriptions} {
- set item [OptCurDesc $descriptions];
+ set item [OptCurDesc $descriptions]
# Descend untill we get the actual item and not a sub program
while {[OptIsPrg $item]} {
- set item [OptCurDesc $item];
+ set item [OptCurDesc $item]
}
- return $item;
+ return $item
}
# Current final instruction adress
proc OptCurAddr {descriptions {start {}}} {
- set adress [OptGetPrgCounter $descriptions];
- lappend start $adress;
- set item [lindex $descriptions $adress];
+ set adress [OptGetPrgCounter $descriptions]
+ lappend start $adress
+ set item [lindex $descriptions $adress]
if {[OptIsPrg $item]} {
- return [OptCurAddr $item $start];
+ return [OptCurAddr $item $start]
} else {
- return $start;
+ return $start
}
}
# Set the value field of the current instruction
proc OptCurSetValue {descriptionsName value} {
upvar $descriptionsName descriptions
# get the current item full adress
- set adress [OptCurAddr $descriptions];
+ set adress [OptCurAddr $descriptions]
# use the 3th field of the item (see OptValue / OptNewInst)
lappend adress 2
- Lvarset descriptions $adress [list 1 $value];
+ Lvarset descriptions $adress [list 1 $value]
# ^hasBeenSet flag
}
@@ -343,10 +343,10 @@ proc ::tcl::OptProcArgGiven {argname} {
proc OptState {item} {
lindex $item 0
}
-
+
# current state
proc OptCurState {descriptions} {
- OptState [OptCurDesc $descriptions];
+ OptState [OptCurDesc $descriptions]
}
#######
@@ -354,11 +354,11 @@ proc ::tcl::OptProcArgGiven {argname} {
# Returns the argument that has to be processed now
proc OptCurrentArg {lst} {
- lindex $lst 0;
+ lindex $lst 0
}
# Advance to next argument
proc OptNextArg {argsName} {
- uplevel 1 [list Lvarpop1 $argsName];
+ uplevel 1 [list Lvarpop1 $argsName]
}
#######
@@ -370,49 +370,49 @@ proc ::tcl::OptProcArgGiven {argname} {
# eventually eat all the arguments.
proc OptDoAll {descriptionsName argumentsName} {
upvar $descriptionsName descriptions
- upvar $argumentsName arguments;
-# puts "entered DoAll";
+ upvar $argumentsName arguments
+# puts "entered DoAll"
# Nb: the places where "state" can be set are tricky to figure
# because DoOne sets the state to flagsValue and return -continue
# when needed...
- set state [OptCurState $descriptions];
+ set state [OptCurState $descriptions]
# We'll exit the loop in "OptDoOne" or when state is empty.
while 1 {
- set curitem [OptCurDesc $descriptions];
+ set curitem [OptCurDesc $descriptions]
# Do subprograms if needed, call ourselves on the sub branch
while {[OptIsPrg $curitem]} {
OptDoAll curitem arguments
-# puts "done DoAll sub";
- # Insert back the results in current tree;
+# puts "done DoAll sub"
+ # Insert back the results in current tree
Lvarset1nc descriptions [OptGetPrgCounter $descriptions]\
- $curitem;
- OptNextDesc descriptions;
- set curitem [OptCurDesc $descriptions];
- set state [OptCurState $descriptions];
+ $curitem
+ OptNextDesc descriptions
+ set curitem [OptCurDesc $descriptions]
+ set state [OptCurState $descriptions]
}
-# puts "state = \"$state\" - arguments=($arguments)";
+# puts "state = \"$state\" - arguments=($arguments)"
if {[Lempty $state]} {
# Nothing left to do, we are done in this branch:
- break;
+ break
}
# The following statement can make us terminate/continue
# as it use return -code {break, continue, return and error}
# codes
- OptDoOne descriptions state arguments;
+ OptDoOne descriptions state arguments
# If we are here, no special return code where issued,
# we'll step to next instruction :
-# puts "new state = \"$state\"";
- OptNextDesc descriptions;
- set state [OptCurState $descriptions];
+# puts "new state = \"$state\""
+ OptNextDesc descriptions
+ set state [OptCurState $descriptions]
}
}
# Process one step for the state machine,
# eventually consuming the current argument.
proc OptDoOne {descriptionsName stateName argumentsName} {
- upvar $argumentsName arguments;
- upvar $descriptionsName descriptions;
- upvar $stateName state;
+ upvar $argumentsName arguments
+ upvar $descriptionsName descriptions
+ upvar $stateName state
# the special state/instruction "args" eats all
# the remaining args (if any)
@@ -420,27 +420,27 @@ proc ::tcl::OptProcArgGiven {argname} {
if {![Lempty $arguments]} {
# If there is no additional arguments, leave the default value
# in.
- OptCurSetValue descriptions $arguments;
- set arguments {};
+ OptCurSetValue descriptions $arguments
+ set arguments {}
}
# puts "breaking out ('args' state: consuming every reminding args)"
- return -code break;
+ return -code break
}
if {[Lempty $arguments]} {
if {$state == "flags"} {
# no argument and no flags : we're done
-# puts "returning to previous (sub)prg (no more args)";
- return -code return;
+# puts "returning to previous (sub)prg (no more args)"
+ return -code return
} elseif {$state == "optValue"} {
set state next; # not used, for debug only
# go to next state
- return ;
+ return
} else {
- return -code error [OptMissingValue $descriptions];
+ return -code error [OptMissingValue $descriptions]
}
} else {
- set arg [OptCurrentArg $arguments];
+ set arg [OptCurrentArg $arguments]
}
switch $state {
@@ -450,62 +450,62 @@ proc ::tcl::OptProcArgGiven {argname} {
# Still a flag ?
if {![OptIsFlag $arg]} {
# don't consume the argument, return to previous prg
- return -code return;
+ return -code return
}
# consume the flag
- OptNextArg arguments;
+ OptNextArg arguments
if {[string equal "--" $arg]} {
# return from 'flags' state
- return -code return;
+ return -code return
}
- set hits [OptHits descriptions $arg];
+ set hits [OptHits descriptions $arg]
if {$hits > 1} {
return -code error [OptAmbigous $descriptions $arg]
} elseif {$hits == 0} {
return -code error [OptFlagUsage $descriptions $arg]
}
- set item [OptCurDesc $descriptions];
+ set item [OptCurDesc $descriptions]
if {[OptNeedValue $item]} {
# we need a value, next state is
- set state flagValue;
+ set state flagValue
} else {
- OptCurSetValue descriptions 1;
+ OptCurSetValue descriptions 1
}
# continue
- return -code continue;
+ return -code continue
}
flagValue -
value {
- set item [OptCurDesc $descriptions];
+ set item [OptCurDesc $descriptions]
# Test the values against their required type
if {[catch {OptCheckType $arg\
[OptType $item] [OptTypeArgs $item]} val]} {
return -code error [OptBadValue $item $arg $val]
}
# consume the value
- OptNextArg arguments;
+ OptNextArg arguments
# set the value
- OptCurSetValue descriptions $val;
+ OptCurSetValue descriptions $val
# go to next state
if {$state == "flagValue"} {
set state flags
- return -code continue;
+ return -code continue
} else {
set state next; # not used, for debug only
return ; # will go on next step
}
}
optValue {
- set item [OptCurDesc $descriptions];
+ set item [OptCurDesc $descriptions]
# Test the values against their required type
if {![catch {OptCheckType $arg\
[OptType $item] [OptTypeArgs $item]} val]} {
# right type, so :
# consume the value
- OptNextArg arguments;
+ OptNextArg arguments
# set the value
- OptCurSetValue descriptions $val;
+ OptCurSetValue descriptions $val
}
# go to next state
set state next; # not used, for debug only
@@ -516,39 +516,39 @@ proc ::tcl::OptProcArgGiven {argname} {
# state as been entered !
return -code error "Bug! unknown state in DoOne \"$state\"\
(prg counter [OptGetPrgCounter $descriptions]:\
- [OptCurDesc $descriptions])";
+ [OptCurDesc $descriptions])"
}
# Parse the options given the key to previously registered description
# and arguments list
proc ::tcl::OptKeyParse {descKey arglist} {
- set desc [OptKeyGetDesc $descKey];
+ set desc [OptKeyGetDesc $descKey]
# make sure -help always give usage
if {[string equal -nocase "-help" $arglist]} {
- return -code error [OptError "Usage information:" $desc 1];
+ return -code error [OptError "Usage information:" $desc 1]
}
- OptDoAll desc arglist;
+ OptDoAll desc arglist
if {![Lempty $arglist]} {
- return -code error [OptTooManyArgs $desc $arglist];
+ return -code error [OptTooManyArgs $desc $arglist]
}
-
+
# Analyse the result
# Walk through the tree:
- OptTreeVars $desc "#[expr {[info level]-1}]" ;
+ OptTreeVars $desc "#[expr {[info level]-1}]"
}
# determine string length for nice tabulated output
proc OptTreeVars {desc level {vnamesLst {}}} {
foreach item $desc {
- if {[OptIsCounter $item]} continue;
+ if {[OptIsCounter $item]} continue
if {[OptIsPrg $item]} {
- set vnamesLst [OptTreeVars $item $level $vnamesLst];
+ set vnamesLst [OptTreeVars $item $level $vnamesLst]
} else {
- set vname [OptVarName $item];
+ set vname [OptVarName $item]
upvar $level $vname var
if {[OptHasBeenSet $item]} {
# puts "adding $vname"
@@ -556,10 +556,10 @@ proc ::tcl::OptKeyParse {descKey arglist} {
# it is more usefull, for instance you can check that
# no flags at all was given with expr
# {![string match "*-*" $Args]}
- lappend vnamesLst [OptName $item];
- set var [OptValue $item];
+ lappend vnamesLst [OptName $item]
+ set var [OptValue $item]
} else {
- set var [OptDefaultValue $item];
+ set var [OptDefaultValue $item]
}
}
}
@@ -571,7 +571,7 @@ proc ::tcl::OptKeyParse {descKey arglist} {
# and emit an error if arg is not of the correct type
# otherwise returns the canonical value of that arg (ie 0/1 for booleans)
proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
-# puts "checking '$arg' against '$type' ($typeArgs)";
+# puts "checking '$arg' against '$type' ($typeArgs)"
# only types "any", "choice", and numbers can have leading "-"
@@ -580,7 +580,7 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
if {![string is integer -strict $arg]} {
error "not an integer"
}
- return $arg;
+ return $arg
}
float {
return [expr {double($arg)}]
@@ -591,7 +591,7 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
if {[llength $arg]==0 && [OptIsFlag $arg]} {
error "no values with leading -"
}
- return $arg;
+ return $arg
}
boolean {
if {![string is boolean -strict $arg]} {
@@ -604,10 +604,10 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
if {[lsearch -exact $typeArgs $arg] < 0} {
error "invalid choice"
}
- return $arg;
+ return $arg
}
any {
- return $arg;
+ return $arg
}
string -
default {
@@ -617,7 +617,7 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
return $arg
}
}
- return neverReached;
+ return neverReached
}
# internal utilities
@@ -625,34 +625,34 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
# returns the number of flags matching the given arg
# sets the (local) prg counter to the list of matches
proc OptHits {descName arg} {
- upvar $descName desc;
+ upvar $descName desc
set hits 0
set hitems {}
- set i 1;
+ set i 1
- set larg [string tolower $arg];
- set len [string length $larg];
- set last [expr {$len-1}];
+ set larg [string tolower $arg]
+ set len [string length $larg]
+ set last [expr {$len-1}]
foreach item [lrange $desc 1 end] {
set flag [OptName $item]
# lets try to match case insensitively
# (string length ought to be cheap)
- set lflag [string tolower $flag];
+ set lflag [string tolower $flag]
if {$len == [string length $lflag]} {
if {[string equal $larg $lflag]} {
# Exact match case
- OptSetPrgCounter desc $i;
- return 1;
+ OptSetPrgCounter desc $i
+ return 1
}
} elseif {[string equal $larg [string range $lflag 0 $last]]} {
- lappend hitems $i;
- incr hits;
+ lappend hitems $i
+ incr hits
}
- incr i;
+ incr i
}
if {$hits} {
- OptSetPrgCounter desc $hitems;
+ OptSetPrgCounter desc $hitems
}
return $hits
}
@@ -660,29 +660,29 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
# Extract fields from the list structure:
proc OptName {item} {
- lindex $item 1;
+ lindex $item 1
}
proc OptHasBeenSet {item} {
- Lget $item {2 0};
+ Lget $item {2 0}
}
proc OptValue {item} {
- Lget $item {2 1};
+ Lget $item {2 1}
}
proc OptIsFlag {name} {
- string match "-*" $name;
+ string match "-*" $name
}
proc OptIsOpt {name} {
- string match {\?*} $name;
+ string match {\?*} $name
}
proc OptVarName {item} {
- set name [OptName $item];
+ set name [OptName $item]
if {[OptIsFlag $name]} {
- return [string range $name 1 end];
+ return [string range $name 1 end]
} elseif {[OptIsOpt $name]} {
- return [string trim $name "?"];
+ return [string trim $name "?"]
} else {
- return $name;
+ return $name
}
}
proc OptType {item} {
@@ -719,13 +719,13 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
proc OptOptUsage {item {what ""}} {
return -code error "invalid description format$what: $item\n\
should be a list of {varname|-flagname ?-type? ?defaultvalue?\
- ?helpstring?}";
+ ?helpstring?}"
}
# Generate a canonical form single instruction
proc OptNewInst {state varname type typeArgs help} {
- list $state $varname [list 0 {}] $type $typeArgs $help;
+ list $state $varname [list 0 {}] $type $typeArgs $help
# ^ ^
# | |
# hasBeenSet=+ +=currentValue
@@ -733,18 +733,18 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
# Translate one item to canonical form
proc OptNormalizeOne {item} {
- set lg [Lassign $item varname arg1 arg2 arg3];
-# puts "called optnormalizeone '$item' v=($varname), lg=$lg";
- set isflag [OptIsFlag $varname];
- set isopt [OptIsOpt $varname];
+ set lg [Lassign $item varname arg1 arg2 arg3]
+# puts "called optnormalizeone '$item' v=($varname), lg=$lg"
+ set isflag [OptIsFlag $varname]
+ set isopt [OptIsOpt $varname]
if {$isflag} {
- set state "flags";
+ set state "flags"
} elseif {$isopt} {
- set state "optValue";
+ set state "optValue"
} elseif {![string equal $varname "args"]} {
- set state "value";
+ set state "value"
} else {
- set state "args";
+ set state "args"
}
# apply 'smart' 'fuzzy' logic to try to make
@@ -754,9 +754,9 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
switch $lg {
1 {
if {$isflag} {
- return [OptNewInst $state $varname boolflag false ""];
+ return [OptNewInst $state $varname boolflag false ""]
} else {
- return [OptNewInst $state $varname any "" ""];
+ return [OptNewInst $state $varname any "" ""]
}
}
2 {
@@ -776,20 +776,20 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
set help ""
set def $arg1
}
- return [OptNewInst $state $varname $type $def $help];
+ return [OptNewInst $state $varname $type $def $help]
}
3 {
# varname type value
# varname value comment
-
+
if {[regexp {^-(.+)$} $arg1 x type]} {
# flags/optValue as they are optional, need a "value",
# on the contrary, for a variable (non optional),
# default value is pointless, 'cept for choices :
if {$isflag || $isopt || ($type == "choice")} {
- return [OptNewInst $state $varname $type $arg2 ""];
+ return [OptNewInst $state $varname $type $arg2 ""]
} else {
- return [OptNewInst $state $varname $type "" $arg2];
+ return [OptNewInst $state $varname $type "" $arg2]
}
} else {
return [OptNewInst $state $varname\
@@ -798,13 +798,13 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
}
4 {
if {[regexp {^-(.+)$} $arg1 x type]} {
- return [OptNewInst $state $varname $type $arg2 $arg3];
+ return [OptNewInst $state $varname $type $arg2 $arg3]
} else {
- return -code error [OptOptUsage $item];
+ return -code error [OptOptUsage $item]
}
}
default {
- return -code error [OptOptUsage $item];
+ return -code error [OptOptUsage $item]
}
}
}
@@ -829,7 +829,7 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
OptError "ambigous option \"$arg\", choose from:" [OptSelection $desc]
}
proc OptFlagUsage {desc arg} {
- OptError "bad flag \"$arg\", must be one of" $desc;
+ OptError "bad flag \"$arg\", must be one of" $desc
}
proc OptTooManyArgs {desc arguments} {
OptError "too many arguments (unexpected argument(s): $arguments),\
@@ -838,45 +838,45 @@ proc ::tcl::OptCheckType {arg type {typeArgs ""}} {
}
proc OptParamType {item} {
if {[OptIsFlag $item]} {
- return "flag";
+ return "flag"
} else {
- return "parameter";
+ return "parameter"
}
}
proc OptBadValue {item arg {err {}}} {
-# puts "bad val err = \"$err\"";
+# puts "bad val err = \"$err\""
OptError "bad value \"$arg\" for [OptParamType $item]"\
[list $item]
}
proc OptMissingValue {descriptions} {
-# set item [OptCurDescFinal $descriptions];
- set item [OptCurDesc $descriptions];
+# set item [OptCurDescFinal $descriptions]
+ set item [OptCurDesc $descriptions]
OptError "no value given for [OptParamType $item] \"[OptName $item]\"\
(use -help for full usage) :"\
[list $item]
}
proc ::tcl::OptKeyError {prefix descKey {header 0}} {
- OptError $prefix [OptKeyGetDesc $descKey] $header;
+ OptError $prefix [OptKeyGetDesc $descKey] $header
}
# determine string length for nice tabulated output
proc OptLengths {desc nlName tlName dlName} {
- upvar $nlName nl;
- upvar $tlName tl;
- upvar $dlName dl;
+ upvar $nlName nl
+ upvar $tlName tl
+ upvar $dlName dl
foreach item $desc {
- if {[OptIsCounter $item]} continue;
+ if {[OptIsCounter $item]} continue
if {[OptIsPrg $item]} {
OptLengths $item nl tl dl
} else {
SetMax nl [string length [OptName $item]]
SetMax tl [string length [OptType $item]]
- set dv [OptTypeArgs $item];
+ set dv [OptTypeArgs $item]
if {[OptState $item] != "header"} {
- set dv "($dv)";
+ set dv "($dv)"
}
- set l [string length $dv];
+ set l [string length $dv]
# limit the space allocated to potentially big "choices"
if {([OptType $item] != "choice") || ($l<=12)} {
SetMax dl $l
@@ -890,22 +890,22 @@ proc ::tcl::OptKeyError {prefix descKey {header 0}} {
}
# output the tree
proc OptTree {desc nl tl dl} {
- set res "";
+ set res ""
foreach item $desc {
- if {[OptIsCounter $item]} continue;
+ if {[OptIsCounter $item]} continue
if {[OptIsPrg $item]} {
- append res [OptTree $item $nl $tl $dl];
+ append res [OptTree $item $nl $tl $dl]
} else {
- set dv [OptTypeArgs $item];
+ set dv [OptTypeArgs $item]
if {[OptState $item] != "header"} {
- set dv "($dv)";
+ set dv "($dv)"
}
- append res [format "\n %-*s %-*s %-*s %s" \
+ append res [string trimright [format "\n %-*s %-*s %-*s %s" \
$nl [OptName $item] $tl [OptType $item] \
- $dl $dv [OptHelp $item]]
+ $dl $dv [OptHelp $item]]]
}
}
- return $res;
+ return $res
}
# Give nice usage string
@@ -913,13 +913,13 @@ proc ::tcl::OptError {prefix desc {header 0}} {
# determine length
if {$header} {
# add faked instruction
- set h [list [OptNewInst header Var/FlagName Type Value Help]];
- lappend h [OptNewInst header ------------ ---- ----- ----];
- lappend h [OptNewInst header {( -help} "" "" {gives this help )}]
+ set h [list [OptNewInst header Var/FlagName Type Value Help]]
+ lappend h [OptNewInst header ------------ ---- ----- ----]
+ lappend h [OptNewInst header {(-help} "" "" {gives this help)}]
set desc [concat $h $desc]
}
OptLengths $desc nl tl dl
- # actually output
+ # actually output
return "$prefix[OptTree $desc $nl $tl $dl]"
}
@@ -943,105 +943,105 @@ proc ::tcl::Lempty {list} {
# Gets the value of one leaf of a lists tree
proc ::tcl::Lget {list indexLst} {
if {[llength $indexLst] <= 1} {
- return [lindex $list $indexLst];
+ return [lindex $list $indexLst]
}
- Lget [lindex $list [lindex $indexLst 0]] [lrange $indexLst 1 end];
+ Lget [lindex $list [lindex $indexLst 0]] [lrange $indexLst 1 end]
}
# Sets the value of one leaf of a lists tree
# (we use the version that does not create the elements because
# it would be even slower... needs to be written in C !)
# (nb: there is a non trivial recursive problem with indexes 0,
# which appear because there is no difference between a list
-# of 1 element and 1 element alone : [list "a"] == "a" while
+# of 1 element and 1 element alone : [list "a"] == "a" while
# it should be {a} and [listp a] should be 0 while [listp {a b}] would be 1
# and [listp "a b"] maybe 0. listp does not exist either...)
proc ::tcl::Lvarset {listName indexLst newValue} {
- upvar $listName list;
+ upvar $listName list
if {[llength $indexLst] <= 1} {
- Lvarset1nc list $indexLst $newValue;
+ Lvarset1nc list $indexLst $newValue
} else {
- set idx [lindex $indexLst 0];
- set targetList [lindex $list $idx];
+ set idx [lindex $indexLst 0]
+ set targetList [lindex $list $idx]
# reduce refcount on targetList (not really usefull now,
# could be with optimizing compiler)
-# Lvarset1 list $idx {};
+# Lvarset1 list $idx {}
# recursively replace in targetList
- Lvarset targetList [lrange $indexLst 1 end] $newValue;
+ Lvarset targetList [lrange $indexLst 1 end] $newValue
# put updated sub list back in the tree
- Lvarset1nc list $idx $targetList;
+ Lvarset1nc list $idx $targetList
}
}
# Set one cell to a value, eventually create all the needed elements
# (on level-1 of lists)
variable emptyList {}
proc ::tcl::Lvarset1 {listName index newValue} {
- upvar $listName list;
+ upvar $listName list
if {$index < 0} {return -code error "invalid negative index"}
- set lg [llength $list];
+ set lg [llength $list]
if {$index >= $lg} {
- variable emptyList;
+ variable emptyList
for {set i $lg} {$i<$index} {incr i} {
- lappend list $emptyList;
+ lappend list $emptyList
}
- lappend list $newValue;
+ lappend list $newValue
} else {
- set list [lreplace $list $index $index $newValue];
+ set list [lreplace $list $index $index $newValue]
}
}
# same as Lvarset1 but no bound checking / creation
proc ::tcl::Lvarset1nc {listName index newValue} {
- upvar $listName list;
- set list [lreplace $list $index $index $newValue];
+ upvar $listName list
+ set list [lreplace $list $index $index $newValue]
}
# Increments the value of one leaf of a lists tree
# (which must exists)
proc ::tcl::Lvarincr {listName indexLst {howMuch 1}} {
- upvar $listName list;
+ upvar $listName list
if {[llength $indexLst] <= 1} {
- Lvarincr1 list $indexLst $howMuch;
+ Lvarincr1 list $indexLst $howMuch
} else {
- set idx [lindex $indexLst 0];
- set targetList [lindex $list $idx];
+ set idx [lindex $indexLst 0]
+ set targetList [lindex $list $idx]
# reduce refcount on targetList
- Lvarset1nc list $idx {};
+ Lvarset1nc list $idx {}
# recursively replace in targetList
- Lvarincr targetList [lrange $indexLst 1 end] $howMuch;
+ Lvarincr targetList [lrange $indexLst 1 end] $howMuch
# put updated sub list back in the tree
- Lvarset1nc list $idx $targetList;
+ Lvarset1nc list $idx $targetList
}
}
# Increments the value of one cell of a list
proc ::tcl::Lvarincr1 {listName index {howMuch 1}} {
- upvar $listName list;
- set newValue [expr {[lindex $list $index]+$howMuch}];
- set list [lreplace $list $index $index $newValue];
- return $newValue;
+ upvar $listName list
+ set newValue [expr {[lindex $list $index]+$howMuch}]
+ set list [lreplace $list $index $index $newValue]
+ return $newValue
}
# Removes the first element of a list
# and returns the new list value
proc ::tcl::Lvarpop1 {listName} {
- upvar $listName list;
- set list [lrange $list 1 end];
+ upvar $listName list
+ set list [lrange $list 1 end]
}
# Same but returns the removed element
# (Like the tclX version)
proc ::tcl::Lvarpop {listName} {
- upvar $listName list;
- set el [lindex $list 0];
- set list [lrange $list 1 end];
- return $el;
+ upvar $listName list
+ set el [lindex $list 0]
+ set list [lrange $list 1 end]
+ return $el
}
# Assign list elements to variables and return the length of the list
proc ::tcl::Lassign {list args} {
# faster than direct blown foreach (which does not byte compile)
- set i 0;
- set lg [llength $list];
+ set i 0
+ set lg [llength $list]
foreach vname $args {
if {$i>=$lg} break
- uplevel 1 [list ::set $vname [lindex $list $i]];
- incr i;
+ uplevel 1 [list ::set $vname [lindex $list $i]]
+ incr i
}
- return $lg;
+ return $lg
}
# Misc utilities
diff --git a/library/opt/pkgIndex.tcl b/library/opt/pkgIndex.tcl
index c5d3635..107d4c6 100644
--- a/library/opt/pkgIndex.tcl
+++ b/library/opt/pkgIndex.tcl
@@ -9,4 +9,4 @@
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.2]} {return}
-package ifneeded opt 0.4.5 [list source [file join $dir optparse.tcl]]
+package ifneeded opt 0.4.6 [list source [file join $dir optparse.tcl]]
diff --git a/library/package.tcl b/library/package.tcl
index 06f619c..52daa0e 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,11 +57,10 @@ proc tcl::Pkg::CompareExtension { fileName {ext {}} } {
}
# pkg_mkIndex --
-# This procedure creates a package index in a given directory. The
-# package index consists of a "pkgIndex.tcl" file whose contents are
-# a Tcl script that sets up package information with "package require"
-# commands. The commands describe all of the packages defined by the
-# files given as arguments.
+# This procedure creates a package index in a given directory. The package
+# index consists of a "pkgIndex.tcl" file whose contents are a Tcl script that
+# sets up package information with "package require" commands. The commands
+# describe all of the packages defined by the files given as arguments.
#
# Arguments:
# -direct (optional) If this flag is present, the generated
@@ -82,7 +81,7 @@ proc tcl::Pkg::CompareExtension { fileName {ext {}} } {
# dir.
proc pkg_mkIndex {args} {
- set usage {"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"};
+ set usage {"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"}
set argCount [llength $args]
if {$argCount < 1} {
@@ -128,20 +127,21 @@ proc pkg_mkIndex {args} {
set dir [lindex $args $idx]
set patternList [lrange $args [expr {$idx + 1}] end]
- if {[llength $patternList] == 0} {
+ if {![llength $patternList]} {
set patternList [list "*.tcl" "*[info sharedlibextension]"]
}
- if {[catch {
- glob -directory $dir -tails -types {r f} -- {*}$patternList
- } fileList o]} {
- return -options $o $fileList
+ try {
+ set fileList [glob -directory $dir -tails -types {r f} -- \
+ {*}$patternList]
+ } on error {msg opt} {
+ return -options $opt $msg
}
foreach file $fileList {
# For each file, figure out what commands and packages it provides.
# To do this, create a child interpreter, load the file into the
- # interpreter, and get a list of the new commands and packages
- # that are defined.
+ # interpreter, and get a list of the new commands and packages that
+ # are defined.
if {$file eq "pkgIndex.tcl"} {
continue
@@ -163,20 +163,23 @@ proc pkg_mkIndex {args} {
}
}
foreach pkg [info loaded] {
- if {! [string match -nocase $loadPat [lindex $pkg 1]]} {
+ if {![string match -nocase $loadPat [lindex $pkg 1]]} {
continue
}
if {$doVerbose} {
tclLog "package [lindex $pkg 1] matches '$loadPat'"
}
- if {[catch {
+ try {
load [lindex $pkg 0] [lindex $pkg 1] $c
- } err]} {
+ } on error err {
if {$doVerbose} {
- tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err"
+ tclLog "warning: load [lindex $pkg 0]\
+ [lindex $pkg 1]\nfailed with: $err"
+ }
+ } on ok {} {
+ if {$doVerbose} {
+ tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
}
- } elseif {$doVerbose} {
- tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
}
if {[lindex $pkg 1] eq "Tk"} {
# Withdraw . if Tk was loaded, to avoid showing a window.
@@ -185,21 +188,25 @@ proc pkg_mkIndex {args} {
}
$c eval {
- # Stub out the package command so packages can
- # require other packages.
+ # Stub out the package command so packages can require other
+ # packages.
rename package __package_orig
proc package {what args} {
switch -- $what {
- require { return ; # ignore transitive requires }
- default { __package_orig $what {*}$args }
+ require {
+ return; # Ignore transitive requires
+ }
+ default {
+ __package_orig $what {*}$args
+ }
}
}
proc tclPkgUnknown args {}
package unknown tclPkgUnknown
- # Stub out the unknown command so package can call
- # into each other during their initialilzation.
+ # Stub out the unknown command so package can call into each other
+ # during their initialilzation.
proc unknown {args} {}
@@ -207,9 +214,9 @@ proc pkg_mkIndex {args} {
proc auto_import {args} {}
- # reserve the ::tcl namespace for support procs
- # and temporary variables. This might make it awkward
- # to generate a pkgIndex.tcl file for the ::tcl namespace.
+ # reserve the ::tcl namespace for support procs and temporary
+ # variables. This might make it awkward to generate a
+ # pkgIndex.tcl file for the ::tcl namespace.
namespace eval ::tcl {
variable dir ;# Current directory being processed
@@ -230,22 +237,22 @@ proc pkg_mkIndex {args} {
$c eval [list set ::tcl::file $file]
$c eval [list set ::tcl::direct $direct]
- # Download needed procedures into the slave because we've
- # just deleted the unknown procedure. This doesn't handle
- # procedures with default arguments.
+ # Download needed procedures into the slave because we've just deleted
+ # the unknown procedure. This doesn't handle procedures with default
+ # arguments.
foreach p {::tcl::Pkg::CompareExtension} {
$c eval [list namespace eval [namespace qualifiers $p] {}]
$c eval [list proc $p [info args $p] [info body $p]]
}
- if {[catch {
+ try {
$c eval {
set ::tcl::debug "loading or sourcing"
- # we need to track command defined by each package even in
- # the -direct case, because they are needed internally by
- # the "partial pkgIndex.tcl" step above.
+ # we need to track command defined by each package even in the
+ # -direct case, because they are needed internally by the
+ # "partial pkgIndex.tcl" step above.
proc ::tcl::GetAllNamespaces {{root ::}} {
set list $root
@@ -267,18 +274,17 @@ proc pkg_mkIndex {args} {
}
set ::tcl::origCmds [info commands]
- # Try to load the file if it has the shared library
- # extension, otherwise source it. It's important not to
- # try to load files that aren't shared libraries, because
- # on some systems (like SunOS) the loader will abort the
- # whole application when it gets an error.
+ # Try to load the file if it has the shared library extension,
+ # otherwise source it. It's important not to try to load
+ # files that aren't shared libraries, because on some systems
+ # (like SunOS) the loader will abort the whole application
+ # when it gets an error.
if {[::tcl::Pkg::CompareExtension $::tcl::file [info sharedlibextension]]} {
- # The "file join ." command below is necessary.
- # Without it, if the file name has no \'s and we're
- # on UNIX, the load command will invoke the
- # LD_LIBRARY_PATH search mechanism, which could cause
- # the wrong file to be used.
+ # The "file join ." command below is necessary. Without
+ # it, if the file name has no \'s and we're on UNIX, the
+ # load command will invoke the LD_LIBRARY_PATH search
+ # mechanism, which could cause the wrong file to be used.
set ::tcl::debug loading
load [file join $::tcl::dir $::tcl::file]
@@ -289,22 +295,21 @@ 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
}
@@ -313,18 +318,19 @@ 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)
}
@@ -332,8 +338,8 @@ proc pkg_mkIndex {args} {
}
}
- # Look through the packages that appeared, and if there is
- # a version provided, then record it
+ # Look through the packages that appeared, and if there is a
+ # version provided, then record it
foreach ::tcl::x [package names] {
if {[package provide $::tcl::x] ne ""
@@ -343,12 +349,12 @@ proc pkg_mkIndex {args} {
}
}
}
- } msg] == 1} {
+ } on error msg {
set what [$c eval set ::tcl::debug]
if {$doVerbose} {
tclLog "warning: error while $what $file: $msg"
}
- } else {
+ } on ok {} {
set what [$c eval set ::tcl::debug]
if {$doVerbose} {
tclLog "successful $what of $file"
@@ -357,7 +363,7 @@ proc pkg_mkIndex {args} {
set cmds [lsort [$c eval array names ::tcl::newCmds]]
set pkgs [$c eval set ::tcl::newPkgs]
if {$doVerbose} {
- if { !$direct } {
+ if {!$direct} {
tclLog "commands provided were $cmds"
}
tclLog "packages provided were $pkgs"
@@ -393,7 +399,7 @@ proc pkg_mkIndex {args} {
lappend cmd ::tcl::Pkg::Create -name $name -version $version
foreach spec [lsort -index 0 $files($pkg)] {
foreach {file type procs} $spec {
- if { $direct } {
+ if {$direct} {
set procs {}
}
lappend cmd "-$type" [list $file $procs]
@@ -408,11 +414,10 @@ proc pkg_mkIndex {args} {
}
# tclPkgSetup --
-# This is a utility procedure use by pkgIndex.tcl files. It is invoked
-# as part of a "package ifneeded" script. It calls "package provide"
-# to indicate that a package is available, then sets entries in the
-# auto_index array so that the package's files will be auto-loaded when
-# the commands are used.
+# This is a utility procedure use by pkgIndex.tcl files. It is invoked as
+# part of a "package ifneeded" script. It calls "package provide" to indicate
+# that a package is available, then sets entries in the auto_index array so
+# that the package's files will be auto-loaded when the commands are used.
#
# Arguments:
# dir - Directory containing all the files for this package.
@@ -437,18 +442,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.
@@ -461,12 +466,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]
@@ -474,24 +479,22 @@ proc tclPkgUnknown {name args} {
}
set tclSeenPath($dir) 1
- # we can't use glob in safe interps, so enclose the following
- # in a catch statement, where we get the pkgIndex files out
- # of the subdirectories
+ # we can't use glob in safe interps, so enclose the following in a
+ # catch statement, where we get the pkgIndex files out of the
+ # subdirectories
catch {
foreach file [glob -directory $dir -join -nocomplain \
* pkgIndex.tcl] {
set dir [file dirname $file]
if {![info exists procdDirs($dir)]} {
- set code [catch {source $file} msg opt]
- if {$code == 1 &&
- [lindex [dict get $opt -errorcode] 0] eq "POSIX" &&
- [lindex [dict get $opt -errorcode] 1] eq "EACCES"} {
+ try {
+ source $file
+ } trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
- }
- if {$code} {
+ } on error msg {
tclLog "error reading package index file $file: $msg"
- } else {
+ } on ok {} {
set procdDirs($dir) 1
}
}
@@ -500,18 +503,16 @@ 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])} {
- set code [catch {source $file} msg opt]
- if {$code == 1 &&
- [lindex [dict get $opt -errorcode] 0] eq "POSIX" &&
- [lindex [dict get $opt -errorcode] 1] eq "EACCES"} {
+ try {
+ source $file
+ } trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
- }
- if {$code} {
+ } on error msg {
tclLog "error reading package index file $file: $msg"
- } else {
+ } on ok {} {
set procdDirs($dir) 1
}
}
@@ -519,12 +520,11 @@ proc tclPkgUnknown {name args} {
set use_path [lrange $use_path 0 end-1]
- # Check whether any of the index scripts we [source]d above
- # set a new value for $::auto_path. If so, then find any
- # new directories on the $::auto_path, and lappend them to
- # the $use_path we are working from. This gives index scripts
- # the (arguably unwise) power to expand the index script search
- # path while the search is in progress.
+ # Check whether any of the index scripts we [source]d above set a new
+ # value for $::auto_path. If so, then find any new directories on the
+ # $::auto_path, and lappend them to the $use_path we are working from.
+ # This gives index scripts the (arguably unwise) power to expand the
+ # index script search path while the search is in progress.
set index 0
if {[llength $old_path] == [llength $auto_path]} {
foreach dir $auto_path old $old_path {
@@ -536,11 +536,11 @@ proc tclPkgUnknown {name args} {
}
}
- # $index now points to the first element of $auto_path that
- # has changed, or the beginning if $auto_path has changed length
- # Scan the new elements of $auto_path for directories to add to
- # $use_path. Don't add directories we've already seen, or ones
- # already on the $use_path.
+ # $index now points to the first element of $auto_path that has
+ # changed, or the beginning if $auto_path has changed length Scan the
+ # new elements of $auto_path for directories to add to $use_path.
+ # Don't add directories we've already seen, or ones already on the
+ # $use_path.
foreach dir [lrange $auto_path $index end] {
if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} {
lappend use_path $dir
@@ -551,9 +551,9 @@ proc tclPkgUnknown {name args} {
}
# tcl::MacOSXPkgUnknown --
-# This procedure extends the "package unknown" function for MacOSX.
-# It scans the Resources/Scripts directories of the immediate children
-# of the auto_path directories for pkgIndex files.
+# This procedure extends the "package unknown" function for MacOSX. It scans
+# the Resources/Scripts directories of the immediate children of the auto_path
+# directories for pkgIndex files.
#
# Arguments:
# original - original [package unknown] procedure
@@ -562,7 +562,6 @@ proc tclPkgUnknown {name args} {
# exact - Either "-exact" or omitted. Not used.
proc tcl::MacOSXPkgUnknown {original name args} {
-
# First do the cross-platform default search
uplevel 1 $original [linsert $args 0 $name]
@@ -572,8 +571,8 @@ proc tcl::MacOSXPkgUnknown {original name args} {
if {![info exists auto_path]} {
return
}
- # Cache the auto_path, because it may change while we run through
- # the first set of pkgIndex.tcl files
+ # Cache the auto_path, because it may change while we run through the
+ # first set of pkgIndex.tcl files
set old_path [set use_path $auto_path]
while {[llength $use_path]} {
set dir [lindex $use_path end]
@@ -590,28 +589,25 @@ proc tcl::MacOSXPkgUnknown {original name args} {
* Resources Scripts pkgIndex.tcl] {
set dir [file dirname $file]
if {![info exists procdDirs($dir)]} {
- set code [catch {source $file} msg opt]
- if {$code == 1 &&
- [lindex [dict get $opt -errorcode] 0] eq "POSIX" &&
- [lindex [dict get $opt -errorcode] 1] eq "EACCES"} {
+ try {
+ source $file
+ } trap {POSIX EACCES} {} {
# $file was not readable; silently ignore
continue
- }
- if {$code} {
+ } on error msg {
tclLog "error reading package index file $file: $msg"
- } else {
+ } on ok {} {
set procdDirs($dir) 1
}
}
}
set use_path [lrange $use_path 0 end-1]
- # Check whether any of the index scripts we [source]d above
- # set a new value for $::auto_path. If so, then find any
- # new directories on the $::auto_path, and lappend them to
- # the $use_path we are working from. This gives index scripts
- # the (arguably unwise) power to expand the index script search
- # path while the search is in progress.
+ # Check whether any of the index scripts we [source]d above set a new
+ # value for $::auto_path. If so, then find any new directories on the
+ # $::auto_path, and lappend them to the $use_path we are working from.
+ # This gives index scripts the (arguably unwise) power to expand the
+ # index script search path while the search is in progress.
set index 0
if {[llength $old_path] == [llength $auto_path]} {
foreach dir $auto_path old $old_path {
@@ -623,11 +619,11 @@ proc tcl::MacOSXPkgUnknown {original name args} {
}
}
- # $index now points to the first element of $auto_path that
- # has changed, or the beginning if $auto_path has changed length
- # Scan the new elements of $auto_path for directories to add to
- # $use_path. Don't add directories we've already seen, or ones
- # already on the $use_path.
+ # $index now points to the first element of $auto_path that has
+ # changed, or the beginning if $auto_path has changed length Scan the
+ # new elements of $auto_path for directories to add to $use_path.
+ # Don't add directories we've already seen, or ones already on the
+ # $use_path.
foreach dir [lrange $auto_path $index end] {
if {![info exists tclSeenPath($dir)] && ($dir ni $use_path)} {
lappend use_path $dir
@@ -653,12 +649,12 @@ proc tcl::MacOSXPkgUnknown {original name args} {
#
# Any number of -load and -source parameters may be
# specified, so long as there is at least one -load or
-# -source parameter. If the procs component of a
-# module specifier is left off, that module will be
-# set up for direct loading; otherwise, it will be
-# set up for lazy loading. If both -source and -load
-# are specified, the -load'ed files will be loaded
-# first, followed by the -source'd files.
+# -source parameter. If the procs component of a module
+# specifier is left off, that module will be set up for
+# direct loading; otherwise, it will be set up for lazy
+# loading. If both -source and -load are specified, the
+# -load'ed files will be loaded first, followed by the
+# -source'd files.
#
# Results:
# An appropriate "package ifneeded" statement for the package.
@@ -676,10 +672,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 {}}
@@ -690,14 +686,14 @@ proc ::tcl::Pkg::Create {args} {
switch -glob -- $flag {
"-name" -
"-version" {
- if { $i >= $len } {
+ if {$i >= $len} {
error [format $err(valueMissing) $flag]
}
set opts($flag) [lindex $args $i]
}
"-source" -
"-load" {
- if { $i >= $len } {
+ if {$i >= $len} {
error [format $err(valueMissing) $flag]
}
lappend opts($flag) [lindex $args $i]
@@ -709,20 +705,20 @@ proc ::tcl::Pkg::Create {args} {
}
# Validate the parameters
- if { [llength $opts(-name)] == 0 } {
+ if {![llength $opts(-name)]} {
error [format $err(valueMissing) "-name"]
}
- if { [llength $opts(-version)] == 0 } {
+ if {![llength $opts(-version)]} {
error [format $err(valueMissing) "-version"]
}
-
- if { [llength $opts(-source)] == 0 && [llength $opts(-load)] == 0 } {
+
+ if {!([llength $opts(-source)] || [llength $opts(-load)])} {
error $err(noLoadOrSource)
}
# OK, now everything is good. Generate the package ifneeded statment.
set cmdline "package ifneeded $opts(-name) $opts(-version) "
-
+
set cmdList {}
set lazyFileList {}
@@ -740,7 +736,7 @@ proc ::tcl::Pkg::Create {args} {
}
}
- if { [llength $lazyFileList] > 0 } {
+ if {[llength $lazyFileList]} {
lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\
$opts(-version) [list $lazyFileList]\]"
}
@@ -748,4 +744,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/reg/pkgIndex.tcl b/library/reg/pkgIndex.tcl
index 1241f2a..55af4b3 100755
--- a/library/reg/pkgIndex.tcl
+++ b/library/reg/pkgIndex.tcl
@@ -1,9 +1,9 @@
-if {![package vsatisfies [package provide Tcl] 8]} return
-if {[info sharedlibextension] != ".dll"} return
-if {[info exists ::tcl_platform(debug)]} {
- package ifneeded registry 1.2.2 \
- [list load [file join $dir tclreg12g.dll] registry]
+if {([info commands ::tcl::pkgconfig] eq "")
+ || ([info sharedlibextension] ne ".dll")} return
+if {[::tcl::pkgconfig get debug]} {
+ package ifneeded registry 1.3.0 \
+ [list load [file join $dir tclreg13g.dll] registry]
} else {
- package ifneeded registry 1.2.2 \
- [list load [file join $dir tclreg12.dll] registry]
+ package ifneeded registry 1.3.0 \
+ [list load [file join $dir tclreg13.dll] registry]
}
diff --git a/library/safe.tcl b/library/safe.tcl
index 1a340a1..394aa97 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,10 +151,18 @@ proc ::safe::interpConfigure {args} {
set item [::tcl::OptCurDesc $desc]
set name [::tcl::OptName $item]
switch -exact -- $name {
- -accessPath {return [list -accessPath $state(access_path)]}
- -statics {return [list -statics $state(staticsok)]}
- -nested {return [list -nested $state(nestedok)]}
- -deleteHook {return [list -deleteHook $state(cleanupHook)]}
+ -accessPath {
+ return [list -accessPath $state(access_path)]
+ }
+ -statics {
+ return [list -statics $state(staticsok)]
+ }
+ -nested {
+ return [list -nested $state(nestedok)]
+ }
+ -deleteHook {
+ return [list -deleteHook $state(cleanupHook)]
+ }
-noStatics {
# it is most probably a set in fact but we would need
# then to jump to the set part and it is not *sure*
@@ -192,7 +200,7 @@ proc ::safe::interpConfigure {args} {
if {
![::tcl::OptProcArgGiven -statics]
&& ![::tcl::OptProcArgGiven -noStatics]
- } {
+ } then {
set statics $state(staticsok)
} else {
set statics [InterpStatics]
@@ -200,7 +208,7 @@ proc ::safe::interpConfigure {args} {
if {
[::tcl::OptProcArgGiven -nested] ||
[::tcl::OptProcArgGiven -nestedLoadOk]
- } {
+ } then {
set nested [InterpNested]
} else {
set nested $state(nestedok)
@@ -238,7 +246,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.
@@ -249,7 +257,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
@@ -424,7 +432,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
@@ -457,8 +465,19 @@ proc ::safe::InterpInit {
# This alias lets the slave have access to a subset of the 'file'
# command functionality.
- AliasSubset $slave file \
- file dir.* join root.* ext.* tail path.* split
+ ::interp expose $slave file
+ foreach subcommand {dirname extension rootname tail} {
+ ::interp alias $slave ::tcl::file::$subcommand {} \
+ ::safe::AliasFileSubcommand $slave $subcommand
+ }
+ foreach subcommand {
+ atime attributes copy delete executable exists isdirectory isfile
+ link lstat mtime mkdir nativename normalize owned readable readlink
+ rename size stat tempfile type volumes writable
+ } {
+ ::interp alias $slave ::tcl::file::$subcommand {} \
+ ::safe::BadSubcommand $slave file $subcommand
+ }
# Subcommands of info
foreach {subcommand alias} {
@@ -475,16 +494,16 @@ proc ::safe::InterpInit {
if {[catch {::interp eval $slave {
source [file join $tcl_library init.tcl]
- }} msg]} {
+ }} msg opt]} {
Log $slave "can't source init.tcl ($msg)"
- return -code error "can't source init.tcl into slave $slave ($msg)"
+ return -options $opt "can't source init.tcl into slave $slave ($msg)"
}
if {[catch {::interp eval $slave {
source [file join $tcl_library tm.tcl]
- }} msg]} {
+ }} msg opt]} {
Log $slave "can't source tm.tcl ($msg)"
- return -code error "can't source tm.tcl into slave $slave ($msg)"
+ return -options $opt "can't source tm.tcl into slave $slave ($msg)"
}
# Sync the paths used to search for Tcl modules. This can be done only
@@ -538,9 +557,9 @@ proc ::safe::interpDelete {slave} {
# remove the hook now, otherwise if the hook calls us somehow,
# we'll loop
unset state(cleanupHook)
- if {[catch {
+ try {
{*}$hook $slave
- } err]} {
+ } on error err {
Log $slave "Delete hook error ($err)"
}
}
@@ -563,7 +582,7 @@ proc ::safe::interpDelete {slave} {
return
}
-# Set (or get) the logging mecanism
+# Set (or get) the logging mecanism
proc ::safe::setLogCmd {args} {
variable Log
@@ -657,7 +676,19 @@ proc ::safe::CheckFileName {slave file} {
}
}
+# AliasFileSubcommand handles selected subcommands of [file] in safe
+# interpreters that are *almost* safe. In particular, it just acts to
+# prevent discovery of what home directories exist.
+
+proc ::safe::AliasFileSubcommand {slave subcommand name} {
+ if {[string match ~* $name]} {
+ set name ./$name
+ }
+ tailcall ::interp invokehidden $slave tcl:file:$subcommand $name
+}
+
# AliasGlob is the target of the "glob" alias in safe interpreters.
+
proc ::safe::AliasGlob {slave args} {
Log $slave "GLOB ! $args" NOTICE
set cmd {}
@@ -721,14 +752,12 @@ proc ::safe::AliasGlob {slave args} {
# access path of that slave. Done after basic argument processing so that
# we know if -nocomplain is set.
if {$got(-directory)} {
- if {[catch {
+ try {
set dir [TranslatePath $slave $virtualdir]
DirInAccessPath $slave $dir
- } msg]} {
+ } on error msg {
Log $slave $msg
- if {$got(-nocomplain)} {
- return
- }
+ if {$got(-nocomplain)} return
return -code error "permission denied"
}
lappend cmd -directory $dir
@@ -744,26 +773,27 @@ proc ::safe::AliasGlob {slave args} {
foreach opt [lrange $args $at end] {
if {![regexp $dirPartRE $opt -> thedir thefile]} {
set thedir .
+ } elseif {[string match ~* $thedir]} {
+ set thedir ./$thedir
}
- if {$thedir eq "*"} {
+ if {$thedir eq "*" &&
+ ($thefile eq "pkgIndex.tcl" || $thefile eq "*.tm")} {
set mapped 0
foreach d [glob -directory [TranslatePath $slave $virtualdir] \
-types d -tails *] {
catch {
DirInAccessPath $slave \
[TranslatePath $slave [file join $virtualdir $d]]
- if {$thefile eq "pkgIndex.tcl" || $thefile eq "*.tm"} {
- lappend cmd [file join $d $thefile]
- set mapped 1
- }
+ lappend cmd [file join $d $thefile]
+ set mapped 1
}
}
if {$mapped} continue
}
- if {[catch {
- set thedir [file join $virtualdir $thedir]
- DirInAccessPath $slave [TranslatePath $slave $thedir]
- } msg]} {
+ try {
+ DirInAccessPath $slave [TranslatePath $slave \
+ [file join $virtualdir $thedir]]
+ } on error msg {
Log $slave $msg
if {$got(-nocomplain)} continue
return -code error "permission denied"
@@ -776,19 +806,19 @@ proc ::safe::AliasGlob {slave args} {
if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} {
return
}
- if {[catch {
- ::interp invokehidden $slave glob {*}$cmd
- } msg]} {
+ try {
+ set entries [::interp invokehidden $slave glob {*}$cmd]
+ } on error msg {
Log $slave $msg
return -code error "script error"
}
- Log $slave "GLOB < $msg" NOTICE
+ Log $slave "GLOB < $entries" NOTICE
# Translate path back to what the slave should see.
set res {}
set l [string length $dir]
- foreach p $msg {
+ foreach p $entries {
if {[string equal -length $l $dir $p]} {
set p [string replace $p 0 [expr {$l-1}] $virtualdir]
}
@@ -852,6 +882,7 @@ proc ::safe::AliasSource {slave args} {
# because we want to control [info script] in the slave so information
# doesn't leak so much. [Bug 2913625]
set old [::interp eval $slave {info script}]
+ set replacementMsg "script error"
set code [catch {
set f [open $realfile]
fconfigure $f -eofchar \032
@@ -861,14 +892,17 @@ proc ::safe::AliasSource {slave args} {
set contents [read $f]
close $f
::interp eval $slave [list info script $file]
- ::interp eval $slave $contents
} msg opt]
+ if {$code == 0} {
+ set code [catch {::interp eval $slave $contents} msg opt]
+ set replacementMsg $msg
+ }
catch {interp eval $slave [list info script $old]}
# Note that all non-errors are fine result codes from [source], so we must
# take a little care to do it properly. [Bug 2923613]
if {$code == 1} {
Log $slave $msg
- return -code error "script error"
+ return -code error $replacementMsg
}
return -code $code -options $opt $msg
}
@@ -918,30 +952,28 @@ proc ::safe::AliasLoad {slave file args} {
# file loading
# get the real path from the virtual one.
- if {[catch {
+ try {
set file [TranslatePath $slave $file]
- } msg]} {
+ } on error msg {
Log $slave $msg
return -code error "permission denied"
}
# check the translated path
- if {[catch {
+ try {
FileInAccessPath $slave $file
- } msg]} {
+ } on error msg {
Log $slave $msg
return -code error "permission denied (path)"
}
}
- if {[catch {
- ::interp invokehidden $slave load $file $package $target
- } msg]} {
+ try {
+ return [::interp invokehidden $slave load $file $package $target]
+ } on error msg {
Log $slave $msg
return -code error $msg
}
-
- return $msg
}
# FileInAccessPath raises an error if the file is not found in the list of
@@ -986,59 +1018,33 @@ proc ::safe::DirInAccessPath {slave dir} {
}
}
-# This procedure enables access from a safe interpreter to only a subset
-# of the subcommands of a command:
+# This procedure is used to report an attempt to use an unsafe member of an
+# ensemble command.
-proc ::safe::Subset {slave command okpat args} {
- set subcommand [lindex $args 0]
- if {[regexp $okpat $subcommand]} {
- return [$command {*}$args]
- }
+proc ::safe::BadSubcommand {slave command subcommand args} {
set msg "not allowed to invoke subcommand $subcommand of $command"
Log $slave $msg
- return -code error $msg
-}
-
-# This procedure installs an alias in a slave that invokes "safesubset" in
-# the master to execute allowed subcommands. It precomputes the pattern of
-# allowed subcommands; you can use wildcards in the pattern if you wish to
-# allow subcommand abbreviation.
-#
-# Syntax is: AliasSubset slave alias target subcommand1 subcommand2...
-
-proc ::safe::AliasSubset {slave alias target args} {
- set pat "^([join $args |])\$"
- ::interp alias $slave $alias {}\
- [namespace current]::Subset $slave $target $pat
+ return -code error -errorcode {TCL SAFE SUBCOMMAND} $msg
}
# AliasEncoding is the target of the "encoding" alias in safe interpreters.
proc ::safe::AliasEncoding {slave option args} {
- # Careful; do not want empty option to get through to the [string equal]
- if {[regexp {^(name.*|convert.*|)$} $option]} {
- return [::interp invokehidden $slave encoding $option {*}$args]
- }
-
- if {[string equal -length [string length $option] $option "system"]} {
- if {[llength $args] == 0} {
- # passed all the tests , lets source it:
- if {[catch {
- set sysenc [::interp invokehidden $slave encoding system]
- } msg]} {
- Log $slave $msg
- return -code error "script error"
- }
- return $sysenc
+ # Note that [encoding dirs] is not supported in safe slaves at all
+ set subcommands {convertfrom convertto names system}
+ try {
+ set option [tcl::prefix match -error [list -level 1 -errorcode \
+ [list TCL LOOKUP INDEX option $option]] $subcommands $option]
+ # Special case: [encoding system] ok, but [encoding system foo] not
+ if {$option eq "system" && [llength $args]} {
+ return -code error -errorcode {TCL WRONGARGS} \
+ "wrong # args: should be \"encoding system\""
}
- set msg "wrong # args: should be \"encoding system\""
- set code {TCL WRONGARGS}
- } else {
- set msg "bad option \"$option\": must be convertfrom, convertto, names, or system"
- set code [list TCL LOOKUP INDEX option $option]
+ } on error {msg options} {
+ Log $slave $msg
+ return -options $options $msg
}
- Log $slave $msg
- return -code error -errorcode $code $msg
+ tailcall ::interp invokehidden $slave encoding $option {*}$args
}
# Various minor hiding of platform features. [Bug 2913625]
diff --git a/library/tclIndex b/library/tclIndex
index 010616f..26603c1 100644
--- a/library/tclIndex
+++ b/library/tclIndex
@@ -1,4 +1,5 @@
# Tcl autoload index file, version 2.0
+# -*- tcl -*-
# This file is generated by the "auto_mkindex" command
# and sourced to set up indexing information for one or
# more commands. Typically each line is a command that
@@ -48,29 +49,15 @@ set auto_index(::safe::AddSubDirs) [list source [file join $dir safe.tcl]]
set auto_index(::safe::interpDelete) [list source [file join $dir safe.tcl]]
set auto_index(::safe::setLogCmd) [list source [file join $dir safe.tcl]]
set auto_index(::safe::SyncAccessPath) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::InterpStateName) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::IsInterp) [list source [file join $dir safe.tcl]]
set auto_index(::safe::PathToken) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::PathListName) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::VirtualPathListName) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::PathNumberName) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::StaticsOkName) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::NestedOkName) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::Toplevel) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::Set) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::Lappend) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::Unset) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::Exists) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::GetAccessPath) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::StaticsOk) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::NestedOk) [list source [file join $dir safe.tcl]]
-set auto_index(::safe::DeleteHookName) [list source [file join $dir safe.tcl]]
set auto_index(::safe::TranslatePath) [list source [file join $dir safe.tcl]]
set auto_index(::safe::Log) [list source [file join $dir safe.tcl]]
set auto_index(::safe::CheckFileName) [list source [file join $dir safe.tcl]]
+set auto_index(::safe::AliasGlob) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AliasSource) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AliasLoad) [list source [file join $dir safe.tcl]]
set auto_index(::safe::FileInAccessPath) [list source [file join $dir safe.tcl]]
+set auto_index(::safe::DirInAccessPath) [list source [file join $dir safe.tcl]]
set auto_index(::safe::Subset) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AliasSubset) [list source [file join $dir safe.tcl]]
set auto_index(::safe::AliasEncoding) [list source [file join $dir safe.tcl]]
@@ -82,6 +69,7 @@ set auto_index(tcl_startOfPreviousWord) [list source [file join $dir word.tcl]]
set auto_index(::tcl::tm::add) [list source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::remove) [list source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::list) [list source [file join $dir tm.tcl]]
+set auto_index(::tcl::tm::Defaults) [list source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::UnknownHandler) [list source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::roots) [list source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::path) [list source [file join $dir tm.tcl]]
diff --git a/library/tm.tcl b/library/tm.tcl
index 7b9cafe..55efda6 100644
--- a/library/tm.tcl
+++ b/library/tm.tcl
@@ -1,48 +1,44 @@
# -*- tcl -*-
#
-# Searching for Tcl Modules. Defines a procedure, declares it as the
-# primary command for finding packages, however also uses the former
-# 'package unknown' command as a fallback.
+# Searching for Tcl Modules. Defines a procedure, declares it as the primary
+# command for finding packages, however also uses the former 'package unknown'
+# command as a fallback.
#
-# Locates all possible packages in a directory via a less restricted
-# glob. The targeted directory is derived from the name of the
-# requested package. I.e. the TM scan will look only at directories
-# which can contain the requested package. It will register all
-# packages it found in the directory so that future requests have a
-# higher chance of being fulfilled by the ifneeded database without
-# having to come to us again.
+# Locates all possible packages in a directory via a less restricted glob. The
+# targeted directory is derived from the name of the requested package, i.e.
+# the TM scan will look only at directories which can contain the requested
+# package. It will register all packages it found in the directory so that
+# future requests have a higher chance of being fulfilled by the ifneeded
+# database without having to come to us again.
#
-# We do not remember where we have been and simply rescan targeted
-# directories when invoked again. The reasoning is this:
+# We do not remember where we have been and simply rescan targeted directories
+# when invoked again. The reasoning is this:
#
-# - The only way we get back to the same directory is if someone is
-# trying to [package require] something that wasn't there on the
-# first scan.
+# - The only way we get back to the same directory is if someone is trying to
+# [package require] something that wasn't there on the first scan.
#
# Either
# 1) It is there now: If we rescan, you get it; if not you don't.
#
-# This covers the possibility that the application asked for a
-# package late, and the package was actually added to the
-# installation after the application was started. It shoukld
-# still be able to find it.
+# This covers the possibility that the application asked for a package
+# late, and the package was actually added to the installation after the
+# application was started. It shoukld still be able to find it.
#
-# 2) It still is not there: Either way, you don't get it, but the
-# rescan takes time. This is however an error case and we dont't
-# care that much about it
+# 2) It still is not there: Either way, you don't get it, but the rescan
+# takes time. This is however an error case and we dont't care that much
+# about it
#
-# 3) It was there the first time; but for some reason a "package
-# forget" has been run, and "package" doesn't know about it
-# anymore.
+# 3) It was there the first time; but for some reason a "package forget" has
+# been run, and "package" doesn't know about it anymore.
#
-# This can be an indication that the application wishes to reload
-# some functionality. And should work as well.
+# This can be an indication that the application wishes to reload some
+# functionality. And should work as well.
#
-# Note that this also strikes a balance between doing a glob targeting
-# a single package, and thus most likely requiring multiple globs of
-# the same directory when the application is asking for many packages,
-# and trying to glob for _everything_ in all subdirectories when
-# looking for a package, which comes with a heavy startup cost.
+# Note that this also strikes a balance between doing a glob targeting a
+# single package, and thus most likely requiring multiple globs of the same
+# directory when the application is asking for many packages, and trying to
+# glob for _everything_ in all subdirectories when looking for a package,
+# which comes with a heavy startup cost.
#
# We scan for regular packages only if no satisfying module was found.
@@ -71,46 +67,43 @@ namespace eval ::tcl::tm {
# path with 'list'.
#
# Results
-# No result for subcommands 'add' and 'remove'. A list of paths
-# for 'list'.
+# No result for subcommands 'add' and 'remove'. A list of paths for
+# 'list'.
#
# Sideeffects
-# The subcommands 'add' and 'remove' manipulate the list of
-# paths to search for Tcl Modules. The subcommand 'list' has no
-# sideeffects.
+# The subcommands 'add' and 'remove' manipulate the list of paths to
+# search for Tcl Modules. The subcommand 'list' has no sideeffects.
-proc ::tcl::tm::add {path args} {
+proc ::tcl::tm::add {args} {
# PART OF THE ::tcl::tm::path ENSEMBLE
#
# The path is added at the head to the list of module paths.
#
- # The command enforces the restriction that no path may be an
- # ancestor directory of any other path on the list. If the new
- # path violates this restriction an error wil be raised.
+ # The command enforces the restriction that no path may be an ancestor
+ # directory of any other path on the list. If the new path violates this
+ # restriction an error wil be raised.
#
- # If the path is already present as is no error will be raised and
- # no action will be taken.
+ # If the path is already present as is no error will be raised and no
+ # action will be taken.
variable paths
- # We use a copy of the path as source during validation, and
- # extend it as well. Because we not only have to detect if the new
- # paths are bogus with respect to the existing paths, but also
- # between themselves. Otherwise we can still add bogus paths, by
- # specifying them in a single call. This makes the use of the new
- # paths simpler as well, a trivial assignment of the collected
- # paths to the official state var.
+ # We use a copy of the path as source during validation, and extend it as
+ # well. Because we not only have to detect if the new paths are bogus with
+ # respect to the existing paths, but also between themselves. Otherwise we
+ # can still add bogus paths, by specifying them in a single call. This
+ # makes the use of the new paths simpler as well, a trivial assignment of
+ # the collected paths to the official state var.
set newpaths $paths
- foreach p [linsert $args 0 $path] {
+ foreach p $args {
if {$p in $newpaths} {
# Ignore a path already on the list.
continue
}
- # Search for paths which are subdirectories of the new one. If
- # there are any then the new path violates the restriction
- # about ancestors.
+ # Search for paths which are subdirectories of the new one. If there
+ # are any then the new path violates the restriction about ancestors.
set pos [lsearch -glob $newpaths ${p}/*]
# Cannot use "in", we need the position for the message.
@@ -119,10 +112,9 @@ proc ::tcl::tm::add {path args} {
"$p is ancestor of existing module path [lindex $newpaths $pos]."
}
- # Now look for existing paths which are ancestors of the new
- # one. This reverse question forces us to loop over the
- # existing paths, as each element is the pattern, not the new
- # path :(
+ # Now look for existing paths which are ancestors of the new one. This
+ # reverse question forces us to loop over the existing paths, as each
+ # element is the pattern, not the new path :(
foreach ep $newpaths {
if {[string match ${ep}/* $p]} {
@@ -134,24 +126,23 @@ proc ::tcl::tm::add {path args} {
set newpaths [linsert $newpaths 0 $p]
}
- # The validation of the input is complete and successful, and
- # everything in newpaths is either an old path, or added. We can
- # now extend the official list of paths, a simple assignment is
- # sufficient.
+ # The validation of the input is complete and successful, and everything
+ # in newpaths is either an old path, or added. We can now extend the
+ # official list of paths, a simple assignment is sufficient.
set paths $newpaths
return
}
-proc ::tcl::tm::remove {path args} {
+proc ::tcl::tm::remove {args} {
# PART OF THE ::tcl::tm::path ENSEMBLE
#
- # Removes the path from the list of module paths. The command is
- # silently ignored if the path is not on the list.
+ # Removes the path from the list of module paths. The command is silently
+ # ignored if the path is not on the list.
variable paths
- foreach p [linsert $args 0 $path] {
+ foreach p $args {
set pos [lsearch -exact $paths $p]
if {$pos >= 0} {
set paths [lreplace $paths $pos $pos]
@@ -177,27 +168,26 @@ 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]
@@ -206,11 +196,10 @@ proc ::tcl::tm::UnknownHandler {original name args} {
set pkgroot ""
}
- # We don't remember a copy of the paths while looping. Tcl
- # Modules are unable to change the list while we are searching
- # for them. This also simplifies the loop, as we cannot get
- # additional directories while iterating over the list. A
- # simple foreach is sufficient.
+ # We don't remember a copy of the paths while looping. Tcl Modules are
+ # unable to change the list while we are searching for them. This also
+ # simplifies the loop, as we cannot get additional directories while
+ # iterating over the list. A simple foreach is sufficient.
set satisfied 0
foreach path $paths {
@@ -223,12 +212,11 @@ proc ::tcl::tm::UnknownHandler {original name args} {
}
set strip [llength [file split $path]]
- # We can't use glob in safe interps, so enclose the following
- # in a catch statement, where we get the module files out
- # of the subdirectories. In other words, Tcl Modules are
- # not-functional in such an interpreter. This is the same
- # as for the command "tclPkgUnknown", i.e. the search for
- # regular packages.
+ # We can't use glob in safe interps, so enclose the following in a
+ # catch statement, where we get the module files out of the
+ # subdirectories. In other words, Tcl Modules are not-functional
+ # in such an interpreter. This is the same as for the command
+ # "tclPkgUnknown", i.e. the search for regular packages.
catch {
# We always look for _all_ possible modules in the current
@@ -238,13 +226,15 @@ proc ::tcl::tm::UnknownHandler {original name args} {
set pkgfilename [join [lrange [file split $file] $strip end] ::]
if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} {
- # Ignore everything not matching our pattern
- # for package names.
+ # Ignore everything not matching our pattern for
+ # package names.
continue
}
- if {[catch {package vcompare $pkgversion 0}]} {
- # Ignore everything where the version part is
- # not acceptable to "package vcompare".
+ try {
+ package vcompare $pkgversion 0
+ } on error {} {
+ # Ignore everything where the version part is not
+ # acceptable to "package vcompare".
continue
}
@@ -257,38 +247,36 @@ proc ::tcl::tm::UnknownHandler {original name args} {
continue
}
- # We have found a candidate, generate a "provide
- # script" for it, and remember it. Note that we
- # are using ::list to do this; locally [list]
- # means something else without the namespace
- # specifier.
-
- # NOTE. When making changes to the format of the
- # provide command generated below CHECK that the
- # 'LOCATE' procedure in core file
- # 'platform/shell.tcl' still understands it, or,
- # if not, update its implementation appropriately.
+ # We have found a candidate, generate a "provide script"
+ # for it, and remember it. Note that we are using ::list
+ # to do this; locally [list] means something else without
+ # the namespace specifier.
+
+ # NOTE. When making changes to the format of the provide
+ # command generated below CHECK that the 'LOCATE'
+ # procedure in core file 'platform/shell.tcl' still
+ # understands it, or, if not, update its implementation
+ # appropriately.
#
- # Right now LOCATE's implementation assumes that
- # the path of the package file is the last element
- # in the list.
+ # Right now LOCATE's implementation assumes that the path
+ # of the package file is the last element in the list.
package ifneeded $pkgname $pkgversion \
"[::list package provide $pkgname $pkgversion];[::list source -encoding utf-8 $file]"
- # We abort in this unknown handler only if we got
- # a satisfying candidate for the requested
- # package. Otherwise we still have to fallback to
- # the regular package search to complete the
- # processing.
+ # We abort in this unknown handler only if we got a
+ # satisfying candidate for the requested package.
+ # Otherwise we still have to fallback to the regular
+ # package search to complete the processing.
if {($pkgname eq $name)
&& [package vsatisfies $pkgversion {*}$args]} {
set satisfied 1
- # We do not abort the loop, and keep adding
- # provide scripts for every candidate in the
- # directory, just remember to not fall back to
- # the regular search anymore.
+
+ # We do not abort the loop, and keep adding provide
+ # scripts for every candidate in the directory, just
+ # remember to not fall back to the regular search
+ # anymore.
}
}
}
@@ -299,8 +287,8 @@ proc ::tcl::tm::UnknownHandler {original name args} {
}
}
- # Fallback to previous command, if existing. See comment above
- # about ::list...
+ # Fallback to previous command, if existing. See comment above about
+ # ::list...
if {[llength $original]} {
uplevel 1 $original [::linsert $args 0 $name]
@@ -371,17 +359,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}