From decb78c6ab524e9ded4c6e633c74c331c82f1d5d Mon Sep 17 00:00:00 2001 From: Stefan Frederik Date: Tue, 17 Aug 2021 00:24:32 +0200 Subject: [PATCH] added windows installer binary template builder --- XSchemWin/INSTALL_WIN | 2 +- .../binary_template/lib/tcl8.6/auto.tcl | 648 +++ .../binary_template/lib/tcl8.6/clock.tcl | 4547 +++++++++++++++++ .../binary_template/lib/tcl8.6/history.tcl | 335 ++ .../binary_template/lib/tcl8.6/init.tcl | 827 +++ .../binary_template/lib/tcl8.6/license.terms | 40 + .../binary_template/lib/tcl8.6/package.tcl | 751 +++ .../binary_template/lib/tcl8.6/parray.tcl | 28 + .../binary_template/lib/tcl8.6/safe.tcl | 1289 +++++ .../binary_template/lib/tcl8.6/tclIndex | 78 + .../binary_template/lib/tcl8.6/tm.tcl | 380 ++ .../binary_template/lib/tcl8.6/word.tcl | 154 + .../binary_template/lib/tk8.6/bgerror.tcl | 272 + .../binary_template/lib/tk8.6/button.tcl | 782 +++ .../binary_template/lib/tk8.6/choosedir.tcl | 308 ++ .../binary_template/lib/tk8.6/clrpick.tcl | 695 +++ .../binary_template/lib/tk8.6/comdlg.tcl | 322 ++ .../binary_template/lib/tk8.6/console.tcl | 1150 +++++ .../binary_template/lib/tk8.6/dialog.tcl | 175 + .../binary_template/lib/tk8.6/entry.tcl | 686 +++ .../binary_template/lib/tk8.6/focus.tcl | 178 + .../binary_template/lib/tk8.6/fontchooser.tcl | 455 ++ .../binary_template/lib/tk8.6/iconlist.tcl | 717 +++ .../binary_template/lib/tk8.6/icons.tcl | 153 + .../binary_template/lib/tk8.6/license.terms | 40 + .../binary_template/lib/tk8.6/listbox.tcl | 560 ++ .../binary_template/lib/tk8.6/megawidget.tcl | 297 ++ .../binary_template/lib/tk8.6/menu.tcl | 1379 +++++ .../binary_template/lib/tk8.6/mkpsenc.tcl | 1488 ++++++ .../binary_template/lib/tk8.6/msgbox.tcl | 427 ++ .../binary_template/lib/tk8.6/obsolete.tcl | 178 + .../binary_template/lib/tk8.6/optMenu.tcl | 43 + .../binary_template/lib/tk8.6/palette.tcl | 244 + .../binary_template/lib/tk8.6/panedwindow.tcl | 194 + .../binary_template/lib/tk8.6/safetk.tcl | 262 + .../binary_template/lib/tk8.6/scale.tcl | 290 ++ .../binary_template/lib/tk8.6/scrlbar.tcl | 456 ++ .../binary_template/lib/tk8.6/spinbox.tcl | 593 +++ .../binary_template/lib/tk8.6/tclIndex | 253 + .../binary_template/lib/tk8.6/tearoff.tcl | 184 + .../binary_template/lib/tk8.6/text.tcl | 1237 +++++ .../binary_template/lib/tk8.6/tk.tcl | 712 +++ .../binary_template/lib/tk8.6/tkfbox.tcl | 1240 +++++ .../binary_template/lib/tk8.6/unsupported.tcl | 269 + .../binary_template/lib/tk8.6/xmfbox.tcl | 989 ++++ .../licenses/tcl-license.terms | 40 + .../binary_template/licenses/tk-license.terms | 40 + .../licenses/xlib-license.terms | 40 + XSchemWin/Installer/create_binary.bat | 21 + XSchemWin/README_WIN | 1 + XSchemWin/XSchemWix/Product.wxs | 2 +- 51 files changed, 26449 insertions(+), 2 deletions(-) create mode 100644 XSchemWin/Installer/binary_template/lib/tcl8.6/auto.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tcl8.6/clock.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tcl8.6/history.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tcl8.6/init.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tcl8.6/license.terms create mode 100644 XSchemWin/Installer/binary_template/lib/tcl8.6/package.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tcl8.6/parray.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tcl8.6/safe.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tcl8.6/tclIndex create mode 100644 XSchemWin/Installer/binary_template/lib/tcl8.6/tm.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tcl8.6/word.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/bgerror.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/button.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/choosedir.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/clrpick.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/comdlg.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/console.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/dialog.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/entry.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/focus.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/fontchooser.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/iconlist.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/icons.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/license.terms create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/listbox.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/megawidget.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/menu.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/mkpsenc.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/msgbox.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/obsolete.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/optMenu.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/palette.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/panedwindow.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/safetk.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/scale.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/scrlbar.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/spinbox.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/tclIndex create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/tearoff.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/text.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/tk.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/tkfbox.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/unsupported.tcl create mode 100644 XSchemWin/Installer/binary_template/lib/tk8.6/xmfbox.tcl create mode 100644 XSchemWin/Installer/binary_template/licenses/tcl-license.terms create mode 100644 XSchemWin/Installer/binary_template/licenses/tk-license.terms create mode 100644 XSchemWin/Installer/binary_template/licenses/xlib-license.terms create mode 100644 XSchemWin/Installer/create_binary.bat diff --git a/XSchemWin/INSTALL_WIN b/XSchemWin/INSTALL_WIN index 13157283..47ff4828 100644 --- a/XSchemWin/INSTALL_WIN +++ b/XSchemWin/INSTALL_WIN @@ -3,7 +3,7 @@ - Windows 10 - ActiveState TCL/TK 8.69 x64 (https://www.activestate.com/products/tcl/) - Gawk for Windows (Add directory of awk.exe to PATH) - - NGSpice for Windows + - NGSpice for Windows (Add directory of NGSpice to PATH, if it's not already done so) 2. Install Tree C:/Program Files/XSchem/bin - Binaries (executable file). diff --git a/XSchemWin/Installer/binary_template/lib/tcl8.6/auto.tcl b/XSchemWin/Installer/binary_template/lib/tcl8.6/auto.tcl new file mode 100644 index 00000000..64c5bc72 --- /dev/null +++ b/XSchemWin/Installer/binary_template/lib/tcl8.6/auto.tcl @@ -0,0 +1,648 @@ +# auto.tcl -- +# +# 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. +# + +# 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. +# +# Arguments: +# None. + +proc auto_reset {} { + global auto_execs auto_index auto_path + if {[array exists auto_index]} { + foreach cmdName [array names auto_index] { + set fqcn [namespace which $cmdName] + 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] + } +} + +# 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. +# +# Arguments: +# basename Prefix of the directory name, (e.g., "tk") +# version Version number of the package, (e.g., "8.0") +# patch Patchlevel of the package, (e.g., "8.0.3") +# initScript Initialization script to source (e.g., tk.tcl) +# enVarName environment variable to honor (e.g., TK_LIBRARY) +# varName Global variable to set when done (e.g., tk_library) + +proc tcl_findLibrary {basename version patch initScript enVarName varName} { + upvar #0 $varName the_library + global auto_path env tcl_platform + + set dirs {} + set errors {} + + # The C application may have hardwired a path, which we honor + + 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. + + if {[info exists env($enVarName)]} { + lappend dirs $env($enVarName) + } + + # 2. In the package script directory registered within the + # configuration of the package itself. + + catch { + lappend dirs [::${basename}::pkgconfig get scriptdir,runtime] + } + + # 3. Relative to auto_path directories. This checks relative to the + # Tcl library as well as allowing loading of libraries added to the + # auto_path that is not relative to the core library or binary paths. + foreach d $auto_path { + lappend dirs [file join $d $basename$version] + if {$tcl_platform(platform) eq "unix" + && $tcl_platform(os) eq "Darwin"} { + # 4. On MacOSX, check the Resources/Scripts subdir too + lappend dirs [file join $d $basename$version Resources Scripts] + } + } + + # 3. Various locations relative to the executable + # ../lib/foo1.0 (From bin directory in install hierarchy) + # ../../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. + # + # ../../library (From unix/arch directory in build hierarchy) + # ../../foo1.0.1/library + # (From unix directory in parallel build hierarchy) + # ../../../foo1.0.1/library + # (From unix/arch directory in parallel build hierarchy) + + set parentDir [file dirname [file dirname [info nameofexecutable]]] + set grandParentDir [file dirname $parentDir] + lappend dirs [file join $parentDir lib $basename$version] + lappend dirs [file join $grandParentDir lib $basename$version] + lappend dirs [file join $parentDir library] + if {0} { + lappend dirs [file join $grandParentDir library] + lappend dirs [file join $grandParentDir $basename$patch library] + lappend dirs [file join [file dirname $grandParentDir] \ + $basename$patch library] + } + } + # uniquify $dirs in order + array set seen {} + foreach i $dirs { + # Make sure $i is unique under normalization. Avoid repeated [source]. + if {[interp issafe]} { + # Safe interps have no [file normalize]. + set norm $i + } else { + set norm [file normalize $i] + } + if {[info exists seen($norm)]} { + continue + } + set seen($norm) {} + + 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 + + if {[interp issafe] || [file exists $file]} { + if {![catch {uplevel #0 [list source $file]} msg opts]} { + return + } + append errors "$file: $msg\n" + append errors [dict get $opts -errorinfo]\n + } + } + unset -nocomplain the_library + set msg "Can't find a usable $initScript in the following directories: \n" + append msg " $dirs\n\n" + append msg "$errors\n\n" + append msg "This probably means that $basename wasn't installed properly.\n" + error $msg +} + + +# ---------------------------------------------------------------------- +# 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. + +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. +# +# 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. + +proc auto_mkindex {dir args} { + if {[interp issafe]} { + error "can't generate index within safe interpreter" + } + + set oldDir [pwd] + cd $dir + + append index "# Tcl autoload index file, version 2.0\n" + append index "# This file is generated by the \"auto_mkindex\" command\n" + append index "# and sourced to set up indexing information for one or\n" + append index "# more commands. Typically each line is a command that\n" + append index "# sets an element in the auto_index array, where the\n" + append index "# element name is the name of a command and the value is\n" + append index "# a script that loads the command.\n\n" + if {![llength $args]} { + set args *.tcl + } + + auto_mkindex_parser::init + foreach file [lsort [glob -- {*}$args]] { + try { + append index [auto_mkindex_parser::mkindex $file] + } on error {msg opts} { + cd $oldDir + return -options $opts $msg + } + } + auto_mkindex_parser::cleanup + + set fid [open "tclIndex" w] + puts -nonewline $fid $index + close $fid + cd $oldDir +} + +# 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] + 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" + append index "# and sourced to set up indexing information for one or\n" + append index "# more commands. Typically each line is a command that\n" + append index "# sets an element in the auto_index array, where the\n" + append index "# element name is the name of a command and the value is\n" + append index "# a script that loads the command.\n\n" + if {![llength $args]} { + set args *.tcl + } + foreach file [lsort [glob -- {*}$args]] { + set f "" + set error [catch { + set f [open $file] + fconfigure $f -eofchar \032 + while {[gets $f line] >= 0} { + if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} { + set procName [lindex [auto_qualify $procName "::"] 0] + append index "set [list auto_index($procName)]" + append index " \[list source \[file join \$dir [list $file]\]\]\n" + } + } + close $f + } msg opts] + if {$error} { + catch {close $f} + cd $oldDir + return -options $opts $msg + } + } + set f "" + set error [catch { + set f [open tclIndex w] + puts -nonewline $f $index + close $f + cd $oldDir + } msg opts] + if {$error} { + catch {close $f} + cd $oldDir + error $msg $info $code + return -options $opts $msg + } +} + +# 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. + +namespace eval auto_mkindex_parser { + variable parser "" ;# parser used to build index + variable index "" ;# maintains index as it is built + variable scriptFile "" ;# name of file being processed + variable contextStack "" ;# stack of namespace scopes + variable imports "" ;# keeps track of all imported cmds + variable initCommands ;# list of commands that create aliases + if {![info exists initCommands]} { + set initCommands [list] + } + + proc init {} { + variable parser + variable initCommands + + if {![interp issafe]} { + set parser [interp create -safe] + $parser hide info + $parser hide rename + $parser hide proc + $parser hide namespace + $parser hide eval + $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 proc unknown {args} {} + + # We'll need access to the "namespace" command within the + # interp. Put it back, but move it out of the way. + + $parser expose namespace + $parser invokehidden rename namespace _%@namespace + $parser expose eval + $parser invokehidden rename eval _%@eval + + # Install all the registered psuedo-command implementations + + foreach cmd $initCommands { + eval $cmd + } + } + } + proc cleanup {} { + variable parser + interp delete $parser + unset 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. +# +# Arguments: +# file Name of Tcl source file to be indexed. + +proc auto_mkindex_parser::mkindex {file} { + variable parser + variable index + variable scriptFile + variable contextStack + variable imports + + set scriptFile $file + + set fid [open $file] + fconfigure $fid -eofchar \032 + 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. + set contents [string map [list \$ \0] $contents] + + set index "" + set contextStack "" + set imports "" + + $parser eval $contents + + foreach name $imports { + catch {$parser eval [list _%@namespace forget $name]} + } + return $index +} + +# auto_mkindex_parser::hook command +# +# Registers a Tcl command to evaluate when initializing the child interpreter +# used by the mkindex parser. The command is evaluated in the parent +# interpreter, and can use the variable auto_mkindex_parser::parser to get to +# the child + +proc auto_mkindex_parser::hook {cmd} { + variable initCommands + + lappend initCommands $cmd +} + +# auto_mkindex_parser::slavehook command +# +# Registers a Tcl command to evaluate when initializing the child interpreter +# used by the mkindex parser. The command is evaluated in the child +# interpreter. + +proc auto_mkindex_parser::slavehook {cmd} { + variable initCommands + + # The $parser variable is defined to be the name of the child 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. +# +# 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. +# arglist Argument list for command. +# body Implementation of command to handle indexing. + +proc auto_mkindex_parser::command {name arglist body} { + hook [list auto_mkindex_parser::commandInit $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. +# +# Arguments: +# name Name of command recognized in Tcl files. +# arglist Argument list for command. +# body Implementation of command to handle indexing. + +proc auto_mkindex_parser::commandInit {name arglist body} { + variable parser + + set ns [namespace qualifiers $name] + set tail [namespace tail $name] + if {$ns eq ""} { + set fakeName [namespace current]::_%@fake_$tail + } else { + set fakeName [namespace current]::[string map {:: _} _%@fake_$name] + } + 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. + + 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: + # "_%@eval {$alias} \$args" + # 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 + + set alias [namespace tail $fakeName] + $parser invokehidden proc $name {args} "_%@eval {$alias} \$args" + $parser alias $alias $fakeName + } else { + $parser alias $name $fakeName + } + return +} + +# auto_mkindex_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. +# +# Arguments: +# name - Name that is being added to index. + +proc auto_mkindex_parser::fullname {name} { + variable contextStack + + if {![string match ::* $name]} { + foreach ns $contextStack { + set name "${ns}::$name" + if {[string match ::* $name]} { + break + } + } + } + + if {[namespace qualifiers $name] eq ""} { + set name [namespace tail $name] + } elseif {![string match ::* $name]} { + set name "::$name" + } + + # Earlier, mkindex replaced all $'s with \0. Now, we have to reverse that + # replacement. + return [string map [list \0 \$] $name] +} + +# auto_mkindex_parser::indexEntry -- +# +# Used by commands like "proc" within the auto_mkindex parser to add a +# correctly-quoted entry to the index. This is shared code so it is done +# *right*, in one place. +# +# Arguments: +# name - Name that is being added to index. + +proc auto_mkindex_parser::indexEntry {name} { + variable index + variable scriptFile + + # We convert all metacharacters to their backslashed form, and pre-split + # the file name that we know about (which will be a proper list, and so + # correctly quoted). + + set name [string range [list \}[fullname $name]] 2 end] + set filenameParts [file split $scriptFile] + + append index [format \ + {set auto_index(%s) [list source [file join $dir %s]]%s} \ + $name $filenameParts \n] + return +} + +if {[llength $::auto_mkindex_parser::initCommands]} { + return +} + +# Register all of the procedures for the auto_mkindex parser that will build +# the "tclIndex" file. + +# AUTO MKINDEX: proc name arglist body +# Adds an entry to the auto index list for the given procedure name. + +auto_mkindex_parser::command proc {name args} { + indexEntry $name +} + +# Conditionally add support for Tcl byte code files. There are some tricky +# details here. First, we need to get the tbcload library initialized in the +# current interpreter. We cannot load tbcload into the child 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 {[namespace which -command tbcload::bcproc] eq ""} { + auto_load tbcload::bcproc + } + load {} tbcload $auto_mkindex_parser::parser + + # AUTO MKINDEX: tbcload::bcproc name arglist body + # Adds an entry to the auto index list for the given pre-compiled + # procedure name. + + auto_mkindex_parser::commandInit tbcload::bcproc {name args} { + indexEntry $name + } + } +} + +# AUTO MKINDEX: namespace eval name command ?arg arg...? +# Adds the namespace name onto the context stack and evaluates the associated +# body of commands. +# +# 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. + +auto_mkindex_parser::command namespace {op args} { + switch -- $op { + eval { + variable parser + variable contextStack + + set name [lindex $args 0] + set args [lrange $args 1 end] + + set contextStack [linsert $contextStack 0 $name] + $parser eval [list _%@namespace eval $name] $args + set contextStack [lrange $contextStack 1 end] + } + import { + variable parser + variable imports + foreach pattern $args { + if {$pattern ne "-force"} { + lappend imports $pattern + } + } + catch {$parser eval "_%@namespace import $args"} + } + ensemble { + variable parser + variable contextStack + if {[lindex $args 0] eq "create"} { + set name ::[join [lreverse $contextStack] ::] + catch { + set name [dict get [lrange $args 1 end] -command] + if {![string match ::* $name]} { + set name ::[join [lreverse $contextStack] ::]$name + } + regsub -all ::+ $name :: name + } + # create artifical proc to force an entry in the tclIndex + $parser eval [list ::proc $name {} {}] + } + } + } +} + +# AUTO MKINDEX: oo::class create name ?definition? +# Adds an entry to the auto index list for the given class name. +auto_mkindex_parser::command oo::class {op name {body ""}} { + if {$op eq "create"} { + indexEntry $name + } +} +auto_mkindex_parser::command class {op name {body ""}} { + if {$op eq "create"} { + indexEntry $name + } +} + +return diff --git a/XSchemWin/Installer/binary_template/lib/tcl8.6/clock.tcl b/XSchemWin/Installer/binary_template/lib/tcl8.6/clock.tcl new file mode 100644 index 00000000..273b5345 --- /dev/null +++ b/XSchemWin/Installer/binary_template/lib/tcl8.6/clock.tcl @@ -0,0 +1,4547 @@ +#---------------------------------------------------------------------- +# +# 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. +# +# +#---------------------------------------------------------------------- +# +# Copyright (c) 2004-2007 Kevin B. Kenny +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +#---------------------------------------------------------------------- + +# 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.6 + if { $::tcl_platform(platform) eq {windows} } { + if { [catch { package require registry 1.1 }] } { + namespace eval ::tcl::clock [list variable NoRegistry {}] + } + } +} + +# 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]]] + +#---------------------------------------------------------------------- +# +# clock -- +# +# Manipulate times. +# +# The 'clock' command manipulates time. Refer to the user documentation for +# the available subcommands and what they do. +# +#---------------------------------------------------------------------- + +namespace eval ::tcl::clock { + + # Export the subcommands + + namespace export format + namespace export clicks + namespace export microseconds + namespace export milliseconds + namespace export scan + namespace export seconds + namespace export add + + # Import the message catalog commands that we use. + + namespace import ::msgcat::mcload + namespace import ::msgcat::mclocale + namespace import ::msgcat::mc + namespace import ::msgcat::mcpackagelocale + +} + +#---------------------------------------------------------------------- +# +# ::tcl::clock::Initialize -- +# +# Finish initializing the 'clock' subsystem +# +# Results: +# None. +# +# 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. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::Initialize {} { + + rename ::tcl::clock::Initialize {} + + variable LibDir + + # Define the Greenwich time zone + + proc InitTZData {} { + variable TZData + array unset TZData + set TZData(:Etc/GMT) { + {-9223372036854775808 0 0 GMT} + } + set TZData(:GMT) $TZData(:Etc/GMT) + set TZData(:Etc/UTC) { + {-9223372036854775808 0 0 UTC} + } + set TZData(:UTC) $TZData(:Etc/UTC) + set TZData(:localtime) {} + } + InitTZData + + mcpackagelocale set {} + ::msgcat::mcpackageconfig set mcfolder [file join $LibDir msgs] + ::msgcat::mcpackageconfig set unknowncmd "" + ::msgcat::mcpackageconfig set changecmd ChangeCurrentLocale + + # Define the message catalog for the root locale. + + ::msgcat::mcmset {} { + AM {am} + BCE {B.C.E.} + CE {C.E.} + DATE_FORMAT {%m/%d/%Y} + DATE_TIME_FORMAT {%a %b %e %H:%M:%S %Y} + DAYS_OF_WEEK_ABBREV { + Sun Mon Tue Wed Thu Fri Sat + } + DAYS_OF_WEEK_FULL { + Sunday Monday Tuesday Wednesday Thursday Friday Saturday + } + GREGORIAN_CHANGE_DATE 2299161 + LOCALE_DATE_FORMAT {%m/%d/%Y} + LOCALE_DATE_TIME_FORMAT {%a %b %e %H:%M:%S %Y} + LOCALE_ERAS {} + LOCALE_NUMERALS { + 00 01 02 03 04 05 06 07 08 09 + 10 11 12 13 14 15 16 17 18 19 + 20 21 22 23 24 25 26 27 28 29 + 30 31 32 33 34 35 36 37 38 39 + 40 41 42 43 44 45 46 47 48 49 + 50 51 52 53 54 55 56 57 58 59 + 60 61 62 63 64 65 66 67 68 69 + 70 71 72 73 74 75 76 77 78 79 + 80 81 82 83 84 85 86 87 88 89 + 90 91 92 93 94 95 96 97 98 99 + } + LOCALE_TIME_FORMAT {%H:%M:%S} + LOCALE_YEAR_FORMAT {%EC%Ey} + MONTHS_ABBREV { + Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec + } + MONTHS_FULL { + January February March + April May June + July August September + October November December + } + PM {pm} + TIME_FORMAT {%H:%M:%S} + TIME_FORMAT_12 {%I:%M:%S %P} + TIME_FORMAT_24 {%H:%M} + TIME_FORMAT_24_SECS {%H:%M:%S} + } + + # Define a few Gregorian change dates for other locales. In most cases + # the change date follows a language, because a nation's colonies changed + # at the same time as the nation itself. In many cases, different + # national boundaries existed; the dominating rule is to follow the + # nation's capital. + + # Italy, Spain, Portugal, Poland + + ::msgcat::mcset it GREGORIAN_CHANGE_DATE 2299161 + ::msgcat::mcset es GREGORIAN_CHANGE_DATE 2299161 + ::msgcat::mcset pt GREGORIAN_CHANGE_DATE 2299161 + ::msgcat::mcset pl GREGORIAN_CHANGE_DATE 2299161 + + # France, Austria + + ::msgcat::mcset fr GREGORIAN_CHANGE_DATE 2299227 + + # 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 + + # Austria + + ::msgcat::mcset de_AT GREGORIAN_CHANGE_DATE 2299527 + + # Hungary + + ::msgcat::mcset hu GREGORIAN_CHANGE_DATE 2301004 + + # Germany, Norway, Denmark (Catholic Germany changed earlier) + + ::msgcat::mcset de_DE 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) + + ::msgcat::mcset nl GREGORIAN_CHANGE_DATE 2342165 + + # Protestant Switzerland (Catholic cantons changed earlier) + + ::msgcat::mcset fr_CH GREGORIAN_CHANGE_DATE 2361342 + ::msgcat::mcset it_CH GREGORIAN_CHANGE_DATE 2361342 + ::msgcat::mcset de_CH GREGORIAN_CHANGE_DATE 2361342 + + # English speaking countries + + ::msgcat::mcset en GREGORIAN_CHANGE_DATE 2361222 + + # Sweden (had several changes onto and off of the Gregorian calendar) + + ::msgcat::mcset sv GREGORIAN_CHANGE_DATE 2361390 + + # Russia + + ::msgcat::mcset ru GREGORIAN_CHANGE_DATE 2421639 + + # 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 + + variable ZoneinfoPaths {} + foreach path { + /usr/share/zoneinfo + /usr/share/lib/zoneinfo + /usr/lib/zoneinfo + /usr/local/etc/zoneinfo + } { + if { [file isdirectory $path] } { + lappend ZoneinfoPaths $path + } + } + + # Define the directories for time zone data and message catalogs. + + variable DataDir [file join $LibDir tzdata] + + # Number of days in the months, in common years and leap years. + + variable DaysInRomanMonthInCommonYear \ + { 31 28 31 30 31 30 31 31 30 31 30 31 } + variable DaysInRomanMonthInLeapYear \ + { 31 29 31 30 31 30 31 31 30 31 30 31 } + variable DaysInPriorMonthsInCommonYear [list 0] + variable DaysInPriorMonthsInLeapYear [list 0] + set i 0 + foreach j $DaysInRomanMonthInCommonYear { + lappend DaysInPriorMonthsInCommonYear [incr i $j] + } + set i 0 + foreach j $DaysInRomanMonthInLeapYear { + lappend DaysInPriorMonthsInLeapYear [incr i $j] + } + + # Another epoch (Hi, Jeff!) + + variable Roddenberry 1946 + + # Integer ranges + + variable MINWIDE -9223372036854775808 + variable MAXWIDE 9223372036854775807 + + # Day before Leap Day + + 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. + + # The keys are long lists of values obtained from the time zone + # information in the Registry. In order, the list elements are: + # Bias StandardBias DaylightBias + # StandardDate.wYear StandardDate.wMonth StandardDate.wDayOfWeek + # StandardDate.wDay StandardDate.wHour StandardDate.wMinute + # StandardDate.wSecond StandardDate.wMilliseconds + # 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. + + 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 + {-39600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Midway + {-36000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Honolulu + {-32400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Anchorage + {-28800 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Los_Angeles + {-28800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Tijuana + {-25200 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Denver + {-25200 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Chihuahua + {-25200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Phoenix + {-21600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Regina + {-21600 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Chicago + {-21600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Mexico_City + {-18000 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/New_York + {-18000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Indianapolis + {-14400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Caracas + {-14400 0 3600 0 3 6 2 23 59 59 999 0 10 6 2 23 59 59 999} + :America/Santiago + {-14400 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Manaus + {-14400 0 3600 0 11 0 1 2 0 0 0 0 3 0 2 2 0 0 0} :America/Halifax + {-12600 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/St_Johns + {-10800 0 3600 0 2 0 2 2 0 0 0 0 10 0 3 2 0 0 0} :America/Sao_Paulo + {-10800 0 3600 0 10 0 5 2 0 0 0 0 4 0 1 2 0 0 0} :America/Godthab + {-10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :America/Buenos_Aires + {-10800 0 3600 0 2 0 5 2 0 0 0 0 11 0 1 2 0 0 0} :America/Bahia + {-10800 0 3600 0 3 0 2 2 0 0 0 0 10 0 1 2 0 0 0} :America/Montevideo + {-7200 0 3600 0 9 0 5 2 0 0 0 0 3 0 5 2 0 0 0} :America/Noronha + {-3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Atlantic/Azores + {-3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Atlantic/Cape_Verde + {0 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :UTC + {0 0 3600 0 10 0 5 2 0 0 0 0 3 0 5 1 0 0 0} :Europe/London + {3600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Kinshasa + {3600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :CET + {7200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Africa/Harare + {7200 0 3600 0 9 4 5 23 59 59 0 0 4 4 5 23 59 59 0} + :Africa/Cairo + {7200 0 3600 0 10 0 5 4 0 0 0 0 3 0 5 3 0 0 0} :Europe/Helsinki + {7200 0 3600 0 9 0 3 2 0 0 0 0 3 5 5 2 0 0 0} :Asia/Jerusalem + {7200 0 3600 0 9 0 5 1 0 0 0 0 3 0 5 0 0 0 0} :Europe/Bucharest + {7200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Europe/Athens + {7200 0 3600 0 9 5 5 1 0 0 0 0 3 4 5 0 0 0 0} :Asia/Amman + {7200 0 3600 0 10 6 5 23 59 59 999 0 3 0 5 0 0 0 0} + :Asia/Beirut + {7200 0 -3600 0 4 0 1 2 0 0 0 0 9 0 1 2 0 0 0} :Africa/Windhoek + {10800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Riyadh + {10800 0 3600 0 10 0 1 4 0 0 0 0 4 0 1 3 0 0 0} :Asia/Baghdad + {10800 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Europe/Moscow + {12600 0 3600 0 9 2 4 2 0 0 0 0 3 0 1 2 0 0 0} :Asia/Tehran + {14400 0 3600 0 10 0 5 5 0 0 0 0 3 0 5 4 0 0 0} :Asia/Baku + {14400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Muscat + {14400 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Tbilisi + {16200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Kabul + {18000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Karachi + {18000 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Yekaterinburg + {19800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Calcutta + {20700 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Katmandu + {21600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Dhaka + {21600 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Novosibirsk + {23400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Rangoon + {25200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Bangkok + {25200 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Krasnoyarsk + {28800 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Chongqing + {28800 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Irkutsk + {32400 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Asia/Tokyo + {32400 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Yakutsk + {34200 0 3600 0 3 0 5 3 0 0 0 0 10 0 5 2 0 0 0} :Australia/Adelaide + {34200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Australia/Darwin + {36000 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Australia/Brisbane + {36000 0 3600 0 10 0 5 3 0 0 0 0 3 0 5 2 0 0 0} :Asia/Vladivostok + {36000 0 3600 0 3 0 5 3 0 0 0 0 10 0 1 2 0 0 0} :Australia/Hobart + {36000 0 3600 0 3 0 5 3 0 0 0 0 10 0 5 2 0 0 0} :Australia/Sydney + {39600 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Noumea + {43200 0 3600 0 3 0 3 3 0 0 0 0 10 0 1 2 0 0 0} :Pacific/Auckland + {43200 0 3600 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} :Pacific/Fiji + {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. + + variable DateParseActions { + + { seconds } 0 {} + + { julianDay } 1 {} + + { era century yearOfCentury month dayOfMonth } 2 { + dict set date year [expr { 100 * [dict get $date century] + + [dict get $date yearOfCentury] }] + set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \ + $changeover] + } + { era century yearOfCentury dayOfYear } 2 { + dict set date year [expr { 100 * [dict get $date century] + + [dict get $date yearOfCentury] }] + set date [GetJulianDayFromEraYearDay $date[set date {}] \ + $changeover] + } + + { century yearOfCentury month dayOfMonth } 3 { + dict set date era CE + dict set date year [expr { 100 * [dict get $date century] + + [dict get $date yearOfCentury] }] + set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \ + $changeover] + } + { century yearOfCentury dayOfYear } 3 { + dict set date era CE + dict set date year [expr { 100 * [dict get $date century] + + [dict get $date yearOfCentury] }] + set date [GetJulianDayFromEraYearDay $date[set date {}] \ + $changeover] + } + { iso8601Century iso8601YearOfCentury iso8601Week dayOfWeek } 3 { + dict set date era CE + dict set date iso8601Year \ + [expr { 100 * [dict get $date iso8601Century] + + [dict get $date iso8601YearOfCentury] }] + set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \ + $changeover] + } + + { yearOfCentury month dayOfMonth } 4 { + set date [InterpretTwoDigitYear $date[set date {}] $baseTime] + dict set date era CE + set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \ + $changeover] + } + { yearOfCentury dayOfYear } 4 { + set date [InterpretTwoDigitYear $date[set date {}] $baseTime] + dict set date era CE + set date [GetJulianDayFromEraYearDay $date[set date {}] \ + $changeover] + } + { iso8601YearOfCentury iso8601Week dayOfWeek } 4 { + set date [InterpretTwoDigitYear \ + $date[set date {}] $baseTime \ + iso8601YearOfCentury iso8601Year] + dict set date era CE + set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \ + $changeover] + } + + { month dayOfMonth } 5 { + set date [AssignBaseYear $date[set date {}] \ + $baseTime $timeZone $changeover] + set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \ + $changeover] + } + { dayOfYear } 5 { + set date [AssignBaseYear $date[set date {}] \ + $baseTime $timeZone $changeover] + set date [GetJulianDayFromEraYearDay $date[set date {}] \ + $changeover] + } + { iso8601Week dayOfWeek } 5 { + set date [AssignBaseIso8601Year $date[set date {}] \ + $baseTime $timeZone $changeover] + set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \ + $changeover] + } + + { dayOfMonth } 6 { + set date [AssignBaseMonth $date[set date {}] \ + $baseTime $timeZone $changeover] + set date [GetJulianDayFromEraYearMonthDay $date[set date {}] \ + $changeover] + } + + { dayOfWeek } 7 { + set date [AssignBaseWeek $date[set date {}] \ + $baseTime $timeZone $changeover] + set date [GetJulianDayFromEraYearWeekDay $date[set date {}] \ + $changeover] + } + + {} 8 { + set date [AssignBaseJulianDay $date[set date {}] \ + $baseTime $timeZone $changeover] + } + } + + # Groups of fields that specify time of day, priorities, and code that + # processes them + + variable TimeParseActions { + + seconds 1 {} + + { hourAMPM minute second amPmIndicator } 2 { + dict set date secondOfDay [InterpretHMSP $date] + } + { hour minute second } 2 { + dict set date secondOfDay [InterpretHMS $date] + } + + { hourAMPM minute amPmIndicator } 3 { + dict set date second 0 + dict set date secondOfDay [InterpretHMSP $date] + } + { hour minute } 3 { + dict set date second 0 + dict set date secondOfDay [InterpretHMS $date] + } + + { hourAMPM amPmIndicator } 4 { + dict set date minute 0 + dict set date second 0 + dict set date secondOfDay [InterpretHMSP $date] + } + { hour } 4 { + dict set date minute 0 + dict set date second 0 + dict set date secondOfDay [InterpretHMS $date] + } + + { } 5 { + dict set date secondOfDay 0 + } + } + + # Legacy time zones, used primarily for parsing RFC822 dates. + + variable LegacyTimeZone [dict create \ + gmt +0000 \ + ut +0000 \ + utc +0000 \ + bst +0100 \ + wet +0000 \ + wat -0100 \ + at -0200 \ + nft -0330 \ + nst -0330 \ + ndt -0230 \ + ast -0400 \ + adt -0300 \ + est -0500 \ + edt -0400 \ + cst -0600 \ + cdt -0500 \ + mst -0700 \ + mdt -0600 \ + pst -0800 \ + pdt -0700 \ + yst -0900 \ + ydt -0800 \ + hst -1000 \ + hdt -0900 \ + cat -1000 \ + ahst -1000 \ + nt -1100 \ + idlw -1200 \ + cet +0100 \ + cest +0200 \ + met +0100 \ + mewt +0100 \ + mest +0200 \ + swt +0100 \ + sst +0200 \ + fwt +0100 \ + fst +0200 \ + eet +0200 \ + eest +0300 \ + bt +0300 \ + it +0330 \ + zp4 +0400 \ + zp5 +0500 \ + ist +0530 \ + zp6 +0600 \ + wast +0700 \ + wadt +0800 \ + jt +0730 \ + cct +0800 \ + jst +0900 \ + kst +0900 \ + cast +0930 \ + jdt +1000 \ + kdt +1000 \ + cadt +1030 \ + east +1000 \ + eadt +1030 \ + gst +1000 \ + nzt +1200 \ + nzst +1200 \ + nzdt +1300 \ + idle +1200 \ + a +0100 \ + b +0200 \ + c +0300 \ + d +0400 \ + e +0500 \ + f +0600 \ + g +0700 \ + h +0800 \ + i +0900 \ + k +1000 \ + l +1100 \ + m +1200 \ + n -0100 \ + o -0200 \ + p -0300 \ + q -0400 \ + r -0500 \ + s -0600 \ + t -0700 \ + u -0800 \ + v -0900 \ + w -1000 \ + x -1100 \ + y -1200 \ + z +0000 \ + ] + + # Caches + + variable LocaleNumeralCache {}; # Dictionary whose keys are locale + # names and whose values are pairs + # comprising regexes matching numerals + # in the given locales and dictionaries + # mapping the numerals to their numeric + # values. + # variable CachedSystemTimeZone; # If 'CachedSystemTimeZone' exists, + # it contains the value of the + # system time zone, as determined from + # the environment. + variable TimeZoneBad {}; # Dictionary whose keys are time zone + # names and whose values are 1 if + # the time zone is unknown and 0 + # if it is known. + variable TZData; # Array whose keys are time zone names + # and whose values are lists of quads + # comprising start time, UTC offset, + # Daylight Saving Time indicator, and + # time zone abbreviation. + variable FormatProc; # Array mapping format group + # and locale to the name of a procedure + # that renders the given format +} +::tcl::clock::Initialize + +#---------------------------------------------------------------------- +# +# clock format -- +# +# 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. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::format { args } { + + variable FormatProc + variable TZData + + lassign [ParseFormatArgs {*}$args] format locale timezone + set locale [string tolower $locale] + set clockval [lindex $args 0] + + # Get the data for time changes in the given zone + + if {$timezone eq ""} { + set timezone [GetSystemTimeZone] + } + if {![info exists TZData($timezone)]} { + if {[catch {SetupTimeZone $timezone} retval opts]} { + dict unset opts -errorinfo + 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. + + set procName formatproc'$format'$locale + set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName] + if {[info exists FormatProc($procName)]} { + set procName $FormatProc($procName) + } else { + set FormatProc($procName) \ + [ParseClockFormatFormat $procName $format $locale] + } + + return [$procName $clockval $timezone] + +} + +#---------------------------------------------------------------------- +# +# ParseClockFormatFormat -- +# +# Builds and caches a procedure that formats a time value. +# +# Parameters: +# format -- Format string to use +# locale -- Locale in which the format string is to be interpreted +# +# Results: +# Returns the name of the newly-built procedure. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::ParseClockFormatFormat {procName format locale} { + + if {[namespace which $procName] ne {}} { + return $procName + } + + # Map away the locale-dependent composite format groups + + EnterLocale $locale + + # 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 + } +} + +proc ::tcl::clock::ParseClockFormatFormat2 {format locale procName} { + set didLocaleEra 0 + set didLocaleNumerals 0 + set preFormatCode \ + [string map [list @GREGORIAN_CHANGE_DATE@ \ + [mc GREGORIAN_CHANGE_DATE]] \ + { + variable TZData + set date [GetDateFields $clockval \ + $TZData($timezone) \ + @GREGORIAN_CHANGE_DATE@] + }] + set formatString {} + set substituents {} + set state {} + + set format [LocalizeFormat $locale $format] + + foreach char [split $format {}] { + switch -exact -- $state { + {} { + if { [string equal % $char] } { + set state percent + } else { + append formatString $char + } + } + percent { # Character following a '%' character + set state {} + switch -exact -- $char { + % { # A literal character, '%' + append formatString %% + } + a { # Day of week, abbreviated + append formatString %s + append substituents \ + [string map \ + [list @DAYS_OF_WEEK_ABBREV@ \ + [list [mc DAYS_OF_WEEK_ABBREV]]] \ + { [lindex @DAYS_OF_WEEK_ABBREV@ \ + [expr {[dict get $date dayOfWeek] \ + % 7}]]}] + } + A { # Day of week, spelt out. + append formatString %s + append substituents \ + [string map \ + [list @DAYS_OF_WEEK_FULL@ \ + [list [mc DAYS_OF_WEEK_FULL]]] \ + { [lindex @DAYS_OF_WEEK_FULL@ \ + [expr {[dict get $date dayOfWeek] \ + % 7}]]}] + } + b - h { # Name of month, abbreviated. + append formatString %s + append substituents \ + [string map \ + [list @MONTHS_ABBREV@ \ + [list [mc MONTHS_ABBREV]]] \ + { [lindex @MONTHS_ABBREV@ \ + [expr {[dict get $date month]-1}]]}] + } + B { # Name of month, spelt out + append formatString %s + append substituents \ + [string map \ + [list @MONTHS_FULL@ \ + [list [mc MONTHS_FULL]]] \ + { [lindex @MONTHS_FULL@ \ + [expr {[dict get $date month]-1}]]}] + } + C { # Century number + append formatString %02d + append substituents \ + { [expr {[dict get $date year] / 100}]} + } + d { # Day of month, with leading zero + append formatString %02d + append substituents { [dict get $date dayOfMonth]} + } + e { # Day of month, without leading zero + append formatString %2d + append substituents { [dict get $date dayOfMonth]} + } + E { # Format group in a locale-dependent + # alternative era + set state percentE + if {!$didLocaleEra} { + append preFormatCode \ + [string map \ + [list @LOCALE_ERAS@ \ + [list [mc LOCALE_ERAS]]] \ + { + set date [GetLocaleEra \ + $date[set date {}] \ + @LOCALE_ERAS@]}] \n + set didLocaleEra 1 + } + if {!$didLocaleNumerals} { + append preFormatCode \ + [list set localeNumerals \ + [mc LOCALE_NUMERALS]] \n + set didLocaleNumerals 1 + } + } + g { # Two-digit year relative to ISO8601 + # week number + append formatString %02d + append substituents \ + { [expr { [dict get $date iso8601Year] % 100 }]} + } + G { # Four-digit year relative to ISO8601 + # week number + append formatString %02d + append substituents { [dict get $date iso8601Year]} + } + H { # Hour in the 24-hour day, leading zero + append formatString %02d + append substituents \ + { [expr { [dict get $date localSeconds] \ + / 3600 % 24}]} + } + I { # Hour AM/PM, with leading zero + append formatString %02d + append substituents \ + { [expr { ( ( ( [dict get $date localSeconds] \ + % 86400 ) \ + + 86400 \ + - 3600 ) \ + / 3600 ) \ + % 12 + 1 }] } + } + j { # Day of year (001-366) + append formatString %03d + append substituents { [dict get $date dayOfYear]} + } + J { # Julian Day Number + append formatString %07ld + append substituents { [dict get $date julianDay]} + } + k { # Hour (0-23), no leading zero + append formatString %2d + append substituents \ + { [expr { [dict get $date localSeconds] + / 3600 + % 24 }]} + } + l { # Hour (12-11), no leading zero + append formatString %2d + append substituents \ + { [expr { ( ( ( [dict get $date localSeconds] + % 86400 ) + + 86400 + - 3600 ) + / 3600 ) + % 12 + 1 }]} + } + m { # Month number, leading zero + append formatString %02d + append substituents { [dict get $date month]} + } + M { # Minute of the hour, leading zero + append formatString %02d + append substituents \ + { [expr { [dict get $date localSeconds] + / 60 + % 60 }]} + } + n { # A literal newline + append formatString \n + } + N { # Month number, no leading zero + append formatString %2d + append substituents { [dict get $date month]} + } + O { # A format group in the locale's + # alternative numerals + set state percentO + if {!$didLocaleNumerals} { + append preFormatCode \ + [list set localeNumerals \ + [mc LOCALE_NUMERALS]] \n + set didLocaleNumerals 1 + } + } + p { # Localized 'AM' or 'PM' indicator + # converted to uppercase + append formatString %s + append preFormatCode \ + [list set AM [string toupper [mc AM]]] \n \ + [list set PM [string toupper [mc PM]]] \n + append substituents \ + { [expr {(([dict get $date localSeconds] + % 86400) < 43200) ? + $AM : $PM}]} + } + P { # Localized 'AM' or 'PM' indicator + append formatString %s + append preFormatCode \ + [list set am [mc AM]] \n \ + [list set pm [mc PM]] \n + append substituents \ + { [expr {(([dict get $date localSeconds] + % 86400) < 43200) ? + $am : $pm}]} + + } + Q { # Hi, Jeff! + append formatString %s + append substituents { [FormatStarDate $date]} + } + s { # Seconds from the Posix Epoch + append formatString %s + append substituents { [dict get $date seconds]} + } + S { # Second of the minute, with + # leading zero + append formatString %02d + append substituents \ + { [expr { [dict get $date localSeconds] + % 60 }]} + } + t { # A literal tab character + append formatString \t + } + u { # Day of the week (1-Monday, 7-Sunday) + append formatString %1d + append substituents { [dict get $date dayOfWeek]} + } + U { # Week of the year (00-53). The + # first Sunday of the year is the + # first day of week 01 + append formatString %02d + append preFormatCode { + set dow [dict get $date dayOfWeek] + if { $dow == 7 } { + set dow 0 + } + incr dow + set UweekNumber \ + [expr { ( [dict get $date dayOfYear] + - $dow + 7 ) + / 7 }] + } + append substituents { $UweekNumber} + } + V { # The ISO8601 week number + append formatString %02d + append substituents { [dict get $date iso8601Week]} + } + w { # Day of the week (0-Sunday, + # 6-Saturday) + append formatString %1d + append substituents \ + { [expr { [dict get $date dayOfWeek] % 7 }]} + } + W { # Week of the year (00-53). The first + # Monday of the year is the first day + # of week 01. + append preFormatCode { + set WweekNumber \ + [expr { ( [dict get $date dayOfYear] + - [dict get $date dayOfWeek] + + 7 ) + / 7 }] + } + append formatString %02d + append substituents { $WweekNumber} + } + y { # The two-digit year of the century + append formatString %02d + append substituents \ + { [expr { [dict get $date year] % 100 }]} + } + Y { # The four-digit year + append formatString %04d + append substituents { [dict get $date year]} + } + z { # The time zone as hours and minutes + # east (+) or west (-) of Greenwich + append formatString %s + append substituents { [FormatNumericTimeZone \ + [dict get $date tzOffset]]} + } + Z { # The name of the time zone + append formatString %s + append substituents { [dict get $date tzName]} + } + % { # A literal percent character + append formatString %% + } + default { # An unknown escape sequence + append formatString %% $char + } + } + } + percentE { # Character following %E + set state {} + switch -exact -- $char { + E { + append formatString %s + append substituents { } \ + [string map \ + [list @BCE@ [list [mc BCE]] \ + @CE@ [list [mc CE]]] \ + {[dict get {BCE @BCE@ CE @CE@} \ + [dict get $date era]]}] + } + C { # Locale-dependent era + append formatString %s + append substituents { [dict get $date localeEra]} + } + y { # Locale-dependent year of the era + append preFormatCode { + set y [dict get $date localeYear] + if { $y >= 0 && $y < 100 } { + set Eyear [lindex $localeNumerals $y] + } else { + set Eyear $y + } + } + append formatString %s + append substituents { $Eyear} + } + default { # Unknown %E format group + append formatString %%E $char + } + } + } + percentO { # Character following %O + set state {} + switch -exact -- $char { + d - e { # Day of the month in alternative + # numerals + append formatString %s + append substituents \ + { [lindex $localeNumerals \ + [dict get $date dayOfMonth]]} + } + H - k { # Hour of the day in alternative + # numerals + append formatString %s + append substituents \ + { [lindex $localeNumerals \ + [expr { [dict get $date localSeconds] + / 3600 + % 24 }]]} + } + I - l { # Hour (12-11) AM/PM in alternative + # numerals + append formatString %s + append substituents \ + { [lindex $localeNumerals \ + [expr { ( ( ( [dict get $date localSeconds] + % 86400 ) + + 86400 + - 3600 ) + / 3600 ) + % 12 + 1 }]]} + } + m { # Month number in alternative numerals + append formatString %s + append substituents \ + { [lindex $localeNumerals [dict get $date month]]} + } + M { # Minute of the hour in alternative + # numerals + append formatString %s + append substituents \ + { [lindex $localeNumerals \ + [expr { [dict get $date localSeconds] + / 60 + % 60 }]]} + } + S { # Second of the minute in alternative + # numerals + append formatString %s + append substituents \ + { [lindex $localeNumerals \ + [expr { [dict get $date localSeconds] + % 60 }]]} + } + u { # Day of the week (Monday=1,Sunday=7) + # in alternative numerals + append formatString %s + append substituents \ + { [lindex $localeNumerals \ + [dict get $date dayOfWeek]]} + } + w { # Day of the week (Sunday=0,Saturday=6) + # in alternative numerals + append formatString %s + append substituents \ + { [lindex $localeNumerals \ + [expr { [dict get $date dayOfWeek] % 7 }]]} + } + y { # Year of the century in alternative + # numerals + append formatString %s + append substituents \ + { [lindex $localeNumerals \ + [expr { [dict get $date year] % 100 }]]} + } + default { # Unknown format group + append formatString %%O $char + } + } + } + } + } + + # Clean up any improperly terminated groups + + switch -exact -- $state { + percent { + append formatString %% + } + percentE { + append retval %%E + } + percentO { + append retval %%O + } + } + + proc $procName {clockval timezone} " + $preFormatCode + return \[::format [list $formatString] $substituents\] + " + + # puts [list $procName [info args $procName] [info body $procName]] + + return $procName +} + +#---------------------------------------------------------------------- +# +# clock scan -- +# +# 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. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::scan { args } { + + set format {} + + # Check the count of args + + if { [llength $args] < 1 || [llength $args] % 2 != 1 } { + set cmdName "clock scan" + return -code error \ + -errorcode [list CLOCK wrongNumArgs] \ + "wrong \# args: should be\ + \"$cmdName string\ + ?-base seconds?\ + ?-format string? ?-gmt boolean?\ + ?-locale LOCALE? ?-timezone ZONE?\"" + } + + # Set defaults + + set base [clock seconds] + set string [lindex $args 0] + set format {} + set gmt 0 + set locale c + set timezone [GetSystemTimeZone] + + # Pick up command line options. + + foreach { flag value } [lreplace $args 0 0] { + set saw($flag) {} + switch -exact -- $flag { + -b - -ba - -bas - -base { + set base $value + } + -f - -fo - -for - -form - -forma - -format { + set format $value + } + -g - -gm - -gmt { + set gmt $value + } + -l - -lo - -loc - -loca - -local - -locale { + set locale [string tolower $value] + } + -t - -ti - -tim - -time - -timez - -timezo - -timezon - -timezone { + set timezone $value + } + default { + return -code error \ + -errorcode [list CLOCK badOption $flag] \ + "bad option \"$flag\",\ + must be -base, -format, -gmt, -locale or -timezone" + } + } + } + + # Check options for validity + + if { [info exists saw(-gmt)] && [info exists saw(-timezone)] } { + return -code error \ + -errorcode [list CLOCK gmtWithTimezone] \ + "cannot use -gmt and -timezone in same call" + } + if { [catch { expr { wide($base) } } result] } { + 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 { ![info exists saw(-format)] } { + # 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] \ + "legacy \[clock scan\] does not support -locale" + + } + return [FreeScan $string $base $timezone $locale] + } + + # Change locale if a fresh locale has been given on the command line. + + EnterLocale $locale + + try { + # 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 + dict unset opts -errorinfo + return -options $opts $result + } +} + +#---------------------------------------------------------------------- +# +# FreeScan -- +# +# Scans a time in free format +# +# Parameters: +# string - String containing the time to scan +# base - Base time, expressed in seconds from the Epoch +# timezone - Default time zone in which the time will be expressed +# 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 +# +#---------------------------------------------------------------------- + +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} { + dict unset opts -errorinfo + return -options $opts $retval + } + + # Extract year, month and day from the base time for the parser to use as + # defaults + + set date [GetDateFields $base $TZData($timezone) 2361222] + dict set date secondOfDay [expr { + [dict get $date localSeconds] % 86400 + }] + + # 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" + } + + # 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 + if { $y < 100 } { + if { $y >= 39 } { + incr y 1900 + } else { + incr y 2000 + } + } + dict set date era CE + dict set date year $y + dict set date month $m + dict set date dayOfMonth $d + if { $parseTime eq {} } { + set parseTime 0 + } + } + + # 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 \ + [expr { 60 * $minEast + 3600 * $dstFlag }]] + SetupTimeZone $timezone + } + dict set date tzName $timezone + + # Assemble date, time, zone into seconds-from-epoch + + 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 + && ( [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 tzName $timezone + set date [ConvertLocalToUTC $date[set date {}] $TZData($timezone) 2361222] + set seconds [dict get $date seconds] + + # Do relative times + + if { [llength $parseRel] > 0 } { + lassign $parseRel relMonth relDay relSecond + 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 + }]] + incr jdwkday [expr { 7 * $dayOrdinal }] + if { $dayOrdinal > 0 } { + incr jdwkday -7 + } + 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 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] }] + if { $monthDiff <= 0 } { + incr monthDiff 12 + } + incr monthOrdinal -1 + } else { + set monthDiff [expr { [dict get $date month] - $monthNumber }] + if { $monthDiff >= 0 } { + incr monthDiff -12 + } + incr monthOrdinal + } + set seconds [add $seconds $monthOrdinal years $monthDiff months \ + -timezone $timezone -locale $locale] + } + + return $seconds +} + + +#---------------------------------------------------------------------- +# +# ParseClockScanFormat -- +# +# Parses a format string given to [clock scan -format] +# +# Parameters: +# formatString - The format being parsed +# 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] +# +# 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 +# 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. + + set procName scanproc'$formatString'$locale + set procName [namespace current]::[string map {: {\:} \\ {\\}} $procName] + if { [namespace which $procName] != {} } { + return $procName + } + + variable DateParseActions + variable TimeParseActions + + # Localize the %x, %X, etc. groups + + set formatString [LocalizeFormat $locale $formatString] + + # Condense whitespace + + regsub -all {[[:space:]]+} $formatString { } formatString + + # Walk through the groups of the format string. In this loop, we + # accumulate: + # - a regular expression that matches the string, + # - the count of capturing brackets in the regexp + # - a set of code that post-processes the fields captured by the regexp, + # - a dictionary whose keys are the names of fields that are present + # in the format string. + + set re {^[[:space:]]*} + set captureCount 0 + set postcode {} + set fieldSet [dict create] + set fieldCount 0 + set postSep {} + set state {} + + foreach c [split $formatString {}] { + switch -exact -- $state { + {} { + if { $c eq "%" } { + set state % + } elseif { $c eq " " } { + append re {[[:space:]]+} + } else { + if { ! [string is alnum $c] } { + append re "\\" + } + append re $c + } + } + % { + set state {} + switch -exact -- $c { + % { + append re % + } + { } { + append re "\[\[:space:\]\]*" + } + a - A { # Day of week, in words + set l {} + foreach \ + i {7 1 2 3 4 5 6} \ + abr [mc DAYS_OF_WEEK_ABBREV] \ + full [mc DAYS_OF_WEEK_FULL] { + dict set l [string tolower $abr] $i + dict set l [string tolower $full] $i + incr i + } + lassign [UniquePrefixRegexp $l] regex lookup + append re ( $regex ) + dict set fieldSet dayOfWeek [incr fieldCount] + append postcode "dict set date dayOfWeek \[" \ + "dict get " [list $lookup] " " \ + \[ {string tolower $field} [incr captureCount] \] \ + "\]\n" + } + b - B - h { # Name of month + set i 0 + set l {} + foreach \ + abr [mc MONTHS_ABBREV] \ + full [mc MONTHS_FULL] { + incr i + dict set l [string tolower $abr] $i + dict set l [string tolower $full] $i + } + lassign [UniquePrefixRegexp $l] regex lookup + append re ( $regex ) + dict set fieldSet month [incr fieldCount] + append postcode "dict set date month \[" \ + "dict get " [list $lookup] \ + " " \[ {string tolower $field} \ + [incr captureCount] \] \ + "\]\n" + } + C { # Gregorian century + append re \\s*(\\d\\d?) + dict set fieldSet century [incr fieldCount] + append postcode "dict set date century \[" \ + "::scan \$field" [incr captureCount] " %d" \ + "\]\n" + } + d - e { # Day of month + append re \\s*(\\d\\d?) + dict set fieldSet dayOfMonth [incr fieldCount] + append postcode "dict set date dayOfMonth \[" \ + "::scan \$field" [incr captureCount] " %d" \ + "\]\n" + } + E { # Prefix for locale-specific codes + set state %E + } + g { # ISO8601 2-digit year + append re \\s*(\\d\\d) + dict set fieldSet iso8601YearOfCentury \ + [incr fieldCount] + append postcode \ + "dict set date iso8601YearOfCentury \[" \ + "::scan \$field" [incr captureCount] " %d" \ + "\]\n" + } + G { # ISO8601 4-digit year + append re \\s*(\\d\\d)(\\d\\d) + dict set fieldSet iso8601Century [incr fieldCount] + dict set fieldSet iso8601YearOfCentury \ + [incr fieldCount] + append postcode \ + "dict set date iso8601Century \[" \ + "::scan \$field" [incr captureCount] " %d" \ + "\]\n" \ + "dict set date iso8601YearOfCentury \[" \ + "::scan \$field" [incr captureCount] " %d" \ + "\]\n" + } + H - k { # Hour of day + append re \\s*(\\d\\d?) + dict set fieldSet hour [incr fieldCount] + append postcode "dict set date hour \[" \ + "::scan \$field" [incr captureCount] " %d" \ + "\]\n" + } + I - l { # Hour, AM/PM + append re \\s*(\\d\\d?) + dict set fieldSet hourAMPM [incr fieldCount] + append postcode "dict set date hourAMPM \[" \ + "::scan \$field" [incr captureCount] " %d" \ + "\]\n" + } + j { # Day of year + append re \\s*(\\d\\d?\\d?) + dict set fieldSet dayOfYear [incr fieldCount] + append postcode "dict set date dayOfYear \[" \ + "::scan \$field" [incr captureCount] " %d" \ + "\]\n" + } + J { # Julian Day Number + append re \\s*(\\d+) + dict set fieldSet julianDay [incr fieldCount] + append postcode "dict set date julianDay \[" \ + "::scan \$field" [incr captureCount] " %ld" \ + "\]\n" + } + m - N { # Month number + append re \\s*(\\d\\d?) + dict set fieldSet month [incr fieldCount] + append postcode "dict set date month \[" \ + "::scan \$field" [incr captureCount] " %d" \ + "\]\n" + } + M { # Minute + append re \\s*(\\d\\d?) + dict set fieldSet minute [incr fieldCount] + append postcode "dict set date minute \[" \ + "::scan \$field" [incr captureCount] " %d" \ + "\]\n" + } + n { # Literal newline + append re \\n + } + O { # Prefix for locale numerics + set state %O + } + p - P { # AM/PM indicator + set l [list [string tolower [mc AM]] 0 \ + [string tolower [mc PM]] 1] + lassign [UniquePrefixRegexp $l] regex lookup + append re ( $regex ) + dict set fieldSet amPmIndicator [incr fieldCount] + append postcode "dict set date amPmIndicator \[" \ + "dict get " [list $lookup] " \[string tolower " \ + "\$field" \ + [incr captureCount] \ + "\]\]\n" + } + Q { # Hi, Jeff! + append re {Stardate\s+([-+]?\d+)(\d\d\d)[.](\d)} + incr captureCount + dict set fieldSet seconds [incr fieldCount] + append postcode {dict set date seconds } \[ \ + {ParseStarDate $field} [incr captureCount] \ + { $field} [incr captureCount] \ + { $field} [incr captureCount] \ + \] \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. + append re {\s*([-+]?\d+)} + dict set fieldSet seconds [incr fieldCount] + append postcode {dict set date seconds } \[ \ + {ScanWide $field} [incr captureCount] \] \n + } + S { # Second + append re \\s*(\\d\\d?) + dict set fieldSet second [incr fieldCount] + append postcode "dict set date second \[" \ + "::scan \$field" [incr captureCount] " %d" \ + "\]\n" + } + t { # Literal tab character + append re \\t + } + u - w { # Day number within week, 0 or 7 == Sun + # 1=Mon, 6=Sat + append re \\s*(\\d) + dict set fieldSet dayOfWeek [incr fieldCount] + append postcode {::scan $field} [incr captureCount] \ + { %d dow} \n \ + { + if { $dow == 0 } { + set dow 7 + } elseif { $dow > 7 } { + return -code error \ + -errorcode [list CLOCK badDayOfWeek] \ + "day of week is greater than 7" + } + 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. + 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 \[" \ + "::scan \$field" [incr captureCount] " %d" \ + "\]\n" + } + W { # Week of the year (00-53). The first + # Monday of the year is the first day + # of week 01. No scan rule uses this + # group. + append re \\s*\\d\\d? + } + y { # Two-digit Gregorian year + append re \\s*(\\d\\d?) + dict set fieldSet yearOfCentury [incr fieldCount] + append postcode "dict set date yearOfCentury \[" \ + "::scan \$field" [incr captureCount] " %d" \ + "\]\n" + } + Y { # 4-digit Gregorian year + append re \\s*(\\d\\d)(\\d\\d) + dict set fieldSet century [incr fieldCount] + dict set fieldSet yearOfCentury [incr fieldCount] + append postcode \ + "dict set date century \[" \ + "::scan \$field" [incr captureCount] " %d" \ + "\]\n" \ + "dict set date yearOfCentury \[" \ + "::scan \$field" [incr captureCount] " %d" \ + "\]\n" + } + z - Z { # Time zone name + append re {(?:([-+]\d\d(?::?\d\d(?::?\d\d)?)?)|([[:alnum:]]{1,4}))} + dict set fieldSet tzName [incr fieldCount] + append postcode \ + {if } \{ { $field} [incr captureCount] \ + { ne "" } \} { } \{ \n \ + {dict set date tzName $field} \ + $captureCount \n \ + \} { else } \{ \n \ + {dict set date tzName } \[ \ + {ConvertLegacyTimeZone $field} \ + [incr captureCount] \] \n \ + \} \n \ + } + % { # Literal percent character + append re % + } + default { + append re % + if { ! [string is alnum $c] } { + append re \\ + } + append re $c + } + } + } + %E { + switch -exact -- $c { + C { # Locale-dependent era + set d {} + foreach triple [mc LOCALE_ERAS] { + lassign $triple t symbol year + dict set d [string tolower $symbol] $year + } + lassign [UniquePrefixRegexp $d] regex lookup + append re (?: $regex ) + } + E { + set l {} + dict set l [string tolower [mc BCE]] BCE + dict set l [string tolower [mc CE]] CE + dict set l b.c.e. BCE + dict set l c.e. CE + dict set l b.c. BCE + dict set l a.d. CE + lassign [UniquePrefixRegexp $l] regex lookup + append re ( $regex ) + dict set fieldSet era [incr fieldCount] + append postcode "dict set date era \["\ + "dict get " [list $lookup] \ + { } \[ {string tolower $field} \ + [incr captureCount] \] \ + "\]\n" + } + y { # Locale-dependent year of the era + lassign [LocaleNumeralMatcher $locale] regex lookup + append re $regex + incr captureCount + } + default { + append re %E + if { ! [string is alnum $c] } { + append re \\ + } + append re $c + } + } + set state {} + } + %O { + switch -exact -- $c { + d - e { + lassign [LocaleNumeralMatcher $locale] regex lookup + append re $regex + dict set fieldSet dayOfMonth [incr fieldCount] + append postcode "dict set date dayOfMonth \[" \ + "dict get " [list $lookup] " \$field" \ + [incr captureCount] \ + "\]\n" + } + H - k { + lassign [LocaleNumeralMatcher $locale] regex lookup + append re $regex + dict set fieldSet hour [incr fieldCount] + append postcode "dict set date hour \[" \ + "dict get " [list $lookup] " \$field" \ + [incr captureCount] \ + "\]\n" + } + I - l { + lassign [LocaleNumeralMatcher $locale] regex lookup + append re $regex + dict set fieldSet hourAMPM [incr fieldCount] + append postcode "dict set date hourAMPM \[" \ + "dict get " [list $lookup] " \$field" \ + [incr captureCount] \ + "\]\n" + } + m { + lassign [LocaleNumeralMatcher $locale] regex lookup + append re $regex + dict set fieldSet month [incr fieldCount] + append postcode "dict set date month \[" \ + "dict get " [list $lookup] " \$field" \ + [incr captureCount] \ + "\]\n" + } + M { + lassign [LocaleNumeralMatcher $locale] regex lookup + append re $regex + dict set fieldSet minute [incr fieldCount] + append postcode "dict set date minute \[" \ + "dict get " [list $lookup] " \$field" \ + [incr captureCount] \ + "\]\n" + } + S { + lassign [LocaleNumeralMatcher $locale] regex lookup + append re $regex + dict set fieldSet second [incr fieldCount] + append postcode "dict set date second \[" \ + "dict get " [list $lookup] " \$field" \ + [incr captureCount] \ + "\]\n" + } + u - w { + lassign [LocaleNumeralMatcher $locale] regex lookup + append re $regex + dict set fieldSet dayOfWeek [incr fieldCount] + append postcode "set dow \[dict get " [list $lookup] \ + { $field} [incr captureCount] \] \n \ + { + if { $dow == 0 } { + set dow 7 + } elseif { $dow > 7 } { + return -code error \ + -errorcode [list CLOCK badDayOfWeek] \ + "day of week is greater than 7" + } + dict set date dayOfWeek $dow + } + } + y { + lassign [LocaleNumeralMatcher $locale] regex lookup + append re $regex + dict set fieldSet yearOfCentury [incr fieldCount] + append postcode {dict set date yearOfCentury } \[ \ + {dict get } [list $lookup] { $field} \ + [incr captureCount] \] \n + } + default { + append re %O + if { ! [string is alnum $c] } { + append re \\ + } + append re $c + } + } + set state {} + } + } + } + + # Clean up any unfinished format groups + + append re $state \\s*\$ + + # Build the procedure + + set procBody {} + append procBody "variable ::tcl::clock::TZData" \n + append procBody "if \{ !\[ regexp -nocase [list $re] \$string ->" + for { set i 1 } { $i <= $captureCount } { incr i } { + append procBody " " field $i + } + append procBody "\] \} \{" \n + append procBody { + return -code error -errorcode [list CLOCK badInputString] \ + {input string does not match supplied format} + } + append procBody \}\n + append procBody "set date \[dict create\]" \n + append procBody {dict set date tzName $timeZone} \n + 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. + + if { ![dict exists $fieldSet seconds] + && ![dict exists $fieldSet starDate] } { + if { [dict exists $fieldSet tzName] } { + append procBody { + set timeZone [dict get $date tzName] + } + } + append procBody { + ::tcl::clock::SetupTimeZone $timeZone + } + } + + # Add code that gets Julian Day Number from the fields. + + append procBody [MakeParseCodeFromFields $fieldSet $DateParseActions] + + # Get time of day + + 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 + + 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] + }] + } + + # Finally, convert the date to local time + + append procBody { + set date [::tcl::clock::ConvertLocalToUTC $date[set date {}] \ + $TZData($timeZone) $changeover] + } + } + + # Return result + + append procBody {return [dict get $date seconds]} \n + + proc $procName { string baseTime timeZone } $procBody + + # puts [list proc $procName [list string baseTime timeZone] $procBody] + + return $procName +} + +#---------------------------------------------------------------------- +# +# LocaleNumeralMatcher -- +# +# 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. +# +# Side effects: +# Caches the result. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::LocaleNumeralMatcher {l} { + variable LocaleNumeralCache + + if { ![dict exists $LocaleNumeralCache $l] } { + set d {} + set i 0 + set sep \( + foreach n [mc LOCALE_NUMERALS] { + dict set d $n $i + regsub -all {[^[:alnum:]]} $n \\\\& subex + append re $sep $subex + set sep | + incr i + } + append re \) + dict set LocaleNumeralCache $l [list $re $d] + } + 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. +# +# Parameters: +# data - List of alternating match-strings and values. +# Match-strings with distinct values are considered +# 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'. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +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. + + set prefixMapping [dict create] + set successors [dict create {} {}] + + # Walk the key-value pairs + + foreach { key value } $data { + # Construct all prefixes of the key; + + set prefix {} + foreach char [split $key {}] { + set oldPrefix $prefix + dict set successors $oldPrefix $char {} + append prefix $char + + # Put the prefixes in the 'prefixMapping' and 'successors' + # dictionaries + + dict lappend prefixMapping $prefix $value + if { ![dict exists $successors $prefix] } { + dict set successors $prefix {} + } + } + } + + # Identify those prefixes that designate unique values, and those that are + # the full keys + + set uniquePrefixMapping {} + dict for { key valueList } $prefixMapping { + if { [llength $valueList] == 1 } { + dict set uniquePrefixMapping $key [lindex $valueList 0] + } + } + foreach { key value } $data { + dict set uniquePrefixMapping $key $value + } + + # Construct the re. + + return [list \ + [MakeUniquePrefixRegexp $successors $uniquePrefixMapping {}] \ + $uniquePrefixMapping] +} + +#---------------------------------------------------------------------- +# +# MakeUniquePrefixRegexp -- +# +# Service procedure for 'UniquePrefixRegexp' that constructs a regular +# expresison that matches the unique prefixes. +# +# Parameters: +# successors - Dictionary whose keys are all prefixes +# of keys passed to 'UniquePrefixRegexp' and whose +# values are dictionaries whose keys are the characters +# that may follow those prefixes. +# uniquePrefixMapping - Dictionary whose keys are the unique +# prefixes and whose values are not examined. +# prefixString - Current prefix being processed. +# +# Results: +# Returns a constructed regular expression that matches the set of +# unique prefixes beginning with the 'prefixString'. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +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]]] + if { [llength $schars] == 0 } { + 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 + # parentheses. + + set re {} + if { + [dict exists $uniquePrefixMapping $prefixString] + || [llength $schars] > 1 + } then { + append re "(?:" + } + + # Generate a regexp that matches the successors. + + set sep "" + foreach { c } $schars { + set nextPrefix $prefixString$c + regsub -all {[^[:alnum:]]} $c \\\\& rechar + append re $sep $rechar \ + [MakeUniquePrefixRegexp \ + $successors $uniquePrefixMapping $nextPrefix] + set sep | + } + + # If the current prefix is a unique prefix, make all following text + # optional. Otherwise, if there is more than one successor character, + # close the non-capturing parentheses. + + if { [dict exists $uniquePrefixMapping $prefixString] } { + append re ")?" + } elseif { [llength $schars] > 1 } { + append re ")" + } + + return $re +} + +#---------------------------------------------------------------------- +# +# MakeParseCodeFromFields -- +# +# 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, +# and whose values are the rightmost positions +# at which those fields appear. +# parseActions -- List of triples: field set, priority, and +# code to emit. Smaller priorities are better, and +# the list must be in ascending order by priority +# +# Results: +# Returns a burst of code that extracts the day number from the given +# date. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::MakeParseCodeFromFields { dateFields parseActions } { + + set currPrio 999 + set currFieldPos [list] + set currCodeBurst { + error "in ::tcl::clock::MakeParseCodeFromFields: can't happen" + } + + foreach { fieldSet prio parseAction } $parseActions { + # 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. + + set fieldPos [list] + set ok true + foreach field $fieldSet { + if { ! [dict exists $dateFields $field] } { + set ok 0 + break + } + lappend fieldPos [dict get $dateFields $field] + } + + # Quit if we don't have a complete set of fields + if { !$ok } { + continue + } + + # Determine whether the current answer is better than the last. + + set fPos [lsort -integer -decreasing $fieldPos] + + if { $prio == $currPrio } { + foreach currPos $currFieldPos newPos $fPos { + if { + ![string is integer $newPos] + || ![string is integer $currPos] + || $newPos > $currPos + } then { + break + } + if { $newPos < $currPos } { + set ok 0 + break + } + } + } + if { !$ok } { + continue + } + + # Remember the best possibility for extracting date information + + set currPrio $prio + set currFieldPos $fPos + set currCodeBurst $parseAction + } + + return $currCodeBurst +} + +#---------------------------------------------------------------------- +# +# EnterLocale -- +# +# Switch [mclocale] to a given locale if necessary +# +# Parameters: +# locale -- Desired locale +# +# Results: +# Returns the locale that was previously current. +# +# Side effects: +# Does [mclocale]. If necessary, loades the designated locale's files. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::EnterLocale { locale } { + if { $locale eq {system} } { + if { $::tcl_platform(platform) ne {windows} } { + # On a non-windows platform, the 'system' locale is the same as + # the 'current' locale + + 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 + + mcpackagelocale set [mclocale] + + # Make a new locale string for the system locale, and get the + # Control Panel information + + set locale [mclocale]_windows + if { ! [mcpackagelocale present $locale] } { + LoadWindowsDateTimeFormats $locale + } + } + } + if { $locale eq {current}} { + set locale [mclocale] + } + # Eventually load the locale + mcpackagelocale set $locale +} + +#---------------------------------------------------------------------- +# +# LoadWindowsDateTimeFormats -- +# +# Load the date/time formats from the Control Panel in Windows and +# convert them so that they're usable by Tcl. +# +# Parameters: +# locale - Name of the locale in whose message catalog +# the converted formats are to be stored. +# +# Results: +# None. +# +# 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. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::LoadWindowsDateTimeFormats { locale } { + # Bail out if we can't find the Registry + + variable NoRegistry + if { [info exists NoRegistry] } return + + if { ![catch { + registry get "HKEY_CURRENT_USER\\Control Panel\\International" \ + sShortDate + } string] } { + set quote {} + set datefmt {} + foreach { unquoted quoted } [split $string '] { + append datefmt $quote [string map { + dddd %A + ddd %a + dd %d + d %e + MMMM %B + MMM %b + MM %m + M %N + yyyy %Y + yy %y + y %y + gg {} + } $unquoted] + if { $quoted eq {} } { + set quote ' + } else { + set quote $quoted + } + } + ::msgcat::mcset $locale DATE_FORMAT $datefmt + } + + if { ![catch { + registry get "HKEY_CURRENT_USER\\Control Panel\\International" \ + sLongDate + } string] } { + set quote {} + set ldatefmt {} + foreach { unquoted quoted } [split $string '] { + append ldatefmt $quote [string map { + dddd %A + ddd %a + dd %d + d %e + MMMM %B + MMM %b + MM %m + M %N + yyyy %Y + yy %y + y %y + gg {} + } $unquoted] + if { $quoted eq {} } { + set quote ' + } else { + set quote $quoted + } + } + ::msgcat::mcset $locale LOCALE_DATE_FORMAT $ldatefmt + } + + if { ![catch { + registry get "HKEY_CURRENT_USER\\Control Panel\\International" \ + sTimeFormat + } string] } { + set quote {} + set timefmt {} + foreach { unquoted quoted } [split $string '] { + append timefmt $quote [string map { + HH %H + H %k + hh %I + h %l + mm %M + m %M + ss %S + s %S + tt %p + t %p + } $unquoted] + if { $quoted eq {} } { + set quote ' + } else { + set quote $quoted + } + } + ::msgcat::mcset $locale TIME_FORMAT $timefmt + } + + catch { + ::msgcat::mcset $locale DATE_TIME_FORMAT "$datefmt $timefmt" + } + catch { + ::msgcat::mcset $locale LOCALE_DATE_TIME_FORMAT "$ldatefmt $timefmt" + } + + return + +} + +#---------------------------------------------------------------------- +# +# LocalizeFormat -- +# +# Map away locale-dependent format groups in a clock format. +# +# Parameters: +# locale -- Current [mclocale] locale, supplied to avoid +# an extra call +# format -- Format supplied to [clock scan] or [clock format] +# +# Results: +# Returns the string with locale-dependent composite format groups +# substituted out. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::LocalizeFormat { locale format } { + + # message catalog key to cache this format + set key FORMAT_$format + + if { [::msgcat::mcexists -exactlocale -exactnamespace $key] } { + return [mc $key] + } + # Handle locale-dependent format groups by mapping them out of the format + # string. Note that the order of the [string map] operations is + # significant because later formats can refer to later ones; for example + # %c can refer to %X, which in turn can refer to %T. + + set list { + %% %% + %D %m/%d/%Y + %+ {%a %b %e %H:%M:%S %Z %Y} + } + lappend list %EY [string map $list [mc LOCALE_YEAR_FORMAT]] + lappend list %T [string map $list [mc TIME_FORMAT_24_SECS]] + lappend list %R [string map $list [mc TIME_FORMAT_24]] + lappend list %r [string map $list [mc TIME_FORMAT_12]] + lappend list %X [string map $list [mc TIME_FORMAT]] + lappend list %EX [string map $list [mc LOCALE_TIME_FORMAT]] + lappend list %x [string map $list [mc DATE_FORMAT]] + lappend list %Ex [string map $list [mc LOCALE_DATE_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] + + ::msgcat::mcset $locale $key $format + return $format +} + +#---------------------------------------------------------------------- +# +# FormatNumericTimeZone -- +# +# Formats a time zone as +hhmmss +# +# Parameters: +# z - Time zone in seconds east of Greenwich +# +# Results: +# Returns the time zone formatted in a numeric form +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::FormatNumericTimeZone { z } { + if { $z < 0 } { + set z [expr { - $z }] + set retval - + } else { + set retval + + } + append retval [::format %02d [expr { $z / 3600 }]] + set z [expr { $z % 3600 }] + append retval [::format %02d [expr { $z / 60 }]] + set z [expr { $z % 60 }] + if { $z != 0 } { + append retval [::format %02d $z] + } + return $retval +} + +#---------------------------------------------------------------------- +# +# FormatStarDate -- +# +# Formats a date as a StarDate. +# +# Parameters: +# date - Dictionary containing 'year', 'dayOfYear', and +# 'localSeconds' fields. +# +# Results: +# Returns the given date formatted as a StarDate. +# +# Side effects: +# None. +# +# Jeff Hobbs put this in to support an atrocious pun about Tcl being +# "Enterprise ready." Now we're stuck with it. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::FormatStarDate { date } { + variable Roddenberry + + # Get day of year, zero based + + set doy [expr { [dict get $date dayOfYear] - 1 }] + + # Determine whether the year is a leap year + + set lp [IsGregorianLeapYear $date] + + # Convert day of year to a fractional year + + if { $lp } { + set fractYear [expr { 1000 * $doy / 366 }] + } else { + set fractYear [expr { 1000 * $doy / 365 }] + } + + # Put together the StarDate + + return [::format "Stardate %02d%03d.%1d" \ + [expr { [dict get $date year] - $Roddenberry }] \ + $fractYear \ + [expr { [dict get $date localSeconds] % 86400 + / ( 86400 / 10 ) }]] +} + +#---------------------------------------------------------------------- +# +# ParseStarDate -- +# +# Parses a StarDate +# +# Parameters: +# year - Year from the Roddenberry epoch +# fractYear - Fraction of a year specifiying the day of year. +# fractDay - Fraction of a day +# +# Results: +# Returns a count of seconds from the Posix epoch. +# +# Side effects: +# None. +# +# Jeff Hobbs put this in to support an atrocious pun about Tcl being +# "Enterprise ready." Now we're stuck with it. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::ParseStarDate { year fractYear fractDay } { + variable Roddenberry + + # Build a tentative date from year and fraction. + + set date [dict create \ + gregorian 1 \ + era CE \ + year [expr { $year + $Roddenberry }] \ + dayOfYear [expr { $fractYear * 365 / 1000 + 1 }]] + set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]] + + # Determine whether the given year is a leap year + + set lp [IsGregorianLeapYear $date] + + # Reconvert the fractional year according to whether the given year is a + # leap year + + if { $lp } { + dict set date dayOfYear \ + [expr { $fractYear * 366 / 1000 + 1 }] + } else { + dict set date dayOfYear \ + [expr { $fractYear * 365 / 1000 + 1 }] + } + dict unset date julianDay + dict unset date gregorian + set date [GetJulianDayFromGregorianEraYearDay $date[set date {}]] + + return [expr { + 86400 * [dict get $date julianDay] + - 210866803200 + + ( 86400 / 10 ) * $fractDay + }] +} + +#---------------------------------------------------------------------- +# +# ScanWide -- +# +# Scans a wide integer from an input +# +# Parameters: +# 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. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::ScanWide { str } { + set count [::scan $str {%ld %c} result junk] + if { $count != 1 } { + return -code error -errorcode [list CLOCK notAnInteger $str] \ + "\"$str\" is not an integer" + } + if { [incr result 0] != $str } { + return -code error -errorcode [list CLOCK integervalueTooLarge] \ + "integer value too large to represent" + } + return $result +} + +#---------------------------------------------------------------------- +# +# InterpretTwoDigitYear -- +# +# 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. +# baseTime - Base time relative to which the date is expressed. +# twoDigitField - Name of the field that stores the two-digit year. +# Default is 'yearOfCentury' +# fourDigitField - Name of the field that will receive the four-digit +# year. Default is 'year' +# +# Results: +# Returns the dictionary augmented with the four-digit year, stored in +# the given key. +# +# 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. +# +#---------------------------------------------------------------------- + +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 }] + } else { + dict set date $fourDigitField [expr { $yr + 1900 }] + } + return $date +} + +#---------------------------------------------------------------------- +# +# AssignBaseYear -- +# +# Places the number of the current year into a dictionary. +# +# Parameters: +# date - Dictionary value to update +# baseTime - Base time from which to extract the year, expressed +# in seconds from the Posix epoch +# timezone - the time zone in which the date is being scanned +# changeover - the Julian Day on which the Gregorian calendar +# was adopted in the target locale. +# +# Results: +# Returns the dictionary with the current year assigned. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::AssignBaseYear { date baseTime timezone changeover } { + variable TZData + + # Find the Julian Day Number corresponding to the base time, and + # find the Gregorian year corresponding to that Julian Day. + + set date2 [GetDateFields $baseTime $TZData($timezone) $changeover] + + # Store the converted year + + dict set date era [dict get $date2 era] + dict set date year [dict get $date2 year] + + return $date +} + +#---------------------------------------------------------------------- +# +# AssignBaseIso8601Year -- +# +# Determines the base year in the ISO8601 fiscal calendar. +# +# Parameters: +# date - Dictionary containing the fields of the date that +# is to be augmented with the base year. +# baseTime - Base time expressed in seconds from the Posix epoch. +# timeZone - Target time zone +# changeover - Julian Day of adoption of the Gregorian calendar in +# the target locale. +# +# Results: +# Returns the given date with "iso8601Year" set to the +# base year. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::AssignBaseIso8601Year {date baseTime timeZone changeover} { + variable TZData + + # Find the Julian Day Number corresponding to the base time + + set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover] + + # Calculate the ISO8601 date and transfer the year + + dict set date era CE + dict set date iso8601Year [dict get $date2 iso8601Year] + return $date +} + +#---------------------------------------------------------------------- +# +# AssignBaseMonth -- +# +# Places the number of the current year and month into a +# dictionary. +# +# Parameters: +# date - Dictionary value to update +# baseTime - Time from which the year and month are to be +# obtained, expressed in seconds from the Posix epoch. +# timezone - Name of the desired time zone +# changeover - Julian Day on which the Gregorian calendar was adopted. +# +# Results: +# Returns the dictionary with the base year and month assigned. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::AssignBaseMonth {date baseTime timezone changeover} { + variable TZData + + # Find the year and month corresponding to the base time + + set date2 [GetDateFields $baseTime $TZData($timezone) $changeover] + dict set date era [dict get $date2 era] + dict set date year [dict get $date2 year] + dict set date month [dict get $date2 month] + return $date +} + +#---------------------------------------------------------------------- +# +# AssignBaseWeek -- +# +# Determines the base year and week in the ISO8601 fiscal calendar. +# +# Parameters: +# date - Dictionary containing the fields of the date that +# is to be augmented with the base year and week. +# baseTime - Base time expressed in seconds from the Posix epoch. +# changeover - Julian Day on which the Gregorian calendar was adopted +# in the target locale. +# +# Results: +# Returns the given date with "iso8601Year" set to the +# base year and "iso8601Week" to the week number. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::AssignBaseWeek {date baseTime timeZone changeover} { + variable TZData + + # Find the Julian Day Number corresponding to the base time + + set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover] + + # Calculate the ISO8601 date and transfer the year + + dict set date era CE + dict set date iso8601Year [dict get $date2 iso8601Year] + dict set date iso8601Week [dict get $date2 iso8601Week] + return $date +} + +#---------------------------------------------------------------------- +# +# AssignBaseJulianDay -- +# +# Determines the base day for a time-of-day conversion. +# +# Parameters: +# date - Dictionary that is to get the base day +# baseTime - Base time expressed in seconds from the Posix epoch +# changeover - Julian day on which the Gregorian calendar was +# adpoted in the target locale. +# +# Results: +# Returns the given dictionary augmented with a 'julianDay' field +# that contains the base day. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::AssignBaseJulianDay { date baseTime timeZone changeover } { + variable TZData + + # Find the Julian Day Number corresponding to the base time + + set date2 [GetDateFields $baseTime $TZData($timeZone) $changeover] + dict set date julianDay [dict get $date2 julianDay] + + return $date +} + +#---------------------------------------------------------------------- +# +# InterpretHMSP -- +# +# Interprets a time in the form "hh:mm:ss am". +# +# Parameters: +# date -- Dictionary containing "hourAMPM", "minute", "second" +# and "amPmIndicator" fields. +# +# Results: +# Returns the number of seconds from local midnight. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::InterpretHMSP { date } { + set hr [dict get $date hourAMPM] + if { $hr == 12 } { + set hr 0 + } + if { [dict get $date amPmIndicator] } { + incr hr 12 + } + dict set date hour $hr + return [InterpretHMS $date[set date {}]] +} + +#---------------------------------------------------------------------- +# +# InterpretHMS -- +# +# Interprets a 24-hour time "hh:mm:ss" +# +# Parameters: +# date -- Dictionary containing the "hour", "minute" and "second" +# fields. +# +# Results: +# Returns the given dictionary augmented with a "secondOfDay" +# field containing the number of seconds from local midnight. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::InterpretHMS { date } { + return [expr { + ( [dict get $date hour] * 60 + + [dict get $date minute] ) * 60 + + [dict get $date second] + }] +} + +#---------------------------------------------------------------------- +# +# GetSystemTimeZone -- +# +# Determines the system time zone, which is the default for the +# 'clock' command if no other zone is supplied. +# +# Parameters: +# None. +# +# Results: +# Returns the system time zone. +# +# Side effects: +# Stores the sustem time zone in the 'CachedSystemTimeZone' +# variable, since determining it may be an expensive process. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::GetSystemTimeZone {} { + variable CachedSystemTimeZone + variable TimeZoneBad + + if {[set result [getenv TCL_TZ]] ne {}} { + set timezone $result + } elseif {[set result [getenv TZ]] ne {}} { + set timezone $result + } + if {![info exists timezone]} { + # Cache the time zone only if it was detected by one of the + # expensive methods. + if { [info exists CachedSystemTimeZone] } { + set timezone $CachedSystemTimeZone + } elseif { $::tcl_platform(platform) eq {windows} } { + set timezone [GuessWindowsTimeZone] + } elseif { [file exists /etc/localtime] + && ![catch {ReadZoneinfoFile \ + Tcl/Localtime /etc/localtime}] } { + set timezone :Tcl/Localtime + } else { + set timezone :localtime + } + set CachedSystemTimeZone $timezone + } + if { ![dict exists $TimeZoneBad $timezone] } { + dict set TimeZoneBad $timezone [catch {SetupTimeZone $timezone}] + } + if { [dict get $TimeZoneBad $timezone] } { + return :localtime + } else { + return $timezone + } +} + +#---------------------------------------------------------------------- +# +# ConvertLegacyTimeZone -- +# +# 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. +# +# 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" + } + return [dict get $LegacyTimeZone $tzname] +} + +#---------------------------------------------------------------------- +# +# SetupTimeZone -- +# +# 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. +# +#---------------------------------------------------------------------- + +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 { + # Make a fixed offset + + ::scan $hh %d hh + if { $mm eq {} } { + set mm 0 + } else { + ::scan $mm %d mm + } + if { $ss eq {} } { + set ss 0 + } else { + ::scan $ss %d ss + } + set offset [expr { ( $hh * 60 + $mm ) * 60 + $ss }] + if { $s eq {-} } { + set offset [expr { - $offset }] + } + set TZData($timezone) [list [list $MINWIDE $offset -1 $timezone]] + + } elseif { [string index $timezone 0] eq {:} } { + # Convert using a time zone file + + if { + [catch { + LoadTimeZoneFile [string range $timezone 1 end] + }] && [catch { + 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] } { + if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } { + dict unset opts -errorinfo + } + return -options $opts $data + } else { + set TZData($timezone) $data + } + + } else { + # 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] } { + dict unset opts -errorinfo + return -options $opts "time zone $timezone not found" + } + set TZData($timezone) $TZData(:$timezone) + } + } + + return +} + +#---------------------------------------------------------------------- +# +# GuessWindowsTimeZone -- +# +# Determines the system time zone on windows. +# +# Parameters: +# None. +# +# Results: +# 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! +# +# 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 + + if { [info exists NoRegistry] } { + return :localtime + } + + # Dredge time zone information out of the registry + + if { [catch { + set rpath HKEY_LOCAL_MACHINE\\System\\CurrentControlSet\\Control\\TimeZoneInformation + set data [list \ + [expr { -60 + * [registry get $rpath Bias] }] \ + [expr { -60 + * [registry get $rpath StandardBias] }] \ + [expr { -60 \ + * [registry get $rpath DaylightBias] }]] + set stdtzi [registry get $rpath StandardStart] + foreach ind {0 2 14 4 6 8 10 12} { + binary scan $stdtzi @${ind}s val + lappend data $val + } + set daytzi [registry get $rpath DaylightStart] + foreach ind {0 2 14 4 6 8 10 12} { + binary scan $daytzi @${ind}s val + 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) + + if { [dict exists $WinZoneInfo $data] } { + set tzname [dict get $WinZoneInfo $data] + if { ! [dict exists $TimeZoneBad $tzname] } { + dict set TimeZoneBad $tzname [catch {SetupTimeZone $tzname}] + } + } else { + set tzname {} + } + if { $tzname eq {} || [dict get $TimeZoneBad $tzname] } { + lassign $data \ + bias stdBias dstBias \ + stdYear stdMonth stdDayOfWeek stdDayOfMonth \ + stdHour stdMinute stdSecond stdMillisec \ + dstYear dstMonth dstDayOfWeek dstDayOfMonth \ + dstHour dstMinute dstSecond dstMillisec + set stdDelta [expr { $bias + $stdBias }] + set dstDelta [expr { $bias + $dstBias }] + if { $stdDelta <= 0 } { + set stdSignum + + set stdDelta [expr { - $stdDelta }] + set dispStdSignum - + } else { + set stdSignum - + set dispStdSignum + + } + set hh [::format %02d [expr { $stdDelta / 3600 }]] + set mm [::format %02d [expr { ($stdDelta / 60 ) % 60 }]] + set ss [::format %02d [expr { $stdDelta % 60 }]] + set tzname {} + append tzname < $dispStdSignum $hh $mm > $stdSignum $hh : $mm : $ss + if { $stdMonth >= 0 } { + if { $dstDelta <= 0 } { + set dstSignum + + set dstDelta [expr { - $dstDelta }] + set dispDstSignum - + } else { + set dstSignum - + set dispDstSignum + + } + set hh [::format %02d [expr { $dstDelta / 3600 }]] + set mm [::format %02d [expr { ($dstDelta / 60 ) % 60 }]] + set ss [::format %02d [expr { $dstDelta % 60 }]] + append tzname < $dispDstSignum $hh $mm > $dstSignum $hh : $mm : $ss + 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. + return :localtime + } + append tzname / [::format %02d $dstHour] \ + : [::format %02d $dstMinute] \ + : [::format %02d $dstSecond] + 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. + return :localtime + } + append tzname / [::format %02d $stdHour] \ + : [::format %02d $stdMinute] \ + : [::format %02d $stdSecond] + } + dict set WinZoneInfo $data $tzname + } + + return [dict get $WinZoneInfo $data] +} + +#---------------------------------------------------------------------- +# +# LoadTimeZoneFile -- +# +# Load the data file that specifies the conversion between a +# given time zone and Greenwich. +# +# Parameters: +# fileName -- Name of the file to load +# +# Results: +# None. +# +# Side effects: +# TZData(:fileName) contains the time zone data +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::LoadTimeZoneFile { fileName } { + variable DataDir + variable TZData + + if { [info exists TZData($fileName)] } { + return + } + + # Since an unsafe interp uses the [clock] command in the parent, 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 { + source -encoding utf-8 [file join $DataDir $fileName] + } on error {} { + return -code error \ + -errorcode [list CLOCK badTimeZone :$fileName] \ + "time zone \":$fileName\" not found" + } + return +} + +#---------------------------------------------------------------------- +# +# LoadZoneinfoFile -- +# +# Loads a binary time zone information file in Olson format. +# +# Parameters: +# 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. +# +# Side effects: +# TZData(:fileName) contains the time zone data +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::LoadZoneinfoFile { fileName } { + variable ZoneinfoPaths + + # Since an unsafe interp uses the [clock] command in the parent, 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" + } + foreach d $ZoneinfoPaths { + set fname [file join $d $fileName] + if { [file readable $fname] && [file isfile $fname] } { + break + } + unset fname + } + ReadZoneinfoFile $fileName $fname +} + +#---------------------------------------------------------------------- +# +# ReadZoneinfoFile -- +# +# Loads a binary time zone information file in Olson format. +# +# Parameters: +# fileName - Name of the time zone (relative path name of the +# file). +# 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. +# +# Side effects: +# TZData(:fileName) contains the time zone data +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::ReadZoneinfoFile {fileName fname} { + variable MINWIDE + variable TZData + if { ![file exists $fname] } { + return -code error "$fileName not found" + } + + if { [file size $fname] > 262144 } { + return -code error "$fileName too big" + } + + # Suck in all the data from the file + + set f [open $fname r] + fconfigure $f -translation binary + 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. + + binary scan $d a4a1x15IIIIII \ + magic version nIsGMT nIsStd nLeap nTime nType nChar + set seek 44 + set ilen 4 + set iformat I + if { $magic != {TZif} } { + return -code error "$fileName not a time zone information file" + } + if { $nType > 255 } { + return -code error "$fileName contains too many time types" + } + # Accept only Posix-style zoneinfo. Sorry, 'leaps' bigots. + if { $nLeap != 0 } { + 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. + + if {$version eq "2"} { + 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}} { + return -code error "seek address $seek miscomputed, magic = $magic" + } + set iformat W + set ilen 8 + incr seek 44 + } + + # Next come ${nTime} transition times, followed by ${nTime} time type + # codes. The type codes are unsigned 1-byte quantities. We insert an + # arbitrary start time in front of the transitions. + + binary scan $d @${seek}${iformat}${nTime}c${nTime} times tempCodes + incr seek [expr { ($ilen + 1) * $nTime }] + set times [linsert $times 0 $MINWIDE] + set codes {} + foreach c $tempCodes { + lappend codes [expr { $c & 0xFF }] + } + 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. + + for { set i 0 } { $i < $nType } { incr i } { + binary scan $d @${seek}Icc gmtOff isDst abbrInd + lappend types [list $gmtOff $isDst $abbrInd] + 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. + + binary scan $d @${seek}a${nChar} abbrs + incr seek ${nChar} + set abbrList [split $abbrs \0] + set i 0 + set abbrevs {} + foreach a $abbrList { + for {set j 0} {$j <= [string length $a]} {incr j} { + dict set abbrevs $i [string range $a $j end] + incr i + } + } + + # Package up a list of tuples, each of which contains transition time, + # seconds east of Greenwich, DST flag and time zone abbreviation. + + set r {} + set lastTime $MINWIDE + foreach t $times c $codes { + if { $t < $lastTime } { + return -code error "$fileName has times out of order" + } + set lastTime $t + lassign [lindex $types $c] gmtoff isDst abbrInd + set abbrev [dict get $abbrevs $abbrInd] + lappend r [list $t $gmtoff $isDst $abbrev] + } + + # 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), + # nIsStd standard/DST indicators and nIsGMT UTC/local indicators. + + if {$version eq {2}} { + set seek [expr {$seek + 8 * $nLeap + $nIsStd + $nIsGMT + 1}] + set last [string first \n $d $seek] + set posix [string range $d $seek [expr {$last-1}]] + if {[llength $posix] > 0} { + set posixFields [ParsePosixTimeZone $posix] + foreach tuple [ProcessPosixTimeZone $posixFields] { + lassign $tuple t gmtoff isDst abbrev + if {$t > $lastTime} { + lappend r $tuple + } + } + } + } + + set TZData(:$fileName) $r + + return +} + +#---------------------------------------------------------------------- +# +# ParsePosixTimeZone -- +# +# Parses the TZ environment variable in Posix form +# +# Parameters: +# tz Time zone specifier to be interpreted +# +# Results: +# Returns a dictionary whose values contain the various pieces of the +# time zone specification. +# +# Side effects: +# None. +# +# Errors: +# Throws an error if the syntax of the time zone is incorrect. +# +# 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 +# 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 +# but follows Posix. +# stdHours - Hours part of the offset from Greenwich to the given +# (non-DST) time zone. +# stdMinutes - Minutes part of the offset from Greenwich to the +# given (non-DST) time zone. Empty denotes zero. +# stdSeconds - Seconds part of the offset from Greenwich to the +# given (non-DST) time zone. Empty denotes zero. +# dstName - Name of the time zone when DST is in effect, or the +# empty string if the time zone does not observe Daylight +# Saving Time. +# dstSignum, dstHours, dstMinutes, dstSeconds - +# Fields corresponding to stdSignum, stdHours, stdMinutes, +# stdSeconds for the Daylight Saving Time version of the +# time zone. If dstHours is empty, it is presumed to be 1. +# startDayOfYear - The ordinal number of the day of the year on which +# Daylight Saving Time begins. If this field is +# empty, then DST begins on a given month-week-day, +# as below. +# startJ - The letter J, or an empty string. If a J is present in +# this field, then startDayOfYear does not count February 29 +# even in leap years. +# startMonth - The number of the month in which Daylight Saving Time +# begins, supplied if startDayOfYear is empty. If both +# startDayOfYear and startMonth are empty, then US rules +# are presumed. +# startWeekOfMonth - The number of the week in the month in which +# Daylight Saving Time begins, in the range 1-5. +# 5 denotes the last week of the month even in a +# 4-week month. +# startDayOfWeek - The number of the day of the week (Sunday=0, +# Saturday=6) on which Daylight Saving Time begins. +# startHours - The hours part of the time of day at which Daylight +# Saving Time begins. An empty string is presumed to be 2. +# startMinutes - The minutes part of the time of day at which DST begins. +# An empty string is presumed zero. +# startSeconds - The seconds part of the time of day at which DST begins. +# An empty string is presumed zero. +# endDayOfYear, endJ, endMonth, endWeekOfMonth, endDayOfWeek, +# 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. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::ParsePosixTimeZone { tz } { + if {[regexp -expanded -nocase -- { + ^ + # 1 - Standard time zone name + ([[:alpha:]]+ | <[-+[:alnum:]]+>) + # 2 - Standard time zone offset, signum + ([-+]?) + # 3 - Standard time zone offset, hours + ([[:digit:]]{1,2}) + (?: + # 4 - Standard time zone offset, minutes + : ([[:digit:]]{1,2}) + (?: + # 5 - Standard time zone offset, seconds + : ([[:digit:]]{1,2} ) + )? + )? + (?: + # 6 - DST time zone name + ([[:alpha:]]+ | <[-+[:alnum:]]+>) + (?: + (?: + # 7 - DST time zone offset, signum + ([-+]?) + # 8 - DST time zone offset, hours + ([[:digit:]]{1,2}) + (?: + # 9 - DST time zone offset, minutes + : ([[:digit:]]{1,2}) + (?: + # 10 - DST time zone offset, seconds + : ([[:digit:]]{1,2}) + )? + )? + )? + (?: + , + (?: + # 11 - Optional J in n and Jn form 12 - Day of year + ( J ? ) ( [[:digit:]]+ ) + | M + # 13 - Month number 14 - Week of month 15 - Day of week + ( [[:digit:]] + ) + [.] ( [[:digit:]] + ) + [.] ( [[:digit:]] + ) + ) + (?: + # 16 - Start time of DST - hours + / ( [[:digit:]]{1,2} ) + (?: + # 17 - Start time of DST - minutes + : ( [[:digit:]]{1,2} ) + (?: + # 18 - Start time of DST - seconds + : ( [[:digit:]]{1,2} ) + )? + )? + )? + , + (?: + # 19 - Optional J in n and Jn form 20 - Day of year + ( J ? ) ( [[:digit:]]+ ) + | M + # 21 - Month number 22 - Week of month 23 - Day of week + ( [[:digit:]] + ) + [.] ( [[:digit:]] + ) + [.] ( [[:digit:]] + ) + ) + (?: + # 24 - End time of DST - hours + / ( [[:digit:]]{1,2} ) + (?: + # 25 - End time of DST - minutes + : ( [[:digit:]]{1,2} ) + (?: + # 26 - End time of DST - seconds + : ( [[:digit:]]{1,2} ) + )? + )? + )? + )? + )? + )? + $ + } $tz -> x(stdName) x(stdSignum) x(stdHours) x(stdMinutes) x(stdSeconds) \ + x(dstName) x(dstSignum) x(dstHours) x(dstMinutes) x(dstSeconds) \ + x(startJ) x(startDayOfYear) \ + x(startMonth) x(startWeekOfMonth) x(startDayOfWeek) \ + x(startHours) x(startMinutes) x(startSeconds) \ + 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] + } + + 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. +# +# Parameters: +# z - Dictionary returned from 'ParsePosixTimeZone' +# +# Results: +# Returns time zone information for the 'TZData' array. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::ProcessPosixTimeZone { z } { + variable MINWIDE + variable TZData + + # Determine the standard time zone name and seconds east of Greenwich + + set stdName [dict get $z stdName] + if { [string index $stdName 0] eq {<} } { + set stdName [string range $stdName 1 end-1] + } + if { [dict get $z stdSignum] eq {-} } { + set stdSignum +1 + } else { + set stdSignum -1 + } + 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] + } else { + set stdMinutes 0 + } + if { [dict get $z stdSeconds] ne {} } { + set stdSeconds [lindex [::scan [dict get $z stdSeconds] %d] 0] + } else { + set stdSeconds 0 + } + 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 + + set dstName [dict get $z dstName] + if { $dstName eq {} } { + return $data + } + if { [string index $dstName 0] eq {<} } { + set dstName [string range $dstName 1 end-1] + } + + # Determine the daylight name + + if { [dict get $z dstSignum] eq {-} } { + set dstSignum +1 + } else { + set dstSignum -1 + } + if { [dict get $z dstHours] eq {} } { + set dstOffset [expr { 3600 + $stdOffset }] + } else { + 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] + } else { + set dstMinutes 0 + } + if { [dict get $z dstSeconds] ne {} } { + set dstSeconds [lindex [::scan [dict get $z dstSeconds] %d] 0] + } else { + set dstSeconds 0 + } + set dstOffset [expr { + (($dstHours*60 + $dstMinutes) * 60 + $dstSeconds) * $dstSignum + }] + } + + # Fill in defaults for European or US DST rules + # US start time is the second Sunday in March + # EU start time is the last Sunday in March + # 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 {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} { + # EU + dict set z startWeekOfMonth 5 + if {$stdHours>2} { + dict set z startHours 2 + } else { + dict set z startHours [expr {$stdHours+1}] + } + } else { + # US + dict set z startWeekOfMonth 2 + dict set z startHours 2 + } + dict set z startMonth 3 + dict set z startDayOfWeek 0 + dict set z startMinutes 0 + dict set z startSeconds 0 + } + if { + [dict get $z endDayOfYear] eq {} + && [dict get $z endMonth] eq {} + } then { + if {($stdSignum * $stdHours>=0) && ($stdSignum * $stdHours<=12)} { + # EU + dict set z endMonth 10 + dict set z endWeekOfMonth 5 + if {$stdHours>2} { + dict set z endHours 3 + } else { + dict set z endHours [expr {$stdHours+2}] + } + } else { + # US + dict set z endMonth 11 + dict set z endWeekOfMonth 1 + dict set z endHours 2 + } + dict set z endDayOfWeek 0 + dict set z endMinutes 0 + dict set z endSeconds 0 + } + + # Put DST in effect in all years from 1916 to 2099. + + for { set y 1916 } { $y < 2100 } { incr y } { + set startTime [DeterminePosixDSTTime $z start $y] + incr startTime [expr { - wide($stdOffset) }] + set endTime [DeterminePosixDSTTime $z end $y] + incr endTime [expr { - wide($dstOffset) }] + if { $startTime < $endTime } { + lappend data \ + [list $startTime $dstOffset 1 $dstName] \ + [list $endTime $stdOffset 0 $stdName] + } else { + lappend data \ + [list $endTime $stdOffset 0 $stdName] \ + [list $startTime $dstOffset 1 $dstName] + } + } + + return $data +} + +#---------------------------------------------------------------------- +# +# DeterminePosixDSTTime -- +# +# Determines the time that Daylight Saving Time starts or ends from a +# Posix time zone specification. +# +# Parameters: +# z - Time zone data returned from ParsePosixTimeZone. +# Missing fields are expected to be filled in with +# default values. +# bound - The word 'start' or 'end' +# 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. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::DeterminePosixDSTTime { z bound y } { + + variable FEB_28 + + # Determine the start or end day of DST + + 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] + && ( $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] + dict set date dayOfWeek [dict get $z ${bound}DayOfWeek] + set dowim [dict get $z ${bound}WeekOfMonth] + if { $dowim >= 5 } { + set dowim -1 + } + dict set date dayOfWeekInMonth $dowim + set date [GetJulianDayFromEraYearMonthWeekDay $date[set date {}] 2361222] + + } + + set jd [dict get $date julianDay] + set seconds [expr { + wide($jd) * wide(86400) - wide(210866803200) + }] + + set h [dict get $z ${bound}Hours] + if { $h eq {} } { + set h 2 + } else { + set h [lindex [::scan $h %d] 0] + } + set m [dict get $z ${bound}Minutes] + if { $m eq {} } { + set m 0 + } else { + set m [lindex [::scan $m %d] 0] + } + set s [dict get $z ${bound}Seconds] + if { $s eq {} } { + set s 0 + } else { + set s [lindex [::scan $s %d] 0] + } + set tod [expr { ( $h * 60 + $m ) * 60 + $s }] + return [expr { $seconds + $tod }] +} + +#---------------------------------------------------------------------- +# +# GetLocaleEra -- +# +# Given local time expressed in seconds from the Posix epoch, +# determine localized era and year within the era. +# +# Parameters: +# date - Dictionary that must contain the keys, 'localSeconds', +# whose value is expressed as the appropriate local time; +# and 'year', whose value is the Gregorian year. +# etable - Value of the LOCALE_ERAS key in the message catalogue +# for the target locale. +# +# Results: +# 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 + }] + } else { + dict set date localeEra [lindex $etable $index 1] + dict set date localeYear [expr { + [dict get $date year] - [lindex $etable $index 2] + }] + } + return $date +} + +#---------------------------------------------------------------------- +# +# GetJulianDayFromEraYearDay -- +# +# Given a year, month and day on the Gregorian calendar, determines +# the Julian Day Number beginning at noon on that date. +# +# Parameters: +# date -- A dictionary in which the 'era', 'year', and +# 'dayOfYear' slots are populated. The calendar in use +# is determined by the date itself relative to: +# changeover -- Julian day on which the Gregorian calendar was +# 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). +# +# Side effects: +# None. +# +# Bugs: +# This code needs to be moved to the C layer. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::GetJulianDayFromEraYearDay {date changeover} { + # Get absolute year number from the civil year + + switch -exact -- [dict get $date era] { + BCE { + set year [expr { 1 - [dict get $date year] }] + } + CE { + set year [dict get $date year] + } + } + set ym1 [expr { $year - 1 }] + + # 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 ) + }] + + # 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 ) + }] + } + + dict set date julianDay $jd + return $date +} + +#---------------------------------------------------------------------- +# +# GetJulianDayFromEraYearMonthWeekDay -- +# +# 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' +# 'weekOfMonth', 'dayOfWeek', and 'dayOfWeekInMonth'. +# changeover - Julian Day of adoption of the Gregorian calendar +# +# Results: +# Returns the given dictionary, augmented with a 'julianDay' key. +# +# Side effects: +# None. +# +# Bugs: +# This code needs to be moved to the C layer. +# +#---------------------------------------------------------------------- + +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) + + set date2 $date + set week [dict get $date dayOfWeekInMonth] + if { $week >= 0 } { + dict set date2 dayOfMonth 0 + } else { + dict incr date2 month + dict set date2 dayOfMonth 7 + } + set date2 [GetJulianDayFromEraYearMonthDay $date2[set date2 {}] \ + $changeover] + set wd0 [WeekdayOnOrBefore [dict get $date dayOfWeek] \ + [dict get $date2 julianDay]] + dict set date julianDay [expr { $wd0 + 7 * $week }] + return $date +} + +#---------------------------------------------------------------------- +# +# IsGregorianLeapYear -- +# +# Determines whether a given date represents a leap year in the +# Gregorian calendar. +# +# Parameters: +# date -- The date to test. The fields, 'era', 'year' and 'gregorian' +# must be set. +# +# Results: +# Returns 1 if the year is a leap year, 0 otherwise. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::IsGregorianLeapYear { date } { + switch -exact -- [dict get $date era] { + BCE { + set year [expr { 1 - [dict get $date year]}] + } + CE { + set year [dict get $date year] + } + } + if { $year % 4 != 0 } { + return 0 + } elseif { ![dict get $date gregorian] } { + return 1 + } elseif { $year % 400 == 0 } { + return 1 + } elseif { $year % 100 == 0 } { + return 0 + } else { + return 1 + } +} + +#---------------------------------------------------------------------- +# +# WeekdayOnOrBefore -- +# +# 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 +# j -- Julian Day number +# +# Results: +# Returns the Julian Day Number of the desired date. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +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. +# +# Parameters: +# list - List of lists, sorted in ascending order by the +# first elements +# key - Value to search for +# +# Results: +# Returns the index of the greatest element in $list that is less than +# or equal to $key. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::BSearch { list key } { + if {[llength $list] == 0} { + return -1 + } + if { $key < [lindex $list 0 0] } { + return -1 + } + + set l 0 + 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. + + set m [expr { ( $l + $u + 1 ) / 2 }] + if { $key >= [lindex $list $m 0] } { + set l $m + } else { + set u [expr { $m - 1 }] + } + } + + return $l +} + +#---------------------------------------------------------------------- +# +# clock add -- +# +# Adds an offset to a given time. +# +# Syntax: +# clock add clockval ?count unit?... ?-option value? +# +# Parameters: +# clockval -- Starting time value +# count -- Amount of a unit of time to add +# unit -- Unit of time to add, must be one of: +# years year months month weeks week +# days day hours hour minutes minute +# seconds second +# +# Options: +# -gmt BOOLEAN +# (Deprecated) Flag synonymous with '-timezone :GMT' +# -timezone ZONE +# Name of the time zone in which calculations are to be done. +# -locale NAME +# Name of the locale in which calculations are to be done. +# Used to determine the Gregorian change date. +# +# Results: +# Returns the given time adjusted by the given offset(s) in +# 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. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::add { clockval args } { + if { [llength $args] % 2 != 0 } { + set cmdName "clock add" + return -code error \ + -errorcode [list CLOCK wrongNumArgs] \ + "wrong \# args: should be\ + \"$cmdName clockval ?number units?...\ + ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?\"" + } + if { [catch { expr {wide($clockval)} } result] } { + return -code error $result + } + + set offsets {} + set gmt 0 + set locale c + 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 + } + -l - -lo - -loc - -loca - -local - -locale { + set locale [string tolower $b] + } + -t - -ti - -tim - -time - -timez - -timezo - -timezon - + -timezone { + set timezone $b + } + default { + throw [list CLOCK badOption $a] \ + "bad option \"$a\",\ + must be -gmt, -locale or -timezone" + } + } + } + } + + # Check options for validity + + if { [info exists saw(-gmt)] && [info exists saw(-timezone)] } { + return -code error \ + -errorcode [list CLOCK gmtWithTimezone] \ + "cannot use -gmt and -timezone in same call" + } + if { [catch { expr { wide($clockval) } } result] } { + 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 + } + + EnterLocale $locale + + set changeover [mc GREGORIAN_CHANGE_DATE] + + if {[catch {SetupTimeZone $timezone} retval opts]} { + dict unset opts -errorinfo + return -options $opts $retval + } + + try { + foreach { quantity unit } $offsets { + switch -exact -- $unit { + years - year { + set clockval [AddMonths [expr { 12 * $quantity }] \ + $clockval $timezone $changeover] + } + months - month { + set clockval [AddMonths $quantity $clockval $timezone \ + $changeover] + } + + weeks - week { + set clockval [AddDays [expr { 7 * $quantity }] \ + $clockval $timezone $changeover] + } + days - day { + set clockval [AddDays $quantity $clockval $timezone \ + $changeover] + } + + hours - hour { + set clockval [expr { 3600 * $quantity + $clockval }] + } + minutes - minute { + set clockval [expr { 60 * $quantity + $clockval }] + } + seconds - second { + set clockval [expr { $quantity + $clockval }] + } + + default { + throw [list CLOCK badUnit $unit] \ + "unknown unit \"$unit\", must be \ + years, months, weeks, days, hours, minutes or seconds" + } + } + } + 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 + } +} + +#---------------------------------------------------------------------- +# +# AddMonths -- +# +# Add a given number of months to a given clock value in a given +# time zone. +# +# Parameters: +# months - Number of months to add (may be negative) +# clockval - Seconds since the epoch before the operation +# timezone - Time zone in which the operation is to be performed +# +# Results: +# Returns the new clock value as a number of seconds since +# the epoch. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::AddMonths { months clockval timezone changeover } { + variable DaysInRomanMonthInCommonYear + variable DaysInRomanMonthInLeapYear + variable TZData + + # 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 tzName $timezone + + # Add the requisite number of months + + set m [dict get $date month] + incr m $months + incr m -1 + set delta [expr { $m / 12 }] + set mm [expr { $m % 12 }] + dict set date month [expr { $mm + 1 }] + dict incr date year $delta + + # If the date doesn't exist in the current month, repair it + + if { [IsGregorianLeapYear $date] } { + set hath [lindex $DaysInRomanMonthInLeapYear $mm] + } else { + set hath [lindex $DaysInRomanMonthInCommonYear $mm] + } + if { [dict get $date dayOfMonth] > $hath } { + dict set date dayOfMonth $hath + } + + # Reconvert to a number of seconds + + set date [GetJulianDayFromEraYearMonthDay \ + $date[set date {}]\ + $changeover] + 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. +# +# Parameters: +# days - Number of days to add (may be negative) +# clockval - Seconds since the epoch before the operation +# timezone - Time zone in which the operation is to be performed +# changeover - Julian Day on which the Gregorian calendar was adopted +# in the target locale. +# +# Results: +# Returns the new clock value as a number of seconds since the epoch. +# +# Side effects: +# None. +# +#---------------------------------------------------------------------- + +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 tzName $timezone + + # Add the requisite number of days + + dict incr date julianDay $days + + # Reconvert to a number of seconds + + 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] + +} + +#---------------------------------------------------------------------- +# +# ChangeCurrentLocale -- +# +# The global locale was changed within msgcat. +# Clears the buffered parse functions of the current locale. +# +# Parameters: +# loclist (ignored) +# +# Results: +# None. +# +# Side effects: +# Buffered parse functions are cleared. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::ChangeCurrentLocale {args} { + variable FormatProc + variable LocaleNumeralCache + variable CachedSystemTimeZone + variable TimeZoneBad + + foreach p [info procs [namespace current]::scanproc'*'current] { + rename $p {} + } + foreach p [info procs [namespace current]::formatproc'*'current] { + rename $p {} + } + + catch {array unset FormatProc *'current} + set LocaleNumeralCache {} +} + +#---------------------------------------------------------------------- +# +# ClearCaches -- +# +# Clears all caches to reclaim the memory used in [clock] +# +# Parameters: +# None. +# +# Results: +# None. +# +# Side effects: +# Caches are cleared. +# +#---------------------------------------------------------------------- + +proc ::tcl::clock::ClearCaches {} { + variable FormatProc + variable LocaleNumeralCache + variable CachedSystemTimeZone + variable TimeZoneBad + + foreach p [info procs [namespace current]::scanproc'*] { + rename $p {} + } + foreach p [info procs [namespace current]::formatproc'*] { + rename $p {} + } + + catch {unset FormatProc} + set LocaleNumeralCache {} + catch {unset CachedSystemTimeZone} + set TimeZoneBad {} + InitTZData +} diff --git a/XSchemWin/Installer/binary_template/lib/tcl8.6/history.tcl b/XSchemWin/Installer/binary_template/lib/tcl8.6/history.tcl new file mode 100644 index 00000000..ef9099be --- /dev/null +++ b/XSchemWin/Installer/binary_template/lib/tcl8.6/history.tcl @@ -0,0 +1,335 @@ +# history.tcl -- +# +# Implementation of the history command. +# +# 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. +# + +# 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 { + variable history + if {![info exists history]} { + array set history { + nextid 0 + keep 20 + 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. + + if {![llength $args]} { + set args info + } + + # Tricky stuff needed to make stack and errors come out right! + tailcall apply {arglist {tailcall history {*}$arglist} ::tcl} $args +} + +# (unnamed) -- +# +# Callback when [::history] is destroyed. Destroys the implementation. +# +# Parameters: +# oldName what the command was called. +# newName what the command is now called (an empty string). +# op the operation (= delete). +# +# Results: +# none +# +# Side Effects: +# The implementation of the [::history] command ceases to exist. + +trace add command ::history delete [list apply {{oldName newName op} { + variable history + unset -nocomplain history + foreach c [info procs ::tcl::Hist*] { + rename $c {} + } + rename ::tcl::history {} +} ::tcl}] + +# 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. +# Results: +# If executing, then the results of the command are returned +# +# Side Effects: +# Adds to the history list + +proc ::tcl::HistAdd {event {exec {}}} { + variable history + + if { + [prefix longest {exec {}} $exec] eq "" + && [llength [info level 0]] == 3 + } then { + return -code error "bad argument \"$exec\": should be \"exec\"" + } + + # Do not add empty commands to the history + if {[string trim $event] 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 "" + } + tailcall eval $event +} + +# tcl::HistKeep -- +# +# Set or query the limit on the length of the history list +# +# Parameters: +# limit (optional) the length of the history list +# +# Results: +# If no limit is specified, the current limit is returned +# +# Side Effects: +# Updates history(keep) if a limit is specified + +proc ::tcl::HistKeep {{count {}}} { + variable history + if {[llength [info level 0]] == 1} { + return $history(keep) + } + 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 +# +# Parameters: +# none +# +# Results: +# none +# +# Side Effects: +# Resets the history array, except for the keep limit + +proc ::tcl::HistClear {} { + variable history + set keep $history(keep) + unset history + array set history [list \ + nextid 0 \ + keep $keep \ + oldest -$keep \ + ] +} + +# tcl::HistInfo -- +# +# Return a pretty-printed version of the history list +# +# Parameters: +# num (optional) the length of the history list to return +# +# Results: +# A formatted history list + +proc ::tcl::HistInfo {{count {}}} { + 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\"" + } + set result {} + set newline "" + for {set i [expr {$history(nextid) - $count + 1}]} \ + {$i <= $history(nextid)} {incr i} { + if {![info exists history($i)]} { + continue + } + set cmd [string map [list \n \n\t] [string trimright $history($i) \ \n]] + append result $newline[format "%6d %s" $i $cmd] + set newline \n + } + return $result +} + +# tcl::HistRedo -- +# +# 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, +# which means the previous event. +# +# Results: +# Those of the command being redone. +# +# Side Effects: +# Replaces the current history list item with the one being redone. + +proc ::tcl::HistRedo {{event -1}} { + variable history + + 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 +} + +# tcl::HistIndex -- +# +# Map from an event specifier to an index in the history list. +# +# Parameters: +# event index of history item to redo. +# 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. +# +# Results: +# The index into history, or an error if the index didn't match. + +proc ::tcl::HistIndex {event} { + variable history + if {![string is integer -strict $event]} { + for {set i [expr {$history(nextid)-1}]} {[info exists history($i)]} \ + {incr i -1} { + if {[string match $event* $history($i)]} { + return $i + } + if {[string match $event $history($i)]} { + return $i + } + } + return -code error "no event matches \"$event\"" + } elseif {$event <= 0} { + set i [expr {$history(nextid) + $event}] + } else { + set i $event + } + if {$i <= $history(oldest)} { + return -code error "event \"$event\" is too far in the past" + } + if {$i > $history(nextid)} { + return -code error "event \"$event\" hasn't occured yet" + } + 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. +# +# Results: +# The value from the history list. + +proc ::tcl::HistEvent {{event -1}} { + variable history + set i [HistIndex $event] + if {![info exists history($i)]} { + 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. +# +# Side Effects: +# Changes the history list. + +proc ::tcl::HistChange {newValue {event 0}} { + variable history + set i [HistIndex $event] + set history($i) $newValue +} + +# tcl::HistNextID -- +# +# Returns the number of the next history event. +# +# Parameters: +# None. +# +# Side Effects: +# None. + +proc ::tcl::HistNextID {} { + variable history + return [expr {$history(nextid) + 1}] +} + +return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/XSchemWin/Installer/binary_template/lib/tcl8.6/init.tcl b/XSchemWin/Installer/binary_template/lib/tcl8.6/init.tcl new file mode 100644 index 00000000..1bfca4c6 --- /dev/null +++ b/XSchemWin/Installer/binary_template/lib/tcl8.6/init.tcl @@ -0,0 +1,827 @@ +# init.tcl -- +# +# Default system startup file for Tcl-based applications. Defines +# "unknown" procedure and auto-load facilities. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 Scriptics Corporation. +# Copyright (c) 2004 Kevin B. Kenny. All rights reserved. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +# This test intentionally written in pre-7.5 Tcl +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.11 + +# Compute the auto path to use in this interpreter. +# The values on the path come from several locations: +# +# The environment variable TCLLIBPATH +# +# tcl_library, which is the directory containing this init.tcl script. +# [tclInit] (Tcl_Init()) searches around for the directory containing this +# init.tcl and defines tcl_library to that location before sourcing it. +# +# The parent directory of tcl_library. Adding the parent +# means that packages in peer directories will be found automatically. +# +# Also add the directory ../lib relative to the directory where the +# executable is located. This is meant to find binary packages for the +# same architecture as the current executable. +# +# tcl_pkgPath, which is set by the platform-specific initialization routines +# On UNIX it is compiled in +# On Windows, it is not used +# +# (Ticket 41c9857bdd) In a safe interpreter, this file does not set +# ::auto_path (other than to {} if it is undefined). The caller, typically +# a Safe Base command, is responsible for setting ::auto_path. + +if {![info exists auto_path]} { + if {[info exists env(TCLLIBPATH)] && (![interp issafe])} { + set auto_path $env(TCLLIBPATH) + } else { + set auto_path "" + } +} +namespace eval tcl { + if {![interp issafe]} { + variable Dir + foreach Dir [list $::tcl_library [file dirname $::tcl_library]] { + if {$Dir ni $::auto_path} { + lappend ::auto_path $Dir + } + } + set Dir [file join [file dirname [file dirname \ + [info nameofexecutable]]] lib] + if {$Dir ni $::auto_path} { + lappend ::auto_path $Dir + } + if {[info exists ::tcl_pkgPath]} { catch { + foreach Dir $::tcl_pkgPath { + if {$Dir ni $::auto_path} { + lappend ::auto_path $Dir + } + } + }} + + variable Path [encoding dirs] + set Dir [file join $::tcl_library encoding] + if {$Dir ni $Path} { + lappend Path $Dir + encoding dirs $Path + } + unset Dir Path + } + + # TIP #255 min and max functions + namespace eval mathfunc { + proc min {args} { + if {![llength $args]} { + return -code error \ + "not enough arguments to math function \"min\"" + } + set val Inf + foreach arg $args { + # This will handle forcing the numeric value without + # ruining the internal type of a numeric object + if {[catch {expr {double($arg)}} err]} { + return -code error $err + } + if {$arg < $val} {set val $arg} + } + return $val + } + proc max {args} { + if {![llength $args]} { + return -code error \ + "not enough arguments to math function \"max\"" + } + set val -Inf + foreach arg $args { + # This will handle forcing the numeric value without + # ruining the internal type of a numeric object + if {[catch {expr {double($arg)}} err]} { + return -code error $err + } + if {$arg > $val} {set val $arg} + } + return $val + } + namespace export min max + } +} + +# Windows specific end of initialization + +if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} { + namespace eval tcl { + proc EnvTraceProc {lo n1 n2 op} { + global env + set x $env($n2) + set env($lo) $x + set env([string toupper $lo]) $x + } + proc InitWinEnv {} { + global env tcl_platform + foreach p [array names env] { + set u [string toupper $p] + if {$u ne $p} { + switch -- $u { + COMSPEC - + PATH { + set temp $env($p) + unset env($p) + set env($u) $temp + trace add variable env($p) write \ + [namespace code [list EnvTraceProc $p]] + trace add variable env($u) write \ + [namespace code [list EnvTraceProc $p]] + } + } + } + } + if {![info exists env(COMSPEC)]} { + set env(COMSPEC) cmd.exe + } + } + InitWinEnv + } +} + +# Setup the unknown package handler + + +if {[interp issafe]} { + package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} +} else { + # Set up search for Tcl Modules (TIP #189). + # and setup platform specific unknown package handlers + if {$tcl_platform(os) eq "Darwin" + && $tcl_platform(platform) eq "unix"} { + package unknown {::tcl::tm::UnknownHandler \ + {::tcl::MacOSXPkgUnknown ::tclPkgUnknown}} + } else { + package unknown {::tcl::tm::UnknownHandler ::tclPkgUnknown} + } + + # Set up the 'clock' ensemble + + namespace eval ::tcl::clock [list variable TclLibDir $::tcl_library] + + proc ::tcl::initClock {} { + # Auto-loading stubs for 'clock.tcl' + + foreach cmd {add format scan} { + proc ::tcl::clock::$cmd args { + variable TclLibDir + source -encoding utf-8 [file join $TclLibDir clock.tcl] + return [uplevel 1 [info level 0]] + } + } + + rename ::tcl::initClock {} + } + ::tcl::initClock +} + +# Conditionalize for presence of exec. + +if {[namespace which -command exec] eq ""} { + + # Some machines do not have exec. Also, on all + # platforms, safe interpreters do not have exec. + + set auto_noexec 1 +} + +# Define a log command (which can be overwitten to log errors +# differently, specially when stderr is not available) + +if {[namespace which -command tclLog] eq ""} { + proc tclLog {string} { + catch {puts stderr $string} + } +} + +# unknown -- +# This procedure is called when a Tcl command is invoked that doesn't +# 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 +# Tcl script file. If so, load it and execute it. +# 2. If the command was invoked interactively at top-level: +# (a) see if the command exists as an executable UNIX program. +# If so, "exec" the command. +# (b) see if the command requests csh-like history substitution +# in one of the common forms !!, !, or ^old^new. If +# so, emulate csh's history substitution. +# (c) see if the command is a unique abbreviation for another +# command. If so, invoke the command. +# +# Arguments: +# args - A list whose elements are the words of the original +# command, including the command name. + +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 + } + + set name [lindex $args 0] + 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\"" + } + set UnknownPending($name) pending + set ret [catch { + auto_load $name [uplevel 1 {::namespace current}] + } msg opts] + unset UnknownPending($name) + if {$ret != 0} { + dict append opts -errorinfo "\n (autoloading \"$name\")" + return -options $opts $msg + } + if {![array size UnknownPending]} { + unset UnknownPending + } + if {$msg} { + if {[info exists savedErrorCode]} { + set ::errorCode $savedErrorCode + } else { + unset -nocomplain ::errorCode + } + if {[info exists savedErrorInfo]} { + set errorInfo $savedErrorInfo + } else { + unset -nocomplain errorInfo + } + set code [catch {uplevel 1 $args} msg opts] + if {$code == 1} { + # + # Compute stack trace contribution from the [uplevel]. + # Note the dependence on how Tcl_AddErrorInfo, etc. + # construct the stack trace. + # + set errInfo [dict get $opts -errorinfo] + set errCode [dict get $opts -errorcode] + set cinfo $args + if {[string bytelength $cinfo] > 150} { + set cinfo [string range $cinfo 0 150] + while {[string bytelength $cinfo] > 150} { + set cinfo [string range $cinfo 0 end-1] + } + append cinfo ... + } + set tail "\n (\"uplevel\" body line 1)\n invoked\ + from within\n\"uplevel 1 \$args\"" + set expect "$msg\n while executing\n\"$cinfo\"$tail" + if {$errInfo eq $expect} { + # + # The stack has only the eval from the expanded command + # Do not generate any stack trace here. + # + dict unset opts -errorinfo + dict incr opts -level + return -options $opts $msg + } + # + # Stack trace is nested, trim off just the contribution + # from the extra "eval" of $args due to the "catch" above. + # + set last [string last $tail $errInfo] + if {$last + [string length $tail] != [string length $errInfo]} { + # Very likely cannot happen + return -options $opts $msg + } + set errInfo [string range $errInfo 0 $last-1] + set tail "\"$cinfo\"" + set last [string last $tail $errInfo] + if {$last < 0 || $last + [string length $tail] != [string length $errInfo]} { + return -code error -errorcode $errCode \ + -errorinfo $errInfo $msg + } + set errInfo [string range $errInfo 0 $last-1] + set tail "\n invoked from within\n" + set last [string last $tail $errInfo] + if {$last + [string length $tail] == [string length $errInfo]} { + return -code error -errorcode $errCode \ + -errorinfo [string range $errInfo 0 $last-1] $msg + } + set tail "\n while executing\n" + set last [string last $tail $errInfo] + if {$last + [string length $tail] == [string length $errInfo]} { + return -code error -errorcode $errCode \ + -errorinfo [string range $errInfo 0 $last-1] $msg + } + return -options $opts $msg + } else { + dict incr opts -level + return -options $opts $msg + } + } + } + + if {([info level] == 1) && ([info script] eq "") + && [info exists tcl_interactive] && $tcl_interactive} { + if {![info exists auto_noexec]} { + set new [auto_execok $name] + if {$new ne ""} { + set redir "" + if {[namespace which -command console] eq ""} { + set redir ">&@stdout <@stdin" + } + uplevel 1 [list ::catch \ + [concat exec $redir $new [lrange $args 1 end]] \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + } + if {$name eq "!!"} { + set newcmd [history event] + } elseif {[regexp {^!(.+)$} $name -> event]} { + set newcmd [history event $event] + } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} { + set newcmd [history event -1] + catch {regsub -all -- $old $newcmd $new newcmd} + } + if {[info exists newcmd]} { + tclLog $newcmd + history change $newcmd 0 + uplevel 1 [list ::catch $newcmd \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + + set ret [catch {set candidates [info commands $name*]} msg] + if {$name eq "::"} { + set name "" + } + if {$ret != 0} { + dict append opts -errorinfo \ + "\n (expanding command prefix \"$name\" in unknown)" + return -options $opts $msg + } + # Filter out bogus matches when $name contained + # a glob-special char [Bug 946952] + if {$name eq ""} { + # Handle empty $name separately due to strangeness + # in [string first] (See RFE 1243354) + set cmds $candidates + } else { + set cmds [list] + foreach x $candidates { + if {[string first $name $x] == 0} { + lappend cmds $x + } + } + } + if {[llength $cmds] == 1} { + uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } + if {[llength $cmds]} { + return -code error "ambiguous command name \"$name\": [lsort $cmds]" + } + } + return -code error -errorcode [list TCL LOOKUP COMMAND $name] \ + "invalid command name \"$name\"" +} + +# auto_load -- +# Checks a collection of library directories to see if a procedure +# is defined in one of them. If so, it sources the appropriate +# library file to create the procedure. Returns 1 if it successfully +# loaded the procedure, 0 otherwise. +# +# 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] +# for instance. If not given, namespace current is used. + +proc auto_load {cmd {namespace {}}} { + global auto_index auto_path + + if {$namespace eq ""} { + set namespace [uplevel 1 [list ::namespace current]] + } + set nameList [auto_qualify $cmd $namespace] + # workaround non canonical auto_index entries that might be around + # from older auto_mkindex versions + lappend nameList $cmd + foreach name $nameList { + if {[info exists auto_index($name)]} { + namespace eval :: $auto_index($name) + # There's a couple of ways to look for a command of a given + # name. One is to use + # 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 + # namespace which -command $name + if {[namespace which -command $name] ne ""} { + return 1 + } + } + } + if {![info exists auto_path]} { + return 0 + } + + if {![auto_load_index]} { + return 0 + } + foreach name $nameList { + if {[info exists auto_index($name)]} { + namespace eval :: $auto_index($name) + if {[namespace which -command $name] ne ""} { + return 1 + } + } + } + return 0 +} + +# auto_load_index -- +# Loads the contents of tclIndex files on the auto_path directory +# list. This is usually invoked within auto_load to load the index +# of available commands. Returns 1 if the index is loaded, and 0 if +# the index is already loaded and up to date. +# +# Arguments: +# None. + +proc auto_load_index {} { + variable ::tcl::auto_oldpath + global auto_index auto_path + + if {[info exists auto_oldpath] && ($auto_oldpath eq $auto_path)} { + return 0 + } + set auto_oldpath $auto_path + + # Check if we are a safe interpreter. In that case, we support only + # newer format tclIndex files. + + set issafe [interp issafe] + for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} { + set dir [lindex $auto_path $i] + set f "" + if {$issafe} { + catch {source [file join $dir tclIndex]} + } elseif {[catch {set f [open [file join $dir tclIndex]]}]} { + continue + } else { + set error [catch { + fconfigure $f -eofchar \032 + set id [gets $f] + if {$id eq "# Tcl autoload index file, version 2.0"} { + eval [read $f] + } elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"} { + while {[gets $f line] >= 0} { + if {([string index $line 0] eq "#") \ + || ([llength $line] != 2)} { + continue + } + set name [lindex $line 0] + set auto_index($name) \ + "source [file join $dir [lindex $line 1]]" + } + } else { + error "[file join $dir tclIndex] isn't a proper Tcl index file" + } + } msg opts] + if {$f ne ""} { + close $f + } + if {$error} { + return -options $opts $msg + } + } + } + return 1 +} + +# auto_qualify -- +# +# Compute a fully qualified names list for use in the auto_index array. +# For historical reasons, commands in the global namespace do not have leading +# :: in the index key. The list has two elements when the command name is +# relative (no leading ::) and the namespace is not the global one. Otherwise +# only one name is returned (and searched in the auto_index). +# +# Arguments - +# cmd The command name. Can be any name accepted for command +# invocations (Like "foo::::bar"). +# namespace The namespace where the command is being used - must be +# a canonical namespace as returned by [namespace current] +# for instance. + +proc auto_qualify {cmd namespace} { + + # count separators and clean them up + # (making sure that foo:::::bar will be treated as foo::bar) + set n [regsub -all {::+} $cmd :: cmd] + + # Ignore namespace if the name starts with :: + # Handle special case of only leading :: + + # Before each return case we give an example of which category it is + # with the following form : + # (inputCmd, inputNameSpace) -> output + + if {[string match ::* $cmd]} { + if {$n > 1} { + # (::foo::bar , *) -> ::foo::bar + return [list $cmd] + } else { + # (::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 + return [list $cmd] + } else { + # (nocolons , ::sub) -> ::sub::nocolons nocolons + return [list ${namespace}::$cmd $cmd] + } + } elseif {$namespace eq "::"} { + # (foo::bar , ::) -> ::foo::bar + return [list ::$cmd] + } else { + # (foo::bar , ::sub) -> ::sub::foo::bar ::foo::bar + return [list ${namespace}::$cmd ::$cmd] + } +} + +# auto_import -- +# +# Invoked during "namespace import" to make see if the imported commands +# reside in an autoloaded library. If so, the commands are loaded so +# that they will be available for the import links. If not, then this +# procedure does nothing. +# +# Arguments - +# pattern The pattern of commands being imported (like "foo::*") +# a canonical namespace as returned by [namespace current] + +proc auto_import {pattern} { + global auto_index + + # If no namespace is specified, this will be an error case + + if {![string match *::* $pattern]} { + return + } + + set ns [uplevel 1 [list ::namespace current]] + set patternList [auto_qualify $pattern $ns] + + auto_load_index + + foreach pattern $patternList { + foreach name [array names auto_index $pattern] { + if {([namespace which -command $name] eq "") + && ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} { + namespace eval :: $auto_index($name) + } + } + } +} + +# auto_execok -- +# +# 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, +# for speed. +# +# Arguments: +# name - Name of a command. + +if {$tcl_platform(platform) eq "windows"} { +# Windows version. +# +# Note that file executable doesn't work under Windows, so we have to +# look for files with .exe, .com, or .bat extensions. Also, the path +# may be in the Path or PATH environment variables, and path +# components are separated with semicolons, not colons as under Unix. +# +proc auto_execok name { + global auto_execs env tcl_platform + + if {[info exists auto_execs($name)]} { + return $auto_execs($name) + } + set auto_execs($name) "" + + set shellBuiltins [list assoc cls copy date del dir echo erase ftype \ + md mkdir mklink move rd ren rename rmdir start time type ver vol] + if {[info exists env(PATHEXT)]} { + # Add an initial ; to have the {} extension check first. + set execExtensions [split ";$env(PATHEXT)" ";"] + } else { + set execExtensions [list {} .com .exe .bat .cmd] + } + + if {[string tolower $name] in $shellBuiltins} { + # When this is command.com for some reason on Win2K, Tcl won't + # exec it unless the case is right, which this corrects. COMSPEC + # may not point to a real file, so do the check. + set cmd $env(COMSPEC) + if {[file exists $cmd]} { + set cmd [file attributes $cmd -shortname] + } + return [set auto_execs($name) [list $cmd /c $name]] + } + + if {[llength [file split $name]] != 1} { + foreach ext $execExtensions { + set file ${name}${ext} + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + return "" + } + + set path "[file dirname [info nameof]];.;" + if {[info exists env(SystemRoot)]} { + set windir $env(SystemRoot) + } elseif {[info exists env(WINDIR)]} { + set windir $env(WINDIR) + } + if {[info exists windir]} { + if {$tcl_platform(os) eq "Windows NT"} { + append path "$windir/system32;" + } + append path "$windir/system;$windir;" + } + + foreach var {PATH Path path} { + if {[info exists env($var)]} { + append path ";$env($var)" + } + } + + foreach ext $execExtensions { + unset -nocomplain checked + foreach dir [split $path {;}] { + # Skip already checked directories + if {[info exists checked($dir)] || ($dir eq "")} { + continue + } + set checked($dir) {} + set file [file join $dir ${name}${ext}] + if {[file exists $file] && ![file isdirectory $file]} { + return [set auto_execs($name) [list $file]] + } + } + } + return "" +} + +} else { +# Unix version. +# +proc auto_execok name { + global auto_execs env + + if {[info exists auto_execs($name)]} { + return $auto_execs($name) + } + set auto_execs($name) "" + if {[llength [file split $name]] != 1} { + if {[file executable $name] && ![file isdirectory $name]} { + set auto_execs($name) [list $name] + } + return $auto_execs($name) + } + foreach dir [split $env(PATH) :] { + if {$dir eq ""} { + set dir . + } + set file [file join $dir $name] + if {[file executable $file] && ![file isdirectory $file]} { + set auto_execs($name) [list $file] + return $auto_execs($name) + } + } + return "" +} + +} + +# ::tcl::CopyDirectory -- +# +# 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. +# +# Note that making changes to this procedure can change the results +# of running Tcl's tests. +# +# Arguments: +# action - "renaming" or "copying" +# src - source directory +# dest - destination directory +proc tcl::CopyDirectory {action src dest} { + set nsrc [file normalize $src] + set ndest [file normalize $dest] + + if {$action eq "renaming"} { + # Can't rename volumes. We could give a more precise + # error message here, but that would break the test suite. + if {$nsrc in [file volumes]} { + return -code error "error $action \"$src\" to\ + \"$dest\": trying to rename a volume or move a directory\ + into itself" + } + } + if {[file exists $dest]} { + if {$nsrc eq $ndest} { + return -code error "error $action \"$src\" to\ + \"$dest\": trying to rename a volume or move a directory\ + into itself" + } + if {$action eq "copying"} { + # We used to throw an error here, but, looking more closely + # at the core copy code in tclFCmd.c, if the destination + # 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 { + # Depending on the platform, and on the current + # working directory, the directories '.', '..' + # can be returned in various combinations. Anyway, + # if any other file is returned, we must signal an error. + set existing [glob -nocomplain -directory $dest * .*] + lappend existing {*}[glob -nocomplain -directory $dest \ + -type hidden * .*] + foreach s $existing { + if {[file tail $s] ni {. ..}} { + return -code error "error $action \"$src\" to\ + \"$dest\": file already exists" + } + } + } + } else { + if {[string first $nsrc $ndest] >= 0} { + set srclen [expr {[llength [file split $nsrc]] - 1}] + set ndest [lindex [file split $ndest] $srclen] + if {$ndest eq [file tail $nsrc]} { + return -code error "error $action \"$src\" to\ + \"$dest\": trying to rename a volume or move a directory\ + into itself" + } + } + file mkdir $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 *] \ + [glob -nocomplain -directory $src -types hidden *]] + + foreach s [lsort -unique $filelist] { + if {[file tail $s] ni {. ..}} { + file copy -force -- $s [file join $dest [file tail $s]] + } + } + return +} diff --git a/XSchemWin/Installer/binary_template/lib/tcl8.6/license.terms b/XSchemWin/Installer/binary_template/lib/tcl8.6/license.terms new file mode 100644 index 00000000..d8049cd9 --- /dev/null +++ b/XSchemWin/Installer/binary_template/lib/tcl8.6/license.terms @@ -0,0 +1,40 @@ +This software is copyrighted by the Regents of the University of +California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState +Corporation and other parties. The following terms apply to all files +associated with the software unless explicitly disclaimed in +individual files. + +The authors hereby grant permission to use, copy, modify, distribute, +and license this software and its documentation for any purpose, provided +that existing copyright notices are retained in all copies and that this +notice is included verbatim in any distributions. No written agreement, +license, or royalty fee is required for any of the authorized uses. +Modifications to this software may be copyrighted by their authors +and need not follow the licensing terms described here, provided that +the new terms are clearly indicated on the first page of each file where +they apply. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY +FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES +ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY +DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE +IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE +NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. + +GOVERNMENT USE: If you are acquiring this software on behalf of the +U.S. government, the Government shall have only "Restricted Rights" +in the software and related documentation as defined in the Federal +Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you +are acquiring the software on behalf of the Department of Defense, the +software shall be classified as "Commercial Computer Software" and the +Government shall have only "Restricted Rights" as defined in Clause +252.227-7014 (b) (3) of DFARs. Notwithstanding the foregoing, the +authors grant the U.S. Government and others acting in its behalf +permission to use and distribute the software in accordance with the +terms specified in this license. diff --git a/XSchemWin/Installer/binary_template/lib/tcl8.6/package.tcl b/XSchemWin/Installer/binary_template/lib/tcl8.6/package.tcl new file mode 100644 index 00000000..4a733467 --- /dev/null +++ b/XSchemWin/Installer/binary_template/lib/tcl8.6/package.tcl @@ -0,0 +1,751 @@ +# package.tcl -- +# +# utility procs formerly in init.tcl which can be loaded on demand +# for package management. +# +# 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. +# + +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. +# +# Arguments: +# fileName name of a file whose extension is compared +# ext (optional) The extension to compare against; you must +# provide the starting dot. +# Defaults to [info sharedlibextension] +# +# Results: +# Returns 1 if the extension matches, 0 otherwise + +proc tcl::Pkg::CompareExtension {fileName {ext {}}} { + global tcl_platform + if {$ext eq ""} {set ext [info sharedlibextension]} + if {$tcl_platform(platform) eq "windows"} { + return [string equal -nocase [file extension $fileName] $ext] + } else { + # Some unices add trailing numbers after the .so, so + # we could have something like '.so.1.2'. + set root $fileName + while {1} { + 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 + # extensions. Otherwise we might return 1 in this case: + # tcl::Pkg::CompareExtension foo.so.bar .so + # which should not match. + + if {![string is integer -strict [string range $currExt 1 end]]} { + return 0 + } + set root [file rootname $root] + } + } +} + +# 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. +# +# Arguments: +# -direct (optional) If this flag is present, the generated +# code in pkgMkIndex.tcl will cause the package to be +# loaded when "package require" is executed, rather +# than lazily when the first reference to an exported +# procedure in the package is made. +# -verbose (optional) Verbose output; the name of each file that +# was successfully rocessed is printed out. Additionally, +# if processing of a file failed a message is printed. +# -load pat (optional) Preload any packages whose names match +# the pattern. Used to handle DLLs that depend on +# other packages during their Init procedure. +# dir - Name of the directory in which to create the index. +# args - Any number of additional arguments, each giving +# a glob pattern that matches the names of one or +# more shared libraries or Tcl script files in +# dir. + +proc pkg_mkIndex {args} { + set usage {"pkg_mkIndex ?-direct? ?-lazy? ?-load pattern? ?-verbose? ?--? dir ?pattern ...?"} + + set argCount [llength $args] + if {$argCount < 1} { + return -code error "wrong # args: should be\n$usage" + } + + set more "" + set direct 1 + set doVerbose 0 + set loadPat "" + for {set idx 0} {$idx < $argCount} {incr idx} { + set flag [lindex $args $idx] + switch -glob -- $flag { + -- { + # done with the flags + incr idx + break + } + -verbose { + set doVerbose 1 + } + -lazy { + set direct 0 + append more " -lazy" + } + -direct { + append more " -direct" + } + -load { + incr idx + set loadPat [lindex $args $idx] + append more " -load $loadPat" + } + -* { + return -code error "unknown flag $flag: should be\n$usage" + } + default { + # done with the flags + break + } + } + } + + set dir [lindex $args $idx] + set patternList [lrange $args [expr {$idx + 1}] end] + if {![llength $patternList]} { + 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 + } + 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. + + if {$file eq "pkgIndex.tcl"} { + continue + } + + set c [interp create] + + # Load into the child any packages currently loaded in the parent + # interpreter that match the -load pattern. + + if {$loadPat ne ""} { + if {$doVerbose} { + tclLog "currently loaded packages: '[info loaded]'" + tclLog "trying to load all packages matching $loadPat" + } + if {![llength [info loaded]]} { + tclLog "warning: no packages are currently loaded, nothing" + tclLog "can possibly match '$loadPat'" + } + } + foreach pkg [info loaded] { + if {![string match -nocase $loadPat [lindex $pkg 1]]} { + continue + } + if {$doVerbose} { + tclLog "package [lindex $pkg 1] matches '$loadPat'" + } + try { + load [lindex $pkg 0] [lindex $pkg 1] $c + } on error 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]" + } + } + if {[lindex $pkg 1] eq "Tk"} { + # Withdraw . if Tk was loaded, to avoid showing a window. + $c eval [list wm withdraw .] + } + } + + $c eval { + # 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 + } + } + } + proc tclPkgUnknown args {} + package unknown tclPkgUnknown + + # Stub out the unknown command so package can call into each other + # during their initialilzation. + + proc unknown {args} {} + + # Stub out the auto_import mechanism + + 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. + + namespace eval ::tcl { + variable dir ;# Current directory being processed + variable file ;# Current file being processed + variable direct ;# -direct flag value + variable x ;# Loop variable + variable debug ;# For debugging + variable type ;# "load" or "source", for -direct + variable namespaces ;# Existing namespaces (e.g., ::tcl) + variable packages ;# Existing packages (e.g., Tcl) + variable origCmds ;# Existing commands + variable newCmds ;# Newly created commands + variable newPkgs {} ;# Newly created packages + } + } + + $c eval [list set ::tcl::dir $dir] + $c eval [list set ::tcl::file $file] + $c eval [list set ::tcl::direct $direct] + + # Download needed procedures into the child 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 { + $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. + + proc ::tcl::GetAllNamespaces {{root ::}} { + set list $root + foreach ns [namespace children $root] { + lappend list {*}[::tcl::GetAllNamespaces $ns] + } + return $list + } + + # init the list of existing namespaces, packages, commands + + foreach ::tcl::x [::tcl::GetAllNamespaces] { + set ::tcl::namespaces($::tcl::x) 1 + } + foreach ::tcl::x [package names] { + if {[package provide $::tcl::x] ne ""} { + set ::tcl::packages($::tcl::x) 1 + } + } + 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. + + 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. + + set ::tcl::debug loading + load [file join $::tcl::dir $::tcl::file] + set ::tcl::type load + } else { + set ::tcl::debug sourcing + source [file join $::tcl::dir $::tcl::file] + 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} { + # 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)]} { + namespace import -force ${::tcl::x}::* + } + + # Figure out what commands appeared + + foreach ::tcl::x [info commands] { + set ::tcl::newCmds($::tcl::x) 1 + } + foreach ::tcl::x $::tcl::origCmds { + unset -nocomplain ::tcl::newCmds($::tcl::x) + } + 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 + + 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) + } + } + } + } + + # 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 "" + && ![info exists ::tcl::packages($::tcl::x)]} { + lappend ::tcl::newPkgs \ + [list $::tcl::x [package provide $::tcl::x]] + } + } + } + } on error msg { + set what [$c eval set ::tcl::debug] + if {$doVerbose} { + tclLog "warning: error while $what $file: $msg" + } + } on ok {} { + set what [$c eval set ::tcl::debug] + if {$doVerbose} { + tclLog "successful $what of $file" + } + set type [$c eval set ::tcl::type] + set cmds [lsort [$c eval array names ::tcl::newCmds]] + set pkgs [$c eval set ::tcl::newPkgs] + if {$doVerbose} { + if {!$direct} { + tclLog "commands provided were $cmds" + } + tclLog "packages provided were $pkgs" + } + if {[llength $pkgs] > 1} { + tclLog "warning: \"$file\" provides more than one package ($pkgs)" + } + foreach pkg $pkgs { + # cmds is empty/not used in the direct case + lappend files($pkg) [list $file $type $cmds] + } + + if {$doVerbose} { + tclLog "processed $file" + } + } + interp delete $c + } + + append index "# Tcl package index file, version 1.1\n" + append index "# This file is generated by the \"pkg_mkIndex$more\" command\n" + append index "# and sourced either when an application starts up or\n" + append index "# by a \"package unknown\" script. It invokes the\n" + append index "# \"package ifneeded\" command to set up package-related\n" + append index "# information so that packages will be loaded automatically\n" + append index "# in response to \"package require\" commands. When this\n" + append index "# script is sourced, the variable \$dir must contain the\n" + append index "# full path name of this file's directory.\n" + + foreach pkg [lsort [array names files]] { + set cmd {} + lassign $pkg name version + lappend cmd ::tcl::Pkg::Create -name $name -version $version + foreach spec [lsort -index 0 $files($pkg)] { + foreach {file type procs} $spec { + if {$direct} { + set procs {} + } + lappend cmd "-$type" [list $file $procs] + } + } + append index "\n[eval $cmd]" + } + + set f [open [file join $dir pkgIndex.tcl] w] + puts $f $index + close $f +} + +# 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. +# +# Arguments: +# dir - Directory containing all the files for this package. +# pkg - Name of the package (no version number). +# version - Version number for the package, such as 2.1.3. +# files - List of files that constitute the package. Each +# element is a sub-list with three elements. The first +# is the name of a file relative to $dir, the second is +# "load" or "source", indicating whether the file is a +# loadable binary or a script to source, and the third +# is a list of commands defined by this file. + +proc tclPkgSetup {dir pkg version files} { + global auto_index + + package provide $pkg $version + foreach fileInfo $files { + set f [lindex $fileInfo 0] + set type [lindex $fileInfo 1] + foreach cmd [lindex $fileInfo 2] { + if {$type eq "load"} { + 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. +# +# Arguments: +# name - Name of desired package. Not used. +# version - Version of desired package. Not used. +# exact - Either "-exact" or omitted. Not used. + +proc tclPkgUnknown {name args} { + global auto_path env + + 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 + 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] + continue + } + set tclSeenPath($dir) 1 + + # Get the pkgIndex.tcl files in subdirectories of auto_path directories. + # - Safe Base interpreters have a restricted "glob" command that + # works in this case. + # - The "catch" was essential when there was no safe glob and every + # call in a safe interp failed; it is retained only for corner + # cases in which the eventual call to glob returns an error. + 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} {} { + # $file was not readable; silently ignore + continue + } on error msg { + tclLog "error reading package index file $file: $msg" + } on ok {} { + set procdDirs($dir) 1 + } + } + } + } + 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", + if {([interp issafe] || [file exists $file])} { + try { + source $file + } trap {POSIX EACCES} {} { + # $file was not readable; silently ignore + continue + } on error msg { + tclLog "error reading package index file $file: $msg" + } on ok {} { + set procdDirs($dir) 1 + } + } + } + + set use_path [lrange $use_path 0 end-1] + + # Check whether any of the index scripts we [source]d above set a new + # value for $::auto_path. If so, then find any new directories on the + # $::auto_path, and lappend them to the $use_path we are working from. + # This gives index scripts the (arguably unwise) power to expand the + # index script search path while the search is in progress. + set index 0 + if {[llength $old_path] == [llength $auto_path]} { + foreach dir $auto_path old $old_path { + if {$dir ne $old} { + # This entry in $::auto_path has changed. + break + } + incr index + } + } + + # $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 + } + } + set old_path $auto_path + } +} + +# 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. +# +# Arguments: +# original - original [package unknown] procedure +# name - Name of desired package. Not used. +# version - Version of desired package. Not used. +# 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] + + # Now do MacOSX specific searching + global auto_path + + 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 + 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] + continue + } + set tclSeenPath($dir) 1 + + # get the pkgIndex files out of the subdirectories + # Safe interpreters do not use tcl::MacOSXPkgUnknown - see init.tcl. + foreach file [glob -directory $dir -join -nocomplain \ + * Resources Scripts pkgIndex.tcl] { + set dir [file dirname $file] + if {![info exists procdDirs($dir)]} { + try { + source $file + } trap {POSIX EACCES} {} { + # $file was not readable; silently ignore + continue + } on error msg { + tclLog "error reading package index file $file: $msg" + } on ok {} { + set procdDirs($dir) 1 + } + } + } + set use_path [lrange $use_path 0 end-1] + + # Check whether any of the index scripts we [source]d above set a new + # value for $::auto_path. If so, then find any new directories on the + # $::auto_path, and lappend them to the $use_path we are working from. + # This gives index scripts the (arguably unwise) power to expand the + # index script search path while the search is in progress. + set index 0 + if {[llength $old_path] == [llength $auto_path]} { + foreach dir $auto_path old $old_path { + if {$dir ne $old} { + # This entry in $::auto_path has changed. + break + } + incr index + } + } + + # $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 + } + } + set old_path $auto_path + } +} + +# ::tcl::Pkg::Create -- +# +# Given a package specification generate a "package ifneeded" statement +# for the package, suitable for inclusion in a pkgIndex.tcl file. +# +# Arguments: +# args arguments used by the Create function: +# -name packageName +# -version packageVersion +# -load {filename ?{procs}?} +# ... +# -source {filename ?{procs}?} +# ... +# +# 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. +# +# Results: +# An appropriate "package ifneeded" statement for the package. + +proc ::tcl::Pkg::Create {args} { + append err(usage) "[lindex [info level 0] 0] " + append err(usage) "-name packageName -version packageVersion" + append err(usage) "?-load {filename ?{procs}?}? ... " + append err(usage) "?-source {filename ?{procs}?}? ..." + + set err(wrongNumArgs) "wrong # args: should be \"$err(usage)\"" + set err(valueMissing) "value for \"%s\" missing: should be \"$err(usage)\"" + set err(unknownOpt) "unknown option \"%s\": should be \"$err(usage)\"" + set err(noLoadOrSource) "at least one of -load and -source must be given" + + # process arguments + set len [llength $args] + if {$len < 6} { + error $err(wrongNumArgs) + } + + # Initialize parameters + array set opts {-name {} -version {} -source {} -load {}} + + # process parameters + for {set i 0} {$i < $len} {incr i} { + set flag [lindex $args $i] + incr i + switch -glob -- $flag { + "-name" - + "-version" { + if {$i >= $len} { + error [format $err(valueMissing) $flag] + } + set opts($flag) [lindex $args $i] + } + "-source" - + "-load" { + if {$i >= $len} { + error [format $err(valueMissing) $flag] + } + lappend opts($flag) [lindex $args $i] + } + default { + error [format $err(unknownOpt) [lindex $args $i]] + } + } + } + + # Validate the parameters + if {![llength $opts(-name)]} { + error [format $err(valueMissing) "-name"] + } + if {![llength $opts(-version)]} { + error [format $err(valueMissing) "-version"] + } + + if {!([llength $opts(-source)] || [llength $opts(-load)])} { + error $err(noLoadOrSource) + } + + # OK, now everything is good. Generate the package ifneeded statment. + set cmdline "package ifneeded $opts(-name) $opts(-version) " + + set cmdList {} + set lazyFileList {} + + # Handle -load and -source specs + foreach key {load source} { + foreach filespec $opts(-$key) { + lassign $filespec filename proclist + + if { [llength $proclist] == 0 } { + set cmd "\[list $key \[file join \$dir [list $filename]\]\]" + lappend cmdList $cmd + } else { + lappend lazyFileList [list $filename $key $proclist] + } + } + } + + if {[llength $lazyFileList]} { + lappend cmdList "\[list tclPkgSetup \$dir $opts(-name)\ + $opts(-version) [list $lazyFileList]\]" + } + append cmdline [join $cmdList "\\n"] + return $cmdline +} + +interp alias {} ::pkg::create {} ::tcl::Pkg::Create diff --git a/XSchemWin/Installer/binary_template/lib/tcl8.6/parray.tcl b/XSchemWin/Installer/binary_template/lib/tcl8.6/parray.tcl new file mode 100644 index 00000000..a9c2cb15 --- /dev/null +++ b/XSchemWin/Installer/binary_template/lib/tcl8.6/parray.tcl @@ -0,0 +1,28 @@ +# parray: +# Print the contents of a global array on stdout. +# +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +proc parray {a {pattern *}} { + upvar 1 $a array + if {![array exists array]} { + return -code error "\"$a\" isn't an array" + } + set maxl 0 + set names [lsort [array names array $pattern]] + foreach name $names { + if {[string length $name] > $maxl} { + set maxl [string length $name] + } + } + set maxl [expr {$maxl + [string length $a] + 2}] + foreach name $names { + set nameString [format %s(%s) $a $name] + puts stdout [format "%-*s = %s" $maxl $nameString $array($name)] + } +} diff --git a/XSchemWin/Installer/binary_template/lib/tcl8.6/safe.tcl b/XSchemWin/Installer/binary_template/lib/tcl8.6/safe.tcl new file mode 100644 index 00000000..b9dd18dc --- /dev/null +++ b/XSchemWin/Installer/binary_template/lib/tcl8.6/safe.tcl @@ -0,0 +1,1289 @@ +# safe.tcl -- +# +# This file provide a safe loading/sourcing mechanism for safe interpreters. +# It implements a virtual path mechanism to hide the real pathnames from the +# child. It runs in a parent interpreter and sets up data structure and +# aliases that will be invoked when used from a child interpreter. +# +# See the safe.n man page for details. +# +# Copyright (c) 1996-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. + +# +# The implementation is based on namespaces. These naming conventions are +# followed: +# Private procs starts with uppercase. +# Public procs are exported and starts with lowercase +# + +# Needed utilities package +package require opt 0.4.8 + +# Create the safe namespace +namespace eval ::safe { + # Exported API: + namespace export interpCreate interpInit interpConfigure interpDelete \ + interpAddToAccessPath interpFindInAccessPath setLogCmd +} + +# Helper function to resolve the dual way of specifying staticsok (either +# by -noStatics or -statics 0) +proc ::safe::InterpStatics {} { + foreach v {Args statics noStatics} { + upvar $v $v + } + set flag [::tcl::OptProcArgGiven -noStatics] + if {$flag && (!$noStatics == !$statics) + && ([::tcl::OptProcArgGiven -statics])} { + return -code error\ + "conflicting values given for -statics and -noStatics" + } + if {$flag} { + return [expr {!$noStatics}] + } else { + return $statics + } +} + +# Helper function to resolve the dual way of specifying nested loading +# (either by -nestedLoadOk or -nested 1) +proc ::safe::InterpNested {} { + foreach v {Args nested nestedLoadOk} { + upvar $v $v + } + 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) + && ([::tcl::OptProcArgGiven -nested])} { + return -code error\ + "conflicting values given for -nested and -nestedLoadOk" + } + if {$flag} { + # another difference with "InterpStatics" + return $nestedLoadOk + } else { + return $nested + } +} + +#### +# +# API entry points that needs argument parsing : +# +#### + +# Interface/entry point function and front end for "Create" +proc ::safe::interpCreate {args} { + set Args [::tcl::OptKeyParse ::safe::interpCreate $args] + RejectExcessColons $slave + InterpCreate $slave $accessPath \ + [InterpStatics] [InterpNested] $deleteHook +} + +proc ::safe::interpInit {args} { + set Args [::tcl::OptKeyParse ::safe::interpIC $args] + if {![::interp exists $slave]} { + return -code error "\"$slave\" is not an interpreter" + } + RejectExcessColons $slave + InterpInit $slave $accessPath \ + [InterpStatics] [InterpNested] $deleteHook +} + +# Check that the given child is "one of us" +proc ::safe::CheckInterp {child} { + namespace upvar ::safe [VarName $child] state + if {![info exists state] || ![::interp exists $child]} { + return -code error \ + "\"$child\" is not an interpreter managed by ::safe::" + } +} + +# Interface/entry point function and front end for "Configure". This code +# is awfully pedestrian because it would need more coupling and support +# between the way we store the configuration values in safe::interp's and +# the Opt package. Obviously we would like an OptConfigure to avoid +# duplicating all this code everywhere. +# -> TODO (the app should share or access easily the program/value stored +# by opt) + +# This is even more complicated by the boolean flags with no values that +# we had the bad idea to support for the sake of user simplicity in +# create/init but which makes life hard in configure... +# So this will be hopefully written and some integrated with opt1.0 +# (hopefully for tcl8.1 ?) +proc ::safe::interpConfigure {args} { + switch [llength $args] { + 1 { + # If we have exactly 1 argument the semantic is to return all + # the current configuration. We still call OptKeyParse though + # we know that "child" is our given argument because it also + # checks for the "-help" option. + set Args [::tcl::OptKeyParse ::safe::interpIC $args] + CheckInterp $slave + namespace upvar ::safe [VarName $slave] state + + return [join [list \ + [list -accessPath $state(access_path)] \ + [list -statics $state(staticsok)] \ + [list -nested $state(nestedok)] \ + [list -deleteHook $state(cleanupHook)]]] + } + 2 { + # If we have exactly 2 arguments the semantic is a "configure + # get" + lassign $args slave arg + + # get the flag sub program (we 'know' about Opt's internal + # representation of data) + set desc [lindex [::tcl::OptKeyGetDesc ::safe::interpIC] 2] + set hits [::tcl::OptHits desc $arg] + if {$hits > 1} { + return -code error [::tcl::OptAmbigous $desc $arg] + } elseif {$hits == 0} { + return -code error [::tcl::OptFlagUsage $desc $arg] + } + CheckInterp $slave + namespace upvar ::safe [VarName $slave] state + + 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)] + } + -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* + # that it is a set action that the user want, so force + # it to use the unambigous -statics ?value? instead: + return -code error\ + "ambigous query (get or set -noStatics ?)\ + use -statics instead" + } + -nestedLoadOk { + return -code error\ + "ambigous query (get or set -nestedLoadOk ?)\ + use -nested instead" + } + default { + return -code error "unknown flag $name (bug)" + } + } + } + default { + # Otherwise we want to parse the arguments like init and + # create did + set Args [::tcl::OptKeyParse ::safe::interpIC $args] + CheckInterp $slave + namespace upvar ::safe [VarName $slave] state + + # Get the current (and not the default) values of whatever has + # not been given: + if {![::tcl::OptProcArgGiven -accessPath]} { + set doreset 0 + set accessPath $state(access_path) + } else { + set doreset 1 + } + if { + ![::tcl::OptProcArgGiven -statics] + && ![::tcl::OptProcArgGiven -noStatics] + } then { + set statics $state(staticsok) + } else { + set statics [InterpStatics] + } + if { + [::tcl::OptProcArgGiven -nested] || + [::tcl::OptProcArgGiven -nestedLoadOk] + } then { + set nested [InterpNested] + } else { + set nested $state(nestedok) + } + if {![::tcl::OptProcArgGiven -deleteHook]} { + set deleteHook $state(cleanupHook) + } + # we can now reconfigure : + InterpSetConfig $slave $accessPath $statics $nested $deleteHook + # auto_reset the child (to completly synch the new access_path) + if {$doreset} { + if {[catch {::interp eval $slave {auto_reset}} msg]} { + Log $slave "auto_reset failed: $msg" + } else { + Log $slave "successful auto_reset" NOTICE + } + + # Sync the paths used to search for Tcl modules. + ::interp eval $slave {tcl::tm::path remove {*}[tcl::tm::list]} + if {[llength $state(tm_path_slave)] > 0} { + ::interp eval $slave [list \ + ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]] + } + + # Remove stale "package ifneeded" data for non-loaded packages. + # - Not for loaded packages, because "package forget" erases + # data from "package provide" as well as "package ifneeded". + # - This is OK because the script cannot reload any version of + # the package unless it first does "package forget". + foreach pkg [::interp eval $slave {package names}] { + if {[::interp eval $slave [list package provide $pkg]] eq ""} { + ::interp eval $slave [list package forget $pkg] + } + } + } + return + } + } +} + +#### +# +# Functions that actually implements the exported APIs +# +#### + +# +# safe::InterpCreate : doing the real job +# +# This procedure creates a safe interpreter and initializes it with the safe +# base aliases. +# NB: child name must be simple alphanumeric string, no spaces, no (), no +# {},... {because the state array is stored as part of the name} +# +# Returns the child name. +# +# Optional Arguments : +# + child name : if empty, generated name will be used +# + access_path: path list controlling where load/source can occur, +# if empty: the parent auto_path will be used. +# + staticsok : flag, if 0 :no static package can be loaded (load {} Xxx) +# if 1 :static packages are ok. +# + nestedok: flag, if 0 :no loading to sub-sub interps (load xx xx sub) +# if 1 : multiple levels are ok. + +# use the full name and no indent so auto_mkIndex can find us +proc ::safe::InterpCreate { + child + access_path + staticsok + nestedok + deletehook + } { + # Create the child. + # If evaluated in ::safe, the interpreter command for foo is ::foo; + # but for foo::bar is safe::foo::bar. So evaluate in :: instead. + if {$child ne ""} { + namespace eval :: [list ::interp create -safe $child] + } else { + # empty argument: generate child name + set child [::interp create -safe] + } + Log $child "Created" NOTICE + + # Initialize it. (returns child name) + InterpInit $child $access_path $staticsok $nestedok $deletehook +} + +# +# InterpSetConfig (was setAccessPath) : +# Sets up child virtual auto_path and corresponding structure within +# the parent. Also sets the tcl_library in the child to be the first +# directory in the path. +# NB: If you change the path after the child has been initialized you +# probably need to call "auto_reset" in the child in order that it gets +# the right auto_index() array values. + +proc ::safe::InterpSetConfig {child access_path staticsok nestedok deletehook} { + global auto_path + + # determine and store the access path if empty + if {$access_path eq ""} { + set access_path $auto_path + + # Make sure that tcl_library is in auto_path and at the first + # position (needed by setAccessPath) + set where [lsearch -exact $access_path [info library]] + if {$where < 0} { + # not found, add it. + set access_path [linsert $access_path 0 [info library]] + Log $child "tcl_library was not in auto_path,\ + added it to slave's access_path" NOTICE + } elseif {$where != 0} { + # not first, move it first + set access_path [linsert \ + [lreplace $access_path $where $where] \ + 0 [info library]] + Log $child "tcl_libray was not in first in auto_path,\ + moved it to front of slave's access_path" NOTICE + } + + # Add 1st level sub dirs (will searched by auto loading from tcl + # code in the child using glob and thus fail, so we add them here + # so by default it works the same). + set access_path [AddSubDirs $access_path] + } + + Log $child "Setting accessPath=($access_path) staticsok=$staticsok\ + nestedok=$nestedok deletehook=($deletehook)" NOTICE + + namespace upvar ::safe [VarName $child] state + + # clear old autopath if it existed + # build new one + # Extend the access list with the paths used to look for Tcl Modules. + # We save the virtual form separately as well, as syncing it with the + # child has to be deferred until the necessary commands are present for + # setup. + + set norm_access_path {} + set slave_access_path {} + set map_access_path {} + set remap_access_path {} + set slave_tm_path {} + + set i 0 + foreach dir $access_path { + set token [PathToken $i] + lappend slave_access_path $token + lappend map_access_path $token $dir + lappend remap_access_path $dir $token + lappend norm_access_path [file normalize $dir] + incr i + } + + set morepaths [::tcl::tm::list] + set firstpass 1 + while {[llength $morepaths]} { + set addpaths $morepaths + set morepaths {} + + foreach dir $addpaths { + # Prevent the addition of dirs on the tm list to the + # result if they are already known. + if {[dict exists $remap_access_path $dir]} { + if {$firstpass} { + # $dir is in [::tcl::tm::list] and belongs in the slave_tm_path. + # Later passes handle subdirectories, which belong in the + # access path but not in the module path. + lappend slave_tm_path [dict get $remap_access_path $dir] + } + continue + } + + set token [PathToken $i] + lappend access_path $dir + lappend slave_access_path $token + lappend map_access_path $token $dir + lappend remap_access_path $dir $token + lappend norm_access_path [file normalize $dir] + if {$firstpass} { + # $dir is in [::tcl::tm::list] and belongs in the slave_tm_path. + # Later passes handle subdirectories, which belong in the + # access path but not in the module path. + lappend slave_tm_path $token + } + incr i + + # [Bug 2854929] + # Recursively find deeper paths which may contain + # modules. Required to handle modules with names like + # 'platform::shell', which translate into + # 'platform/shell-X.tm', i.e arbitrarily deep + # subdirectories. + lappend morepaths {*}[glob -nocomplain -directory $dir -type d *] + } + set firstpass 0 + } + + set state(access_path) $access_path + set state(access_path,map) $map_access_path + set state(access_path,remap) $remap_access_path + set state(access_path,norm) $norm_access_path + set state(access_path,slave) $slave_access_path + set state(tm_path_slave) $slave_tm_path + set state(staticsok) $staticsok + set state(nestedok) $nestedok + set state(cleanupHook) $deletehook + + SyncAccessPath $child + return +} + +# +# +# FindInAccessPath: +# Search for a real directory and returns its virtual Id (including the +# "$") +proc ::safe::interpFindInAccessPath {child path} { + CheckInterp $child + namespace upvar ::safe [VarName $child] state + + if {![dict exists $state(access_path,remap) $path]} { + return -code error "$path not found in access path" + } + + return [dict get $state(access_path,remap) $path] +} + +# +# addToAccessPath: +# add (if needed) a real directory to access path and return its +# virtual token (including the "$"). +proc ::safe::interpAddToAccessPath {child path} { + # first check if the directory is already in there + # (inlined interpFindInAccessPath). + CheckInterp $child + namespace upvar ::safe [VarName $child] state + + if {[dict exists $state(access_path,remap) $path]} { + return [dict get $state(access_path,remap) $path] + } + + # new one, add it: + set token [PathToken [llength $state(access_path)]] + + lappend state(access_path) $path + lappend state(access_path,slave) $token + lappend state(access_path,map) $token $path + lappend state(access_path,remap) $path $token + lappend state(access_path,norm) [file normalize $path] + + SyncAccessPath $child + return $token +} + +# This procedure applies the initializations to an already existing +# interpreter. It is useful when you want to install the safe base aliases +# into a preexisting safe interpreter. +proc ::safe::InterpInit { + child + access_path + staticsok + nestedok + deletehook + } { + # Configure will generate an access_path when access_path is empty. + InterpSetConfig $child $access_path $staticsok $nestedok $deletehook + + # NB we need to add [namespace current], aliases are always absolute + # paths. + + # These aliases let the child load files to define new commands + # This alias lets the child use the encoding names, convertfrom, + # convertto, and system, but not "encoding system " to set the + # system encoding. + # Handling Tcl Modules, we need a restricted form of Glob. + # This alias interposes on the 'exit' command and cleanly terminates + # the child. + + foreach {command alias} { + source AliasSource + load AliasLoad + encoding AliasEncoding + exit interpDelete + glob AliasGlob + } { + ::interp alias $child $command {} [namespace current]::$alias $child + } + + # This alias lets the child have access to a subset of the 'file' + # command functionality. + + ::interp expose $child file + foreach subcommand {dirname extension rootname tail} { + ::interp alias $child ::tcl::file::$subcommand {} \ + ::safe::AliasFileSubcommand $child $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 $child ::tcl::file::$subcommand {} \ + ::safe::BadSubcommand $child file $subcommand + } + + # Subcommands of info + foreach {subcommand alias} { + nameofexecutable AliasExeName + } { + ::interp alias $child ::tcl::info::$subcommand \ + {} [namespace current]::$alias $child + } + + # The allowed child variables already have been set by Tcl_MakeSafe(3) + + # Source init.tcl and tm.tcl into the child, to get auto_load and + # other procedures defined: + + if {[catch {::interp eval $child { + source [file join $tcl_library init.tcl] + }} msg opt]} { + Log $child "can't source init.tcl ($msg)" + return -options $opt "can't source init.tcl into slave $child ($msg)" + } + + if {[catch {::interp eval $child { + source [file join $tcl_library tm.tcl] + }} msg opt]} { + Log $child "can't source tm.tcl ($msg)" + return -options $opt "can't source tm.tcl into slave $child ($msg)" + } + + # Sync the paths used to search for Tcl modules. This can be done only + # now, after tm.tcl was loaded. + namespace upvar ::safe [VarName $child] state + if {[llength $state(tm_path_slave)] > 0} { + ::interp eval $child [list \ + ::tcl::tm::add {*}[lreverse $state(tm_path_slave)]] + } + return $child +} + +# Add (only if needed, avoid duplicates) 1 level of sub directories to an +# existing path list. Also removes non directories from the returned +# list. +proc ::safe::AddSubDirs {pathList} { + set res {} + foreach dir $pathList { + if {[file isdirectory $dir]} { + # check that we don't have it yet as a children of a previous + # dir + if {$dir ni $res} { + lappend res $dir + } + foreach sub [glob -directory $dir -nocomplain *] { + if {[file isdirectory $sub] && ($sub ni $res)} { + # new sub dir, add it ! + lappend res $sub + } + } + } + } + return $res +} + +# This procedure deletes a safe interpreter managed by Safe Tcl and cleans up +# associated state. +# - The command will also delete non-Safe-Base interpreters. +# - This is regrettable, but to avoid breaking existing code this should be +# amended at the next major revision by uncommenting "CheckInterp". + +proc ::safe::interpDelete {child} { + Log $child "About to delete" NOTICE + + # CheckInterp $child + namespace upvar ::safe [VarName $child] state + + # When an interpreter is deleted with [interp delete], any sub-interpreters + # are deleted automatically, but this leaves behind their data in the Safe + # Base. To clean up properly, we call safe::interpDelete recursively on each + # Safe Base sub-interpreter, so each one is deleted cleanly and not by + # the automatic mechanism built into [interp delete]. + foreach sub [interp children $child] { + if {[info exists ::safe::[VarName [list $child $sub]]]} { + ::safe::interpDelete [list $child $sub] + } + } + + # If the child has a cleanup hook registered, call it. Check the + # existance because we might be called to delete an interp which has + # not been registered with us at all + + if {[info exists state(cleanupHook)]} { + set hook $state(cleanupHook) + if {[llength $hook]} { + # remove the hook now, otherwise if the hook calls us somehow, + # we'll loop + unset state(cleanupHook) + try { + {*}$hook $child + } on error err { + Log $child "Delete hook error ($err)" + } + } + } + + # Discard the global array of state associated with the child, and + # delete the interpreter. + + if {[info exists state]} { + unset state + } + + # if we have been called twice, the interp might have been deleted + # already + if {[::interp exists $child]} { + ::interp delete $child + Log $child "Deleted" NOTICE + } + + return +} + +# Set (or get) the logging mecanism + +proc ::safe::setLogCmd {args} { + variable Log + set la [llength $args] + if {$la == 0} { + return $Log + } elseif {$la == 1} { + set Log [lindex $args 0] + } else { + set Log $args + } + + if {$Log eq ""} { + # Disable logging completely. Calls to it will be compiled out + # of all users. + proc ::safe::Log {args} {} + } else { + # Activate logging, define proper command. + + proc ::safe::Log {child msg {type ERROR}} { + variable Log + {*}$Log "$type for slave $child : $msg" + return + } + } +} + +# ------------------- END OF PUBLIC METHODS ------------ + +# +# Sets the child auto_path to the parent recorded value. Also sets +# tcl_library to the first token of the virtual path. +# +proc ::safe::SyncAccessPath {child} { + namespace upvar ::safe [VarName $child] state + + set slave_access_path $state(access_path,slave) + ::interp eval $child [list set auto_path $slave_access_path] + + Log $child "auto_path in $child has been set to $slave_access_path"\ + NOTICE + + # This code assumes that info library is the first element in the + # list of auto_path's. See -> InterpSetConfig for the code which + # ensures this condition. + + ::interp eval $child [list \ + set tcl_library [lindex $slave_access_path 0]] +} + +# Returns the virtual token for directory number N. +proc ::safe::PathToken {n} { + # We need to have a ":" in the token string so [file join] on the + # mac won't turn it into a relative path. + return "\$p(:$n:)" ;# Form tested by case 7.2 +} + +# +# translate virtual path into real path +# +proc ::safe::TranslatePath {child path} { + namespace upvar ::safe [VarName $child] state + + # somehow strip the namespaces 'functionality' out (the danger is that + # we would strip valid macintosh "../" queries... : + if {[string match "*::*" $path] || [string match "*..*" $path]} { + return -code error "invalid characters in path $path" + } + + # Use a cached map instead of computed local vars and subst. + + return [string map $state(access_path,map) $path] +} + +# file name control (limit access to files/resources that should be a +# valid tcl source file) +proc ::safe::CheckFileName {child file} { + # This used to limit what can be sourced to ".tcl" and forbid files + # with more than 1 dot and longer than 14 chars, but I changed that + # for 8.4 as a safe interp has enough internal protection already to + # allow sourcing anything. - hobbs + + if {![file exists $file]} { + # don't tell the file path + return -code error "no such file or directory" + } + + if {![file readable $file]} { + # don't tell the file path + return -code error "not readable" + } +} + +# 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 {child subcommand name} { + if {[string match ~* $name]} { + set name ./$name + } + tailcall ::interp invokehidden $child tcl:file:$subcommand $name +} + +# AliasGlob is the target of the "glob" alias in safe interpreters. + +proc ::safe::AliasGlob {child args} { + Log $child "GLOB ! $args" NOTICE + set cmd {} + set at 0 + array set got { + -directory 0 + -nocomplain 0 + -join 0 + -tails 0 + -- 0 + } + + if {$::tcl_platform(platform) eq "windows"} { + set dirPartRE {^(.*)[\\/]([^\\/]*)$} + } else { + set dirPartRE {^(.*)/([^/]*)$} + } + + set dir {} + set virtualdir {} + + while {$at < [llength $args]} { + switch -glob -- [set opt [lindex $args $at]] { + -nocomplain - -- - -tails { + lappend cmd $opt + set got($opt) 1 + incr at + } + -join { + set got($opt) 1 + incr at + } + -types - -type { + lappend cmd -types [lindex $args [incr at]] + incr at + } + -directory { + if {$got($opt)} { + return -code error \ + {"-directory" cannot be used with "-path"} + } + set got($opt) 1 + set virtualdir [lindex $args [incr at]] + incr at + } + -* { + Log $child "Safe base rejecting glob option '$opt'" + return -code error "Safe base rejecting glob option '$opt'" + } + default { + break + } + } + if {$got(--)} break + } + + # Get the real path from the virtual one and check that the path is in the + # access path of that child. Done after basic argument processing so that + # we know if -nocomplain is set. + if {$got(-directory)} { + try { + set dir [TranslatePath $child $virtualdir] + DirInAccessPath $child $dir + } on error msg { + Log $child $msg + if {$got(-nocomplain)} return + return -code error "permission denied" + } + if {$got(--)} { + set cmd [linsert $cmd end-1 -directory $dir] + } else { + lappend cmd -directory $dir + } + } else { + # The code after this "if ... else" block would conspire to return with + # no results in this case, if it were allowed to proceed. Instead, + # return now and reduce the number of cases to be considered later. + Log $child {option -directory must be supplied} + if {$got(-nocomplain)} return + return -code error "permission denied" + } + + # Apply the -join semantics ourselves. + if {$got(-join)} { + set args [lreplace $args $at end [join [lrange $args $at end] "/"]] + } + + # Process the pattern arguments. If we've done a join there is only one + # pattern argument. + + set firstPattern [llength $cmd] + foreach opt [lrange $args $at end] { + if {![regexp $dirPartRE $opt -> thedir thefile]} { + set thedir . + # The *.tm search comes here. + } + # "Special" treatment for (joined) argument {*/pkgIndex.tcl}. + # Do the expansion of "*" here, and filter out any directories that are + # not in the access path. The outcome is to lappend to cmd a path of + # the form $virtualdir/subdir/pkgIndex.tcl for each subdirectory subdir, + # after removing any subdir that are not in the access path. + if {($thedir eq "*") && ($thefile eq "pkgIndex.tcl")} { + set mapped 0 + foreach d [glob -directory [TranslatePath $child $virtualdir] \ + -types d -tails *] { + catch { + DirInAccessPath $child \ + [TranslatePath $child [file join $virtualdir $d]] + lappend cmd [file join $d $thefile] + set mapped 1 + } + } + if {$mapped} continue + # Don't [continue] if */pkgIndex.tcl has no matches in the access + # path. The pattern will now receive the same treatment as a + # "non-special" pattern (and will fail because it includes a "*" in + # the directory name). + } + # Any directory pattern that is not an exact (i.e. non-glob) match to a + # directory in the access path will be rejected here. + # - Rejections include any directory pattern that has glob matching + # patterns "*", "?", backslashes, braces or square brackets, (UNLESS + # it corresponds to a genuine directory name AND that directory is in + # the access path). + # - The only "special matching characters" that remain in patterns for + # processing by glob are in the filename tail. + # - [file join $anything ~${foo}] is ~${foo}, which is not an exact + # match to any directory in the access path. Hence directory patterns + # that begin with "~" are rejected here. Tests safe-16.[5-8] check + # that "file join" remains as required and does not expand ~${foo}. + # - Bug [3529949] relates to unwanted expansion of ~${foo} and this is + # how the present code avoids the bug. All tests safe-16.* relate. + try { + DirInAccessPath $child [TranslatePath $child \ + [file join $virtualdir $thedir]] + } on error msg { + Log $child $msg + if {$got(-nocomplain)} continue + return -code error "permission denied" + } + lappend cmd $opt + } + + Log $child "GLOB = $cmd" NOTICE + + if {$got(-nocomplain) && [llength $cmd] eq $firstPattern} { + return + } + try { + # >>>>>>>>>> HERE'S THE CALL TO SAFE INTERP GLOB <<<<<<<<<< + # - Pattern arguments added to cmd have NOT been translated from tokens. + # Only the virtualdir is translated (to dir). + # - In the pkgIndex.tcl case, there is no "*" in the pattern arguments, + # which are a list of names each with tail pkgIndex.tcl. The purpose + # of the call to glob is to remove the names for which the file does + # not exist. + set entries [::interp invokehidden $child glob {*}$cmd] + } on error msg { + # This is the only place that a call with -nocomplain and no invalid + # "dash-options" can return an error. + Log $child $msg + return -code error "script error" + } + + Log $child "GLOB < $entries" NOTICE + + # Translate path back to what the child should see. + set res {} + set l [string length $dir] + foreach p $entries { + if {[string equal -length $l $dir $p]} { + set p [string replace $p 0 [expr {$l-1}] $virtualdir] + } + lappend res $p + } + + Log $child "GLOB > $res" NOTICE + return $res +} + +# AliasSource is the target of the "source" alias in safe interpreters. + +proc ::safe::AliasSource {child args} { + set argc [llength $args] + # Extended for handling of Tcl Modules to allow not only "source + # filename", but "source -encoding E filename" as well. + if {[lindex $args 0] eq "-encoding"} { + incr argc -2 + set encoding [lindex $args 1] + set at 2 + if {$encoding eq "identity"} { + Log $child "attempt to use the identity encoding" + return -code error "permission denied" + } + } else { + set at 0 + set encoding {} + } + if {$argc != 1} { + set msg "wrong # args: should be \"source ?-encoding E? fileName\"" + Log $child "$msg ($args)" + return -code error $msg + } + set file [lindex $args $at] + + # get the real path from the virtual one. + if {[catch { + set realfile [TranslatePath $child $file] + } msg]} { + Log $child $msg + return -code error "permission denied" + } + + # check that the path is in the access path of that child + if {[catch { + FileInAccessPath $child $realfile + } msg]} { + Log $child $msg + return -code error "permission denied" + } + + # Check that the filename exists and is readable. If it is not, deliver + # this -errorcode so that caller in tclPkgUnknown does not write a message + # to tclLog. Has no effect on other callers of ::source, which are in + # "package ifneeded" scripts. + if {[catch { + CheckFileName $child $realfile + } msg]} { + Log $child "$realfile:$msg" + return -code error -errorcode {POSIX EACCES} $msg + } + + # Passed all the tests, lets source it. Note that we do this all manually + # because we want to control [info script] in the child so information + # doesn't leak so much. [Bug 2913625] + set old [::interp eval $child {info script}] + set replacementMsg "script error" + set code [catch { + set f [open $realfile] + fconfigure $f -eofchar \032 + if {$encoding ne ""} { + fconfigure $f -encoding $encoding + } + set contents [read $f] + close $f + ::interp eval $child [list info script $file] + } msg opt] + if {$code == 0} { + set code [catch {::interp eval $child $contents} msg opt] + set replacementMsg $msg + } + catch {interp eval $child [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 $child $msg + return -code error $replacementMsg + } + return -code $code -options $opt $msg +} + +# AliasLoad is the target of the "load" alias in safe interpreters. + +proc ::safe::AliasLoad {child file args} { + set argc [llength $args] + if {$argc > 2} { + set msg "load error: too many arguments" + Log $child "$msg ($argc) {$file $args}" + return -code error $msg + } + + # package name (can be empty if file is not). + set package [lindex $args 0] + + namespace upvar ::safe [VarName $child] state + + # Determine where to load. load use a relative interp path and {} + # means self, so we can directly and safely use passed arg. + set target [lindex $args 1] + if {$target ne ""} { + # we will try to load into a sub sub interp; check that we want to + # authorize that. + if {!$state(nestedok)} { + Log $child "loading to a sub interp (nestedok)\ + disabled (trying to load $package to $target)" + return -code error "permission denied (nested load)" + } + } + + # Determine what kind of load is requested + if {$file eq ""} { + # static package loading + if {$package eq ""} { + set msg "load error: empty filename and no package name" + Log $child $msg + return -code error $msg + } + if {!$state(staticsok)} { + Log $child "static packages loading disabled\ + (trying to load $package to $target)" + return -code error "permission denied (static package)" + } + } else { + # file loading + + # get the real path from the virtual one. + try { + set file [TranslatePath $child $file] + } on error msg { + Log $child $msg + return -code error "permission denied" + } + + # check the translated path + try { + FileInAccessPath $child $file + } on error msg { + Log $child $msg + return -code error "permission denied (path)" + } + } + + try { + return [::interp invokehidden $child load $file $package $target] + } on error msg { + # Some packages return no error message. + set msg0 "load of binary library for package $package failed" + if {$msg eq {}} { + set msg $msg0 + } else { + set msg "$msg0: $msg" + } + Log $child $msg + return -code error $msg + } +} + +# FileInAccessPath raises an error if the file is not found in the list of +# directories contained in the (parent side recorded) child's access path. + +# the security here relies on "file dirname" answering the proper +# result... needs checking ? +proc ::safe::FileInAccessPath {child file} { + namespace upvar ::safe [VarName $child] state + set access_path $state(access_path) + + if {[file isdirectory $file]} { + return -code error "\"$file\": is a directory" + } + set parent [file dirname $file] + + # Normalize paths for comparison since lsearch knows nothing of + # potential pathname anomalies. + set norm_parent [file normalize $parent] + + namespace upvar ::safe [VarName $child] state + if {$norm_parent ni $state(access_path,norm)} { + return -code error "\"$file\": not in access_path" + } +} + +proc ::safe::DirInAccessPath {child dir} { + namespace upvar ::safe [VarName $child] state + set access_path $state(access_path) + + if {[file isfile $dir]} { + return -code error "\"$dir\": is a file" + } + + # Normalize paths for comparison since lsearch knows nothing of + # potential pathname anomalies. + set norm_dir [file normalize $dir] + + namespace upvar ::safe [VarName $child] state + if {$norm_dir ni $state(access_path,norm)} { + return -code error "\"$dir\": not in access_path" + } +} + +# This procedure is used to report an attempt to use an unsafe member of an +# ensemble command. + +proc ::safe::BadSubcommand {child command subcommand args} { + set msg "not allowed to invoke subcommand $subcommand of $command" + Log $child $msg + return -code error -errorcode {TCL SAFE SUBCOMMAND} $msg +} + +# AliasEncoding is the target of the "encoding" alias in safe interpreters. + +proc ::safe::AliasEncoding {child option args} { + # Note that [encoding dirs] is not supported in safe children 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\"" + } + } on error {msg options} { + Log $child $msg + return -options $options $msg + } + tailcall ::interp invokehidden $child encoding $option {*}$args +} + +# Various minor hiding of platform features. [Bug 2913625] + +proc ::safe::AliasExeName {child} { + return "" +} + +# ------------------------------------------------------------------------------ +# Using Interpreter Names with Namespace Qualifiers +# ------------------------------------------------------------------------------ +# (1) We wish to preserve compatibility with existing code, in which Safe Base +# interpreter names have no namespace qualifiers. +# (2) safe::interpCreate and the rest of the Safe Base previously could not +# accept namespace qualifiers in an interpreter name. +# (3) The interp command will accept namespace qualifiers in an interpreter +# name, but accepts distinct interpreters that will have the same command +# name (e.g. foo, ::foo, and :::foo) (bug 66c2e8c974). +# (4) To satisfy these constraints, Safe Base interpreter names will be fully +# qualified namespace names with no excess colons and with the leading "::" +# omitted. +# (5) Trailing "::" implies a namespace tail {}, which interp reads as {{}}. +# Reject such names. +# (6) We could: +# (a) EITHER reject usable but non-compliant names (e.g. excess colons) in +# interpCreate, interpInit; +# (b) OR accept such names and then translate to a compliant name in every +# command. +# The problem with (b) is that the user will expect to use the name with the +# interp command and will find that it is not recognised. +# E.g "interpCreate ::foo" creates interpreter "foo", and the user's name +# "::foo" works with all the Safe Base commands, but "interp eval ::foo" +# fails. +# So we choose (a). +# (7) The command +# namespace upvar ::safe S$child state +# becomes +# namespace upvar ::safe [VarName $child] state +# ------------------------------------------------------------------------------ + +proc ::safe::RejectExcessColons {child} { + set stripped [regsub -all -- {:::*} $child ::] + if {[string range $stripped end-1 end] eq {::}} { + return -code error {interpreter name must not end in "::"} + } + if {$stripped ne $child} { + set msg {interpreter name has excess colons in namespace separators} + return -code error $msg + } + if {[string range $stripped 0 1] eq {::}} { + return -code error {interpreter name must not begin "::"} + } + return +} + +proc ::safe::VarName {child} { + # return S$child + return S[string map {:: @N @ @A} $child] +} + +proc ::safe::Setup {} { + #### + # + # Setup the arguments parsing + # + #### + + # Share the descriptions + set temp [::tcl::OptKeyRegister { + {-accessPath -list {} "access path for the slave"} + {-noStatics "prevent loading of statically linked pkgs"} + {-statics true "loading of statically linked pkgs"} + {-nestedLoadOk "allow nested loading"} + {-nested false "nested loading"} + {-deleteHook -script {} "delete hook"} + }] + + # create case (slave is optional) + ::tcl::OptKeyRegister { + {?slave? -name {} "name of the slave (optional)"} + } ::safe::interpCreate + + # adding the flags sub programs to the command program (relying on Opt's + # internal implementation details) + lappend ::tcl::OptDesc(::safe::interpCreate) $::tcl::OptDesc($temp) + + # init and configure (slave is needed) + ::tcl::OptKeyRegister { + {slave -name {} "name of the slave"} + } ::safe::interpIC + + # adding the flags sub programs to the command program (relying on Opt's + # internal implementation details) + lappend ::tcl::OptDesc(::safe::interpIC) $::tcl::OptDesc($temp) + + # temp not needed anymore + ::tcl::OptKeyDelete $temp + + #### + # + # Default: No logging. + # + #### + + setLogCmd {} + + # Log eventually. + # To enable error logging, set Log to {puts stderr} for instance, + # via setLogCmd. + return +} + +namespace eval ::safe { + # internal variables + + # Log command, set via 'setLogCmd'. Logging is disabled when empty. + variable Log {} + + # The package maintains a state array per child interp under its + # control. The name of this array is S. This array is + # brought into scope where needed, using 'namespace upvar'. The S + # prefix is used to avoid that a child interp called "Log" smashes + # the "Log" variable. + # + # The array's elements are: + # + # access_path : List of paths accessible to the child. + # access_path,norm : Ditto, in normalized form. + # access_path,slave : Ditto, as the path tokens as seen by the child. + # access_path,map : dict ( token -> path ) + # access_path,remap : dict ( path -> token ) + # tm_path_slave : List of TM root directories, as tokens seen by the child. + # staticsok : Value of option -statics + # nestedok : Value of option -nested + # cleanupHook : Value of option -deleteHook +} + +::safe::Setup diff --git a/XSchemWin/Installer/binary_template/lib/tcl8.6/tclIndex b/XSchemWin/Installer/binary_template/lib/tcl8.6/tclIndex new file mode 100644 index 00000000..0409d9b4 --- /dev/null +++ b/XSchemWin/Installer/binary_template/lib/tcl8.6/tclIndex @@ -0,0 +1,78 @@ +# 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 +# sets an element in the auto_index array, where the +# element name is the name of a command and the value is +# a script that loads the command. + +set auto_index(auto_reset) [list source [file join $dir auto.tcl]] +set auto_index(tcl_findLibrary) [list source [file join $dir auto.tcl]] +set auto_index(auto_mkindex) [list source [file join $dir auto.tcl]] +set auto_index(auto_mkindex_old) [list source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::init) [list source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::cleanup) [list source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::mkindex) [list source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::hook) [list source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::slavehook) [list source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::command) [list source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::commandInit) [list source [file join $dir auto.tcl]] +set auto_index(::auto_mkindex_parser::fullname) [list source [file join $dir auto.tcl]] +set auto_index(history) [list source [file join $dir history.tcl]] +set auto_index(::tcl::HistAdd) [list source [file join $dir history.tcl]] +set auto_index(::tcl::HistKeep) [list source [file join $dir history.tcl]] +set auto_index(::tcl::HistClear) [list source [file join $dir history.tcl]] +set auto_index(::tcl::HistInfo) [list source [file join $dir history.tcl]] +set auto_index(::tcl::HistRedo) [list source [file join $dir history.tcl]] +set auto_index(::tcl::HistIndex) [list source [file join $dir history.tcl]] +set auto_index(::tcl::HistEvent) [list source [file join $dir history.tcl]] +set auto_index(::tcl::HistChange) [list source [file join $dir history.tcl]] +set auto_index(pkg_mkIndex) [list source [file join $dir package.tcl]] +set auto_index(tclPkgSetup) [list source [file join $dir package.tcl]] +set auto_index(tclPkgUnknown) [list source [file join $dir package.tcl]] +set auto_index(::tcl::MacOSXPkgUnknown) [list source [file join $dir package.tcl]] +set auto_index(::pkg::create) [list source [file join $dir package.tcl]] +set auto_index(parray) [list source [file join $dir parray.tcl]] +set auto_index(::safe::InterpStatics) [list source [file join $dir safe.tcl]] +set auto_index(::safe::InterpNested) [list source [file join $dir safe.tcl]] +set auto_index(::safe::interpCreate) [list source [file join $dir safe.tcl]] +set auto_index(::safe::interpInit) [list source [file join $dir safe.tcl]] +set auto_index(::safe::CheckInterp) [list source [file join $dir safe.tcl]] +set auto_index(::safe::interpConfigure) [list source [file join $dir safe.tcl]] +set auto_index(::safe::InterpCreate) [list source [file join $dir safe.tcl]] +set auto_index(::safe::InterpSetConfig) [list source [file join $dir safe.tcl]] +set auto_index(::safe::interpFindInAccessPath) [list source [file join $dir safe.tcl]] +set auto_index(::safe::interpAddToAccessPath) [list source [file join $dir safe.tcl]] +set auto_index(::safe::InterpInit) [list source [file join $dir safe.tcl]] +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::PathToken) [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]] +set auto_index(tcl_wordBreakAfter) [list source [file join $dir word.tcl]] +set auto_index(tcl_wordBreakBefore) [list source [file join $dir word.tcl]] +set auto_index(tcl_endOfWord) [list source [file join $dir word.tcl]] +set auto_index(tcl_startOfNextWord) [list source [file join $dir word.tcl]] +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]] +if {[namespace exists ::tcl::unsupported]} { + set auto_index(timerate) {namespace import ::tcl::unsupported::timerate} +} diff --git a/XSchemWin/Installer/binary_template/lib/tcl8.6/tm.tcl b/XSchemWin/Installer/binary_template/lib/tcl8.6/tm.tcl new file mode 100644 index 00000000..c60084cc --- /dev/null +++ b/XSchemWin/Installer/binary_template/lib/tcl8.6/tm.tcl @@ -0,0 +1,380 @@ +# -*- 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. +# +# 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: +# +# - 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. +# +# 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. +# +# 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. +# +# We scan for regular packages only if no satisfying module was found. + +namespace eval ::tcl::tm { + # Default paths. None yet. + + variable paths {} + + # The regex pattern a file name has to match to make it a Tcl Module. + + set pkgpattern {^([_[:alpha:]][:_[:alnum:]]*)-([[:digit:]].*)[.]tm$} + + # Export the public API + + namespace export path + namespace ensemble create -command path -subcommands {add remove list} +} + +# ::tcl::tm::path implementations -- +# +# Public API to the module path. See specification. +# +# Arguments +# cmd - The subcommand to execute +# args - The paths to add/remove. Must not appear querying the +# path with 'list'. +# +# Results +# 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. + +proc ::tcl::tm::add {args} { + # PART OF THE ::tcl::tm::path ENSEMBLE + # + # The path is added at the head to the list of module paths. + # + # The command enforces the restriction that no path may be an ancestor + # directory of any other path on the list. If the new path violates this + # restriction an error wil be raised. + # + # 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. + + set newpaths $paths + foreach p $args { + if {$p in $newpaths} { + # Ignore a path already on the list. + continue + } + + # Search for paths which are subdirectories of the new one. If there + # are any then the new path violates the restriction about ancestors. + + set pos [lsearch -glob $newpaths ${p}/*] + # Cannot use "in", we need the position for the message. + if {$pos >= 0} { + return -code error \ + "$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 :( + + foreach ep $newpaths { + if {[string match ${ep}/* $p]} { + return -code error \ + "$p is subdirectory of existing module path $ep." + } + } + + 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. + + set paths $newpaths + return +} + +proc ::tcl::tm::remove {args} { + # PART OF THE ::tcl::tm::path ENSEMBLE + # + # Removes the path from the list of module paths. The command is silently + # ignored if the path is not on the list. + + variable paths + + foreach p $args { + set pos [lsearch -exact $paths $p] + if {$pos >= 0} { + set paths [lreplace $paths $pos $pos] + } + } +} + +proc ::tcl::tm::list {} { + # PART OF THE ::tcl::tm::path ENSEMBLE + + variable paths + return $paths +} + +# ::tcl::tm::UnknownHandler -- +# +# Unknown handler for Tcl Modules, i.e. packages in module form. +# +# Arguments +# original - Original [package unknown] procedure. +# name - Name of desired package. +# version - Version of desired package. Can be the +# 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. +# +# Results +# None. +# +# Sideeffects +# 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. + + variable paths + variable pkgpattern + + # Without paths to search we can do nothing. (Except falling back to the + # regular search). + + if {[llength $paths]} { + set pkgpath [string map {:: /} $name] + set pkgroot [file dirname $pkgpath] + if {$pkgroot eq "."} { + 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. + + set satisfied 0 + foreach path $paths { + if {![interp issafe] && ![file exists $path]} { + continue + } + set currentsearchpath [file join $path $pkgroot] + if {![interp issafe] && ![file exists $currentsearchpath]} { + continue + } + set strip [llength [file split $path]] + + # Get the module files out of the subdirectories. + # - Safe Base interpreters have a restricted "glob" command that + # works in this case. + # - The "catch" was essential when there was no safe glob and every + # call in a safe interp failed; it is retained only for corner + # cases in which the eventual call to glob returns an error. + + catch { + # We always look for _all_ possible modules in the current + # path, to get the max result out of the glob. + + foreach file [glob -nocomplain -directory $currentsearchpath *.tm] { + set pkgfilename [join [lrange [file split $file] $strip end] ::] + + if {![regexp -- $pkgpattern $pkgfilename --> pkgname pkgversion]} { + # 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". + continue + } + + if {([package ifneeded $pkgname $pkgversion] ne {}) + && (![interp issafe]) + } { + # There's already a provide script registered for + # this version of this package. Since all units of + # code claiming to be the same version of the same + # package ought to be identical, just stick with + # the one we already have. + # This does not apply to Safe Base interpreters because + # the token-to-directory mapping may have changed. + 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. + # + # 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. + + 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. + } + } + } + } + + if {$satisfied} { + return + } + } + + # Fallback to previous command, if existing. See comment above about + # ::list... + + if {[llength $original]} { + uplevel 1 $original [::linsert $args 0 $name] + } +} + +# ::tcl::tm::Defaults -- +# +# Determines the default search paths. +# +# Arguments +# None +# +# Results +# None. +# +# Sideeffects +# May add paths to the list of defaults. + +proc ::tcl::tm::Defaults {} { + global env tcl_platform + + regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor + set exe [file normalize [info nameofexecutable]] + + # Note that we're using [::list], not [list] because [list] means + # something other than [::list] in this namespace. + roots [::list \ + [file dirname [info library]] \ + [file join [file dirname [file dirname $exe]] lib] \ + ] + + if {$tcl_platform(platform) eq "windows"} { + set sep ";" + } else { + set sep ":" + } + for {set n $minor} {$n >= 0} {incr n -1} { + foreach ev [::list \ + TCL${major}.${n}_TM_PATH \ + TCL${major}_${n}_TM_PATH \ + ] { + if {![info exists env($ev)]} continue + foreach p [split $env($ev) $sep] { + path add $p + } + } + } + return +} + +# ::tcl::tm::roots -- +# +# Public API to the module path. See specification. +# +# Arguments +# paths - List of 'root' paths to derive search paths from. +# +# Results +# No result. +# +# Sideeffects +# Calls 'path add' to paths to the list of module search paths. + +proc ::tcl::tm::roots {paths} { + regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor + foreach pa $paths { + set p [file join $pa tcl$major] + for {set n $minor} {$n >= 0} {incr n -1} { + set px [file join $p ${major}.${n}] + if {![interp issafe]} {set px [file normalize $px]} + path add $px + } + set px [file join $p site-tcl] + 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. + +if {![interp issafe]} {::tcl::tm::Defaults} diff --git a/XSchemWin/Installer/binary_template/lib/tcl8.6/word.tcl b/XSchemWin/Installer/binary_template/lib/tcl8.6/word.tcl new file mode 100644 index 00000000..828f13ab --- /dev/null +++ b/XSchemWin/Installer/binary_template/lib/tcl8.6/word.tcl @@ -0,0 +1,154 @@ +# word.tcl -- +# +# This file defines various procedures for computing word boundaries in +# strings. This file is primarily needed so Tk text and entry widgets behave +# properly for different platforms. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# Copyright (c) 1998 Scritpics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# The following variables are used to determine which characters are +# interpreted as white space. + +if {$::tcl_platform(platform) eq "windows"} { + # Windows style - any but a unicode space char + if {![info exists ::tcl_wordchars]} { + set ::tcl_wordchars {\S} + } + if {![info exists ::tcl_nonwordchars]} { + set ::tcl_nonwordchars {\s} + } +} else { + # Motif style - any unicode word char (number, letter, or underscore) + if {![info exists ::tcl_wordchars]} { + set ::tcl_wordchars {\w} + } + if {![info exists ::tcl_nonwordchars]} { + set ::tcl_nonwordchars {\W} + } +} + +# Arrange for caches of the real matcher REs to be kept, which enables the REs +# themselves to be cached for greater performance (and somewhat greater +# clarity too). + +namespace eval ::tcl { + variable WordBreakRE + array set WordBreakRE {} + + proc UpdateWordBreakREs args { + # Ignores the arguments + global tcl_wordchars tcl_nonwordchars + variable WordBreakRE + + # To keep the RE strings short... + set letter $tcl_wordchars + set space $tcl_nonwordchars + + set WordBreakRE(after) "$letter$space|$space$letter" + set WordBreakRE(before) "^.*($letter$space|$space$letter)" + set WordBreakRE(end) "$space*$letter+$space" + set WordBreakRE(next) "$letter*$space+$letter" + set WordBreakRE(previous) "$space*($letter+)$space*\$" + } + + # Initialize the cache + UpdateWordBreakREs + trace add variable ::tcl_wordchars write ::tcl::UpdateWordBreakREs + trace add variable ::tcl_nonwordchars write ::tcl::UpdateWordBreakREs +} + +# tcl_wordBreakAfter -- +# +# This procedure returns the index of the first word boundary after the +# starting point in the given string, or -1 if there are no more boundaries in +# the given string. The index returned refers to the first character of the +# pair that comprises a boundary. +# +# Arguments: +# str - String to search. +# start - Index into string specifying starting point. + +proc tcl_wordBreakAfter {str start} { + variable ::tcl::WordBreakRE + set result {-1 -1} + regexp -indices -start $start -- $WordBreakRE(after) $str result + return [lindex $result 1] +} + +# tcl_wordBreakBefore -- +# +# This procedure returns the index of the first word boundary before the +# starting point in the given string, or -1 if there are no more boundaries in +# the given string. The index returned refers to the second character of the +# pair that comprises a boundary. +# +# Arguments: +# str - String to search. +# start - Index into string specifying starting point. + +proc tcl_wordBreakBefore {str start} { + variable ::tcl::WordBreakRE + set result {-1 -1} + regexp -indices -- $WordBreakRE(before) [string range $str 0 $start] result + return [lindex $result 1] +} + +# tcl_endOfWord -- +# +# This procedure returns the index of the first end-of-word location after a +# starting index in the given string. An end-of-word location is defined to be +# the first whitespace character following the first non-whitespace character +# after the starting point. Returns -1 if there are no more words after the +# starting point. +# +# Arguments: +# str - String to search. +# start - Index into string specifying starting point. + +proc tcl_endOfWord {str start} { + variable ::tcl::WordBreakRE + set result {-1 -1} + regexp -indices -start $start -- $WordBreakRE(end) $str result + return [lindex $result 1] +} + +# tcl_startOfNextWord -- +# +# This procedure returns the index of the first start-of-word location after a +# starting index in the given string. A start-of-word location is defined to +# be a non-whitespace character following a whitespace character. Returns -1 +# if there are no more start-of-word locations after the starting point. +# +# Arguments: +# str - String to search. +# start - Index into string specifying starting point. + +proc tcl_startOfNextWord {str start} { + variable ::tcl::WordBreakRE + set result {-1 -1} + regexp -indices -start $start -- $WordBreakRE(next) $str result + return [lindex $result 1] +} + +# tcl_startOfPreviousWord -- +# +# This procedure returns the index of the first start-of-word location before +# a starting index in the given string. +# +# Arguments: +# str - String to search. +# start - Index into string specifying starting point. + +proc tcl_startOfPreviousWord {str start} { + variable ::tcl::WordBreakRE + set word {-1 -1} + if {$start > 0} { + regexp -indices -- $WordBreakRE(previous) [string range $str 0 $start-1] \ + result word + } + return [lindex $word 0] +} diff --git a/XSchemWin/Installer/binary_template/lib/tk8.6/bgerror.tcl b/XSchemWin/Installer/binary_template/lib/tk8.6/bgerror.tcl new file mode 100644 index 00000000..fe8dfe04 --- /dev/null +++ b/XSchemWin/Installer/binary_template/lib/tk8.6/bgerror.tcl @@ -0,0 +1,272 @@ +# bgerror.tcl -- +# +# Implementation of the bgerror procedure. It posts a dialog box with +# the error message and gives the user a chance to see a more detailed +# stack trace, and possible do something more interesting with that +# trace (like save it to a log). This is adapted from work done by +# Donal K. Fellows. +# +# Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2007 by ActiveState Software Inc. +# Copyright (c) 2007 Daniel A. Steffen +# Copyright (c) 2009 Pat Thoyts + +namespace eval ::tk::dialog::error { + namespace import -force ::tk::msgcat::* + namespace export bgerror + option add *ErrorDialog.function.text [mc "Save To Log"] \ + widgetDefault + option add *ErrorDialog.function.command [namespace code SaveToLog] + option add *ErrorDialog*Label.font TkCaptionFont widgetDefault + if {[tk windowingsystem] eq "aqua"} { + option add *ErrorDialog*background systemAlertBackgroundActive \ + widgetDefault + option add *ErrorDialog*info.text.background \ + systemTextBackgroundColor widgetDefault + option add *ErrorDialog*Button.highlightBackground \ + systemAlertBackgroundActive widgetDefault + } +} + +proc ::tk::dialog::error::Return {which code} { + variable button + + .bgerrorDialog.$which state {active selected focus} + update idletasks + after 100 + set button $code +} + +proc ::tk::dialog::error::Details {} { + set w .bgerrorDialog + set caption [option get $w.function text {}] + set command [option get $w.function command {}] + if {($caption eq "") || ($command eq "")} { + grid forget $w.function + } + lappend command [$w.top.info.text get 1.0 end-1c] + $w.function configure -text $caption -command $command + grid $w.top.info - -sticky nsew -padx 3m -pady 3m +} + +proc ::tk::dialog::error::SaveToLog {text} { + if {$::tcl_platform(platform) eq "windows"} { + set allFiles *.* + } else { + set allFiles * + } + set types [list \ + [list [mc "Log Files"] .log] \ + [list [mc "Text Files"] .txt] \ + [list [mc "All Files"] $allFiles] \ + ] + set filename [tk_getSaveFile -title [mc "Select Log File"] \ + -filetypes $types -defaultextension .log -parent .bgerrorDialog] + if {$filename ne {}} { + set f [open $filename w] + puts -nonewline $f $text + close $f + } + return +} + +proc ::tk::dialog::error::Destroy {w} { + if {$w eq ".bgerrorDialog"} { + variable button + set button -1 + } +} + +proc ::tk::dialog::error::DeleteByProtocol {} { + variable button + set button 1 +} + +proc ::tk::dialog::error::ReturnInDetails w { + bind $w {}; # Remove this binding + $w invoke + return -code break +} + +# ::tk::dialog::error::bgerror -- +# +# This is the default version of bgerror. +# It tries to execute tkerror, if that fails it posts a dialog box +# containing the error message and gives the user a chance to ask +# to see a stack trace. +# +# Arguments: +# err - The error message. +# +proc ::tk::dialog::error::bgerror {err {flag 1}} { + global errorInfo + variable button + + set info $errorInfo + + set ret [catch {::tkerror $err} msg]; + if {$ret != 1} {return -code $ret $msg} + + # The application's tkerror either failed or was not found + # so we use the default dialog. But on Aqua we cannot display + # the dialog if the background error occurs in an idle task + # being processed inside of [NSView drawRect]. In that case + # we post the dialog as an after task instead. + set windowingsystem [tk windowingsystem] + if {$windowingsystem eq "aqua"} { + if $flag { + set errorInfo $info + after 500 [list bgerror "$err" 0] + return + } + } + + set ok [mc OK] + # Truncate the message if it is too wide (>maxLine characters) or + # too tall (>4 lines). Truncation occurs at the first point at + # which one of those conditions is met. + set displayedErr "" + set lines 0 + set maxLine 45 + foreach line [split $err \n] { + if {[string length $line] > $maxLine} { + append displayedErr "[string range $line 0 $maxLine-3]..." + break + } + if {$lines > 4} { + append displayedErr "..." + break + } else { + append displayedErr "${line}\n" + } + incr lines + } + + set title [mc "Application Error"] + set text [mc "Error: %1\$s" $displayedErr] + set buttons [list ok $ok dismiss [mc "Skip Messages"] \ + function [mc "Details >>"]] + + # 1. Create the top-level window and divide it into top + # and bottom parts. + + set dlg .bgerrorDialog + set bg [ttk::style lookup . -background] + destroy $dlg + toplevel $dlg -class ErrorDialog -background $bg + wm withdraw $dlg + wm title $dlg $title + wm iconname $dlg ErrorDialog + wm protocol $dlg WM_DELETE_WINDOW [namespace code DeleteByProtocol] + + if {$windowingsystem eq "aqua"} { + ::tk::unsupported::MacWindowStyle style $dlg moveableAlert {} + } elseif {$windowingsystem eq "x11"} { + wm attributes $dlg -type dialog + } + + ttk::frame $dlg.bot + ttk::frame $dlg.top + pack $dlg.bot -side bottom -fill both + pack $dlg.top -side top -fill both -expand 1 + + set W [ttk::frame $dlg.top.info] + text $W.text -setgrid true -height 10 -wrap char \ + -yscrollcommand [list $W.scroll set] + if {$windowingsystem ne "aqua"} { + $W.text configure -width 40 + } + + ttk::scrollbar $W.scroll -command [list $W.text yview] + pack $W.scroll -side right -fill y + pack $W.text -side left -expand yes -fill both + $W.text insert 0.0 "$err\n$info" + $W.text mark set insert 0.0 + bind $W.text {focus %W} + $W.text configure -state disabled + + # 2. Fill the top part with bitmap and message + + # Max-width of message is the width of the screen... + set wrapwidth [winfo screenwidth $dlg] + # ...minus the width of the icon, padding and a fudge factor for + # the window manager decorations and aesthetics. + set wrapwidth [expr {$wrapwidth-60-[winfo pixels $dlg 9m]}] + ttk::label $dlg.msg -justify left -text $text -wraplength $wrapwidth + ttk::label $dlg.bitmap -image ::tk::icons::error + + grid $dlg.bitmap $dlg.msg -in $dlg.top -row 0 -padx 3m -pady 3m + grid configure $dlg.bitmap -sticky ne + grid configure $dlg.msg -sticky nsw -padx {0 3m} + grid rowconfigure $dlg.top 1 -weight 1 + grid columnconfigure $dlg.top 1 -weight 1 + + # 3. Create a row of buttons at the bottom of the dialog. + + set i 0 + foreach {name caption} $buttons { + ttk::button $dlg.$name -text $caption -default normal \ + -command [namespace code [list set button $i]] + grid $dlg.$name -in $dlg.bot -column $i -row 0 -sticky ew -padx 10 + grid columnconfigure $dlg.bot $i -weight 1 + # We boost the size of some Mac buttons for l&f + if {$windowingsystem eq "aqua"} { + if {($name eq "ok") || ($name eq "dismiss")} { + grid columnconfigure $dlg.bot $i -minsize 90 + } + grid configure $dlg.$name -pady 7 + } + incr i + } + # The "OK" button is the default for this dialog. + $dlg.ok configure -default active + + bind $dlg [namespace code {Return ok 0}] + bind $dlg [namespace code {Return dismiss 1}] + bind $dlg [namespace code {Destroy %W}] + bind $dlg.function [namespace code {ReturnInDetails %W}] + $dlg.function configure -command [namespace code Details] + + # 6. Withdraw the window, then update all the geometry information + # so we know how big it wants to be, then center the window in the + # display (Motif style) and de-iconify it. + + ::tk::PlaceWindow $dlg + + # 7. Set a grab and claim the focus too. + + ::tk::SetFocusGrab $dlg $dlg.ok + + # 8. Ensure that we are topmost. + + raise $dlg + if {[tk windowingsystem] eq "win32"} { + # Place it topmost if we aren't at the top of the stacking + # order to ensure that it's seen + if {[lindex [wm stackorder .] end] ne "$dlg"} { + wm attributes $dlg -topmost 1 + } + } + + # 9. Wait for the user to respond, then restore the focus and + # return the index of the selected button. Restore the focus + # before deleting the window, since otherwise the window manager + # may take the focus away so we can't redirect it. Finally, + # restore any grab that was in effect. + + vwait [namespace which -variable button] + set copy $button; # Save a copy... + + ::tk::RestoreFocusGrab $dlg $dlg.ok destroy + + if {$copy == 1} { + return -code break + } +} + +namespace eval :: { + # Fool the indexer + proc bgerror err {} + rename bgerror {} + namespace import ::tk::dialog::error::bgerror +} diff --git a/XSchemWin/Installer/binary_template/lib/tk8.6/button.tcl b/XSchemWin/Installer/binary_template/lib/tk8.6/button.tcl new file mode 100644 index 00000000..9b136077 --- /dev/null +++ b/XSchemWin/Installer/binary_template/lib/tk8.6/button.tcl @@ -0,0 +1,782 @@ +# button.tcl -- +# +# This file defines the default bindings for Tk label, button, +# checkbutton, and radiobutton widgets and provides procedures +# that help in implementing those bindings. +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 2002 ActiveState Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +#------------------------------------------------------------------------- +# The code below creates the default class bindings for buttons. +#------------------------------------------------------------------------- + +if {[tk windowingsystem] eq "aqua"} { + + bind Radiobutton { + tk::ButtonEnter %W + } + bind Radiobutton <1> { + tk::ButtonDown %W + } + bind Radiobutton { + tk::ButtonUp %W + } + bind Checkbutton { + tk::ButtonEnter %W + } + bind Checkbutton <1> { + tk::ButtonDown %W + } + bind Checkbutton { + tk::ButtonUp %W + } + bind Checkbutton { + tk::ButtonLeave %W + } +} +if {"win32" eq [tk windowingsystem]} { + bind Checkbutton { + tk::CheckRadioInvoke %W select + } + bind Checkbutton { + tk::CheckRadioInvoke %W select + } + bind Checkbutton { + tk::CheckRadioInvoke %W deselect + } + bind Checkbutton <1> { + tk::CheckRadioDown %W + } + bind Checkbutton { + tk::ButtonUp %W + } + bind Checkbutton { + tk::CheckRadioEnter %W + } + bind Checkbutton { + tk::ButtonLeave %W + } + + bind Radiobutton <1> { + tk::CheckRadioDown %W + } + bind Radiobutton { + tk::ButtonUp %W + } + bind Radiobutton { + tk::CheckRadioEnter %W + } +} +if {"x11" eq [tk windowingsystem]} { + bind Checkbutton { + if {!$tk_strictMotif} { + tk::CheckInvoke %W + } + } + bind Radiobutton { + if {!$tk_strictMotif} { + tk::CheckRadioInvoke %W + } + } + bind Checkbutton <1> { + tk::CheckInvoke %W + } + bind Radiobutton <1> { + tk::CheckRadioInvoke %W + } + bind Checkbutton { + tk::CheckEnter %W + } + bind Radiobutton { + tk::ButtonEnter %W + } + bind Checkbutton { + tk::CheckLeave %W + } +} + +bind Button { + tk::ButtonInvoke %W +} +bind Checkbutton { + tk::CheckRadioInvoke %W +} +bind Radiobutton { + tk::CheckRadioInvoke %W +} +bind Button <> { + tk::ButtonInvoke %W +} +bind Checkbutton <> { + tk::CheckRadioInvoke %W +} +bind Radiobutton <> { + tk::CheckRadioInvoke %W +} + +bind Button {} +bind Button { + tk::ButtonEnter %W +} +bind Button { + tk::ButtonLeave %W +} +bind Button <1> { + tk::ButtonDown %W +} +bind Button { + tk::ButtonUp %W +} + +bind Checkbutton {} + +bind Radiobutton {} +bind Radiobutton { + tk::ButtonLeave %W +} + +if {"win32" eq [tk windowingsystem]} { + +######################### +# Windows implementation +######################### + +# ::tk::ButtonEnter -- +# The procedure below is invoked when the mouse pointer enters a +# button widget. It records the button we're in and changes the +# state of the button to active unless the button is disabled. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::ButtonEnter w { + variable ::tk::Priv + if {[$w cget -state] ne "disabled"} { + + # If the mouse button is down, set the relief to sunken on entry. + # Overwise, if there's an -overrelief value, set the relief to that. + + set Priv($w,relief) [$w cget -relief] + if {$Priv(buttonWindow) eq $w} { + $w configure -relief sunken -state active + set Priv($w,prelief) sunken + } elseif {[set over [$w cget -overrelief]] ne ""} { + $w configure -relief $over + set Priv($w,prelief) $over + } + } + set Priv(window) $w +} + +# ::tk::ButtonLeave -- +# The procedure below is invoked when the mouse pointer leaves a +# button widget. It changes the state of the button back to inactive. +# Restore any modified relief too. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::ButtonLeave w { + variable ::tk::Priv + if {[$w cget -state] ne "disabled"} { + $w configure -state normal + } + + # Restore the original button relief if it was changed by Tk. + # That is signaled by the existence of Priv($w,prelief). + + if {[info exists Priv($w,relief)]} { + if {[info exists Priv($w,prelief)] && \ + $Priv($w,prelief) eq [$w cget -relief]} { + $w configure -relief $Priv($w,relief) + } + unset -nocomplain Priv($w,relief) Priv($w,prelief) + } + + set Priv(window) "" +} + +# ::tk::ButtonDown -- +# The procedure below is invoked when the mouse button is pressed in +# a button widget. It records the fact that the mouse is in the button, +# saves the button's relief so it can be restored later, and changes +# the relief to sunken. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::ButtonDown w { + variable ::tk::Priv + + # Only save the button's relief if it does not yet exist. If there + # is an overrelief setting, Priv($w,relief) will already have been set, + # and the current value of the -relief option will be incorrect. + + if {![info exists Priv($w,relief)]} { + set Priv($w,relief) [$w cget -relief] + } + + if {[$w cget -state] ne "disabled"} { + set Priv(buttonWindow) $w + $w configure -relief sunken -state active + set Priv($w,prelief) sunken + + # If this button has a repeatdelay set up, get it going with an after + after cancel $Priv(afterId) + set delay [$w cget -repeatdelay] + set Priv(repeated) 0 + if {$delay > 0} { + set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]] + } + } +} + +# ::tk::ButtonUp -- +# The procedure below is invoked when the mouse button is released +# in a button widget. It restores the button's relief and invokes +# the command as long as the mouse hasn't left the button. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::ButtonUp w { + variable ::tk::Priv + if {$Priv(buttonWindow) eq $w} { + set Priv(buttonWindow) "" + + # Restore the button's relief if it was cached. + + if {[info exists Priv($w,relief)]} { + if {[info exists Priv($w,prelief)] && \ + $Priv($w,prelief) eq [$w cget -relief]} { + $w configure -relief $Priv($w,relief) + } + unset -nocomplain Priv($w,relief) Priv($w,prelief) + } + + # Clean up the after event from the auto-repeater + after cancel $Priv(afterId) + + if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} { + $w configure -state normal + + # Only invoke the command if it wasn't already invoked by the + # auto-repeater functionality + if { $Priv(repeated) == 0 } { + uplevel #0 [list $w invoke] + } + } + } +} + +# ::tk::CheckRadioEnter -- +# The procedure below is invoked when the mouse pointer enters a +# checkbutton or radiobutton widget. It records the button we're in +# and changes the state of the button to active unless the button is +# disabled. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::CheckRadioEnter w { + variable ::tk::Priv + if {[$w cget -state] ne "disabled"} { + if {$Priv(buttonWindow) eq $w} { + $w configure -state active + } + if {[set over [$w cget -overrelief]] ne ""} { + set Priv($w,relief) [$w cget -relief] + set Priv($w,prelief) $over + $w configure -relief $over + } + } + set Priv(window) $w +} + +# ::tk::CheckRadioDown -- +# The procedure below is invoked when the mouse button is pressed in +# a button widget. It records the fact that the mouse is in the button, +# saves the button's relief so it can be restored later, and changes +# the relief to sunken. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::CheckRadioDown w { + variable ::tk::Priv + if {![info exists Priv($w,relief)]} { + set Priv($w,relief) [$w cget -relief] + } + if {[$w cget -state] ne "disabled"} { + set Priv(buttonWindow) $w + set Priv(repeated) 0 + $w configure -state active + } +} + +} + +if {"x11" eq [tk windowingsystem]} { + +##################### +# Unix implementation +##################### + +# ::tk::ButtonEnter -- +# The procedure below is invoked when the mouse pointer enters a +# button widget. It records the button we're in and changes the +# state of the button to active unless the button is disabled. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::ButtonEnter {w} { + variable ::tk::Priv + if {[$w cget -state] ne "disabled"} { + # On unix the state is active just with mouse-over + $w configure -state active + + # If the mouse button is down, set the relief to sunken on entry. + # Overwise, if there's an -overrelief value, set the relief to that. + + set Priv($w,relief) [$w cget -relief] + if {$Priv(buttonWindow) eq $w} { + $w configure -relief sunken + set Priv($w,prelief) sunken + } elseif {[set over [$w cget -overrelief]] ne ""} { + $w configure -relief $over + set Priv($w,prelief) $over + } + } + set Priv(window) $w +} + +# ::tk::ButtonLeave -- +# The procedure below is invoked when the mouse pointer leaves a +# button widget. It changes the state of the button back to inactive. +# Restore any modified relief too. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::ButtonLeave w { + variable ::tk::Priv + if {[$w cget -state] ne "disabled"} { + $w configure -state normal + } + + # Restore the original button relief if it was changed by Tk. + # That is signaled by the existence of Priv($w,prelief). + + if {[info exists Priv($w,relief)]} { + if {[info exists Priv($w,prelief)] && \ + $Priv($w,prelief) eq [$w cget -relief]} { + $w configure -relief $Priv($w,relief) + } + unset -nocomplain Priv($w,relief) Priv($w,prelief) + } + + set Priv(window) "" +} + +# ::tk::ButtonDown -- +# The procedure below is invoked when the mouse button is pressed in +# a button widget. It records the fact that the mouse is in the button, +# saves the button's relief so it can be restored later, and changes +# the relief to sunken. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::ButtonDown w { + variable ::tk::Priv + + # Only save the button's relief if it does not yet exist. If there + # is an overrelief setting, Priv($w,relief) will already have been set, + # and the current value of the -relief option will be incorrect. + + if {![info exists Priv($w,relief)]} { + set Priv($w,relief) [$w cget -relief] + } + + if {[$w cget -state] ne "disabled"} { + set Priv(buttonWindow) $w + $w configure -relief sunken + set Priv($w,prelief) sunken + + # If this button has a repeatdelay set up, get it going with an after + after cancel $Priv(afterId) + set delay [$w cget -repeatdelay] + set Priv(repeated) 0 + if {$delay > 0} { + set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]] + } + } +} + +# ::tk::ButtonUp -- +# The procedure below is invoked when the mouse button is released +# in a button widget. It restores the button's relief and invokes +# the command as long as the mouse hasn't left the button. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::ButtonUp w { + variable ::tk::Priv + if {$w eq $Priv(buttonWindow)} { + set Priv(buttonWindow) "" + + # Restore the button's relief if it was cached. + + if {[info exists Priv($w,relief)]} { + if {[info exists Priv($w,prelief)] && \ + $Priv($w,prelief) eq [$w cget -relief]} { + $w configure -relief $Priv($w,relief) + } + unset -nocomplain Priv($w,relief) Priv($w,prelief) + } + + # Clean up the after event from the auto-repeater + after cancel $Priv(afterId) + + if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} { + # Only invoke the command if it wasn't already invoked by the + # auto-repeater functionality + if { $Priv(repeated) == 0 } { + uplevel #0 [list $w invoke] + } + } + } +} + +} + +if {[tk windowingsystem] eq "aqua"} { + +#################### +# Mac implementation +#################### + +# ::tk::ButtonEnter -- +# The procedure below is invoked when the mouse pointer enters a +# button widget. It records the button we're in and changes the +# state of the button to active unless the button is disabled. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::ButtonEnter {w} { + variable ::tk::Priv + if {[$w cget -state] ne "disabled"} { + + # If there's an -overrelief value, set the relief to that. + + if {$Priv(buttonWindow) eq $w} { + $w configure -state active + } elseif {[set over [$w cget -overrelief]] ne ""} { + set Priv($w,relief) [$w cget -relief] + set Priv($w,prelief) $over + $w configure -relief $over + } + } + set Priv(window) $w +} + +# ::tk::ButtonLeave -- +# The procedure below is invoked when the mouse pointer leaves a +# button widget. It changes the state of the button back to +# inactive. If we're leaving the button window with a mouse button +# pressed (Priv(buttonWindow) == $w), restore the relief of the +# button too. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::ButtonLeave w { + variable ::tk::Priv + if {$w eq $Priv(buttonWindow)} { + $w configure -state normal + } + + # Restore the original button relief if it was changed by Tk. + # That is signaled by the existence of Priv($w,prelief). + + if {[info exists Priv($w,relief)]} { + if {[info exists Priv($w,prelief)] && \ + $Priv($w,prelief) eq [$w cget -relief]} { + $w configure -relief $Priv($w,relief) + } + unset -nocomplain Priv($w,relief) Priv($w,prelief) + } + + set Priv(window) "" +} + +# ::tk::ButtonDown -- +# The procedure below is invoked when the mouse button is pressed in +# a button widget. It records the fact that the mouse is in the button, +# saves the button's relief so it can be restored later, and changes +# the relief to sunken. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::ButtonDown w { + variable ::tk::Priv + + if {[$w cget -state] ne "disabled"} { + set Priv(buttonWindow) $w + $w configure -state active + + # If this button has a repeatdelay set up, get it going with an after + after cancel $Priv(afterId) + set Priv(repeated) 0 + if { ![catch {$w cget -repeatdelay} delay] } { + if {$delay > 0} { + set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]] + } + } + } +} + +# ::tk::ButtonUp -- +# The procedure below is invoked when the mouse button is released +# in a button widget. It restores the button's relief and invokes +# the command as long as the mouse hasn't left the button. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::ButtonUp w { + variable ::tk::Priv + if {$Priv(buttonWindow) eq $w} { + set Priv(buttonWindow) "" + $w configure -state normal + + # Restore the button's relief if it was cached. + + if {[info exists Priv($w,relief)]} { + if {[info exists Priv($w,prelief)] && \ + $Priv($w,prelief) eq [$w cget -relief]} { + $w configure -relief $Priv($w,relief) + } + unset -nocomplain Priv($w,relief) Priv($w,prelief) + } + + # Clean up the after event from the auto-repeater + after cancel $Priv(afterId) + + if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} { + # Only invoke the command if it wasn't already invoked by the + # auto-repeater functionality + if { $Priv(repeated) == 0 } { + uplevel #0 [list $w invoke] + } + } + } +} + +} + +################## +# Shared routines +################## + +# ::tk::ButtonInvoke -- +# The procedure below is called when a button is invoked through +# the keyboard. It simulate a press of the button via the mouse. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::ButtonInvoke w { + if {[winfo exists $w] && [$w cget -state] ne "disabled"} { + set oldRelief [$w cget -relief] + set oldState [$w cget -state] + $w configure -state active -relief sunken + after 100 [list ::tk::ButtonInvokeEnd $w $oldState $oldRelief] + } +} + +# ::tk::ButtonInvokeEnd -- +# The procedure below is called after a button is invoked through +# the keyboard. It simulate a release of the button via the mouse. +# +# Arguments: +# w - The name of the widget. +# oldState - Old state to be set back. +# oldRelief - Old relief to be set back. + +proc ::tk::ButtonInvokeEnd {w oldState oldRelief} { + if {[winfo exists $w]} { + $w configure -state $oldState -relief $oldRelief + uplevel #0 [list $w invoke] + } +} + +# ::tk::ButtonAutoInvoke -- +# +# Invoke an auto-repeating button, and set it up to continue to repeat. +# +# Arguments: +# w button to invoke. +# +# Results: +# None. +# +# Side effects: +# May create an after event to call ::tk::ButtonAutoInvoke. + +proc ::tk::ButtonAutoInvoke {w} { + variable ::tk::Priv + after cancel $Priv(afterId) + set delay [$w cget -repeatinterval] + if {$Priv(window) eq $w} { + incr Priv(repeated) + uplevel #0 [list $w invoke] + } + if {$delay > 0} { + set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]] + } +} + +# ::tk::CheckRadioInvoke -- +# The procedure below is invoked when the mouse button is pressed in +# a checkbutton or radiobutton widget, or when the widget is invoked +# through the keyboard. It invokes the widget if it +# isn't disabled. +# +# Arguments: +# w - The name of the widget. +# cmd - The subcommand to invoke (one of invoke, select, or deselect). + +proc ::tk::CheckRadioInvoke {w {cmd invoke}} { + if {[$w cget -state] ne "disabled"} { + uplevel #0 [list $w $cmd] + } +} + +# Special versions of the handlers for checkbuttons on Unix that do the magic +# to make things work right when the checkbutton indicator is hidden; +# radiobuttons don't need this complexity. + +# ::tk::CheckInvoke -- +# The procedure below invokes the checkbutton, like ButtonInvoke, but handles +# what to do when the checkbutton indicator is missing. Only used on Unix. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::CheckInvoke {w} { + variable ::tk::Priv + if {[$w cget -state] ne "disabled"} { + # Additional logic to switch the "selected" colors around if necessary + # (when we're indicator-less). + + if {![$w cget -indicatoron] && [info exist Priv($w,selectcolor)]} { + if {[$w cget -selectcolor] eq $Priv($w,aselectcolor)} { + $w configure -selectcolor $Priv($w,selectcolor) + } else { + $w configure -selectcolor $Priv($w,aselectcolor) + } + } + uplevel #0 [list $w invoke] + } +} + +# ::tk::CheckEnter -- +# The procedure below enters the checkbutton, like ButtonEnter, but handles +# what to do when the checkbutton indicator is missing. Only used on Unix. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::CheckEnter {w} { + variable ::tk::Priv + if {[$w cget -state] ne "disabled"} { + # On unix the state is active just with mouse-over + $w configure -state active + + # If the mouse button is down, set the relief to sunken on entry. + # Overwise, if there's an -overrelief value, set the relief to that. + + set Priv($w,relief) [$w cget -relief] + if {$Priv(buttonWindow) eq $w} { + $w configure -relief sunken + set Priv($w,prelief) sunken + } elseif {[set over [$w cget -overrelief]] ne ""} { + $w configure -relief $over + set Priv($w,prelief) $over + } + + # Compute what the "selected and active" color should be. + + if {![$w cget -indicatoron] && [$w cget -selectcolor] ne ""} { + set Priv($w,selectcolor) [$w cget -selectcolor] + lassign [winfo rgb $w [$w cget -selectcolor]] r1 g1 b1 + lassign [winfo rgb $w [$w cget -activebackground]] r2 g2 b2 + set Priv($w,aselectcolor) \ + [format "#%04x%04x%04x" [expr {($r1+$r2)/2}] \ + [expr {($g1+$g2)/2}] [expr {($b1+$b2)/2}]] + # use uplevel to work with other var resolvers + if {[uplevel #0 [list set [$w cget -variable]]] + eq [$w cget -onvalue]} { + $w configure -selectcolor $Priv($w,aselectcolor) + } + } + } + set Priv(window) $w +} + +# ::tk::CheckLeave -- +# The procedure below leaves the checkbutton, like ButtonLeave, but handles +# what to do when the checkbutton indicator is missing. Only used on Unix. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::CheckLeave {w} { + variable ::tk::Priv + if {[$w cget -state] ne "disabled"} { + $w configure -state normal + } + + # Restore the original button "selected" color; but only if the user + # has not changed it in the meantime. + + if {![$w cget -indicatoron] && [info exist Priv($w,selectcolor)]} { + if {[$w cget -selectcolor] eq $Priv($w,selectcolor) + || ([info exist Priv($w,aselectcolor)] && + [$w cget -selectcolor] eq $Priv($w,aselectcolor))} { + $w configure -selectcolor $Priv($w,selectcolor) + } + } + unset -nocomplain Priv($w,selectcolor) Priv($w,aselectcolor) + + # Restore the original button relief if it was changed by Tk. That is + # signaled by the existence of Priv($w,prelief). + + if {[info exists Priv($w,relief)]} { + if {[info exists Priv($w,prelief)] && \ + $Priv($w,prelief) eq [$w cget -relief]} { + $w configure -relief $Priv($w,relief) + } + unset -nocomplain Priv($w,relief) Priv($w,prelief) + } + + set Priv(window) "" +} + +return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/XSchemWin/Installer/binary_template/lib/tk8.6/choosedir.tcl b/XSchemWin/Installer/binary_template/lib/tk8.6/choosedir.tcl new file mode 100644 index 00000000..68dd9b0d --- /dev/null +++ b/XSchemWin/Installer/binary_template/lib/tk8.6/choosedir.tcl @@ -0,0 +1,308 @@ +# choosedir.tcl -- +# +# Choose directory dialog implementation for Unix/Mac. +# +# Copyright (c) 1998-2000 by Scriptics Corporation. +# All rights reserved. + +# Make sure the tk::dialog namespace, in which all dialogs should live, exists +namespace eval ::tk::dialog {} +namespace eval ::tk::dialog::file {} + +# Make the chooseDir namespace inside the dialog namespace +namespace eval ::tk::dialog::file::chooseDir { + namespace import -force ::tk::msgcat::* +} + +# ::tk::dialog::file::chooseDir:: -- +# +# Implements the TK directory selection dialog. +# +# Arguments: +# args Options parsed by the procedure. +# +proc ::tk::dialog::file::chooseDir:: {args} { + variable ::tk::Priv + set dataName __tk_choosedir + upvar ::tk::dialog::file::$dataName data + Config $dataName $args + + if {$data(-parent) eq "."} { + set w .$dataName + } else { + set w $data(-parent).$dataName + } + + # (re)create the dialog box if necessary + # + if {![winfo exists $w]} { + ::tk::dialog::file::Create $w TkChooseDir + } elseif {[winfo class $w] ne "TkChooseDir"} { + destroy $w + ::tk::dialog::file::Create $w TkChooseDir + } else { + set data(dirMenuBtn) $w.contents.f1.menu + set data(dirMenu) $w.contents.f1.menu.menu + set data(upBtn) $w.contents.f1.up + set data(icons) $w.contents.icons + set data(ent) $w.contents.f2.ent + set data(okBtn) $w.contents.f2.ok + set data(cancelBtn) $w.contents.f2.cancel + set data(hiddenBtn) $w.contents.f2.hidden + } + if {$::tk::dialog::file::showHiddenBtn} { + $data(hiddenBtn) configure -state normal + grid $data(hiddenBtn) + } else { + $data(hiddenBtn) configure -state disabled + grid remove $data(hiddenBtn) + } + + # When using -mustexist, manage the OK button state for validity + $data(okBtn) configure -state normal + if {$data(-mustexist)} { + $data(ent) configure -validate key \ + -validatecommand [list ::tk::dialog::file::chooseDir::IsOK? $w %P] + } else { + $data(ent) configure -validate none + } + + # Dialog boxes should be transient with respect to their parent, + # so that they will always stay on top of their parent window. However, + # some window managers will create the window as withdrawn if the parent + # window is withdrawn or iconified. Combined with the grab we put on the + # window, this can hang the entire application. Therefore we only make + # the dialog transient if the parent is viewable. + + if {[winfo viewable [winfo toplevel $data(-parent)]] } { + wm transient $w $data(-parent) + } + + trace add variable data(selectPath) write \ + [list ::tk::dialog::file::SetPath $w] + $data(dirMenuBtn) configure \ + -textvariable ::tk::dialog::file::${dataName}(selectPath) + + set data(filter) "*" + set data(previousEntryText) "" + ::tk::dialog::file::UpdateWhenIdle $w + + # Withdraw the window, then update all the geometry information + # so we know how big it wants to be, then center the window in the + # display (Motif style) and de-iconify it. + + ::tk::PlaceWindow $w widget $data(-parent) + wm title $w $data(-title) + + # Set a grab and claim the focus too. + + ::tk::SetFocusGrab $w $data(ent) + $data(ent) delete 0 end + $data(ent) insert 0 $data(selectPath) + $data(ent) selection range 0 end + $data(ent) icursor end + + # Wait for the user to respond, then restore the focus and + # return the index of the selected button. Restore the focus + # before deleting the window, since otherwise the window manager + # may take the focus away so we can't redirect it. Finally, + # restore any grab that was in effect. + + vwait ::tk::Priv(selectFilePath) + + ::tk::RestoreFocusGrab $w $data(ent) withdraw + + # Cleanup traces on selectPath variable + # + + foreach trace [trace info variable data(selectPath)] { + trace remove variable data(selectPath) [lindex $trace 0] [lindex $trace 1] + } + $data(dirMenuBtn) configure -textvariable {} + + # Return value to user + # + + return $Priv(selectFilePath) +} + +# ::tk::dialog::file::chooseDir::Config -- +# +# Configures the Tk choosedir dialog according to the argument list +# +proc ::tk::dialog::file::chooseDir::Config {dataName argList} { + upvar ::tk::dialog::file::$dataName data + + # 0: Delete all variable that were set on data(selectPath) the + # last time the file dialog is used. The traces may cause troubles + # if the dialog is now used with a different -parent option. + # + foreach trace [trace info variable data(selectPath)] { + trace remove variable data(selectPath) [lindex $trace 0] [lindex $trace 1] + } + + # 1: the configuration specs + # + set specs { + {-mustexist "" "" 0} + {-initialdir "" "" ""} + {-parent "" "" "."} + {-title "" "" ""} + } + + # 2: default values depending on the type of the dialog + # + if {![info exists data(selectPath)]} { + # first time the dialog has been popped up + set data(selectPath) [pwd] + } + + # 3: parse the arguments + # + tclParseConfigSpec ::tk::dialog::file::$dataName $specs "" $argList + + if {$data(-title) eq ""} { + set data(-title) "[mc "Choose Directory"]" + } + + # Stub out the -multiple value for the dialog; it doesn't make sense for + # choose directory dialogs, but we have to have something there because we + # share so much code with the file dialogs. + set data(-multiple) 0 + + # 4: set the default directory and selection according to the -initial + # settings + # + if {$data(-initialdir) ne ""} { + # Ensure that initialdir is an absolute path name. + if {[file isdirectory $data(-initialdir)]} { + set old [pwd] + cd $data(-initialdir) + set data(selectPath) [pwd] + cd $old + } else { + set data(selectPath) [pwd] + } + } + + if {![winfo exists $data(-parent)]} { + return -code error -errorcode [list TK LOOKUP WINDOW $data(-parent)] \ + "bad window path name \"$data(-parent)\"" + } +} + +# Gets called when user presses Return in the "Selection" entry or presses OK. +# +proc ::tk::dialog::file::chooseDir::OkCmd {w} { + upvar ::tk::dialog::file::[winfo name $w] data + + # This is the brains behind selecting non-existant directories. Here's + # the flowchart: + # 1. If the icon list has a selection, join it with the current dir, + # and return that value. + # 1a. If the icon list does not have a selection ... + # 2. If the entry is empty, do nothing. + # 3. If the entry contains an invalid directory, then... + # 3a. If the value is the same as last time through here, end dialog. + # 3b. If the value is different than last time, save it and return. + # 4. If entry contains a valid directory, then... + # 4a. If the value is the same as the current directory, end dialog. + # 4b. If the value is different from the current directory, change to + # that directory. + + set selection [$data(icons) selection get] + if {[llength $selection] != 0} { + set iconText [$data(icons) get [lindex $selection 0]] + set iconText [file join $data(selectPath) $iconText] + Done $w $iconText + } else { + set text [$data(ent) get] + if {$text eq ""} { + return + } + set text [file join {*}[file split [string trim $text]]] + if {![file exists $text] || ![file isdirectory $text]} { + # Entry contains an invalid directory. If it's the same as the + # last time they came through here, reset the saved value and end + # the dialog. Otherwise, save the value (so we can do this test + # next time). + if {$text eq $data(previousEntryText)} { + set data(previousEntryText) "" + Done $w $text + } else { + set data(previousEntryText) $text + } + } else { + # Entry contains a valid directory. If it is the same as the + # current directory, end the dialog. Otherwise, change to that + # directory. + if {$text eq $data(selectPath)} { + Done $w $text + } else { + set data(selectPath) $text + } + } + } + return +} + +# Change state of OK button to match -mustexist correctness of entry +# +proc ::tk::dialog::file::chooseDir::IsOK? {w text} { + upvar ::tk::dialog::file::[winfo name $w] data + + set ok [file isdirectory $text] + $data(okBtn) configure -state [expr {$ok ? "normal" : "disabled"}] + + # always return 1 + return 1 +} + +proc ::tk::dialog::file::chooseDir::DblClick {w} { + upvar ::tk::dialog::file::[winfo name $w] data + set selection [$data(icons) selection get] + if {[llength $selection] != 0} { + set filenameFragment [$data(icons) get [lindex $selection 0]] + set file $data(selectPath) + if {[file isdirectory $file]} { + ::tk::dialog::file::ListInvoke $w [list $filenameFragment] + return + } + } +} + +# Gets called when user browses the IconList widget (dragging mouse, arrow +# keys, etc) +# +proc ::tk::dialog::file::chooseDir::ListBrowse {w text} { + upvar ::tk::dialog::file::[winfo name $w] data + + if {$text eq ""} { + return + } + + set file [::tk::dialog::file::JoinFile $data(selectPath) $text] + $data(ent) delete 0 end + $data(ent) insert 0 $file +} + +# ::tk::dialog::file::chooseDir::Done -- +# +# Gets called when user has input a valid filename. Pops up a +# dialog box to confirm selection when necessary. Sets the +# Priv(selectFilePath) variable, which will break the "vwait" +# loop in tk_chooseDirectory and return the selected filename to the +# script that calls tk_getOpenFile or tk_getSaveFile +# +proc ::tk::dialog::file::chooseDir::Done {w {selectFilePath ""}} { + upvar ::tk::dialog::file::[winfo name $w] data + variable ::tk::Priv + + if {$selectFilePath eq ""} { + set selectFilePath $data(selectPath) + } + if {$data(-mustexist) && ![file isdirectory $selectFilePath]} { + return + } + set Priv(selectFilePath) $selectFilePath +} diff --git a/XSchemWin/Installer/binary_template/lib/tk8.6/clrpick.tcl b/XSchemWin/Installer/binary_template/lib/tk8.6/clrpick.tcl new file mode 100644 index 00000000..e408d037 --- /dev/null +++ b/XSchemWin/Installer/binary_template/lib/tk8.6/clrpick.tcl @@ -0,0 +1,695 @@ +# clrpick.tcl -- +# +# Color selection dialog for platforms that do not support a +# standard color selection dialog. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# ToDo: +# +# (1): Find out how many free colors are left in the colormap and +# don't allocate too many colors. +# (2): Implement HSV color selection. +# + +# Make sure namespaces exist +namespace eval ::tk {} +namespace eval ::tk::dialog {} +namespace eval ::tk::dialog::color { + namespace import ::tk::msgcat::* +} + +# ::tk::dialog::color:: -- +# +# Create a color dialog and let the user choose a color. This function +# should not be called directly. It is called by the tk_chooseColor +# function when a native color selector widget does not exist +# +proc ::tk::dialog::color:: {args} { + variable ::tk::Priv + set dataName __tk__color + upvar ::tk::dialog::color::$dataName data + set w .$dataName + + # The lines variables track the start and end indices of the line + # elements in the colorbar canvases. + set data(lines,red,start) 0 + set data(lines,red,last) -1 + set data(lines,green,start) 0 + set data(lines,green,last) -1 + set data(lines,blue,start) 0 + set data(lines,blue,last) -1 + + # This is the actual number of lines that are drawn in each color strip. + # Note that the bars may be of any width. + # However, NUM_COLORBARS must be a number that evenly divides 256. + # Such as 256, 128, 64, etc. + set data(NUM_COLORBARS) 16 + + # BARS_WIDTH is the number of pixels wide the color bar portion of the + # canvas is. This number must be a multiple of NUM_COLORBARS + set data(BARS_WIDTH) 160 + + # PLGN_WIDTH is the number of pixels wide of the triangular selection + # polygon. This also results in the definition of the padding on the + # left and right sides which is half of PLGN_WIDTH. Make this number even. + set data(PLGN_HEIGHT) 10 + + # PLGN_HEIGHT is the height of the selection polygon and the height of the + # selection rectangle at the bottom of the color bar. No restrictions. + set data(PLGN_WIDTH) 10 + + Config $dataName $args + InitValues $dataName + + set sc [winfo screen $data(-parent)] + set winExists [winfo exists $w] + if {!$winExists || $sc ne [winfo screen $w]} { + if {$winExists} { + destroy $w + } + toplevel $w -class TkColorDialog -screen $sc + if {[tk windowingsystem] eq "x11"} {wm attributes $w -type dialog} + BuildDialog $w + } + + # Dialog boxes should be transient with respect to their parent, + # so that they will always stay on top of their parent window. However, + # some window managers will create the window as withdrawn if the parent + # window is withdrawn or iconified. Combined with the grab we put on the + # window, this can hang the entire application. Therefore we only make + # the dialog transient if the parent is viewable. + + if {[winfo viewable [winfo toplevel $data(-parent)]] } { + wm transient $w $data(-parent) + } + + # 5. Withdraw the window, then update all the geometry information + # so we know how big it wants to be, then center the window in the + # display (Motif style) and de-iconify it. + + ::tk::PlaceWindow $w widget $data(-parent) + wm title $w $data(-title) + + # 6. Set a grab and claim the focus too. + + ::tk::SetFocusGrab $w $data(okBtn) + + # 7. Wait for the user to respond, then restore the focus and + # return the index of the selected button. Restore the focus + # before deleting the window, since otherwise the window manager + # may take the focus away so we can't redirect it. Finally, + # restore any grab that was in effect. + + vwait ::tk::Priv(selectColor) + set result $Priv(selectColor) + ::tk::RestoreFocusGrab $w $data(okBtn) + unset data + + return $result +} + +# ::tk::dialog::color::InitValues -- +# +# Get called during initialization or when user resets NUM_COLORBARS +# +proc ::tk::dialog::color::InitValues {dataName} { + upvar ::tk::dialog::color::$dataName data + + # IntensityIncr is the difference in color intensity between a colorbar + # and its neighbors. + set data(intensityIncr) [expr {256 / $data(NUM_COLORBARS)}] + + # ColorbarWidth is the width of each colorbar + set data(colorbarWidth) [expr {$data(BARS_WIDTH) / $data(NUM_COLORBARS)}] + + # Indent is the width of the space at the left and right side of the + # colorbar. It is always half the selector polygon width, because the + # polygon extends into the space. + set data(indent) [expr {$data(PLGN_WIDTH) / 2}] + + set data(colorPad) 2 + set data(selPad) [expr {$data(PLGN_WIDTH) / 2}] + + # + # minX is the x coordinate of the first colorbar + # + set data(minX) $data(indent) + + # + # maxX is the x coordinate of the last colorbar + # + set data(maxX) [expr {$data(BARS_WIDTH) + $data(indent)-1}] + + # + # canvasWidth is the width of the entire canvas, including the indents + # + set data(canvasWidth) [expr {$data(BARS_WIDTH) + $data(PLGN_WIDTH)}] + + # Set the initial color, specified by -initialcolor, or the + # color chosen by the user the last time. + set data(selection) $data(-initialcolor) + set data(finalColor) $data(-initialcolor) + set rgb [winfo rgb . $data(selection)] + + set data(red,intensity) [expr {[lindex $rgb 0]/0x100}] + set data(green,intensity) [expr {[lindex $rgb 1]/0x100}] + set data(blue,intensity) [expr {[lindex $rgb 2]/0x100}] +} + +# ::tk::dialog::color::Config -- +# +# Parses the command line arguments to tk_chooseColor +# +proc ::tk::dialog::color::Config {dataName argList} { + variable ::tk::Priv + upvar ::tk::dialog::color::$dataName data + + # 1: the configuration specs + # + if {[info exists Priv(selectColor)] && $Priv(selectColor) ne ""} { + set defaultColor $Priv(selectColor) + } else { + set defaultColor [. cget -background] + } + + set specs [list \ + [list -initialcolor "" "" $defaultColor] \ + [list -parent "" "" "."] \ + [list -title "" "" [mc "Color"]] \ + ] + + # 2: parse the arguments + # + tclParseConfigSpec ::tk::dialog::color::$dataName $specs "" $argList + + if {$data(-title) eq ""} { + set data(-title) " " + } + if {[catch {winfo rgb . $data(-initialcolor)} err]} { + return -code error -errorcode [list TK LOOKUP COLOR $data(-initialcolor)] \ + $err + } + + if {![winfo exists $data(-parent)]} { + return -code error -errorcode [list TK LOOKUP WINDOW $data(-parent)] \ + "bad window path name \"$data(-parent)\"" + } +} + +# ::tk::dialog::color::BuildDialog -- +# +# Build the dialog. +# +proc ::tk::dialog::color::BuildDialog {w} { + upvar ::tk::dialog::color::[winfo name $w] data + + # TopFrame contains the color strips and the color selection + # + set topFrame [frame $w.top -relief raised -bd 1] + + # StripsFrame contains the colorstrips and the individual RGB entries + set stripsFrame [frame $topFrame.colorStrip] + + set maxWidth [::tk::mcmaxamp &Red &Green &Blue] + set maxWidth [expr {$maxWidth<6 ? 6 : $maxWidth}] + set colorList { + red "&Red" + green "&Green" + blue "&Blue" + } + foreach {color l} $colorList { + # each f frame contains an [R|G|B] entry and the equiv. color strip. + set f [frame $stripsFrame.$color] + + # The box frame contains the label and entry widget for an [R|G|B] + set box [frame $f.box] + + ::tk::AmpWidget label $box.label -text "[mc $l]:" \ + -width $maxWidth -anchor ne + bind $box.label <> [list focus $box.entry] + + entry $box.entry -textvariable \ + ::tk::dialog::color::[winfo name $w]($color,intensity) \ + -width 4 + pack $box.label -side left -fill y -padx 2 -pady 3 + pack $box.entry -side left -anchor n -pady 0 + pack $box -side left -fill both + + set height [expr { + [winfo reqheight $box.entry] - + 2*([$box.entry cget -highlightthickness] + [$box.entry cget -bd]) + }] + + canvas $f.color -height $height \ + -width $data(BARS_WIDTH) -relief sunken -bd 2 + canvas $f.sel -height $data(PLGN_HEIGHT) \ + -width $data(canvasWidth) -highlightthickness 0 + pack $f.color -expand yes -fill both + pack $f.sel -expand yes -fill both + + pack $f -side top -fill x -padx 0 -pady 2 + + set data($color,entry) $box.entry + set data($color,col) $f.color + set data($color,sel) $f.sel + + bind $data($color,col) \ + [list tk::dialog::color::DrawColorScale $w $color 1] + bind $data($color,col) \ + [list tk::dialog::color::EnterColorBar $w $color] + bind $data($color,col) \ + [list tk::dialog::color::LeaveColorBar $w $color] + + bind $data($color,sel) \ + [list tk::dialog::color::EnterColorBar $w $color] + bind $data($color,sel) \ + [list tk::dialog::color::LeaveColorBar $w $color] + + bind $box.entry [list tk::dialog::color::HandleRGBEntry $w] + } + + pack $stripsFrame -side left -fill both -padx 4 -pady 10 + + # The selFrame contains a frame that demonstrates the currently + # selected color + # + set selFrame [frame $topFrame.sel] + set lab [::tk::AmpWidget label $selFrame.lab \ + -text [mc "&Selection:"] -anchor sw] + set ent [entry $selFrame.ent \ + -textvariable ::tk::dialog::color::[winfo name $w](selection) \ + -width 16] + set f1 [frame $selFrame.f1 -relief sunken -bd 2] + set data(finalCanvas) [frame $f1.demo -bd 0 -width 100 -height 70] + + pack $lab $ent -side top -fill x -padx 4 -pady 2 + pack $f1 -expand yes -anchor nw -fill both -padx 6 -pady 10 + pack $data(finalCanvas) -expand yes -fill both + + bind $ent [list tk::dialog::color::HandleSelEntry $w] + + pack $selFrame -side left -fill none -anchor nw + pack $topFrame -side top -expand yes -fill both -anchor nw + + # the botFrame frame contains the buttons + # + set botFrame [frame $w.bot -relief raised -bd 1] + + ::tk::AmpWidget button $botFrame.ok -text [mc "&OK"] \ + -command [list tk::dialog::color::OkCmd $w] + ::tk::AmpWidget button $botFrame.cancel -text [mc "&Cancel"] \ + -command [list tk::dialog::color::CancelCmd $w] + + set data(okBtn) $botFrame.ok + set data(cancelBtn) $botFrame.cancel + + grid x $botFrame.ok x $botFrame.cancel x -sticky ew + grid configure $botFrame.ok $botFrame.cancel -padx 10 -pady 10 + grid columnconfigure $botFrame {0 4} -weight 1 -uniform space + grid columnconfigure $botFrame {1 3} -weight 1 -uniform button + grid columnconfigure $botFrame 2 -weight 2 -uniform space + pack $botFrame -side bottom -fill x + + # Accelerator bindings + bind $lab <> [list focus $ent] + bind $w [list tk::ButtonInvoke $data(cancelBtn)] + bind $w [list tk::AltKeyInDialog $w %A] + + wm protocol $w WM_DELETE_WINDOW [list tk::dialog::color::CancelCmd $w] + bind $lab [list tk::dialog::color::CancelCmd $w] +} + +# ::tk::dialog::color::SetRGBValue -- +# +# Sets the current selection of the dialog box +# +proc ::tk::dialog::color::SetRGBValue {w color} { + upvar ::tk::dialog::color::[winfo name $w] data + + set data(red,intensity) [lindex $color 0] + set data(green,intensity) [lindex $color 1] + set data(blue,intensity) [lindex $color 2] + + RedrawColorBars $w all + + # Now compute the new x value of each colorbars pointer polygon + foreach color {red green blue} { + set x [RgbToX $w $data($color,intensity)] + MoveSelector $w $data($color,sel) $color $x 0 + } +} + +# ::tk::dialog::color::XToRgb -- +# +# Converts a screen coordinate to intensity +# +proc ::tk::dialog::color::XToRgb {w x} { + upvar ::tk::dialog::color::[winfo name $w] data + + set x [expr {($x * $data(intensityIncr))/ $data(colorbarWidth)}] + if {$x > 255} { + set x 255 + } + return $x +} + +# ::tk::dialog::color::RgbToX +# +# Converts an intensity to screen coordinate. +# +proc ::tk::dialog::color::RgbToX {w color} { + upvar ::tk::dialog::color::[winfo name $w] data + + return [expr {($color * $data(colorbarWidth)/ $data(intensityIncr))}] +} + +# ::tk::dialog::color::DrawColorScale -- +# +# Draw color scale is called whenever the size of one of the color +# scale canvases is changed. +# +proc ::tk::dialog::color::DrawColorScale {w c {create 0}} { + upvar ::tk::dialog::color::[winfo name $w] data + + # col: color bar canvas + # sel: selector canvas + set col $data($c,col) + set sel $data($c,sel) + + # First handle the case that we are creating everything for the first time. + if {$create} { + # First remove all the lines that already exist. + if { $data(lines,$c,last) > $data(lines,$c,start)} { + for {set i $data(lines,$c,start)} \ + {$i <= $data(lines,$c,last)} {incr i} { + $sel delete $i + } + } + # Delete the selector if it exists + if {[info exists data($c,index)]} { + $sel delete $data($c,index) + } + + # Draw the selection polygons + CreateSelector $w $sel $c + $sel bind $data($c,index) \ + [list tk::dialog::color::StartMove $w $sel $c %x $data(selPad) 1] + $sel bind $data($c,index) \ + [list tk::dialog::color::MoveSelector $w $sel $c %x $data(selPad)] + $sel bind $data($c,index) \ + [list tk::dialog::color::ReleaseMouse $w $sel $c %x $data(selPad)] + + set height [winfo height $col] + # Create an invisible region under the colorstrip to catch mouse clicks + # that aren't on the selector. + set data($c,clickRegion) [$sel create rectangle 0 0 \ + $data(canvasWidth) $height -fill {} -outline {}] + + bind $col \ + [list tk::dialog::color::StartMove $w $sel $c %x $data(colorPad)] + bind $col \ + [list tk::dialog::color::MoveSelector $w $sel $c %x $data(colorPad)] + bind $col \ + [list tk::dialog::color::ReleaseMouse $w $sel $c %x $data(colorPad)] + + $sel bind $data($c,clickRegion) \ + [list tk::dialog::color::StartMove $w $sel $c %x $data(selPad)] + $sel bind $data($c,clickRegion) \ + [list tk::dialog::color::MoveSelector $w $sel $c %x $data(selPad)] + $sel bind $data($c,clickRegion) \ + [list tk::dialog::color::ReleaseMouse $w $sel $c %x $data(selPad)] + } else { + # l is the canvas index of the first colorbar. + set l $data(lines,$c,start) + } + + # Draw the color bars. + set highlightW [expr {[$col cget -highlightthickness] + [$col cget -bd]}] + for {set i 0} { $i < $data(NUM_COLORBARS)} { incr i} { + set intensity [expr {$i * $data(intensityIncr)}] + set startx [expr {$i * $data(colorbarWidth) + $highlightW}] + if {$c eq "red"} { + set color [format "#%02x%02x%02x" \ + $intensity $data(green,intensity) $data(blue,intensity)] + } elseif {$c eq "green"} { + set color [format "#%02x%02x%02x" \ + $data(red,intensity) $intensity $data(blue,intensity)] + } else { + set color [format "#%02x%02x%02x" \ + $data(red,intensity) $data(green,intensity) $intensity] + } + + if {$create} { + set index [$col create rect $startx $highlightW \ + [expr {$startx +$data(colorbarWidth)}] \ + [expr {[winfo height $col] + $highlightW}] \ + -fill $color -outline $color] + } else { + $col itemconfigure $l -fill $color -outline $color + incr l + } + } + $sel raise $data($c,index) + + if {$create} { + set data(lines,$c,last) $index + set data(lines,$c,start) [expr {$index - $data(NUM_COLORBARS) + 1}] + } + + RedrawFinalColor $w +} + +# ::tk::dialog::color::CreateSelector -- +# +# Creates and draws the selector polygon at the position +# $data($c,intensity). +# +proc ::tk::dialog::color::CreateSelector {w sel c } { + upvar ::tk::dialog::color::[winfo name $w] data + set data($c,index) [$sel create polygon \ + 0 $data(PLGN_HEIGHT) \ + $data(PLGN_WIDTH) $data(PLGN_HEIGHT) \ + $data(indent) 0] + set data($c,x) [RgbToX $w $data($c,intensity)] + $sel move $data($c,index) $data($c,x) 0 +} + +# ::tk::dialog::color::RedrawFinalColor +# +# Combines the intensities of the three colors into the final color +# +proc ::tk::dialog::color::RedrawFinalColor {w} { + upvar ::tk::dialog::color::[winfo name $w] data + + set color [format "#%02x%02x%02x" $data(red,intensity) \ + $data(green,intensity) $data(blue,intensity)] + + $data(finalCanvas) configure -bg $color + set data(finalColor) $color + set data(selection) $color + set data(finalRGB) [list \ + $data(red,intensity) \ + $data(green,intensity) \ + $data(blue,intensity)] +} + +# ::tk::dialog::color::RedrawColorBars -- +# +# Only redraws the colors on the color strips that were not manipulated. +# Params: color of colorstrip that changed. If color is not [red|green|blue] +# Then all colorstrips will be updated +# +proc ::tk::dialog::color::RedrawColorBars {w colorChanged} { + upvar ::tk::dialog::color::[winfo name $w] data + + switch $colorChanged { + red { + DrawColorScale $w green + DrawColorScale $w blue + } + green { + DrawColorScale $w red + DrawColorScale $w blue + } + blue { + DrawColorScale $w red + DrawColorScale $w green + } + default { + DrawColorScale $w red + DrawColorScale $w green + DrawColorScale $w blue + } + } + RedrawFinalColor $w +} + +#---------------------------------------------------------------------- +# Event handlers +#---------------------------------------------------------------------- + +# ::tk::dialog::color::StartMove -- +# +# Handles a mousedown button event over the selector polygon. +# Adds the bindings for moving the mouse while the button is +# pressed. Sets the binding for the button-release event. +# +# Params: sel is the selector canvas window, color is the color of the strip. +# +proc ::tk::dialog::color::StartMove {w sel color x delta {dontMove 0}} { + upvar ::tk::dialog::color::[winfo name $w] data + + if {!$dontMove} { + MoveSelector $w $sel $color $x $delta + } +} + +# ::tk::dialog::color::MoveSelector -- +# +# Moves the polygon selector so that its middle point has the same +# x value as the specified x. If x is outside the bounds [0,255], +# the selector is set to the closest endpoint. +# +# Params: sel is the selector canvas, c is [red|green|blue] +# x is a x-coordinate. +# +proc ::tk::dialog::color::MoveSelector {w sel color x delta} { + upvar ::tk::dialog::color::[winfo name $w] data + + incr x -$delta + + if { $x < 0 } { + set x 0 + } elseif { $x > $data(BARS_WIDTH)} { + set x $data(BARS_WIDTH) + } + set diff [expr {$x - $data($color,x)}] + $sel move $data($color,index) $diff 0 + set data($color,x) [expr {$data($color,x) + $diff}] + + # Return the x value that it was actually set at + return $x +} + +# ::tk::dialog::color::ReleaseMouse +# +# Removes mouse tracking bindings, updates the colorbars. +# +# Params: sel is the selector canvas, color is the color of the strip, +# x is the x-coord of the mouse. +# +proc ::tk::dialog::color::ReleaseMouse {w sel color x delta} { + upvar ::tk::dialog::color::[winfo name $w] data + + set x [MoveSelector $w $sel $color $x $delta] + + # Determine exactly what color we are looking at. + set data($color,intensity) [XToRgb $w $x] + + RedrawColorBars $w $color +} + +# ::tk::dialog::color::ResizeColorbars -- +# +# Completely redraws the colorbars, including resizing the +# colorstrips +# +proc ::tk::dialog::color::ResizeColorBars {w} { + upvar ::tk::dialog::color::[winfo name $w] data + + if { + ($data(BARS_WIDTH) < $data(NUM_COLORBARS)) || + (($data(BARS_WIDTH) % $data(NUM_COLORBARS)) != 0) + } then { + set data(BARS_WIDTH) $data(NUM_COLORBARS) + } + InitValues [winfo name $w] + foreach color {red green blue} { + $data($color,col) configure -width $data(canvasWidth) + DrawColorScale $w $color 1 + } +} + +# ::tk::dialog::color::HandleSelEntry -- +# +# Handles the return keypress event in the "Selection:" entry +# +proc ::tk::dialog::color::HandleSelEntry {w} { + upvar ::tk::dialog::color::[winfo name $w] data + + set text [string trim $data(selection)] + # Check to make sure that the color is valid + if {[catch {set color [winfo rgb . $text]} ]} { + set data(selection) $data(finalColor) + return + } + + set R [expr {[lindex $color 0]/0x100}] + set G [expr {[lindex $color 1]/0x100}] + set B [expr {[lindex $color 2]/0x100}] + + SetRGBValue $w "$R $G $B" + set data(selection) $text +} + +# ::tk::dialog::color::HandleRGBEntry -- +# +# Handles the return keypress event in the R, G or B entry +# +proc ::tk::dialog::color::HandleRGBEntry {w} { + upvar ::tk::dialog::color::[winfo name $w] data + + foreach c {red green blue} { + if {[catch { + set data($c,intensity) [expr {int($data($c,intensity))}] + }]} { + set data($c,intensity) 0 + } + + if {$data($c,intensity) < 0} { + set data($c,intensity) 0 + } + if {$data($c,intensity) > 255} { + set data($c,intensity) 255 + } + } + + SetRGBValue $w "$data(red,intensity) \ + $data(green,intensity) $data(blue,intensity)" +} + +# mouse cursor enters a color bar +# +proc ::tk::dialog::color::EnterColorBar {w color} { + upvar ::tk::dialog::color::[winfo name $w] data + + $data($color,sel) itemconfigure $data($color,index) -fill red +} + +# mouse leaves enters a color bar +# +proc ::tk::dialog::color::LeaveColorBar {w color} { + upvar ::tk::dialog::color::[winfo name $w] data + + $data($color,sel) itemconfigure $data($color,index) -fill black +} + +# user hits OK button +# +proc ::tk::dialog::color::OkCmd {w} { + variable ::tk::Priv + upvar ::tk::dialog::color::[winfo name $w] data + + set Priv(selectColor) $data(finalColor) +} + +# user hits Cancel button or destroys window +# +proc ::tk::dialog::color::CancelCmd {w} { + variable ::tk::Priv + set Priv(selectColor) "" +} diff --git a/XSchemWin/Installer/binary_template/lib/tk8.6/comdlg.tcl b/XSchemWin/Installer/binary_template/lib/tk8.6/comdlg.tcl new file mode 100644 index 00000000..b4d89785 --- /dev/null +++ b/XSchemWin/Installer/binary_template/lib/tk8.6/comdlg.tcl @@ -0,0 +1,322 @@ +# comdlg.tcl -- +# +# Some functions needed for the common dialog boxes. Probably need to go +# in a different file. +# +# Copyright (c) 1996 Sun Microsystems, Inc. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +# tclParseConfigSpec -- +# +# Parses a list of "-option value" pairs. If all options and +# values are legal, the values are stored in +# $data($option). Otherwise an error message is returned. When +# an error happens, the data() array may have been partially +# modified, but all the modified members of the data(0 array are +# guaranteed to have valid values. This is different than +# Tk_ConfigureWidget() which does not modify the value of a +# widget record if any error occurs. +# +# Arguments: +# +# w = widget record to modify. Must be the pathname of a widget. +# +# specs = { +# {-commandlineswitch resourceName ResourceClass defaultValue verifier} +# {....} +# } +# +# flags = a list of flags. Currently supported flags are: +# DONTSETDEFAULTS = skip default values setting +# +# argList = The list of "-option value" pairs. +# +proc tclParseConfigSpec {w specs flags argList} { + upvar #0 $w data + + # 1: Put the specs in associative arrays for faster access + # + foreach spec $specs { + if {[llength $spec] < 4} { + return -code error -errorcode {TK VALUE CONFIG_SPEC} \ + "\"spec\" should contain 5 or 4 elements" + } + set cmdsw [lindex $spec 0] + set cmd($cmdsw) "" + set rname($cmdsw) [lindex $spec 1] + set rclass($cmdsw) [lindex $spec 2] + set def($cmdsw) [lindex $spec 3] + set verproc($cmdsw) [lindex $spec 4] + } + + if {[llength $argList] & 1} { + set cmdsw [lindex $argList end] + if {![info exists cmd($cmdsw)]} { + return -code error -errorcode [list TK LOOKUP OPTION $cmdsw] \ + "bad option \"$cmdsw\": must be [tclListValidFlags cmd]" + } + return -code error -errorcode {TK VALUE_MISSING} \ + "value for \"$cmdsw\" missing" + } + + # 2: set the default values + # + if {"DONTSETDEFAULTS" ni $flags} { + foreach cmdsw [array names cmd] { + set data($cmdsw) $def($cmdsw) + } + } + + # 3: parse the argument list + # + foreach {cmdsw value} $argList { + if {![info exists cmd($cmdsw)]} { + return -code error -errorcode [list TK LOOKUP OPTION $cmdsw] \ + "bad option \"$cmdsw\": must be [tclListValidFlags cmd]" + } + set data($cmdsw) $value + } + + # Done! +} + +proc tclListValidFlags {v} { + upvar $v cmd + + set len [llength [array names cmd]] + set i 1 + set separator "" + set errormsg "" + foreach cmdsw [lsort [array names cmd]] { + append errormsg "$separator$cmdsw" + incr i + if {$i == $len} { + set separator ", or " + } else { + set separator ", " + } + } + return $errormsg +} + +#---------------------------------------------------------------------- +# +# Focus Group +# +# Focus groups are used to handle the user's focusing actions inside a +# toplevel. +# +# One example of using focus groups is: when the user focuses on an +# entry, the text in the entry is highlighted and the cursor is put to +# the end of the text. When the user changes focus to another widget, +# the text in the previously focused entry is validated. +# +#---------------------------------------------------------------------- + + +# ::tk::FocusGroup_Create -- +# +# Create a focus group. All the widgets in a focus group must be +# within the same focus toplevel. Each toplevel can have only +# one focus group, which is identified by the name of the +# toplevel widget. +# +proc ::tk::FocusGroup_Create {t} { + variable ::tk::Priv + if {[winfo toplevel $t] ne $t} { + return -code error -errorcode [list TK LOOKUP TOPLEVEL $t] \ + "$t is not a toplevel window" + } + if {![info exists Priv(fg,$t)]} { + set Priv(fg,$t) 1 + set Priv(focus,$t) "" + bind $t [list tk::FocusGroup_In $t %W %d] + bind $t [list tk::FocusGroup_Out $t %W %d] + bind $t [list tk::FocusGroup_Destroy $t %W] + } +} + +# ::tk::FocusGroup_BindIn -- +# +# Add a widget into the "FocusIn" list of the focus group. The $cmd will be +# called when the widget is focused on by the user. +# +proc ::tk::FocusGroup_BindIn {t w cmd} { + variable FocusIn + variable ::tk::Priv + if {![info exists Priv(fg,$t)]} { + return -code error -errorcode [list TK LOOKUP FOCUS_GROUP $t] \ + "focus group \"$t\" doesn't exist" + } + set FocusIn($t,$w) $cmd +} + + +# ::tk::FocusGroup_BindOut -- +# +# Add a widget into the "FocusOut" list of the focus group. The +# $cmd will be called when the widget loses the focus (User +# types Tab or click on another widget). +# +proc ::tk::FocusGroup_BindOut {t w cmd} { + variable FocusOut + variable ::tk::Priv + if {![info exists Priv(fg,$t)]} { + return -code error -errorcode [list TK LOOKUP FOCUS_GROUP $t] \ + "focus group \"$t\" doesn't exist" + } + set FocusOut($t,$w) $cmd +} + +# ::tk::FocusGroup_Destroy -- +# +# Cleans up when members of the focus group is deleted, or when the +# toplevel itself gets deleted. +# +proc ::tk::FocusGroup_Destroy {t w} { + variable FocusIn + variable FocusOut + variable ::tk::Priv + + if {$t eq $w} { + unset Priv(fg,$t) + unset Priv(focus,$t) + + foreach name [array names FocusIn $t,*] { + unset FocusIn($name) + } + foreach name [array names FocusOut $t,*] { + unset FocusOut($name) + } + } else { + if {[info exists Priv(focus,$t)] && ($Priv(focus,$t) eq $w)} { + set Priv(focus,$t) "" + } + unset -nocomplain FocusIn($t,$w) FocusOut($t,$w) + } +} + +# ::tk::FocusGroup_In -- +# +# Handles the event. Calls the FocusIn command for the newly +# focused widget in the focus group. +# +proc ::tk::FocusGroup_In {t w detail} { + variable FocusIn + variable ::tk::Priv + + if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} { + # This is caused by mouse moving out&in of the window *or* + # ordinary keypresses some window managers (ie: CDE [Bug: 2960]). + return + } + if {![info exists FocusIn($t,$w)]} { + set FocusIn($t,$w) "" + return + } + if {![info exists Priv(focus,$t)]} { + return + } + if {$Priv(focus,$t) eq $w} { + # This is already in focus + # + return + } else { + set Priv(focus,$t) $w + eval $FocusIn($t,$w) + } +} + +# ::tk::FocusGroup_Out -- +# +# Handles the event. Checks if this is really a lose +# focus event, not one generated by the mouse moving out of the +# toplevel window. Calls the FocusOut command for the widget +# who loses its focus. +# +proc ::tk::FocusGroup_Out {t w detail} { + variable FocusOut + variable ::tk::Priv + + if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} { + # This is caused by mouse moving out of the window + return + } + if {![info exists Priv(focus,$t)]} { + return + } + if {![info exists FocusOut($t,$w)]} { + return + } else { + eval $FocusOut($t,$w) + set Priv(focus,$t) "" + } +} + +# ::tk::FDGetFileTypes -- +# +# Process the string given by the -filetypes option of the file +# dialogs. Similar to the C function TkGetFileFilters() on the Mac +# and Windows platform. +# +proc ::tk::FDGetFileTypes {string} { + foreach t $string { + if {[llength $t] < 2 || [llength $t] > 3} { + return -code error -errorcode {TK VALUE FILE_TYPE} \ + "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\"" + } + lappend fileTypes([lindex $t 0]) {*}[lindex $t 1] + } + + set types {} + foreach t $string { + set label [lindex $t 0] + set exts {} + + if {[info exists hasDoneType($label)]} { + continue + } + + # Validate each macType. This is to agree with the + # behaviour of TkGetFileFilters(). This list may be + # empty. + foreach macType [lindex $t 2] { + if {[string length $macType] != 4} { + return -code error -errorcode {TK VALUE MAC_TYPE} \ + "bad Macintosh file type \"$macType\"" + } + } + + set name "$label \(" + set sep "" + set doAppend 1 + foreach ext $fileTypes($label) { + if {$ext eq ""} { + continue + } + regsub {^[.]} $ext "*." ext + if {![info exists hasGotExt($label,$ext)]} { + if {$doAppend} { + if {[string length $sep] && [string length $name]>40} { + set doAppend 0 + append name $sep... + } else { + append name $sep$ext + } + } + lappend exts $ext + set hasGotExt($label,$ext) 1 + } + set sep "," + } + append name "\)" + lappend types [list $name $exts] + + set hasDoneType($label) 1 + } + + return $types +} diff --git a/XSchemWin/Installer/binary_template/lib/tk8.6/console.tcl b/XSchemWin/Installer/binary_template/lib/tk8.6/console.tcl new file mode 100644 index 00000000..30c4d883 --- /dev/null +++ b/XSchemWin/Installer/binary_template/lib/tk8.6/console.tcl @@ -0,0 +1,1150 @@ +# console.tcl -- +# +# This code constructs the console window for an application. It +# can be used by non-unix systems that do not have built-in support +# for shells. +# +# Copyright (c) 1995-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-2000 Ajuba Solutions. +# Copyright (c) 2007-2008 Daniel A. Steffen +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +# TODO: history - remember partially written command + +namespace eval ::tk::console { + variable blinkTime 500 ; # msecs to blink braced range for + variable blinkRange 1 ; # enable blinking of the entire braced range + variable magicKeys 1 ; # enable brace matching and proc/var recognition + variable maxLines 600 ; # maximum # of lines buffered in console + variable showMatches 1 ; # show multiple expand matches + variable useFontchooser [llength [info command ::tk::fontchooser]] + variable inPlugin [info exists embed_args] + variable defaultPrompt ; # default prompt if tcl_prompt1 isn't used + + if {$inPlugin} { + set defaultPrompt {subst {[history nextid] % }} + } else { + set defaultPrompt {subst {([file tail [pwd]]) [history nextid] % }} + } +} + +# simple compat function for tkcon code added for this console +interp alias {} EvalAttached {} consoleinterp eval + +# ::tk::ConsoleInit -- +# This procedure constructs and configures the console windows. +# +# Arguments: +# None. + +proc ::tk::ConsoleInit {} { + if {![consoleinterp eval {set tcl_interactive}]} { + wm withdraw . + } + + if {[tk windowingsystem] eq "aqua"} { + set mod "Cmd" + } else { + set mod "Ctrl" + } + + if {[catch {menu .menubar} err]} { + bgerror "INIT: $err" + } + AmpMenuArgs .menubar add cascade -label [mc &File] -menu .menubar.file + AmpMenuArgs .menubar add cascade -label [mc &Edit] -menu .menubar.edit + + menu .menubar.file -tearoff 0 + AmpMenuArgs .menubar.file add command -label [mc "&Source..."] \ + -command {tk::ConsoleSource} + AmpMenuArgs .menubar.file add command -label [mc "&Hide Console"] \ + -command {wm withdraw .} + AmpMenuArgs .menubar.file add command -label [mc "&Clear Console"] \ + -command {.console delete 1.0 "promptEnd linestart"} + if {[tk windowingsystem] ne "aqua"} { + AmpMenuArgs .menubar.file add command -label [mc E&xit] -command {exit} + } + + menu .menubar.edit -tearoff 0 + AmpMenuArgs .menubar.edit add command -label [mc Cu&t] -accel "$mod+X"\ + -command {event generate .console <>} + AmpMenuArgs .menubar.edit add command -label [mc &Copy] -accel "$mod+C"\ + -command {event generate .console <>} + AmpMenuArgs .menubar.edit add command -label [mc P&aste] -accel "$mod+V"\ + -command {event generate .console <>} + + if {[tk windowingsystem] ne "win32"} { + AmpMenuArgs .menubar.edit add command -label [mc Cl&ear] \ + -command {event generate .console <>} + } else { + AmpMenuArgs .menubar.edit add command -label [mc &Delete] \ + -command {event generate .console <>} -accel "Del" + + AmpMenuArgs .menubar add cascade -label [mc &Help] -menu .menubar.help + menu .menubar.help -tearoff 0 + AmpMenuArgs .menubar.help add command -label [mc &About...] \ + -command tk::ConsoleAbout + } + + AmpMenuArgs .menubar.edit add separator + if {$::tk::console::useFontchooser} { + if {[tk windowingsystem] eq "aqua"} { + .menubar.edit add command -label tk_choose_font_marker + set index [.menubar.edit index tk_choose_font_marker] + .menubar.edit entryconfigure $index \ + -label [mc "Show Fonts"]\ + -accelerator "$mod-T"\ + -command [list ::tk::console::FontchooserToggle] + bind Console <> \ + [list ::tk::console::FontchooserVisibility $index] + ::tk::console::FontchooserVisibility $index + } else { + AmpMenuArgs .menubar.edit add command -label [mc "&Font..."] \ + -command [list ::tk::console::FontchooserToggle] + } + bind Console [list ::tk::console::FontchooserFocus %W 1] + bind Console [list ::tk::console::FontchooserFocus %W 0] + } + AmpMenuArgs .menubar.edit add command -label [mc "&Increase Font Size"] \ + -accel "$mod++" -command {event generate .console <>} + AmpMenuArgs .menubar.edit add command -label [mc "&Decrease Font Size"] \ + -accel "$mod+-" -command {event generate .console <>} + AmpMenuArgs .menubar.edit add command -label [mc "Fit To Screen Width"] \ + -command {event generate .console <>} + + if {[tk windowingsystem] eq "aqua"} { + .menubar add cascade -label [mc Window] -menu [menu .menubar.window] + .menubar add cascade -label [mc Help] -menu [menu .menubar.help] + } + + . configure -menu .menubar + + # See if we can find a better font than the TkFixedFont + catch {font create TkConsoleFont {*}[font configure TkFixedFont]} + set families [font families] + switch -exact -- [tk windowingsystem] { + aqua { set preferred {Monaco 10} } + win32 { set preferred {ProFontWindows 8 Consolas 8} } + default { set preferred {} } + } + foreach {family size} $preferred { + if {$family in $families} { + font configure TkConsoleFont -family $family -size $size + break + } + } + + # Provide the right border for the text widget (platform dependent). + ::ttk::style layout ConsoleFrame { + Entry.field -sticky news -border 1 -children { + ConsoleFrame.padding -sticky news + } + } + ::ttk::frame .consoleframe -style ConsoleFrame + + set con [text .console -yscrollcommand [list .sb set] -setgrid true \ + -borderwidth 0 -highlightthickness 0 -font TkConsoleFont] + if {[tk windowingsystem] eq "aqua"} { + scrollbar .sb -command [list $con yview] + } else { + ::ttk::scrollbar .sb -command [list $con yview] + } + pack .sb -in .consoleframe -fill both -side right -padx 1 -pady 1 + pack $con -in .consoleframe -fill both -expand 1 -side left -padx 1 -pady 1 + pack .consoleframe -fill both -expand 1 -side left + + ConsoleBind $con + + $con tag configure stderr -foreground red + $con tag configure stdin -foreground blue + $con tag configure prompt -foreground \#8F4433 + $con tag configure proc -foreground \#008800 + $con tag configure var -background \#FFC0D0 + $con tag raise sel + $con tag configure blink -background \#FFFF00 + $con tag configure find -background \#FFFF00 + + focus $con + + # Avoid listing this console in [winfo interps] + if {[info command ::send] eq "::send"} {rename ::send {}} + + wm protocol . WM_DELETE_WINDOW { wm withdraw . } + wm title . [mc "Console"] + flush stdout + $con mark set output [$con index "end - 1 char"] + tk::TextSetCursor $con end + $con mark set promptEnd insert + $con mark gravity promptEnd left + + # A variant of ConsolePrompt to avoid a 'puts' call + set w $con + set temp [$w index "end - 1 char"] + $w mark set output end + if {![consoleinterp eval "info exists tcl_prompt1"]} { + set string [EvalAttached $::tk::console::defaultPrompt] + $w insert output $string stdout + } + $w mark set output $temp + ::tk::TextSetCursor $w end + $w mark set promptEnd insert + $w mark gravity promptEnd left + + if {[tk windowingsystem] ne "aqua"} { + # Subtle work-around to erase the '% ' that tclMain.c prints out + after idle [subst -nocommand { + if {[$con get 1.0 output] eq "% "} { $con delete 1.0 output } + }] + } +} + +# ::tk::ConsoleSource -- +# +# Prompts the user for a file to source in the main interpreter. +# +# Arguments: +# None. + +proc ::tk::ConsoleSource {} { + set filename [tk_getOpenFile -defaultextension .tcl -parent . \ + -title [mc "Select a file to source"] \ + -filetypes [list \ + [list [mc "Tcl Scripts"] .tcl] \ + [list [mc "All Files"] *]]] + if {$filename ne ""} { + set cmd [list source $filename] + if {[catch {consoleinterp eval $cmd} result]} { + ConsoleOutput stderr "$result\n" + } + } +} + +# ::tk::ConsoleInvoke -- +# Processes the command line input. If the command is complete it +# is evaled in the main interpreter. Otherwise, the continuation +# prompt is added and more input may be added. +# +# Arguments: +# None. + +proc ::tk::ConsoleInvoke {args} { + set ranges [.console tag ranges input] + set cmd "" + if {[llength $ranges]} { + set pos 0 + while {[lindex $ranges $pos] ne ""} { + set start [lindex $ranges $pos] + set end [lindex $ranges [incr pos]] + append cmd [.console get $start $end] + incr pos + } + } + if {$cmd eq ""} { + ConsolePrompt + } elseif {[info complete $cmd]} { + .console mark set output end + .console tag delete input + set result [consoleinterp record $cmd] + if {$result ne ""} { + puts $result + } + ConsoleHistory reset + ConsolePrompt + } else { + ConsolePrompt partial + } + .console yview -pickplace insert +} + +# ::tk::ConsoleHistory -- +# This procedure implements command line history for the +# console. In general is evals the history command in the +# main interpreter to obtain the history. The variable +# ::tk::HistNum is used to store the current location in the history. +# +# Arguments: +# cmd - Which action to take: prev, next, reset. + +set ::tk::HistNum 1 +proc ::tk::ConsoleHistory {cmd} { + variable HistNum + + switch $cmd { + prev { + incr HistNum -1 + if {$HistNum == 0} { + set cmd {history event [expr {[history nextid] -1}]} + } else { + set cmd "history event $HistNum" + } + if {[catch {consoleinterp eval $cmd} cmd]} { + incr HistNum + return + } + .console delete promptEnd end + .console insert promptEnd $cmd {input stdin} + .console see end + } + next { + incr HistNum + if {$HistNum == 0} { + set cmd {history event [expr {[history nextid] -1}]} + } elseif {$HistNum > 0} { + set cmd "" + set HistNum 1 + } else { + set cmd "history event $HistNum" + } + if {$cmd ne ""} { + catch {consoleinterp eval $cmd} cmd + } + .console delete promptEnd end + .console insert promptEnd $cmd {input stdin} + .console see end + } + reset { + set HistNum 1 + } + } +} + +# ::tk::ConsolePrompt -- +# This procedure draws the prompt. If tcl_prompt1 or tcl_prompt2 +# exists in the main interpreter it will be called to generate the +# prompt. Otherwise, a hard coded default prompt is printed. +# +# Arguments: +# partial - Flag to specify which prompt to print. + +proc ::tk::ConsolePrompt {{partial normal}} { + set w .console + if {$partial eq "normal"} { + set temp [$w index "end - 1 char"] + $w mark set output end + if {[consoleinterp eval "info exists tcl_prompt1"]} { + consoleinterp eval "eval \[set tcl_prompt1\]" + } else { + puts -nonewline [EvalAttached $::tk::console::defaultPrompt] + } + } else { + set temp [$w index output] + $w mark set output end + if {[consoleinterp eval "info exists tcl_prompt2"]} { + consoleinterp eval "eval \[set tcl_prompt2\]" + } else { + puts -nonewline "> " + } + } + flush stdout + $w mark set output $temp + ::tk::TextSetCursor $w end + $w mark set promptEnd insert + $w mark gravity promptEnd left + ::tk::console::ConstrainBuffer $w $::tk::console::maxLines + $w see end +} + +# Copy selected text from the console +proc ::tk::console::Copy {w} { + if {![catch {set data [$w get sel.first sel.last]}]} { + clipboard clear -displayof $w + clipboard append -displayof $w $data + } +} +# Copies selected text. If the selection is within the current active edit +# region then it will be cut, if not it is only copied. +proc ::tk::console::Cut {w} { + if {![catch {set data [$w get sel.first sel.last]}]} { + clipboard clear -displayof $w + clipboard append -displayof $w $data + if {[$w compare sel.first >= output]} { + $w delete sel.first sel.last + } + } +} +# Paste text from the clipboard +proc ::tk::console::Paste {w} { + catch { + set clip [::tk::GetSelection $w CLIPBOARD] + set list [split $clip \n\r] + tk::ConsoleInsert $w [lindex $list 0] + foreach x [lrange $list 1 end] { + $w mark set insert {end - 1c} + tk::ConsoleInsert $w "\n" + tk::ConsoleInvoke + tk::ConsoleInsert $w $x + } + } +} + +# Fit TkConsoleFont to window width +proc ::tk::console::FitScreenWidth {w} { + set width [winfo screenwidth $w] + set cwidth [$w cget -width] + set s -50 + set fit 0 + array set fi [font configure TkConsoleFont] + while {$s < 0} { + set fi(-size) $s + set f [font create {*}[array get fi]] + set c [font measure $f "eM"] + font delete $f + if {$c * $cwidth < 1.667 * $width} { + font configure TkConsoleFont -size $s + break + } + incr s 2 + } +} + +# ::tk::ConsoleBind -- +# This procedure first ensures that the default bindings for the Text +# class have been defined. Then certain bindings are overridden for +# the class. +# +# Arguments: +# None. + +proc ::tk::ConsoleBind {w} { + bindtags $w [list $w Console PostConsole [winfo toplevel $w] all] + + ## Get all Text bindings into Console + foreach ev [bind Text] { + bind Console $ev [bind Text $ev] + } + ## We really didn't want the newline insertion... + bind Console {} + ## ...or any Control-v binding (would block <>) + bind Console {} + + # For the moment, transpose isn't enabled until the console + # gets and overhaul of how it handles input -- hobbs + bind Console {} + + # Ignore all Alt, Meta, and Control keypresses unless explicitly bound. + # Otherwise, if a widget binding for one of these is defined, the + # class binding will also fire and insert the character + # which is wrong. + + bind Console {# nothing } + bind Console {# nothing} + bind Console {# nothing} + + foreach {ev key} { + <> + <> + <> + <> + + <> + <> + <> + <> + <> + <> + <> + <> + <> + + <> + <> + <> + <> + <> + <> + <> + } { + event add $ev $key + bind Console $key {} + } + if {[tk windowingsystem] eq "aqua"} { + foreach {ev key} { + <> + <> + } { + event add $ev $key + bind Console $key {} + } + if {$::tk::console::useFontchooser} { + bind Console [list ::tk::console::FontchooserToggle] + } + } + bind Console <> { + if {[%W compare insert > promptEnd]} { + ::tk::console::Expand %W + } + } + bind Console <> { + if {[%W compare insert > promptEnd]} { + ::tk::console::Expand %W path + } + } + bind Console <> { + if {[%W compare insert > promptEnd]} { + ::tk::console::Expand %W proc + } + } + bind Console <> { + if {[%W compare insert > promptEnd]} { + ::tk::console::Expand %W var + } + } + bind Console <> { + %W mark set insert {end - 1c} + tk::ConsoleInsert %W "\n" + tk::ConsoleInvoke + break + } + bind Console { + if {{} ne [%W tag nextrange sel 1.0 end] \ + && [%W compare sel.first >= promptEnd]} { + %W delete sel.first sel.last + } elseif {[%W compare insert >= promptEnd]} { + %W delete insert + %W see insert + } + } + bind Console { + if {{} ne [%W tag nextrange sel 1.0 end] \ + && [%W compare sel.first >= promptEnd]} { + %W delete sel.first sel.last + } elseif {[%W compare insert != 1.0] && \ + [%W compare insert > promptEnd]} { + %W delete insert-1c + %W see insert + } + } + bind Console [bind Console ] + + bind Console <> { + if {[%W compare insert < promptEnd]} { + tk::TextSetCursor %W {insert linestart} + } else { + tk::TextSetCursor %W promptEnd + } + } + bind Console <> { + tk::TextSetCursor %W {insert lineend} + } + bind Console { + if {[%W compare insert < promptEnd]} { + break + } + %W delete insert + } + bind Console <> { + if {[%W compare insert < promptEnd]} { + break + } + if {[%W compare insert == {insert lineend}]} { + %W delete insert + } else { + %W delete insert {insert lineend} + } + } + bind Console <> { + ## Clear console display + %W delete 1.0 "promptEnd linestart" + } + bind Console <> { + ## Clear command line (Unix shell staple) + %W delete promptEnd end + } + bind Console { + if {[%W compare insert >= promptEnd]} { + %W delete insert {insert wordend} + } + } + bind Console { + if {[%W compare {insert -1c wordstart} >= promptEnd]} { + %W delete {insert -1c wordstart} insert + } + } + bind Console { + if {[%W compare insert >= promptEnd]} { + %W delete insert {insert wordend} + } + } + bind Console { + if {[%W compare {insert -1c wordstart} >= promptEnd]} { + %W delete {insert -1c wordstart} insert + } + } + bind Console { + if {[%W compare insert >= promptEnd]} { + %W delete insert {insert wordend} + } + } + bind Console <> { + tk::ConsoleHistory prev + } + bind Console <> { + tk::ConsoleHistory next + } + bind Console { + catch {tk::ConsoleInsert %W [::tk::GetSelection %W PRIMARY]} + } + bind Console { + tk::ConsoleInsert %W %A + } + bind Console { + eval destroy [winfo child .] + source -encoding utf-8 [file join $tk_library console.tcl] + } + if {[tk windowingsystem] eq "aqua"} { + bind Console { + exit + } + } + bind Console <> { ::tk::console::Cut %W } + bind Console <> { ::tk::console::Copy %W } + bind Console <> { ::tk::console::Paste %W } + + bind Console <> { + set size [font configure TkConsoleFont -size] + if {$size < 0} {set sign -1} else {set sign 1} + set size [expr {(abs($size) + 1) * $sign}] + font configure TkConsoleFont -size $size + if {$::tk::console::useFontchooser} { + tk fontchooser configure -font TkConsoleFont + } + } + bind Console <> { + set size [font configure TkConsoleFont -size] + if {abs($size) < 2} { return } + if {$size < 0} {set sign -1} else {set sign 1} + set size [expr {(abs($size) - 1) * $sign}] + font configure TkConsoleFont -size $size + if {$::tk::console::useFontchooser} { + tk fontchooser configure -font TkConsoleFont + } + } + bind Console <> { + ::tk::console::FitScreenWidth %W + } + + ## + ## Bindings for doing special things based on certain keys + ## + bind PostConsole { + if {"\\" ne [%W get insert-2c]} { + ::tk::console::MatchPair %W \( \) promptEnd + } + } + bind PostConsole { + if {"\\" ne [%W get insert-2c]} { + ::tk::console::MatchPair %W \[ \] promptEnd + } + } + bind PostConsole { + if {"\\" ne [%W get insert-2c]} { + ::tk::console::MatchPair %W \{ \} promptEnd + } + } + bind PostConsole { + if {"\\" ne [%W get insert-2c]} { + ::tk::console::MatchQuote %W promptEnd + } + } + + bind PostConsole { + if {"%A" ne ""} { + ::tk::console::TagProc %W + } + } +} + +# ::tk::ConsoleInsert -- +# Insert a string into a text at the point of the insertion cursor. +# If there is a selection in the text, and it covers the point of the +# insertion cursor, then delete the selection before inserting. Insertion +# is restricted to the prompt area. +# +# Arguments: +# w - The text window in which to insert the string +# s - The string to insert (usually just a single character) + +proc ::tk::ConsoleInsert {w s} { + if {$s eq ""} { + return + } + catch { + if {[$w compare sel.first <= insert] \ + && [$w compare sel.last >= insert]} { + $w tag remove sel sel.first promptEnd + $w delete sel.first sel.last + } + } + if {[$w compare insert < promptEnd]} { + $w mark set insert end + } + $w insert insert $s {input stdin} + $w see insert +} + +# ::tk::ConsoleOutput -- +# +# This routine is called directly by ConsolePutsCmd to cause a string +# to be displayed in the console. +# +# Arguments: +# dest - The output tag to be used: either "stderr" or "stdout". +# string - The string to be displayed. + +proc ::tk::ConsoleOutput {dest string} { + set w .console + $w insert output $string $dest + ::tk::console::ConstrainBuffer $w $::tk::console::maxLines + $w see insert +} + +# ::tk::ConsoleExit -- +# +# This routine is called by ConsoleEventProc when the main window of +# the application is destroyed. Don't call exit - that probably already +# happened. Just delete our window. +# +# Arguments: +# None. + +proc ::tk::ConsoleExit {} { + destroy . +} + +# ::tk::ConsoleAbout -- +# +# This routine displays an About box to show Tcl/Tk version info. +# +# Arguments: +# None. + +proc ::tk::ConsoleAbout {} { + tk_messageBox -type ok -message "[mc {Tcl for Windows}] + +Tcl $::tcl_patchLevel +Tk $::tk_patchLevel" +} + +# ::tk::console::Fontchooser* -- +# Let the user select the console font (TIP 324). + +proc ::tk::console::FontchooserToggle {} { + if {[tk fontchooser configure -visible]} { + tk fontchooser hide + } else { + tk fontchooser show + } +} +proc ::tk::console::FontchooserVisibility {index} { + if {[tk fontchooser configure -visible]} { + .menubar.edit entryconfigure $index -label [::tk::msgcat::mc "Hide Fonts"] + } else { + .menubar.edit entryconfigure $index -label [::tk::msgcat::mc "Show Fonts"] + } +} +proc ::tk::console::FontchooserFocus {w isFocusIn} { + if {$isFocusIn} { + tk fontchooser configure -parent $w -font TkConsoleFont \ + -command [namespace code [list FontchooserApply]] + } else { + tk fontchooser configure -parent $w -font {} -command {} + } +} +proc ::tk::console::FontchooserApply {font args} { + catch {font configure TkConsoleFont {*}[font actual $font]} +} + +# ::tk::console::TagProc -- +# +# Tags a procedure in the console if it's recognized +# This procedure is not perfect. However, making it perfect wastes +# too much CPU time... +# +# Arguments: +# w - console text widget + +proc ::tk::console::TagProc w { + if {!$::tk::console::magicKeys} { + return + } + set exp "\[^\\\\\]\[\[ \t\n\r\;{}\"\$\]" + set i [$w search -backwards -regexp $exp insert-1c promptEnd-1c] + if {$i eq ""} { + set i promptEnd + } else { + append i +2c + } + regsub -all "\[\[\\\\\\?\\*\]" [$w get $i "insert-1c wordend"] {\\\0} c + if {[llength [EvalAttached [list info commands $c]]]} { + $w tag add proc $i "insert-1c wordend" + } else { + $w tag remove proc $i "insert-1c wordend" + } + if {[llength [EvalAttached [list info vars $c]]]} { + $w tag add var $i "insert-1c wordend" + } else { + $w tag remove var $i "insert-1c wordend" + } +} + +# ::tk::console::MatchPair -- +# +# Blinks a matching pair of characters +# c2 is assumed to be at the text index 'insert'. +# This proc is really loopy and took me an hour to figure out given +# all possible combinations with escaping except for escaped \'s. +# It doesn't take into account possible commenting... Oh well. If +# anyone has something better, I'd like to see/use it. This is really +# only efficient for small contexts. +# +# Arguments: +# w - console text widget +# c1 - first char of pair +# c2 - second char of pair +# +# Calls: ::tk::console::Blink + +proc ::tk::console::MatchPair {w c1 c2 {lim 1.0}} { + if {!$::tk::console::magicKeys} { + return + } + if {{} ne [set ix [$w search -back $c1 insert $lim]]} { + while { + [string match {\\} [$w get $ix-1c]] && + [set ix [$w search -back $c1 $ix-1c $lim]] ne {} + } {} + set i1 insert-1c + while {$ix ne {}} { + set i0 $ix + set j 0 + while {[set i0 [$w search $c2 $i0 $i1]] ne {}} { + append i0 +1c + if {[string match {\\} [$w get $i0-2c]]} { + continue + } + incr j + } + if {!$j} { + break + } + set i1 $ix + while {$j && [set ix [$w search -back $c1 $ix $lim]] ne {}} { + if {[string match {\\} [$w get $ix-1c]]} { + continue + } + incr j -1 + } + } + if {[string match {} $ix]} { + set ix [$w index $lim] + } + } else { + set ix [$w index $lim] + } + if {$::tk::console::blinkRange} { + Blink $w $ix [$w index insert] + } else { + Blink $w $ix $ix+1c [$w index insert-1c] [$w index insert] + } +} + +# ::tk::console::MatchQuote -- +# +# Blinks between matching quotes. +# Blinks just the quote if it's unmatched, otherwise blinks quoted string +# The quote to match is assumed to be at the text index 'insert'. +# +# Arguments: +# w - console text widget +# +# Calls: ::tk::console::Blink + +proc ::tk::console::MatchQuote {w {lim 1.0}} { + if {!$::tk::console::magicKeys} { + return + } + set i insert-1c + set j 0 + while {[set i [$w search -back \" $i $lim]] ne {}} { + if {[string match {\\} [$w get $i-1c]]} { + continue + } + if {!$j} { + set i0 $i + } + incr j + } + if {$j&1} { + if {$::tk::console::blinkRange} { + Blink $w $i0 [$w index insert] + } else { + Blink $w $i0 $i0+1c [$w index insert-1c] [$w index insert] + } + } else { + Blink $w [$w index insert-1c] [$w index insert] + } +} + +# ::tk::console::Blink -- +# +# Blinks between n index pairs for a specified duration. +# +# Arguments: +# w - console text widget +# i1 - start index to blink region +# i2 - end index of blink region +# dur - duration in usecs to blink for +# +# Outputs: +# blinks selected characters in $w + +proc ::tk::console::Blink {w args} { + eval [list $w tag add blink] $args + after $::tk::console::blinkTime [list $w] tag remove blink $args +} + +# ::tk::console::ConstrainBuffer -- +# +# This limits the amount of data in the text widget +# Called by Prompt and ConsoleOutput +# +# Arguments: +# w - console text widget +# size - # of lines to constrain to +# +# Outputs: +# may delete data in console widget + +proc ::tk::console::ConstrainBuffer {w size} { + if {[$w index end] > $size} { + $w delete 1.0 [expr {int([$w index end])-$size}].0 + } +} + +# ::tk::console::Expand -- +# +# Arguments: +# ARGS: w - text widget in which to expand str +# type - type of expansion (path / proc / variable) +# +# Calls: ::tk::console::Expand(Pathname|Procname|Variable) +# +# Outputs: The string to match is expanded to the longest possible match. +# If ::tk::console::showMatches is non-zero and the longest match +# equaled the string to expand, then all possible matches are +# output to stdout. Triggers bell if no matches are found. +# +# Returns: number of matches found + +proc ::tk::console::Expand {w {type ""}} { + set exp "\[^\\\\\]\[\[ \t\n\r\\\{\"\\\\\$\]" + set tmp [$w search -backwards -regexp $exp insert-1c promptEnd-1c] + if {$tmp eq ""} { + set tmp promptEnd + } else { + append tmp +2c + } + if {[$w compare $tmp >= insert]} { + return + } + set str [$w get $tmp insert] + switch -glob $type { + path* { + set res [ExpandPathname $str] + } + proc* { + set res [ExpandProcname $str] + } + var* { + set res [ExpandVariable $str] + } + default { + set res {} + foreach t {Pathname Procname Variable} { + if {![catch {Expand$t $str} res] && ($res ne "")} { + break + } + } + } + } + set len [llength $res] + if {$len} { + set repl [lindex $res 0] + $w delete $tmp insert + $w insert $tmp $repl {input stdin} + if {($len > 1) && ($::tk::console::showMatches) && ($repl eq $str)} { + puts stdout [lsort [lreplace $res 0 0]] + } + } else { + bell + } + return [incr len -1] +} + +# ::tk::console::ExpandPathname -- +# +# Expand a file pathname based on $str +# This is based on UNIX file name conventions +# +# Arguments: +# str - partial file pathname to expand +# +# Calls: ::tk::console::ExpandBestMatch +# +# Returns: list containing longest unique match followed by all the +# possible further matches + +proc ::tk::console::ExpandPathname str { + set pwd [EvalAttached pwd] + if {[catch {EvalAttached [list cd [file dirname $str]]} err opt]} { + return -options $opt $err + } + set dir [file tail $str] + ## Check to see if it was known to be a directory and keep the trailing + ## slash if so (file tail cuts it off) + if {[string match */ $str]} { + append dir / + } + if {[catch {lsort [EvalAttached [list glob $dir*]]} m]} { + set match {} + } else { + if {[llength $m] > 1} { + if { $::tcl_platform(platform) eq "windows" } { + ## Windows is screwy because it's case insensitive + set tmp [ExpandBestMatch [string tolower $m] \ + [string tolower $dir]] + ## Don't change case if we haven't changed the word + if {[string length $dir]==[string length $tmp]} { + set tmp $dir + } + } else { + set tmp [ExpandBestMatch $m $dir] + } + if {[string match ?*/* $str]} { + set tmp [file dirname $str]/$tmp + } elseif {[string match /* $str]} { + set tmp /$tmp + } + regsub -all { } $tmp {\\ } tmp + set match [linsert $m 0 $tmp] + } else { + ## This may look goofy, but it handles spaces in path names + eval append match $m + if {[file isdir $match]} { + append match / + } + if {[string match ?*/* $str]} { + set match [file dirname $str]/$match + } elseif {[string match /* $str]} { + set match /$match + } + regsub -all { } $match {\\ } match + ## Why is this one needed and the ones below aren't!! + set match [list $match] + } + } + EvalAttached [list cd $pwd] + return $match +} + +# ::tk::console::ExpandProcname -- +# +# Expand a tcl proc name based on $str +# +# Arguments: +# str - partial proc name to expand +# +# Calls: ::tk::console::ExpandBestMatch +# +# Returns: list containing longest unique match followed by all the +# possible further matches + +proc ::tk::console::ExpandProcname str { + set match [EvalAttached [list info commands $str*]] + if {[llength $match] == 0} { + set ns [EvalAttached \ + "namespace children \[namespace current\] [list $str*]"] + if {[llength $ns]==1} { + set match [EvalAttached [list info commands ${ns}::*]] + } else { + set match $ns + } + } + if {[llength $match] > 1} { + regsub -all { } [ExpandBestMatch $match $str] {\\ } str + set match [linsert $match 0 $str] + } else { + regsub -all { } $match {\\ } match + } + return $match +} + +# ::tk::console::ExpandVariable -- +# +# Expand a tcl variable name based on $str +# +# Arguments: +# str - partial tcl var name to expand +# +# Calls: ::tk::console::ExpandBestMatch +# +# Returns: list containing longest unique match followed by all the +# possible further matches + +proc ::tk::console::ExpandVariable str { + if {[regexp {([^\(]*)\((.*)} $str -> ary str]} { + ## Looks like they're trying to expand an array. + set match [EvalAttached [list array names $ary $str*]] + if {[llength $match] > 1} { + set vars $ary\([ExpandBestMatch $match $str] + foreach var $match { + lappend vars $ary\($var\) + } + return $vars + } elseif {[llength $match] == 1} { + set match $ary\($match\) + } + ## Space transformation avoided for array names. + } else { + set match [EvalAttached [list info vars $str*]] + if {[llength $match] > 1} { + regsub -all { } [ExpandBestMatch $match $str] {\\ } str + set match [linsert $match 0 $str] + } else { + regsub -all { } $match {\\ } match + } + } + return $match +} + +# ::tk::console::ExpandBestMatch -- +# +# Finds the best unique match in a list of names. +# The extra $e in this argument allows us to limit the innermost loop a little +# further. This improves speed as $l becomes large or $e becomes long. +# +# Arguments: +# l - list to find best unique match in +# e - currently best known unique match +# +# Returns: longest unique match in the list + +proc ::tk::console::ExpandBestMatch {l {e {}}} { + set ec [lindex $l 0] + if {[llength $l]>1} { + set e [expr {[string length $e] - 1}] + set ei [expr {[string length $ec] - 1}] + foreach l $l { + while {$ei>=$e && [string first $ec $l]} { + set ec [string range $ec 0 [incr ei -1]] + } + } + } + return $ec +} + +# now initialize the console +::tk::ConsoleInit diff --git a/XSchemWin/Installer/binary_template/lib/tk8.6/dialog.tcl b/XSchemWin/Installer/binary_template/lib/tk8.6/dialog.tcl new file mode 100644 index 00000000..a099d900 --- /dev/null +++ b/XSchemWin/Installer/binary_template/lib/tk8.6/dialog.tcl @@ -0,0 +1,175 @@ +# dialog.tcl -- +# +# This file defines the procedure tk_dialog, which creates a dialog +# box containing a bitmap, a message, and one or more buttons. +# +# Copyright (c) 1992-1993 The Regents of the University of California. +# Copyright (c) 1994-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. +# + +# +# ::tk_dialog: +# +# This procedure displays a dialog box, waits for a button in the dialog +# to be invoked, then returns the index of the selected button. If the +# dialog somehow gets destroyed, -1 is returned. +# +# Arguments: +# w - Window to use for dialog top-level. +# title - Title to display in dialog's decorative frame. +# text - Message to display in dialog. +# bitmap - Bitmap to display in dialog (empty string means none). +# default - Index of button that is to display the default ring +# (-1 means none). +# args - One or more strings to display in buttons across the +# bottom of the dialog box. + +proc ::tk_dialog {w title text bitmap default args} { + variable ::tk::Priv + + # Check that $default was properly given + if {[string is integer -strict $default]} { + if {$default >= [llength $args]} { + return -code error -errorcode {TK DIALOG BAD_DEFAULT} \ + "default button index greater than number of buttons\ + specified for tk_dialog" + } + } elseif {"" eq $default} { + set default -1 + } else { + set default [lsearch -exact $args $default] + } + + set windowingsystem [tk windowingsystem] + + # 1. Create the top-level window and divide it into top + # and bottom parts. + + destroy $w + toplevel $w -class Dialog + wm title $w $title + wm iconname $w Dialog + wm protocol $w WM_DELETE_WINDOW { } + + # Dialog boxes should be transient with respect to their parent, + # so that they will always stay on top of their parent window. However, + # some window managers will create the window as withdrawn if the parent + # window is withdrawn or iconified. Combined with the grab we put on the + # window, this can hang the entire application. Therefore we only make + # the dialog transient if the parent is viewable. + # + if {[winfo viewable [winfo toplevel [winfo parent $w]]] } { + wm transient $w [winfo toplevel [winfo parent $w]] + } + + if {$windowingsystem eq "aqua"} { + ::tk::unsupported::MacWindowStyle style $w moveableModal {} + } elseif {$windowingsystem eq "x11"} { + wm attributes $w -type dialog + } + + frame $w.bot + frame $w.top + if {$windowingsystem eq "x11"} { + $w.bot configure -relief raised -bd 1 + $w.top configure -relief raised -bd 1 + } + pack $w.bot -side bottom -fill both + pack $w.top -side top -fill both -expand 1 + grid anchor $w.bot center + + # 2. Fill the top part with bitmap and message (use the option + # database for -wraplength and -font so that they can be + # overridden by the caller). + + option add *Dialog.msg.wrapLength 3i widgetDefault + option add *Dialog.msg.font TkCaptionFont widgetDefault + + label $w.msg -justify left -text $text + pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m + if {$bitmap ne ""} { + if {$windowingsystem eq "aqua" && $bitmap eq "error"} { + set bitmap "stop" + } + label $w.bitmap -bitmap $bitmap + pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m + } + + # 3. Create a row of buttons at the bottom of the dialog. + + set i 0 + foreach but $args { + button $w.button$i -text $but -command [list set ::tk::Priv(button) $i] + if {$i == $default} { + $w.button$i configure -default active + } else { + $w.button$i configure -default normal + } + grid $w.button$i -in $w.bot -column $i -row 0 -sticky ew \ + -padx 10 -pady 4 + grid columnconfigure $w.bot $i + # We boost the size of some Mac buttons for l&f + if {$windowingsystem eq "aqua"} { + set tmp [string tolower $but] + if {$tmp eq "ok" || $tmp eq "cancel"} { + grid columnconfigure $w.bot $i -minsize 90 + } + grid configure $w.button$i -pady 7 + } + incr i + } + + # 4. Create a binding for on the dialog if there is a + # default button. + # Convention also dictates that if the keyboard focus moves among the + # the buttons that the binding affects the button with the focus. + + if {$default >= 0} { + bind $w [list $w.button$default invoke] + } + bind $w <> [list bind $w {[tk_focusPrev %W] invoke}] + bind $w <> [list bind $w {[tk_focusNext %W] invoke}] + + # 5. Create a binding for the window that sets the + # button variable to -1; this is needed in case something happens + # that destroys the window, such as its parent window being destroyed. + + bind $w {set ::tk::Priv(button) -1} + + # 6. Withdraw the window, then update all the geometry information + # so we know how big it wants to be, then center the window in the + # display (Motif style) and de-iconify it. + + ::tk::PlaceWindow $w + tkwait visibility $w + + # 7. Set a grab and claim the focus too. + + if {$default >= 0} { + set focus $w.button$default + } else { + set focus $w + } + tk::SetFocusGrab $w $focus + + # 8. Wait for the user to respond, then restore the focus and + # return the index of the selected button. Restore the focus + # before deleting the window, since otherwise the window manager + # may take the focus away so we can't redirect it. Finally, + # restore any grab that was in effect. + + vwait ::tk::Priv(button) + + catch { + # It's possible that the window has already been destroyed, + # hence this "catch". Delete the Destroy handler so that + # Priv(button) doesn't get reset by it. + + bind $w {} + } + tk::RestoreFocusGrab $w $focus + return $Priv(button) +} diff --git a/XSchemWin/Installer/binary_template/lib/tk8.6/entry.tcl b/XSchemWin/Installer/binary_template/lib/tk8.6/entry.tcl new file mode 100644 index 00000000..6539af77 --- /dev/null +++ b/XSchemWin/Installer/binary_template/lib/tk8.6/entry.tcl @@ -0,0 +1,686 @@ +# entry.tcl -- +# +# This file defines the default bindings for Tk entry widgets and provides +# procedures that help in implementing those bindings. +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994-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. +# + +#------------------------------------------------------------------------- +# Elements of tk::Priv that are used in this file: +# +# afterId - If non-null, it means that auto-scanning is underway +# and it gives the "after" id for the next auto-scan +# command to be executed. +# mouseMoved - Non-zero means the mouse has moved a significant +# amount since the button went down (so, for example, +# start dragging out a selection). +# pressX - X-coordinate at which the mouse button was pressed. +# selectMode - The style of selection currently underway: +# char, word, or line. +# x, y - Last known mouse coordinates for scanning +# and auto-scanning. +# data - Used for Cut and Copy +#------------------------------------------------------------------------- + +#------------------------------------------------------------------------- +# The code below creates the default class bindings for entries. +#------------------------------------------------------------------------- +bind Entry <> { + if {![catch {tk::EntryGetSelection %W} tk::Priv(data)]} { + clipboard clear -displayof %W + clipboard append -displayof %W $tk::Priv(data) + %W delete sel.first sel.last + unset tk::Priv(data) + } +} +bind Entry <> { + if {![catch {tk::EntryGetSelection %W} tk::Priv(data)]} { + clipboard clear -displayof %W + clipboard append -displayof %W $tk::Priv(data) + unset tk::Priv(data) + } +} +bind Entry <> { + catch { + if {[tk windowingsystem] ne "x11"} { + catch { + %W delete sel.first sel.last + } + } + %W insert insert [::tk::GetSelection %W CLIPBOARD] + tk::EntrySeeInsert %W + } +} +bind Entry <> { + # ignore if there is no selection + catch {%W delete sel.first sel.last} +} +bind Entry <> { + if {$tk_strictMotif || ![info exists tk::Priv(mouseMoved)] + || !$tk::Priv(mouseMoved)} { + tk::EntryPaste %W %x + } +} + +bind Entry <> { + %W selection range 0 end + %W icursor end +} + +# Standard Motif bindings: + +bind Entry { + tk::EntryButton1 %W %x + %W selection clear +} +bind Entry { + set tk::Priv(x) %x + tk::EntryMouseSelect %W %x +} +bind Entry { + set tk::Priv(selectMode) word + tk::EntryMouseSelect %W %x + catch {%W icursor sel.last} +} +bind Entry { + set tk::Priv(selectMode) line + tk::EntryMouseSelect %W %x + catch {%W icursor sel.last} +} +bind Entry { + set tk::Priv(selectMode) char + %W selection adjust @%x +} +bind Entry { + set tk::Priv(selectMode) word + tk::EntryMouseSelect %W %x +} +bind Entry { + set tk::Priv(selectMode) line + tk::EntryMouseSelect %W %x +} +bind Entry { + set tk::Priv(x) %x + tk::EntryAutoScan %W +} +bind Entry { + tk::CancelRepeat +} +bind Entry { + tk::CancelRepeat +} +bind Entry { + %W icursor @%x +} + +bind Entry <> { + tk::EntrySetCursor %W [expr {[%W index insert]-1}] +} +bind Entry <> { + tk::EntrySetCursor %W [expr {[%W index insert]+1}] +} +bind Entry <> { + tk::EntryKeySelect %W [expr {[%W index insert]-1}] + tk::EntrySeeInsert %W +} +bind Entry <> { + tk::EntryKeySelect %W [expr {[%W index insert]+1}] + tk::EntrySeeInsert %W +} +bind Entry <> { + tk::EntrySetCursor %W [tk::EntryPreviousWord %W insert] +} +bind Entry <> { + tk::EntrySetCursor %W [tk::EntryNextWord %W insert] +} +bind Entry <> { + tk::EntryKeySelect %W [tk::EntryPreviousWord %W insert] + tk::EntrySeeInsert %W +} +bind Entry <> { + tk::EntryKeySelect %W [tk::EntryNextWord %W insert] + tk::EntrySeeInsert %W +} +bind Entry <> { + tk::EntrySetCursor %W 0 +} +bind Entry <> { + tk::EntryKeySelect %W 0 + tk::EntrySeeInsert %W +} +bind Entry <> { + tk::EntrySetCursor %W end +} +bind Entry <> { + tk::EntryKeySelect %W end + tk::EntrySeeInsert %W +} + +bind Entry { + if {[%W selection present]} { + %W delete sel.first sel.last + } else { + %W delete insert + } +} +bind Entry { + tk::EntryBackspace %W +} + +bind Entry { + %W selection from insert +} +bind Entry { + tk::ListboxBeginSelect %W [%W index active] +} +bind Listbox { + tk::ListboxBeginExtend %W [%W index active] +} +bind Listbox { + tk::ListboxBeginExtend %W [%W index active] +} +bind Listbox { + tk::ListboxCancel %W +} +bind Listbox <> { + tk::ListboxSelectAll %W +} +bind Listbox <> { + if {[%W cget -selectmode] ne "browse"} { + %W selection clear 0 end + tk::FireListboxSelectEvent %W + } +} + +# Additional Tk bindings that aren't part of the Motif look and feel: + +bind Listbox <2> { + %W scan mark %x %y +} +bind Listbox { + %W scan dragto %x %y +} + +# The MouseWheel will typically only fire on Windows and Mac OS X. +# However, someone could use the "event generate" command to produce +# one on other platforms. + +if {[tk windowingsystem] eq "aqua"} { + bind Listbox { + %W yview scroll [expr {-(%D)}] units + } + bind Listbox { + %W yview scroll [expr {-10 * (%D)}] units + } + bind Listbox { + %W xview scroll [expr {-(%D)}] units + } + bind Listbox { + %W xview scroll [expr {-10 * (%D)}] units + } +} else { + bind Listbox { + if {%D >= 0} { + %W yview scroll [expr {-%D/30}] units + } else { + %W yview scroll [expr {(29-%D)/30}] units + } + } + bind Listbox { + if {%D >= 0} { + %W xview scroll [expr {-%D/30}] units + } else { + %W xview scroll [expr {(29-%D)/30}] units + } + } +} + +if {[tk windowingsystem] eq "x11"} { + # Support for mousewheels on Linux/Unix commonly comes through mapping + # the wheel to the extended buttons. If you have a mousewheel, find + # Linux configuration info at: + # http://linuxreviews.org/howtos/xfree/mouse/ + bind Listbox <4> { + if {!$tk_strictMotif} { + %W yview scroll -5 units + } + } + bind Listbox { + if {!$tk_strictMotif} { + %W xview scroll -5 units + } + } + bind Listbox <5> { + if {!$tk_strictMotif} { + %W yview scroll 5 units + } + } + bind Listbox { + if {!$tk_strictMotif} { + %W xview scroll 5 units + } + } +} + +# ::tk::ListboxBeginSelect -- +# +# This procedure is typically invoked on button-1 presses. It begins +# the process of making a selection in the listbox. Its exact behavior +# depends on the selection mode currently in effect for the listbox; +# see the Motif documentation for details. +# +# Arguments: +# w - The listbox widget. +# el - The element for the selection operation (typically the +# one under the pointer). Must be in numerical form. + +proc ::tk::ListboxBeginSelect {w el {focus 1}} { + variable ::tk::Priv + if {[$w cget -selectmode] eq "multiple"} { + if {[$w selection includes $el]} { + $w selection clear $el + } else { + $w selection set $el + } + } else { + $w selection clear 0 end + $w selection set $el + $w selection anchor $el + set Priv(listboxSelection) {} + set Priv(listboxPrev) $el + } + tk::FireListboxSelectEvent $w + # check existence as ListboxSelect may destroy us + if {$focus && [winfo exists $w] && [$w cget -state] eq "normal"} { + focus $w + } +} + +# ::tk::ListboxMotion -- +# +# This procedure is called to process mouse motion events while +# button 1 is down. It may move or extend the selection, depending +# on the listbox's selection mode. +# +# Arguments: +# w - The listbox widget. +# el - The element under the pointer (must be a number). + +proc ::tk::ListboxMotion {w el} { + variable ::tk::Priv + if {$el == $Priv(listboxPrev)} { + return + } + set anchor [$w index anchor] + switch [$w cget -selectmode] { + browse { + $w selection clear 0 end + $w selection set $el + set Priv(listboxPrev) $el + tk::FireListboxSelectEvent $w + } + extended { + set i $Priv(listboxPrev) + if {$i eq ""} { + set i $el + $w selection set $el + } + if {[$w selection includes anchor]} { + $w selection clear $i $el + $w selection set anchor $el + } else { + $w selection clear $i $el + $w selection clear anchor $el + } + if {![info exists Priv(listboxSelection)]} { + set Priv(listboxSelection) [$w curselection] + } + while {($i < $el) && ($i < $anchor)} { + if {$i in $Priv(listboxSelection)} { + $w selection set $i + } + incr i + } + while {($i > $el) && ($i > $anchor)} { + if {$i in $Priv(listboxSelection)} { + $w selection set $i + } + incr i -1 + } + set Priv(listboxPrev) $el + tk::FireListboxSelectEvent $w + } + } +} + +# ::tk::ListboxBeginExtend -- +# +# This procedure is typically invoked on shift-button-1 presses. It +# begins the process of extending a selection in the listbox. Its +# exact behavior depends on the selection mode currently in effect +# for the listbox; see the Motif documentation for details. +# +# Arguments: +# w - The listbox widget. +# el - The element for the selection operation (typically the +# one under the pointer). Must be in numerical form. + +proc ::tk::ListboxBeginExtend {w el} { + if {[$w cget -selectmode] eq "extended"} { + if {[$w selection includes anchor]} { + ListboxMotion $w $el + } else { + # No selection yet; simulate the begin-select operation. + ListboxBeginSelect $w $el + } + } +} + +# ::tk::ListboxBeginToggle -- +# +# This procedure is typically invoked on control-button-1 presses. It +# begins the process of toggling a selection in the listbox. Its +# exact behavior depends on the selection mode currently in effect +# for the listbox; see the Motif documentation for details. +# +# Arguments: +# w - The listbox widget. +# el - The element for the selection operation (typically the +# one under the pointer). Must be in numerical form. + +proc ::tk::ListboxBeginToggle {w el} { + variable ::tk::Priv + if {[$w cget -selectmode] eq "extended"} { + set Priv(listboxSelection) [$w curselection] + set Priv(listboxPrev) $el + $w selection anchor $el + if {[$w selection includes $el]} { + $w selection clear $el + } else { + $w selection set $el + } + tk::FireListboxSelectEvent $w + } +} + +# ::tk::ListboxAutoScan -- +# This procedure is invoked when the mouse leaves an entry window +# with button 1 down. It scrolls the window up, down, left, or +# right, depending on where the mouse left the window, and reschedules +# itself as an "after" command so that the window continues to scroll until +# the mouse moves back into the window or the mouse button is released. +# +# Arguments: +# w - The entry window. + +proc ::tk::ListboxAutoScan {w} { + variable ::tk::Priv + if {![winfo exists $w]} return + set x $Priv(x) + set y $Priv(y) + if {$y >= [winfo height $w]} { + $w yview scroll 1 units + } elseif {$y < 0} { + $w yview scroll -1 units + } elseif {$x >= [winfo width $w]} { + $w xview scroll 2 units + } elseif {$x < 0} { + $w xview scroll -2 units + } else { + return + } + ListboxMotion $w [$w index @$x,$y] + set Priv(afterId) [after 50 [list tk::ListboxAutoScan $w]] +} + +# ::tk::ListboxUpDown -- +# +# Moves the location cursor (active element) up or down by one element, +# and changes the selection if we're in browse or extended selection +# mode. +# +# Arguments: +# w - The listbox widget. +# amount - +1 to move down one item, -1 to move back one item. + +proc ::tk::ListboxUpDown {w amount} { + variable ::tk::Priv + $w activate [expr {[$w index active] + $amount}] + $w see active + switch [$w cget -selectmode] { + browse { + $w selection clear 0 end + $w selection set active + tk::FireListboxSelectEvent $w + } + extended { + $w selection clear 0 end + $w selection set active + $w selection anchor active + set Priv(listboxPrev) [$w index active] + set Priv(listboxSelection) {} + tk::FireListboxSelectEvent $w + } + } +} + +# ::tk::ListboxExtendUpDown -- +# +# Does nothing unless we're in extended selection mode; in this +# case it moves the location cursor (active element) up or down by +# one element, and extends the selection to that point. +# +# Arguments: +# w - The listbox widget. +# amount - +1 to move down one item, -1 to move back one item. + +proc ::tk::ListboxExtendUpDown {w amount} { + variable ::tk::Priv + if {[$w cget -selectmode] ne "extended"} { + return + } + set active [$w index active] + if {![info exists Priv(listboxSelection)]} { + $w selection set $active + set Priv(listboxSelection) [$w curselection] + } + $w activate [expr {$active + $amount}] + $w see active + ListboxMotion $w [$w index active] +} + +# ::tk::ListboxDataExtend +# +# This procedure is called for key-presses such as Shift-KEndData. +# If the selection mode isn't multiple or extend then it does nothing. +# Otherwise it moves the active element to el and, if we're in +# extended mode, extends the selection to that point. +# +# Arguments: +# w - The listbox widget. +# el - An integer element number. + +proc ::tk::ListboxDataExtend {w el} { + set mode [$w cget -selectmode] + if {$mode eq "extended"} { + $w activate $el + $w see $el + if {[$w selection includes anchor]} { + ListboxMotion $w $el + } + } elseif {$mode eq "multiple"} { + $w activate $el + $w see $el + } +} + +# ::tk::ListboxCancel +# +# This procedure is invoked to cancel an extended selection in +# progress. If there is an extended selection in progress, it +# restores all of the items between the active one and the anchor +# to their previous selection state. +# +# Arguments: +# w - The listbox widget. + +proc ::tk::ListboxCancel w { + variable ::tk::Priv + if {[$w cget -selectmode] ne "extended"} { + return + } + set first [$w index anchor] + set last $Priv(listboxPrev) + if {$last eq ""} { + # Not actually doing any selection right now + return + } + if {$first > $last} { + set tmp $first + set first $last + set last $tmp + } + $w selection clear $first $last + while {$first <= $last} { + if {$first in $Priv(listboxSelection)} { + $w selection set $first + } + incr first + } + tk::FireListboxSelectEvent $w +} + +# ::tk::ListboxSelectAll +# +# This procedure is invoked to handle the "select all" operation. +# For single and browse mode, it just selects the active element. +# Otherwise it selects everything in the widget. +# +# Arguments: +# w - The listbox widget. + +proc ::tk::ListboxSelectAll w { + set mode [$w cget -selectmode] + if {$mode eq "single" || $mode eq "browse"} { + $w selection clear 0 end + $w selection set active + } else { + $w selection set 0 end + } + tk::FireListboxSelectEvent $w +} + +# ::tk::FireListboxSelectEvent +# +# Fire the <> event if the listbox is not in disabled +# state. +# +# Arguments: +# w - The listbox widget. + +proc ::tk::FireListboxSelectEvent w { + if {[$w cget -state] eq "normal"} { + event generate $w <> + } +} diff --git a/XSchemWin/Installer/binary_template/lib/tk8.6/megawidget.tcl b/XSchemWin/Installer/binary_template/lib/tk8.6/megawidget.tcl new file mode 100644 index 00000000..ec9f469a --- /dev/null +++ b/XSchemWin/Installer/binary_template/lib/tk8.6/megawidget.tcl @@ -0,0 +1,297 @@ +# megawidget.tcl +# +# Basic megawidget support classes. Experimental for any use other than +# the ::tk::IconList megawdget, which is itself only designed for use in +# the Unix file dialogs. +# +# Copyright (c) 2009-2010 Donal K. Fellows +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +package require Tk + +::oo::class create ::tk::Megawidget { + superclass ::oo::class + method unknown {w args} { + if {[string match .* $w]} { + [self] create $w {*}$args + return $w + } + next $w {*}$args + } + unexport new unknown + self method create {name superclasses body} { + next $name [list \ + superclass ::tk::MegawidgetClass {*}$superclasses]\;$body + } +} + +::oo::class create ::tk::MegawidgetClass { + variable w hull options IdleCallbacks + constructor args { + # Extract the "widget name" from the object name + set w [namespace tail [self]] + + # Configure things + tclParseConfigSpec [my varname options] [my GetSpecs] "" $args + + # Move the object out of the way of the hull widget + rename [self] _tmp + + # Make the hull widget(s) + my CreateHull + bind $hull [list [namespace which my] destroy] + + # Rename things into their final places + rename ::$w theWidget + rename [self] ::$w + + # Make the contents + my Create + } + destructor { + foreach {name cb} [array get IdleCallbacks] { + after cancel $cb + unset IdleCallbacks($name) + } + if {[winfo exists $w]} { + bind $hull {} + destroy $w + } + } + + #################################################################### + # + # MegawidgetClass::configure -- + # + # Implementation of 'configure' for megawidgets. Emulates the operation + # of the standard Tk configure method fairly closely, which makes things + # substantially more complex than they otherwise would be. + # + # This method assumes that the 'GetSpecs' method returns a description + # of all the specifications of the options (i.e., as Tk returns except + # with the actual values removed). It also assumes that the 'options' + # array in the class holds all options; it is up to subclasses to set + # traces on that array if they want to respond to configuration changes. + # + # TODO: allow unambiguous abbreviations. + # + method configure args { + # Configure behaves differently depending on the number of arguments + set argc [llength $args] + if {$argc == 0} { + return [lmap spec [my GetSpecs] { + lappend spec $options([lindex $spec 0]) + }] + } elseif {$argc == 1} { + set opt [lindex $args 0] + if {[info exists options($opt)]} { + set spec [lsearch -inline -index 0 -exact [my GetSpecs] $opt] + return [linsert $spec end $options($opt)] + } + } elseif {$argc == 2} { + # Special case for where we're setting a single option. This + # avoids some of the costly operations. We still do the [array + # get] as this gives a sufficiently-consistent trace. + set opt [lindex $args 0] + if {[dict exists [array get options] $opt]} { + # Actually set the new value of the option. Use a catch to + # allow a megawidget user to throw an error from a write trace + # on the options array to reject invalid values. + try { + array set options $args + } on error {ret info} { + # Rethrow the error to get a clean stack trace + return -code error -errorcode [dict get $info -errorcode] $ret + } + return + } + } elseif {$argc % 2 == 0} { + # Check that all specified options exist. Any unknown option will + # cause the merged dictionary to be bigger than the options array + set merge [dict merge [array get options] $args] + if {[dict size $merge] == [array size options]} { + # Actually set the new values of the options. Use a catch to + # allow a megawidget user to throw an error from a write trace + # on the options array to reject invalid values + try { + array set options $args + } on error {ret info} { + # Rethrow the error to get a clean stack trace + return -code error -errorcode [dict get $info -errorcode] $ret + } + return + } + # Due to the order of the merge, the unknown options will be at + # the end of the dict. This makes the first unknown option easy to + # find. + set opt [lindex [dict keys $merge] [array size options]] + } else { + set opt [lindex $args end] + return -code error -errorcode [list TK VALUE_MISSING] \ + "value for \"$opt\" missing" + } + return -code error -errorcode [list TK LOOKUP OPTION $opt] \ + "bad option \"$opt\": must be [tclListValidFlags options]" + } + + #################################################################### + # + # MegawidgetClass::cget -- + # + # Implementation of 'cget' for megawidgets. Emulates the operation of + # the standard Tk cget method fairly closely. + # + # This method assumes that the 'options' array in the class holds all + # options; it is up to subclasses to set traces on that array if they + # want to respond to configuration reads. + # + # TODO: allow unambiguous abbreviations. + # + method cget option { + return $options($option) + } + + #################################################################### + # + # MegawidgetClass::TraceOption -- + # + # Sets up the tracing of an element of the options variable. + # + method TraceOption {option method args} { + set callback [list my $method {*}$args] + trace add variable options($option) write [namespace code $callback] + } + + #################################################################### + # + # MegawidgetClass::GetSpecs -- + # + # Return a list of descriptions of options supported by this + # megawidget. Each option is described by the 4-tuple list, consisting + # of the name of the option, the "option database" name, the "option + # database" class-name, and the default value of the option. These are + # the same values returned by calling the configure method of a widget, + # except without the current values of the options. + # + method GetSpecs {} { + return { + {-takefocus takeFocus TakeFocus {}} + } + } + + #################################################################### + # + # MegawidgetClass::CreateHull -- + # + # Creates the real main widget of the megawidget. This is often a frame + # or toplevel widget, but isn't always (lightweight megawidgets might + # use a content widget directly). + # + # The name of the hull widget is given by the 'w' instance variable. The + # name should be written into the 'hull' instance variable. The command + # created by this method will be renamed. + # + method CreateHull {} { + return -code error -errorcode {TCL OO ABSTRACT_METHOD} \ + "method must be overridden" + } + + #################################################################### + # + # MegawidgetClass::Create -- + # + # Creates the content of the megawidget. The name of the widget to + # create the content in will be in the 'hull' instance variable. + # + method Create {} { + return -code error -errorcode {TCL OO ABSTRACT_METHOD} \ + "method must be overridden" + } + + #################################################################### + # + # MegawidgetClass::WhenIdle -- + # + # Arrange for a method to be called on the current instance when Tk is + # idle. Only one such method call per method will be queued; subsequent + # queuing actions before the callback fires will be silently ignored. + # The additional args will be passed to the callback, and the callbacks + # will be properly cancelled if the widget is destroyed. + # + method WhenIdle {method args} { + if {![info exists IdleCallbacks($method)]} { + set IdleCallbacks($method) [after idle [list \ + [namespace which my] DoWhenIdle $method $args]] + } + } + method DoWhenIdle {method arguments} { + unset IdleCallbacks($method) + tailcall my $method {*}$arguments + } +} + +#################################################################### +# +# tk::SimpleWidget -- +# +# Simple megawidget class that makes it easy create widgets that behave +# like a ttk widget. It creates the hull as a ttk::frame and maps the +# state manipulation methods of the overall megawidget to the equivalent +# operations on the ttk::frame. +# +::tk::Megawidget create ::tk::SimpleWidget {} { + variable w hull options + method GetSpecs {} { + return { + {-cursor cursor Cursor {}} + {-takefocus takeFocus TakeFocus {}} + } + } + method CreateHull {} { + set hull [::ttk::frame $w -cursor $options(-cursor)] + my TraceOption -cursor UpdateCursorOption + } + method UpdateCursorOption args { + $hull configure -cursor $options(-cursor) + } + # Not fixed names, so can't forward + method state args { + tailcall $hull state {*}$args + } + method instate args { + tailcall $hull instate {*}$args + } +} + +#################################################################### +# +# tk::FocusableWidget -- +# +# Simple megawidget class that makes a ttk-like widget that has a focus +# ring. +# +::tk::Megawidget create ::tk::FocusableWidget ::tk::SimpleWidget { + variable w hull options + method GetSpecs {} { + return { + {-cursor cursor Cursor {}} + {-takefocus takeFocus TakeFocus ::ttk::takefocus} + } + } + method CreateHull {} { + ttk::frame $w + set hull [ttk::entry $w.cHull -takefocus 0 -cursor $options(-cursor)] + pack $hull -expand yes -fill both -ipadx 2 -ipady 2 + my TraceOption -cursor UpdateCursorOption + } +} + +return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/XSchemWin/Installer/binary_template/lib/tk8.6/menu.tcl b/XSchemWin/Installer/binary_template/lib/tk8.6/menu.tcl new file mode 100644 index 00000000..c4991f81 --- /dev/null +++ b/XSchemWin/Installer/binary_template/lib/tk8.6/menu.tcl @@ -0,0 +1,1379 @@ +# menu.tcl -- +# +# This file defines the default bindings for Tk menus and menubuttons. +# It also implements keyboard traversal of menus and implements a few +# other utility procedures related to menus. +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 2007 Daniel A. Steffen +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +#------------------------------------------------------------------------- +# Elements of tk::Priv that are used in this file: +# +# cursor - Saves the -cursor option for the posted menubutton. +# focus - Saves the focus during a menu selection operation. +# Focus gets restored here when the menu is unposted. +# grabGlobal - Used in conjunction with tk::Priv(oldGrab): if +# tk::Priv(oldGrab) is non-empty, then tk::Priv(grabGlobal) +# contains either an empty string or "-global" to +# indicate whether the old grab was a local one or +# a global one. +# inMenubutton - The name of the menubutton widget containing +# the mouse, or an empty string if the mouse is +# not over any menubutton. +# menuBar - The name of the menubar that is the root +# of the cascade hierarchy which is currently +# posted. This is null when there is no menu currently +# being pulled down from a menu bar. +# oldGrab - Window that had the grab before a menu was posted. +# Used to restore the grab state after the menu +# is unposted. Empty string means there was no +# grab previously set. +# popup - If a menu has been popped up via tk_popup, this +# gives the name of the menu. Otherwise this +# value is empty. +# postedMb - Name of the menubutton whose menu is currently +# posted, or an empty string if nothing is posted +# A grab is set on this widget. +# relief - Used to save the original relief of the current +# menubutton. +# window - When the mouse is over a menu, this holds the +# name of the menu; it's cleared when the mouse +# leaves the menu. +# tearoff - Whether the last menu posted was a tearoff or not. +# This is true always for unix, for tearoffs for Mac +# and Windows. +# activeMenu - This is the last active menu for use +# with the <> virtual event. +# activeItem - This is the last active menu item for +# use with the <> virtual event. +#------------------------------------------------------------------------- + +#------------------------------------------------------------------------- +# Overall note: +# This file is tricky because there are five different ways that menus +# can be used: +# +# 1. As a pulldown from a menubutton. In this style, the variable +# tk::Priv(postedMb) identifies the posted menubutton. +# 2. As a torn-off menu copied from some other menu. In this style +# tk::Priv(postedMb) is empty, and menu's type is "tearoff". +# 3. As an option menu, triggered from an option menubutton. In this +# style tk::Priv(postedMb) identifies the posted menubutton. +# 4. As a popup menu. In this style tk::Priv(postedMb) is empty and +# the top-level menu's type is "normal". +# 5. As a pulldown from a menubar. The variable tk::Priv(menubar) has +# the owning menubar, and the menu itself is of type "normal". +# +# The various binding procedures use the state described above to +# distinguish the various cases and take different actions in each +# case. +#------------------------------------------------------------------------- + +#------------------------------------------------------------------------- +# The code below creates the default class bindings for menus +# and menubuttons. +#------------------------------------------------------------------------- + +bind Menubutton {} +bind Menubutton { + tk::MbEnter %W +} +bind Menubutton { + tk::MbLeave %W +} +bind Menubutton <1> { + if {$tk::Priv(inMenubutton) ne ""} { + tk::MbPost $tk::Priv(inMenubutton) %X %Y + } +} +bind Menubutton { + tk::MbMotion %W up %X %Y +} +bind Menubutton { + tk::MbMotion %W down %X %Y +} +bind Menubutton { + tk::MbButtonUp %W +} +bind Menubutton { + tk::MbPost %W + tk::MenuFirstEntry [%W cget -menu] +} +bind Menubutton <> { + tk::MbPost %W + tk::MenuFirstEntry [%W cget -menu] +} + +# Must set focus when mouse enters a menu, in order to allow +# mixed-mode processing using both the mouse and the keyboard. +# Don't set the focus if the event comes from a grab release, +# though: such an event can happen after as part of unposting +# a cascaded chain of menus, after the focus has already been +# restored to wherever it was before menu selection started. + +bind Menu {} + +bind Menu { + set tk::Priv(window) %W + if {[%W cget -type] eq "tearoff"} { + if {"%m" ne "NotifyUngrab"} { + if {[tk windowingsystem] eq "x11"} { + tk_menuSetFocus %W + } + } + } + tk::MenuMotion %W %x %y %s +} + +bind Menu { + tk::MenuLeave %W %X %Y %s +} +bind Menu { + tk::MenuMotion %W %x %y %s +} +bind Menu