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