summaryrefslogtreecommitdiffstats
path: root/tcl8.6/tools
diff options
context:
space:
mode:
authorWilliam Joye <wjoye@cfa.harvard.edu>2018-01-02 21:03:49 (GMT)
committerWilliam Joye <wjoye@cfa.harvard.edu>2018-01-02 21:03:49 (GMT)
commit914501b5b992e7b6c7e0a4c958712a8ba9cab41c (patch)
treeedbc059b9557d5fdb79e5a5c47889bc54708da53 /tcl8.6/tools
parentf88c190a01bc7f57e79dfaf91a3c0c48c2031549 (diff)
downloadblt-914501b5b992e7b6c7e0a4c958712a8ba9cab41c.zip
blt-914501b5b992e7b6c7e0a4c958712a8ba9cab41c.tar.gz
blt-914501b5b992e7b6c7e0a4c958712a8ba9cab41c.tar.bz2
upgrade to tcl/tk 8.6.8
Diffstat (limited to 'tcl8.6/tools')
-rw-r--r--tcl8.6/tools/Makefile.in67
-rw-r--r--tcl8.6/tools/README25
-rwxr-xr-xtcl8.6/tools/checkLibraryDoc.tcl293
-rwxr-xr-xtcl8.6/tools/configure2170
-rw-r--r--tcl8.6/tools/configure.in35
-rw-r--r--tcl8.6/tools/eolFix.tcl80
-rw-r--r--tcl8.6/tools/feather.bmpbin0 -> 2102 bytes
-rwxr-xr-xtcl8.6/tools/findBadExternals.tcl53
-rwxr-xr-xtcl8.6/tools/fix_tommath_h.tcl102
-rw-r--r--tcl8.6/tools/genStubs.tcl1179
-rw-r--r--tcl8.6/tools/index.tcl199
-rw-r--r--tcl8.6/tools/installData.tcl50
-rwxr-xr-xtcl8.6/tools/loadICU.tcl619
-rwxr-xr-xtcl8.6/tools/makeTestCases.tcl1180
-rw-r--r--tcl8.6/tools/man2help.tcl141
-rw-r--r--tcl8.6/tools/man2help2.tcl1033
-rw-r--r--tcl8.6/tools/man2html.tcl185
-rw-r--r--tcl8.6/tools/man2html1.tcl258
-rw-r--r--tcl8.6/tools/man2html2.tcl927
-rw-r--r--tcl8.6/tools/man2tcl.c424
-rw-r--r--tcl8.6/tools/mkdepend.tcl420
-rw-r--r--tcl8.6/tools/regexpTestLib.tcl263
-rw-r--r--tcl8.6/tools/tcl.hpj.in19
-rwxr-xr-xtcl8.6/tools/tclZIC.tcl1373
-rw-r--r--tcl8.6/tools/tcltk-man2html-utils.tcl1634
-rwxr-xr-xtcl8.6/tools/tcltk-man2html.tcl752
-rw-r--r--tcl8.6/tools/tsdPerf.tcl24
-rw-r--r--tcl8.6/tools/uniClass.tcl130
-rw-r--r--tcl8.6/tools/uniParse.tcl411
-rw-r--r--tcl8.6/tools/white.bmpbin0 -> 20522 bytes
30 files changed, 14046 insertions, 0 deletions
diff --git a/tcl8.6/tools/Makefile.in b/tcl8.6/tools/Makefile.in
new file mode 100644
index 0000000..5e9f88e
--- /dev/null
+++ b/tcl8.6/tools/Makefile.in
@@ -0,0 +1,67 @@
+# This makefile is used to convert Tcl manual pages into various
+# alternate formats:
+#
+# Windows help file: 1. Build the winhelp target on Unix
+# 2. Build the helpfile target on Windows
+#
+# HTML: 1. Build the html target on Unix
+
+TCL = tcl@TCL_VERSION@
+TK = tk@TCL_VERSION@
+VER = @TCL_WIN_VERSION@
+
+TCL_BIN_DIR = @TCL_BIN_DIR@
+TCL_SOURCE = @TCL_SRC_DIR@
+TK_SOURCE = $(TCL_SOURCE)/../$(TK)
+PRO_SOURCE = $(TCL_SOURCE)/../pro
+ITCL_SOURCE = $(TCL_SOURCE)/../itcl3.1.0
+
+TCL_DOCS = $(TCL_SOURCE)/doc/*.[13n]
+
+TK_DOCS = $(TK_SOURCE)/doc/*.[13n]
+
+PRO_DOCS = \
+ $(PRO_SOURCE)/doc/man/procheck.1 \
+ $(PRO_SOURCE)/doc/man/prodebug.1 \
+ $(PRO_SOURCE)/doc/man/prodebug.n \
+ $(PRO_SOURCE)/doc/man/prolicense.1
+
+ITCL_DOCS = \
+ $(ITCL_SOURCE)/itcl/doc/*.[13n] \
+ $(ITCL_SOURCE)/itk/doc/*.[13n]
+
+# $(ITCL_SOURCE)/iwidgets3.0.0/doc/*.[13n]
+
+COREDOCS = $(TCL_DOCS) $(TK_DOCS)
+#PRODOCS = $(COREDOCS) $(PRO_DOCS) $(ITCL_DOCS)
+PRODOCS = $(COREDOCS) $(PRO_DOCS)
+TCLSH = $(TCL_BIN_DIR)/tclsh
+CC = @CC@
+
+#
+# Targets
+#
+
+all: core
+
+pro:
+ $(MAKE) DOCS="$(PRODOCS)" VER="" rtf
+
+core:
+ $(MAKE) DOCS="$(COREDOCS)" rtf
+
+rtf: $(TCL_SOURCE)/tools/man2help.tcl man2tcl $(DOCS)
+ LD_LIBRARY_PATH=$(TCL_BIN_DIR) \
+ TCL_LIBRARY=$(TCL_SOURCE)/library \
+ $(TCLSH) $(TCL_SOURCE)/tools/man2help.tcl tcl "$(VER)" $(DOCS)
+
+winhelp: tcl.rtf
+
+man2tcl: $(TCL_SOURCE)/tools/man2tcl.c
+ $(CC) $(CFLAGS) -o man2tcl $(TCL_SOURCE)/tools/man2tcl.c
+
+clean:
+ -rm -f man2tcl *.o *.cnt *.rtf
+
+helpfile:
+ hcw /c /e tcl.hpj
diff --git a/tcl8.6/tools/README b/tcl8.6/tools/README
new file mode 100644
index 0000000..f4bf627
--- /dev/null
+++ b/tcl8.6/tools/README
@@ -0,0 +1,25 @@
+This directory contains unsupported tools used to build parts of Tcl
+for distribution.
+
+
+uniParse.tcl -- Script for converting the Unicode character database
+ into a compact table stored in generic/tclUniData.c.
+
+uniClass.tcl -- Script for generating regexp class tables from the Tcl
+ "string is" classes
+
+Generating HTML files.
+The tcl-tk-man-html.tcl script from Robert Critchlow
+generates a nice set of HTML with good cross references.
+Use it like
+ tclsh tcl-tk-man-html.tcl --htmldir=/tmp/tcl8.2
+This script is very picky about the organization of man pages,
+effectively acting as a style enforcer.
+
+Generating Windows Help Files:
+1) Build tcl in the ../unix directory
+2) On UNIX, (after autoconf and configure), do
+ make
+ this converts the Nroff to RTF files.
+2) On Windows, convert the RTF to a Help doc, do
+ nmake helpfile
diff --git a/tcl8.6/tools/checkLibraryDoc.tcl b/tcl8.6/tools/checkLibraryDoc.tcl
new file mode 100755
index 0000000..6d147ac
--- /dev/null
+++ b/tcl8.6/tools/checkLibraryDoc.tcl
@@ -0,0 +1,293 @@
+# checkLibraryDoc.tcl --
+#
+# This script attempts to determine what APIs exist in the source base that
+# have not been documented. By grepping through all of the doc/*.3 man
+# pages, looking for "Pkg_*" (e.g., Tcl_ or Tk_), and comparing this list
+# against the list of Pkg_ APIs found in the source (e.g., tcl8.2/*/*.[ch])
+# we create six lists:
+# 1) APIs in Source not in Docs.
+# 2) APIs in Docs not in Source.
+# 3) Internal APIs and structs.
+# 4) Misc APIs and structs that we are not documenting.
+# 5) Command APIs (e.g., Tcl_ArrayObjCmd.)
+# 6) Proc pointers (e.g., Tcl_CloseProc.)
+#
+# Note: Each list is "a best guess" approximation. If developers write
+# non-standard code, this script will produce erroneous results. Each
+# list should be carefully checked for accuracy.
+#
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+
+lappend auto_path "c:/program\ files/tclpro1.2/win32-ix86/bin"
+#lappend auto_path "/home/surles/cvs/tclx8.0/tcl/unix"
+if {[catch {package require Tclx}]} {
+ puts "error: could not load TclX. Please set TCL_LIBRARY."
+ exit 1
+}
+
+# A list of structs that are known to be undocumented.
+
+set StructList {
+ Tcl_AsyncHandler \
+ Tcl_CallFrame \
+ Tcl_Condition \
+ Tcl_Encoding \
+ Tcl_EncodingState \
+ Tcl_EncodingType \
+ Tcl_HashEntry \
+ Tcl_HashSearch \
+ Tcl_HashTable \
+ Tcl_Mutex \
+ Tcl_Pid \
+ Tcl_QueuePosition \
+ Tcl_ResolvedVarInfo \
+ Tcl_SavedResult \
+ Tcl_ThreadDataKey \
+ Tcl_ThreadId \
+ Tcl_Time \
+ Tcl_TimerToken \
+ Tcl_Token \
+ Tcl_Trace \
+ Tcl_Value \
+ Tcl_ValueType \
+ Tcl_Var \
+ Tk_3DBorder \
+ Tk_ArgvInfo \
+ Tk_BindingTable \
+ Tk_Canvas \
+ Tk_CanvasTextInfo \
+ Tk_ConfigSpec \
+ Tk_ConfigTypes \
+ Tk_Cursor \
+ Tk_CustomOption \
+ Tk_ErrorHandler \
+ Tk_FakeWin \
+ Tk_Font \
+ Tk_FontMetrics \
+ Tk_GeomMgr \
+ Tk_Image \
+ Tk_ImageMaster \
+ Tk_ImageType \
+ Tk_Item \
+ Tk_ItemType \
+ Tk_OptionSpec\
+ Tk_OptionTable \
+ Tk_OptionType \
+ Tk_PhotoHandle \
+ Tk_PhotoImageBlock \
+ Tk_PhotoImageFormat \
+ Tk_PostscriptInfo \
+ Tk_SavedOption \
+ Tk_SavedOptions \
+ Tk_SegType \
+ Tk_TextLayout \
+ Tk_Window \
+}
+
+# Misc junk that appears in the comments of the source. This just
+# allows us to filter comments that "fool" the script.
+
+set CommentList {
+ Tcl_Create\[Obj\]Command \
+ Tcl_DecrRefCount\\n \
+ Tcl_NewObj\\n \
+ Tk_GetXXX \
+}
+
+# Main entry point to this script.
+
+proc main {} {
+ global argv0
+ global argv
+
+ set len [llength $argv]
+ if {($len != 2) && ($len != 3)} {
+ puts "usage: $argv0 pkgName pkgDir \[outFile\]"
+ puts " pkgName == Tcl,Tk"
+ puts " pkgDir == /home/surles/cvs/tcl8.2"
+ exit 1
+ }
+
+ set pkg [lindex $argv 0]
+ set dir [lindex $argv 1]
+ if {[llength $argv] == 3} {
+ set file [open [lindex $argv 2] w]
+ } else {
+ set file stdout
+ }
+
+ foreach {c d} [compare [grepCode $dir $pkg] [grepDocs $dir $pkg]] {}
+ filter $c $d $dir $pkg $file
+
+ if {$file ne "stdout"} {
+ close $file
+ }
+ return
+}
+
+# Intersect the two list and write out the sets of APIs in one
+# list that is not in the other.
+
+proc compare {list1 list2} {
+ set inter [intersect3 $list1 $list2]
+ return [list [lindex $inter 0] [lindex $inter 2]]
+}
+
+# Filter the lists into the six lists we report on. Then write
+# the results to the file.
+
+proc filter {code docs dir pkg {outFile stdout}} {
+ set apis {}
+
+ # A list of Tcl command APIs. These are not documented.
+ # This list should just be verified for accuracy.
+
+ set cmds {}
+
+ # A list of proc pointer structs. These are not documented.
+ # This list should just be verified for accuracy.
+
+ set procs {}
+
+ # A list of internal declarations. These are not documented.
+ # This list should just be verified for accuracy.
+
+ set decls [grepDecl $dir $pkg]
+
+ # A list of misc. procedure declarations that are not documented.
+ # This list should just be verified for accuracy.
+
+ set misc [grepMisc $dir $pkg]
+
+ set pat1 ".*(${pkg}_\[A-z0-9]+).*$"
+
+ # A list of APIs in the source, not in the docs.
+ # This list should just be verified for accuracy.
+
+ foreach x $code {
+ if {[string match *Cmd $x]} {
+ if {[string match ${pkg}* $x]} {
+ lappend cmds $x
+ }
+ } elseif {[string match *Proc $x]} {
+ if {[string match ${pkg}* $x]} {
+ lappend procs $x
+ }
+ } elseif {[lsearch -exact $decls $x] >= 0} {
+ # No Op.
+ } elseif {[lsearch -exact $misc $x] >= 0} {
+ # No Op.
+ } else {
+ lappend apis $x
+ }
+ }
+
+ dump $apis "APIs in Source not in Docs." $outFile
+ dump $docs "APIs in Docs not in Source." $outFile
+ dump $decls "Internal APIs and structs." $outFile
+ dump $misc "Misc APIs and structs that we are not documenting." $outFile
+ dump $cmds "Command APIs." $outFile
+ dump $procs "Proc pointers." $outFile
+ return
+}
+
+# Print the list of APIs if the list is not null.
+
+proc dump {list title file} {
+ if {$list ne ""} {
+ puts $file ""
+ puts $file $title
+ puts $file "---------------------------------------------------------"
+ foreach x $list {
+ puts $file $x
+ }
+ }
+}
+
+# Grep into "dir/*/*.[ch]" looking for APIs that match $pkg_*.
+# (e.g., Tcl_Exit). Return a list of APIs.
+
+proc grepCode {dir pkg} {
+ set apis [myGrep "${pkg}_\.\*" "${dir}/\*/\*\.\[ch\]"]
+ set pat1 ".*(${pkg}_\[A-z0-9]+).*$"
+
+ foreach a $apis {
+ if {[regexp -- $pat1 $a main n1]} {
+ set result([string trim $n1]) 1
+ }
+ }
+ return [lsort [array names result]]
+}
+
+# Grep into "dir/doc/*.3" looking for APIs that match $pkg_*.
+# (e.g., Tcl_Exit). Return a list of APIs.
+
+proc grepDocs {dir pkg} {
+ set apis [myGrep "\\fB${pkg}_\.\*\\fR" "${dir}/doc/\*\.3"]
+ set pat1 ".*(${pkg}_\[A-z0-9]+)\\\\fR.*$"
+
+ foreach a $apis {
+ if {[regexp -- $pat1 $a main n1]} {
+ set result([string trim $n1]) 1
+ }
+ }
+ return [lsort [array names result]]
+}
+
+# Grep into "generic/pkgIntDecls.h" looking for APIs that match $pkg_*.
+# (e.g., Tcl_Export). Return a list of APIs.
+
+proc grepDecl {dir pkg} {
+ set file [file join $dir generic "[string tolower $pkg]IntDecls.h"]
+ set apis [myGrep "^EXTERN.*\[ \t\]${pkg}_.*" $file]
+ set pat1 ".*(${pkg}_\[A-z0-9]+).*$"
+
+ foreach a $apis {
+ if {[regexp -- $pat1 $a main n1]} {
+ set result([string trim $n1]) 1
+ }
+ }
+ return [lsort [array names result]]
+}
+
+# Grep into "*/*.[ch]" looking for APIs that match $pkg_Db*.
+# (e.g., Tcl_DbCkalloc). Return a list of APIs.
+
+proc grepMisc {dir pkg} {
+ global CommentList
+ global StructList
+
+ set apis [myGrep "^EXTERN.*\[ \t\]${pkg}_Db.*" "${dir}/\*/\*\.\[ch\]"]
+ set pat1 ".*(${pkg}_\[A-z0-9]+).*$"
+
+ foreach a $apis {
+ if {[regexp -- $pat1 $a main n1]} {
+ set dbg([string trim $n1]) 1
+ }
+ }
+
+ set result {}
+ eval {lappend result} $StructList
+ eval {lappend result} [lsort [array names dbg]]
+ eval {lappend result} $CommentList
+ return $result
+}
+
+proc myGrep {searchPat globPat} {
+ set result {}
+ foreach file [glob -nocomplain $globPat] {
+ set file [open $file r]
+ set data [read $file]
+ close $file
+ foreach line [split $data "\n"] {
+ if {[regexp "^.*${searchPat}.*\$" $line]} {
+ lappend result $line
+ }
+ }
+ }
+ return $result
+}
+main
+
diff --git a/tcl8.6/tools/configure b/tcl8.6/tools/configure
new file mode 100755
index 0000000..3d30039
--- /dev/null
+++ b/tcl8.6/tools/configure
@@ -0,0 +1,2170 @@
+#! /bin/sh
+# Guess values for system-dependent variables and create Makefiles.
+# Generated by GNU Autoconf 2.59.
+#
+# Copyright (C) 2003 Free Software Foundation, Inc.
+# This configure script is free software; the Free Software Foundation
+# gives unlimited permission to copy, distribute and modify it.
+## --------------------- ##
+## M4sh Initialization. ##
+## --------------------- ##
+
+# Be Bourne compatible
+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
+ emulate sh
+ NULLCMD=:
+ # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
+ # is contrary to our usage. Disable this feature.
+ alias -g '${1+"$@"}'='"$@"'
+elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then
+ set -o posix
+fi
+DUALCASE=1; export DUALCASE # for MKS sh
+
+# Support unset when possible.
+if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then
+ as_unset=unset
+else
+ as_unset=false
+fi
+
+
+# Work around bugs in pre-3.0 UWIN ksh.
+$as_unset ENV MAIL MAILPATH
+PS1='$ '
+PS2='> '
+PS4='+ '
+
+# NLS nuisances.
+for as_var in \
+ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \
+ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \
+ LC_TELEPHONE LC_TIME
+do
+ if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then
+ eval $as_var=C; export $as_var
+ else
+ $as_unset $as_var
+ fi
+done
+
+# Required to use basename.
+if expr a : '\(a\)' >/dev/null 2>&1; then
+ as_expr=expr
+else
+ as_expr=false
+fi
+
+if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then
+ as_basename=basename
+else
+ as_basename=false
+fi
+
+
+# Name of the executable.
+as_me=`$as_basename "$0" ||
+$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \
+ X"$0" : 'X\(//\)$' \| \
+ X"$0" : 'X\(/\)$' \| \
+ . : '\(.\)' 2>/dev/null ||
+echo X/"$0" |
+ sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; }
+ /^X\/\(\/\/\)$/{ s//\1/; q; }
+ /^X\/\(\/\).*/{ s//\1/; q; }
+ s/.*/./; q'`
+
+
+# PATH needs CR, and LINENO needs CR and PATH.
+# Avoid depending upon Character Ranges.
+as_cr_letters='abcdefghijklmnopqrstuvwxyz'
+as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
+as_cr_Letters=$as_cr_letters$as_cr_LETTERS
+as_cr_digits='0123456789'
+as_cr_alnum=$as_cr_Letters$as_cr_digits
+
+# The user is always right.
+if test "${PATH_SEPARATOR+set}" != set; then
+ echo "#! /bin/sh" >conf$$.sh
+ echo "exit 0" >>conf$$.sh
+ chmod +x conf$$.sh
+ if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then
+ PATH_SEPARATOR=';'
+ else
+ PATH_SEPARATOR=:
+ fi
+ rm -f conf$$.sh
+fi
+
+
+ as_lineno_1=$LINENO
+ as_lineno_2=$LINENO
+ as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null`
+ test "x$as_lineno_1" != "x$as_lineno_2" &&
+ test "x$as_lineno_3" = "x$as_lineno_2" || {
+ # Find who we are. Look in the path if we contain no path at all
+ # relative or not.
+ case $0 in
+ *[\\/]* ) as_myself=$0 ;;
+ *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break
+done
+
+ ;;
+ esac
+ # We did not find ourselves, most probably we were run as `sh COMMAND'
+ # in which case we are not to be found in the path.
+ if test "x$as_myself" = x; then
+ as_myself=$0
+ fi
+ if test ! -f "$as_myself"; then
+ { echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2
+ { (exit 1); exit 1; }; }
+ fi
+ case $CONFIG_SHELL in
+ '')
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for as_base in sh bash ksh sh5; do
+ case $as_dir in
+ /*)
+ if ("$as_dir/$as_base" -c '
+ as_lineno_1=$LINENO
+ as_lineno_2=$LINENO
+ as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null`
+ test "x$as_lineno_1" != "x$as_lineno_2" &&
+ test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then
+ $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; }
+ $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; }
+ CONFIG_SHELL=$as_dir/$as_base
+ export CONFIG_SHELL
+ exec "$CONFIG_SHELL" "$0" ${1+"$@"}
+ fi;;
+ esac
+ done
+done
+;;
+ esac
+
+ # Create $as_me.lineno as a copy of $as_myself, but with $LINENO
+ # uniformly replaced by the line number. The first 'sed' inserts a
+ # line-number line before each line; the second 'sed' does the real
+ # work. The second script uses 'N' to pair each line-number line
+ # with the numbered line, and appends trailing '-' during
+ # substitution so that $LINENO is not a special case at line end.
+ # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the
+ # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-)
+ sed '=' <$as_myself |
+ sed '
+ N
+ s,$,-,
+ : loop
+ s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3,
+ t loop
+ s,-$,,
+ s,^['$as_cr_digits']*\n,,
+ ' >$as_me.lineno &&
+ chmod +x $as_me.lineno ||
+ { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2
+ { (exit 1); exit 1; }; }
+
+ # Don't try to exec as it changes $[0], causing all sort of problems
+ # (the dirname of $[0] is not the place where we might find the
+ # original and so on. Autoconf is especially sensible to this).
+ . ./$as_me.lineno
+ # Exit status is that of the last command.
+ exit
+}
+
+
+case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in
+ *c*,-n*) ECHO_N= ECHO_C='
+' ECHO_T=' ' ;;
+ *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;;
+ *) ECHO_N= ECHO_C='\c' ECHO_T= ;;
+esac
+
+if expr a : '\(a\)' >/dev/null 2>&1; then
+ as_expr=expr
+else
+ as_expr=false
+fi
+
+rm -f conf$$ conf$$.exe conf$$.file
+echo >conf$$.file
+if ln -s conf$$.file conf$$ 2>/dev/null; then
+ # We could just check for DJGPP; but this test a) works b) is more generic
+ # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04).
+ if test -f conf$$.exe; then
+ # Don't use ln at all; we don't have any links
+ as_ln_s='cp -p'
+ else
+ as_ln_s='ln -s'
+ fi
+elif ln conf$$.file conf$$ 2>/dev/null; then
+ as_ln_s=ln
+else
+ as_ln_s='cp -p'
+fi
+rm -f conf$$ conf$$.exe conf$$.file
+
+if mkdir -p . 2>/dev/null; then
+ as_mkdir_p=:
+else
+ test -d ./-p && rmdir ./-p
+ as_mkdir_p=false
+fi
+
+as_executable_p="test -f"
+
+# Sed expression to map a string onto a valid CPP name.
+as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
+
+# Sed expression to map a string onto a valid variable name.
+as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"
+
+
+# IFS
+# We need space, tab and new line, in precisely that order.
+as_nl='
+'
+IFS=" $as_nl"
+
+# CDPATH.
+$as_unset CDPATH
+
+
+# Name of the host.
+# hostname on some systems (SVR3.2, Linux) returns a bogus exit status,
+# so uname gets run too.
+ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q`
+
+exec 6>&1
+
+#
+# Initializations.
+#
+ac_default_prefix=/usr/local
+ac_config_libobj_dir=.
+cross_compiling=no
+subdirs=
+MFLAGS=
+MAKEFLAGS=
+SHELL=${CONFIG_SHELL-/bin/sh}
+
+# Maximum number of lines to put in a shell here document.
+# This variable seems obsolete. It should probably be removed, and
+# only ac_max_sed_lines should be used.
+: ${ac_max_here_lines=38}
+
+# Identity of this package.
+PACKAGE_NAME=
+PACKAGE_TARNAME=
+PACKAGE_VERSION=
+PACKAGE_STRING=
+PACKAGE_BUGREPORT=
+
+ac_unique_file="man2tcl.c"
+ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS TCL_WIN_VERSION CC TCL_VERSION TCL_PATCH_LEVEL TCL_SRC_DIR TCL_BIN_DIR LIBOBJS LTLIBOBJS'
+ac_subst_files=''
+
+# Initialize some variables set by options.
+ac_init_help=
+ac_init_version=false
+# The variables have the same names as the options, with
+# dashes changed to underlines.
+cache_file=/dev/null
+exec_prefix=NONE
+no_create=
+no_recursion=
+prefix=NONE
+program_prefix=NONE
+program_suffix=NONE
+program_transform_name=s,x,x,
+silent=
+site=
+srcdir=
+verbose=
+x_includes=NONE
+x_libraries=NONE
+
+# Installation directory options.
+# These are left unexpanded so users can "make install exec_prefix=/foo"
+# and all the variables that are supposed to be based on exec_prefix
+# by default will actually change.
+# Use braces instead of parens because sh, perl, etc. also accept them.
+bindir='${exec_prefix}/bin'
+sbindir='${exec_prefix}/sbin'
+libexecdir='${exec_prefix}/libexec'
+datadir='${prefix}/share'
+sysconfdir='${prefix}/etc'
+sharedstatedir='${prefix}/com'
+localstatedir='${prefix}/var'
+libdir='${exec_prefix}/lib'
+includedir='${prefix}/include'
+oldincludedir='/usr/include'
+infodir='${prefix}/info'
+mandir='${prefix}/man'
+
+ac_prev=
+for ac_option
+do
+ # If the previous option needs an argument, assign it.
+ if test -n "$ac_prev"; then
+ eval "$ac_prev=\$ac_option"
+ ac_prev=
+ continue
+ fi
+
+ ac_optarg=`expr "x$ac_option" : 'x[^=]*=\(.*\)'`
+
+ # Accept the important Cygnus configure options, so we can diagnose typos.
+
+ case $ac_option in
+
+ -bindir | --bindir | --bindi | --bind | --bin | --bi)
+ ac_prev=bindir ;;
+ -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)
+ bindir=$ac_optarg ;;
+
+ -build | --build | --buil | --bui | --bu)
+ ac_prev=build_alias ;;
+ -build=* | --build=* | --buil=* | --bui=* | --bu=*)
+ build_alias=$ac_optarg ;;
+
+ -cache-file | --cache-file | --cache-fil | --cache-fi \
+ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c)
+ ac_prev=cache_file ;;
+ -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \
+ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)
+ cache_file=$ac_optarg ;;
+
+ --config-cache | -C)
+ cache_file=config.cache ;;
+
+ -datadir | --datadir | --datadi | --datad | --data | --dat | --da)
+ ac_prev=datadir ;;
+ -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \
+ | --da=*)
+ datadir=$ac_optarg ;;
+
+ -disable-* | --disable-*)
+ ac_feature=`expr "x$ac_option" : 'x-*disable-\(.*\)'`
+ # Reject names that are not valid shell variable names.
+ expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null &&
+ { echo "$as_me: error: invalid feature name: $ac_feature" >&2
+ { (exit 1); exit 1; }; }
+ ac_feature=`echo $ac_feature | sed 's/-/_/g'`
+ eval "enable_$ac_feature=no" ;;
+
+ -enable-* | --enable-*)
+ ac_feature=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'`
+ # Reject names that are not valid shell variable names.
+ expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null &&
+ { echo "$as_me: error: invalid feature name: $ac_feature" >&2
+ { (exit 1); exit 1; }; }
+ ac_feature=`echo $ac_feature | sed 's/-/_/g'`
+ case $ac_option in
+ *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;;
+ *) ac_optarg=yes ;;
+ esac
+ eval "enable_$ac_feature='$ac_optarg'" ;;
+
+ -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \
+ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \
+ | --exec | --exe | --ex)
+ ac_prev=exec_prefix ;;
+ -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \
+ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \
+ | --exec=* | --exe=* | --ex=*)
+ exec_prefix=$ac_optarg ;;
+
+ -gas | --gas | --ga | --g)
+ # Obsolete; use --with-gas.
+ with_gas=yes ;;
+
+ -help | --help | --hel | --he | -h)
+ ac_init_help=long ;;
+ -help=r* | --help=r* | --hel=r* | --he=r* | -hr*)
+ ac_init_help=recursive ;;
+ -help=s* | --help=s* | --hel=s* | --he=s* | -hs*)
+ ac_init_help=short ;;
+
+ -host | --host | --hos | --ho)
+ ac_prev=host_alias ;;
+ -host=* | --host=* | --hos=* | --ho=*)
+ host_alias=$ac_optarg ;;
+
+ -includedir | --includedir | --includedi | --included | --include \
+ | --includ | --inclu | --incl | --inc)
+ ac_prev=includedir ;;
+ -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \
+ | --includ=* | --inclu=* | --incl=* | --inc=*)
+ includedir=$ac_optarg ;;
+
+ -infodir | --infodir | --infodi | --infod | --info | --inf)
+ ac_prev=infodir ;;
+ -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*)
+ infodir=$ac_optarg ;;
+
+ -libdir | --libdir | --libdi | --libd)
+ ac_prev=libdir ;;
+ -libdir=* | --libdir=* | --libdi=* | --libd=*)
+ libdir=$ac_optarg ;;
+
+ -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \
+ | --libexe | --libex | --libe)
+ ac_prev=libexecdir ;;
+ -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \
+ | --libexe=* | --libex=* | --libe=*)
+ libexecdir=$ac_optarg ;;
+
+ -localstatedir | --localstatedir | --localstatedi | --localstated \
+ | --localstate | --localstat | --localsta | --localst \
+ | --locals | --local | --loca | --loc | --lo)
+ ac_prev=localstatedir ;;
+ -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \
+ | --localstate=* | --localstat=* | --localsta=* | --localst=* \
+ | --locals=* | --local=* | --loca=* | --loc=* | --lo=*)
+ localstatedir=$ac_optarg ;;
+
+ -mandir | --mandir | --mandi | --mand | --man | --ma | --m)
+ ac_prev=mandir ;;
+ -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)
+ mandir=$ac_optarg ;;
+
+ -nfp | --nfp | --nf)
+ # Obsolete; use --without-fp.
+ with_fp=no ;;
+
+ -no-create | --no-create | --no-creat | --no-crea | --no-cre \
+ | --no-cr | --no-c | -n)
+ no_create=yes ;;
+
+ -no-recursion | --no-recursion | --no-recursio | --no-recursi \
+ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r)
+ no_recursion=yes ;;
+
+ -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \
+ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \
+ | --oldin | --oldi | --old | --ol | --o)
+ ac_prev=oldincludedir ;;
+ -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \
+ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \
+ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*)
+ oldincludedir=$ac_optarg ;;
+
+ -prefix | --prefix | --prefi | --pref | --pre | --pr | --p)
+ ac_prev=prefix ;;
+ -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)
+ prefix=$ac_optarg ;;
+
+ -program-prefix | --program-prefix | --program-prefi | --program-pref \
+ | --program-pre | --program-pr | --program-p)
+ ac_prev=program_prefix ;;
+ -program-prefix=* | --program-prefix=* | --program-prefi=* \
+ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*)
+ program_prefix=$ac_optarg ;;
+
+ -program-suffix | --program-suffix | --program-suffi | --program-suff \
+ | --program-suf | --program-su | --program-s)
+ ac_prev=program_suffix ;;
+ -program-suffix=* | --program-suffix=* | --program-suffi=* \
+ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*)
+ program_suffix=$ac_optarg ;;
+
+ -program-transform-name | --program-transform-name \
+ | --program-transform-nam | --program-transform-na \
+ | --program-transform-n | --program-transform- \
+ | --program-transform | --program-transfor \
+ | --program-transfo | --program-transf \
+ | --program-trans | --program-tran \
+ | --progr-tra | --program-tr | --program-t)
+ ac_prev=program_transform_name ;;
+ -program-transform-name=* | --program-transform-name=* \
+ | --program-transform-nam=* | --program-transform-na=* \
+ | --program-transform-n=* | --program-transform-=* \
+ | --program-transform=* | --program-transfor=* \
+ | --program-transfo=* | --program-transf=* \
+ | --program-trans=* | --program-tran=* \
+ | --progr-tra=* | --program-tr=* | --program-t=*)
+ program_transform_name=$ac_optarg ;;
+
+ -q | -quiet | --quiet | --quie | --qui | --qu | --q \
+ | -silent | --silent | --silen | --sile | --sil)
+ silent=yes ;;
+
+ -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)
+ ac_prev=sbindir ;;
+ -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \
+ | --sbi=* | --sb=*)
+ sbindir=$ac_optarg ;;
+
+ -sharedstatedir | --sharedstatedir | --sharedstatedi \
+ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \
+ | --sharedst | --shareds | --shared | --share | --shar \
+ | --sha | --sh)
+ ac_prev=sharedstatedir ;;
+ -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \
+ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \
+ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \
+ | --sha=* | --sh=*)
+ sharedstatedir=$ac_optarg ;;
+
+ -site | --site | --sit)
+ ac_prev=site ;;
+ -site=* | --site=* | --sit=*)
+ site=$ac_optarg ;;
+
+ -srcdir | --srcdir | --srcdi | --srcd | --src | --sr)
+ ac_prev=srcdir ;;
+ -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*)
+ srcdir=$ac_optarg ;;
+
+ -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \
+ | --syscon | --sysco | --sysc | --sys | --sy)
+ ac_prev=sysconfdir ;;
+ -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \
+ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*)
+ sysconfdir=$ac_optarg ;;
+
+ -target | --target | --targe | --targ | --tar | --ta | --t)
+ ac_prev=target_alias ;;
+ -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)
+ target_alias=$ac_optarg ;;
+
+ -v | -verbose | --verbose | --verbos | --verbo | --verb)
+ verbose=yes ;;
+
+ -version | --version | --versio | --versi | --vers | -V)
+ ac_init_version=: ;;
+
+ -with-* | --with-*)
+ ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`
+ # Reject names that are not valid shell variable names.
+ expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null &&
+ { echo "$as_me: error: invalid package name: $ac_package" >&2
+ { (exit 1); exit 1; }; }
+ ac_package=`echo $ac_package| sed 's/-/_/g'`
+ case $ac_option in
+ *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;;
+ *) ac_optarg=yes ;;
+ esac
+ eval "with_$ac_package='$ac_optarg'" ;;
+
+ -without-* | --without-*)
+ ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'`
+ # Reject names that are not valid shell variable names.
+ expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null &&
+ { echo "$as_me: error: invalid package name: $ac_package" >&2
+ { (exit 1); exit 1; }; }
+ ac_package=`echo $ac_package | sed 's/-/_/g'`
+ eval "with_$ac_package=no" ;;
+
+ --x)
+ # Obsolete; use --with-x.
+ with_x=yes ;;
+
+ -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \
+ | --x-incl | --x-inc | --x-in | --x-i)
+ ac_prev=x_includes ;;
+ -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \
+ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*)
+ x_includes=$ac_optarg ;;
+
+ -x-libraries | --x-libraries | --x-librarie | --x-librari \
+ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l)
+ ac_prev=x_libraries ;;
+ -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \
+ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*)
+ x_libraries=$ac_optarg ;;
+
+ -*) { echo "$as_me: error: unrecognized option: $ac_option
+Try \`$0 --help' for more information." >&2
+ { (exit 1); exit 1; }; }
+ ;;
+
+ *=*)
+ ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='`
+ # Reject names that are not valid shell variable names.
+ expr "x$ac_envvar" : ".*[^_$as_cr_alnum]" >/dev/null &&
+ { echo "$as_me: error: invalid variable name: $ac_envvar" >&2
+ { (exit 1); exit 1; }; }
+ ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`
+ eval "$ac_envvar='$ac_optarg'"
+ export $ac_envvar ;;
+
+ *)
+ # FIXME: should be removed in autoconf 3.0.
+ echo "$as_me: WARNING: you should use --build, --host, --target" >&2
+ expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null &&
+ echo "$as_me: WARNING: invalid host type: $ac_option" >&2
+ : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}
+ ;;
+
+ esac
+done
+
+if test -n "$ac_prev"; then
+ ac_option=--`echo $ac_prev | sed 's/_/-/g'`
+ { echo "$as_me: error: missing argument to $ac_option" >&2
+ { (exit 1); exit 1; }; }
+fi
+
+# Be sure to have absolute paths.
+for ac_var in exec_prefix prefix
+do
+ eval ac_val=$`echo $ac_var`
+ case $ac_val in
+ [\\/$]* | ?:[\\/]* | NONE | '' ) ;;
+ *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2
+ { (exit 1); exit 1; }; };;
+ esac
+done
+
+# Be sure to have absolute paths.
+for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \
+ localstatedir libdir includedir oldincludedir infodir mandir
+do
+ eval ac_val=$`echo $ac_var`
+ case $ac_val in
+ [\\/$]* | ?:[\\/]* ) ;;
+ *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2
+ { (exit 1); exit 1; }; };;
+ esac
+done
+
+# There might be people who depend on the old broken behavior: `$host'
+# used to hold the argument of --host etc.
+# FIXME: To remove some day.
+build=$build_alias
+host=$host_alias
+target=$target_alias
+
+# FIXME: To remove some day.
+if test "x$host_alias" != x; then
+ if test "x$build_alias" = x; then
+ cross_compiling=maybe
+ echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host.
+ If a cross compiler is detected then cross compile mode will be used." >&2
+ elif test "x$build_alias" != "x$host_alias"; then
+ cross_compiling=yes
+ fi
+fi
+
+ac_tool_prefix=
+test -n "$host_alias" && ac_tool_prefix=$host_alias-
+
+test "$silent" = yes && exec 6>/dev/null
+
+
+# Find the source files, if location was not specified.
+if test -z "$srcdir"; then
+ ac_srcdir_defaulted=yes
+ # Try the directory containing this script, then its parent.
+ ac_confdir=`(dirname "$0") 2>/dev/null ||
+$as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$0" : 'X\(//\)[^/]' \| \
+ X"$0" : 'X\(//\)$' \| \
+ X"$0" : 'X\(/\)' \| \
+ . : '\(.\)' 2>/dev/null ||
+echo X"$0" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; }
+ /^X\(\/\/\)[^/].*/{ s//\1/; q; }
+ /^X\(\/\/\)$/{ s//\1/; q; }
+ /^X\(\/\).*/{ s//\1/; q; }
+ s/.*/./; q'`
+ srcdir=$ac_confdir
+ if test ! -r $srcdir/$ac_unique_file; then
+ srcdir=..
+ fi
+else
+ ac_srcdir_defaulted=no
+fi
+if test ! -r $srcdir/$ac_unique_file; then
+ if test "$ac_srcdir_defaulted" = yes; then
+ { echo "$as_me: error: cannot find sources ($ac_unique_file) in $ac_confdir or .." >&2
+ { (exit 1); exit 1; }; }
+ else
+ { echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2
+ { (exit 1); exit 1; }; }
+ fi
+fi
+(cd $srcdir && test -r ./$ac_unique_file) 2>/dev/null ||
+ { echo "$as_me: error: sources are in $srcdir, but \`cd $srcdir' does not work" >&2
+ { (exit 1); exit 1; }; }
+srcdir=`echo "$srcdir" | sed 's%\([^\\/]\)[\\/]*$%\1%'`
+ac_env_build_alias_set=${build_alias+set}
+ac_env_build_alias_value=$build_alias
+ac_cv_env_build_alias_set=${build_alias+set}
+ac_cv_env_build_alias_value=$build_alias
+ac_env_host_alias_set=${host_alias+set}
+ac_env_host_alias_value=$host_alias
+ac_cv_env_host_alias_set=${host_alias+set}
+ac_cv_env_host_alias_value=$host_alias
+ac_env_target_alias_set=${target_alias+set}
+ac_env_target_alias_value=$target_alias
+ac_cv_env_target_alias_set=${target_alias+set}
+ac_cv_env_target_alias_value=$target_alias
+
+#
+# Report the --help message.
+#
+if test "$ac_init_help" = "long"; then
+ # Omit some internal or obsolete options to make the list less imposing.
+ # This message is too long to be a string in the A/UX 3.1 sh.
+ cat <<_ACEOF
+\`configure' configures this package to adapt to many kinds of systems.
+
+Usage: $0 [OPTION]... [VAR=VALUE]...
+
+To assign environment variables (e.g., CC, CFLAGS...), specify them as
+VAR=VALUE. See below for descriptions of some of the useful variables.
+
+Defaults for the options are specified in brackets.
+
+Configuration:
+ -h, --help display this help and exit
+ --help=short display options specific to this package
+ --help=recursive display the short help of all the included packages
+ -V, --version display version information and exit
+ -q, --quiet, --silent do not print \`checking...' messages
+ --cache-file=FILE cache test results in FILE [disabled]
+ -C, --config-cache alias for \`--cache-file=config.cache'
+ -n, --no-create do not create output files
+ --srcdir=DIR find the sources in DIR [configure dir or \`..']
+
+_ACEOF
+
+ cat <<_ACEOF
+Installation directories:
+ --prefix=PREFIX install architecture-independent files in PREFIX
+ [$ac_default_prefix]
+ --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX
+ [PREFIX]
+
+By default, \`make install' will install all the files in
+\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify
+an installation prefix other than \`$ac_default_prefix' using \`--prefix',
+for instance \`--prefix=\$HOME'.
+
+For better control, use the options below.
+
+Fine tuning of the installation directories:
+ --bindir=DIR user executables [EPREFIX/bin]
+ --sbindir=DIR system admin executables [EPREFIX/sbin]
+ --libexecdir=DIR program executables [EPREFIX/libexec]
+ --datadir=DIR read-only architecture-independent data [PREFIX/share]
+ --sysconfdir=DIR read-only single-machine data [PREFIX/etc]
+ --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com]
+ --localstatedir=DIR modifiable single-machine data [PREFIX/var]
+ --libdir=DIR object code libraries [EPREFIX/lib]
+ --includedir=DIR C header files [PREFIX/include]
+ --oldincludedir=DIR C header files for non-gcc [/usr/include]
+ --infodir=DIR info documentation [PREFIX/info]
+ --mandir=DIR man documentation [PREFIX/man]
+_ACEOF
+
+ cat <<\_ACEOF
+_ACEOF
+fi
+
+if test -n "$ac_init_help"; then
+
+ cat <<\_ACEOF
+
+Optional Packages:
+ --with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
+ --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no)
+ --with-tcl=DIR use Tcl $DEF_VER binaries from DIR
+
+_ACEOF
+fi
+
+if test "$ac_init_help" = "recursive"; then
+ # If there are subdirs, report their specific --help.
+ ac_popdir=`pwd`
+ for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue
+ test -d $ac_dir || continue
+ ac_builddir=.
+
+if test "$ac_dir" != .; then
+ ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'`
+ # A "../" for each directory in $ac_dir_suffix.
+ ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'`
+else
+ ac_dir_suffix= ac_top_builddir=
+fi
+
+case $srcdir in
+ .) # No --srcdir option. We are building in place.
+ ac_srcdir=.
+ if test -z "$ac_top_builddir"; then
+ ac_top_srcdir=.
+ else
+ ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'`
+ fi ;;
+ [\\/]* | ?:[\\/]* ) # Absolute path.
+ ac_srcdir=$srcdir$ac_dir_suffix;
+ ac_top_srcdir=$srcdir ;;
+ *) # Relative path.
+ ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix
+ ac_top_srcdir=$ac_top_builddir$srcdir ;;
+esac
+
+# Do not use `cd foo && pwd` to compute absolute paths, because
+# the directories may not exist.
+case `pwd` in
+.) ac_abs_builddir="$ac_dir";;
+*)
+ case "$ac_dir" in
+ .) ac_abs_builddir=`pwd`;;
+ [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";;
+ *) ac_abs_builddir=`pwd`/"$ac_dir";;
+ esac;;
+esac
+case $ac_abs_builddir in
+.) ac_abs_top_builddir=${ac_top_builddir}.;;
+*)
+ case ${ac_top_builddir}. in
+ .) ac_abs_top_builddir=$ac_abs_builddir;;
+ [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;;
+ *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;;
+ esac;;
+esac
+case $ac_abs_builddir in
+.) ac_abs_srcdir=$ac_srcdir;;
+*)
+ case $ac_srcdir in
+ .) ac_abs_srcdir=$ac_abs_builddir;;
+ [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;;
+ *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;;
+ esac;;
+esac
+case $ac_abs_builddir in
+.) ac_abs_top_srcdir=$ac_top_srcdir;;
+*)
+ case $ac_top_srcdir in
+ .) ac_abs_top_srcdir=$ac_abs_builddir;;
+ [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;;
+ *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;;
+ esac;;
+esac
+
+ cd $ac_dir
+ # Check for guested configure; otherwise get Cygnus style configure.
+ if test -f $ac_srcdir/configure.gnu; then
+ echo
+ $SHELL $ac_srcdir/configure.gnu --help=recursive
+ elif test -f $ac_srcdir/configure; then
+ echo
+ $SHELL $ac_srcdir/configure --help=recursive
+ elif test -f $ac_srcdir/configure.ac ||
+ test -f $ac_srcdir/configure.in; then
+ echo
+ $ac_configure --help
+ else
+ echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2
+ fi
+ cd $ac_popdir
+ done
+fi
+
+test -n "$ac_init_help" && exit 0
+if $ac_init_version; then
+ cat <<\_ACEOF
+
+Copyright (C) 2003 Free Software Foundation, Inc.
+This configure script is free software; the Free Software Foundation
+gives unlimited permission to copy, distribute and modify it.
+_ACEOF
+ exit 0
+fi
+exec 5>config.log
+cat >&5 <<_ACEOF
+This file contains any messages produced by compilers while
+running configure, to aid debugging if configure makes a mistake.
+
+It was created by $as_me, which was
+generated by GNU Autoconf 2.59. Invocation command line was
+
+ $ $0 $@
+
+_ACEOF
+{
+cat <<_ASUNAME
+## --------- ##
+## Platform. ##
+## --------- ##
+
+hostname = `(hostname || uname -n) 2>/dev/null | sed 1q`
+uname -m = `(uname -m) 2>/dev/null || echo unknown`
+uname -r = `(uname -r) 2>/dev/null || echo unknown`
+uname -s = `(uname -s) 2>/dev/null || echo unknown`
+uname -v = `(uname -v) 2>/dev/null || echo unknown`
+
+/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown`
+/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown`
+
+/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown`
+/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown`
+/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown`
+hostinfo = `(hostinfo) 2>/dev/null || echo unknown`
+/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown`
+/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown`
+/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown`
+
+_ASUNAME
+
+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ echo "PATH: $as_dir"
+done
+
+} >&5
+
+cat >&5 <<_ACEOF
+
+
+## ----------- ##
+## Core tests. ##
+## ----------- ##
+
+_ACEOF
+
+
+# Keep a trace of the command line.
+# Strip out --no-create and --no-recursion so they do not pile up.
+# Strip out --silent because we don't want to record it for future runs.
+# Also quote any args containing shell meta-characters.
+# Make two passes to allow for proper duplicate-argument suppression.
+ac_configure_args=
+ac_configure_args0=
+ac_configure_args1=
+ac_sep=
+ac_must_keep_next=false
+for ac_pass in 1 2
+do
+ for ac_arg
+ do
+ case $ac_arg in
+ -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;;
+ -q | -quiet | --quiet | --quie | --qui | --qu | --q \
+ | -silent | --silent | --silen | --sile | --sil)
+ continue ;;
+ *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*)
+ ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;
+ esac
+ case $ac_pass in
+ 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;;
+ 2)
+ ac_configure_args1="$ac_configure_args1 '$ac_arg'"
+ if test $ac_must_keep_next = true; then
+ ac_must_keep_next=false # Got value, back to normal.
+ else
+ case $ac_arg in
+ *=* | --config-cache | -C | -disable-* | --disable-* \
+ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \
+ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \
+ | -with-* | --with-* | -without-* | --without-* | --x)
+ case "$ac_configure_args0 " in
+ "$ac_configure_args1"*" '$ac_arg' "* ) continue ;;
+ esac
+ ;;
+ -* ) ac_must_keep_next=true ;;
+ esac
+ fi
+ ac_configure_args="$ac_configure_args$ac_sep'$ac_arg'"
+ # Get rid of the leading space.
+ ac_sep=" "
+ ;;
+ esac
+ done
+done
+$as_unset ac_configure_args0 || test "${ac_configure_args0+set}" != set || { ac_configure_args0=; export ac_configure_args0; }
+$as_unset ac_configure_args1 || test "${ac_configure_args1+set}" != set || { ac_configure_args1=; export ac_configure_args1; }
+
+# When interrupted or exit'd, cleanup temporary files, and complete
+# config.log. We remove comments because anyway the quotes in there
+# would cause problems or look ugly.
+# WARNING: Be sure not to use single quotes in there, as some shells,
+# such as our DU 5.0 friend, will then `close' the trap.
+trap 'exit_status=$?
+ # Save into config.log some information that might help in debugging.
+ {
+ echo
+
+ cat <<\_ASBOX
+## ---------------- ##
+## Cache variables. ##
+## ---------------- ##
+_ASBOX
+ echo
+ # The following way of writing the cache mishandles newlines in values,
+{
+ (set) 2>&1 |
+ case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in
+ *ac_space=\ *)
+ sed -n \
+ "s/'"'"'/'"'"'\\\\'"'"''"'"'/g;
+ s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p"
+ ;;
+ *)
+ sed -n \
+ "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p"
+ ;;
+ esac;
+}
+ echo
+
+ cat <<\_ASBOX
+## ----------------- ##
+## Output variables. ##
+## ----------------- ##
+_ASBOX
+ echo
+ for ac_var in $ac_subst_vars
+ do
+ eval ac_val=$`echo $ac_var`
+ echo "$ac_var='"'"'$ac_val'"'"'"
+ done | sort
+ echo
+
+ if test -n "$ac_subst_files"; then
+ cat <<\_ASBOX
+## ------------- ##
+## Output files. ##
+## ------------- ##
+_ASBOX
+ echo
+ for ac_var in $ac_subst_files
+ do
+ eval ac_val=$`echo $ac_var`
+ echo "$ac_var='"'"'$ac_val'"'"'"
+ done | sort
+ echo
+ fi
+
+ if test -s confdefs.h; then
+ cat <<\_ASBOX
+## ----------- ##
+## confdefs.h. ##
+## ----------- ##
+_ASBOX
+ echo
+ sed "/^$/d" confdefs.h | sort
+ echo
+ fi
+ test "$ac_signal" != 0 &&
+ echo "$as_me: caught signal $ac_signal"
+ echo "$as_me: exit $exit_status"
+ } >&5
+ rm -f core *.core &&
+ rm -rf conftest* confdefs* conf$$* $ac_clean_files &&
+ exit $exit_status
+ ' 0
+for ac_signal in 1 2 13 15; do
+ trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal
+done
+ac_signal=0
+
+# confdefs.h avoids OS command line length limits that DEFS can exceed.
+rm -rf conftest* confdefs.h
+# AIX cpp loses on an empty file, so make sure it contains at least a newline.
+echo >confdefs.h
+
+# Predefined preprocessor variables.
+
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_NAME "$PACKAGE_NAME"
+_ACEOF
+
+
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_TARNAME "$PACKAGE_TARNAME"
+_ACEOF
+
+
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_VERSION "$PACKAGE_VERSION"
+_ACEOF
+
+
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_STRING "$PACKAGE_STRING"
+_ACEOF
+
+
+cat >>confdefs.h <<_ACEOF
+#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT"
+_ACEOF
+
+
+# Let the site file select an alternate cache file if it wants to.
+# Prefer explicitly selected file to automatically selected ones.
+if test -z "$CONFIG_SITE"; then
+ if test "x$prefix" != xNONE; then
+ CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site"
+ else
+ CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site"
+ fi
+fi
+for ac_site_file in $CONFIG_SITE; do
+ if test -r "$ac_site_file"; then
+ { echo "$as_me:$LINENO: loading site script $ac_site_file" >&5
+echo "$as_me: loading site script $ac_site_file" >&6;}
+ sed 's/^/| /' "$ac_site_file" >&5
+ . "$ac_site_file"
+ fi
+done
+
+if test -r "$cache_file"; then
+ # Some versions of bash will fail to source /dev/null (special
+ # files actually), so we avoid doing that.
+ if test -f "$cache_file"; then
+ { echo "$as_me:$LINENO: loading cache $cache_file" >&5
+echo "$as_me: loading cache $cache_file" >&6;}
+ case $cache_file in
+ [\\/]* | ?:[\\/]* ) . $cache_file;;
+ *) . ./$cache_file;;
+ esac
+ fi
+else
+ { echo "$as_me:$LINENO: creating cache $cache_file" >&5
+echo "$as_me: creating cache $cache_file" >&6;}
+ >$cache_file
+fi
+
+# Check that the precious variables saved in the cache have kept the same
+# value.
+ac_cache_corrupted=false
+for ac_var in `(set) 2>&1 |
+ sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; do
+ eval ac_old_set=\$ac_cv_env_${ac_var}_set
+ eval ac_new_set=\$ac_env_${ac_var}_set
+ eval ac_old_val="\$ac_cv_env_${ac_var}_value"
+ eval ac_new_val="\$ac_env_${ac_var}_value"
+ case $ac_old_set,$ac_new_set in
+ set,)
+ { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5
+echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;}
+ ac_cache_corrupted=: ;;
+ ,set)
+ { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5
+echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;}
+ ac_cache_corrupted=: ;;
+ ,);;
+ *)
+ if test "x$ac_old_val" != "x$ac_new_val"; then
+ { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5
+echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}
+ { echo "$as_me:$LINENO: former value: $ac_old_val" >&5
+echo "$as_me: former value: $ac_old_val" >&2;}
+ { echo "$as_me:$LINENO: current value: $ac_new_val" >&5
+echo "$as_me: current value: $ac_new_val" >&2;}
+ ac_cache_corrupted=:
+ fi;;
+ esac
+ # Pass precious variables to config.status.
+ if test "$ac_new_set" = set; then
+ case $ac_new_val in
+ *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*)
+ ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;;
+ *) ac_arg=$ac_var=$ac_new_val ;;
+ esac
+ case " $ac_configure_args " in
+ *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy.
+ *) ac_configure_args="$ac_configure_args '$ac_arg'" ;;
+ esac
+ fi
+done
+if $ac_cache_corrupted; then
+ { echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5
+echo "$as_me: error: changes in the environment can compromise the build" >&2;}
+ { { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5
+echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;}
+ { (exit 1); exit 1; }; }
+fi
+
+ac_ext=c
+ac_cpp='$CPP $CPPFLAGS'
+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'
+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'
+ac_compiler_gnu=$ac_cv_c_compiler_gnu
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+# Recover information that Tcl computed with its configure script.
+
+#--------------------------------------------------------------------
+# See if there was a command-line option for where Tcl is; if
+# not, assume that its top-level directory is a sibling of ours.
+#--------------------------------------------------------------------
+
+DEF_VER=8.6
+
+
+# Check whether --with-tcl or --without-tcl was given.
+if test "${with_tcl+set}" = set; then
+ withval="$with_tcl"
+ TCL_BIN_DIR=$withval
+else
+ TCL_BIN_DIR=`cd ../../tcl$DEF_VER$TCL_PATCH_LEVEL/unix; pwd`
+fi;
+if test ! -d $TCL_BIN_DIR; then
+ { { echo "$as_me:$LINENO: error: Tcl directory $TCL_BIN_DIR doesn't exist" >&5
+echo "$as_me: error: Tcl directory $TCL_BIN_DIR doesn't exist" >&2;}
+ { (exit 1); exit 1; }; }
+fi
+if test ! -f $TCL_BIN_DIR/tclConfig.sh; then
+ { { echo "$as_me:$LINENO: error: There's no tclConfig.sh in $TCL_BIN_DIR; perhaps you didn't specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?" >&5
+echo "$as_me: error: There's no tclConfig.sh in $TCL_BIN_DIR; perhaps you didn't specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?" >&2;}
+ { (exit 1); exit 1; }; }
+fi
+
+. $TCL_BIN_DIR/tclConfig.sh
+
+TCL_WIN_VERSION=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
+
+CC=$TCL_CC
+
+
+
+
+
+
+ ac_config_files="$ac_config_files Makefile tcl.hpj"
+cat >confcache <<\_ACEOF
+# This file is a shell script that caches the results of configure
+# tests run on this system so they can be shared between configure
+# scripts and configure runs, see configure's option --config-cache.
+# It is not useful on other systems. If it contains results you don't
+# want to keep, you may remove or edit it.
+#
+# config.status only pays attention to the cache file if you give it
+# the --recheck option to rerun configure.
+#
+# `ac_cv_env_foo' variables (set or unset) will be overridden when
+# loading this file, other *unset* `ac_cv_foo' will be assigned the
+# following values.
+
+_ACEOF
+
+# The following way of writing the cache mishandles newlines in values,
+# but we know of no workaround that is simple, portable, and efficient.
+# So, don't put newlines in cache variables' values.
+# Ultrix sh set writes to stderr and can't be redirected directly,
+# and sets the high bit in the cache file unless we assign to the vars.
+{
+ (set) 2>&1 |
+ case `(ac_space=' '; set | grep ac_space) 2>&1` in
+ *ac_space=\ *)
+ # `set' does not quote correctly, so add quotes (double-quote
+ # substitution turns \\\\ into \\, and sed turns \\ into \).
+ sed -n \
+ "s/'/'\\\\''/g;
+ s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p"
+ ;;
+ *)
+ # `set' quotes correctly as required by POSIX, so do not add quotes.
+ sed -n \
+ "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p"
+ ;;
+ esac;
+} |
+ sed '
+ t clear
+ : clear
+ s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/
+ t end
+ /^ac_cv_env/!s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/
+ : end' >>confcache
+if diff $cache_file confcache >/dev/null 2>&1; then :; else
+ if test -w $cache_file; then
+ test "x$cache_file" != "x/dev/null" && echo "updating cache $cache_file"
+ cat confcache >$cache_file
+ else
+ echo "not updating unwritable cache $cache_file"
+ fi
+fi
+rm -f confcache
+
+test "x$prefix" = xNONE && prefix=$ac_default_prefix
+# Let make expand exec_prefix.
+test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'
+
+# VPATH may cause trouble with some makes, so we remove $(srcdir),
+# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and
+# trailing colons and then remove the whole line if VPATH becomes empty
+# (actually we leave an empty line to preserve line numbers).
+if test "x$srcdir" = x.; then
+ ac_vpsub='/^[ ]*VPATH[ ]*=/{
+s/:*\$(srcdir):*/:/;
+s/:*\${srcdir}:*/:/;
+s/:*@srcdir@:*/:/;
+s/^\([^=]*=[ ]*\):*/\1/;
+s/:*$//;
+s/^[^=]*=[ ]*$//;
+}'
+fi
+
+# Transform confdefs.h into DEFS.
+# Protect against shell expansion while executing Makefile rules.
+# Protect against Makefile macro expansion.
+#
+# If the first sed substitution is executed (which looks for macros that
+# take arguments), then we branch to the quote section. Otherwise,
+# look for a macro that doesn't take arguments.
+cat >confdef2opt.sed <<\_ACEOF
+t clear
+: clear
+s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\),-D\1=\2,g
+t quote
+s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\),-D\1=\2,g
+t quote
+d
+: quote
+s,[ `~#$^&*(){}\\|;'"<>?],\\&,g
+s,\[,\\&,g
+s,\],\\&,g
+s,\$,$$,g
+p
+_ACEOF
+# We use echo to avoid assuming a particular line-breaking character.
+# The extra dot is to prevent the shell from consuming trailing
+# line-breaks from the sub-command output. A line-break within
+# single-quotes doesn't work because, if this script is created in a
+# platform that uses two characters for line-breaks (e.g., DOS), tr
+# would break.
+ac_LF_and_DOT=`echo; echo .`
+DEFS=`sed -n -f confdef2opt.sed confdefs.h | tr "$ac_LF_and_DOT" ' .'`
+rm -f confdef2opt.sed
+
+
+ac_libobjs=
+ac_ltlibobjs=
+for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue
+ # 1. Remove the extension, and $U if already installed.
+ ac_i=`echo "$ac_i" |
+ sed 's/\$U\././;s/\.o$//;s/\.obj$//'`
+ # 2. Add them.
+ ac_libobjs="$ac_libobjs $ac_i\$U.$ac_objext"
+ ac_ltlibobjs="$ac_ltlibobjs $ac_i"'$U.lo'
+done
+LIBOBJS=$ac_libobjs
+
+LTLIBOBJS=$ac_ltlibobjs
+
+
+
+: ${CONFIG_STATUS=./config.status}
+ac_clean_files_save=$ac_clean_files
+ac_clean_files="$ac_clean_files $CONFIG_STATUS"
+{ echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5
+echo "$as_me: creating $CONFIG_STATUS" >&6;}
+cat >$CONFIG_STATUS <<_ACEOF
+#! $SHELL
+# Generated by $as_me.
+# Run this file to recreate the current configuration.
+# Compiler output produced by configure, useful for debugging
+# configure, is in config.log if it exists.
+
+debug=false
+ac_cs_recheck=false
+ac_cs_silent=false
+SHELL=\${CONFIG_SHELL-$SHELL}
+_ACEOF
+
+cat >>$CONFIG_STATUS <<\_ACEOF
+## --------------------- ##
+## M4sh Initialization. ##
+## --------------------- ##
+
+# Be Bourne compatible
+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then
+ emulate sh
+ NULLCMD=:
+ # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which
+ # is contrary to our usage. Disable this feature.
+ alias -g '${1+"$@"}'='"$@"'
+elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then
+ set -o posix
+fi
+DUALCASE=1; export DUALCASE # for MKS sh
+
+# Support unset when possible.
+if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then
+ as_unset=unset
+else
+ as_unset=false
+fi
+
+
+# Work around bugs in pre-3.0 UWIN ksh.
+$as_unset ENV MAIL MAILPATH
+PS1='$ '
+PS2='> '
+PS4='+ '
+
+# NLS nuisances.
+for as_var in \
+ LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \
+ LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \
+ LC_TELEPHONE LC_TIME
+do
+ if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then
+ eval $as_var=C; export $as_var
+ else
+ $as_unset $as_var
+ fi
+done
+
+# Required to use basename.
+if expr a : '\(a\)' >/dev/null 2>&1; then
+ as_expr=expr
+else
+ as_expr=false
+fi
+
+if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then
+ as_basename=basename
+else
+ as_basename=false
+fi
+
+
+# Name of the executable.
+as_me=`$as_basename "$0" ||
+$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \
+ X"$0" : 'X\(//\)$' \| \
+ X"$0" : 'X\(/\)$' \| \
+ . : '\(.\)' 2>/dev/null ||
+echo X/"$0" |
+ sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; }
+ /^X\/\(\/\/\)$/{ s//\1/; q; }
+ /^X\/\(\/\).*/{ s//\1/; q; }
+ s/.*/./; q'`
+
+
+# PATH needs CR, and LINENO needs CR and PATH.
+# Avoid depending upon Character Ranges.
+as_cr_letters='abcdefghijklmnopqrstuvwxyz'
+as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'
+as_cr_Letters=$as_cr_letters$as_cr_LETTERS
+as_cr_digits='0123456789'
+as_cr_alnum=$as_cr_Letters$as_cr_digits
+
+# The user is always right.
+if test "${PATH_SEPARATOR+set}" != set; then
+ echo "#! /bin/sh" >conf$$.sh
+ echo "exit 0" >>conf$$.sh
+ chmod +x conf$$.sh
+ if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then
+ PATH_SEPARATOR=';'
+ else
+ PATH_SEPARATOR=:
+ fi
+ rm -f conf$$.sh
+fi
+
+
+ as_lineno_1=$LINENO
+ as_lineno_2=$LINENO
+ as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null`
+ test "x$as_lineno_1" != "x$as_lineno_2" &&
+ test "x$as_lineno_3" = "x$as_lineno_2" || {
+ # Find who we are. Look in the path if we contain no path at all
+ # relative or not.
+ case $0 in
+ *[\\/]* ) as_myself=$0 ;;
+ *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break
+done
+
+ ;;
+ esac
+ # We did not find ourselves, most probably we were run as `sh COMMAND'
+ # in which case we are not to be found in the path.
+ if test "x$as_myself" = x; then
+ as_myself=$0
+ fi
+ if test ! -f "$as_myself"; then
+ { { echo "$as_me:$LINENO: error: cannot find myself; rerun with an absolute path" >&5
+echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2;}
+ { (exit 1); exit 1; }; }
+ fi
+ case $CONFIG_SHELL in
+ '')
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for as_base in sh bash ksh sh5; do
+ case $as_dir in
+ /*)
+ if ("$as_dir/$as_base" -c '
+ as_lineno_1=$LINENO
+ as_lineno_2=$LINENO
+ as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null`
+ test "x$as_lineno_1" != "x$as_lineno_2" &&
+ test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then
+ $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; }
+ $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; }
+ CONFIG_SHELL=$as_dir/$as_base
+ export CONFIG_SHELL
+ exec "$CONFIG_SHELL" "$0" ${1+"$@"}
+ fi;;
+ esac
+ done
+done
+;;
+ esac
+
+ # Create $as_me.lineno as a copy of $as_myself, but with $LINENO
+ # uniformly replaced by the line number. The first 'sed' inserts a
+ # line-number line before each line; the second 'sed' does the real
+ # work. The second script uses 'N' to pair each line-number line
+ # with the numbered line, and appends trailing '-' during
+ # substitution so that $LINENO is not a special case at line end.
+ # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the
+ # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-)
+ sed '=' <$as_myself |
+ sed '
+ N
+ s,$,-,
+ : loop
+ s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3,
+ t loop
+ s,-$,,
+ s,^['$as_cr_digits']*\n,,
+ ' >$as_me.lineno &&
+ chmod +x $as_me.lineno ||
+ { { echo "$as_me:$LINENO: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&5
+echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2;}
+ { (exit 1); exit 1; }; }
+
+ # Don't try to exec as it changes $[0], causing all sort of problems
+ # (the dirname of $[0] is not the place where we might find the
+ # original and so on. Autoconf is especially sensible to this).
+ . ./$as_me.lineno
+ # Exit status is that of the last command.
+ exit
+}
+
+
+case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in
+ *c*,-n*) ECHO_N= ECHO_C='
+' ECHO_T=' ' ;;
+ *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;;
+ *) ECHO_N= ECHO_C='\c' ECHO_T= ;;
+esac
+
+if expr a : '\(a\)' >/dev/null 2>&1; then
+ as_expr=expr
+else
+ as_expr=false
+fi
+
+rm -f conf$$ conf$$.exe conf$$.file
+echo >conf$$.file
+if ln -s conf$$.file conf$$ 2>/dev/null; then
+ # We could just check for DJGPP; but this test a) works b) is more generic
+ # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04).
+ if test -f conf$$.exe; then
+ # Don't use ln at all; we don't have any links
+ as_ln_s='cp -p'
+ else
+ as_ln_s='ln -s'
+ fi
+elif ln conf$$.file conf$$ 2>/dev/null; then
+ as_ln_s=ln
+else
+ as_ln_s='cp -p'
+fi
+rm -f conf$$ conf$$.exe conf$$.file
+
+if mkdir -p . 2>/dev/null; then
+ as_mkdir_p=:
+else
+ test -d ./-p && rmdir ./-p
+ as_mkdir_p=false
+fi
+
+as_executable_p="test -f"
+
+# Sed expression to map a string onto a valid CPP name.
+as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"
+
+# Sed expression to map a string onto a valid variable name.
+as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"
+
+
+# IFS
+# We need space, tab and new line, in precisely that order.
+as_nl='
+'
+IFS=" $as_nl"
+
+# CDPATH.
+$as_unset CDPATH
+
+exec 6>&1
+
+# Open the log real soon, to keep \$[0] and so on meaningful, and to
+# report actual input values of CONFIG_FILES etc. instead of their
+# values after options handling. Logging --version etc. is OK.
+exec 5>>config.log
+{
+ echo
+ sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX
+## Running $as_me. ##
+_ASBOX
+} >&5
+cat >&5 <<_CSEOF
+
+This file was extended by $as_me, which was
+generated by GNU Autoconf 2.59. Invocation command line was
+
+ CONFIG_FILES = $CONFIG_FILES
+ CONFIG_HEADERS = $CONFIG_HEADERS
+ CONFIG_LINKS = $CONFIG_LINKS
+ CONFIG_COMMANDS = $CONFIG_COMMANDS
+ $ $0 $@
+
+_CSEOF
+echo "on `(hostname || uname -n) 2>/dev/null | sed 1q`" >&5
+echo >&5
+_ACEOF
+
+# Files that config.status was made for.
+if test -n "$ac_config_files"; then
+ echo "config_files=\"$ac_config_files\"" >>$CONFIG_STATUS
+fi
+
+if test -n "$ac_config_headers"; then
+ echo "config_headers=\"$ac_config_headers\"" >>$CONFIG_STATUS
+fi
+
+if test -n "$ac_config_links"; then
+ echo "config_links=\"$ac_config_links\"" >>$CONFIG_STATUS
+fi
+
+if test -n "$ac_config_commands"; then
+ echo "config_commands=\"$ac_config_commands\"" >>$CONFIG_STATUS
+fi
+
+cat >>$CONFIG_STATUS <<\_ACEOF
+
+ac_cs_usage="\
+\`$as_me' instantiates files from templates according to the
+current configuration.
+
+Usage: $0 [OPTIONS] [FILE]...
+
+ -h, --help print this help, then exit
+ -V, --version print version number, then exit
+ -q, --quiet do not print progress messages
+ -d, --debug don't remove temporary files
+ --recheck update $as_me by reconfiguring in the same conditions
+ --file=FILE[:TEMPLATE]
+ instantiate the configuration file FILE
+
+Configuration files:
+$config_files
+
+Report bugs to <bug-autoconf@gnu.org>."
+_ACEOF
+
+cat >>$CONFIG_STATUS <<_ACEOF
+ac_cs_version="\\
+config.status
+configured by $0, generated by GNU Autoconf 2.59,
+ with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\"
+
+Copyright (C) 2003 Free Software Foundation, Inc.
+This config.status script is free software; the Free Software Foundation
+gives unlimited permission to copy, distribute and modify it."
+srcdir=$srcdir
+_ACEOF
+
+cat >>$CONFIG_STATUS <<\_ACEOF
+# If no file are specified by the user, then we need to provide default
+# value. By we need to know if files were specified by the user.
+ac_need_defaults=:
+while test $# != 0
+do
+ case $1 in
+ --*=*)
+ ac_option=`expr "x$1" : 'x\([^=]*\)='`
+ ac_optarg=`expr "x$1" : 'x[^=]*=\(.*\)'`
+ ac_shift=:
+ ;;
+ -*)
+ ac_option=$1
+ ac_optarg=$2
+ ac_shift=shift
+ ;;
+ *) # This is not an option, so the user has probably given explicit
+ # arguments.
+ ac_option=$1
+ ac_need_defaults=false;;
+ esac
+
+ case $ac_option in
+ # Handling of the options.
+_ACEOF
+cat >>$CONFIG_STATUS <<\_ACEOF
+ -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)
+ ac_cs_recheck=: ;;
+ --version | --vers* | -V )
+ echo "$ac_cs_version"; exit 0 ;;
+ --he | --h)
+ # Conflict between --help and --header
+ { { echo "$as_me:$LINENO: error: ambiguous option: $1
+Try \`$0 --help' for more information." >&5
+echo "$as_me: error: ambiguous option: $1
+Try \`$0 --help' for more information." >&2;}
+ { (exit 1); exit 1; }; };;
+ --help | --hel | -h )
+ echo "$ac_cs_usage"; exit 0 ;;
+ --debug | --d* | -d )
+ debug=: ;;
+ --file | --fil | --fi | --f )
+ $ac_shift
+ CONFIG_FILES="$CONFIG_FILES $ac_optarg"
+ ac_need_defaults=false;;
+ --header | --heade | --head | --hea )
+ $ac_shift
+ CONFIG_HEADERS="$CONFIG_HEADERS $ac_optarg"
+ ac_need_defaults=false;;
+ -q | -quiet | --quiet | --quie | --qui | --qu | --q \
+ | -silent | --silent | --silen | --sile | --sil | --si | --s)
+ ac_cs_silent=: ;;
+
+ # This is an error.
+ -*) { { echo "$as_me:$LINENO: error: unrecognized option: $1
+Try \`$0 --help' for more information." >&5
+echo "$as_me: error: unrecognized option: $1
+Try \`$0 --help' for more information." >&2;}
+ { (exit 1); exit 1; }; } ;;
+
+ *) ac_config_targets="$ac_config_targets $1" ;;
+
+ esac
+ shift
+done
+
+ac_configure_extra_args=
+
+if $ac_cs_silent; then
+ exec 6>/dev/null
+ ac_configure_extra_args="$ac_configure_extra_args --silent"
+fi
+
+_ACEOF
+cat >>$CONFIG_STATUS <<_ACEOF
+if \$ac_cs_recheck; then
+ echo "running $SHELL $0 " $ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6
+ exec $SHELL $0 $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion
+fi
+
+_ACEOF
+
+
+
+
+
+cat >>$CONFIG_STATUS <<\_ACEOF
+for ac_config_target in $ac_config_targets
+do
+ case "$ac_config_target" in
+ # Handling of arguments.
+ "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;;
+ "tcl.hpj" ) CONFIG_FILES="$CONFIG_FILES tcl.hpj" ;;
+ *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5
+echo "$as_me: error: invalid argument: $ac_config_target" >&2;}
+ { (exit 1); exit 1; }; };;
+ esac
+done
+
+# If the user did not use the arguments to specify the items to instantiate,
+# then the envvar interface is used. Set only those that are not.
+# We use the long form for the default assignment because of an extremely
+# bizarre bug on SunOS 4.1.3.
+if $ac_need_defaults; then
+ test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files
+fi
+
+# Have a temporary directory for convenience. Make it in the build tree
+# simply because there is no reason to put it here, and in addition,
+# creating and moving files from /tmp can sometimes cause problems.
+# Create a temporary directory, and hook for its removal unless debugging.
+$debug ||
+{
+ trap 'exit_status=$?; rm -rf $tmp && exit $exit_status' 0
+ trap '{ (exit 1); exit 1; }' 1 2 13 15
+}
+
+# Create a (secure) tmp directory for tmp files.
+
+{
+ tmp=`(umask 077 && mktemp -d -q "./confstatXXXXXX") 2>/dev/null` &&
+ test -n "$tmp" && test -d "$tmp"
+} ||
+{
+ tmp=./confstat$$-$RANDOM
+ (umask 077 && mkdir $tmp)
+} ||
+{
+ echo "$me: cannot create a temporary directory in ." >&2
+ { (exit 1); exit 1; }
+}
+
+_ACEOF
+
+cat >>$CONFIG_STATUS <<_ACEOF
+
+#
+# CONFIG_FILES section.
+#
+
+# No need to generate the scripts if there are no CONFIG_FILES.
+# This happens for instance when ./config.status config.h
+if test -n "\$CONFIG_FILES"; then
+ # Protect against being on the right side of a sed subst in config.status.
+ sed 's/,@/@@/; s/@,/@@/; s/,;t t\$/@;t t/; /@;t t\$/s/[\\\\&,]/\\\\&/g;
+ s/@@/,@/; s/@@/@,/; s/@;t t\$/,;t t/' >\$tmp/subs.sed <<\\CEOF
+s,@SHELL@,$SHELL,;t t
+s,@PATH_SEPARATOR@,$PATH_SEPARATOR,;t t
+s,@PACKAGE_NAME@,$PACKAGE_NAME,;t t
+s,@PACKAGE_TARNAME@,$PACKAGE_TARNAME,;t t
+s,@PACKAGE_VERSION@,$PACKAGE_VERSION,;t t
+s,@PACKAGE_STRING@,$PACKAGE_STRING,;t t
+s,@PACKAGE_BUGREPORT@,$PACKAGE_BUGREPORT,;t t
+s,@exec_prefix@,$exec_prefix,;t t
+s,@prefix@,$prefix,;t t
+s,@program_transform_name@,$program_transform_name,;t t
+s,@bindir@,$bindir,;t t
+s,@sbindir@,$sbindir,;t t
+s,@libexecdir@,$libexecdir,;t t
+s,@datadir@,$datadir,;t t
+s,@sysconfdir@,$sysconfdir,;t t
+s,@sharedstatedir@,$sharedstatedir,;t t
+s,@localstatedir@,$localstatedir,;t t
+s,@libdir@,$libdir,;t t
+s,@includedir@,$includedir,;t t
+s,@oldincludedir@,$oldincludedir,;t t
+s,@infodir@,$infodir,;t t
+s,@mandir@,$mandir,;t t
+s,@build_alias@,$build_alias,;t t
+s,@host_alias@,$host_alias,;t t
+s,@target_alias@,$target_alias,;t t
+s,@DEFS@,$DEFS,;t t
+s,@ECHO_C@,$ECHO_C,;t t
+s,@ECHO_N@,$ECHO_N,;t t
+s,@ECHO_T@,$ECHO_T,;t t
+s,@LIBS@,$LIBS,;t t
+s,@TCL_WIN_VERSION@,$TCL_WIN_VERSION,;t t
+s,@CC@,$CC,;t t
+s,@TCL_VERSION@,$TCL_VERSION,;t t
+s,@TCL_PATCH_LEVEL@,$TCL_PATCH_LEVEL,;t t
+s,@TCL_SRC_DIR@,$TCL_SRC_DIR,;t t
+s,@TCL_BIN_DIR@,$TCL_BIN_DIR,;t t
+s,@LIBOBJS@,$LIBOBJS,;t t
+s,@LTLIBOBJS@,$LTLIBOBJS,;t t
+CEOF
+
+_ACEOF
+
+ cat >>$CONFIG_STATUS <<\_ACEOF
+ # Split the substitutions into bite-sized pieces for seds with
+ # small command number limits, like on Digital OSF/1 and HP-UX.
+ ac_max_sed_lines=48
+ ac_sed_frag=1 # Number of current file.
+ ac_beg=1 # First line for current file.
+ ac_end=$ac_max_sed_lines # Line after last line for current file.
+ ac_more_lines=:
+ ac_sed_cmds=
+ while $ac_more_lines; do
+ if test $ac_beg -gt 1; then
+ sed "1,${ac_beg}d; ${ac_end}q" $tmp/subs.sed >$tmp/subs.frag
+ else
+ sed "${ac_end}q" $tmp/subs.sed >$tmp/subs.frag
+ fi
+ if test ! -s $tmp/subs.frag; then
+ ac_more_lines=false
+ else
+ # The purpose of the label and of the branching condition is to
+ # speed up the sed processing (if there are no `@' at all, there
+ # is no need to browse any of the substitutions).
+ # These are the two extra sed commands mentioned above.
+ (echo ':t
+ /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed
+ if test -z "$ac_sed_cmds"; then
+ ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed"
+ else
+ ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed"
+ fi
+ ac_sed_frag=`expr $ac_sed_frag + 1`
+ ac_beg=$ac_end
+ ac_end=`expr $ac_end + $ac_max_sed_lines`
+ fi
+ done
+ if test -z "$ac_sed_cmds"; then
+ ac_sed_cmds=cat
+ fi
+fi # test -n "$CONFIG_FILES"
+
+_ACEOF
+cat >>$CONFIG_STATUS <<\_ACEOF
+for ac_file in : $CONFIG_FILES; do test "x$ac_file" = x: && continue
+ # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in".
+ case $ac_file in
+ - | *:- | *:-:* ) # input from stdin
+ cat >$tmp/stdin
+ ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'`
+ ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;;
+ *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'`
+ ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;;
+ * ) ac_file_in=$ac_file.in ;;
+ esac
+
+ # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories.
+ ac_dir=`(dirname "$ac_file") 2>/dev/null ||
+$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$ac_file" : 'X\(//\)[^/]' \| \
+ X"$ac_file" : 'X\(//\)$' \| \
+ X"$ac_file" : 'X\(/\)' \| \
+ . : '\(.\)' 2>/dev/null ||
+echo X"$ac_file" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; }
+ /^X\(\/\/\)[^/].*/{ s//\1/; q; }
+ /^X\(\/\/\)$/{ s//\1/; q; }
+ /^X\(\/\).*/{ s//\1/; q; }
+ s/.*/./; q'`
+ { if $as_mkdir_p; then
+ mkdir -p "$ac_dir"
+ else
+ as_dir="$ac_dir"
+ as_dirs=
+ while test ! -d "$as_dir"; do
+ as_dirs="$as_dir $as_dirs"
+ as_dir=`(dirname "$as_dir") 2>/dev/null ||
+$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \
+ X"$as_dir" : 'X\(//\)[^/]' \| \
+ X"$as_dir" : 'X\(//\)$' \| \
+ X"$as_dir" : 'X\(/\)' \| \
+ . : '\(.\)' 2>/dev/null ||
+echo X"$as_dir" |
+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; }
+ /^X\(\/\/\)[^/].*/{ s//\1/; q; }
+ /^X\(\/\/\)$/{ s//\1/; q; }
+ /^X\(\/\).*/{ s//\1/; q; }
+ s/.*/./; q'`
+ done
+ test ! -n "$as_dirs" || mkdir $as_dirs
+ fi || { { echo "$as_me:$LINENO: error: cannot create directory \"$ac_dir\"" >&5
+echo "$as_me: error: cannot create directory \"$ac_dir\"" >&2;}
+ { (exit 1); exit 1; }; }; }
+
+ ac_builddir=.
+
+if test "$ac_dir" != .; then
+ ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'`
+ # A "../" for each directory in $ac_dir_suffix.
+ ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'`
+else
+ ac_dir_suffix= ac_top_builddir=
+fi
+
+case $srcdir in
+ .) # No --srcdir option. We are building in place.
+ ac_srcdir=.
+ if test -z "$ac_top_builddir"; then
+ ac_top_srcdir=.
+ else
+ ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'`
+ fi ;;
+ [\\/]* | ?:[\\/]* ) # Absolute path.
+ ac_srcdir=$srcdir$ac_dir_suffix;
+ ac_top_srcdir=$srcdir ;;
+ *) # Relative path.
+ ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix
+ ac_top_srcdir=$ac_top_builddir$srcdir ;;
+esac
+
+# Do not use `cd foo && pwd` to compute absolute paths, because
+# the directories may not exist.
+case `pwd` in
+.) ac_abs_builddir="$ac_dir";;
+*)
+ case "$ac_dir" in
+ .) ac_abs_builddir=`pwd`;;
+ [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";;
+ *) ac_abs_builddir=`pwd`/"$ac_dir";;
+ esac;;
+esac
+case $ac_abs_builddir in
+.) ac_abs_top_builddir=${ac_top_builddir}.;;
+*)
+ case ${ac_top_builddir}. in
+ .) ac_abs_top_builddir=$ac_abs_builddir;;
+ [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;;
+ *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;;
+ esac;;
+esac
+case $ac_abs_builddir in
+.) ac_abs_srcdir=$ac_srcdir;;
+*)
+ case $ac_srcdir in
+ .) ac_abs_srcdir=$ac_abs_builddir;;
+ [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;;
+ *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;;
+ esac;;
+esac
+case $ac_abs_builddir in
+.) ac_abs_top_srcdir=$ac_top_srcdir;;
+*)
+ case $ac_top_srcdir in
+ .) ac_abs_top_srcdir=$ac_abs_builddir;;
+ [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;;
+ *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;;
+ esac;;
+esac
+
+
+
+ if test x"$ac_file" != x-; then
+ { echo "$as_me:$LINENO: creating $ac_file" >&5
+echo "$as_me: creating $ac_file" >&6;}
+ rm -f "$ac_file"
+ fi
+ # Let's still pretend it is `configure' which instantiates (i.e., don't
+ # use $as_me), people would be surprised to read:
+ # /* config.h. Generated by config.status. */
+ if test x"$ac_file" = x-; then
+ configure_input=
+ else
+ configure_input="$ac_file. "
+ fi
+ configure_input=$configure_input"Generated from `echo $ac_file_in |
+ sed 's,.*/,,'` by configure."
+
+ # First look for the input files in the build tree, otherwise in the
+ # src tree.
+ ac_file_inputs=`IFS=:
+ for f in $ac_file_in; do
+ case $f in
+ -) echo $tmp/stdin ;;
+ [\\/$]*)
+ # Absolute (can't be DOS-style, as IFS=:)
+ test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5
+echo "$as_me: error: cannot find input file: $f" >&2;}
+ { (exit 1); exit 1; }; }
+ echo "$f";;
+ *) # Relative
+ if test -f "$f"; then
+ # Build tree
+ echo "$f"
+ elif test -f "$srcdir/$f"; then
+ # Source tree
+ echo "$srcdir/$f"
+ else
+ # /dev/null tree
+ { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5
+echo "$as_me: error: cannot find input file: $f" >&2;}
+ { (exit 1); exit 1; }; }
+ fi;;
+ esac
+ done` || { (exit 1); exit 1; }
+_ACEOF
+cat >>$CONFIG_STATUS <<_ACEOF
+ sed "$ac_vpsub
+$extrasub
+_ACEOF
+cat >>$CONFIG_STATUS <<\_ACEOF
+:t
+/@[a-zA-Z_][a-zA-Z_0-9]*@/!b
+s,@configure_input@,$configure_input,;t t
+s,@srcdir@,$ac_srcdir,;t t
+s,@abs_srcdir@,$ac_abs_srcdir,;t t
+s,@top_srcdir@,$ac_top_srcdir,;t t
+s,@abs_top_srcdir@,$ac_abs_top_srcdir,;t t
+s,@builddir@,$ac_builddir,;t t
+s,@abs_builddir@,$ac_abs_builddir,;t t
+s,@top_builddir@,$ac_top_builddir,;t t
+s,@abs_top_builddir@,$ac_abs_top_builddir,;t t
+" $ac_file_inputs | (eval "$ac_sed_cmds") >$tmp/out
+ rm -f $tmp/stdin
+ if test x"$ac_file" != x-; then
+ mv $tmp/out $ac_file
+ else
+ cat $tmp/out
+ rm -f $tmp/out
+ fi
+
+done
+_ACEOF
+
+cat >>$CONFIG_STATUS <<\_ACEOF
+
+{ (exit 0); exit 0; }
+_ACEOF
+chmod +x $CONFIG_STATUS
+ac_clean_files=$ac_clean_files_save
+
+
+# configure is writing to config.log, and then calls config.status.
+# config.status does its own redirection, appending to config.log.
+# Unfortunately, on DOS this fails, as config.log is still kept open
+# by configure, so config.status won't be able to write to it; its
+# output is simply discarded. So we exec the FD to /dev/null,
+# effectively closing config.log, so it can be properly (re)opened and
+# appended to by config.status. When coming back to configure, we
+# need to make the FD available again.
+if test "$no_create" != yes; then
+ ac_cs_success=:
+ ac_config_status_args=
+ test "$silent" = yes &&
+ ac_config_status_args="$ac_config_status_args --quiet"
+ exec 5>/dev/null
+ $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false
+ exec 5>>config.log
+ # Use ||, not &&, to avoid exiting from the if with $? = 1, which
+ # would make configure fail if this is the last instruction.
+ $ac_cs_success || { (exit 1); exit 1; }
+fi
+
diff --git a/tcl8.6/tools/configure.in b/tcl8.6/tools/configure.in
new file mode 100644
index 0000000..6aebcaa
--- /dev/null
+++ b/tcl8.6/tools/configure.in
@@ -0,0 +1,35 @@
+dnl This file is an input file used by the GNU "autoconf" program to
+dnl generate the file "configure", which is run to configure the
+dnl Makefile in this directory.
+AC_INIT(man2tcl.c)
+AC_PREREQ(2.59)
+
+# Recover information that Tcl computed with its configure script.
+
+#--------------------------------------------------------------------
+# See if there was a command-line option for where Tcl is; if
+# not, assume that its top-level directory is a sibling of ours.
+#--------------------------------------------------------------------
+
+DEF_VER=8.6
+
+AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl $DEF_VER binaries from DIR], TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd ../../tcl$DEF_VER$TCL_PATCH_LEVEL/unix; pwd`)
+if test ! -d $TCL_BIN_DIR; then
+ AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR doesn't exist)
+fi
+if test ! -f $TCL_BIN_DIR/tclConfig.sh; then
+ AC_MSG_ERROR(There's no tclConfig.sh in $TCL_BIN_DIR; perhaps you didn't specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?)
+fi
+
+. $TCL_BIN_DIR/tclConfig.sh
+
+TCL_WIN_VERSION=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
+AC_SUBST(TCL_WIN_VERSION)
+CC=$TCL_CC
+AC_SUBST(CC)
+AC_SUBST(TCL_VERSION)
+AC_SUBST(TCL_PATCH_LEVEL)
+AC_SUBST(TCL_SRC_DIR)
+AC_SUBST(TCL_BIN_DIR)
+
+AC_OUTPUT(Makefile tcl.hpj)
diff --git a/tcl8.6/tools/eolFix.tcl b/tcl8.6/tools/eolFix.tcl
new file mode 100644
index 0000000..3f35ed4
--- /dev/null
+++ b/tcl8.6/tools/eolFix.tcl
@@ -0,0 +1,80 @@
+## Super aggressive EOL-fixer!
+##
+## Will even understand screwed up ones like CRCRLF.
+## (found in bad CVS repositories, caused by spacey developers
+## abusing CVS)
+##
+## davygrvy@pobox.com 3:41 PM 10/12/2001
+##
+
+package provide EOL-fix 1.1
+
+namespace eval ::EOL {
+ variable outMode crlf
+}
+
+proc EOL::fix {filename {newfilename {}}} {
+ variable outMode
+
+ if {![file exists $filename]} {
+ return
+ }
+ puts "EOL Fixing: $filename"
+
+ file rename ${filename} ${filename}.o
+ set fhnd [open ${filename}.o r]
+
+ if {$newfilename ne ""} {
+ set newfhnd [open ${newfilename} w]
+ } else {
+ set newfhnd [open ${filename} w]
+ }
+
+ fconfigure $newfhnd -translation [list auto $outMode]
+ seek $fhnd 0 end
+ set theEnd [tell $fhnd]
+ seek $fhnd 0 start
+
+ fconfigure $fhnd -translation binary -buffersize $theEnd
+ set rawFile [read $fhnd $theEnd]
+ close $fhnd
+
+ regsub -all {(\r)|(\r){1,2}(\n)} $rawFile "\n" rawFile
+
+ set lineList [split $rawFile \n]
+
+ foreach line $lineList {
+ puts $newfhnd $line
+ }
+
+ close $newfhnd
+ file delete ${filename}.o
+}
+
+proc EOL::fixall {args} {
+ if {[llength $args] == 0} {
+ puts stderr "no files to fix"
+ exit 1
+ } else {
+ set cmd [lreplace $args -1 -1 glob -nocomplain]
+ }
+
+ foreach f [eval $cmd] {
+ if {[file isfile $f]} {fix $f}
+ }
+}
+
+if {$tcl_interactive == 0 && $argc > 0} {
+ if {[string index [lindex $argv 0] 0] eq "-"} {
+ switch -- [lindex $argv 0] {
+ -cr {set ::EOL::outMode cr}
+ -crlf {set ::EOL::outMode crlf}
+ -lf {set ::EOL::outMode lf}
+ default {puts stderr "improper mode switch"; exit 1}
+ }
+ set argv [lrange $argv 1 end]
+ }
+ eval EOL::fixall $argv
+} else {
+ return
+}
diff --git a/tcl8.6/tools/feather.bmp b/tcl8.6/tools/feather.bmp
new file mode 100644
index 0000000..23aa02e
--- /dev/null
+++ b/tcl8.6/tools/feather.bmp
Binary files differ
diff --git a/tcl8.6/tools/findBadExternals.tcl b/tcl8.6/tools/findBadExternals.tcl
new file mode 100755
index 0000000..2228357
--- /dev/null
+++ b/tcl8.6/tools/findBadExternals.tcl
@@ -0,0 +1,53 @@
+# findBadExternals.tcl --
+#
+# This script scans the Tcl load library for exported symbols
+# that do not begin with 'Tcl' or 'tcl'. It reports them on the
+# standard output. It is used to make sure that the library does
+# not inadvertently export externals that may be in conflict with
+# other code.
+#
+# Usage:
+#
+# tclsh findBadExternals.tcl /path/to/tclXX.so-or-.dll
+#
+# Copyright (c) 2005 George Peter Staplin and Kevin Kenny
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#----------------------------------------------------------------------
+
+proc main {argc argv} {
+
+ if {$argc != 1} {
+ puts stderr "syntax is: [info script] libtcl"
+ return 1
+ }
+
+
+ switch -exact -- $::tcl_platform(platform) {
+ unix -
+ macosx {
+ set status [catch {
+ exec nm --extern-only --defined-only [lindex $argv 0]
+ } result]
+ }
+ windows {
+ set status [catch {
+ exec dumpbin /exports [lindex $argv 0]
+ } result]
+ }
+ }
+ if {$status != 0 && $::errorCode ne "NONE"} {
+ puts $result
+ return 1
+ }
+
+ foreach line [split $result \n] {
+ if {! [string match {* [Tt]cl*} $line]} {
+ puts $line
+ }
+ }
+
+ return 0
+}
+exit [main $::argc $::argv]
diff --git a/tcl8.6/tools/fix_tommath_h.tcl b/tcl8.6/tools/fix_tommath_h.tcl
new file mode 100755
index 0000000..04bf857
--- /dev/null
+++ b/tcl8.6/tools/fix_tommath_h.tcl
@@ -0,0 +1,102 @@
+# fixtommath.tcl --
+#
+# Changes to 'tommath.h' to make it conform with Tcl's linking
+# conventions.
+#
+# Copyright (c) 2005 by 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.
+#----------------------------------------------------------------------
+
+set f [open [lindex $argv 0] r]
+set data [read $f]
+close $f
+
+set eat_endif 0
+set eat_semi 0
+set def_count 0
+foreach line [split $data \n] {
+ if {!$eat_semi && !$eat_endif} {
+ switch -regexp -- $line {
+ {#define BN_H_} {
+ puts $line
+ puts {}
+ puts "\#include \"tclInt.h\""
+ puts "\#include \"tclTomMathDecls.h\""
+ puts "\#ifndef MODULE_SCOPE"
+ puts "\#define MODULE_SCOPE extern"
+ puts "\#endif"
+ }
+ {typedef\s+unsigned long\s+mp_digit;} {
+ # change the second 'typedef unsigned long mp
+ incr def_count
+ puts "\#ifndef MP_DIGIT_DECLARED"
+ if {$def_count == 2} {
+ puts [string map {long int} $line]
+ } else {
+ puts $line
+ }
+ puts "\#define MP_DIGIT_DECLARED"
+ puts "\#endif"
+ }
+ {typedef.*mp_digit;} {
+ puts "\#ifndef MP_DIGIT_DECLARED"
+ puts $line
+ puts "\#define MP_DIGIT_DECLARED"
+ puts "\#endif"
+ }
+ {typedef struct} {
+ puts "\#ifndef MP_INT_DECLARED"
+ puts "\#define MP_INT_DECLARED"
+ puts "typedef struct mp_int mp_int;"
+ puts "\#endif"
+ puts "struct mp_int \{"
+ }
+ \}\ mp_int\; {
+ puts "\};"
+ }
+ {^(char|int|void)} {
+ puts "/*"
+ puts $line
+ set eat_semi 1
+ set after_semi "*/"
+ }
+ {^extern (int|const)} {
+ puts "\#if defined(BUILD_tcl) || !defined(_WIN32)"
+ puts [regsub {^extern} $line "MODULE_SCOPE"]
+ set eat_semi 1
+ set after_semi "\#endif"
+ }
+ {define heap macros} {
+ puts $line
+ puts "\#if 0 /* these are macros in tclTomMathDecls.h */"
+ set eat_endif 1
+ }
+ {__x86_64__} {
+ puts "[string map {__x86_64__ NEVER} $line]\
+ /* 128-bit ints fail in too many places */"
+ }
+ {#include} {
+ # remove all includes
+ }
+ default {
+ puts $line
+ }
+ }
+ } else {
+ puts $line
+ }
+ if {$eat_semi} {
+ if {[regexp {; *$} $line]} {
+ puts $after_semi
+ set eat_semi 0
+ }
+ }
+ if {$eat_endif} {
+ if {[regexp {^\#endif} $line]} {
+ puts "\#endif"
+ set eat_endif 0
+ }
+ }
+}
diff --git a/tcl8.6/tools/genStubs.tcl b/tcl8.6/tools/genStubs.tcl
new file mode 100644
index 0000000..9f2c6ca
--- /dev/null
+++ b/tcl8.6/tools/genStubs.tcl
@@ -0,0 +1,1179 @@
+# genStubs.tcl --
+#
+# This script generates a set of stub files for a given
+# interface.
+#
+#
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+namespace eval genStubs {
+ # libraryName --
+ #
+ # The name of the entire library. This value is used to compute
+ # the USE_*_STUBS macro and the name of the init file.
+
+ variable libraryName "UNKNOWN"
+
+ # interfaces --
+ #
+ # An array indexed by interface name that is used to maintain
+ # the set of valid interfaces. The value is empty.
+
+ array set interfaces {}
+
+ # curName --
+ #
+ # The name of the interface currently being defined.
+
+ variable curName "UNKNOWN"
+
+ # scspec --
+ #
+ # Storage class specifier for external function declarations.
+ # Normally "EXTERN", may be set to something like XYZAPI
+ #
+ variable scspec "EXTERN"
+
+ # epoch, revision --
+ #
+ # The epoch and revision numbers of the interface currently being defined.
+ # (@@@TODO: should be an array mapping interface names -> numbers)
+ #
+
+ variable epoch {}
+ variable revision 0
+
+ # hooks --
+ #
+ # An array indexed by interface name that contains the set of
+ # subinterfaces that should be defined for a given interface.
+
+ array set hooks {}
+
+ # stubs --
+ #
+ # This three dimensional array is indexed first by interface name,
+ # second by platform name, and third by a numeric offset or the
+ # constant "lastNum". The lastNum entry contains the largest
+ # numeric offset used for a given interface/platform combo. Each
+ # numeric offset contains the C function specification that
+ # should be used for the given entry in the stub table. The spec
+ # consists of a list in the form returned by parseDecl.
+
+ array set stubs {}
+
+ # outDir --
+ #
+ # The directory where the generated files should be placed.
+
+ variable outDir .
+}
+
+# genStubs::library --
+#
+# This function is used in the declarations file to set the name
+# of the library that the interfaces are associated with (e.g. "tcl").
+# This value will be used to define the inline conditional macro.
+#
+# Arguments:
+# name The library name.
+#
+# Results:
+# None.
+
+proc genStubs::library {name} {
+ variable libraryName $name
+}
+
+# genStubs::interface --
+#
+# This function is used in the declarations file to set the name
+# of the interface currently being defined.
+#
+# Arguments:
+# name The name of the interface.
+#
+# Results:
+# None.
+
+proc genStubs::interface {name} {
+ variable curName $name
+ variable interfaces
+
+ set interfaces($name) {}
+ return
+}
+
+# genStubs::scspec --
+#
+# Define the storage class macro used for external function declarations.
+# Typically, this will be a macro like XYZAPI or EXTERN that
+# expands to either DLLIMPORT or DLLEXPORT, depending on whether
+# -DBUILD_XYZ has been set.
+#
+proc genStubs::scspec {value} {
+ variable scspec $value
+}
+
+# genStubs::epoch --
+#
+# Define the epoch number for this library. The epoch
+# should be incrememented when a release is made that
+# contains incompatible changes to the public API.
+#
+proc genStubs::epoch {value} {
+ variable epoch $value
+}
+
+# genStubs::hooks --
+#
+# This function defines the subinterface hooks for the current
+# interface.
+#
+# Arguments:
+# names The ordered list of interfaces that are reachable through the
+# hook vector.
+#
+# Results:
+# None.
+
+proc genStubs::hooks {names} {
+ variable curName
+ variable hooks
+
+ set hooks($curName) $names
+ return
+}
+
+# genStubs::declare --
+#
+# This function is used in the declarations file to declare a new
+# interface entry.
+#
+# Arguments:
+# index The index number of the interface.
+# platform The platform the interface belongs to. Should be one
+# of generic, win, unix, or macosx or aqua or x11.
+# decl The C function declaration, or {} for an undefined
+# entry.
+#
+# Results:
+# None.
+
+proc genStubs::declare {args} {
+ variable stubs
+ variable curName
+ variable revision
+
+ incr revision
+ if {[llength $args] == 2} {
+ lassign $args index decl
+ set platformList generic
+ } elseif {[llength $args] == 3} {
+ lassign $args index platformList decl
+ } else {
+ puts stderr "wrong # args: declare $args"
+ return
+ }
+
+ # Check for duplicate declarations, then add the declaration and
+ # bump the lastNum counter if necessary.
+
+ foreach platform $platformList {
+ if {[info exists stubs($curName,$platform,$index)]} {
+ puts stderr "Duplicate entry: declare $args"
+ }
+ }
+ regsub -all "\[ \t\n\]+" [string trim $decl] " " decl
+ set decl [parseDecl $decl]
+
+ foreach platform $platformList {
+ if {$decl ne ""} {
+ set stubs($curName,$platform,$index) $decl
+ if {![info exists stubs($curName,$platform,lastNum)] \
+ || ($index > $stubs($curName,$platform,lastNum))} {
+ set stubs($curName,$platform,lastNum) $index
+ }
+ }
+ }
+ return
+}
+
+# genStubs::export --
+#
+# This function is used in the declarations file to declare a symbol
+# that is exported from the library but is not in the stubs table.
+#
+# Arguments:
+# decl The C function declaration, or {} for an undefined
+# entry.
+#
+# Results:
+# None.
+
+proc genStubs::export {args} {
+ if {[llength $args] != 1} {
+ puts stderr "wrong # args: export $args"
+ }
+ return
+}
+
+# genStubs::rewriteFile --
+#
+# This function replaces the machine generated portion of the
+# specified file with new contents. It looks for the !BEGIN! and
+# !END! comments to determine where to place the new text.
+#
+# Arguments:
+# file The name of the file to modify.
+# text The new text to place in the file.
+#
+# Results:
+# None.
+
+proc genStubs::rewriteFile {file text} {
+ if {![file exists $file]} {
+ puts stderr "Cannot find file: $file"
+ return
+ }
+ set in [open ${file} r]
+ set out [open ${file}.new w]
+ fconfigure $out -translation lf
+
+ while {![eof $in]} {
+ set line [gets $in]
+ if {[string match "*!BEGIN!*" $line]} {
+ break
+ }
+ puts $out $line
+ }
+ puts $out "/* !BEGIN!: Do not edit below this line. */"
+ puts $out $text
+ while {![eof $in]} {
+ set line [gets $in]
+ if {[string match "*!END!*" $line]} {
+ break
+ }
+ }
+ puts $out "/* !END!: Do not edit above this line. */"
+ puts -nonewline $out [read $in]
+ close $in
+ close $out
+ file rename -force ${file}.new ${file}
+ return
+}
+
+# genStubs::addPlatformGuard --
+#
+# Wrap a string inside a platform #ifdef.
+#
+# Arguments:
+# plat Platform to test.
+#
+# Results:
+# Returns the original text inside an appropriate #ifdef.
+
+proc genStubs::addPlatformGuard {plat iftxt {eltxt {}} {withCygwin 0}} {
+ set text ""
+ switch $plat {
+ win {
+ append text "#if defined(_WIN32)"
+ if {$withCygwin} {
+ append text " || defined(__CYGWIN__)"
+ }
+ append text " /* WIN */\n${iftxt}"
+ if {$eltxt ne ""} {
+ append text "#else /* WIN */\n${eltxt}"
+ }
+ append text "#endif /* WIN */\n"
+ }
+ unix {
+ append text "#if !defined(_WIN32)"
+ if {$withCygwin} {
+ append text " && !defined(__CYGWIN__)"
+ }
+ append text " && !defined(MAC_OSX_TCL)\
+ /* UNIX */\n${iftxt}"
+ if {$eltxt ne ""} {
+ append text "#else /* UNIX */\n${eltxt}"
+ }
+ append text "#endif /* UNIX */\n"
+ }
+ macosx {
+ append text "#ifdef MAC_OSX_TCL /* MACOSX */\n${iftxt}"
+ if {$eltxt ne ""} {
+ append text "#else /* MACOSX */\n${eltxt}"
+ }
+ append text "#endif /* MACOSX */\n"
+ }
+ aqua {
+ append text "#ifdef MAC_OSX_TK /* AQUA */\n${iftxt}"
+ if {$eltxt ne ""} {
+ append text "#else /* AQUA */\n${eltxt}"
+ }
+ append text "#endif /* AQUA */\n"
+ }
+ x11 {
+ append text "#if !(defined(_WIN32)"
+ if {$withCygwin} {
+ append text " || defined(__CYGWIN__)"
+ }
+ append text " || defined(MAC_OSX_TK))\
+ /* X11 */\n${iftxt}"
+ if {$eltxt ne ""} {
+ append text "#else /* X11 */\n${eltxt}"
+ }
+ append text "#endif /* X11 */\n"
+ }
+ default {
+ append text "${iftxt}${eltxt}"
+ }
+ }
+ return $text
+}
+
+# genStubs::emitSlots --
+#
+# Generate the stub table slots for the given interface. If there
+# are no generic slots, then one table is generated for each
+# platform, otherwise one table is generated for all platforms.
+#
+# Arguments:
+# name The name of the interface being emitted.
+# textVar The variable to use for output.
+#
+# Results:
+# None.
+
+proc genStubs::emitSlots {name textVar} {
+ upvar $textVar text
+
+ forAllStubs $name makeSlot 1 text {" void (*reserved$i)(void);\n"}
+ return
+}
+
+# genStubs::parseDecl --
+#
+# Parse a C function declaration into its component parts.
+#
+# Arguments:
+# decl The function declaration.
+#
+# Results:
+# Returns a list of the form {returnType name args}. The args
+# element consists of a list of type/name pairs, or a single
+# element "void". If the function declaration is malformed
+# then an error is displayed and the return value is {}.
+
+proc genStubs::parseDecl {decl} {
+ if {![regexp {^(.*)\((.*)\)$} $decl all prefix args]} {
+ set prefix $decl
+ set args {}
+ }
+ set prefix [string trim $prefix]
+ if {![regexp {^(.+[ ][*]*)([^ *]+)$} $prefix all rtype fname]} {
+ puts stderr "Bad return type: $decl"
+ return
+ }
+ set rtype [string trim $rtype]
+ if {$args eq ""} {
+ return [list $rtype $fname {}]
+ }
+ foreach arg [split $args ,] {
+ lappend argList [string trim $arg]
+ }
+ if {![string compare [lindex $argList end] "..."]} {
+ set args TCL_VARARGS
+ foreach arg [lrange $argList 0 end-1] {
+ set argInfo [parseArg $arg]
+ if {[llength $argInfo] == 2 || [llength $argInfo] == 3} {
+ lappend args $argInfo
+ } else {
+ puts stderr "Bad argument: '$arg' in '$decl'"
+ return
+ }
+ }
+ } else {
+ set args {}
+ foreach arg $argList {
+ set argInfo [parseArg $arg]
+ if {![string compare $argInfo "void"]} {
+ lappend args "void"
+ break
+ } elseif {[llength $argInfo] == 2 || [llength $argInfo] == 3} {
+ lappend args $argInfo
+ } else {
+ puts stderr "Bad argument: '$arg' in '$decl'"
+ return
+ }
+ }
+ }
+ return [list $rtype $fname $args]
+}
+
+# genStubs::parseArg --
+#
+# This function parses a function argument into a type and name.
+#
+# Arguments:
+# arg The argument to parse.
+#
+# Results:
+# Returns a list of type and name with an optional third array
+# indicator. If the argument is malformed, returns "".
+
+proc genStubs::parseArg {arg} {
+ if {![regexp {^(.+[ ][*]*)([^][ *]+)(\[\])?$} $arg all type name array]} {
+ if {$arg eq "void"} {
+ return $arg
+ } else {
+ return
+ }
+ }
+ set result [list [string trim $type] $name]
+ if {$array ne ""} {
+ lappend result $array
+ }
+ return $result
+}
+
+# genStubs::makeDecl --
+#
+# Generate the prototype for a function.
+#
+# Arguments:
+# name The interface name.
+# decl The function declaration.
+# index The slot index for this function.
+#
+# Results:
+# Returns the formatted declaration string.
+
+proc genStubs::makeDecl {name decl index} {
+ variable scspec
+ lassign $decl rtype fname args
+
+ append text "/* $index */\n"
+ set line "$scspec $rtype"
+ set count [expr {2 - ([string length $line] / 8)}]
+ append line [string range "\t\t\t" 0 $count]
+ set pad [expr {24 - [string length $line]}]
+ if {$pad <= 0} {
+ append line " "
+ set pad 0
+ }
+ if {$args eq ""} {
+ append line $fname
+ append text $line
+ append text ";\n"
+ return $text
+ }
+ append line $fname
+
+ set arg1 [lindex $args 0]
+ switch -exact $arg1 {
+ void {
+ append line "(void)"
+ }
+ TCL_VARARGS {
+ set sep "("
+ foreach arg [lrange $args 1 end] {
+ append line $sep
+ set next {}
+ append next [lindex $arg 0]
+ if {[string index $next end] ne "*"} {
+ append next " "
+ }
+ append next [lindex $arg 1] [lindex $arg 2]
+ if {[string length $line] + [string length $next] \
+ + $pad > 76} {
+ append text [string trimright $line] \n
+ set line "\t\t\t\t"
+ set pad 28
+ }
+ append line $next
+ set sep ", "
+ }
+ append line ", ...)"
+ if {[lindex $args end] eq "{const char *} format"} {
+ append line " TCL_FORMAT_PRINTF(" [expr [llength $args] - 1] ", " [llength $args] ")"
+ }
+ }
+ default {
+ set sep "("
+ foreach arg $args {
+ append line $sep
+ set next {}
+ append next [lindex $arg 0]
+ if {[string index $next end] ne "*"} {
+ append next " "
+ }
+ append next [lindex $arg 1] [lindex $arg 2]
+ if {[string length $line] + [string length $next] \
+ + $pad > 76} {
+ append text [string trimright $line] \n
+ set line "\t\t\t\t"
+ set pad 28
+ }
+ append line $next
+ set sep ", "
+ }
+ append line ")"
+ }
+ }
+ return "$text$line;\n"
+}
+
+# genStubs::makeMacro --
+#
+# Generate the inline macro for a function.
+#
+# Arguments:
+# name The interface name.
+# decl The function declaration.
+# index The slot index for this function.
+#
+# Results:
+# Returns the formatted macro definition.
+
+proc genStubs::makeMacro {name decl index} {
+ lassign $decl rtype fname args
+
+ set lfname [string tolower [string index $fname 0]]
+ append lfname [string range $fname 1 end]
+
+ set text "#define $fname \\\n\t("
+ if {$args eq ""} {
+ append text "*"
+ }
+ append text "${name}StubsPtr->$lfname)"
+ append text " /* $index */\n"
+ return $text
+}
+
+# genStubs::makeSlot --
+#
+# Generate the stub table entry for a function.
+#
+# Arguments:
+# name The interface name.
+# decl The function declaration.
+# index The slot index for this function.
+#
+# Results:
+# Returns the formatted table entry.
+
+proc genStubs::makeSlot {name decl index} {
+ lassign $decl rtype fname args
+
+ set lfname [string tolower [string index $fname 0]]
+ append lfname [string range $fname 1 end]
+
+ set text " "
+ if {$args eq ""} {
+ append text $rtype " *" $lfname "; /* $index */\n"
+ return $text
+ }
+ if {[string range $rtype end-8 end] eq "__stdcall"} {
+ append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") "
+ } elseif {[string range $rtype 0 11] eq "TCL_NORETURN"} {
+ append text "TCL_NORETURN1 " [string trim [string range $rtype 12 end]] " (*" $lfname ") "
+ } else {
+ append text $rtype " (*" $lfname ") "
+ }
+ set arg1 [lindex $args 0]
+ switch -exact $arg1 {
+ void {
+ append text "(void)"
+ }
+ TCL_VARARGS {
+ set sep "("
+ foreach arg [lrange $args 1 end] {
+ append text $sep [lindex $arg 0]
+ if {[string index $text end] ne "*"} {
+ append text " "
+ }
+ append text [lindex $arg 1] [lindex $arg 2]
+ set sep ", "
+ }
+ append text ", ...)"
+ if {[lindex $args end] eq "{const char *} format"} {
+ append text " TCL_FORMAT_PRINTF(" [expr [llength $args] - 1] ", " [llength $args] ")"
+ }
+ }
+ default {
+ set sep "("
+ foreach arg $args {
+ append text $sep [lindex $arg 0]
+ if {[string index $text end] ne "*"} {
+ append text " "
+ }
+ append text [lindex $arg 1] [lindex $arg 2]
+ set sep ", "
+ }
+ append text ")"
+ }
+ }
+
+ append text "; /* $index */\n"
+ return $text
+}
+
+# genStubs::makeInit --
+#
+# Generate the prototype for a function.
+#
+# Arguments:
+# name The interface name.
+# decl The function declaration.
+# index The slot index for this function.
+#
+# Results:
+# Returns the formatted declaration string.
+
+proc genStubs::makeInit {name decl index} {
+ if {[lindex $decl 2] eq ""} {
+ append text " &" [lindex $decl 1] ", /* " $index " */\n"
+ } else {
+ append text " " [lindex $decl 1] ", /* " $index " */\n"
+ }
+ return $text
+}
+
+# genStubs::forAllStubs --
+#
+# This function iterates over all of the platforms and invokes
+# a callback for each slot. The result of the callback is then
+# placed inside appropriate platform guards.
+#
+# Arguments:
+# name The interface name.
+# slotProc The proc to invoke to handle the slot. It will
+# have the interface name, the declaration, and
+# the index appended.
+# onAll If 1, emit the skip string even if there are
+# definitions for one or more platforms.
+# textVar The variable to use for output.
+# skipString The string to emit if a slot is skipped. This
+# string will be subst'ed in the loop so "$i" can
+# be used to substitute the index value.
+#
+# Results:
+# None.
+
+proc genStubs::forAllStubs {name slotProc onAll textVar
+ {skipString {"/* Slot $i is reserved */\n"}}} {
+ variable stubs
+ upvar $textVar text
+
+ set plats [array names stubs $name,*,lastNum]
+ if {[info exists stubs($name,generic,lastNum)]} {
+ # Emit integrated stubs block
+ set lastNum -1
+ foreach plat [array names stubs $name,*,lastNum] {
+ if {$stubs($plat) > $lastNum} {
+ set lastNum $stubs($plat)
+ }
+ }
+ for {set i 0} {$i <= $lastNum} {incr i} {
+ set slots [array names stubs $name,*,$i]
+ set emit 0
+ if {[info exists stubs($name,generic,$i)]} {
+ if {[llength $slots] > 1} {
+ puts stderr "conflicting generic and platform entries:\
+ $name $i"
+ }
+ append text [$slotProc $name $stubs($name,generic,$i) $i]
+ set emit 1
+ } elseif {[llength $slots] > 0} {
+ array set slot {unix 0 x11 0 win 0 macosx 0 aqua 0}
+ foreach s $slots {
+ set slot([lindex [split $s ,] 1]) 1
+ }
+ # "aqua", "macosx" and "x11" are special cases:
+ # "macosx" implies "unix", "aqua" implies "macosx" and "x11"
+ # implies "unix", so we need to be careful not to emit
+ # duplicate stubs entries:
+ if {($slot(unix) && $slot(macosx)) || (
+ ($slot(unix) || $slot(macosx)) &&
+ ($slot(x11) || $slot(aqua)))} {
+ puts stderr "conflicting platform entries: $name $i"
+ }
+ ## unix ##
+ set temp {}
+ set plat unix
+ if {!$slot(aqua) && !$slot(x11)} {
+ if {$slot($plat)} {
+ append temp [$slotProc $name $stubs($name,$plat,$i) $i]
+ } elseif {$onAll} {
+ eval {append temp} $skipString
+ }
+ }
+ if {$temp ne ""} {
+ append text [addPlatformGuard $plat $temp]
+ set emit 1
+ }
+ ## x11 ##
+ set temp {}
+ set plat x11
+ if {!$slot(unix) && !$slot(macosx)} {
+ if {$slot($plat)} {
+ append temp [$slotProc $name $stubs($name,$plat,$i) $i]
+ } elseif {$onAll} {
+ eval {append temp} $skipString
+ }
+ }
+ if {$temp ne ""} {
+ append text [addPlatformGuard $plat $temp]
+ set emit 1
+ }
+ ## win ##
+ set temp {}
+ set plat win
+ if {$slot($plat)} {
+ append temp [$slotProc $name $stubs($name,$plat,$i) $i]
+ } elseif {$onAll} {
+ eval {append temp} $skipString
+ }
+ if {$temp ne ""} {
+ append text [addPlatformGuard $plat $temp]
+ set emit 1
+ }
+ ## macosx ##
+ set temp {}
+ set plat macosx
+ if {!$slot(aqua) && !$slot(x11)} {
+ if {$slot($plat)} {
+ append temp [$slotProc $name $stubs($name,$plat,$i) $i]
+ } elseif {$slot(unix)} {
+ append temp [$slotProc $name $stubs($name,unix,$i) $i]
+ } elseif {$onAll} {
+ eval {append temp} $skipString
+ }
+ }
+ if {$temp ne ""} {
+ append text [addPlatformGuard $plat $temp]
+ set emit 1
+ }
+ ## aqua ##
+ set temp {}
+ set plat aqua
+ if {!$slot(unix) && !$slot(macosx)} {
+ if {[string range $skipString 1 2] ne "/*"} {
+ # genStubs.tcl previously had a bug here causing it to
+ # erroneously generate both a unix entry and an aqua
+ # entry for a given stubs table slot. To preserve
+ # backwards compatibility, generate a dummy stubs entry
+ # before every aqua entry (note that this breaks the
+ # correspondence between emitted entry number and
+ # actual position of the entry in the stubs table, e.g.
+ # TkIntStubs entry 113 for aqua is in fact at position
+ # 114 in the table, entry 114 at position 116 etc).
+ eval {append temp} $skipString
+ set temp "[string range $temp 0 end-1] /*\
+ Dummy entry for stubs table backwards\
+ compatibility */\n"
+ }
+ if {$slot($plat)} {
+ append temp [$slotProc $name $stubs($name,$plat,$i) $i]
+ } elseif {$onAll} {
+ eval {append temp} $skipString
+ }
+ }
+ if {$temp ne ""} {
+ append text [addPlatformGuard $plat $temp]
+ set emit 1
+ }
+ }
+ if {!$emit} {
+ eval {append text} $skipString
+ }
+ }
+ } else {
+ # Emit separate stubs blocks per platform
+ array set block {unix 0 x11 0 win 0 macosx 0 aqua 0}
+ foreach s [array names stubs $name,*,lastNum] {
+ set block([lindex [split $s ,] 1]) 1
+ }
+ ## unix ##
+ if {$block(unix) && !$block(x11)} {
+ set temp {}
+ set plat unix
+ set lastNum $stubs($name,$plat,lastNum)
+ for {set i 0} {$i <= $lastNum} {incr i} {
+ if {[info exists stubs($name,$plat,$i)]} {
+ append temp [$slotProc $name $stubs($name,$plat,$i) $i]
+ } else {
+ eval {append temp} $skipString
+ }
+ }
+ append text [addPlatformGuard $plat $temp {} true]
+ }
+ ## win ##
+ if {$block(win)} {
+ set temp {}
+ set plat win
+ set lastNum $stubs($name,$plat,lastNum)
+ for {set i 0} {$i <= $lastNum} {incr i} {
+ if {[info exists stubs($name,$plat,$i)]} {
+ append temp [$slotProc $name $stubs($name,$plat,$i) $i]
+ } else {
+ eval {append temp} $skipString
+ }
+ }
+ append text [addPlatformGuard $plat $temp {} true]
+ }
+ ## macosx ##
+ if {($block(unix) || $block(macosx)) && !$block(aqua) && !$block(x11)} {
+ set temp {}
+ set lastNum -1
+ foreach plat {unix macosx} {
+ if {$block($plat)} {
+ set lastNum [expr {$lastNum > $stubs($name,$plat,lastNum)
+ ? $lastNum : $stubs($name,$plat,lastNum)}]
+ }
+ }
+ for {set i 0} {$i <= $lastNum} {incr i} {
+ set emit 0
+ foreach plat {unix macosx} {
+ if {[info exists stubs($name,$plat,$i)]} {
+ append temp [$slotProc $name $stubs($name,$plat,$i) $i]
+ set emit 1
+ break
+ }
+ }
+ if {!$emit} {
+ eval {append temp} $skipString
+ }
+ }
+ append text [addPlatformGuard macosx $temp]
+ }
+ ## aqua ##
+ if {$block(aqua)} {
+ set temp {}
+ set lastNum -1
+ foreach plat {unix macosx aqua} {
+ if {$block($plat)} {
+ set lastNum [expr {$lastNum > $stubs($name,$plat,lastNum)
+ ? $lastNum : $stubs($name,$plat,lastNum)}]
+ }
+ }
+ for {set i 0} {$i <= $lastNum} {incr i} {
+ set emit 0
+ foreach plat {unix macosx aqua} {
+ if {[info exists stubs($name,$plat,$i)]} {
+ append temp [$slotProc $name $stubs($name,$plat,$i) $i]
+ set emit 1
+ break
+ }
+ }
+ if {!$emit} {
+ eval {append temp} $skipString
+ }
+ }
+ append text [addPlatformGuard aqua $temp]
+ }
+ ## x11 ##
+ if {$block(x11)} {
+ set temp {}
+ set lastNum -1
+ foreach plat {unix macosx x11} {
+ if {$block($plat)} {
+ set lastNum [expr {$lastNum > $stubs($name,$plat,lastNum)
+ ? $lastNum : $stubs($name,$plat,lastNum)}]
+ }
+ }
+ for {set i 0} {$i <= $lastNum} {incr i} {
+ set emit 0
+ foreach plat {unix macosx x11} {
+ if {[info exists stubs($name,$plat,$i)]} {
+ if {$plat ne "macosx"} {
+ append temp [$slotProc $name \
+ $stubs($name,$plat,$i) $i]
+ } else {
+ eval {set etxt} $skipString
+ append temp [addPlatformGuard $plat [$slotProc \
+ $name $stubs($name,$plat,$i) $i] $etxt true]
+ }
+ set emit 1
+ break
+ }
+ }
+ if {!$emit} {
+ eval {append temp} $skipString
+ }
+ }
+ append text [addPlatformGuard x11 $temp {} true]
+ }
+ }
+}
+
+# genStubs::emitDeclarations --
+#
+# This function emits the function declarations for this interface.
+#
+# Arguments:
+# name The interface name.
+# textVar The variable to use for output.
+#
+# Results:
+# None.
+
+proc genStubs::emitDeclarations {name textVar} {
+ upvar $textVar text
+
+ append text "\n/*\n * Exported function declarations:\n */\n\n"
+ forAllStubs $name makeDecl 0 text
+ return
+}
+
+# genStubs::emitMacros --
+#
+# This function emits the inline macros for an interface.
+#
+# Arguments:
+# name The name of the interface being emitted.
+# textVar The variable to use for output.
+#
+# Results:
+# None.
+
+proc genStubs::emitMacros {name textVar} {
+ variable libraryName
+ upvar $textVar text
+
+ set upName [string toupper $libraryName]
+ append text "\n#if defined(USE_${upName}_STUBS)\n"
+ append text "\n/*\n * Inline function declarations:\n */\n\n"
+
+ forAllStubs $name makeMacro 0 text
+
+ append text "\n#endif /* defined(USE_${upName}_STUBS) */\n"
+ return
+}
+
+# genStubs::emitHeader --
+#
+# This function emits the body of the <name>Decls.h file for
+# the specified interface.
+#
+# Arguments:
+# name The name of the interface being emitted.
+#
+# Results:
+# None.
+
+proc genStubs::emitHeader {name} {
+ variable outDir
+ variable hooks
+ variable epoch
+ variable revision
+
+ set capName [string toupper [string index $name 0]]
+ append capName [string range $name 1 end]
+
+ if {$epoch ne ""} {
+ set CAPName [string toupper $name]
+ append text "\n"
+ append text "#define ${CAPName}_STUBS_EPOCH $epoch\n"
+ append text "#define ${CAPName}_STUBS_REVISION $revision\n"
+ }
+
+ append text "\n#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
+
+ emitDeclarations $name text
+
+ if {[info exists hooks($name)]} {
+ append text "\ntypedef struct {\n"
+ foreach hook $hooks($name) {
+ set capHook [string toupper [string index $hook 0]]
+ append capHook [string range $hook 1 end]
+ append text " const struct ${capHook}Stubs *${hook}Stubs;\n"
+ }
+ append text "} ${capName}StubHooks;\n"
+ }
+ append text "\ntypedef struct ${capName}Stubs {\n"
+ append text " int magic;\n"
+ if {$epoch ne ""} {
+ append text " int epoch;\n"
+ append text " int revision;\n"
+ }
+ if {[info exists hooks($name)]} {
+ append text " const ${capName}StubHooks *hooks;\n\n"
+ } else {
+ append text " void *hooks;\n\n"
+ }
+
+ emitSlots $name text
+
+ append text "} ${capName}Stubs;\n\n"
+
+ append text "extern const ${capName}Stubs *${name}StubsPtr;\n\n"
+ append text "#ifdef __cplusplus\n}\n#endif\n"
+
+ emitMacros $name text
+
+ rewriteFile [file join $outDir ${name}Decls.h] $text
+ return
+}
+
+# genStubs::emitInit --
+#
+# Generate the table initializers for an interface.
+#
+# Arguments:
+# name The name of the interface to initialize.
+# textVar The variable to use for output.
+#
+# Results:
+# Returns the formatted output.
+
+proc genStubs::emitInit {name textVar} {
+ variable hooks
+ variable interfaces
+ variable epoch
+ upvar $textVar text
+ set root 1
+
+ set capName [string toupper [string index $name 0]]
+ append capName [string range $name 1 end]
+
+ if {[info exists hooks($name)]} {
+ append text "\nstatic const ${capName}StubHooks ${name}StubHooks = \{\n"
+ set sep " "
+ foreach sub $hooks($name) {
+ append text $sep "&${sub}Stubs"
+ set sep ",\n "
+ }
+ append text "\n\};\n"
+ }
+ foreach intf [array names interfaces] {
+ if {[info exists hooks($intf)]} {
+ if {[lsearch -exact $hooks($intf) $name] >= 0} {
+ set root 0
+ break
+ }
+ }
+ }
+
+ append text "\n"
+ if {!$root} {
+ append text "static "
+ }
+ append text "const ${capName}Stubs ${name}Stubs = \{\n TCL_STUB_MAGIC,\n"
+ if {$epoch ne ""} {
+ set CAPName [string toupper $name]
+ append text " ${CAPName}_STUBS_EPOCH,\n"
+ append text " ${CAPName}_STUBS_REVISION,\n"
+ }
+ if {[info exists hooks($name)]} {
+ append text " &${name}StubHooks,\n"
+ } else {
+ append text " 0,\n"
+ }
+
+ forAllStubs $name makeInit 1 text {" 0, /* $i */\n"}
+
+ append text "\};\n"
+ return
+}
+
+# genStubs::emitInits --
+#
+# This function emits the body of the <name>StubInit.c file for
+# the specified interface.
+#
+# Arguments:
+# name The name of the interface being emitted.
+#
+# Results:
+# None.
+
+proc genStubs::emitInits {} {
+ variable hooks
+ variable outDir
+ variable libraryName
+ variable interfaces
+
+ # Assuming that dependencies only go one level deep, we need to emit
+ # all of the leaves first to avoid needing forward declarations.
+
+ set leaves {}
+ set roots {}
+ foreach name [lsort [array names interfaces]] {
+ if {[info exists hooks($name)]} {
+ lappend roots $name
+ } else {
+ lappend leaves $name
+ }
+ }
+ foreach name $leaves {
+ emitInit $name text
+ }
+ foreach name $roots {
+ emitInit $name text
+ }
+
+ rewriteFile [file join $outDir ${libraryName}StubInit.c] $text
+}
+
+# genStubs::init --
+#
+# This is the main entry point.
+#
+# Arguments:
+# None.
+#
+# Results:
+# None.
+
+proc genStubs::init {} {
+ global argv argv0
+ variable outDir
+ variable interfaces
+
+ if {[llength $argv] < 2} {
+ puts stderr "usage: $argv0 outDir declFile ?declFile...?"
+ exit 1
+ }
+
+ set outDir [lindex $argv 0]
+
+ foreach file [lrange $argv 1 end] {
+ source $file
+ }
+
+ foreach name [lsort [array names interfaces]] {
+ puts "Emitting $name"
+ emitHeader $name
+ }
+
+ emitInits
+}
+
+# lassign --
+#
+# This function emulates the TclX lassign command.
+#
+# Arguments:
+# valueList A list containing the values to be assigned.
+# args The list of variables to be assigned.
+#
+# Results:
+# Returns any values that were not assigned to variables.
+
+if {[string length [namespace which lassign]] == 0} {
+ proc lassign {valueList args} {
+ if {[llength $args] == 0} {
+ error "wrong # args: should be \"lassign list varName ?varName ...?\""
+ }
+ uplevel [list foreach $args $valueList {break}]
+ return [lrange $valueList [llength $args] end]
+ }
+}
+
+genStubs::init
diff --git a/tcl8.6/tools/index.tcl b/tcl8.6/tools/index.tcl
new file mode 100644
index 0000000..71329c2
--- /dev/null
+++ b/tcl8.6/tools/index.tcl
@@ -0,0 +1,199 @@
+# index.tcl --
+#
+# This file defines procedures that are used during the first pass of
+# the man page conversion. It is used to extract information used to
+# generate a table of contents and a keyword list.
+#
+# Copyright (c) 1996 by Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# Global variables used by these scripts:
+#
+# state - state variable that controls action of text proc.
+#
+# topics - array indexed by (package,section,topic) with value
+# of topic ID.
+#
+# keywords - array indexed by keyword string with value of topic ID.
+#
+# curID - current topic ID, starts at 0 and is incremented for
+# each new topic file.
+#
+# curPkg - current package name (e.g. Tcl).
+#
+# curSect - current section title (e.g. "Tcl Built-In Commands").
+#
+
+# getPackages --
+#
+# Generate a sorted list of package names from the topics array.
+#
+# Arguments:
+# none.
+
+proc getPackages {} {
+ global topics
+ foreach i [array names topics] {
+ regsub {^(.*),.*,.*$} $i {\1} i
+ set temp($i) {}
+ }
+ lsort [array names temp]
+}
+
+# getSections --
+#
+# Generate a sorted list of section titles in the specified package
+# from the topics array.
+#
+# Arguments:
+# pkg - Name of package to search.
+
+proc getSections {pkg} {
+ global topics
+ regsub -all {[][*?\\]} $pkg {\\&} pkg
+ foreach i [array names topics "${pkg},*"] {
+ regsub {^.*,(.*),.*$} $i {\1} i
+ set temp($i) {}
+ }
+ lsort [array names temp]
+}
+
+# getTopics --
+#
+# Generate a sorted list of topics in the specified section of the
+# specified package from the topics array.
+#
+# Arguments:
+# pkg - Name of package to search.
+# sect - Name of section to search.
+
+proc getTopics {pkg sect} {
+ global topics
+ regsub -all {[][*?\\]} $pkg {\\&} pkg
+ regsub -all {[][*?\\]} $sect {\\&} sect
+ foreach i [array names topics "${pkg},${sect},*"] {
+ regsub {^.*,.*,(.*)$} $i {\1} i
+ set temp($i) {}
+ }
+ lsort [array names temp]
+}
+
+# text --
+#
+# This procedure adds entries to the hypertext arrays topics and keywords.
+#
+# Arguments:
+# string - Text to index.
+
+
+proc text string {
+ global state curID curPkg curSect topics keywords
+
+ switch $state {
+ NAME {
+ foreach i [split $string ","] {
+ set topic [string trim $i]
+ set index "$curPkg,$curSect,$topic"
+ if {[info exists topics($index)]
+ && [string compare $topics($index) $curID] != 0} {
+ puts stderr "duplicate topic $topic in $curPkg"
+ }
+ set topics($index) $curID
+ lappend keywords($topic) $curID
+ }
+ }
+ KEY {
+ foreach i [split $string ","] {
+ lappend keywords([string trim $i]) $curID
+ }
+ }
+ DT -
+ OFF -
+ DASH {}
+ default {
+ puts stderr "text: unknown state: $state"
+ }
+ }
+}
+
+
+# macro --
+#
+# This procedure is invoked to process macro invocations that start
+# with "." (instead of ').
+#
+# Arguments:
+# name - The name of the macro (without the ".").
+# args - Any additional arguments to the macro.
+
+proc macro {name args} {
+ switch $name {
+ SH - SS {
+ global state
+
+ switch $args {
+ NAME {
+ if {$state eq "INIT" } {
+ set state NAME
+ }
+ }
+ DESCRIPTION {set state DT}
+ INTRODUCTION {set state DT}
+ KEYWORDS {set state KEY}
+ default {set state OFF}
+ }
+
+ }
+ TH {
+ global state curID curPkg curSect topics keywords
+ set state INIT
+ if {[llength $args] != 5} {
+ set args [join $args " "]
+ puts stderr "Bad .TH macro: .$name $args"
+ }
+ incr curID
+ set topic [lindex $args 0] ;# Tcl_UpVar
+ set curPkg [lindex $args 3] ;# Tcl
+ set curSect [lindex $args 4] ;# {Tcl Library Procedures}
+ regsub -all {\\ } $curSect { } curSect
+ set index "$curPkg,$curSect,$topic"
+ set topics($index) $curID
+ lappend keywords($topic) $curID
+ }
+ }
+}
+
+
+# dash --
+#
+# This procedure is invoked to handle dash characters ("\-" in
+# troff). It only function in pass1 is to terminate the NAME state.
+#
+# Arguments:
+# None.
+
+proc dash {} {
+ global state
+ if {$state eq "NAME"} {
+ set state DASH
+ }
+}
+
+
+
+# initGlobals, tab, font, char, macro2 --
+#
+# These procedures do nothing during the first pass.
+#
+# Arguments:
+# None.
+
+proc initGlobals {} {}
+proc newline {} {}
+proc tab {} {}
+proc font type {}
+proc char name {}
+proc macro2 {name args} {}
+
diff --git a/tcl8.6/tools/installData.tcl b/tcl8.6/tools/installData.tcl
new file mode 100644
index 0000000..4b43f1e
--- /dev/null
+++ b/tcl8.6/tools/installData.tcl
@@ -0,0 +1,50 @@
+#!/bin/sh
+#\
+exec tclsh "$0" ${1+"$@"}
+
+#----------------------------------------------------------------------
+#
+# installData.tcl --
+#
+# This file installs a hierarchy of data found in the directory
+# specified by its first argument into the directory specified
+# by its second.
+#
+#----------------------------------------------------------------------
+#
+# Copyright (c) 2004 by 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.
+#----------------------------------------------------------------------
+
+proc copyDir {d1 d2} {
+
+ puts [format {%*sCreating %s} [expr {4 * [info level]}] {} \
+ [file tail $d2]]
+
+ file delete -force -- $d2
+ file mkdir $d2
+
+ foreach ftail [glob -directory $d1 -nocomplain -tails *] {
+ set f [file join $d1 $ftail]
+ if {[file isdirectory $f] && [string compare CVS $ftail]} {
+ copyDir $f [file join $d2 $ftail]
+ } elseif {[file isfile $f]} {
+ file copy -force $f [file join $d2 $ftail]
+ if {$::tcl_platform(platform) eq {unix}} {
+ file attributes [file join $d2 $ftail] -permissions 0644
+ } else {
+ file attributes [file join $d2 $ftail] -readonly 1
+ }
+ }
+ }
+
+ if {$::tcl_platform(platform) eq {unix}} {
+ file attributes $d2 -permissions 0755
+ } else {
+ file attributes $d2 -readonly 1
+ }
+
+}
+
+copyDir [file normalize [lindex $argv 0]] [file normalize [lindex $argv 1]]
diff --git a/tcl8.6/tools/loadICU.tcl b/tcl8.6/tools/loadICU.tcl
new file mode 100755
index 0000000..31f1e54
--- /dev/null
+++ b/tcl8.6/tools/loadICU.tcl
@@ -0,0 +1,619 @@
+#----------------------------------------------------------------------
+#
+# loadICU,tcl --
+#
+# Extracts locale strings from a distribution of ICU
+# (http://oss.software.ibm.com/developerworks/opensource/icu/project/)
+# and makes Tcl message catalogs for the 'clock' command.
+#
+# Usage:
+# loadICU.tcl sourceDir destDir
+#
+# Parameters:
+# sourceDir -- Path name of the 'data' directory of your ICU4C
+# distribution.
+# destDir -- Directory into which the Tcl message catalogs should go.
+#
+# Results:
+# None.
+#
+# Side effects:
+# Creates the message catalogs.
+#
+#----------------------------------------------------------------------
+#
+# Copyright (c) 2004 by 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.
+#----------------------------------------------------------------------
+
+# Calculate the Chinese numerals from zero to ninety-nine.
+
+set zhDigits [list {} \u4e00 \u4e8c \u4e09 \u56db \
+ \u4e94 \u516d \u4e03 \u516b \u4e5d]
+set t 0
+foreach zt $zhDigits {
+ if { $t == 0 } {
+ set zt {}
+ } elseif { $t == 10 } {
+ set zt \u5341
+ } else {
+ append zt \u5341
+ }
+ set d 0
+ foreach zd $zhDigits {
+ if { $t == 0 && $d == 0 } {
+ set zd \u3007
+ } elseif { $t == 20 && $d != 0 } {
+ set zt \u5eff
+ } elseif { $t == 30 && $d != 0 } {
+ set zt \u5345
+ }
+ lappend zhNumbers $zt$zd
+ incr d
+ }
+ incr t 10
+}
+
+# Set format overrides for various locales.
+
+set format(zh,LOCALE_NUMERALS) $zhNumbers
+set format(ja,LOCALE_ERAS) [list \
+ [list -9223372036854775808 \u897f\u66a6 0 ] \
+ [list -3061011600 \u660e\u6cbb 1867] \
+ [list -1812186000 \u5927\u6b63 1911] \
+ [list -1357635600 \u662d\u548c 1925] \
+ [list 600220800 \u5e73\u6210 1988]]
+set format(zh,LOCALE_DATE_FORMAT) "\u516c\u5143%Y\u5e74%B%Od\u65E5"
+set format(ja,LOCALE_DATE_FORMAT) "%EY\u5e74%m\u6708%d\u65E5"
+set format(ko,LOCALE_DATE_FORMAT) "%Y\ub144%B%Od\uc77c"
+set format(zh,LOCALE_TIME_FORMAT) "%OH\u65f6%OM\u5206%OS\u79d2"
+set format(ja,LOCALE_TIME_FORMAT) "%H\u6642%M\u5206%S\u79d2"
+set format(ko,LOCALE_TIME_FORMAT) "%H\uc2dc%M\ubd84%S\ucd08"
+set format(zh,LOCALE_DATE_TIME_FORMAT) "%A %Y\u5e74%B%Od\u65E5%OH\u65f6%OM\u5206%OS\u79d2 %z"
+set format(ja,LOCALE_DATE_TIME_FORMAT) "%EY\u5e74%m\u6708%d\u65E5 (%a) %H\u6642%M\u5206%S\u79d2 %z"
+set format(ko,LOCALE_DATE_TIME_FORMAT) "%A %Y\ub144%B%Od\uc77c%H\uc2dc%M\ubd84%S\ucd08 %z"
+set format(ja,TIME_FORMAT_12) {%P %I:%M:%S}
+
+# The next set of format overrides were obtained from the glibc
+# localization strings.
+
+set format(cs_CZ,DATE_FORMAT) %d.%m.%Y
+set format(cs_CZ,DATE_TIME_FORMAT) {%a %e. %B %Y, %H:%M:%S %z}
+set format(cs_CZ,TIME_FORMAT) %H:%M:%S
+set format(cs_CZ,TIME_FORMAT_12) %I:%M:%S
+set format(da_DK,DATE_FORMAT) %d-%m-%Y
+set format(da_DK,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(da_DK,TIME_FORMAT) %T
+set format(da_DK,TIME_FORMAT_12) %T
+set format(de_AT,DATE_FORMAT) %Y-%m-%d
+set format(de_AT,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(de_AT,TIME_FORMAT) %T
+set format(de_AT,TIME_FORMAT_12) %T
+set format(de_BE,DATE_FORMAT) %Y-%m-%d
+set format(de_BE,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(de_BE,TIME_FORMAT) %T
+set format(de_BE,TIME_FORMAT_12) %T
+set format(de_CH,DATE_FORMAT) %Y-%m-%d
+set format(de_CH,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(de_CH,TIME_FORMAT) %T
+set format(de_CH,TIME_FORMAT_12) %T
+set format(de_DE,DATE_FORMAT) %Y-%m-%d
+set format(de_DE,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(de_DE,TIME_FORMAT) %T
+set format(de_DE,TIME_FORMAT_12) %T
+set format(de_LU,DATE_FORMAT) %Y-%m-%d
+set format(de_LU,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(de_LU,TIME_FORMAT) %T
+set format(de_LU,TIME_FORMAT_12) %T
+set format(en_CA,DATE_FORMAT) %d/%m/%y
+set format(en_CA,DATE_TIME_FORMAT) {%a %d %b %Y %r %z}
+set format(en_CA,TIME_FORMAT) %r
+set format(en_CA,TIME_FORMAT_12) {%I:%M:%S %p}
+set format(en_DK,DATE_FORMAT) %Y-%m-%d
+set format(en_DK,DATE_TIME_FORMAT) {%Y-%m-%dT%T %z}
+set format(en_DK,TIME_FORMAT) %T
+set format(en_DK,TIME_FORMAT_12) %T
+set format(en_GB,DATE_FORMAT) %d/%m/%y
+set format(en_GB,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(en_GB,TIME_FORMAT) %T
+set format(en_GB,TIME_FORMAT_12) %T
+set format(en_IE,DATE_FORMAT) %d/%m/%y
+set format(en_IE,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(en_IE,TIME_FORMAT) %T
+set format(en_IE,TIME_FORMAT_12) %T
+set format(en_US,DATE_FORMAT) %m/%d/%y
+set format(en_US,DATE_TIME_FORMAT) {%a %d %b %Y %r %z}
+set format(en_US,TIME_FORMAT) %r
+set format(en_US,TIME_FORMAT_12) {%I:%M:%S %p}
+set format(es_ES,DATE_FORMAT) %d/%m/%y
+set format(es_ES,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(es_ES,TIME_FORMAT) %T
+set format(es_ES,TIME_FORMAT_12) %T
+set format(et_EE,DATE_FORMAT) %d.%m.%Y
+set format(et_EE,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(et_EE,TIME_FORMAT) %T
+set format(et_EE,TIME_FORMAT_12) %T
+set format(eu_ES,DATE_FORMAT) {%a, %Yeko %bren %da}
+set format(eu_ES,DATE_TIME_FORMAT) {%y-%m-%d %T %z}
+set format(eu_ES,TIME_FORMAT) %T
+set format(eu_ES,TIME_FORMAT_12) %T
+set format(fi_FI,DATE_FORMAT) %d.%m.%Y
+set format(fi_FI,DATE_TIME_FORMAT) {%a %e %B %Y %T}
+set format(fi_FI,TIME_FORMAT) %T
+set format(fi_FI,TIME_FORMAT_12) %T
+set format(fo_FO,DATE_FORMAT) %d/%m-%Y
+set format(fo_FO,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(fo_FO,TIME_FORMAT) %T
+set format(fo_FO,TIME_FORMAT_12) %T
+set format(fr_BE,DATE_FORMAT) %d/%m/%y
+set format(fr_BE,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(fr_BE,TIME_FORMAT) %T
+set format(fr_BE,TIME_FORMAT_12) %T
+set format(fr_CA,DATE_FORMAT) %Y-%m-%d
+set format(fr_CA,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(fr_CA,TIME_FORMAT) %T
+set format(fr_CA,TIME_FORMAT_12) %T
+set format(fr_CH,DATE_FORMAT) {%d. %m. %y}
+set format(fr_CH,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(fr_CH,TIME_FORMAT) %T
+set format(fr_CH,TIME_FORMAT_12) %T
+set format(fr_FR,DATE_FORMAT) %d.%m.%Y
+set format(fr_FR,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(fr_FR,TIME_FORMAT) %T
+set format(fr_FR,TIME_FORMAT_12) %T
+set format(fr_LU,DATE_FORMAT) %d.%m.%Y
+set format(fr_LU,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(fr_LU,TIME_FORMAT) %T
+set format(fr_LU,TIME_FORMAT_12) %T
+set format(ga_IE,DATE_FORMAT) %d.%m.%y
+set format(ga_IE,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(ga_IE,TIME_FORMAT) %T
+set format(ga_IE,TIME_FORMAT_12) %T
+set format(gr_GR,DATE_FORMAT) %d/%m/%Y
+set format(gr_GR,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(gr_GR,TIME_FORMAT) %T
+set format(gr_GR,TIME_FORMAT_12) %T
+set format(hr_HR,DATE_FORMAT) %d.%m.%y
+set format(hr_HR,DATE_TIME_FORMAT) {%a %d %b %Y %T}
+set format(hr_HR,TIME_FORMAT) %T
+set format(hr_HR,TIME_FORMAT_12) %T
+set format(hu_HU,DATE_FORMAT) %Y-%m-%d
+set format(hu_HU,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(hu_HU,TIME_FORMAT) %T
+set format(hu_HU,TIME_FORMAT_12) %T
+set format(is_IS,DATE_FORMAT) {%a %e.%b %Y}
+set format(is_IS,DATE_TIME_FORMAT) {%a %e.%b %Y, %T %z}
+set format(is_IS,TIME_FORMAT) %T
+set format(is_IS,TIME_FORMAT_12) %T
+set format(it_IT,DATE_FORMAT) %d/%m/%Y
+set format(it_IT,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(it_IT,TIME_FORMAT) %T
+set format(it_IT,TIME_FORMAT_12) %T
+set format(iw_IL,DATE_FORMAT) %d/%m/%y
+set format(iw_IL,DATE_TIME_FORMAT) {%z %H:%M:%S %Y %b %d %a}
+set format(iw_IL,TIME_FORMAT) %H:%M:%S
+set format(iw_IL,TIME_FORMAT_12) {%I:%M:%S %P}
+set format(kl_GL,DATE_FORMAT) {%d %b %Y}
+set format(kl_GL,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(kl_GL,TIME_FORMAT) %T
+set format(kl_GL,TIME_FORMAT_12) %T
+set format(lt_LT,DATE_FORMAT) %Y.%m.%d
+set format(lt_LT,DATE_TIME_FORMAT) {%Y m. %B %d d. %T}
+set format(lt_LT,TIME_FORMAT) %T
+set format(lt_LT,TIME_FORMAT_12) %T
+set format(lv_LV,DATE_FORMAT) %Y.%m.%d.
+set format(lv_LV,DATE_TIME_FORMAT) {%A, %Y. gada %e. %B, plkst. %H un %M}
+set format(lv_LV,TIME_FORMAT) %T
+set format(lv_LV,TIME_FORMAT_12) %T
+set format(nl_BE,DATE_FORMAT) %d-%m-%y
+set format(nl_BE,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(nl_BE,TIME_FORMAT) %T
+set format(nl_BE,TIME_FORMAT_12) %T
+set format(nl_NL,DATE_FORMAT) %d-%m-%y
+set format(nl_NL,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(nl_NL,TIME_FORMAT) %T
+set format(nl_NL,TIME_FORMAT_12) %T
+set format(no_NO,DATE_FORMAT) %d-%m-%Y
+set format(no_NO,DATE_TIME_FORMAT) {%a %d-%m-%Y %T %z}
+set format(no_NO,TIME_FORMAT) %T
+set format(no_NO,TIME_FORMAT_12) %T
+set format(pl_PL,DATE_FORMAT) %Y-%m-%d
+set format(pl_PL,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(pl_PL,TIME_FORMAT) %T
+set format(pl_PL,TIME_FORMAT_12) %T
+set format(pt_BR,DATE_FORMAT) %d-%m-%Y
+set format(pt_BR,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(pt_BR,TIME_FORMAT) %T
+set format(pt_BR,TIME_FORMAT_12) %T
+set format(pt_PT,DATE_FORMAT) %d-%m-%Y
+set format(pt_PT,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(pt_PT,TIME_FORMAT) %T
+set format(pt_PT,TIME_FORMAT_12) %T
+set format(ro_RO,DATE_FORMAT) %Y-%m-%d
+set format(ro_RO,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(ro_RO,TIME_FORMAT) %T
+set format(ro_RO,TIME_FORMAT_12) %T
+set format(ru_RU,DATE_FORMAT) %d.%m.%Y
+set format(ru_RU,DATE_TIME_FORMAT) {%a %d %b %Y %T}
+set format(ru_RU,TIME_FORMAT) %T
+set format(ru_RU,TIME_FORMAT_12) %T
+set format(sl_SI,DATE_FORMAT) %d.%m.%Y
+set format(sl_SI,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(sl_SI,TIME_FORMAT) %T
+set format(sl_SI,TIME_FORMAT_12) %T
+set format(sv_FI,DATE_FORMAT) %Y-%m-%d
+set format(sv_FI,DATE_TIME_FORMAT) {%a %e %b %Y %H.%M.%S}
+set format(sv_FI,TIME_FORMAT) %H.%M.%S
+set format(sv_FI,TIME_FORMAT_12) %H.%M.%S
+set format(sv_SE,DATE_FORMAT) %Y-%m-%d
+set format(sv_SE,DATE_TIME_FORMAT) {%a %e %b %Y %H.%M.%S}
+set format(sv_SE,TIME_FORMAT) %H.%M.%S
+set format(sv_SE,TIME_FORMAT_12) %H.%M.%S
+set format(tr_TR,DATE_FORMAT) %Y-%m-%d
+set format(tr_TR,DATE_TIME_FORMAT) {%a %d %b %Y %T %z}
+set format(tr_TR,TIME_FORMAT) %T
+set format(tr_TR,TIME_FORMAT_12) %T
+
+#----------------------------------------------------------------------
+#
+# handleLocaleFile --
+#
+# Extracts strings from an ICU locale definition.
+#
+# Parameters:
+# localeName - Name of the locale (e.g., de_AT_euro)
+# fileName - Name of the file containing the data
+# msgFileName - Name of the file containing the Tcl message catalog
+#
+# Results:
+# None.
+#
+# Side effects:
+# Writes the Tcl message catalog.
+#
+#----------------------------------------------------------------------
+
+proc handleLocaleFile { localeName fileName msgFileName } {
+ variable format
+
+ # Get the content of the ICU file
+
+ set f [open $fileName r]
+ fconfigure $f -encoding utf-8
+ set data [read $f]
+ close $f
+
+ # Parse the ICU data
+
+ set state {}
+ foreach line [split $data \n] {
+ switch -exact -- $state {
+ {} {
+
+ # Look for the beginnings of data blocks
+
+ switch -regexp -- $line {
+ {^[[:space:]]*AmPmMarkers[[:space:]]+[\{]} {
+ set state data
+ set key AmPmMarkers
+ }
+ {^[[:space:]]*DateTimePatterns[[:space:]]+[\{]} {
+ set state data
+ set key DateTimePatterns
+ }
+ {^[[:space:]]*DayAbbreviations[[:space:]]+[\{]} {
+ set state data
+ set key DayAbbreviations
+ }
+ {^[[:space:]]*DayNames[[:space:]]+[\{]} {
+ set state data
+ set key DayNames
+ }
+ {^[[:space:]]*Eras[[:space:]]+[\{]} {
+ set state data
+ set key Eras
+ }
+ {^[[:space:]]*MonthAbbreviations[[:space:]]+[\{]} {
+ set state data
+ set key MonthAbbreviations
+ }
+ {^[[:space:]]*MonthNames[[:space:]]+[\{]} {
+ set state data
+ set key MonthNames
+ }
+ }
+ }
+ data {
+
+
+ # Inside a data block, collect the strings, doing backslash
+ # expansion to pick up the Unicodes
+
+ if { [regexp {"(.*)",} $line -> item] } {
+ lappend items($key) [subst -nocommands -novariables $item]
+ } elseif { [regexp {^[[:space:]]*[\}][[:space:]]*$} $line] } {
+ set state {}
+ }
+ }
+ }
+ }
+
+ # Skip locales that don't change time strings.
+
+ if {![array exists items]} return
+
+ # Write the Tcl message catalog
+
+ set f [open $msgFileName w]
+
+ # Write a header
+
+ puts $f "\# created by $::argv0 -- do not edit"
+ puts $f "namespace eval ::tcl::clock \{"
+
+ # Do ordinary sets of strings (weekday and month names)
+
+ foreach key {
+ DayAbbreviations DayNames MonthAbbreviations MonthNames
+ } tkey {
+ DAYS_OF_WEEK_ABBREV DAYS_OF_WEEK_FULL
+ MONTHS_ABBREV MONTHS_FULL
+ } {
+ if { [info exists items($key)] } {
+ set itemList $items($key)
+ set cmd1 " ::msgcat::mcset "
+ append cmd1 $localeName " " $tkey " \[list "
+ foreach item $itemList {
+ append cmd1 \\\n { } \" [backslashify $item] \"
+ }
+ append cmd1 \]
+ puts $f $cmd1
+ }
+ }
+
+ # Do the eras, B.C.E., and C.E.
+
+ if { [info exists items(Eras)] } {
+ foreach { bce ce } $items(Eras) break
+ set cmd " ::msgcat::mcset "
+ append cmd $localeName " " BCE " \"" [backslashify $bce] \"
+ puts $f $cmd
+ set cmd " ::msgcat::mcset "
+ append cmd $localeName " " CE " \"" [backslashify $ce] \"
+ puts $f $cmd
+ }
+
+ # Do the AM and PM markers
+
+ if { [info exists items(AmPmMarkers)] } {
+ foreach { am pm } $items(AmPmMarkers) break
+ set cmd " ::msgcat::mcset "
+ append cmd $localeName " " AM " \"" [backslashify $am] \"
+ puts $f $cmd
+ set cmd " ::msgcat::mcset "
+ append cmd $localeName " " PM " \"" [backslashify $pm] \"
+ puts $f $cmd
+ }
+
+ # Do the date/time patterns. First date...
+
+ if { [info exists format($localeName,DATE_FORMAT)]
+ || [info exists items(DateTimePatterns)] } {
+
+ # Find the shortest date format that includes a 4-digit year.
+
+ if { ![info exists format($localeName,DATE_FORMAT)] } {
+ for { set i 7 } { $i >= 4 } { incr i -1 } {
+ if { [regexp yyyy [lindex $items(DateTimePatterns) $i]] } {
+ break
+ }
+ }
+ set fmt \
+ [backslashify \
+ [percentify [lindex $items(DateTimePatterns) $i]]]
+ set format($localeName,DATE_FORMAT) $fmt
+ }
+
+ # Put it to the message catalog
+
+ set cmd " ::msgcat::mcset "
+ append cmd $localeName " DATE_FORMAT \"" \
+ $format($localeName,DATE_FORMAT) "\""
+ puts $f $cmd
+ }
+
+ # Time
+
+ if { [info exists format($localeName,TIME_FORMAT)]
+ || [info exists items(DateTimePatterns)] } {
+
+ # Find the shortest time pattern that includes the seconds
+
+ if { ![info exists format($localeName,TIME_FORMAT)] } {
+ for { set i 3 } { $i >= 0 } { incr i -1 } {
+ if { [regexp H [lindex $items(DateTimePatterns) $i]]
+ && [regexp s [lindex $items(DateTimePatterns) $i]] } {
+ break
+ }
+ }
+ if { $i >= 0 } {
+ set fmt \
+ [backslashify \
+ [percentify [lindex $items(DateTimePatterns) $i]]]
+ regsub { %Z} $fmt {} format($localeName,TIME_FORMAT)
+ }
+ }
+
+ # Put it to the message catalog
+
+ if { [info exists format($localeName,TIME_FORMAT)] } {
+ set cmd " ::msgcat::mcset "
+ append cmd $localeName " TIME_FORMAT \"" \
+ $format($localeName,TIME_FORMAT) "\""
+ puts $f $cmd
+ }
+ }
+
+ # 12-hour time...
+
+ if { [info exists format($localeName,TIME_FORMAT_12)]
+ || [info exists items(DateTimePatterns)] } {
+
+ # Shortest patterm with 12-hour time that includes seconds
+
+ if { ![info exists format($localeName,TIME_FORMAT_12)] } {
+ for { set i 3 } { $i >= 0 } { incr i -1 } {
+ if { [regexp h [lindex $items(DateTimePatterns) $i]]
+ && [regexp s [lindex $items(DateTimePatterns) $i]] } {
+ break
+ }
+ }
+ if { $i >= 0 } {
+ set fmt \
+ [backslashify \
+ [percentify [lindex $items(DateTimePatterns) $i]]]
+ regsub { %Z} $fmt {} format($localeName,TIME_FORMAT_12)
+ }
+ }
+
+ # Put it to the catalog
+
+ if { [info exists format($localeName,TIME_FORMAT_12)] } {
+ set cmd " ::msgcat::mcset "
+ append cmd $localeName " TIME_FORMAT_12 \"" \
+ $format($localeName,TIME_FORMAT_12) "\""
+ puts $f $cmd
+ }
+ }
+
+ # Date and time... Prefer 24-hour format to 12-hour format.
+
+ if { ![info exists format($localeName,DATE_TIME_FORMAT)]
+ && [info exists format($localeName,DATE_FORMAT)]
+ && [info exists format($localeName,TIME_FORMAT)]} {
+ set format($localeName,DATE_TIME_FORMAT) \
+ $format($localeName,DATE_FORMAT)
+ append format($localeName,DATE_TIME_FORMAT) \
+ " " $format($localeName,TIME_FORMAT) " %z"
+ }
+ if { ![info exists format($localeName,DATE_TIME_FORMAT)]
+ && [info exists format($localeName,DATE_FORMAT)]
+ && [info exists format($localeName,TIME_FORMAT_12)]} {
+ set format($localeName,DATE_TIME_FORMAT) \
+ $format($localeName,DATE_FORMAT)
+ append format($localeName,DATE_TIME_FORMAT) \
+ " " $format($localeName,TIME_FORMAT_12) " %z"
+ }
+
+ # Write date/time format to the file
+
+ if { [info exists format($localeName,DATE_TIME_FORMAT)] } {
+ set cmd " ::msgcat::mcset "
+ append cmd $localeName " DATE_TIME_FORMAT \"" \
+ $format($localeName,DATE_TIME_FORMAT) "\""
+ puts $f $cmd
+ }
+
+ # Write the string sets to the file.
+
+ foreach key {
+ LOCALE_NUMERALS LOCALE_DATE_FORMAT LOCALE_TIME_FORMAT
+ LOCALE_DATE_TIME_FORMAT LOCALE_ERAS LOCALE_YEAR_FORMAT
+ } {
+ if { [info exists format($localeName,$key)] } {
+ set cmd " ::msgcat::mcset "
+ append cmd $localeName " " $key " \"" \
+ [backslashify $format($localeName,$key)] "\""
+ puts $f $cmd
+ }
+ }
+
+ # Footer
+
+ puts $f "\}"
+ close $f
+}
+
+#----------------------------------------------------------------------
+#
+# percentify --
+#
+# Converts a Java/ICU-style time format to a C/Tcl style one.
+#
+# Parameters:
+# string -- Format to convert
+#
+# Results:
+# Returns the converted format.
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc percentify { string } {
+ set retval {}
+ foreach { unquoted quoted } [split $string '] {
+ append retval [string map {
+ EEEE %A MMMM %B yyyy %Y
+ MMM %b EEE %a
+ dd %d hh %I HH %H mm %M MM %m ss %S yy %y
+ a %P d %e h %l H %k M %m z %z
+ } $unquoted]
+ append retval $quoted
+ }
+ return $retval
+}
+
+#----------------------------------------------------------------------
+#
+# backslashify --
+#
+# Converts a UTF-8 string to a plain ASCII one with escapes.
+#
+# Parameters:
+# string -- String to convert
+#
+# Results:
+# Returns the converted string
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc backslashify { string } {
+
+ set retval {}
+ foreach char [split $string {}] {
+ scan $char %c ccode
+ if { $ccode >= 0x0020 && $ccode < 0x007f && $char ne "\""
+ && $char ne "\{" && $char ne "\}" && $char ne "\["
+ && $char ne "\]" && $char ne "\\" && $char ne "\$" } {
+ append retval $char
+ } else {
+ append retval \\u [format %04x $ccode]
+ }
+ }
+ return $retval
+}
+
+#----------------------------------------------------------------------
+#
+# MAIN PROGRAM
+#
+#----------------------------------------------------------------------
+
+# Extract directories from command line
+
+foreach { icudir msgdir } $argv break
+
+# Walk the ICU files and create corresponding Tcl message catalogs
+
+foreach fileName [glob -directory $icudir *.txt] {
+ set n [file rootname [file tail $fileName]]
+ if { [regexp {^[a-z]{2,3}(_[A-Z]{2,3}(_.*)?)?$} $n] } {
+ handleLocaleFile $n $fileName [file join $msgdir [string tolower $n].msg]
+ }
+}
diff --git a/tcl8.6/tools/makeTestCases.tcl b/tcl8.6/tools/makeTestCases.tcl
new file mode 100755
index 0000000..6cc033b
--- /dev/null
+++ b/tcl8.6/tools/makeTestCases.tcl
@@ -0,0 +1,1180 @@
+# TODO - When integrating this with the Core, path names will need to be
+# swizzled here.
+
+package require msgcat
+set d [file dirname [file dirname [info script]]]
+puts "getting transition data from [file join $d library tzdata America Detroit]"
+source [file join $d library/tzdata/America/Detroit]
+
+namespace eval ::tcl::clock {
+ ::msgcat::mcmset en_US_roman {
+ LOCALE_ERAS {
+ {-62164627200 {} 0}
+ {-59008867200 c 100}
+ {-55853107200 cc 200}
+ {-52697347200 ccc 300}
+ {-49541587200 cd 400}
+ {-46385827200 d 500}
+ {-43230067200 dc 600}
+ {-40074307200 dcc 700}
+ {-36918547200 dccc 800}
+ {-33762787200 cm 900}
+ {-30607027200 m 1000}
+ {-27451267200 mc 1100}
+ {-24295507200 mcc 1200}
+ {-21139747200 mccc 1300}
+ {-17983987200 mcd 1400}
+ {-14828227200 md 1500}
+ {-11672467200 mdc 1600}
+ {-8516707200 mdcc 1700}
+ {-5364662400 mdccc 1800}
+ {-2208988800 mcm 1900}
+ {946684800 mm 2000}
+ }
+ LOCALE_NUMERALS {
+ ? i ii iii iv v vi vii viii ix
+ x xi xii xiii xiv xv xvi xvii xviii xix
+ xx xxi xxii xxiii xxiv xxv xxvi xxvii xxviii xxix
+ xxx xxxi xxxii xxxiii xxxiv xxxv xxxvi xxxvii xxxviii xxxix
+ xl xli xlii xliii xliv xlv xlvi xlvii xlviii xlix
+ l li lii liii liv lv lvi lvii lviii lix
+ lx lxi lxii lxiii lxiv lxv lxvi lxvii lxviii lxix
+ lxx lxxi lxxii lxxiii lxxiv lxxv lxxvi lxxvii lxxviii lxxix
+ lxxx lxxxi lxxxii lxxxiii lxxxiv lxxxv lxxxvi lxxxvii lxxxviii
+ lxxxix
+ xc xci xcii xciii xciv xcv xcvi xcvii xcviii xcix
+ c
+ }
+ DATE_FORMAT {%m/%d/%Y}
+ TIME_FORMAT {%H:%M:%S}
+ DATE_TIME_FORMAT {%x %X}
+ LOCALE_DATE_FORMAT {die %Od mensis %Om annoque %EY}
+ LOCALE_TIME_FORMAT {%OH h %OM m %OS s}
+ LOCALE_DATE_TIME_FORMAT {%Ex %EX}
+ }
+}
+
+#----------------------------------------------------------------------
+#
+# listYears --
+#
+# List the years to test in the common clock test cases.
+#
+# Parameters:
+# startOfYearArray - Name of an array in caller's scope that will
+# be initialized as
+# Results:
+# None
+#
+# Side effects:
+# Determines the year numbers of one common year, one leap year, one year
+# following a common year, and one year following a leap year -- starting
+# on each day of the week -- in the XIXth, XXth and XXIth centuries.
+# Initializes the given array to have keys equal to the year numbers and
+# values equal to [clock seconds] at the start of the corresponding
+# years.
+#
+#----------------------------------------------------------------------
+
+proc listYears { startOfYearArray } {
+
+ upvar 1 $startOfYearArray startOfYear
+
+ # List years after 1970
+
+ set y 1970
+ set s 0
+ set dw 4 ;# Thursday
+ while { $y < 2100 } {
+ if { $y % 4 == 0 && $y % 100 != 0 || $y % 400 == 0 } {
+ set l 1
+ incr dw 366
+ set s2 [expr { $s + wide( 366 * 86400 ) }]
+ } else {
+ set l 0
+ incr dw 365
+ set s2 [expr { $s + wide( 365 * 86400 ) }]
+ }
+ set x [expr { $y >= 2037 }]
+ set dw [expr {$dw % 7}]
+ set c [expr { $y / 100 }]
+ if { ![info exists do($x$c$dw$l)] } {
+ set do($x$c$dw$l) $y
+ set startOfYear($y) $s
+ set startOfYear([expr {$y + 1}]) $s2
+ }
+ set s $s2
+ incr y
+ }
+
+ # List years before 1970
+
+ set y 1970
+ set s 0
+ set dw 4; # Thursday
+ while { $y >= 1801 } {
+ set s0 $s
+ incr dw 371
+ incr y -1
+ if { $y % 4 == 0 && $y % 100 != 0 || $y % 400 == 0 } {
+ set l 1
+ incr dw -366
+ set s [expr { $s - wide(366 * 86400) }]
+ } else {
+ set l 0
+ incr dw -365
+ set s [expr { $s - wide(365 * 86400) }]
+ }
+ set dw [expr {$dw % 7}]
+ set c [expr { $y / 100 }]
+ if { ![info exists do($c$dw$l)] } {
+ set do($c$dw$l) $y
+ set startOfYear($y) $s
+ set startOfYear([expr {$y + 1}]) $s0
+ }
+ }
+
+}
+
+#----------------------------------------------------------------------
+#
+# processFile -
+#
+# Processes the 'clock.test' file, updating the test cases in it.
+#
+# Parameters:
+# None.
+#
+# Side effects:
+# Replaces the file with a new copy, constructing needed test cases.
+#
+#----------------------------------------------------------------------
+
+proc processFile {d} {
+
+ # Open two files
+
+ set f1 [open [file join $d tests/clock.test] r]
+ set f2 [open [file join $d tests/clock.new] w]
+
+ # Copy leading portion of the test file
+
+ set state {}
+ while { [gets $f1 line] >= 0 } {
+ switch -exact -- $state {
+ {} {
+ puts $f2 $line
+ if { [regexp "^\# BEGIN (.*)" $line -> cases]
+ && [string compare {} [info commands $cases]] } {
+ set state inCaseSet
+ $cases $f2
+ }
+ }
+ inCaseSet {
+ if { [regexp "^\#\ END $cases\$" $line] } {
+ puts $f2 $line
+ set state {}
+ }
+ }
+ }
+ }
+
+ # Rotate the files
+
+ close $f1
+ close $f2
+ file delete -force [file join $d tests/clock.bak]
+ file rename -force [file join $d tests/clock.test] \
+ [file join $d tests/clock.bak]
+ file rename [file join $d tests/clock.new] [file join $d tests/clock.test]
+
+}
+
+#----------------------------------------------------------------------
+#
+# testcases2 --
+#
+# Outputs the 'clock-2.x' test cases.
+#
+# Parameters:
+# f2 -- Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Test cases for formatting in Gregorian calendar are written to the
+# output file.
+#
+#----------------------------------------------------------------------
+
+proc testcases2 { f2 } {
+
+ listYears startOfYear
+
+ # Define the roman numerals
+
+ set roman {
+ ? i ii iii iv v vi vii viii ix
+ x xi xii xiii xiv xv xvi xvii xviii xix
+ xx xxi xxii xxiii xxiv xxv xxvi xxvii xxviii xxix
+ xxx xxxi xxxii xxxiii xxxiv xxxv xxxvi xxxvii xxxviii xxxix
+ xl xli xlii xliii xliv xlv xlvi xlvii xlviii xlix
+ l li lii liii liv lv lvi lvii lviii lix
+ lx lxi lxii lxiii lxiv lxv lxvi lxvii lxviii lxix
+ lxx lxxi lxxii lxxiii lxxiv lxxv lxxvi lxxvii lxxviii lxxix
+ lxxx lxxxi lxxxii lxxxiii lxxxiv lxxxv lxxxvi lxxxvii lxxxviii lxxxix
+ xc xci xcii xciii xciv xcv xcvi xcvii xcviii xcix
+ c
+ }
+ set romanc {
+ ? c cc ccc cd d dc dcc dccc cm
+ m mc mcc mccc mcd md mdc mdcc mdccc mcm
+ mm mmc mmcc mmccc mmcd mmd mmdc mmdcc mmdccc mmcm
+ mmm mmmc mmmcc mmmccc mmmcd mmmd mmmdc mmmdcc mmmdccc mmmcm
+ }
+
+ # Names of the months
+
+ set short {{} Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec}
+ set long {
+ {} January February March April May June July August September
+ October November December
+ }
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test formatting of Gregorian year, month, day, all formats"
+ puts $f2 "\# Formats tested: %b %B %c %Ec %C %EC %d %Od %e %Oe %h %j %J %m %Om %N %x %Ex %y %Oy %Y %EY"
+ puts $f2 ""
+
+ # Generate the test cases for the first and last day of every month
+ # from 1896 to 2045
+
+ set n 0
+ foreach { y } [lsort -integer [array names startOfYear]] {
+ set s [expr { $startOfYear($y) + wide(12*3600 + 34*60 + 56) }]
+ set m 0
+ set yd 1
+ foreach hath { 31 28 31 30 31 30 31 31 30 31 30 31 } {
+ incr m
+ if { $m == 2 && ( $y%4 == 0 && $y%100 != 0 || $y%400 == 0 ) } {
+ incr hath
+ }
+
+ set b [lindex $short $m]
+ set B [lindex $long $m]
+ set C [format %02d [expr { $y / 100 }]]
+ set h $b
+ set j [format %03d $yd]
+ set mm [format %02d $m]
+ set N [format %2d $m]
+ set yy [format %02d [expr { $y % 100 }]]
+
+ set J [expr { ( $s / 86400 ) + 2440588 }]
+
+ set dt $y-$mm-01
+ set result ""
+ append result $b " " $B " " \
+ $mm /01/ $y " 12:34:56 " \
+ "die i mensis " [lindex $roman $m] " annoque " \
+ [lindex $romanc [expr { $y / 100 }]] \
+ [lindex $roman [expr { $y % 100 }]] " " \
+ [lindex $roman 12] " h " [lindex $roman 34] " m " \
+ [lindex $roman 56] " s " \
+ $C " " [lindex $romanc [expr { $y / 100 }]] \
+ " 01 i 1 i " \
+ $h " " $j " " $J " " $mm " " [lindex $roman $m] " " $N \
+ " " $mm "/01/" $y \
+ " die i mensis " [lindex $roman $m] " annoque " \
+ [lindex $romanc [expr { $y / 100 }]] \
+ [lindex $roman [expr { $y % 100 }]] \
+ " " $yy " " [lindex $roman [expr { $y % 100 }]] " " $y
+ puts $f2 "test clock-2.[incr n] {conversion of $dt} {"
+ puts $f2 " clock format $s \\"
+ puts $f2 "\t-format {%b %B %c %Ec %C %EC %d %Od %e %Oe %h %j %J %m %Om %N %x %Ex %y %Oy %Y} \\"
+ puts $f2 "\t-gmt true -locale en_US_roman"
+ puts $f2 "} {$result}"
+
+ set hm1 [expr { $hath - 1 }]
+ incr s [expr { 86400 * ( $hath - 1 ) }]
+ incr yd $hm1
+
+ set dd [format %02d $hath]
+ set ee [format %2d $hath]
+ set j [format %03d $yd]
+
+ set J [expr { ( $s / 86400 ) + 2440588 }]
+
+ set dt $y-$mm-$dd
+ set result ""
+ append result $b " " $B " " \
+ $mm / $dd / $y " 12:34:56 " \
+ "die " [lindex $roman $hath] " mensis " [lindex $roman $m] \
+ " annoque " \
+ [lindex $romanc [expr { $y / 100 }]] \
+ [lindex $roman [expr { $y % 100 }]] " " \
+ [lindex $roman 12] " h " [lindex $roman 34] " m " \
+ [lindex $roman 56] " s " \
+ $C " " [lindex $romanc [expr { $y / 100 }]] \
+ " " $dd " " [lindex $roman $hath] " " \
+ $ee " " [lindex $roman $hath] " "\
+ $h " " $j " " $J " " $mm " " [lindex $roman $m] " " $N \
+ " " $mm "/" $dd "/" $y \
+ " die " [lindex $roman $hath] " mensis " [lindex $roman $m] \
+ " annoque " \
+ [lindex $romanc [expr { $y / 100 }]] \
+ [lindex $roman [expr { $y % 100 }]] \
+ " " $yy " " [lindex $roman [expr { $y % 100 }]] " " $y
+ puts $f2 "test clock-2.[incr n] {conversion of $dt} {"
+ puts $f2 " clock format $s \\"
+ puts $f2 "\t-format {%b %B %c %Ec %C %EC %d %Od %e %Oe %h %j %J %m %Om %N %x %Ex %y %Oy %Y} \\"
+ puts $f2 "\t-gmt true -locale en_US_roman"
+ puts $f2 "} {$result}"
+
+ incr s 86400
+ incr yd
+ }
+ }
+ puts "testcases2: $n test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases3 --
+#
+# Generate test cases for ISO8601 calendar.
+#
+# Parameters:
+# f2 - Channel handle to the output file
+#
+# Results:
+# None
+#
+# Side effects:
+# Makes a test case for the first and last day of weeks 51, 52, and 1
+# plus the first and last day of a year. Does so for each possible
+# weekday on which a Common Year or Leap Year can begin.
+#
+#----------------------------------------------------------------------
+
+proc testcases3 { f2 } {
+
+ listYears startOfYear
+
+ set case 0
+ foreach { y } [lsort -integer [array names startOfYear]] {
+ set secs $startOfYear($y)
+ set ym1 [expr { $y - 1 }]
+ set dow [expr { ( $secs / 86400 + 4 ) % 7}]
+ switch -exact $dow {
+ 0 {
+ # Year starts on a Sunday.
+ # Prior year started on a Friday or Saturday, and was
+ # a 52-week year.
+ # 1 January is ISO week 52 of the prior year. 2 January
+ # begins ISO week 1 of the current year.
+ # 1 January is week 1 according to %U. According to %W,
+ # week 1 begins on 2 January
+ testISO $f2 $ym1 52 1 [expr { $secs - 6*86400 }]
+ testISO $f2 $ym1 52 6 [expr { $secs - 86400 }]
+ testISO $f2 $ym1 52 7 $secs
+ testISO $f2 $y 1 1 [expr { $secs + 86400 }]
+ testISO $f2 $y 1 6 [expr { $secs + 6*86400}]
+ testISO $f2 $y 1 7 [expr { $secs + 7*86400 }]
+ testISO $f2 $y 2 1 [expr { $secs + 8*86400 }]
+ }
+ 1 {
+ # Year starts on a Monday.
+ # Previous year started on a Saturday or Sunday, and was
+ # a 52-week year.
+ # 1 January is ISO week 1 of the current year
+ # According to %U, it's week 0 until 7 January
+ # 1 January is week 1 according to %W
+ testISO $f2 $ym1 52 1 [expr { $secs - 7*86400 }]
+ testISO $f2 $ym1 52 6 [expr {$secs - 2*86400}]
+ testISO $f2 $ym1 52 7 [expr { $secs - 86400 }]
+ testISO $f2 $y 1 1 $secs
+ testISO $f2 $y 1 6 [expr {$secs + 5*86400}]
+ testISO $f2 $y 1 7 [expr { $secs + 6*86400 }]
+ testISO $f2 $y 2 1 [expr { $secs + 7*86400 }]
+ }
+ 2 {
+ # Year starts on a Tuesday.
+ testISO $f2 $ym1 52 1 [expr { $secs - 8*86400 }]
+ testISO $f2 $ym1 52 6 [expr {$secs - 3*86400}]
+ testISO $f2 $ym1 52 7 [expr { $secs - 2*86400 }]
+ testISO $f2 $y 1 1 [expr { $secs - 86400 }]
+ testISO $f2 $y 1 2 $secs
+ testISO $f2 $y 1 6 [expr {$secs + 4*86400}]
+ testISO $f2 $y 1 7 [expr { $secs + 5*86400 }]
+ testISO $f2 $y 2 1 [expr { $secs + 6*86400 }]
+ }
+ 3 {
+ testISO $f2 $ym1 52 1 [expr { $secs - 9*86400 }]
+ testISO $f2 $ym1 52 6 [expr {$secs - 4*86400}]
+ testISO $f2 $ym1 52 7 [expr { $secs - 3*86400 }]
+ testISO $f2 $y 1 1 [expr { $secs - 2*86400 }]
+ testISO $f2 $y 1 3 $secs
+ testISO $f2 $y 1 6 [expr {$secs + 3*86400}]
+ testISO $f2 $y 1 7 [expr { $secs + 4*86400 }]
+ testISO $f2 $y 2 1 [expr { $secs + 5*86400 }]
+ }
+ 4 {
+ testISO $f2 $ym1 52 1 [expr { $secs - 10*86400 }]
+ testISO $f2 $ym1 52 6 [expr {$secs - 5*86400}]
+ testISO $f2 $ym1 52 7 [expr { $secs - 4*86400 }]
+ testISO $f2 $y 1 1 [expr { $secs - 3*86400 }]
+ testISO $f2 $y 1 4 $secs
+ testISO $f2 $y 1 6 [expr {$secs + 2*86400}]
+ testISO $f2 $y 1 7 [expr { $secs + 3*86400 }]
+ testISO $f2 $y 2 1 [expr { $secs + 4*86400 }]
+ }
+ 5 {
+ testISO $f2 $ym1 53 1 [expr { $secs - 4*86400 }]
+ testISO $f2 $ym1 53 5 $secs
+ testISO $f2 $ym1 53 6 [expr {$secs + 86400}]
+ testISO $f2 $ym1 53 7 [expr { $secs + 2*86400 }]
+ testISO $f2 $y 1 1 [expr { $secs + 3*86400 }]
+ testISO $f2 $y 1 6 [expr {$secs + 8*86400}]
+ testISO $f2 $y 1 7 [expr { $secs + 9*86400 }]
+ testISO $f2 $y 2 1 [expr { $secs + 10*86400 }]
+ }
+ 6 {
+ # messy case because previous year may have had 52 or 53 weeks
+ if { $y%4 == 1 } {
+ testISO $f2 $ym1 53 1 [expr { $secs - 5*86400 }]
+ testISO $f2 $ym1 53 6 $secs
+ testISO $f2 $ym1 53 7 [expr { $secs + 86400 }]
+ } else {
+ testISO $f2 $ym1 52 1 [expr { $secs - 5*86400 }]
+ testISO $f2 $ym1 52 6 $secs
+ testISO $f2 $ym1 52 7 [expr { $secs + 86400 }]
+ }
+ testISO $f2 $y 1 1 [expr { $secs + 2*86400 }]
+ testISO $f2 $y 1 6 [expr { $secs + 7*86400 }]
+ testISO $f2 $y 1 7 [expr { $secs + 8*86400 }]
+ testISO $f2 $y 2 1 [expr { $secs + 9*86400 }]
+ }
+ }
+ }
+ puts "testcases3: $case test cases."
+
+}
+
+proc testISO { f2 G V u secs } {
+
+ upvar 1 case case
+
+ set longdays {Sunday Monday Tuesday Wednesday Thursday Friday Saturday Sunday}
+ set shortdays {Sun Mon Tue Wed Thu Fri Sat Sun}
+
+ puts $f2 "test clock-3.[incr case] {ISO week-based calendar [format %04d-W%02d-%d $G $V $u]} {"
+ puts $f2 " clock format $secs -format {%a %A %g %G %u %U %V %w %W} -gmt true; \# $G-W[format %02d $V]-$u"
+ puts $f2 "} {[lindex $shortdays $u] [lindex $longdays $u]\
+ [format %02d [expr { $G % 100 }]] $G\
+ $u\
+ [clock format $secs -format %U -gmt true]\
+ [format %02d $V] [expr { $u % 7 }]\
+ [clock format $secs -format %W -gmt true]}"
+
+}
+
+#----------------------------------------------------------------------
+#
+# testcases4 --
+#
+# Makes the test cases that test formatting of time of day.
+#
+# Parameters:
+# f2 - Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Writes test cases to the output.
+#
+#----------------------------------------------------------------------
+
+proc testcases4 { f2 } {
+
+ puts $f2 {}
+ puts $f2 "\# Test formatting of time of day"
+ puts $f2 "\# Format groups tested: %H %OH %I %OI %k %Ok %l %Ol %M %OM %p %P %r %R %S %OS %T %X %EX %+"
+ puts $f2 {}
+
+ set i 0
+ set fmt "%H %OH %I %OI %k %Ok %l %Ol %M %OM %p %P %r %R %S %OS %T %X %EX %+"
+ foreach { h romanH I romanI am } {
+ 0 ? 12 xii AM
+ 1 i 1 i AM
+ 11 xi 11 xi AM
+ 12 xii 12 xii PM
+ 13 xiii 1 i PM
+ 23 xxiii 11 xi PM
+ } {
+ set hh [format %02d $h]
+ set II [format %02d $I]
+ set hs [format %2d $h]
+ set Is [format %2d $I]
+ foreach { m romanM } { 0 ? 1 i 58 lviii 59 lix } {
+ set mm [format %02d $m]
+ foreach { s romanS } { 0 ? 1 i 58 lviii 59 lix } {
+ set ss [format %02d $s]
+ set x [expr { ( $h * 60 + $m ) * 60 + $s }]
+ set result ""
+ append result $hh " " $romanH " " $II " " $romanI " " \
+ $hs " " $romanH " " $Is " " $romanI " " $mm " " $romanM " " \
+ $am " " [string tolower $am] " " \
+ $II ":" $mm ":" $ss " " [string tolower $am] " " \
+ $hh ":" $mm " " \
+ $ss " " $romanS " " \
+ $hh ":" $mm ":" $ss " " \
+ $hh ":" $mm ":" $ss " " \
+ $romanH " h " $romanM " m " $romanS " s " \
+ "Thu Jan 1 " $hh : $mm : $ss " GMT 1970"
+ puts $f2 "test clock-4.[incr i] { format time of day $hh:$mm:$ss } {"
+ puts $f2 " clock format $x \\"
+ puts $f2 " -format [list $fmt] \\"
+ puts $f2 " -locale en_US_roman \\"
+ puts $f2 " -gmt true"
+ puts $f2 "} {$result}"
+ }
+ }
+ }
+
+ puts "testcases4: $i test cases."
+}
+
+#----------------------------------------------------------------------
+#
+# testcases5 --
+#
+# Generates the test cases for Daylight Saving Time
+#
+# Parameters:
+# f2 - Channel handle for the input file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Makes test cases for each known or anticipated time change
+# in Detroit.
+#
+#----------------------------------------------------------------------
+
+proc testcases5 { f2 } {
+ variable TZData
+
+ puts $f2 {}
+ puts $f2 "\# Test formatting of Daylight Saving Time"
+ puts $f2 {}
+
+ set fmt {%H:%M:%S %z %Z}
+
+ set i 0
+ puts $f2 "test clock-5.[incr i] {does Detroit exist} {"
+ puts $f2 " clock format 0 -format {} -timezone :America/Detroit"
+ puts $f2 " concat"
+ puts $f2 "} {}"
+ puts $f2 "test clock-5.[incr i] {does Detroit have a Y2038 problem} detroit {"
+ puts $f2 " if { \[clock format 2158894800 -format %z -timezone :America/Detroit\] ne {-0400} } {"
+ puts $f2 " concat {y2038 problem}"
+ puts $f2 " } else {"
+ puts $f2 " concat {ok}"
+ puts $f2 " }"
+ puts $f2 "} ok"
+
+ foreach row $TZData(:America/Detroit) {
+ foreach { t offset isdst tzname } $row break
+ if { $t > -4000000000000 } {
+ set conds [list detroit]
+ if { $t > wide(0x7fffffff) } {
+ set conds [list detroit y2038]
+ }
+ incr t -1
+ set x [clock format $t -format {%Y-%m-%d %H:%M:%S} \
+ -timezone :America/Detroit]
+ set r [clock format $t -format $fmt \
+ -timezone :America/Detroit]
+ puts $f2 "test clock-5.[incr i] {time zone boundary case $x} [list $conds] {"
+ puts $f2 " clock format $t -format [list $fmt] \\"
+ puts $f2 " -timezone :America/Detroit"
+ puts $f2 "} [list $r]"
+ incr t
+ set x [clock format $t -format {%Y-%m-%d %H:%M:%S} \
+ -timezone :America/Detroit]
+ set r [clock format $t -format $fmt \
+ -timezone :America/Detroit]
+ puts $f2 "test clock-5.[incr i] {time zone boundary case $x} [list $conds] {"
+ puts $f2 " clock format $t -format [list $fmt] \\"
+ puts $f2 " -timezone :America/Detroit"
+ puts $f2 "} [list $r]"
+ incr t
+ set x [clock format $t -format {%Y-%m-%d %H:%M:%S} \
+ -timezone :America/Detroit]
+ set r [clock format $t -format $fmt \
+ -timezone :America/Detroit]
+ puts $f2 "test clock-5.[incr i] {time zone boundary case $x} [list $conds] {"
+ puts $f2 " clock format $t -format [list $fmt] \\"
+ puts $f2 " -timezone :America/Detroit"
+ puts $f2 "} [list $r]"
+ }
+ }
+ puts "testcases5: $i test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases8 --
+#
+# Outputs the 'clock-8.x' test cases.
+#
+# Parameters:
+# f2 -- Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Test cases for parsing dates in ccyymmdd format are written to the
+# output file.
+#
+#----------------------------------------------------------------------
+
+proc testcases8 { f2 } {
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test parsing of ccyymmdd"
+ puts $f2 ""
+
+ set n 0
+ foreach year {1970 1971 2000 2001} {
+ foreach month {01 12} {
+ foreach day {02 31} {
+ set scanned [clock scan $year$month$day -gmt true]
+ foreach ccyy {%C%y %Y} {
+ foreach mm {%b %B %h %m %Om %N} {
+ foreach dd {%d %Od %e %Oe} {
+ set string [clock format $scanned \
+ -format "$ccyy $mm $dd" \
+ -locale en_US_roman \
+ -gmt true]
+ puts $f2 "test clock-8.[incr n] {parse ccyymmdd} {"
+ puts $f2 " [list clock scan $string -format [list $ccyy $mm $dd] -locale en_US_roman -gmt 1]"
+ puts $f2 "} $scanned"
+ }
+ }
+ }
+ foreach fmt {%x %D} {
+ set string [clock format $scanned \
+ -format $fmt \
+ -locale en_US_roman \
+ -gmt true]
+ puts $f2 "test clock-8.[incr n] {parse ccyymmdd} {"
+ puts $f2 " [list clock scan $string -format $fmt -locale en_US_roman -gmt 1]"
+ puts $f2 "} $scanned"
+ }
+ }
+ }
+ }
+
+ puts "testcases8: $n test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases11 --
+#
+# Outputs the 'clock-11.x' test cases.
+#
+# Parameters:
+# f2 -- Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Test cases for precedence among YYYYMMDD and YYYYDDD are written
+# to f2.
+#
+#----------------------------------------------------------------------
+
+proc testcases11 { f2 } {
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test precedence among yyyymmdd and yyyyddd"
+ puts $f2 ""
+
+ array set v {
+ Y 1970
+ m 01
+ d 01
+ j 002
+ }
+
+ set n 0
+
+ foreach {a b c d} {
+ Y m d j m Y d j d Y m j j Y m d
+ Y m j d m Y j d d Y j m j Y d m
+ Y d m j m d Y j d m Y j j m Y d
+ Y d j m m d j Y d m j Y j m d Y
+ Y j m d m j Y d d j Y m j d Y m
+ Y j d m m j d Y d j m Y j d m Y
+ } {
+ foreach x [list $a $b $c $d] {
+ switch -exact -- $x {
+ m - d {
+ set value 0
+ }
+ j {
+ set value 86400
+ }
+ }
+ }
+ set format "%$a%$b%$c%$d"
+ set string "$v($a)$v($b)$v($c)$v($d)"
+ puts $f2 "test clock-11.[incr n] {precedence of ccyyddd and ccyymmdd} {"
+ puts $f2 " [list clock scan $string -format $format -gmt 1]"
+ puts $f2 "} $value"
+ }
+
+ puts "testcases11: $n test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases12 --
+#
+# Outputs the 'clock-12.x' test cases, parsing CCyyWwwd
+#
+# Parameters:
+# f2 -- Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Test cases for parsing dates in Gregorian calendar are written to the
+# output file.
+#
+#----------------------------------------------------------------------
+
+proc testcases12 { f2 } {
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test parsing of ccyyWwwd"
+ puts $f2 ""
+
+ set n 0
+ foreach year {1970 1971 2000 2001} {
+ foreach month {01 12} {
+ foreach day {02 31} {
+ set scanned [clock scan $year$month$day -gmt true]
+ foreach d {%a %A %u %w %Ou %Ow} {
+ set string [clock format $scanned \
+ -format "%G W%V $d" \
+ -locale en_US_roman \
+ -gmt true]
+ puts $f2 "test clock-12.[incr n] {parse ccyyWwwd} {"
+ puts $f2 " [list clock scan $string -format [list %G W%V $d] -locale en_US_roman -gmt 1]"
+ puts $f2 "} $scanned"
+ }
+ }
+ }
+ }
+
+ puts "testcases12: $n test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases14 --
+#
+# Outputs the 'clock-14.x' test cases.
+#
+# Parameters:
+# f2 -- Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Test cases for parsing yymmdd dates are output.
+#
+#----------------------------------------------------------------------
+
+proc testcases14 { f2 } {
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test parsing of yymmdd"
+ puts $f2 ""
+
+ set n 0
+ foreach year {1938 1970 2000 2037} {
+ foreach month {01 12} {
+ foreach day {02 31} {
+ set scanned [clock scan $year$month$day -gmt true]
+ foreach yy {%y %Oy} {
+ foreach mm {%b %B %h %m %Om %N} {
+ foreach dd {%d %Od %e %Oe} {
+ set string [clock format $scanned \
+ -format "$yy $mm $dd" \
+ -locale en_US_roman \
+ -gmt true]
+ puts $f2 "test clock-14.[incr n] {parse yymmdd} {"
+ puts $f2 " [list clock scan $string -format [list $yy $mm $dd] -locale en_US_roman -gmt 1]"
+ puts $f2 "} $scanned"
+ }
+ }
+ }
+ }
+ }
+ }
+
+ puts "testcases14: $n test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases17 --
+#
+# Outputs the 'clock-17.x' test cases, parsing yyWwwd
+#
+# Parameters:
+# f2 -- Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Test cases for parsing dates in Gregorian calendar are written to the
+# output file.
+#
+#----------------------------------------------------------------------
+
+proc testcases17 { f2 } {
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test parsing of yyWwwd"
+ puts $f2 ""
+
+ set n 0
+ foreach year {1970 1971 2000 2001} {
+ foreach month {01 12} {
+ foreach day {02 31} {
+ set scanned [clock scan $year$month$day -gmt true]
+ foreach d {%a %A %u %w %Ou %Ow} {
+ set string [clock format $scanned \
+ -format "%g W%V $d" \
+ -locale en_US_roman \
+ -gmt true]
+ puts $f2 "test clock-17.[incr n] {parse yyWwwd} {"
+ puts $f2 " [list clock scan $string -format [list %g W%V $d] -locale en_US_roman -gmt 1]"
+ puts $f2 "} $scanned"
+ }
+ }
+ }
+ }
+
+ puts "testcases17: $n test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases19 --
+#
+# Outputs the 'clock-19.x' test cases.
+#
+# Parameters:
+# f2 -- Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Test cases for parsing mmdd dates are output.
+#
+#----------------------------------------------------------------------
+
+proc testcases19 { f2 } {
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test parsing of mmdd"
+ puts $f2 ""
+
+ set n 0
+ foreach year {1938 1970 2000 2037} {
+ set base [clock scan ${year}0101 -gmt true]
+ foreach month {01 12} {
+ foreach day {02 31} {
+ set scanned [clock scan $year$month$day -gmt true]
+ foreach mm {%b %B %h %m %Om %N} {
+ foreach dd {%d %Od %e %Oe} {
+ set string [clock format $scanned \
+ -format "$mm $dd" \
+ -locale en_US_roman \
+ -gmt true]
+ puts $f2 "test clock-19.[incr n] {parse mmdd} {"
+ puts $f2 " [list clock scan $string -format [list $mm $dd] -locale en_US_roman -base $base -gmt 1]"
+ puts $f2 "} $scanned"
+ }
+ }
+ }
+ }
+ }
+
+ puts "testcases19: $n test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases21 --
+#
+# Outputs the 'clock-21.x' test cases, parsing Wwwd
+#
+# Parameters:
+# f2 -- Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Test cases for parsing dates in Gregorian calendar are written to the
+# output file.
+#
+#----------------------------------------------------------------------
+
+proc testcases22 { f2 } {
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test parsing of Wwwd"
+ puts $f2 ""
+
+ set n 0
+ foreach year {1970 1971 2000 2001} {
+ set base [clock scan ${year}0104 -gmt true]
+ foreach month {03 10} {
+ foreach day {01 31} {
+ set scanned [clock scan $year$month$day -gmt true]
+ foreach d {%a %A %u %w %Ou %Ow} {
+ set string [clock format $scanned \
+ -format "W%V $d" \
+ -locale en_US_roman \
+ -gmt true]
+ puts $f2 "test clock-22.[incr n] {parse Wwwd} {"
+ puts $f2 " [list clock scan $string -format [list W%V $d] -locale en_US_roman -gmt 1] -base $base"
+ puts $f2 "} $scanned"
+ }
+ }
+ }
+ }
+
+ puts "testcases22: $n test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases24 --
+#
+# Outputs the 'clock-24.x' test cases.
+#
+# Parameters:
+# f2 -- Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Test cases for parsing naked day of the month are output.
+#
+#----------------------------------------------------------------------
+
+proc testcases24 { f2 } {
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test parsing of naked day-of-month"
+ puts $f2 ""
+
+ set n 0
+ foreach year {1970 2000} {
+ foreach month {01 12} {
+ set base [clock scan ${year}${month}01 -gmt true]
+ foreach day {02 28} {
+ set scanned [clock scan $year$month$day -gmt true]
+ foreach dd {%d %Od %e %Oe} {
+ set string [clock format $scanned \
+ -format "$dd" \
+ -locale en_US_roman \
+ -gmt true]
+ puts $f2 "test clock-24.[incr n] {parse naked day of month} {"
+ puts $f2 " [list clock scan $string -format $dd -locale en_US_roman -base $base -gmt 1]"
+ puts $f2 "} $scanned"
+ }
+ }
+ }
+ }
+
+ puts "testcases24: $n test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases26 --
+#
+# Outputs the 'clock-26.x' test cases, parsing naked day of week
+#
+# Parameters:
+# f2 -- Channel handle to the output file
+#
+# Results:
+# None.
+#
+# Side effects:
+# Test cases for parsing dates in Gregorian calendar are written to the
+# output file.
+#
+#----------------------------------------------------------------------
+
+proc testcases26 { f2 } {
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test parsing of naked day of week"
+ puts $f2 ""
+
+ set n 0
+ foreach year {1970 2001} {
+ foreach week {01 52} {
+ set base [clock scan ${year}W${week}4 \
+ -format %GW%V%u -gmt true]
+ foreach day {1 7} {
+ set scanned [clock scan ${year}W${week}${day} \
+ -format %GW%V%u -gmt true]
+ foreach d {%a %A %u %w %Ou %Ow} {
+ set string [clock format $scanned \
+ -format "$d" \
+ -locale en_US_roman \
+ -gmt true]
+ puts $f2 "test clock-26.[incr n] {parse naked day of week} {"
+ puts $f2 " [list clock scan $string -format $d -locale en_US_roman -gmt 1] -base $base"
+ puts $f2 "} $scanned"
+ }
+ }
+ }
+ }
+
+ puts "testcases26: $n test cases"
+}
+
+#----------------------------------------------------------------------
+#
+# testcases29 --
+#
+# Makes test cases for parsing of time of day.
+#
+# Parameters:
+# f2 -- Channel where tests are to be written
+#
+# Results:
+# None.
+#
+# Side effects:
+# Writes the tests.
+#
+#----------------------------------------------------------------------
+
+proc testcases29 { f2 } {
+
+ # Put out a header describing the tests
+
+ puts $f2 ""
+ puts $f2 "\# Test parsing of time of day"
+ puts $f2 ""
+
+ set n 0
+ foreach hour {0 1 11 12 13 23} \
+ hampm {12 1 11 12 1 11} \
+ lhour {? i xi xii xiii xxiii} \
+ lhampm {xii i xi xii i xi} \
+ ampmind {am am am pm pm pm} {
+ set sphr [format %2d $hour]
+ set 2dhr [format %02d $hour]
+ set sphampm [format %2d $hampm]
+ set 2dhampm [format %02d $hampm]
+ set AMPMind [string toupper $ampmind]
+ foreach minute {00 01 59} lminute {? i lix} {
+ foreach second {00 01 59} lsecond {? i lix} {
+ set time [expr { ( 60 * $hour + $minute ) * 60 + $second }]
+ foreach {hfmt afmt} [list \
+ %H {} %k {} %OH {} %Ok {} \
+ %I %p %l %p \
+ %OI %p %Ol %p \
+ %I %P %l %P \
+ %OI %P %Ol %P] \
+ {hfld afld} [list \
+ $2dhr {} $sphr {} $lhour {} $lhour {} \
+ $2dhampm $AMPMind $sphampm $AMPMind \
+ $lhampm $AMPMind $lhampm $AMPMind \
+ $2dhampm $ampmind $sphampm $ampmind \
+ $lhampm $ampmind $lhampm $ampmind] \
+ {
+ if { $second eq "00" } {
+ if { $minute eq "00" } {
+ puts $f2 "test clock-29.[incr n] {time parsing} {"
+ puts $f2 " clock scan {2440588 $hfld $afld} \\"
+ puts $f2 " -gmt true -locale en_US_roman \\"
+ puts $f2 " -format {%J $hfmt $afmt}"
+ puts $f2 "} $time"
+ }
+ puts $f2 "test clock-29.[incr n] {time parsing} {"
+ puts $f2 " clock scan {2440588 $hfld:$minute $afld} \\"
+ puts $f2 " -gmt true -locale en_US_roman \\"
+ puts $f2 " -format {%J $hfmt:%M $afmt}"
+ puts $f2 "} $time"
+ puts $f2 "test clock-29.[incr n] {time parsing} {"
+ puts $f2 " clock scan {2440588 $hfld:$lminute $afld} \\"
+ puts $f2 " -gmt true -locale en_US_roman \\"
+ puts $f2 " -format {%J $hfmt:%OM $afmt}"
+ puts $f2 "} $time"
+ }
+ puts $f2 "test clock-29.[incr n] {time parsing} {"
+ puts $f2 " clock scan {2440588 $hfld:$minute:$second $afld} \\"
+ puts $f2 " -gmt true -locale en_US_roman \\"
+ puts $f2 " -format {%J $hfmt:%M:%S $afmt}"
+ puts $f2 "} $time"
+ puts $f2 "test clock-29.[incr n] {time parsing} {"
+ puts $f2 " clock scan {2440588 $hfld:$lminute:$lsecond $afld} \\"
+ puts $f2 " -gmt true -locale en_US_roman \\"
+ puts $f2 " -format {%J $hfmt:%OM:%OS $afmt}"
+ puts $f2 "} $time"
+ }
+ }
+ }
+
+ }
+ puts "testcases29: $n test cases"
+}
+
+processFile $d
diff --git a/tcl8.6/tools/man2help.tcl b/tcl8.6/tools/man2help.tcl
new file mode 100644
index 0000000..ca29226
--- /dev/null
+++ b/tcl8.6/tools/man2help.tcl
@@ -0,0 +1,141 @@
+# man2help.tcl --
+#
+# This file defines procedures that work in conjunction with the
+# man2tcl program to generate a Windows help file from Tcl manual
+# entries.
+#
+# Copyright (c) 1996 by Sun Microsystems, Inc.
+
+#
+# PASS 1
+#
+
+set man2tclprog [file join [file dirname [info script]] \
+ man2tcl[file extension [info nameofexecutable]]]
+
+proc generateContents {basename version files} {
+ global curID topics
+ set curID 0
+ foreach f $files {
+ puts "Pass 1 -- $f"
+ flush stdout
+ doFile $f
+ }
+ set fd [open [file join [file dirname [info script]] $basename$version.cnt] w]
+ fconfigure $fd -translation crlf
+ puts $fd ":Base $basename$version.hlp"
+ foreach package [getPackages] {
+ foreach section [getSections $package] {
+ if {![info exists lastSection]} {
+ set lastSection {}
+ }
+ if {[string compare $lastSection $section]} {
+ puts $fd "1 $section"
+ }
+ set lastSection $section
+ set lastTopic {}
+ foreach topic [getTopics $package $section] {
+ if {[string compare $lastTopic $topic]} {
+ set id $topics($package,$section,$topic)
+ puts $fd "2 $topic=$id"
+ set lastTopic $topic
+ }
+ }
+ }
+ }
+ close $fd
+}
+
+
+#
+# PASS 2
+#
+
+proc generateHelp {basename files} {
+ global curID topics keywords file id_keywords
+ set curID 0
+
+ foreach key [array names keywords] {
+ foreach id $keywords($key) {
+ lappend id_keywords($id) $key
+ }
+ }
+
+ set file [open [file join [file dirname [info script]] $basename.rtf] w]
+ fconfigure $file -translation crlf
+ puts $file "\{\\rtf1\\ansi \\deff0\\deflang1033\{\\fonttbl\{\\f0\\froman\\fcharset0\\fprq2 Times New Roman\;\}\{\\f1\\fmodern\\fcharset0\\fprq1 Courier New\;\}\}"
+ foreach f $files {
+ puts "Pass 2 -- $f"
+ flush stdout
+ initGlobals
+ doFile $f
+ pageBreak
+ }
+ puts $file "\}"
+ close $file
+}
+
+# doFile --
+#
+# Given a file as argument, translate the file to a tcl script and
+# evaluate it.
+#
+# Arguments:
+# file - Name of file to translate.
+
+proc doFile {file} {
+ global man2tclprog
+ if {[catch {eval [exec $man2tclprog [glob $file]]} msg]} {
+ global errorInfo
+ puts stderr $msg
+ puts "in"
+ puts $errorInfo
+ exit 1
+ }
+}
+
+# doDir --
+#
+# Given a directory as argument, translate all the man pages in
+# that directory.
+#
+# Arguments:
+# dir - Name of the directory.
+
+proc doDir dir {
+ puts "Generating man pages for $dir..."
+ foreach f [lsort [glob -directory $dir "*.\[13n\]"]] {
+ doFile $f
+ }
+}
+
+# process command line arguments
+
+if {$argc < 3} {
+ puts stderr "usage: $argv0 \[options\] projectName version manFiles..."
+ exit 1
+}
+
+set arg 0
+
+if {![string compare [lindex $argv $arg] "-bitmap"]} {
+ set bitmap [lindex $argv [incr arg]]
+ incr arg
+}
+set baseName [lindex $argv $arg]
+set version [lindex $argv [incr arg]]
+set files {}
+foreach i [lrange $argv [incr arg] end] {
+ set i [file join $i]
+ if {[file isdir $i]} {
+ foreach f [lsort [glob -directory $i "*.\[13n\]"]] {
+ lappend files $f
+ }
+ } elseif {[file exists $i]} {
+ lappend files $i
+ }
+}
+source [file join [file dirname [info script]] index.tcl]
+generateContents $baseName $version $files
+source [file join [file dirname [info script]] man2help2.tcl]
+generateHelp $baseName $files
diff --git a/tcl8.6/tools/man2help2.tcl b/tcl8.6/tools/man2help2.tcl
new file mode 100644
index 0000000..9c8f503
--- /dev/null
+++ b/tcl8.6/tools/man2help2.tcl
@@ -0,0 +1,1033 @@
+# man2help2.tcl --
+#
+# This file defines procedures that are used during the second pass of
+# the man page conversion. It converts the man format input to rtf
+# form suitable for use by the Windows help compiler.
+#
+# Copyright (c) 1996 by Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# Global variables used by these scripts:
+#
+# state - state variable that controls action of text proc.
+#
+# topics - array indexed by (package,section,topic) with value
+# of topic ID.
+#
+# keywords - array indexed by keyword string with value of topic ID.
+#
+# curID - current topic ID, starts at 0 and is incremented for
+# each new topic file.
+#
+# curPkg - current package name (e.g. Tcl).
+#
+# curSect - current section title (e.g. "Tcl Built-In Commands").
+#
+
+# initGlobals --
+#
+# This procedure is invoked to set the initial values of all of the
+# global variables, before processing a man page.
+#
+# Arguments:
+# None.
+
+proc initGlobals {} {
+ uplevel \#0 unset state
+ global state chars
+
+ set state(paragraphPending) 0
+ set state(breakPending) 0
+ set state(firstIndent) 0
+ set state(leftIndent) 0
+
+ set state(inTP) 0
+ set state(paragraph) 0
+ set state(textState) 0
+ set state(curFont) ""
+ set state(startCode) "{\\b "
+ set state(startEmphasis) "{\\i "
+ set state(endCode) "}"
+ set state(endEmphasis) "}"
+ set state(noFill) 0
+ set state(charCnt) 0
+ set state(offset) [getTwips 0.5i]
+ set state(leftMargin) [getTwips 0.5i]
+ set state(nestingLevel) 0
+ set state(intl) 0
+ set state(sb) 0
+ setTabs 0.5i
+
+# set up international character table
+
+ array set chars {
+ o^ F4
+ }
+}
+
+
+# beginFont --
+#
+# Arranges for future text to use a special font, rather than
+# the default paragraph font.
+#
+# Arguments:
+# font - Name of new font to use.
+
+proc beginFont {font} {
+ global file state
+
+ textSetup
+ if {[string equal $state(curFont) $font]} {
+ return
+ }
+ endFont
+ puts -nonewline $file $state(start$font)
+ set state(curFont) $font
+}
+
+
+# endFont --
+#
+# Reverts to the default font for the paragraph type.
+#
+# Arguments:
+# None.
+
+proc endFont {} {
+ global state file
+
+ if {[string compare $state(curFont) ""]} {
+ puts -nonewline $file $state(end$state(curFont))
+ set state(curFont) ""
+ }
+}
+
+
+# textSetup --
+#
+# This procedure is called the first time that text is output for a
+# paragraph. It outputs the header information for the paragraph.
+#
+# Arguments:
+# None.
+
+proc textSetup {} {
+ global file state
+
+ if $state(breakPending) {
+ puts $file "\\line"
+ }
+ if $state(paragraphPending) {
+ puts $file [format "\\par\n\\pard\\fi%.0f\\li%.0f" \
+ $state(firstIndent) $state(leftIndent)]
+ foreach tab $state(tabs) {
+ puts $file [format "\\tx%.0f" $tab]
+ }
+ set state(tabs) {}
+ if {$state(sb)} {
+ puts $file "\\sb$state(sb)"
+ set state(sb) 0
+ }
+ }
+ set state(breakPending) 0
+ set state(paragraphPending) 0
+}
+
+
+# text --
+#
+# This procedure adds text to the current state(paragraph). If this is
+# the first text in the state(paragraph) then header information for the
+# state(paragraph) is output before the text.
+#
+# Arguments:
+# string - Text to output in the state(paragraph).
+
+proc text {string} {
+ global file state chars
+
+ textSetup
+ set string [string map [list \
+ "\\" "\\\\" \
+ "\{" "\\\{" \
+ "\}" "\\\}" \
+ "\t" {\tab } \
+ '' "\\rdblquote " \
+ `` "\\ldblquote " \
+ "\u00b7" "\\bullet " \
+ ] $string]
+
+ # Check if this is the beginning of an international character string.
+ # If so, look up the sequence in the chars table and substitute the
+ # appropriate hex value.
+
+ if {$state(intl)} {
+ if {[regexp {^'([^']*)'} $string dummy ch]} {
+ if {[info exists chars($ch)]} {
+ regsub {^'[^']*'} $string "\\\\'$chars($ch)" string
+ } else {
+ puts stderr "Unknown international character '$ch'"
+ }
+ }
+ set state(intl) 0
+ }
+
+ switch $state(textState) {
+ REF {
+ if {$state(inTP) == 0} {
+ set string [insertRef $string]
+ }
+ }
+ SEE {
+ global topics curPkg curSect
+ foreach i [split $string] {
+ if {![regexp -nocase {^[a-z_0-9]+} [string trim $i] i ]} {
+ continue
+ }
+ if {![catch {set ref $topics($curPkg,$curSect,$i)} ]} {
+ regsub $i $string [link $i $ref] string
+ }
+ }
+ }
+ KEY {
+ return
+ }
+ }
+ puts -nonewline $file "$string"
+}
+
+
+
+# insertRef --
+#
+# This procedure looks for a string in the cross reference table and
+# generates a hot-link to the appropriate topic. Tries to find the
+# nearest reference in the manual.
+#
+# Arguments:
+# string - Text to output in the state(paragraph).
+
+proc insertRef {string} {
+ global NAME_file curPkg curSect topics curID
+ set path {}
+ set string [string trim $string]
+ set ref {}
+ if {[info exists topics($curPkg,$curSect,$string)]} {
+ set ref $topics($curPkg,$curSect,$string)
+ } else {
+ set sites [array names topics "$curPkg,*,$string"]
+ set count [llength $sites]
+ if {$count > 0} {
+ set ref $topics([lindex $sites 0])
+ } else {
+ set sites [array names topics "*,*,$string"]
+ set count [llength $sites]
+ if {$count > 0} {
+ set ref $topics([lindex $sites 0])
+ }
+ }
+ }
+
+ if {($ref != "") && ($ref != $curID)} {
+ set string [link $string $ref]
+ }
+ return $string
+}
+
+
+
+# macro --
+#
+# This procedure is invoked to process macro invocations that start
+# with "." (instead of ').
+#
+# Arguments:
+# name - The name of the macro (without the ".").
+# args - Any additional arguments to the macro.
+
+proc macro {name args} {
+ global state file
+ switch $name {
+ AP {
+ if {[llength $args] != 3 && [llength $args] != 2} {
+ puts stderr "Bad .AP macro: .$name [join $args " "]"
+ }
+ newPara 3.75i -3.75i
+ setTabs {1.25i 2.5i 3.75i}
+ font B
+ text [lindex $args 0]
+ tab
+ font I
+ text [lindex $args 1]
+ tab
+ font R
+ if {[llength $args] == 3} {
+ text "([lindex $args 2])"
+ }
+ tab
+ }
+ AS {
+ # next page and previous page
+ }
+ br {
+ lineBreak
+ }
+ BS {}
+ BE {}
+ CE {
+ puts -nonewline $::file "\\f0\\fs20 "
+ set state(noFill) 0
+ set state(breakPending) 0
+ newPara ""
+ set state(leftIndent) [expr {$state(leftIndent) - $state(offset)}]
+ set state(sb) 80
+ }
+ CS {
+ # code section
+ set state(noFill) 1
+ newPara ""
+ set state(leftIndent) [expr {$state(leftIndent) + $state(offset)}]
+ set state(sb) 80
+ puts -nonewline $::file "\\f1\\fs18 "
+ }
+ DE {
+ set state(noFill) 0
+ decrNestingLevel
+ newPara 0i
+ }
+ DS {
+ set state(noFill) 1
+ incrNestingLevel
+ newPara 0i
+ }
+ fi {
+ set state(noFill) 0
+ }
+ IP {
+ IPmacro $args
+ }
+ LP {
+ newPara 0i
+ set state(sb) 80
+ }
+ ne {
+ }
+ nf {
+ set state(noFill) 1
+ }
+ OP {
+ if {[llength $args] != 3} {
+ puts stderr "Bad .OP macro: .$name [join $args " "]"
+ }
+ set state(nestingLevel) 0
+ newPara 0i
+ set state(sb) 120
+ setTabs 4c
+ text "Command-Line Name:"
+ tab
+ font B
+ set x [lindex $args 0]
+ regsub -all {\\-} $x - x
+ text $x
+ lineBreak
+ font R
+ text "Database Name:"
+ tab
+ font B
+ text [lindex $args 1]
+ lineBreak
+ font R
+ text "Database Class:"
+ tab
+ font B
+ text [lindex $args 2]
+ font R
+ set state(inTP) 0
+ newPara 0.5i
+ set state(sb) 80
+ }
+ PP {
+ newPara 0i
+ set state(sb) 120
+ }
+ RE {
+ decrNestingLevel
+ }
+ RS {
+ incrNestingLevel
+ }
+ SE {
+ font R
+ set state(noFill) 0
+ set state(nestingLevel) 0
+ newPara 0i
+ text "See the "
+ font B
+ set temp $state(textState)
+ set state(textState) REF
+ text options
+ set state(textState) $temp
+ font R
+ text " manual entry for detailed descriptions of the above options."
+ }
+ SH {
+ SHmacro $args
+ }
+ SS {
+ SHmacro $args subsection
+ }
+ SO {
+ SHmacro "STANDARD OPTIONS"
+ set state(nestingLevel) 0
+ newPara 0i
+ setTabs {4c 8c 12c}
+ font B
+ set state(noFill) 1
+ }
+ so {
+ if {$args ne "man.macros"} {
+ puts stderr "Unknown macro: .$name [join $args " "]"
+ }
+ }
+ sp { ;# needs work
+ if {$args eq ""} {
+ set count 1
+ } else {
+ set count [lindex $args 0]
+ }
+ while {$count > 0} {
+ lineBreak
+ incr count -1
+ }
+ }
+ ta {
+ setTabs $args
+ }
+ TH {
+ THmacro $args
+ }
+ TP {
+ TPmacro $args
+ }
+ UL { ;# underline
+ puts -nonewline $file "{\\ul "
+ text [lindex $args 0]
+ puts -nonewline $file "}"
+ if {[llength $args] == 2} {
+ text [lindex $args 1]
+ }
+ }
+ VE {}
+ VS {}
+ QW {
+ formattedText "``[lindex $args 0]''[lindex $args 1] "
+ }
+ MT {
+ text "``'' "
+ }
+ PQ {
+ formattedText \
+ "(``[lindex $args 0]''[lindex $args 1])[lindex $args 2] "
+ }
+ QR {
+ formattedText "``[lindex $args 0]"
+ dash
+ formattedText "[lindex $args 1]''[lindex $args 2] "
+ }
+ default {
+ puts stderr "Unknown macro: .$name [join $args " "]"
+ }
+ }
+}
+
+
+# link --
+#
+# This procedure returns the string for a hot link to a different
+# context location.
+#
+# Arguments:
+# label - String to display in hot-spot.
+# id - Context string to jump to.
+
+proc link {label id} {
+ return "{\\uldb $label}{\\v $id}"
+}
+
+
+# font --
+#
+# This procedure is invoked to handle font changes in the text
+# being output.
+#
+# Arguments:
+# type - Type of font: R, I, B, or S.
+
+proc font {type} {
+ global state
+ switch $type {
+ P -
+ R {
+ endFont
+ if {$state(textState) eq "REF"} {
+ set state(textState) INSERT
+ }
+ }
+ C -
+ B {
+ beginFont Code
+ if {$state(textState) eq "INSERT"} {
+ set state(textState) REF
+ }
+ }
+ I {
+ beginFont Emphasis
+ }
+ S {
+ }
+ default {
+ puts stderr "Unknown font: $type"
+ }
+ }
+}
+
+
+
+# formattedText --
+#
+# Insert a text string that may also have \fB-style font changes
+# and a few other backslash sequences in it.
+#
+# Arguments:
+# text - Text to insert.
+
+proc formattedText {text} {
+ global chars
+
+ while {$text ne ""} {
+ set index [string first \\ $text]
+ if {$index < 0} {
+ text $text
+ return
+ }
+ text [string range $text 0 [expr {$index-1}]]
+ set c [string index $text [expr {$index+1}]]
+ switch -- $c {
+ f {
+ font [string index $text [expr {$index+2}]]
+ set text [string range $text [expr {$index+3}] end]
+ }
+ e {
+ text "\\"
+ set text [string range $text [expr {$index+2}] end]
+ }
+ - {
+ dash
+ set text [string range $text [expr {$index+2}] end]
+ }
+ & - | {
+ set text [string range $text [expr {$index+2}] end]
+ }
+ ( {
+ char [string range $text $index [expr {$index+3}]]
+ set text [string range $text [expr {$index+4}] end]
+ }
+ default {
+ puts stderr "Unknown sequence: \\$c"
+ set text [string range $text [expr {$index+2}] end]
+ }
+ }
+ }
+}
+
+
+# dash --
+#
+# This procedure is invoked to handle dash characters ("\-" in
+# troff). It outputs a special dash character.
+#
+# Arguments:
+# None.
+
+proc dash {} {
+ global state
+ if {[string equal $state(textState) "NAME"]} {
+ set state(textState) 0
+ }
+ text "-"
+}
+
+
+# tab --
+#
+# This procedure is invoked to handle tabs in the troff input.
+# Right now it does nothing.
+#
+# Arguments:
+# None.
+
+proc tab {} {
+ global file
+
+ textSetup
+ puts -nonewline $file "\\tab "
+}
+
+
+# setTabs --
+#
+# This procedure handles the ".ta" macro, which sets tab stops.
+#
+# Arguments:
+# tabList - List of tab stops in *roff format
+
+proc setTabs {tabList} {
+ global file state
+
+ set state(tabs) {}
+ foreach arg $tabList {
+ if {[string match +* $arg]} {
+ set relativeTo [lindex $state(tabs) end]
+ set arg [string range $arg 1 end]
+ } else {
+ # Local left margin
+ set relativeTo [expr {$state(leftMargin) \
+ + ($state(offset) * $state(nestingLevel))}]
+ }
+ if {[regexp {^\\w'([^']*)'u$} $arg -> submatch]} {
+ # Magic factor!
+ set distance [expr {[string length $submatch] * 86.4}]
+ } else {
+ set distance [getTwips $arg]
+ }
+ lappend state(tabs) [expr {round($distance + $relativeTo)}]
+ }
+}
+
+
+# lineBreak --
+#
+# Generates a line break in the HTML output.
+#
+# Arguments:
+# None.
+
+proc lineBreak {} {
+ global state
+ textSetup
+ set state(breakPending) 1
+}
+
+
+
+# newline --
+#
+# This procedure is invoked to handle newlines in the troff input.
+# It outputs either a space character or a newline character, depending
+# on fill mode.
+#
+# Arguments:
+# None.
+
+proc newline {} {
+ global state
+
+ if {$state(inTP)} {
+ set state(inTP) 0
+ lineBreak
+ } elseif {$state(noFill)} {
+ lineBreak
+ } else {
+ text " "
+ }
+}
+
+
+# pageBreak --
+#
+# This procedure is invoked to generate a page break.
+#
+# Arguments:
+# None.
+
+proc pageBreak {} {
+ global file curVer
+ if {[string equal $curVer ""]} {
+ puts $file {\page}
+ } else {
+ puts $file {\par}
+ puts $file {\pard\sb400\qc}
+ puts $file "Last change: $curVer\\page"
+ }
+}
+
+
+# char --
+#
+# This procedure is called to handle a special character.
+#
+# Arguments:
+# name - Special character named in troff \x or \(xx construct.
+
+proc char {name} {
+ global file state
+
+ switch -exact $name {
+ {\o} {
+ set state(intl) 1
+ }
+ {\ } {
+ textSetup
+ puts -nonewline $file " "
+ }
+ {\0} {
+ textSetup
+ puts -nonewline $file " \\emspace "
+ }
+ {\\} - {\e} {
+ textSetup
+ puts -nonewline $file "\\\\"
+ }
+ {\(+-} {
+ textSetup
+ puts -nonewline $file "\\'b1 "
+ }
+ {\%} - {\|} {
+ }
+ {\(->} {
+ textSetup
+ puts -nonewline $file "->"
+ }
+ {\(bu} {
+ textSetup
+ puts -nonewline $file "\\bullet "
+ }
+ {\(co} {
+ textSetup
+ puts -nonewline $file "\\'a9 "
+ }
+ {\(mi} {
+ textSetup
+ puts -nonewline $file "-"
+ }
+ {\(mu} {
+ textSetup
+ puts -nonewline $file "\\'d7 "
+ }
+ {\(em} - {\(en} {
+ textSetup
+ puts -nonewline $file "-"
+ }
+ {\(fm} {
+ textSetup
+ puts -nonewline $file "\\'27 "
+ }
+ default {
+ puts stderr "Unknown character: $name"
+ }
+ }
+}
+
+
+# macro2 --
+#
+# This procedure handles macros that are invoked with a leading "'"
+# character instead of space. Right now it just generates an
+# error diagnostic.
+#
+# Arguments:
+# name - The name of the macro (without the ".").
+# args - Any additional arguments to the macro.
+
+proc macro2 {name args} {
+ puts stderr "Unknown macro: '$name [join $args " "]"
+}
+
+
+
+# SHmacro --
+#
+# Subsection head; handles the .SH and .SS macros.
+#
+# Arguments:
+# name - Section name.
+
+proc SHmacro {argList {style section}} {
+ global file state
+
+ set args [join $argList " "]
+ if {[llength $argList] < 1} {
+ puts stderr "Bad .SH macro: .SH $args"
+ }
+
+ # control what the text proc does with text
+
+ switch $args {
+ NAME {set state(textState) NAME}
+ DESCRIPTION {set state(textState) INSERT}
+ INTRODUCTION {set state(textState) INSERT}
+ "WIDGET-SPECIFIC OPTIONS" {set state(textState) INSERT}
+ "SEE ALSO" {set state(textState) SEE}
+ KEYWORDS {set state(textState) KEY; return}
+ }
+
+ if {$state(breakPending) != -1} {
+ set state(breakPending) 1
+ } else {
+ set state(breakPending) 0
+ }
+ set state(noFill) 0
+ if {[string compare "subsection" $style] == 0} {
+ nextPara .25i
+ } else {
+ nextPara 0i
+ }
+ font B
+ text $args
+ font R
+ nextPara .5i
+}
+
+# IPmacro --
+#
+# This procedure is invoked to handle ".IP" macros, which may take any
+# of the following forms:
+#
+# .IP [1] Translate to a "1Step" state(paragraph).
+# .IP [x] (x > 1) Translate to a "Step" state(paragraph).
+# .IP Translate to a "Bullet" state(paragraph).
+# .IP text count Translate to a FirstBody state(paragraph) with special
+# indent and tab stop based on "count", and tab after
+# "text".
+#
+# Arguments:
+# argList - List of arguments to the .IP macro.
+#
+# HTML limitations: 'count' in '.IP text count' is ignored.
+
+proc IPmacro {argList} {
+ global file state
+
+ set length [llength $argList]
+ foreach {text indent} $argList break
+ if {$length > 2} {
+ puts stderr "Bad .IP macro: .IP [join $argList " "]"
+ }
+
+ if {$length == 0} {
+ set text {\(bu}
+ set indent 5
+ } elseif {$length == 1} {
+ set indent 5
+ }
+ if {$text == {\(bu}} {
+ set text "\u00b7"
+ }
+
+ set tab [expr $indent * 0.1]i
+ newPara $tab -$tab
+ set state(sb) 80
+ setTabs $tab
+ formattedText $text
+ tab
+}
+
+# TPmacro --
+#
+# This procedure is invoked to handle ".TP" macros, which may take any
+# of the following forms:
+#
+# .TP x Translate to an state(indent)ed state(paragraph) with the
+# specified state(indent) (in 100 twip units).
+# .TP Translate to an state(indent)ed state(paragraph) with
+# default state(indent).
+#
+# Arguments:
+# argList - List of arguments to the .IP macro.
+#
+# HTML limitations: 'x' in '.TP x' is ignored.
+
+proc TPmacro {argList} {
+ global state
+ set length [llength $argList]
+ if {$length == 0} {
+ set val 0.5i
+ } else {
+ set val [expr {([lindex $argList 0] * 100.0)/1440}]i
+ }
+ newPara $val -$val
+ setTabs $val
+ set state(inTP) 1
+ set state(sb) 120
+}
+
+
+# THmacro --
+#
+# This procedure handles the .TH macro. It generates the non-scrolling
+# header section for a given man page, and enters information into the
+# table of contents. The .TH macro has the following form:
+#
+# .TH name section date footer header
+#
+# Arguments:
+# argList - List of arguments to the .TH macro.
+
+proc THmacro {argList} {
+ global file curPkg curSect curID id_keywords state curVer bitmap
+
+ if {[llength $argList] != 5} {
+ set args [join $argList " "]
+ puts stderr "Bad .TH macro: .TH $args"
+ }
+ incr curID
+ set name [lindex $argList 0] ;# Tcl_UpVar
+ set page [lindex $argList 1] ;# 3
+ set curVer [lindex $argList 2] ;# 7.4
+ set curPkg [lindex $argList 3] ;# Tcl
+ set curSect [lindex $argList 4] ;# {Tcl Library Procedures}
+
+ regsub -all {\\ } $curSect { } curSect ;# Clean up for [incr\ Tcl]
+
+ puts $file "#{\\footnote $curID}" ;# Context string
+ puts $file "\${\\footnote $name}" ;# Topic title
+ set browse "${curSect}${name}"
+ regsub -all {[ _-]} $browse {} browse
+ puts $file "+{\\footnote $browse}" ;# Browse sequence
+
+ # Suppress duplicates
+ foreach i $id_keywords($curID) {
+ set keys($i) 1
+ }
+ foreach i [array names keys] {
+ set i [string trim $i]
+ if {[string length $i] > 0} {
+ puts $file "K{\\footnote $i}" ;# Keyword strings
+ }
+ }
+ unset keys
+ puts $file "\\pard\\tx3000\\sb100\\sa100\\fs24\\keepn"
+ font B
+ text $name
+ tab
+ text $curSect
+ font R
+ if {[info exists bitmap]} {
+ # a right justified bitmap
+ puts $file "\\\{bmrt $bitmap\\\}"
+ }
+ puts $file "\\fs20"
+ set state(breakPending) -1
+}
+
+# nextPara --
+#
+# Set the indents for a new paragraph, and start a paragraph break
+#
+# Arguments:
+# leftIndent - The new left margin for body lines.
+# firstIndent - The offset from the left margin for the first line.
+
+proc nextPara {leftIndent {firstIndent 0i}} {
+ global state
+ set state(leftIndent) [getTwips $leftIndent]
+ set state(firstIndent) [getTwips $firstIndent]
+ set state(paragraphPending) 1
+}
+
+
+# newPara --
+#
+# This procedure sets the left and hanging state(indent)s for a line.
+# State(Indent)s are specified in units of inches or centimeters, and are
+# relative to the current nesting level and left margin.
+#
+# Arguments:
+# leftState(Indent) - The new left margin for lines after the first.
+# firstState(Indent) - The new left margin for the first line of a state(paragraph).
+
+proc newPara {leftIndent {firstIndent 0i}} {
+ global state file
+ if $state(paragraph) {
+ puts -nonewline $file "\\line\n"
+ }
+ if {$leftIndent ne ""} {
+ set state(leftIndent) [expr {$state(leftMargin) \
+ + ($state(offset) * $state(nestingLevel)) \
+ + [getTwips $leftIndent]}]
+ }
+ set state(firstIndent) [getTwips $firstIndent]
+ set state(paragraphPending) 1
+}
+
+
+# getTwips --
+#
+# This procedure converts a distance in inches or centimeters into
+# twips (1/1440 of an inch).
+#
+# Arguments:
+# arg - A number followed by "i" or "c"
+
+proc getTwips {arg} {
+ if {[scan $arg "%f%s" distance units] != 2} {
+ puts stderr "bad distance \"$arg\""
+ return 0
+ }
+ if {[string length $units] > 1} {
+ puts stderr "additional characters after unit \"$arg\""
+ set units [string index $units 0]
+ }
+ switch -- $units {
+ c {
+ set distance [expr {$distance * 567}]
+ }
+ i {
+ set distance [expr {$distance * 1440}]
+ }
+ default {
+ puts stderr "bad units in distance \"$arg\""
+ return 0
+ }
+ }
+ return $distance
+}
+
+# incrNestingLevel --
+#
+# This procedure does the work of the .RS macro, which increments
+# the number of state(indent)ations that affect things like .PP.
+#
+# Arguments:
+# None.
+
+proc incrNestingLevel {} {
+ global state
+
+ incr state(nestingLevel)
+ set oldp $state(paragraph)
+ set state(paragraph) 0
+ newPara 0i
+ set state(paragraph) $oldp
+}
+
+# decrNestingLevel --
+#
+# This procedure does the work of the .RE macro, which decrements
+# the number of indentations that affect things like .PP.
+#
+# Arguments:
+# None.
+
+proc decrNestingLevel {} {
+ global state
+
+ if {$state(nestingLevel) == 0} {
+ puts stderr "Nesting level decremented below 0"
+ } else {
+ incr state(nestingLevel) -1
+ }
+}
diff --git a/tcl8.6/tools/man2html.tcl b/tcl8.6/tools/man2html.tcl
new file mode 100644
index 0000000..2d03ab6
--- /dev/null
+++ b/tcl8.6/tools/man2html.tcl
@@ -0,0 +1,185 @@
+#!/bin/sh
+# \
+exec tclsh "$0" ${1+"$@"}
+
+# man2html.tcl --
+#
+# This file contains procedures that work in conjunction with the
+# man2tcl program to generate a HTML files from Tcl manual entries.
+#
+# Copyright (c) 1996 by Sun Microsystems, Inc.
+
+
+# sarray -
+#
+# Save an array to a file so that it can be sourced.
+#
+# Arguments:
+# file - Name of the output file
+# args - Name of the arrays to save
+#
+proc sarray {file args} {
+ set file [open $file w]
+ foreach a $args {
+ upvar $a array
+ if {![array exists array]} {
+ puts "sarray: \"$a\" isn't an array"
+ break
+ }
+
+ foreach name [lsort [array names array]] {
+ regsub -all " " $name "\\ " name1
+ puts $file "set ${a}($name1) \{$array($name)\}"
+ }
+ }
+ close $file
+}
+
+
+# footer --
+#
+# Builds footer info for HTML pages
+#
+# Arguments:
+# packages - List of packages to link to.
+
+proc footer {packages} {
+ lappend f "<HR>"
+ set h {[}
+ foreach package $packages {
+ lappend h "<A HREF=\"../$package/contents.html\">$package</A>"
+ lappend h "|"
+ }
+ lappend f [join [lreplace $h end end {]} ] " "]
+ lappend f "<HR>"
+ lappend f "<PRE>Copyright &#169; 1989-1994 The Regents of the University of California."
+ lappend f "Copyright &#169; 1994-1996 Sun Microsystems, Inc."
+ lappend f "</PRE>"
+ return [join $f "\n"]
+}
+
+
+# doDir --
+#
+# Given a directory as argument, translate all the man pages in
+# that directory.
+#
+# Arguments:
+# dir - Name of the directory.
+
+proc doDir dir {
+ foreach f [lsort [glob -directory $dir "*.\[13n\]"]] {
+ do $f ;# defined in man2html1.tcl & man2html2.tcl
+ }
+}
+
+
+# main --
+#
+# Main code for converting Tcl manual pages to HTML.
+#
+# Arguments:
+# argv - List of arguments to this script.
+
+proc main {argv} {
+ global html_dir
+ # Global vars used in man2html1.tcl and man2html2.tcl
+ global NAME_file KEY_file lib state curFile file inDT textState nestStk
+ global curFont fontStart fontEnd noFillCount footer
+
+ if {[llength $argv] < 2} {
+ puts stderr "usage: $::argv0 html_dir tcl_dir packages..."
+ puts stderr "usage: $::argv0 -clean html_dir"
+ exit 1
+ }
+
+ if {[lindex $argv 0] eq "-clean"} {
+ set html_dir [lindex $argv 1]
+ puts -nonewline "recursively remove: $html_dir? "
+ flush stdout
+ if {[gets stdin] eq "y"} {
+ puts "removing: $html_dir"
+ file delete -force $html_dir
+ }
+ exit 0
+ }
+
+ set html_dir [lindex $argv 0]
+ set tcl_dir [lindex $argv 1]
+ set packages [lrange $argv 2 end]
+ set homeDir [file dirname [info script]]
+
+ #### need to add glob capability to packages ####
+
+ # make sure there are doc directories for each package
+
+ foreach i $packages {
+ if {![file exists $tcl_dir/$i/doc]} {
+ puts stderr "Error: doc directory for package $i is missing"
+ exit 1
+ }
+ if {![file isdirectory $tcl_dir/$i/doc]} {
+ puts stderr "Error: $tcl_dir/$i/doc is not a directory"
+ exit 1
+ }
+ }
+
+ # we want to start with a clean sheet
+
+ if {[file exists $html_dir]} {
+ puts stderr "Error: HTML directory already exists"
+ exit 1
+ } else {
+ file mkdir $html_dir
+ }
+
+ set footer [footer $packages]
+
+ # make the hyperlink arrays and contents.html for all packages
+
+ foreach package $packages {
+ file mkdir $html_dir/$package
+
+ # build hyperlink database arrays: NAME_file and KEY_file
+ #
+ puts "\nScanning man pages in $tcl_dir/$package/doc..."
+ uplevel \#0 [list source $homeDir/man2html1.tcl]
+
+ doDir $tcl_dir/$package/doc
+
+ # clean up the NAME_file and KEY_file database arrays
+ #
+ catch {unset KEY_file()}
+ foreach name [lsort [array names NAME_file]] {
+ set file_name $NAME_file($name)
+ if {[llength $file_name] > 1} {
+ set file_name [lsort $file_name]
+ puts "Warning: '$name' multiply defined in: $file_name;\
+ using last"
+ set NAME_file($name) [lindex $file_name end]
+ }
+ }
+ # sarray $html_dir/$package/xref.tcl NAME_file KEY_file
+
+ # build the contents file from NAME_file
+ #
+ puts "\nGenerating contents.html for $package"
+ doContents $html_dir/$package/contents.html $lib ;# defined in man2html1.tcl
+
+ # now translate the man pages to HTML pages
+ #
+ uplevel \#0 [list source $homeDir/man2html2.tcl]
+ puts "\nBuilding html pages from man pages in $tcl_dir/$package/doc..."
+ doDir $tcl_dir/$package/doc
+
+ unset NAME_file
+ }
+}
+
+
+if [catch { main $argv } result] {
+ global errorInfo
+ puts stderr $result
+ puts stderr "in"
+ puts stderr $errorInfo
+}
diff --git a/tcl8.6/tools/man2html1.tcl b/tcl8.6/tools/man2html1.tcl
new file mode 100644
index 0000000..64982ff
--- /dev/null
+++ b/tcl8.6/tools/man2html1.tcl
@@ -0,0 +1,258 @@
+# man2html1.tcl --
+#
+# This file defines procedures that are used during the first pass of the
+# man page to html conversion process. It is sourced by h.tcl.
+#
+# Copyright (c) 1996 by Sun Microsystems, Inc.
+
+# Global variables used by these scripts:
+#
+# state - state variable that controls action of text proc.
+#
+# curFile - tail of current man page.
+#
+# file - file pointer; for both xref.tcl and contents.html
+#
+# NAME_file - array indexed by NAME and containing file names used
+# for hyperlinks.
+#
+# KEY_file - array indexed by KEYWORD and containing file names used
+# for hyperlinks.
+#
+# lib - contains package name. Used to label section in contents.html
+#
+# inDT - in dictionary term.
+
+
+# text --
+#
+# This procedure adds entries to the hypertext arrays NAME_file
+# and KEY_file.
+#
+# DT: might do this: if first word of $dt matches $name and [llength $name==1]
+# and [llength $dt > 1], then add to NAME_file.
+#
+# Arguments:
+# string - Text to index.
+
+proc text string {
+ global state curFile NAME_file KEY_file inDT
+
+ switch $state {
+ NAME {
+ foreach i [split $string ","] {
+ lappend NAME_file([string trim $i]) $curFile
+ }
+ }
+ KEY {
+ foreach i [split $string ","] {
+ lappend KEY_file([string trim $i]) $curFile
+ }
+ }
+ DT -
+ OFF -
+ DASH {}
+ default {
+ puts stderr "text: unknown state: $state"
+ }
+ }
+}
+
+
+# macro --
+#
+# This procedure is invoked to process macro invocations that start
+# with "." (instead of ').
+#
+# Arguments:
+# name - The name of the macro (without the ".").
+# args - Any additional arguments to the macro.
+
+proc macro {name args} {
+ switch $name {
+ SH - SS {
+ global state
+
+ switch $args {
+ NAME {
+ if {$state eq "INIT"} {
+ set state NAME
+ }
+ }
+ DESCRIPTION {set state DT}
+ INTRODUCTION {set state DT}
+ KEYWORDS {set state KEY}
+ default {set state OFF}
+ }
+
+ }
+ TP {
+ global inDT
+ set inDT 1
+ }
+ TH {
+ global lib state inDT
+ set inDT 0
+ set state INIT
+ if {[llength $args] != 5} {
+ set args [join $args " "]
+ puts stderr "Bad .TH macro: .$name $args"
+ }
+ set lib [lindex $args 3] ;# Tcl or Tk
+ }
+ }
+}
+
+
+# dash --
+#
+# This procedure is invoked to handle dash characters ("\-" in
+# troff). It only function in pass1 is to terminate the NAME state.
+#
+# Arguments:
+# None.
+
+proc dash {} {
+ global state
+ if {$state eq "NAME"} {
+ set state DASH
+ }
+}
+
+
+# newline --
+#
+# This procedure is invoked to handle newlines in the troff input.
+# It's only purpose is to terminate a DT (dictionary term).
+#
+# Arguments:
+# None.
+
+proc newline {} {
+ global inDT
+ set inDT 0
+}
+
+
+# initGlobals, tab, font, char, macro2 --
+#
+# These procedures do nothing during the first pass.
+#
+# Arguments:
+# None.
+
+proc initGlobals {} {}
+proc tab {} {}
+proc font type {}
+proc char name {}
+proc macro2 {name args} {}
+
+
+# doListing --
+#
+# Writes an ls like list to a file. Searches NAME_file for entries
+# that match the input pattern.
+#
+# Arguments:
+# file - Output file pointer.
+# pattern - glob style match pattern
+
+proc doListing {file pattern} {
+ global NAME_file
+
+ set max_len 0
+ foreach name [lsort [array names NAME_file]] {
+ set ref $NAME_file($name)
+ if [string match $pattern $ref] {
+ lappend type $name
+ if {[string length $name] > $max_len} {
+ set max_len [string length $name]
+ }
+ }
+ }
+ if [catch {llength $type} ] {
+ puts stderr " doListing: no names matched pattern ($pattern)"
+ return
+ }
+ incr max_len
+ set ncols [expr {90/$max_len}]
+ set nrows [expr {int(ceil([llength $type] / double($ncols)))} ]
+
+# ? max_len ncols nrows
+
+ set index 0
+ foreach f $type {
+ lappend row([expr {$index % $nrows}]) $f
+ incr index
+ }
+
+ puts -nonewline $file "<PRE>"
+ for {set i 0} {$i<$nrows} {incr i} {
+ foreach name $row($i) {
+ set str [format "%-*s" $max_len $name]
+ regsub $name $str "<A HREF=\"$NAME_file($name).html\">$name</A>" str
+ puts -nonewline $file $str
+ }
+ puts $file {}
+ }
+ puts $file "</PRE>"
+}
+
+
+# doContents --
+#
+# Generates a HTML contents file using the NAME_file array
+# as its input database.
+#
+# Arguments:
+# file - name of the contents file.
+# packageName - string used in the title and sub-heads of the HTML
+# page. Normally name of the package without version
+# numbers.
+
+proc doContents {file packageName} {
+ global footer
+
+ set file [open $file w]
+
+ puts $file "<HTML><HEAD><TITLE>$packageName Manual</TITLE></HEAD><BODY>"
+ puts $file "<H3>$packageName</H3>"
+ doListing $file "*.1"
+
+ puts $file "<HR><H3>$packageName Commands</H3>"
+ doListing $file "*.n"
+
+ puts $file "<HR><H3>$packageName Library</H3>"
+ doListing $file "*.3"
+
+ puts $file $footer
+ puts $file "</BODY></HTML>"
+ close $file
+}
+
+
+# do --
+#
+# This is the toplevel procedure that searches a man page
+# for hypertext links. It builds a data base consisting of
+# two arrays: NAME_file and KEY file. It runs the man2tcl
+# program to turn the man page into a script, then it evals
+# that script.
+#
+# Arguments:
+# fileName - Name of the file to scan.
+
+proc do fileName {
+ global curFile
+ set curFile [file tail $fileName]
+ set file stdout
+ puts " Pass 1 -- $fileName"
+ flush stdout
+ if [catch {eval [exec man2tcl [glob $fileName]]} msg] {
+ global errorInfo
+ puts stderr $msg
+ puts "in"
+ puts $errorInfo
+ exit 1
+ }
+}
diff --git a/tcl8.6/tools/man2html2.tcl b/tcl8.6/tools/man2html2.tcl
new file mode 100644
index 0000000..e4ccedf
--- /dev/null
+++ b/tcl8.6/tools/man2html2.tcl
@@ -0,0 +1,927 @@
+##############################################################################
+# man2html2.tcl --
+#
+# This file defines procedures that are used during the second pass of the man
+# page to html conversion process. It is sourced by man2html.tcl.
+#
+# Copyright (c) 1996 by Sun Microsystems, Inc.
+
+# Global variables used by these scripts:
+#
+# NAME_file - array indexed by NAME and containing file names used for
+# hyperlinks.
+#
+# textState - state variable defining action of 'text' proc.
+#
+# nestStk - stack oriented list containing currently active HTML tags (UL,
+# OL, DL). Local to 'nest' proc.
+#
+# inDT - set by 'TPmacro', cleared by 'newline'. Used to insert the
+# tag while in a dictionary list <DL>.
+#
+# curFont - Name of special font that is currently in use. Null means the
+# default paragraph font is being used.
+#
+# file - Where to output the generated HTML.
+#
+# fontStart - Array to map font names to starting sequences.
+#
+# fontEnd - Array to map font names to ending sequences.
+#
+# noFillCount - Non-zero means don't fill the next $noFillCount lines: force a
+# line break at each newline. Zero means filling is enabled, so
+# don't output line breaks for each newline.
+#
+# footer - info inserted at bottom of each page. Normally read from the
+# xref.tcl file
+
+##############################################################################
+# initGlobals --
+#
+# This procedure is invoked to set the initial values of all of the global
+# variables, before processing a man page.
+#
+# Arguments:
+# None.
+
+proc initGlobals {} {
+ global file noFillCount textState
+ global fontStart fontEnd curFont inPRE charCnt inTable
+
+ nest init
+ set inPRE 0
+ set inTable 0
+ set textState 0
+ set curFont ""
+ set fontStart(Code) "<B>"
+ set fontStart(Emphasis) "<I>"
+ set fontEnd(Code) "</B>"
+ set fontEnd(Emphasis) "</I>"
+ set noFillCount 0
+ set charCnt 0
+ setTabs 0.5i
+}
+
+##############################################################################
+# beginFont --
+#
+# Arranges for future text to use a special font, rather than the default
+# paragraph font.
+#
+# Arguments:
+# font - Name of new font to use.
+
+proc beginFont font {
+ global curFont file fontStart
+
+ if {$curFont eq $font} {
+ return
+ }
+ endFont
+ puts -nonewline $file $fontStart($font)
+ set curFont $font
+}
+
+##############################################################################
+# endFont --
+#
+# Reverts to the default font for the paragraph type.
+#
+# Arguments:
+# None.
+
+proc endFont {} {
+ global curFont file fontEnd
+
+ if {$curFont ne ""} {
+ puts -nonewline $file $fontEnd($curFont)
+ set curFont ""
+ }
+}
+
+##############################################################################
+# text --
+#
+# This procedure adds text to the current paragraph. If this is the first text
+# in the paragraph then header information for the paragraph is output before
+# the text.
+#
+# Arguments:
+# string - Text to output in the paragraph.
+
+proc text string {
+ global file textState inDT charCnt inTable
+
+ set pos [string first "\t" $string]
+ if {$pos >= 0} {
+ text [string range $string 0 [expr $pos-1]]
+ tab
+ text [string range $string [expr $pos+1] end]
+ return
+ }
+ if {$inTable} {
+ if {$inTable == 1} {
+ puts -nonewline $file <TR>
+ set inTable 2
+ }
+ puts -nonewline $file <TD>
+ }
+ incr charCnt [string length $string]
+ regsub -all {&} $string {\&amp;} string
+ regsub -all {<} $string {\&lt;} string
+ regsub -all {>} $string {\&gt;} string
+ regsub -all \" $string {\&quot;} string
+ switch -exact -- $textState {
+ REF {
+ if {$inDT eq ""} {
+ set string [insertRef $string]
+ }
+ }
+ SEE {
+ global NAME_file
+ foreach i [split $string] {
+ if {![regexp -nocase {^[a-z_]+} [string trim $i] i]} {
+# puts "Warning: $i in SEE ALSO not found"
+ continue
+ }
+ if {![catch { set ref $NAME_file($i) }]} {
+ regsub $i $string "<A HREF=\"$ref.html\">$i</A>" string
+ }
+ }
+ }
+ }
+ puts -nonewline $file "$string"
+ if {$inTable} {
+ puts -nonewline $file </TD>
+ }
+}
+
+##############################################################################
+# insertRef --
+#
+# Arguments:
+# string - Text to output in the paragraph.
+
+proc insertRef string {
+ global NAME_file self
+ set path {}
+ if {![catch { set ref $NAME_file([string trim $string]) }]} {
+ if {"$ref.html" ne $self} {
+ set string "<A HREF=\"${path}$ref.html\">$string</A>"
+# puts "insertRef: $self $ref.html ---$string--"
+ }
+ }
+ return $string
+}
+
+##############################################################################
+# macro --
+#
+# This procedure is invoked to process macro invocations that start with "."
+# (instead of ').
+#
+# Arguments:
+# name - The name of the macro (without the ".").
+# args - Any additional arguments to the macro.
+
+proc macro {name args} {
+ switch $name {
+ AP {
+ if {[llength $args] != 3} {
+ puts stderr "Bad .AP macro: .$name [join $args " "]"
+ }
+ setTabs {1.25i 2.5i 3.75i}
+ TPmacro {}
+ font B
+ text "[lindex $args 0] "
+ font I
+ text "[lindex $args 1]"
+ font R
+ text " ([lindex $args 2])"
+ newline
+ }
+ AS {} ;# next page and previous page
+ br {
+ lineBreak
+ }
+ BS {}
+ BE {}
+ CE {
+ global file noFillCount inPRE
+ puts $file </PRE></BLOCKQUOTE>
+ set inPRE 0
+ }
+ CS { ;# code section
+ global file noFillCount inPRE
+ puts -nonewline $file <BLOCKQUOTE><PRE>
+ set inPRE 1
+ }
+ DE {
+ global file noFillCount inTable
+ puts $file </TABLE></BLOCKQUOTE>
+ set inTable 0
+ set noFillCount 0
+ }
+ DS {
+ global file noFillCount inTable
+ puts -nonewline $file {<BLOCKQUOTE><TABLE BORDER="0">}
+ set noFillCount 10000000
+ set inTable 1
+ }
+ fi {
+ global noFillCount
+ set noFillCount 0
+ }
+ IP {
+ IPmacro $args
+ }
+ LP {
+ nest decr
+ nest incr
+ newPara
+ }
+ ne {
+ }
+ nf {
+ global noFillCount
+ set noFillCount 1000000
+ }
+ OP {
+ global inDT file inPRE
+ if {[llength $args] != 3} {
+ puts stderr "Bad .OP macro: .$name [join $args " "]"
+ }
+ nest para DL DT
+ set inPRE 1
+ puts -nonewline $file <PRE>
+ setTabs 4c
+ text "Command-Line Name:"
+ tab
+ font B
+ set x [lindex $args 0]
+ regsub -all {\\-} $x - x
+ text $x
+ newline
+ font R
+ text "Database Name:"
+ tab
+ font B
+ text [lindex $args 1]
+ newline
+ font R
+ text "Database Class:"
+ tab
+ font B
+ text [lindex $args 2]
+ font R
+ puts -nonewline $file </PRE>
+ set inDT "\n<DD>" ;# next newline writes inDT
+ set inPRE 0
+ newline
+ }
+ PP {
+ nest decr
+ nest incr
+ newPara
+ }
+ RE {
+ nest decr
+ }
+ RS {
+ nest incr
+ }
+ SE {
+ global noFillCount textState inPRE file
+
+ font R
+ puts -nonewline $file </PRE>
+ set inPRE 0
+ set noFillCount 0
+ nest reset
+ newPara
+ text "See the "
+ font B
+ set temp $textState
+ set textState REF
+ if {[llength $args] > 0} {
+ text [lindex $args 0]
+ } else {
+ text options
+ }
+ set textState $temp
+ font R
+ text " manual entry for detailed descriptions of the above options."
+ }
+ SH {
+ SHmacro $args
+ }
+ SS {
+ SHmacro $args subsection
+ }
+ SO {
+ global noFillCount inPRE file
+
+ SHmacro "STANDARD OPTIONS"
+ setTabs {4c 8c 12c}
+ set noFillCount 1000000
+ puts -nonewline $file <PRE>
+ set inPRE 1
+ font B
+ }
+ so {
+ if {$args ne "man.macros"} {
+ puts stderr "Unknown macro: .$name [join $args " "]"
+ }
+ }
+ sp { ;# needs work
+ if {$args eq ""} {
+ set count 1
+ } else {
+ set count [lindex $args 0]
+ }
+ while {$count > 0} {
+ lineBreak
+ incr count -1
+ }
+ }
+ ta {
+ setTabs $args
+ }
+ TH {
+ THmacro $args
+ }
+ TP {
+ TPmacro $args
+ }
+ UL { ;# underline
+ global file
+ puts -nonewline $file "<B><U>"
+ text [lindex $args 0]
+ puts -nonewline $file "</U></B>"
+ if {[llength $args] == 2} {
+ text [lindex $args 1]
+ }
+ }
+ VE {
+# global file
+# puts -nonewline $file "</FONT>"
+ }
+ VS {
+# global file
+# if {[llength $args] > 0} {
+# puts -nonewline $file "<BR>"
+# }
+# puts -nonewline $file "<FONT COLOR=\"GREEN\">"
+ }
+ QW {
+ puts -nonewline $file "&\#147;"
+ text [lindex $args 0]
+ puts -nonewline $file "&\#148;"
+ if {[llength $args] > 1} {
+ text [lindex $args 1]
+ }
+ }
+ PQ {
+ puts -nonewline $file "(&\#147;"
+ if {[lindex $args 0] eq {\N'34'}} {
+ puts -nonewline $file \"
+ } else {
+ text [lindex $args 0]
+ }
+ puts -nonewline $file "&\#148;"
+ if {[llength $args] > 1} {
+ text [lindex $args 1]
+ }
+ puts -nonewline $file ")"
+ if {[llength $args] > 2} {
+ text [lindex $args 2]
+ }
+ }
+ QR {
+ puts -nonewline $file "&\#147;"
+ text [lindex $args 0]
+ puts -nonewline $file "&\#148;&\#150;&\#147;"
+ text [lindex $args 1]
+ puts -nonewline $file "&\#148;"
+ if {[llength $args] > 2} {
+ text [lindex $args 2]
+ }
+ }
+ MT {
+ puts -nonewline $file "&\#147;&\#148;"
+ }
+ default {
+ puts stderr "Unknown macro: .$name [join $args " "]"
+ }
+ }
+
+# global nestStk; puts "$name [format "%-20s" $args] $nestStk"
+# flush stdout; flush stderr
+}
+
+##############################################################################
+# font --
+#
+# This procedure is invoked to handle font changes in the text being output.
+#
+# Arguments:
+# type - Type of font: R, I, B, or S.
+
+proc font type {
+ global textState
+ switch $type {
+ P -
+ R {
+ endFont
+ if {$textState eq "REF"} {
+ set textState INSERT
+ }
+ }
+ B {
+ beginFont Code
+ if {$textState eq "INSERT"} {
+ set textState REF
+ }
+ }
+ I {
+ beginFont Emphasis
+ }
+ S {
+ }
+ default {
+ puts stderr "Unknown font: $type"
+ }
+ }
+}
+
+##############################################################################
+# formattedText --
+#
+# Insert a text string that may also have \fB-style font changes and a few
+# other backslash sequences in it.
+#
+# Arguments:
+# text - Text to insert.
+
+proc formattedText text {
+# puts "formattedText: $text"
+ while {$text ne ""} {
+ set index [string first \\ $text]
+ if {$index < 0} {
+ text $text
+ return
+ }
+ text [string range $text 0 [expr $index-1]]
+ set c [string index $text [expr $index+1]]
+ switch -- $c {
+ f {
+ font [string index $text [expr $index+2]]
+ set text [string range $text [expr $index+3] end]
+ }
+ e {
+ text \\
+ set text [string range $text [expr $index+2] end]
+ }
+ - {
+ dash
+ set text [string range $text [expr $index+2] end]
+ }
+ | {
+ set text [string range $text [expr $index+2] end]
+ }
+ default {
+ puts stderr "Unknown sequence: \\$c"
+ set text [string range $text [expr $index+2] end]
+ }
+ }
+ }
+}
+
+##############################################################################
+# dash --
+#
+# This procedure is invoked to handle dash characters ("\-" in troff). It
+# outputs a special dash character.
+#
+# Arguments:
+# None.
+
+proc dash {} {
+ global textState charCnt
+ if {$textState eq "NAME"} {
+ set textState 0
+ }
+ incr charCnt
+ text "-"
+}
+
+##############################################################################
+# tab --
+#
+# This procedure is invoked to handle tabs in the troff input.
+#
+# Arguments:
+# None.
+
+proc tab {} {
+ global inPRE charCnt tabString file
+# ? charCnt
+ if {$inPRE == 1} {
+ set pos [expr $charCnt % [string length $tabString] ]
+ set spaces [string first "1" [string range $tabString $pos end] ]
+ text [format "%*s" [incr spaces] " "]
+ } else {
+# puts "tab: found tab outside of <PRE> block"
+ }
+}
+
+##############################################################################
+# setTabs --
+#
+# This procedure handles the ".ta" macro, which sets tab stops.
+#
+# Arguments:
+# tabList - List of tab stops, each consisting of a number
+# followed by "i" (inch) or "c" (cm).
+
+proc setTabs {tabList} {
+ global file breakPending tabString
+
+ # puts "setTabs: --$tabList--"
+ set last 0
+ set tabString {}
+ set charsPerInch 14.
+ set numTabs [llength $tabList]
+ foreach arg $tabList {
+ if {[string match +* $arg]} {
+ set relative 1
+ set arg [string range $arg 1 end]
+ } else {
+ set relative 0
+ }
+ # Always operate in relative mode for "measurement" mode
+ if {[regexp {^\\w'(.*)'u$} $arg content]} {
+ set distance [string length $content]
+ } else {
+ if {[scan $arg "%f%s" distance units] != 2} {
+ puts stderr "bad distance \"$arg\""
+ return 0
+ }
+ switch -- $units {
+ c {
+ set distance [expr {$distance * $charsPerInch / 2.54}]
+ }
+ i {
+ set distance [expr {$distance * $charsPerInch}]
+ }
+ default {
+ puts stderr "bad units in distance \"$arg\""
+ continue
+ }
+ }
+ }
+ # ? distance
+ if {$relative} {
+ append tabString [format "%*s1" [expr {round($distance-1)}] " "]
+ set last [expr {$last + $distance}]
+ } else {
+ append tabString [format "%*s1" [expr {round($distance-$last-1)}] " "]
+ set last $distance
+ }
+ }
+ # puts "setTabs: --$tabString--"
+}
+
+##############################################################################
+# lineBreak --
+#
+# Generates a line break in the HTML output.
+#
+# Arguments:
+# None.
+
+proc lineBreak {} {
+ global file inPRE
+ puts $file "<BR>"
+}
+
+##############################################################################
+# newline --
+#
+# This procedure is invoked to handle newlines in the troff input. It outputs
+# either a space character or a newline character, depending on fill mode.
+#
+# Arguments:
+# None.
+
+proc newline {} {
+ global noFillCount file inDT inPRE charCnt inTable
+
+ if {$inDT ne ""} {
+ puts $file "\n$inDT"
+ set inDT {}
+ } elseif {$inTable} {
+ if {$inTable > 1} {
+ puts $file </tr>
+ set inTable 1
+ }
+ } elseif {$noFillCount == 0 || $inPRE == 1} {
+ puts $file {}
+ } else {
+ lineBreak
+ incr noFillCount -1
+ }
+ set charCnt 0
+}
+
+##############################################################################
+# char --
+#
+# This procedure is called to handle a special character.
+#
+# Arguments:
+# name - Special character named in troff \x or \(xx construct.
+
+proc char name {
+ global file charCnt
+
+ incr charCnt
+# puts "char: $name"
+ switch -exact $name {
+ \\0 { ;# \0
+ puts -nonewline $file " "
+ }
+ \\\\ { ;# \
+ puts -nonewline $file "\\"
+ }
+ \\(+- { ;# +/-
+ puts -nonewline $file "&#177;"
+ }
+ \\% {} ;# \%
+ \\| { ;# \|
+ }
+ default {
+ puts stderr "Unknown character: $name"
+ }
+ }
+}
+
+##############################################################################
+# macro2 --
+#
+# This procedure handles macros that are invoked with a leading "'" character
+# instead of space. Right now it just generates an error diagnostic.
+#
+# Arguments:
+# name - The name of the macro (without the ".").
+# args - Any additional arguments to the macro.
+
+proc macro2 {name args} {
+ puts stderr "Unknown macro: '$name [join $args " "]"
+}
+
+##############################################################################
+# SHmacro --
+#
+# Subsection head; handles the .SH and .SS macros.
+#
+# Arguments:
+# name - Section name.
+# style - Type of section (optional)
+
+proc SHmacro {argList {style section}} {
+ global file noFillCount textState charCnt
+
+ set args [join $argList " "]
+ if {[llength $argList] < 1} {
+ puts stderr "Bad .SH macro: .$name $args"
+ }
+
+ set noFillCount 0
+ nest reset
+
+ set tag H3
+ if {$style eq "subsection"} {
+ set tag H4
+ }
+ puts -nonewline $file "<$tag>"
+ text $args
+ puts $file "</$tag>"
+
+# ? args textState
+
+ # control what the text proc does with text
+
+ switch $args {
+ NAME {set textState NAME}
+ DESCRIPTION {set textState INSERT}
+ INTRODUCTION {set textState INSERT}
+ "WIDGET-SPECIFIC OPTIONS" {set textState INSERT}
+ "SEE ALSO" {set textState SEE}
+ KEYWORDS {set textState 0}
+ }
+ set charCnt 0
+}
+
+##############################################################################
+# IPmacro --
+#
+# This procedure is invoked to handle ".IP" macros, which may take any of the
+# following forms:
+#
+# .IP [1] Translate to a "1Step" paragraph.
+# .IP [x] (x > 1) Translate to a "Step" paragraph.
+# .IP Translate to a "Bullet" paragraph.
+# .IP \(bu Translate to a "Bullet" paragraph.
+# .IP text count Translate to a FirstBody paragraph with
+# special indent and tab stop based on "count",
+# and tab after "text".
+#
+# Arguments:
+# argList - List of arguments to the .IP macro.
+#
+# HTML limitations: 'count' in '.IP text count' is ignored.
+
+proc IPmacro argList {
+ global file
+
+ setTabs 0.5i
+ set length [llength $argList]
+ if {$length == 0} {
+ nest para UL LI
+ return
+ }
+ # Special case for alternative mechanism for declaring bullets
+ if {[lindex $argList 0] eq "\\(bu"} {
+ nest para UL LI
+ return
+ }
+ if {[regexp {^\[\d+\]$} [lindex $argList 0]]} {
+ nest para OL LI
+ return
+ }
+ nest para DL DT
+ formattedText [lindex $argList 0]
+ puts $file "\n<DD>"
+ return
+}
+
+##############################################################################
+# TPmacro --
+#
+# This procedure is invoked to handle ".TP" macros, which may take any of the
+# following forms:
+#
+# .TP x Translate to an indented paragraph with the specified indent
+# (in 100 twip units).
+# .TP Translate to an indented paragraph with default indent.
+#
+# Arguments:
+# argList - List of arguments to the .IP macro.
+#
+# HTML limitations: 'x' in '.TP x' is ignored.
+
+proc TPmacro {argList} {
+ global inDT
+ nest para DL DT
+ set inDT "\n<DD>" ;# next newline writes inDT
+ setTabs 0.5i
+}
+
+##############################################################################
+# THmacro --
+#
+# This procedure handles the .TH macro. It generates the non-scrolling header
+# section for a given man page, and enters information into the table of
+# contents. The .TH macro has the following form:
+#
+# .TH name section date footer header
+#
+# Arguments:
+# argList - List of arguments to the .TH macro.
+
+proc THmacro {argList} {
+ global file
+
+ if {[llength $argList] != 5} {
+ set args [join $argList " "]
+ puts stderr "Bad .TH macro: .$name $args"
+ }
+ set name [lindex $argList 0] ;# Tcl_UpVar
+ set page [lindex $argList 1] ;# 3
+ set vers [lindex $argList 2] ;# 7.4
+ set lib [lindex $argList 3] ;# Tcl
+ set pname [lindex $argList 4] ;# {Tcl Library Procedures}
+
+ puts -nonewline $file "<HTML><HEAD><TITLE>"
+ text "$lib - $name ($page)"
+ puts $file "</TITLE></HEAD><BODY>\n"
+
+ puts -nonewline $file "<H1><CENTER>"
+ text $pname
+ puts $file "</CENTER></H1>\n"
+}
+
+##############################################################################
+# newPara --
+#
+# This procedure sets the left and hanging indents for a line. Indents are
+# specified in units of inches or centimeters, and are relative to the current
+# nesting level and left margin.
+#
+# Arguments:
+# None
+
+proc newPara {} {
+ global file nestStk
+
+ if {[lindex $nestStk end] ne "NEW"} {
+ nest decr
+ }
+ puts -nonewline $file "<P>"
+}
+
+##############################################################################
+# nest --
+#
+# This procedure takes care of inserting the tags associated with the IP, TP,
+# RS, RE, LP and PP macros. Only 'nest para' takes arguments.
+#
+# Arguments:
+# op - operation: para, incr, decr, reset, init
+# listStart - begin list tag: OL, UL, DL.
+# listItem - item tag: LI, LI, DT.
+
+proc nest {op {listStart "NEW"} {listItem ""} } {
+ global file nestStk inDT charCnt
+# puts "nest: $op $listStart $listItem"
+ switch $op {
+ para {
+ set top [lindex $nestStk end]
+ if {$top eq "NEW"} {
+ set nestStk [lreplace $nestStk end end $listStart]
+ puts $file "<$listStart>"
+ } elseif {$top ne $listStart} {
+ puts stderr "nest para: bad stack"
+ exit 1
+ }
+ puts $file "\n<$listItem>"
+ set charCnt 0
+ }
+ incr {
+ lappend nestStk NEW
+ }
+ decr {
+ if {[llength $nestStk] == 0} {
+ puts stderr "nest error: nest length is zero"
+ set nestStk NEW
+ }
+ set tag [lindex $nestStk end]
+ if {$tag ne "NEW"} {
+ puts $file "</$tag>"
+ }
+ set nestStk [lreplace $nestStk end end]
+ }
+ reset {
+ while {[llength $nestStk] > 0} {
+ nest decr
+ }
+ set nestStk NEW
+ }
+ init {
+ set nestStk NEW
+ set inDT {}
+ }
+ }
+ set charCnt 0
+}
+
+##############################################################################
+# do --
+#
+# This is the toplevel procedure that translates a man page to HTML. It runs
+# the man2tcl program to turn the man page into a script, then it evals that
+# script.
+#
+# Arguments:
+# fileName - Name of the file to translate.
+
+proc do fileName {
+ global file self html_dir package footer
+ set self "[file tail $fileName].html"
+ set file [open "$html_dir/$package/$self" w]
+ puts " Pass 2 -- $fileName"
+ flush stdout
+ initGlobals
+ if {[catch { eval [exec man2tcl [glob $fileName]] } msg]} {
+ global errorInfo
+ puts stderr $msg
+ puts "in"
+ puts stderr $errorInfo
+ exit 1
+ }
+ nest reset
+ puts $file $footer
+ puts $file "</BODY></HTML>"
+ close $file
+}
diff --git a/tcl8.6/tools/man2tcl.c b/tcl8.6/tools/man2tcl.c
new file mode 100644
index 0000000..8e59bea
--- /dev/null
+++ b/tcl8.6/tools/man2tcl.c
@@ -0,0 +1,424 @@
+/*
+ * man2tcl.c --
+ *
+ * This file contains a program that turns a man page of the form used
+ * for Tcl and Tk into a Tcl script that invokes a Tcl command for each
+ * construct in the man page. The script can then be eval'ed to translate
+ * the manual entry into some other format such as MIF or HTML.
+ *
+ * Usage:
+ *
+ * man2tcl ?fileName?
+ *
+ * Copyright (c) 1995 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+static char sccsid[] = "@(#) man2tcl.c 1.3 95/08/12 17:34:08";
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <ctype.h>
+#include <errno.h>
+
+/*
+ * Imported things that aren't defined in header files:
+ */
+
+/*
+ * Some <errno.h> define errno to be something complex and thread-aware; in
+ * that case we definitely do not want to declare errno ourselves!
+ */
+
+#ifndef errno
+extern int errno;
+#endif
+
+/*
+ * Current line number, used for error messages.
+ */
+
+static int lineNumber;
+
+/*
+ * The variable below is set to 1 if an error occurs anywhere while reading in
+ * the file.
+ */
+
+static int status;
+
+/*
+ * The variable below is set to 1 if output should be generated. If it's 0, it
+ * means we're doing a pre-pass to make sure that the file can be properly
+ * parsed.
+ */
+
+static int writeOutput;
+
+#define PRINT(args) if (writeOutput) { printf args; }
+#define PRINTC(chr) if (writeOutput) { putc((chr), stdout); }
+
+/*
+ * Prototypes for functions defined in this file:
+ */
+
+static void DoMacro(char *line);
+static void DoText(char *line);
+static void QuoteText(char *string, int count);
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * main --
+ *
+ * This function is the main program, which does all of the work of the
+ * program.
+ *
+ * Results:
+ * None: exits with a 0 return status to indicate success, or 1 to
+ * indicate that there were problems in the translation.
+ *
+ * Side effects:
+ * A Tcl script is output to standard output. Error messages may be
+ * output on standard error.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+main(
+ int argc, /* Number of command-line arguments. */
+ char **argv) /* Values of command-line arguments. */
+{
+ FILE *f;
+#define MAX_LINE_SIZE 4000
+ char line[MAX_LINE_SIZE];
+ char *p;
+
+ /*
+ * Find the file to read, and open it if it isn't stdin.
+ */
+
+ if (argc == 1) {
+ f = stdin;
+ } else if (argc == 2) {
+ f = fopen(argv[1], "r");
+ if (f == NULL) {
+ fprintf(stderr, "Couldn't read \"%s\": %s\n", argv[1],
+ strerror(errno));
+ exit(1);
+ }
+ } else {
+ fprintf(stderr, "Usage: %s ?fileName?\n", argv[0]);
+ }
+
+ /*
+ * Make two passes over the file. In the first pass, just check to make
+ * sure we can handle everything. If there are problems, generate output
+ * and stop. If everything is OK, make a second pass to actually generate
+ * output.
+ */
+
+ for (writeOutput = 0; writeOutput < 2; writeOutput++) {
+ lineNumber = 0;
+ status = 0;
+ while (fgets(line, MAX_LINE_SIZE, f) != NULL) {
+ for (p = line; *p != 0; p++) {
+ if (*p == '\n') {
+ *p = 0;
+ break;
+ }
+ }
+ lineNumber++;
+
+ if (((line[0] == '.') || (line[0] == '\'')) && (line[1] == '\\') && (line[2] == '\"')) {
+ /*
+ * This line is a comment. Ignore it.
+ */
+
+ continue;
+ }
+
+ if (strlen(line) >= MAX_LINE_SIZE -1) {
+ fprintf(stderr, "Too long line. Max is %d chars.\n",
+ MAX_LINE_SIZE - 1);
+ exit(1);
+ }
+
+ if ((line[0] == '.') || (line[0] == '\'')) {
+ /*
+ * This line is a macro invocation.
+ */
+
+ DoMacro(line);
+ } else {
+ /*
+ * This line is text, possibly with formatting characters
+ * embedded in it.
+ */
+
+ DoText(line);
+ }
+ }
+ if (status != 0) {
+ break;
+ }
+ fseek(f, 0, SEEK_SET);
+ }
+ exit(status);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DoMacro --
+ *
+ * This function is called to handle a macro invocation. It parses the
+ * arguments to the macro and generates a Tcl command to handle the
+ * invocation.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * A Tcl command is written to stdout.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DoMacro(
+ char *line) /* The line of text that contains the macro
+ * invocation. */
+{
+ char *p, *end;
+ int quote;
+
+ /*
+ * If there is no macro name, then just skip the whole line.
+ */
+
+ if ((line[1] == 0) || (isspace(line[1]))) {
+ return;
+ }
+
+ PRINT(("macro"));
+ if (*line != '.') {
+ PRINT(("2"));
+ }
+
+ /*
+ * Parse the arguments to the macro (including the name), in order.
+ */
+
+ p = line+1;
+ while (1) {
+ PRINTC(' ');
+ if (*p == '"') {
+ /*
+ * The argument is delimited by quotes.
+ */
+
+ for (end = p+1; *end != '"'; end++) {
+ if (*end == 0) {
+ fprintf(stderr,
+ "Unclosed quote in macro call on line %d.\n",
+ lineNumber);
+ status = 1;
+ break;
+ }
+ }
+ QuoteText(p+1, (end-(p+1)));
+ } else {
+ quote = 0;
+ for (end = p+1; (*end != 0) && (quote || !isspace(*end)); end++) {
+ if (*end == '\'') {
+ quote = !quote;
+ }
+ }
+ QuoteText(p, end-p);
+ }
+ if (*end == 0) {
+ break;
+ }
+ p = end+1;
+ while (isspace(*p)) {
+ /*
+ * Skip empty space before next argument.
+ */
+
+ p++;
+ }
+ if (*p == 0) {
+ break;
+ }
+ }
+ PRINTC('\n');
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DoText --
+ *
+ * This function is called to handle a line of troff text. It parses the
+ * text, generating Tcl commands for text and for formatting stuff such
+ * as font changes.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Tcl commands are written to stdout.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DoText(
+ char *line) /* The line of text. */
+{
+ char *p, *end;
+
+ /*
+ * Divide the line up into pieces consisting of backslash sequences, tabs,
+ * and other text.
+ */
+
+ p = line;
+ while (*p != 0) {
+ if (*p == '\t') {
+ PRINT(("tab\n"));
+ p++;
+ } else if (*p != '\\') {
+ /*
+ * Ordinary text.
+ */
+
+ for (end = p+1; (*end != '\\') && (*end != 0); end++) {
+ /* Empty loop body. */
+ }
+ PRINT(("text "));
+ QuoteText(p, end-p);
+ PRINTC('\n');
+ p = end;
+ } else {
+ /*
+ * A backslash sequence. There are particular ones that we
+ * understand; output an error message for anything else and just
+ * ignore the backslash.
+ */
+
+ p++;
+ if (*p == 'f') {
+ /*
+ * Font change.
+ */
+
+ PRINT(("font %c\n", p[1]));
+ p += 2;
+ } else if (*p == '-') {
+ PRINT(("dash\n"));
+ p++;
+ } else if (*p == 'e') {
+ PRINT(("text \\\\\n"));
+ p++;
+ } else if (*p == '.') {
+ PRINT(("text .\n"));
+ p++;
+ } else if (*p == '&') {
+ p++;
+ } else if (*p == '0') {
+ PRINT(("text { }\n"));
+ p++;
+ } else if (*p == '(') {
+ if ((p[1] == 0) || (p[2] == 0)) {
+ fprintf(stderr, "Bad \\( sequence on line %d.\n",
+ lineNumber);
+ status = 1;
+ } else {
+ PRINT(("char {\\(%c%c}\n", p[1], p[2]));
+ p += 3;
+ }
+ } else if (*p == 'N' && *(p+1) == '\'') {
+ int ch;
+
+ p += 2;
+ sscanf(p,"%d",&ch);
+ PRINT(("text \\u%04x\n", ch));
+ while(*p&&*p!='\'') p++;
+ p++;
+ } else if (*p != 0) {
+ PRINT(("char {\\%c}\n", *p));
+ p++;
+ }
+ }
+ }
+ PRINT(("newline\n"));
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * QuoteText --
+ *
+ * Copy the "string" argument to stdout, adding quote characters around
+ * any special Tcl characters so that they'll just be treated as ordinary
+ * text.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Text is written to stdout.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+QuoteText(
+ char *string, /* The line of text. */
+ int count) /* Number of characters to write from
+ * string. */
+{
+ if (count == 0) {
+ PRINT(("{}"));
+ return;
+ }
+ for ( ; count > 0; string++, count--) {
+ switch (*string) {
+ case '\\':
+ if (*(string+1) == 'N' && *(string+2) == '\'') {
+ int ch;
+
+ string += 3;
+ count -= 3;
+ sscanf(string,"%d",&ch);
+ PRINT(("\\u%04x", ch));
+ while(count>0&&*string!='\'') {string++;count--;}
+ continue;
+ } else if (*(string+1) == '0') {
+ PRINT(("\\ "));
+ string++;
+ count--;
+ continue;
+ }
+ case '$': case '[': case '{': case ' ': case ';':
+ case '"': case '\t':
+ PRINTC('\\');
+ default:
+ PRINTC(*string);
+ }
+ }
+}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/tcl8.6/tools/mkdepend.tcl b/tcl8.6/tools/mkdepend.tcl
new file mode 100644
index 0000000..ecb2206
--- /dev/null
+++ b/tcl8.6/tools/mkdepend.tcl
@@ -0,0 +1,420 @@
+#==============================================================================
+#
+# mkdepend : generate dependency information from C/C++ files
+#
+# Copyright (c) 1998, Nat Pryce
+#
+# Permission is hereby granted, without written agreement and without
+# license or royalty fees, to use, copy, modify, and distribute this
+# software and its documentation for any purpose, provided that the
+# above copyright notice and the following two paragraphs appear in
+# all copies of this software.
+#
+# IN NO EVENT SHALL THE AUTHOR BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT,
+# SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF
+# THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE AUTHOR HAS BEEN ADVISED
+# OF THE POSSIBILITY OF SUCH DAMAGE.
+#
+# THE AUTHOR SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING, BUT NOT
+# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+# PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS"
+# BASIS, AND THE AUTHOR HAS NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT,
+# UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
+#==============================================================================
+#
+# Modified heavily by David Gravereaux <davygrvy@pobox.com> about 9/17/2006.
+# Original can be found @
+# http://web.archive.org/web/20070616205924/http://www.doc.ic.ac.uk/~np2/software/mkdepend.html
+#==============================================================================
+
+array set mode_data {}
+set mode_data(vc32) {cl -nologo -E}
+
+set source_extensions [list .c .cpp .cxx .cc]
+
+set excludes [list]
+if [info exists env(INCLUDE)] {
+ set rawExcludes [split [string trim $env(INCLUDE) ";"] ";"]
+ foreach exclude $rawExcludes {
+ lappend excludes [file normalize $exclude]
+ }
+}
+
+
+# openOutput --
+#
+# Opens the output file.
+#
+# Arguments:
+# file The file to open
+#
+# Results:
+# None.
+
+proc openOutput {file} {
+ global output
+ set output [open $file w]
+ puts $output "# Automatically generated at [clock format [clock seconds] -format "%Y-%m-%dT%H:%M:%S"] by [info script]\n"
+}
+
+# closeOutput --
+#
+# Closes output file.
+#
+# Arguments:
+# none
+#
+# Results:
+# None.
+
+proc closeOutput {} {
+ global output
+ if {[string match stdout $output] != 0} {
+ close $output
+ }
+}
+
+# readDepends --
+#
+# Read off CCP pipe for #line references.
+#
+# Arguments:
+# chan The pipe channel we are reading in.
+#
+# Results:
+# Raw dependency list pairs.
+
+proc readDepends {chan} {
+ set line ""
+ array set depends {}
+
+ while {[gets $chan line] != -1} {
+ if {[regexp {^#line [0-9]+ \"(.*)\"$} $line dummy fname] != 0} {
+ set fname [file normalize $fname]
+ if {![info exists target]} {
+ # this is ourself
+ set target $fname
+ puts stderr "processing [file tail $fname]"
+ } else {
+ # don't include ourselves as a dependency of ourself.
+ if {![string compare $fname $target]} {continue}
+ # store in an array so multiple occurances are not counted.
+ set depends($target|$fname) ""
+ }
+ }
+ }
+
+ set result {}
+ foreach n [array names depends] {
+ set pair [split $n "|"]
+ lappend result [list [lindex $pair 0] [lindex $pair 1]]
+ }
+
+ return $result
+}
+
+# writeDepends --
+#
+# Write the processed list out to the file.
+#
+# Arguments:
+# out The channel to write to.
+# depends The list of dependency pairs
+#
+# Results:
+# None.
+
+proc writeDepends {out depends} {
+ foreach pair $depends {
+ puts $out "[lindex $pair 0] : \\\n\t[join [lindex $pair 1] " \\\n\t"]"
+ }
+}
+
+# stringStartsWith --
+#
+# Compares second string to the beginning of the first.
+#
+# Arguments:
+# str The string to test the beginning of.
+# prefix The string to test against
+#
+# Results:
+# the result of the comparison.
+
+proc stringStartsWith {str prefix} {
+ set front [string range $str 0 [expr {[string length $prefix] - 1}]]
+ return [expr {[string compare [string tolower $prefix] \
+ [string tolower $front]] == 0}]
+}
+
+# filterExcludes --
+#
+# Remove non-project header files.
+#
+# Arguments:
+# depends List of dependency pairs.
+# excludes List of directories that should be removed
+#
+# Results:
+# the processed dependency list.
+
+proc filterExcludes {depends excludes} {
+ set filtered {}
+
+ foreach pair $depends {
+ set excluded 0
+ set file [lindex $pair 1]
+
+ foreach dir $excludes {
+ if [stringStartsWith $file $dir] {
+ set excluded 1
+ break;
+ }
+ }
+
+ if {!$excluded} {
+ lappend filtered $pair
+ }
+ }
+
+ return $filtered
+}
+
+# replacePrefix --
+#
+# Take the normalized search path and put back the
+# macro name for it.
+#
+# Arguments:
+# file filename.
+#
+# Results:
+# filename properly replaced with macro for it.
+
+proc replacePrefix {file} {
+ global srcPathList srcPathReplaceList
+
+ foreach was $srcPathList is $srcPathReplaceList {
+ regsub $was $file $is file
+ }
+ return $file
+}
+
+# rebaseFiles --
+#
+# Replaces normalized paths with original macro names.
+#
+# Arguments:
+# depends Dependency pair list.
+#
+# Results:
+# The processed dependency pair list.
+
+proc rebaseFiles {depends} {
+ set rebased {}
+ foreach pair $depends {
+ lappend rebased [list \
+ [replacePrefix [lindex $pair 0]] \
+ [replacePrefix [lindex $pair 1]]]
+
+ }
+ return $rebased
+}
+
+# compressDeps --
+#
+# Compresses same named tragets into one pair with
+# multiple deps.
+#
+# Arguments:
+# depends Dependency pair list.
+#
+# Results:
+# The processed list.
+
+proc compressDeps {depends} {
+ array set compressed [list]
+
+ foreach pair $depends {
+ lappend compressed([lindex $pair 0]) [lindex $pair 1]
+ }
+
+ set result [list]
+ foreach n [array names compressed] {
+ lappend result [list $n [lsort $compressed($n)]]
+ }
+
+ return $result
+}
+
+# addSearchPath --
+#
+# Adds a new set of path and replacement string to the global list.
+#
+# Arguments:
+# newPathInfo comma seperated path and replacement string
+#
+# Results:
+# None.
+
+proc addSearchPath {newPathInfo} {
+ global srcPathList srcPathReplaceList
+
+ set infoList [split $newPathInfo ,]
+ lappend srcPathList [file normalize [lindex $infoList 0]]
+ lappend srcPathReplaceList [lindex $infoList 1]
+}
+
+
+# displayUsage --
+#
+# Displays usage to stderr
+#
+# Arguments:
+# none.
+#
+# Results:
+# None.
+
+proc displayUsage {} {
+ puts stderr "mkdepend.tcl \[options\] genericDir,macroName compatDir,macroName platformDir,macroName"
+}
+
+# readInputListFile --
+#
+# Open and read the object file list.
+#
+# Arguments:
+# objectListFile - name of the file to open.
+#
+# Results:
+# None.
+
+proc readInputListFile {objectListFile} {
+ global srcFileList srcPathList source_extensions
+ set f [open $objectListFile r]
+ set fl [read $f]
+ close $f
+
+ # fix native path seperator so it isn't treated as an escape.
+ regsub -all {\\} $fl {/} fl
+
+ # Treat the string as a list so filenames between double quotes are
+ # treated as list elements.
+ foreach fname $fl {
+ # Compiled .res resource files should be ignored.
+ if {[file extension $fname] ne ".obj"} {continue}
+
+ # Just filename without path or extension because the path is
+ # the build directory, not where the source files are located.
+ set baseName [file rootname [file tail $fname]]
+
+ set found 0
+ foreach path $srcPathList {
+ foreach ext $source_extensions {
+ set test [file join $path ${baseName}${ext}]
+ if {[file exist $test]} {
+ lappend srcFileList $test
+ set found 1
+ break
+ }
+ }
+ if {$found} break
+ }
+ }
+}
+
+# main --
+#
+# The main procedure of this script.
+#
+# Arguments:
+# none.
+#
+# Results:
+# None.
+
+proc main {} {
+ global argc argv mode mode_data srcFileList srcPathList excludes
+ global remove_prefix target_prefix output env
+
+ set srcPathList [list]
+ set srcFileList [list]
+
+ if {$argc == 1} {displayUsage}
+
+ # Parse mkdepend input
+ for {set i 0} {$i < [llength $argv]} {incr i} {
+ switch -glob -- [set arg [lindex $argv $i]] {
+ -vc32 {
+ set mode vc32
+ }
+ -bc32 {
+ set mode bc32
+ }
+ -wc32 {
+ set mode wc32
+ }
+ -lc32 {
+ set mode lc32
+ }
+ -mgw32 {
+ set mode mgw32
+ }
+ -passthru:* {
+ set passthru [string range $arg 10 end]
+ regsub -all {"} $passthru {\"} passthru
+ regsub -all {\\} $passthru {/} passthru
+ }
+ -out:* {
+ openOutput [string range $arg 5 end]
+ }
+ @* {
+ set objfile [string range $arg 1 end]
+ regsub -all {\\} $objfile {/} objfile
+ readInputListFile $objfile
+ }
+ -? - -help - --help {
+ displayUsage
+ exit 1
+ }
+ default {
+ if {![info exist mode]} {
+ puts stderr "mode not set"
+ displayUsage
+ }
+ addSearchPath $arg
+ }
+ }
+ }
+
+ # Execute the CPP command and parse output
+
+ foreach srcFile $srcFileList {
+ if {[catch {
+ set command "$mode_data($mode) $passthru \"$srcFile\""
+ set input [open |$command r]
+ set depends [readDepends $input]
+ set status [catch {close $input} result]
+ if {$status == 1 && [lindex $::errorCode 0] eq "CHILDSTATUS"} {
+ foreach { - pid code } $::errorCode break
+ if {$code == 2} {
+ # preprocessor died a cruel death.
+ error $result
+ }
+ }
+ } err]} {
+ puts stderr "error ocurred: $err\n"
+ continue
+ }
+ set depends [filterExcludes $depends $excludes]
+ set depends [rebaseFiles $depends]
+ set depends [compressDeps $depends]
+ writeDepends $output $depends
+ }
+
+ closeOutput
+}
+
+# kick it up.
+main
diff --git a/tcl8.6/tools/regexpTestLib.tcl b/tcl8.6/tools/regexpTestLib.tcl
new file mode 100644
index 0000000..d84a012
--- /dev/null
+++ b/tcl8.6/tools/regexpTestLib.tcl
@@ -0,0 +1,263 @@
+# regexpTestLib.tcl --
+#
+# This file contains tcl procedures used by spencer2testregexp.tcl and
+# spencer2regexp.tcl, which are programs written to convert Henry
+# Spencer's test suite to tcl test files.
+#
+# Copyright (c) 1996 by Sun Microsystems, Inc.
+
+proc readInputFile {} {
+ global inFileName
+ global lineArray
+
+ set fileId [open $inFileName r]
+
+ set i 0
+ while {[gets $fileId line] >= 0} {
+
+ set len [string length $line]
+
+ if {($len > 0) && ([string index $line [expr $len - 1]] == "\\")} {
+ if {[info exists lineArray(c$i)] == 0} {
+ set lineArray(c$i) 1
+ } else {
+ incr lineArray(c$i)
+ }
+ set line [string range $line 0 [expr $len - 2]]
+ append lineArray($i) $line
+ continue
+ }
+ if {[info exists lineArray(c$i)] == 0} {
+ set lineArray(c$i) 1
+ } else {
+ incr lineArray(c$i)
+ }
+ append lineArray($i) $line
+ incr i
+ }
+
+ close $fileId
+ return $i
+}
+
+#
+# strings with embedded @'s are truncated
+# unpreceeded @'s are replaced by {}
+#
+proc removeAts {ls} {
+ set len [llength $ls]
+ set newLs {}
+ foreach item $ls {
+ regsub @.* $item "" newItem
+ lappend newLs $newItem
+ }
+ return $newLs
+}
+
+proc convertErrCode {code} {
+
+ set errMsg "couldn't compile regular expression pattern:"
+
+ if {[string compare $code "INVARG"] == 0} {
+ return "$errMsg invalid argument to regex routine"
+ } elseif {[string compare $code "BADRPT"] == 0} {
+ return "$errMsg ?+* follows nothing"
+ } elseif {[string compare $code "BADBR"] == 0} {
+ return "$errMsg invalid repetition count(s)"
+ } elseif {[string compare $code "BADOPT"] == 0} {
+ return "$errMsg invalid embedded option"
+ } elseif {[string compare $code "EPAREN"] == 0} {
+ return "$errMsg unmatched ()"
+ } elseif {[string compare $code "EBRACE"] == 0} {
+ return "$errMsg unmatched {}"
+ } elseif {[string compare $code "EBRACK"] == 0} {
+ return "$errMsg unmatched \[\]"
+ } elseif {[string compare $code "ERANGE"] == 0} {
+ return "$errMsg invalid character range"
+ } elseif {[string compare $code "ECTYPE"] == 0} {
+ return "$errMsg invalid character class"
+ } elseif {[string compare $code "ECOLLATE"] == 0} {
+ return "$errMsg invalid collating element"
+ } elseif {[string compare $code "EESCAPE"] == 0} {
+ return "$errMsg invalid escape sequence"
+ } elseif {[string compare $code "BADPAT"] == 0} {
+ return "$errMsg invalid regular expression"
+ } elseif {[string compare $code "ESUBREG"] == 0} {
+ return "$errMsg invalid backreference number"
+ } elseif {[string compare $code "IMPOSS"] == 0} {
+ return "$errMsg can never match"
+ }
+ return "$errMsg $code"
+}
+
+proc writeOutputFile {numLines fcn} {
+ global outFileName
+ global lineArray
+
+ # open output file and write file header info to it.
+
+ set fileId [open $outFileName w]
+
+ puts $fileId "# Commands covered: $fcn"
+ puts $fileId "#"
+ puts $fileId "# This Tcl-generated file contains tests for the $fcn tcl command."
+ puts $fileId "# Sourcing this file into Tcl runs the tests and generates output for"
+ puts $fileId "# errors. No output means no errors were found. Setting VERBOSE to"
+ puts $fileId "# -1 will run tests that are known to fail."
+ puts $fileId "#"
+ puts $fileId "# Copyright (c) 1998 Sun Microsystems, Inc."
+ puts $fileId "#"
+ puts $fileId "# See the file \"license.terms\" for information on usage and redistribution"
+ puts $fileId "# of this file, and for a DISCLAIMER OF ALL WARRANTIES."
+ puts $fileId "#"
+ puts $fileId "\# SCCS: \%Z\% \%M\% \%I\% \%E\% \%U\%"
+ puts $fileId "\nproc print \{arg\} \{puts \$arg\}\n"
+ puts $fileId "if \{\[string compare test \[info procs test\]\] == 1\} \{"
+ puts $fileId " source defs ; set VERBOSE -1\n\}\n"
+ puts $fileId "if \{\$VERBOSE != -1\} \{"
+ puts $fileId " proc print \{arg\} \{\}\n\}\n"
+ puts $fileId "#"
+ puts $fileId "# The remainder of this file is Tcl tests that have been"
+ puts $fileId "# converted from Henry Spencer's regexp test suite."
+ puts $fileId "#\n"
+
+ set lineNum 0
+ set srcLineNum 1
+ while {$lineNum < $numLines} {
+
+ set currentLine $lineArray($lineNum)
+
+ # copy comment string to output file and continue
+
+ if {[string index $currentLine 0] == "#"} {
+ puts $fileId $currentLine
+ incr srcLineNum $lineArray(c$lineNum)
+ incr lineNum
+ continue
+ }
+
+ set len [llength $currentLine]
+
+ # copy empty string to output file and continue
+
+ if {$len == 0} {
+ puts $fileId "\n"
+ incr srcLineNum $lineArray(c$lineNum)
+ incr lineNum
+ continue
+ }
+ if {($len < 3)} {
+ puts "warning: test is too short --\n\t$currentLine"
+ incr srcLineNum $lineArray(c$lineNum)
+ incr lineNum
+ continue
+ }
+
+ puts $fileId [convertTestLine $currentLine $len $lineNum $srcLineNum]
+
+ incr srcLineNum $lineArray(c$lineNum)
+ incr lineNum
+ }
+
+ close $fileId
+}
+
+proc convertTestLine {currentLine len lineNum srcLineNum} {
+
+ regsub -all {(?b)\\} $currentLine {\\\\} currentLine
+ set re [lindex $currentLine 0]
+ set flags [lindex $currentLine 1]
+ set str [lindex $currentLine 2]
+
+ # based on flags, decide whether to skip the test
+
+ if {[findSkipFlag $flags]} {
+ regsub -all {\[|\]|\(|\)|\{|\}|\#} $currentLine {\&} line
+ set msg "\# skipping char mapping test from line $srcLineNum\n"
+ append msg "print \{... skip test from line $srcLineNum: $line\}"
+ return $msg
+ }
+
+ # perform mapping if '=' flag exists
+
+ set noBraces 0
+ if {[regexp {=|>} $flags] == 1} {
+ regsub -all {_} $currentLine {\\ } currentLine
+ regsub -all {A} $currentLine {\\007} currentLine
+ regsub -all {B} $currentLine {\\b} currentLine
+ regsub -all {E} $currentLine {\\033} currentLine
+ regsub -all {F} $currentLine {\\f} currentLine
+ regsub -all {N} $currentLine {\\n} currentLine
+
+ # if and \r substitutions are made, do not wrap re, flags,
+ # str, and result in braces
+
+ set noBraces [regsub -all {R} $currentLine {\\\u000D} currentLine]
+ regsub -all {T} $currentLine {\\t} currentLine
+ regsub -all {V} $currentLine {\\v} currentLine
+ if {[regexp {=} $flags] == 1} {
+ set re [lindex $currentLine 0]
+ }
+ set str [lindex $currentLine 2]
+ }
+ set flags [removeFlags $flags]
+
+ # find the test result
+
+ set numVars [expr $len - 3]
+ set vars {}
+ set vals {}
+ set result 0
+ set v 0
+
+ if {[regsub {\*} "$flags" "" newFlags] == 1} {
+ # an error is expected
+
+ if {[string compare $str "EMPTY"] == 0} {
+ # empty regexp is not an error
+ # skip this test
+
+ return "\# skipping the empty-re test from line $srcLineNum\n"
+ }
+ set flags $newFlags
+ set result "\{1 \{[convertErrCode $str]\}\}"
+ } elseif {$numVars > 0} {
+ # at least 1 match is made
+
+ if {[regexp {s} $flags] == 1} {
+ set result "\{0 1\}"
+ } else {
+ while {$v < $numVars} {
+ append vars " var($v)"
+ append vals " \$var($v)"
+ incr v
+ }
+ set tmp [removeAts [lrange $currentLine 3 $len]]
+ set result "\{0 \{1 $tmp\}\}"
+ if {$noBraces} {
+ set result "\[subst $result\]"
+ }
+ }
+ } else {
+ # no match is made
+
+ set result "\{0 0\}"
+ }
+
+ # set up the test and write it to the output file
+
+ set cmd [prepareCmd $flags $re $str $vars $noBraces]
+ if {$cmd == -1} {
+ return "\# skipping test with metasyntax from line $srcLineNum\n"
+ }
+
+ set test "test regexp-1.$srcLineNum \{converted from line $srcLineNum\} \{\n"
+ append test "\tcatch {unset var}\n"
+ append test "\tlist \[catch \{\n"
+ append test "\t\tset match \[$cmd\]\n"
+ append test "\t\tlist \$match $vals\n"
+ append test "\t\} msg\] \$msg\n"
+ append test "\} $result\n"
+ return $test
+}
+
diff --git a/tcl8.6/tools/tcl.hpj.in b/tcl8.6/tools/tcl.hpj.in
new file mode 100644
index 0000000..a94cea6
--- /dev/null
+++ b/tcl8.6/tools/tcl.hpj.in
@@ -0,0 +1,19 @@
+; This file is maintained by HCW. Do not modify this file directly.
+
+[OPTIONS]
+HCW=0
+LCID=0x409 0x0 0x0 ;English (United States)
+REPORT=Yes
+TITLE=Tcl/Tk Reference Manual
+CNT=tcl86.cnt
+COPYRIGHT=Copyright © 2000 Ajuba Solutions
+HLP=tcl86.hlp
+
+[FILES]
+tcl.rtf
+
+[WINDOWS]
+main="Tcl/Tk Reference Manual",,0
+
+[CONFIG]
+BrowseButtons()
diff --git a/tcl8.6/tools/tclZIC.tcl b/tcl8.6/tools/tclZIC.tcl
new file mode 100755
index 0000000..85c9ba9
--- /dev/null
+++ b/tcl8.6/tools/tclZIC.tcl
@@ -0,0 +1,1373 @@
+#----------------------------------------------------------------------
+#
+# tclZIC.tcl --
+#
+# Take the time zone data source files from Arthur Olson's
+# repository at elsie.nci.nih.gov, and prepare time zone
+# information files for Tcl.
+#
+# Usage:
+# tclsh tclZIC.tcl inputDir outputDir
+#
+# Parameters:
+# inputDir - Directory (e.g., tzdata2003e) where Olson's source
+# files are to be found.
+# outputDir - Directory (e.g., ../library/tzdata) where
+# the time zone information files are to be placed.
+#
+# Results:
+# May produce error messages on the standard error. An exit
+# code of zero denotes success; any other exit code is failure.
+#
+# This program parses the timezone data in a means analogous to the
+# 'zic' command, and produces Tcl time zone information files suitable
+# for loading into the 'clock' namespace.
+#
+#----------------------------------------------------------------------
+#
+# Copyright (c) 2004 by 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.
+#----------------------------------------------------------------------
+
+# Define the names of the Olson files that we need to load.
+# We avoid the solar time files and the leap seconds.
+
+set olsonFiles {
+ africa antarctica asia australasia
+ backward etcetera europe northamerica
+ pacificnew southamerica systemv
+}
+
+# Define the year at which the DST information will stop.
+
+set maxyear 2100
+
+# Determine how big a wide integer is.
+
+set MAXWIDE [expr {wide(1)}]
+while 1 {
+ set next [expr {wide($MAXWIDE + $MAXWIDE + 1)}]
+ if {$next < 0} {
+ break
+ }
+ set MAXWIDE $next
+}
+set MINWIDE [expr {-$MAXWIDE-1}]
+
+#----------------------------------------------------------------------
+#
+# loadFiles --
+#
+# Loads the time zone files for each continent into memory
+#
+# Parameters:
+# dir - Directory where the time zone source files are found
+#
+# Results:
+# None.
+#
+# Side effects:
+# Calls 'loadZIC' for each continent's data file in turn.
+# Reports progress on stdout.
+#
+#----------------------------------------------------------------------
+
+proc loadFiles {dir} {
+ variable olsonFiles
+ foreach file $olsonFiles {
+ puts "loading: [file join $dir $file]"
+ loadZIC [file join $dir $file]
+ }
+ return
+}
+
+#----------------------------------------------------------------------
+#
+# checkForwardRuleRefs --
+#
+# Checks to make sure that all references to Daylight Saving
+# Time rules designate defined rules.
+#
+# Parameters:
+# None.
+#
+# Results:
+# None.
+#
+# Side effects:
+# Produces an error message and increases the error count if
+# any undefined rules are present.
+#
+#----------------------------------------------------------------------
+
+proc checkForwardRuleRefs {} {
+ variable forwardRuleRefs
+ variable rules
+
+ foreach {rule where} [array get forwardRuleRefs] {
+ if {![info exists rules($rule)]} {
+ foreach {fileName lno} $where {
+ puts stderr "$fileName:$lno:can't locate rule \"$rule\""
+ incr errorCount
+ }
+ }
+ }
+}
+
+#----------------------------------------------------------------------
+#
+# loadZIC --
+#
+# Load one continent's data into memory.
+#
+# Parameters:
+# fileName -- Name of the time zone source file.
+#
+# Results:
+# None.
+#
+# Side effects:
+# The global variable, 'errorCount' counts the number of errors.
+# The global array, 'links', contains a distillation of the
+# 'Link' directives in the file. The keys are 'links to' and
+# the values are 'links from'. The 'parseRule' and 'parseZone'
+# procedures are called to handle 'Rule' and 'Zone' directives.
+#
+#----------------------------------------------------------------------
+
+proc loadZIC {fileName} {
+ variable errorCount
+ variable links
+
+ # Suck the text into memory.
+
+ set f [open $fileName r]
+ set data [read $f]
+ close $f
+
+ # Break the input into lines, and count line numbers.
+
+ set lno 0
+ foreach line [split $data \n] {
+ incr lno
+
+ # Break a line of input into words.
+
+ regsub {\s*(\#.*)?$} $line {} line
+ if {$line eq ""} {
+ continue
+ }
+ set words {}
+ if {[regexp {^\s} $line]} {
+ # Detect continuations of a zone and flag the list appropriately
+ lappend words ""
+ }
+ lappend words {*}[regexp -all -inline {\S+} $line]
+
+ # Switch on the directive
+
+ switch -exact -- [lindex $words 0] {
+ Rule {
+ parseRule $fileName $lno $words
+ }
+ Link {
+ set links([lindex $words 2]) [lindex $words 1]
+ }
+ Zone {
+ set lastZone [lindex $words 1]
+ set until [parseZone $fileName $lno \
+ $lastZone [lrange $words 2 end] "minimum"]
+ }
+ {} {
+ set i 0
+ foreach word $words {
+ if {[lindex $words $i] ne ""} {
+ break
+ }
+ incr i
+ }
+ set words [lrange $words $i end]
+ set until [parseZone $fileName $lno $lastZone $words $until]
+ }
+ default {
+ incr errorCount
+ puts stderr "$fileName:$lno:unknown line type \"[lindex $words 0]\""
+ }
+ }
+ }
+
+ return
+}
+
+#----------------------------------------------------------------------
+#
+# parseRule --
+#
+# Parses a Rule directive in an Olson file.
+#
+# Parameters:
+# fileName -- Name of the file being parsed.
+# lno - Line number within the file
+# words - The line itself, broken into words.
+#
+# Results:
+# None.
+#
+# Side effects:
+# The rule is analyzed and added to the 'rules' array.
+# Errors are reported and counted.
+#
+#----------------------------------------------------------------------
+
+proc parseRule {fileName lno words} {
+ variable rules
+ variable errorCount
+
+ # Break out the columns
+
+ lassign $words Rule name from to type in on at save letter
+
+ # Handle the 'only' keyword
+
+ if {$to eq "only"} {
+ set to $from
+ }
+
+ # Process the start year
+
+ if {![string is integer $from]} {
+ if {![string equal -length [string length $from] $from "minimum"]} {
+ puts stderr "$fileName:$lno:FROM field \"$from\" not an integer."
+ incr errorCount
+ return
+ } else {
+ set from "minimum"
+ }
+ }
+
+ # Process the end year
+
+ if {![string is integer $to]} {
+ if {![string equal -length [string length $to] $to "maximum"]} {
+ puts stderr "$fileName:$lno:TO field \"$to\" not an integer."
+ incr errorCount
+ return
+ } else {
+ set to "maximum"
+ }
+ }
+
+ # Process the type of year in which the rule applies
+
+ if {$type ne "-"} {
+ puts stderr "$fileName:$lno:year types are not yet supported."
+ incr errorCount
+ return
+ }
+
+ # Process the month in which the rule starts
+
+ if {[catch {lookupMonth $in} in]} {
+ puts stderr "$fileName:$lno:$in"
+ incr errorCount
+ return
+ }
+
+ # Process the day of the month on which the rule starts
+
+ if {[catch {parseON $on} on]} {
+ puts stderr "$fileName:$lno:$on"
+ incr errorCount
+ return
+ }
+
+ # Process the time of day on which the rule starts
+
+ if {[catch {parseTOD $at} at]} {
+ puts stderr "$fileName:$lno:$at"
+ incr errorCount
+ return
+ }
+
+ # Process the DST adder
+
+ if {[catch {parseOffsetTime $save} save]} {
+ puts stderr "$fileName:$lno:$save"
+ incr errorCount
+ return
+ }
+
+ # Process the letter to use for summer time
+
+ if {$letter eq "-"} {
+ set letter ""
+ }
+
+ # Accumulate all the data.
+
+ lappend rules($name) $from $to $type $in $on $at $save $letter
+ return
+
+}
+
+#----------------------------------------------------------------------
+#
+# parseON --
+#
+# Parse a specification for a day of the month
+#
+# Parameters:
+# on - the ON field from a line in an Olson file.
+#
+# Results:
+# Returns a partial Tcl command. When the year and number of the
+# month are appended, the command will return the Julian Day Number
+# of the desired date.
+#
+# Side effects:
+# None.
+#
+# The specification can be:
+# - a simple number, which designates a constant date.
+# - The name of a weekday, followed by >= or <=, followed by a number.
+# This designates the nearest occurrence of the given weekday on
+# or before (on or after) the given day of the month.
+# - The word 'last' followed by a weekday name with no intervening
+# space. This designates the last occurrence of the given weekday
+# in the month.
+#
+#----------------------------------------------------------------------
+
+proc parseON {on} {
+ if {![regexp -expanded {
+ ^(?:
+ # first possibility - simple number - field 1
+ ([[:digit:]]+)
+ |
+ # second possibility - weekday >= (or <=) number
+ # field 2 - weekday
+ ([[:alpha:]]+)
+ # field 3 - direction
+ ([<>]=)
+ # field 4 - number
+ ([[:digit:]]+)
+ |
+ # third possibility - lastWeekday - field 5
+ last([[:alpha:]]+)
+ )$
+ } $on -> dom1 wday2 dir2 num2 wday3]} {
+ error "can't parse ON field \"$on\""
+ }
+ if {$dom1 ne ""} {
+ return [list onDayOfMonth $dom1]
+ } elseif {$wday2 ne ""} {
+ set wday2 [lookupDayOfWeek $wday2]
+ return [list onWeekdayInMonth $wday2 $dir2 $num2]
+ } elseif {$wday3 ne ""} {
+ set wday3 [lookupDayOfWeek $wday3]
+ return [list onLastWeekdayInMonth $wday3]
+ } else {
+ error "in parseOn \"$on\": can't happen"
+ }
+}
+
+#----------------------------------------------------------------------
+#
+# onDayOfMonth --
+#
+# Find a given day of a given month
+#
+# Parameters:
+# day - Day of the month
+# year - Gregorian year
+# month - Number of the month (1-12)
+#
+# Results:
+# Returns the Julian Day Number of the desired day.
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc onDayOfMonth {day year month} {
+ scan $day %d day
+ scan $year %d year
+ scan $month %d month
+ set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \
+ [dict create era CE year $year month $month dayOfMonth $day] \
+ 2361222]
+ return [dict get $date julianDay]
+}
+
+#----------------------------------------------------------------------
+#
+# onWeekdayInMonth --
+#
+# Find the weekday falling on or after (on or before) a
+# given day of the month
+#
+# Parameters:
+# dayOfWeek - Day of the week (Monday=1, Sunday=7)
+# relation - <= for the weekday on or before a given date, >= for
+# the weekday on or after the given date.
+# dayOfMonth - Day of the month
+# year - Gregorian year
+# month - Number of the month (1-12)
+#
+# Results:
+# Returns the Juloan Day Number of the desired day.
+#
+# Side effects:
+# None.
+#
+# onWeekdayInMonth is used to compute Daylight Saving Time rules
+# like 'Sun>=1' (for the nearest Sunday on or after the first of the month)
+# or "Mon<=4' (for the Monday on or before the fourth of the month).
+#
+#----------------------------------------------------------------------
+
+proc onWeekdayInMonth {dayOfWeek relation dayOfMonth year month} {
+ set date [::tcl::clock::GetJulianDayFromEraYearMonthDay [dict create \
+ era CE year $year month $month dayOfMonth $dayOfMonth] 2361222]
+ switch -exact -- $relation {
+ <= {
+ return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \
+ [dict get $date julianDay]]
+ }
+ >= {
+ return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \
+ [expr {[dict get $date julianDay] + 6}]]
+ }
+ }
+}
+
+#----------------------------------------------------------------------
+#
+# onLastWeekdayInMonth --
+#
+# Find the last instance of a given weekday in a month.
+#
+# Parameters:
+# dayOfWeek - Weekday to find (Monday=1, Sunday=7)
+# year - Gregorian year
+# month - Month (1-12)
+#
+# Results:
+# Returns the Julian Day number of the last instance of
+# the given weekday in the given month
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc onLastWeekdayInMonth {dayOfWeek year month} {
+ incr month
+ # Find day 0 of the following month, which is the last day of
+ # the current month. Yes, it works to ask for day 0 of month 13!
+ set date [::tcl::clock::GetJulianDayFromEraYearMonthDay [dict create \
+ era CE year $year month $month dayOfMonth 0] 2361222]
+ return [::tcl::clock::WeekdayOnOrBefore $dayOfWeek \
+ [dict get $date julianDay]]
+}
+
+#----------------------------------------------------------------------
+#
+# parseTOD --
+#
+# Parses the specification of a time of day in an Olson file.
+#
+# Parameters:
+# tod - Time of day, which may be followed by 'w', 's', 'u', 'g'
+# or 'z'. 'w' (or no letter) designates a wall clock time,
+# 's' designates Standard Time in the given zone, and
+# 'u', 'g', and 'z' all designate UTC.
+#
+# Results:
+# Returns a two element list containing a count of seconds from
+# midnight and the letter that followed the time.
+#
+# Side effects:
+# Reports and counts an error if the time cannot be parsed.
+#
+#----------------------------------------------------------------------
+
+proc parseTOD {tod} {
+ if {![regexp -expanded {
+ ^
+ ([[:digit:]]{1,2}) # field 1 - hour
+ (?:
+ :([[:digit:]]{2}) # field 2 - minute
+ (?:
+ :([[:digit:]]{2}) # field 3 - second
+ )?
+ )?
+ (?:
+ ([wsugz]) # field 4 - type indicator
+ )?
+ } $tod -> hour minute second ind]} {
+ puts stderr "$fileName:$lno:can't parse time field \"$tod\""
+ incr errorCount
+ }
+ scan $hour %d hour
+ if {$minute ne ""} {
+ scan $minute %d minute
+ } else {
+ set minute 0
+ }
+ if {$second ne ""} {
+ scan $second %d second
+ } else {
+ set second 0
+ }
+ if {$ind eq ""} {
+ set ind w
+ }
+ return [list [expr {($hour * 60 + $minute) * 60 + $second}] $ind]
+}
+
+#----------------------------------------------------------------------
+#
+# parseOffsetTime --
+#
+# Parses the specification of an offset time in an Olson file.
+#
+# Parameters:
+# offset - Offset time as [+-]hh:mm:ss
+#
+# Results:
+# Returns the offset time as a count of seconds.
+#
+# Side effects:
+# Reports and counts an error if the time cannot be parsed.
+#
+#----------------------------------------------------------------------
+
+proc parseOffsetTime {offset} {
+ if {![regexp -expanded {
+ ^
+ ([-+])? # field 1 - signum
+ ([[:digit:]]{1,2}) # field 2 - hour
+ (?:
+ :([[:digit:]]{2}) # field 3 - minute
+ (?:
+ :([[:digit:]]{2}) # field 4 - second
+ )?
+ )?
+ } $offset -> signum hour minute second]} {
+ puts stderr "$fileName:$lno:can't parse offset time \"$offset\""
+ incr errorCount
+ }
+ append signum 1
+ scan $hour %d hour
+ if {$minute ne ""} {
+ scan $minute %d minute
+ } else {
+ set minute 0
+ }
+ if {$second ne ""} {
+ scan $second %d second
+ } else {
+ set second 0
+ }
+ return [expr {(($hour * 60 + $minute) * 60 + $second) * $signum}]
+
+}
+
+#----------------------------------------------------------------------
+#
+# lookupMonth -
+# Looks up a month by name
+#
+# Parameters:
+# month - Name of a month.
+#
+# Results:
+# Returns the number of the month.
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc lookupMonth {month} {
+ set indx [lsearch -regexp {
+ {} January February March April May June
+ July August September October November December
+ } ${month}.*]
+ if {$indx < 1} {
+ error "unknown month name \"$month\""
+ }
+ return $indx
+}
+
+#----------------------------------------------------------------------
+#
+# lookupDayOfWeek --
+#
+# Looks up the name of a weekday.
+#
+# Parameters:
+# wday - Weekday name (or a unique prefix).
+#
+# Results:
+# Returns the weekday number (Monday=1, Sunday=7)
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc lookupDayOfWeek {wday} {
+ set indx [lsearch -regexp {
+ {} Monday Tuesday Wednesday Thursday Friday Saturday Sunday
+ } ${wday}.*]
+ if {$indx < 1} {
+ error "unknown weekday name \"$wday\""
+ }
+ return $indx
+}
+
+#----------------------------------------------------------------------
+#
+# parseZone --
+#
+# Parses a Zone directive in an Olson file
+#
+# Parameters:
+# fileName -- Name of the file being parsed.
+# lno -- Line number within the file.
+# zone -- Name of the time zone
+# words -- Remaining words on the line.
+# start -- 'Until' time from the previous line if this is a
+# continuation line, or 'minimum' if this is the first line.
+#
+# Results:
+# Returns the 'until' field of the current line
+#
+# Side effects:
+# Stores a row in the 'zones' array describing the current zone.
+# The row consists of a start time (year month day tod), a Standard
+# Time offset from Greenwich, a Daylight Saving Time offset from
+# Standard Time, and a format for printing the time zone.
+#
+# The start time is the result of an earlier call to 'parseUntil'
+# or else the keyword 'minimum'. The GMT offset is the
+# result of a call to 'parseOffsetTime'. The Daylight Saving
+# Time offset is represented as a partial Tcl command. To the
+# command will be appended a start time (seconds from epoch)
+# the current offset of Standard Time from Greenwich, the current
+# offset of Daylight Saving Time from Greenwich, the default
+# offset from this line, the name pattern from this line,
+# the 'until' field from this line, and a variable name where points
+# are to be stored. This command is implemented by the 'applyNoRule',
+# 'applyDSTOffset' and 'applyRules' procedures.
+#
+#----------------------------------------------------------------------
+
+proc parseZone {fileName lno zone words start} {
+ variable zones
+ variable rules
+ variable errorCount
+ variable forwardRuleRefs
+
+ lassign $words gmtoff save format
+ if {[catch {parseOffsetTime $gmtoff} gmtoff]} {
+ puts stderr "$fileName:$lno:$gmtoff"
+ incr errorCount
+ return
+ }
+ if {[info exists rules($save)]} {
+ set save [list applyRules $save]
+ } elseif {$save eq "-"} {
+ set save [list applyNoRule]
+ } elseif {[catch {parseOffsetTime $save} save2]} {
+ lappend forwardRuleRefs($save) $fileName $lno
+ set save [list applyRules $save]
+ } else {
+ set save [list applyDSTOffset $save2]
+ }
+ lappend zones($zone) $start $gmtoff $save $format
+ if {[llength $words] >= 4} {
+ return [parseUntil [lrange $words 3 end]]
+ } else {
+ return {}
+ }
+}
+
+#----------------------------------------------------------------------
+#
+# parseUntil --
+#
+# Parses the 'UNTIL' part of a 'Zone' directive.
+#
+# Parameters:
+# words - The 'UNTIL' part of the directie.
+#
+# Results:
+# Returns a list comprising the year, the month, the day, and
+# the time of day. Time of day is represented as the result of
+# 'parseTOD'.
+#
+#----------------------------------------------------------------------
+
+proc parseUntil {words} {
+ variable firstYear
+
+ if {[llength $words] >= 1} {
+ set year [lindex $words 0]
+ if {![string is integer $year]} {
+ error "can't parse UNTIL field \"$words\""
+ }
+ if {![info exists firstYear] || $year < $firstYear} {
+ set firstYear $year
+ }
+ } else {
+ set year "maximum"
+ }
+ if {[llength $words] >= 2} {
+ set month [lookupMonth [lindex $words 1]]
+ } else {
+ set month 1
+ }
+ if {[llength $words] >= 3} {
+ set day [parseON [lindex $words 2]]
+ } else {
+ set day {onDayOfMonth 1}
+ }
+ if {[llength $words] >= 4} {
+ set tod [parseTOD [lindex $words 3]]
+ } else {
+ set tod {0 w}
+ }
+ return [list $year $month $day $tod]
+}
+
+#----------------------------------------------------------------------
+#
+# applyNoRule --
+#
+# Generates time zone data for a zone without Daylight Saving
+# Time.
+#
+# Parameters:
+# year - Year in which the rule applies
+# startSecs - Time at which the rule starts.
+# stdGMTOffset - Offset from Greenwich prior to the start of the
+# rule
+# DSTOffset - Offset of Daylight from Standard prior to the
+# start of the rule.
+# nextGMTOffset - Offset from Greenwich when the rule is in effect.
+# namePattern - Name of the timezone.
+# until - Time at which the rule expires.
+# pointsVar - Name of a variable in callers scope that receives
+# transition times
+#
+# Results:
+# Returns a two element list comprising 'nextGMTOffset' and
+# 0 - the zero indicates that Daylight Saving Time is not
+# in effect.
+#
+# Side effects:
+# Appends a row to the 'points' variable comprising the start time,
+# the offset from GMT, a zero (indicating that DST is not in effect),
+# and the name of the time zone.
+#
+#----------------------------------------------------------------------
+
+proc applyNoRule {year startSecs stdGMTOffset DSTOffset nextGMTOffset
+ namePattern until pointsVar} {
+ upvar 1 $pointsVar points
+ lappend points $startSecs $nextGMTOffset 0 \
+ [convertNamePattern $namePattern -]
+ return [list $nextGMTOffset 0]
+}
+
+#----------------------------------------------------------------------
+#
+# applyDSTOffset --
+#
+# Generates time zone data for a zone with permanent Daylight
+# Saving Time.
+#
+# Parameters:
+# nextDSTOffset - Offset of Daylight from Standard while the
+# rule is in effect.
+# year - Year in which the rule applies
+# startSecs - Time at which the rule starts.
+# stdGMTOffset - Offset from Greenwich prior to the start of the
+# rule
+# DSTOffset - Offset of Daylight from Standard prior to the
+# start of the rule.
+# nextGMTOffset - Offset from Greenwich when the rule is in effect.
+# namePattern - Name of the timezone.
+# until - Time at which the rule expires.
+# pointsVar - Name of a variable in callers scope that receives
+# transition times
+#
+# Results:
+# Returns a two element list comprising 'nextGMTOffset' and
+# 'nextDSTOffset'.
+#
+# Side effects:
+# Appends a row to the 'points' variable comprising the start time,
+# the offset from GMT, a one (indicating that DST is in effect),
+# and the name of the time zone.
+#
+#----------------------------------------------------------------------
+
+proc applyDSTOffset {nextDSTOffset year startSecs
+ stdGMTOffset DSTOffset nextGMTOffset
+ namePattern until pointsVar} {
+ upvar 1 $pointsVar points
+ lappend points \
+ $startSecs \
+ [expr {$nextGMTOffset + $nextDSTOffset}] \
+ 1 \
+ [convertNamePattern $namePattern S]
+ return [list $nextGMTOffset $nextDSTOffset]
+}
+
+#----------------------------------------------------------------------
+#
+# applyRules --
+#
+# Applies a rule set to a time zone for a given range of time
+#
+# Parameters:
+# ruleSet - Name of the rule set to apply
+# year - Starting year for the rules
+# startSecs - Time at which the rules begin to apply
+# stdGMTOffset - Offset from Greenwich prior to the start of the
+# rules.
+# DSTOffset - Offset of Daylight from Standard prior to the
+# start of the rules.
+# nextGMTOffset - Offset from Greenwich when the rules are in effect.
+# namePattern - Name pattern for the time zone.
+# until - Time at which the rule set expires.
+# pointsVar - Name of a variable in callers scope that receives
+# transition times
+#
+# Results:
+# Returns a two element list comprising the offset from GMT
+# to Standard and the offset from Standard to Daylight (if DST
+# is in effect) at the end of the period in which the rules apply
+#
+# Side effects:
+# Appends one or more rows to the 'points' variable, each of which
+# comprises a transition time, the offset from GMT that is
+# in effect after the transition, a flag for whether DST is in
+# effect, and the name of the time zone.
+#
+#----------------------------------------------------------------------
+
+proc applyRules {ruleSet year startSecs stdGMTOffset DSTOffset nextGMTOffset
+ namePattern until pointsVar} {
+ variable done
+ variable rules
+ variable maxyear
+
+ upvar 1 $pointsVar points
+
+ # Extract the rules that apply to the current year, and the number
+ # of rules (now or in future) that will end at a specific year.
+ # Ignore rules entirely in the past.
+
+ lassign [divideRules $ruleSet $year] currentRules nSunsetRules
+
+ # If the first transition is later than $startSecs, and $stdGMTOffset is
+ # different from $nextGMTOffset, we will need an initial record like:
+ # lappend points $startSecs $stdGMTOffset 0 \
+ # [convertNamePattern $namePattern -]
+
+ set didTransitionIn false
+
+ # Determine the letter to use in Standard Time
+
+ set prevLetter ""
+ foreach {
+ fromYear toYear yearType monthIn daySpecOn timeAt save letter
+ } $rules($ruleSet) {
+ if {$save == 0} {
+ set prevLetter $letter
+ break
+ }
+ }
+
+ # Walk through each year in turn. This loop will break when
+ # (a) the 'until' time is passed
+ # or (b) the 'until' time is empty and all remaining rules extend to
+ # the end of time
+
+ set stdGMTOffset $nextGMTOffset
+
+ # convert "until" to seconds from epoch in current time zone
+
+ if {$until ne ""} {
+ lassign $until untilYear untilMonth untilDaySpec untilTimeOfDay
+ lappend untilDaySpec $untilYear $untilMonth
+ set untilJCD [eval $untilDaySpec]
+ set untilBaseSecs [expr {
+ wide(86400) * wide($untilJCD) - 210866803200 }]
+ set untilSecs [convertTimeOfDay $untilBaseSecs $stdGMTOffset \
+ $DSTOffset {*}$untilTimeOfDay]
+ }
+
+ set origStartSecs $startSecs
+
+ while {($until ne "" && $startSecs < $untilSecs)
+ || ($until eq "" && ($nSunsetRules > 0 || $year < $maxyear))} {
+ set remainingRules $currentRules
+ while {[llength $remainingRules] > 0} {
+
+ # Find the rule with the earliest start time from among the
+ # active rules that haven't yet been processed.
+
+ lassign [findEarliestRule $remainingRules $year \
+ $stdGMTOffset $DSTOffset] earliestSecs earliestIndex
+
+ set endi [expr {$earliestIndex + 7}]
+ set rule [lrange $remainingRules $earliestIndex $endi]
+ lassign $rule fromYear toYear \
+ yearType monthIn daySpecOn timeAt save letter
+
+ # Test if the rule is in effect.
+
+ if {
+ $earliestSecs > $startSecs &&
+ ($until eq "" || $earliestSecs < $untilSecs)
+ } {
+ # Test if the initial transition has been done.
+ # If not, do it now.
+
+ if {!$didTransitionIn && $earliestSecs > $origStartSecs} {
+ set nm [convertNamePattern $namePattern $prevLetter]
+ lappend points \
+ $origStartSecs \
+ [expr {$stdGMTOffset + $DSTOffset}] \
+ 0 \
+ $nm
+ set didTransitionIn true
+ }
+
+ # Add a row to 'points' for the rule
+
+ set nm [convertNamePattern $namePattern $letter]
+ lappend points \
+ $earliestSecs \
+ [expr {$stdGMTOffset + $save}] \
+ [expr {$save != 0}] \
+ $nm
+ }
+
+ # Remove the rule just applied from the queue
+
+ set remainingRules [lreplace \
+ $remainingRules[set remainingRules {}] \
+ $earliestIndex $endi]
+
+ # Update current DST offset and time zone letter
+
+ set DSTOffset $save
+ set prevLetter $letter
+
+ # Reconvert the 'until' time in the current zone.
+
+ if {$until ne ""} {
+ set untilSecs [convertTimeOfDay $untilBaseSecs \
+ $stdGMTOffset $DSTOffset {*}$untilTimeOfDay]
+ }
+ }
+
+ # Advance to the next year
+
+ incr year
+ set date [::tcl::clock::GetJulianDayFromEraYearMonthDay \
+ [dict create era CE year $year month 1 dayOfMonth 1] 2361222]
+ set startSecs [expr {
+ [dict get $date julianDay] * wide(86400) - 210866803200
+ - $stdGMTOffset - $DSTOffset
+ }]
+
+ # Get rules in effect in the new year.
+
+ lassign [divideRules $ruleSet $year] currentRules nSunsetRules
+ }
+
+ return [list $stdGMTOffset $DSTOffset]
+}
+
+#----------------------------------------------------------------------
+#
+# divideRules --
+# Determine what Daylight Saving Time rules may be in effect in
+# a given year.
+#
+# Parameters:
+# ruleSet - Set of rules from 'parseRule'
+# year - Year to test
+#
+# Results:
+# Returns a two element list comprising the subset of 'ruleSet'
+# that is in effect in the given year, and the count of rules
+# that expire in the future (as opposed to those that expire in
+# the past or not at all). If this count is zero, the rules do
+# not change in future years.
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc divideRules {ruleSet year} {
+ variable rules
+
+ set currentRules {}
+ set nSunsetRules 0
+
+ foreach {
+ fromYear toYear yearType monthIn daySpecOn timeAt save letter
+ } $rules($ruleSet) {
+ if {$toYear ne "maximum" && $year > $toYear} {
+ # ignore - rule is in the past
+ } else {
+ if {$fromYear eq "minimum" || $fromYear <= $year} {
+ lappend currentRules $fromYear $toYear $yearType $monthIn \
+ $daySpecOn $timeAt $save $letter
+ }
+ if {$toYear ne "maximum"} {
+ incr nSunsetRules
+ }
+ }
+ }
+
+ return [list $currentRules $nSunsetRules]
+
+}
+
+#----------------------------------------------------------------------
+#
+# findEarliestRule --
+#
+# Find the rule in a rule set that has the earliest start time.
+#
+# Parameters:
+# remainingRules -- Rules to search
+# year - Year being processed.
+# stdGMTOffset - Current offset of standard time from GMT
+# DSTOffset - Current offset of daylight time from standard,
+# if daylight time is in effect.
+#
+# Results:
+# Returns the index in remainingRules of the next rule to
+# go into effect.
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc findEarliestRule {remainingRules year stdGMTOffset DSTOffset} {
+ set earliest $::MAXWIDE
+ set i 0
+ foreach {
+ fromYear toYear yearType monthIn daySpecOn timeAt save letter
+ } $remainingRules {
+ lappend daySpecOn $year $monthIn
+ set dayIn [eval $daySpecOn]
+ set secs [expr {wide(86400) * wide($dayIn) - 210866803200}]
+ set secs [convertTimeOfDay $secs \
+ $stdGMTOffset $DSTOffset {*}$timeAt]
+ if {$secs < $earliest} {
+ set earliest $secs
+ set earliestIdx $i
+ }
+ incr i 8
+ }
+
+ return [list $earliest $earliestIdx]
+}
+
+#----------------------------------------------------------------------
+#
+# convertNamePattern --
+#
+# Converts a name pattern to the name of the time zone.
+#
+# Parameters:
+# pattern - Patthern to convert
+# flag - Daylight Time flag. An empty string denotes Standard
+# Time, anything else is Daylight Time.
+#
+# Results;
+# Returns the name of the time zone.
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc convertNamePattern {pattern flag} {
+ if {[regexp {(.*)/(.*)} $pattern -> standard daylight]} {
+ if {$flag ne ""} {
+ set pattern $daylight
+ } else {
+ set pattern $standard
+ }
+ }
+ return [string map [list %s $flag] $pattern]
+}
+
+#----------------------------------------------------------------------
+#
+# convertTimeOfDay --
+#
+# Takes a time of day specifier from 'parseAt' and converts
+# to seconds from the Epoch,
+#
+# Parameters:
+# seconds -- Time at which the GMT day starts, in seconds
+# from the Posix epoch
+# stdGMTOffset - Offset of Standard Time from Greenwich
+# DSTOffset - Offset of Daylight Time from standard.
+# timeOfDay - Time of day to convert, in seconds from midnight
+# flag - Flag indicating whether the time is Greenwich, Standard
+# or wall-clock. (g, s, or w)
+#
+# Results:
+# Returns the time of day in seconds from the Posix epoch.
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc convertTimeOfDay {seconds stdGMTOffset DSTOffset timeOfDay flag} {
+ incr seconds $timeOfDay
+ switch -exact $flag {
+ g - u - z {
+ }
+ w {
+ incr seconds [expr {-$stdGMTOffset}]
+ incr seconds [expr {-$DSTOffset}]
+ }
+ s {
+ incr seconds [expr {-$stdGMTOffset}]
+ }
+ }
+ return $seconds
+}
+
+#----------------------------------------------------------------------
+#
+# processTimeZone --
+#
+# Generate the information about all time transitions in a
+# time zone.
+#
+# Parameters:
+# zoneName - Name of the time zone
+# zoneData - List containing the rows describing the time zone,
+# obtained from 'parseZone.
+#
+# Results:
+# Returns a list of rows. Each row consists of a time in
+# seconds from the Posix epoch, an offset from GMT to local
+# that begins at that time, a flag indicating whether DST
+# is in effect after that time, and the printable name of the
+# timezone that goes into effect at that time.
+#
+# Side effects:
+# None.
+#
+#----------------------------------------------------------------------
+
+proc processTimeZone {zoneName zoneData} {
+ set points {}
+ set i 0
+ foreach {startTime nextGMTOffset dstRule namePattern} $zoneData {
+ incr i 4
+ set until [lindex $zoneData $i]
+ if {![info exists stdGMTOffset]} {
+ set stdGMTOffset $nextGMTOffset
+ }
+ if {![info exists DSTOffset]} {
+ set DSTOffset 0
+ }
+ if {$startTime eq "minimum"} {
+ set secs $::MINWIDE
+ set year 0
+ } else {
+ lassign $startTime year month dayRule timeOfDay
+ lappend dayRule $year $month
+ set startDay [eval $dayRule]
+ set secs [expr {wide(86400) * wide($startDay) -210866803200}]
+ set secs [convertTimeOfDay $secs \
+ $stdGMTOffset $DSTOffset {*}$timeOfDay]
+ }
+ lappend dstRule \
+ $year $secs $stdGMTOffset $DSTOffset $nextGMTOffset \
+ $namePattern $until points
+ lassign [eval $dstRule] stdGMTOffset DSTOffset
+ }
+ return $points
+}
+
+#----------------------------------------------------------------------
+#
+# writeZones --
+#
+# Writes all the time zone information files.
+#
+# Parameters:
+# outDir - Directory in which to store the files.
+#
+# Results:
+# None.
+#
+# Side effects:
+# Writes the time zone information files; traces what's happening
+# on the standard output.
+#
+#----------------------------------------------------------------------
+
+proc writeZones {outDir} {
+ variable zones
+
+ # Walk the zones
+
+ foreach zoneName [lsort -dictionary [array names zones]] {
+ puts "calculating: $zoneName"
+ set fileName [eval [list file join $outDir] [file split $zoneName]]
+
+ # Create directories as needed
+
+ set dirName [file dirname $fileName]
+ if {![file exists $dirName]} {
+ puts "creating directory: $dirName"
+ file mkdir $dirName
+ }
+
+ # Generate data for a zone
+
+ set data ""
+ foreach {
+ time offset dst name
+ } [processTimeZone $zoneName $zones($zoneName)] {
+ append data "\n " [list [list $time $offset $dst $name]]
+ }
+ append data \n
+
+ # Write the data to the information file
+
+ set f [open $fileName w]
+ fconfigure $f -translation lf
+ puts $f "\# created by $::argv0 - do not edit"
+ puts $f ""
+ puts $f [list set TZData(:$zoneName) $data]
+ close $f
+ }
+
+ return
+}
+
+#----------------------------------------------------------------------
+#
+# writeLinks --
+#
+# Write files describing time zone synonyms (the Link directives
+# from the Olson files)
+#
+# Parameters:
+# outDir - Name of the directory where the output files go.
+#
+# Results:
+# None.
+#
+# Side effects:
+# Creates a file for each link.
+
+proc writeLinks {outDir} {
+ variable links
+
+ # Walk the links
+
+ foreach zoneName [lsort -dictionary [array names links]] {
+ puts "creating link: $zoneName"
+ set fileName [eval [list file join $outDir] [file split $zoneName]]
+
+ # Create directories as needed
+
+ set dirName [file dirname $fileName]
+ if {![file exists $dirName]} {
+ puts "creating directory: $dirName"
+ file mkdir $dirName
+ }
+
+ # Create code for the synonym
+
+ set linkTo $links($zoneName)
+ set sourceCmd "\n [list LoadTimeZoneFile $linkTo]\n"
+ set ifCmd [list if "!\[info exists TZData($linkTo)\]" $sourceCmd]
+ set setCmd "set TZData(:$zoneName) \$TZData(:$linkTo)"
+
+ # Write the file
+
+ set f [open $fileName w]
+ fconfigure $f -translation lf
+ puts $f "\# created by $::argv0 - do not edit"
+ puts $f $ifCmd
+ puts $f $setCmd
+ close $f
+ }
+
+ return
+}
+
+#----------------------------------------------------------------------
+#
+# MAIN PROGRAM
+#
+#----------------------------------------------------------------------
+
+puts "Compiling time zones -- [clock format [clock seconds] \
+ -format {%x %X} -locale system]"
+
+# Determine directories
+
+lassign $argv inDir outDir
+
+puts "Olson files in $inDir"
+puts "Tcl files to be placed in $outDir"
+
+# Initialize count of errors
+
+set errorCount 0
+
+# Parse the Olson files
+
+loadFiles $inDir
+if {$errorCount > 0} {
+ exit 1
+}
+
+# Check that all riles appearing in Zone and Link lines actually exist
+
+checkForwardRuleRefs
+if {$errorCount > 0} {
+ exit 1
+}
+
+# Write the time zone information files
+
+writeZones $outDir
+writeLinks $outDir
+if {$errorCount > 0} {
+ exit 1
+}
+
+# All done!
+
+exit
diff --git a/tcl8.6/tools/tcltk-man2html-utils.tcl b/tcl8.6/tools/tcltk-man2html-utils.tcl
new file mode 100644
index 0000000..9052049
--- /dev/null
+++ b/tcl8.6/tools/tcltk-man2html-utils.tcl
@@ -0,0 +1,1634 @@
+##
+## Utility functions for Man->HTML converter. Note that these
+## functions are specifically intended to work with the format as used
+## by Tcl and Tk; they do not cope with arbitrary nroff markup.
+##
+## Copyright (c) 1995-1997 Roger E. Critchlow Jr
+## Copyright (c) 2004-2011 Donal K. Fellows
+
+set ::manual(report-level) 1
+
+proc manerror {msg} {
+ global manual
+ set name {}
+ set subj {}
+ set procname [lindex [info level -1] 0]
+ if {[info exists manual(name)]} {
+ set name $manual(name)
+ }
+ if {[info exists manual(section)] && [string length $manual(section)]} {
+ puts stderr "$name: $manual(section): $procname: $msg"
+ } else {
+ puts stderr "$name: $procname: $msg"
+ }
+}
+
+proc manreport {level msg} {
+ global manual
+ if {$level < $manual(report-level)} {
+ uplevel 1 [list manerror $msg]
+ }
+}
+
+proc fatal {msg} {
+ global manual
+ uplevel 1 [list manerror $msg]
+ exit 1
+}
+
+##
+## templating
+##
+proc indexfile {} {
+ if {[info exists ::TARGET] && $::TARGET eq "devsite"} {
+ return "index.tml"
+ } else {
+ return "contents.htm"
+ }
+}
+
+proc copyright {copyright {level {}}} {
+ # We don't actually generate a separate copyright page anymore
+ #set page "${level}copyright.htm"
+ #return "<A HREF=\"$page\">Copyright</A> &#169; [htmlize-text [lrange $copyright 2 end]]"
+ # obfuscate any email addresses that may appear in name
+ set who [string map {@ (at)} [lrange $copyright 2 end]]
+ return "Copyright &copy; [htmlize-text $who]"
+}
+
+proc copyout {copyrights {level {}}} {
+ set count 0
+ set out "<div class=\"copy\">"
+ foreach c $copyrights {
+ if {$count > 0} {
+ append out <BR>
+ }
+ append out "[copyright $c $level]\n"
+ incr count
+ }
+ append out "</div>"
+ return $out
+}
+
+proc CSS {{level ""}} {
+ return "<link rel=\"stylesheet\" href=\"${level}$::CSSFILE\" type=\"text/css\" media=\"all\">\n"
+}
+
+proc DOCTYPE {} {
+ return "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">"
+}
+
+proc htmlhead {title header args} {
+ set level ""
+ if {[lindex $args end] eq "../[indexfile]"} {
+ # XXX hack - assume same level for CSS file
+ set level "../"
+ }
+ set out "[DOCTYPE]\n<HTML>\n<HEAD><TITLE>$title</TITLE>\n[CSS $level]</HEAD>\n"
+ foreach {uptitle url} $args {
+ set header "<a href=\"$url\">$uptitle</a> <small>&gt;</small> $header"
+ }
+ append out "<BODY><H2>$header</H2>"
+ global manual
+ if {[info exists manual(subheader)]} {
+ set subs {}
+ foreach {name subdir} $manual(subheader) {
+ if {$name eq $title} {
+ lappend subs $name
+ } else {
+ lappend subs "<A HREF=\"${level}$subdir/[indexfile]\">$name</A>"
+ }
+ }
+ append out "\n<H3>[join $subs { | }]</H3>"
+ }
+ return $out
+}
+
+##
+## parsing
+##
+proc unquote arg {
+ return [string map [list \" {}] $arg]
+}
+
+proc parse-directive {line codename restname} {
+ upvar 1 $codename code $restname rest
+ return [regexp {^(\.[.a-zA-Z0-9]*) *(.*)} $line all code rest]
+}
+
+proc htmlize-text {text {charmap {}}} {
+ # contains some extras for use in nroff->html processing
+ # build on the list passed in, if any
+ lappend charmap \
+ "&ndash;" "&ndash;" \
+ {&} {&amp;} \
+ {\\} "&#92;" \
+ {\e} "&#92;" \
+ {\ } {&nbsp;} \
+ {\|} {&nbsp;} \
+ {\0} { } \
+ \" {&quot;} \
+ {<} {&lt;} \
+ {>} {&gt;} \
+ \u201c "&#8220;" \
+ \u201d "&#8221;"
+
+ return [string map $charmap $text]
+}
+
+proc process-text {text} {
+ global manual
+ # preprocess text; note that this is an incomplete map, and will probably
+ # need to have things added to it as the manuals expand to use them.
+ set charmap [list \
+ {\&} "\t" \
+ {\%} {} \
+ "\\\n" "\n" \
+ {\(+-} "&#177;" \
+ {\(co} "&copy;" \
+ {\(em} "&#8212;" \
+ {\(en} "&#8211;" \
+ {\(fm} "&#8242;" \
+ {\(mu} "&#215;" \
+ {\(mi} "&#8722;" \
+ {\(->} "<font size=\"+1\">&#8594;</font>" \
+ {\fP} {\fR} \
+ {\.} . \
+ {\(bu} "&#8226;" \
+ {\*(qo} "&ocirc;" \
+ ]
+ lappend charmap {\-\|\-} -- ; # two hyphens
+ lappend charmap {\-} - ; # a hyphen
+
+ set text [htmlize-text $text $charmap]
+ # General quoted entity
+ regsub -all {\\N'(\d+)'} $text "\\&#\\1;" text
+ while {[string first "\\" $text] >= 0} {
+ # C R
+ if {[regsub {^([^\\]*)\\fC([^\\]*)\\fR(.*)$} $text \
+ {\1<TT>\2</TT>\3} text]} continue
+ # B R
+ if {[regsub {^([^\\]*)\\fB([^\\]*)\\fR(.*)$} $text \
+ {\1<B>\2</B>\3} text]} continue
+ # B I
+ if {[regsub {^([^\\]*)\\fB([^\\]*)\\fI(.*)$} $text \
+ {\1<B>\2</B>\\fI\3} text]} continue
+ # I R
+ if {[regsub {^([^\\]*)\\fI([^\\]*)\\fR(.*)$} $text \
+ {\1<I>\2</I>\3} text]} continue
+ # I B
+ if {[regsub {^([^\\]*)\\fI([^\\]*)\\fB(.*)$} $text \
+ {\1<I>\2</I>\\fB\3} text]} continue
+ # B B, I I, R R
+ if {
+ [regsub {^([^\\]*)\\fB([^\\]*)\\fB(.*)$} $text \
+ {\1\\fB\2\3} ntext]
+ || [regsub {^([^\\]*)\\fI([^\\]*)\\fI(.*)$} $text \
+ {\1\\fI\2\3} ntext]
+ || [regsub {^([^\\]*)\\fR([^\\]*)\\fR(.*)$} $text \
+ {\1\\fR\2\3} ntext]
+ } {
+ manerror "impotent font change: $text"
+ set text $ntext
+ continue
+ }
+ # unrecognized
+ manerror "uncaught backslash: $text"
+ set text [string map [list "\\" "&#92;"] $text]
+ }
+ return $text
+}
+
+##
+## pass 2 text input and matching
+##
+proc open-text {} {
+ global manual
+ set manual(text-length) [llength $manual(text)]
+ set manual(text-pointer) 0
+}
+
+proc more-text {} {
+ global manual
+ return [expr {$manual(text-pointer) < $manual(text-length)}]
+}
+
+proc next-text {} {
+ global manual
+ if {[more-text]} {
+ set text [lindex $manual(text) $manual(text-pointer)]
+ incr manual(text-pointer)
+ return $text
+ }
+ manerror "read past end of text"
+ error "fatal"
+}
+
+proc is-a-directive {line} {
+ return [string match .* $line]
+}
+
+proc split-directive {line opname restname} {
+ upvar 1 $opname op $restname rest
+ set op [string range $line 0 2]
+ set rest [string trim [string range $line 3 end]]
+}
+
+proc next-op-is {op restname} {
+ global manual
+ upvar 1 $restname rest
+ if {[more-text]} {
+ set text [lindex $manual(text) $manual(text-pointer)]
+ if {[string equal -length 3 $text $op]} {
+ set rest [string range $text 4 end]
+ incr manual(text-pointer)
+ return 1
+ }
+ }
+ return 0
+}
+
+proc backup-text {n} {
+ global manual
+ if {$manual(text-pointer)-$n >= 0} {
+ incr manual(text-pointer) -$n
+ }
+}
+
+proc match-text args {
+ global manual
+ set nargs [llength $args]
+ if {$manual(text-pointer) + $nargs > $manual(text-length)} {
+ return 0
+ }
+ set nback 0
+ foreach arg $args {
+ if {![more-text]} {
+ backup-text $nback
+ return 0
+ }
+ set arg [string trim $arg]
+ set targ [string trim [lindex $manual(text) $manual(text-pointer)]]
+ if {$arg eq $targ} {
+ incr nback
+ incr manual(text-pointer)
+ continue
+ }
+ if {[regexp {^@(\w+)$} $arg all name]} {
+ upvar 1 $name var
+ set var $targ
+ incr nback
+ incr manual(text-pointer)
+ continue
+ }
+ if {[regexp -nocase {^(\.[A-Z][A-Z])@(\w+)$} $arg all op name]\
+ && [string equal $op [lindex $targ 0]]} {
+ upvar 1 $name var
+ set var [lrange $targ 1 end]
+ incr nback
+ incr manual(text-pointer)
+ continue
+ }
+ backup-text $nback
+ return 0
+ }
+ return 1
+}
+
+proc expand-next-text {n} {
+ global manual
+ return [join [lrange $manual(text) $manual(text-pointer) \
+ [expr {$manual(text-pointer)+$n-1}]] \n\n]
+}
+
+##
+## pass 2 output
+##
+proc man-puts {text} {
+ global manual
+ lappend manual(output-$manual(wing-file)-$manual(name)) $text
+}
+
+##
+## build hypertext links to tables of contents
+##
+proc long-toc {text} {
+ global manual
+ set here M[incr manual(section-toc-n)]
+ set manual($manual(name)-id-$text) $here
+ set there L[incr manual(long-toc-n)]
+ lappend manual(section-toc) \
+ "<DD><A HREF=\"$manual(name).htm#$here\" NAME=\"$there\">$text</A>"
+ return "<A NAME=\"$here\">$text</A>"
+}
+
+proc option-toc {name class switch} {
+ global manual
+ # Special case handling, oh we hate it but must do it
+ if {[string match "*OPTIONS" $manual(section)]} {
+ if {$manual(name) ne "ttk_widget" && ($manual(name) ne "ttk_entry" ||
+ ![string match validate* $name])} {
+ # link the defined option into the long table of contents
+ set link [long-toc "$switch, $name, $class"]
+ regsub -- "$switch, $name, $class" $link "$switch" link
+ return $link
+ }
+ } elseif {"$manual(name):$manual(section)" ne "options:DESCRIPTION"} {
+ error "option-toc in $manual(name) section $manual(section)"
+ }
+
+ # link the defined standard option to the long table of contents and make
+ # a target for the standard option references from other man pages.
+
+ set first [lindex $switch 0]
+ set here M$first
+ set there L[incr manual(long-toc-n)]
+ set manual(standard-option-$manual(name)-$first) \
+ "<A HREF=\"$manual(name).htm#$here\">$switch, $name, $class</A>"
+ lappend manual(section-toc) \
+ "<DD><A HREF=\"$manual(name).htm#$here\" NAME=\"$there\">$switch, $name, $class</A>"
+ return "<A NAME=\"$here\">$switch</A>"
+}
+
+proc std-option-toc {name page} {
+ global manual
+ if {[info exists manual(standard-option-$page-$name)]} {
+ lappend manual(section-toc) <DD>$manual(standard-option-$page-$name)
+ return $manual(standard-option-$page-$name)
+ }
+ manerror "missing reference to \"$name\" in $page.n"
+ set here M[incr manual(section-toc-n)]
+ set there L[incr manual(long-toc-n)]
+ set other M$name
+ lappend manual(section-toc) "<DD><A HREF=\"$page.htm#$other\">$name</A>"
+ return "<A HREF=\"$page.htm#$other\">$name</A>"
+}
+
+##
+## process the widget option section
+## in widget and options man pages
+##
+proc output-widget-options {rest} {
+ global manual
+ man-puts <DL>
+ lappend manual(section-toc) <DL>
+ backup-text 1
+ set para {}
+ while {[next-op-is .OP rest]} {
+ switch -exact -- [llength $rest] {
+ 3 {
+ lassign $rest switch name class
+ }
+ 5 {
+ set switch [lrange $rest 0 2]
+ set name [lindex $rest 3]
+ set class [lindex $rest 4]
+ }
+ default {
+ fatal "bad .OP $rest"
+ }
+ }
+ if {![regexp {^(<.>)([-\w ]+)(</.>)$} $switch \
+ all oswitch switch cswitch]} {
+ if {![regexp {^(<.>)([-\w ]+) or ([-\w ]+)(</.>)$} $switch \
+ all oswitch switch1 switch2 cswitch]} {
+ error "not Switch: $switch"
+ }
+ set switch "$switch1$cswitch or $oswitch$switch2"
+ }
+ if {![regexp {^(<.>)([\w]*)(</.>)$} $name all oname name cname]} {
+ error "not Name: $name"
+ }
+ if {![regexp {^(<.>)([\w]*)(</.>)$} $class all oclass class cclass]} {
+ error "not Class: $class"
+ }
+ man-puts "$para<DT>Command-Line Name: $oswitch[option-toc $name $class $switch]$cswitch"
+ man-puts "<DT>Database Name: $oname$name$cname"
+ man-puts "<DT>Database Class: $oclass$class$cclass"
+ man-puts <DD>[next-text]
+ set para <P>
+
+ if {[next-op-is .RS rest]} {
+ while {[more-text]} {
+ set line [next-text]
+ if {[is-a-directive $line]} {
+ split-directive $line code rest
+ switch -exact -- $code {
+ .RE {
+ break
+ }
+ .SH - .SS {
+ manerror "unbalanced .RS at section end"
+ backup-text 1
+ break
+ }
+ default {
+ output-directive $line
+ }
+ }
+ } else {
+ man-puts $line
+ }
+ }
+ }
+ }
+ man-puts </DL>
+ lappend manual(section-toc) </DL>
+}
+
+##
+## process .RS lists
+##
+proc output-RS-list {} {
+ global manual
+ if {[next-op-is .IP rest]} {
+ output-IP-list .RS .IP $rest
+ if {[match-text .RE .sp .RS @rest .IP @rest2]} {
+ man-puts <P>$rest
+ output-IP-list .RS .IP $rest2
+ }
+ if {[match-text .RE .sp .RS @rest .RE]} {
+ man-puts <P>$rest
+ return
+ }
+ if {[next-op-is .RE rest]} {
+ return
+ }
+ }
+ man-puts <DL><DD>
+ while {[more-text]} {
+ set line [next-text]
+ if {[is-a-directive $line]} {
+ split-directive $line code rest
+ switch -exact -- $code {
+ .RE {
+ break
+ }
+ .SH - .SS {
+ manerror "unbalanced .RS at section end"
+ backup-text 1
+ break
+ }
+ default {
+ output-directive $line
+ }
+ }
+ } else {
+ man-puts $line
+ }
+ }
+ man-puts </DL>
+}
+
+##
+## process .IP lists which may be plain indents,
+## numeric lists, or definition lists
+##
+proc output-IP-list {context code rest} {
+ global manual
+ if {![string length $rest]} {
+ # blank label, plain indent, no contents entry
+ man-puts <DL><DD>
+ while {[more-text]} {
+ set line [next-text]
+ if {[is-a-directive $line]} {
+ split-directive $line code rest
+ if {$code eq ".IP" && $rest eq {}} {
+ man-puts "<P>"
+ continue
+ }
+ if {$code in {.br .DS .RS}} {
+ output-directive $line
+ } else {
+ backup-text 1
+ break
+ }
+ } else {
+ man-puts $line
+ }
+ }
+ man-puts </DL>
+ } else {
+ # labelled list, make contents
+ if {$context ne ".SH" && $context ne ".SS"} {
+ man-puts <P>
+ }
+ set dl "<DL class=\"[string tolower $manual(section)]\">"
+ set enddl "</DL>"
+ if {$code eq ".IP"} {
+ if {[regexp {^\[[\da-f]+\]|\(?[\da-f]+\)$} $rest]} {
+ set dl "<OL class=\"[string tolower $manual(section)]\">"
+ set enddl "</OL>"
+ } elseif {"&#8226;" eq $rest} {
+ set dl "<UL class=\"[string tolower $manual(section)]\">"
+ set enddl "</UL>"
+ }
+ }
+ man-puts $dl
+ lappend manual(section-toc) $dl
+ backup-text 1
+ set accept_RE 0
+ set para {}
+ while {[more-text]} {
+ set line [next-text]
+ if {[is-a-directive $line]} {
+ split-directive $line code rest
+ switch -exact -- $code {
+ .IP {
+ if {$accept_RE} {
+ output-IP-list .IP $code $rest
+ continue
+ }
+ if {$manual(section) eq "ARGUMENTS"} {
+ man-puts "$para<DT>$rest<DD>"
+ } elseif {[regexp {^\[([\da-f]+)\]$} $rest -> value]} {
+ man-puts "$para<LI value=\"$value\">"
+ } elseif {[regexp {^\(?([\da-f]+)\)$} $rest -> value]} {
+ man-puts "$para<LI value=\"$value\">"
+ } elseif {"&#8226;" eq $rest} {
+ man-puts "$para<LI>"
+ } else {
+ man-puts "$para<DT>[long-toc $rest]<DD>"
+ }
+ }
+ .sp - .br - .DS - .CS {
+ output-directive $line
+ }
+ .RS {
+ if {[match-text .RS]} {
+ output-directive $line
+ incr accept_RE 1
+ } elseif {[match-text .CS]} {
+ output-directive .CS
+ incr accept_RE 1
+ } elseif {[match-text .PP]} {
+ output-directive .PP
+ incr accept_RE 1
+ } elseif {[match-text .DS]} {
+ output-directive .DS
+ incr accept_RE 1
+ } else {
+ output-directive $line
+ }
+ }
+ .PP {
+ if {[match-text @rest1 .br @rest2 .RS]} {
+ # yet another nroff kludge as above
+ man-puts "$para<DT>[long-toc $rest1]"
+ man-puts "<DT>[long-toc $rest2]<DD>"
+ incr accept_RE 1
+ } elseif {[match-text @rest .RE]} {
+ # gad, this is getting ridiculous
+ if {!$accept_RE} {
+ man-puts "$enddl<P>$rest$dl"
+ backup-text 1
+ set para {}
+ break
+ }
+ man-puts "<P>$rest"
+ incr accept_RE -1
+ } elseif {$accept_RE} {
+ output-directive $line
+ } else {
+ backup-text 1
+ break
+ }
+ }
+ .RE {
+ if {!$accept_RE} {
+ backup-text 1
+ break
+ }
+ incr accept_RE -1
+ }
+ default {
+ backup-text 1
+ break
+ }
+ }
+ } else {
+ man-puts $line
+ }
+ set para <P>
+ }
+ man-puts "$para$enddl"
+ lappend manual(section-toc) $enddl
+ if {$accept_RE} {
+ manerror "missing .RE in output-IP-list"
+ }
+ }
+}
+
+##
+## handle the NAME section lines
+## there's only one line in the NAME section,
+## consisting of a comma separated list of names,
+## followed by a hyphen and a short description.
+##
+proc output-name {line} {
+ global manual
+ # split name line into pieces
+ regexp {^([^-]+) - (.*)$} [regsub -all {[ \n\r\t]+} $line " "] -> head tail
+ # output line to manual page untouched
+ man-puts "$head &mdash; $tail"
+ # output line to long table of contents
+ lappend manual(section-toc) "<DL><DD>$head &mdash; $tail</DD></DL>"
+ # separate out the names for future reference
+ foreach name [split $head ,] {
+ set name [string trim $name]
+ if {[llength $name] > 1} {
+ manerror "name has a space: {$name}\nfrom: $line"
+ }
+ lappend manual(wing-toc) $name
+ lappend manual(name-$name) $manual(wing-file)/$manual(name)
+ }
+ set manual(tooltip-$manual(wing-file)/$manual(name).htm) $line
+}
+
+##
+## build a cross-reference link if appropriate
+##
+proc cross-reference {ref} {
+ global manual remap_link_target
+ global ensemble_commands exclude_refs_map exclude_when_followed_by_map
+ set manname $manual(name)
+ set mantail $manual(tail)
+ if {[string match "Tcl_*" $ref] || [string match "Tk_*" $ref] || [string match "Ttk_*" $ref] || [string match "Itcl_*" $ref] || [string match "Tdbc_*" $ref]} {
+ regexp {^\w+} $ref lref
+ ##
+ ## apply a link remapping if available
+ ##
+ if {[info exists remap_link_target($lref)]} {
+ set lref $remap_link_target($lref)
+ }
+ } elseif {$ref eq "Tcl"} {
+ set lref $ref
+ } elseif {
+ [regexp {^[A-Z0-9 ?!]+$} $ref]
+ && [info exists manual($manname-id-$ref)]
+ } {
+ return "<A HREF=\"#$manual($manname-id-$ref)\">$ref</A>"
+ } else {
+ set lref [string tolower $ref]
+ ##
+ ## apply a link remapping if available
+ ##
+ if {[info exists remap_link_target($lref)]} {
+ set lref $remap_link_target($lref)
+ }
+ }
+ ##
+ ## nothing to reference
+ ##
+ if {![info exists manual(name-$lref)]} {
+ foreach name $ensemble_commands {
+ if {
+ [regexp "^$name \[a-z0-9]*\$" $lref] &&
+ [info exists manual(name-$name)] &&
+ $mantail ne "$name.n" &&
+ (![info exists exclude_refs_map($mantail)] ||
+ $manual(name-$name) ni $exclude_refs_map($mantail))
+ } {
+ return "<A HREF=\"../$manual(name-$name).htm\">$ref</A>"
+ }
+ }
+ if {$lref in {end}} {
+ # no good place to send this tcl token?
+ }
+ return $ref
+ }
+ set manref $manual(name-$lref)
+ ##
+ ## would be a self reference
+ ##
+ foreach name $manref {
+ if {"$manual(wing-file)/$manname" in $name} {
+ return $ref
+ }
+ }
+ ##
+ ## multiple choices for reference
+ ##
+ if {[llength $manref] > 1} {
+ set tcl_i [lsearch -glob $manref *TclCmd*]
+ if {$tcl_i >= 0 && $manual(wing-file) eq "TclCmd"
+ || $manual(wing-file) eq "TclLib"} {
+ set tcl_ref [lindex $manref $tcl_i]
+ return "<A HREF=\"../$tcl_ref.htm\">$ref</A>"
+ }
+ set tk_i [lsearch -glob $manref *TkCmd*]
+ if {$tk_i >= 0 && $manual(wing-file) eq "TkCmd"
+ || $manual(wing-file) eq "TkLib"} {
+ set tk_ref [lindex $manref $tk_i]
+ return "<A HREF=\"../$tk_ref.htm\">$ref</A>"
+ }
+ if {$lref eq "exit" && $mantail eq "tclsh.1" && $tcl_i >= 0} {
+ set tcl_ref [lindex $manref $tcl_i]
+ return "<A HREF=\"../$tcl_ref.htm\">$ref</A>"
+ }
+ puts stderr "multiple cross reference to $ref in $manref from $manual(wing-file)/$mantail"
+ return $ref
+ }
+ ##
+ ## exceptions, sigh, to the rule
+ ##
+ if {[info exists exclude_when_followed_by_map($mantail)]} {
+ upvar 1 text tail
+ set following_word [lindex [regexp -inline {\S+} $tail] 0]
+ foreach {this that} $exclude_when_followed_by_map($mantail) {
+ # only a ref if $this is not followed by $that
+ if {$lref eq $this && [string match $that* $following_word]} {
+ return $ref
+ }
+ }
+ }
+ if {
+ [info exists exclude_refs_map($mantail)]
+ && $lref in $exclude_refs_map($mantail)
+ } {
+ return $ref
+ }
+ ##
+ ## return the cross reference
+ ##
+ return "<A HREF=\"../$manref.htm\">$ref</A>"
+}
+
+##
+## reference generation errors
+##
+proc reference-error {msg text} {
+ global manual
+ puts stderr "$manual(tail): $msg: {$text}"
+ return $text
+}
+
+##
+## insert as many cross references into this text string as are appropriate
+##
+proc insert-cross-references {text} {
+ global manual
+ set result ""
+
+ while 1 {
+ ##
+ ## we identify cross references by:
+ ## ``quotation''
+ ## <B>emboldening</B>
+ ## Tcl_ prefix
+ ## Tk_ prefix
+ ## [a-zA-Z0-9]+ manual entry
+ ## and we avoid messing with already anchored text
+ ##
+ ##
+ ## find where each item lives - EXPENSIVE - and accumulate a list
+ ##
+ unset -nocomplain offsets
+ foreach {name pattern} {
+ anchor {<A } end-anchor {</A>}
+ quote {``} end-quote {''}
+ bold {<B>} end-bold {</B>}
+ c.tcl {Tcl_}
+ c.tk {Tk_}
+ c.ttk {Ttk_}
+ c.tdbc {Tdbc_}
+ c.itcl {Itcl_}
+ Tcl1 {Tcl manual entry}
+ Tcl2 {Tcl overview manual entry}
+ url {http://}
+ } {
+ set o [string first $pattern $text]
+ if {[set offset($name) $o] >= 0} {
+ set invert($o) $name
+ lappend offsets $o
+ }
+ }
+ ##
+ ## if nothing, then we're done.
+ ##
+ if {![info exists offsets]} {
+ return [append result $text]
+ }
+ ##
+ ## sort the offsets
+ ##
+ set offsets [lsort -integer $offsets]
+ ##
+ ## see which we want to use
+ ##
+ switch -exact -- $invert([lindex $offsets 0]) {
+ anchor {
+ if {$offset(end-anchor) < 0} {
+ return [reference-error {Missing end anchor} $text]
+ }
+ append result [string range $text 0 $offset(end-anchor)]
+ set text [string range $text[set text ""] \
+ [expr {$offset(end-anchor)+1}] end]
+ continue
+ }
+ quote {
+ if {$offset(end-quote) < 0} {
+ return [reference-error "Missing end quote" $text]
+ }
+ if {$invert([lindex $offsets 1]) in {tcl tk ttk}} {
+ set offsets [lreplace $offsets 1 1]
+ }
+ switch -exact -- $invert([lindex $offsets 1]) {
+ end-quote {
+ append result [string range $text 0 [expr {$offset(quote)-1}]]
+ set body [string range $text [expr {$offset(quote)+2}] \
+ [expr {$offset(end-quote)-1}]]
+ set text [string range $text[set text ""] \
+ [expr {$offset(end-quote)+2}] end]
+ append result `` [cross-reference $body] ''
+ continue
+ }
+ bold - anchor {
+ append result [string range $text \
+ 0 [expr {$offset(end-quote)+1}]]
+ set text [string range $text[set text ""] \
+ [expr {$offset(end-quote)+2}] end]
+ continue
+ }
+ }
+ return [reference-error "Uncaught quote case" $text]
+ }
+ bold {
+ if {$offset(end-bold) < 0} {
+ return [append result $text]
+ }
+ if {[string match "c.*" $invert([lindex $offsets 1])]} {
+ set offsets [lreplace $offsets 1 1]
+ }
+ switch -exact -- $invert([lindex $offsets 1]) {
+ url - end-bold {
+ append result \
+ [string range $text 0 [expr {$offset(bold)-1}]]
+ set body [string range $text [expr {$offset(bold)+3}] \
+ [expr {$offset(end-bold)-1}]]
+ set text [string range $text[set text ""] \
+ [expr {$offset(end-bold)+4}] end]
+ regsub {http://[\w/.]+} $body {<A HREF="&">&</A>} body
+ append result <B> [cross-reference $body] </B>
+ continue
+ }
+ anchor {
+ append result \
+ [string range $text 0 [expr {$offset(end-bold)+3}]]
+ set text [string range $text[set text ""] \
+ [expr {$offset(end-bold)+4}] end]
+ continue
+ }
+ default {
+ return [reference-error "Uncaught bold case" $text]
+ }
+ }
+ }
+ c.tk - c.ttk - c.tcl - c.tdbc - c.itcl {
+ append result [string range $text 0 \
+ [expr {[lindex $offsets 0]-1}]]
+ regexp -indices -start [lindex $offsets 0] {\w+} $text range
+ set body [string range $text {*}$range]
+ set text [string range $text[set text ""] \
+ [expr {[lindex $range 1]+1}] end]
+ append result [cross-reference $body]
+ continue
+ }
+ Tcl1 - Tcl2 {
+ set off [lindex $offsets 0]
+ append result [string range $text 0 [expr {$off-1}]]
+ set text [string range $text[set text ""] [expr {$off+3}] end]
+ append result [cross-reference Tcl]
+ continue
+ }
+ url {
+ set off [lindex $offsets 0]
+ append result [string range $text 0 [expr {$off-1}]]
+ regexp -indices -start $off {http://[\w/.]+} $text range
+ set url [string range $text {*}$range]
+ append result "<A HREF=\"[string trimright $url .]\">$url</A>"
+ set text [string range $text[set text ""] \
+ [expr {[lindex $range 1]+1}] end]
+ continue
+ }
+ end-anchor - end-bold - end-quote {
+ return [reference-error "Out of place $invert([lindex $offsets 0])" $text]
+ }
+ }
+ }
+}
+
+##
+## process formatting directives
+##
+proc output-directive {line} {
+ global manual
+ # process format directive
+ split-directive $line code rest
+ switch -exact -- $code {
+ .BS - .BE {
+ # man-puts <HR>
+ }
+ .SH - .SS {
+ # drain any open lists
+ # announce the subject
+ set manual(section) $rest
+ # start our own stack of stuff
+ set manual($manual(name)-$manual(section)) {}
+ lappend manual(has-$manual(section)) $manual(name)
+ if {$code ne ".SS"} {
+ man-puts "<H3>[long-toc $manual(section)]</H3>"
+ } else {
+ man-puts "<H4>[long-toc $manual(section)]</H4>"
+ }
+ # some sections can simply free wheel their way through the text
+ # some sections can be processed in their own loops
+ switch -exact -- [string index $code end]:$manual(section) {
+ H:NAME {
+ set names {}
+ while {1} {
+ set line [next-text]
+ if {[is-a-directive $line]} {
+ backup-text 1
+ if {[llength $names]} {
+ output-name [join $names { }]
+ }
+ return
+ }
+ lappend names [string trim $line]
+ }
+ }
+ H:SYNOPSIS {
+ lappend manual(section-toc) <DL>
+ while {1} {
+ if {
+ [next-op-is .nf rest]
+ || [next-op-is .br rest]
+ || [next-op-is .fi rest]
+ } {
+ continue
+ }
+ if {
+ [next-op-is .SH rest]
+ || [next-op-is .SS rest]
+ || [next-op-is .BE rest]
+ || [next-op-is .SO rest]
+ } {
+ backup-text 1
+ break
+ }
+ if {[next-op-is .sp rest]} {
+ #man-puts <P>
+ continue
+ }
+ set more [next-text]
+ if {[is-a-directive $more]} {
+ manerror "in SYNOPSIS found $more"
+ backup-text 1
+ break
+ }
+ foreach more [split $more \n] {
+ regexp {^(\s*)(.*)} $more -> spaces more
+ set spaces [string map {" " "&nbsp;"} $spaces]
+ if {[string length $spaces]} {
+ set spaces <TT>$spaces</TT>
+ }
+ man-puts $spaces$more<BR>
+ if {$manual(wing-file) in {TclLib TkLib}} {
+ lappend manual(section-toc) <DD>$more
+ }
+ }
+ }
+ lappend manual(section-toc) </DL>
+ return
+ }
+ {H:SEE ALSO} {
+ while {[more-text]} {
+ if {[next-op-is .SH rest] || [next-op-is .SS rest]} {
+ backup-text 1
+ return
+ }
+ set more [next-text]
+ if {[is-a-directive $more]} {
+ manerror "$more"
+ backup-text 1
+ return
+ }
+ set nmore {}
+ foreach cr [split $more ,] {
+ set cr [string trim $cr]
+ if {![regexp {^<B>.*</B>$} $cr]} {
+ set cr <B>$cr</B>
+ }
+ if {[regexp {^<B>(.*)\([13n]\)</B>$} $cr all name]} {
+ set cr <B>$name</B>
+ }
+ lappend nmore $cr
+ }
+ man-puts [join $nmore {, }]
+ }
+ return
+ }
+ H:KEYWORDS {
+ while {[more-text]} {
+ if {[next-op-is .SH rest] || [next-op-is .SS rest]} {
+ backup-text 1
+ return
+ }
+ set more [next-text]
+ if {[is-a-directive $more]} {
+ manerror "$more"
+ backup-text 1
+ return
+ }
+ set keys {}
+ foreach key [split $more ,] {
+ set key [string trim $key]
+ lappend manual(keyword-$key) [list $manual(name) \
+ $manual(wing-file)/$manual(name).htm]
+ set initial [string toupper [string index $key 0]]
+ lappend keys "<A href=\"../Keywords/$initial.htm\#$key\">$key</A>"
+ }
+ man-puts [join $keys {, }]
+ }
+ return
+ }
+ }
+ if {[next-op-is .IP rest]} {
+ output-IP-list $code .IP $rest
+ return
+ }
+ if {[next-op-is .PP rest]} {
+ return
+ }
+ return
+ }
+ .SO {
+ # When there's a sequence of multiple .SO chunks, process into one
+ set optslist {}
+ while 1 {
+ if {[match-text @stuff .SE]} {
+ foreach opt [split $stuff \n\t] {
+ lappend optslist [list $opt $rest]
+ }
+ } else {
+ manerror "unexpected .SO format:\n[expand-next-text 2]"
+ }
+ if {![next-op-is .SO rest]} {
+ break
+ }
+ }
+ output-directive {.SH STANDARD OPTIONS}
+ man-puts <DL>
+ lappend manual(section-toc) <DL>
+ foreach optionpair [lsort -dictionary -index 0 $optslist] {
+ lassign $optionpair option targetPage
+ man-puts "<DT><B>[std-option-toc $option $targetPage]</B>"
+ }
+ man-puts </DL>
+ lappend manual(section-toc) </DL>
+ }
+ .OP {
+ output-widget-options $rest
+ return
+ }
+ .IP {
+ output-IP-list .IP .IP $rest
+ return
+ }
+ .PP - .sp {
+ man-puts <P>
+ }
+ .RS {
+ output-RS-list
+ return
+ }
+ .br {
+ man-puts <BR>
+ return
+ }
+ .DS {
+ if {[next-op-is .ta rest]} {
+ # skip the leading .ta directive if it is there
+ }
+ if {[match-text @stuff .DE]} {
+ set td "<td><p class=\"tablecell\">"
+ set bodyText [string map [list \n <tr>$td \t $td] \n$stuff]
+ man-puts "<dl><dd><table border=\"0\">$bodyText</table></dl>"
+ #man-puts <PRE>$stuff</PRE>
+ } elseif {[match-text .fi @ul1 @ul2 .nf @stuff .DE]} {
+ man-puts "<PRE>[lindex $ul1 1][lindex $ul2 1]\n$stuff</PRE>"
+ } else {
+ manerror "unexpected .DS format:\n[expand-next-text 2]"
+ }
+ return
+ }
+ .CS {
+ if {[next-op-is .ta rest]} {
+ # ???
+ }
+ if {[match-text @stuff .CE]} {
+ man-puts <PRE>$stuff</PRE>
+ } else {
+ manerror "unexpected .CS format:\n[expand-next-text 2]"
+ }
+ return
+ }
+ .nf {
+ if {[match-text @more .fi]} {
+ foreach more [split $more \n] {
+ man-puts $more<BR>
+ }
+ } elseif {[match-text .RS @more .RE .fi]} {
+ man-puts <DL><DD>
+ foreach more [split $more \n] {
+ man-puts $more<BR>
+ }
+ man-puts </DL>
+ } elseif {[match-text .RS @more .RS @more2 .RE .RE .fi]} {
+ man-puts <DL><DD>
+ foreach more [split $more \n] {
+ man-puts $more<BR>
+ }
+ man-puts <DL><DD>
+ foreach more2 [split $more2 \n] {
+ man-puts $more2<BR>
+ }
+ man-puts </DL></DL>
+ } elseif {[match-text .RS @more .RS @more2 .RE @more3 .RE .fi]} {
+ man-puts <DL><DD>
+ foreach more [split $more \n] {
+ man-puts $more<BR>
+ }
+ man-puts <DL><DD>
+ foreach more2 [split $more2 \n] {
+ man-puts $more2<BR>
+ }
+ man-puts </DL><DD>
+ foreach more3 [split $more3 \n] {
+ man-puts $more3<BR>
+ }
+ man-puts </DL>
+ } elseif {[match-text .sp .RS @more .RS @more2 .sp .RE .RE .fi]} {
+ man-puts <P><DL><DD>
+ foreach more [split $more \n] {
+ man-puts $more<BR>
+ }
+ man-puts <DL><DD>
+ foreach more2 [split $more2 \n] {
+ man-puts $more2<BR>
+ }
+ man-puts </DL></DL><P>
+ } elseif {[match-text .RS .sp @more .sp .RE .fi]} {
+ man-puts <P><DL><DD>
+ foreach more [split $more \n] {
+ man-puts $more<BR>
+ }
+ man-puts </DL><P>
+ } else {
+ manerror "ignoring $line"
+ }
+ }
+ .RE - .DE - .CE {
+ manerror "unexpected $code"
+ return
+ }
+ .ta - .fi - .na - .ad - .UL - .ie - .el - .ne {
+ manerror "ignoring $line"
+ }
+ default {
+ manerror "unrecognized format directive: $line"
+ }
+ }
+}
+
+##
+## merge copyright listings
+##
+proc merge-copyrights {l1 l2} {
+ set merge {}
+ set re1 {^Copyright +(?:\(c\)|\\\(co|&copy;) +(\w.*?)(?:all rights reserved)?(?:\. )*$}
+ set re2 {^(\d+) +(?:by +)?(\w.*)$} ;# date who
+ set re3 {^(\d+)-(\d+) +(?:by +)?(\w.*)$} ;# from to who
+ set re4 {^(\d+), *(\d+) +(?:by +)?(\w.*)$} ;# date1 date2 who
+ foreach copyright [concat $l1 $l2] {
+ if {[regexp -nocase -- $re1 $copyright -> info]} {
+ set info [string trimright $info ". "] ; # remove extra period
+ if {[regexp -- $re2 $info -> date who]} {
+ lappend dates($who) $date
+ continue
+ } elseif {[regexp -- $re3 $info -> from to who]} {
+ for {set date $from} {$date <= $to} {incr date} {
+ lappend dates($who) $date
+ }
+ continue
+ } elseif {[regexp -- $re3 $info -> date1 date2 who]} {
+ lappend dates($who) $date1 $date2
+ continue
+ }
+ }
+ puts "oops: $copyright"
+ }
+ foreach who [array names dates] {
+ set list [lsort -dictionary $dates($who)]
+ if {[llength $list] == 1 || [lindex $list 0] eq [lrange $list end end]} {
+ lappend merge "Copyright &copy; [lindex $list 0] $who"
+ } else {
+ lappend merge "Copyright &copy; [lindex $list 0]-[lrange $list end end] $who"
+ }
+ }
+ return [lsort -dictionary $merge]
+}
+
+##
+## foreach of the man pages in the section specified by
+## sectionDescriptor, convert manpages into hypertext in
+## the directory specified by outputDir.
+##
+proc make-manpage-section {outputDir sectionDescriptor} {
+ global manual overall_title tcltkdesc verbose
+ global excluded_pages forced_index_pages process_first_patterns
+
+ set LQ \u201c
+ set RQ \u201d
+
+ lassign $sectionDescriptor \
+ manual(wing-glob) \
+ manual(wing-name) \
+ manual(wing-file) \
+ manual(wing-description)
+ set manual(wing-copyrights) {}
+ makedirhier $outputDir/$manual(wing-file)
+ set manual(wing-toc-fp) [open $outputDir/$manual(wing-file)/[indexfile] w]
+ # whistle
+ puts stderr "scanning section $manual(wing-name)"
+ # put the entry for this section into the short table of contents
+ if {[regexp {^(.+), version (.+)$} $manual(wing-name) -> name version]} {
+ puts $manual(short-toc-fp) "<DT><A HREF=\"$manual(wing-file)/[indexfile]\" TITLE=\"version $version\">$name</A></DT><DD>$manual(wing-description)</DD>"
+ } else {
+ puts $manual(short-toc-fp) "<DT><A HREF=\"$manual(wing-file)/[indexfile]\">$manual(wing-name)</A></DT><DD>$manual(wing-description)</DD>"
+ }
+ # initialize the wing table of contents
+ puts $manual(wing-toc-fp) [htmlhead $manual(wing-name) \
+ $manual(wing-name) $overall_title "../[indexfile]"]
+ # initialize the short table of contents for this section
+ set manual(wing-toc) {}
+ # initialize the man directory for this section
+ makedirhier $outputDir/$manual(wing-file)
+ # initialize the long table of contents for this section
+ set manual(long-toc-n) 1
+ # get the manual pages for this section
+ set manual(pages) [lsort -dictionary [glob -nocomplain $manual(wing-glob)]]
+ # Some pages have to go first so that their links override others
+ foreach pat $process_first_patterns {
+ set n [lsearch -glob $manual(pages) $pat]
+ if {$n >= 0} {
+ set f [lindex $manual(pages) $n]
+ puts stderr "shuffling [file tail $f] to front of processing queue"
+ set manual(pages) \
+ [linsert [lreplace $manual(pages) $n $n] 0 $f]
+ }
+ }
+ # set manual(pages) [lrange $manual(pages) 0 5]
+ foreach manual_page $manual(pages) {
+ set manual(page) [file normalize $manual_page]
+ # whistle
+ if {$verbose} {
+ puts stderr "scanning page $manual(page)"
+ } else {
+ puts -nonewline stderr .
+ }
+ set manual(tail) [file tail $manual(page)]
+ set manual(name) [file root $manual(tail)]
+ set manual(section) {}
+ if {$manual(name) in $excluded_pages} {
+ # obsolete
+ if {!$verbose} {
+ puts stderr ""
+ }
+ manerror "discarding $manual(name)"
+ continue
+ }
+ set manual(infp) [open $manual(page)]
+ set manual(text) {}
+ set manual(partial-text) {}
+ foreach p {.RS .DS .CS .SO} {
+ set manual($p) 0
+ }
+ set manual(stack) {}
+ set manual(section) {}
+ set manual(section-toc) {}
+ set manual(section-toc-n) 1
+ set manual(copyrights) {}
+ lappend manual(all-pages) $manual(wing-file)/$manual(tail)
+ lappend manual(all-page-domains) $manual(wing-name)
+ manreport 100 $manual(name)
+ while {[gets $manual(infp) line] >= 0} {
+ manreport 100 $line
+ if {[regexp {^[`'][/\\]} $line]} {
+ if {[regexp {Copyright (?:\(c\)|\\\(co).*$} $line copyright]} {
+ lappend manual(copyrights) $copyright
+ }
+ # comment
+ continue
+ }
+ if {"$line" eq {'}} {
+ # comment
+ continue
+ }
+ if {![parse-directive $line code rest]} {
+ addbuffer $line
+ continue
+ }
+ switch -exact -- $code {
+ .if - .nr - .ti - .in - .ie - .el -
+ .ad - .na - .so - .ne - .AS - .HS - .VE - .VS - . {
+ # ignore
+ continue
+ }
+ }
+ switch -exact -- $code {
+ .SH - .SS {
+ flushbuffer
+ if {[llength $rest] == 0} {
+ gets $manual(infp) rest
+ }
+ lappend manual(text) "$code [unquote $rest]"
+ }
+ .TH {
+ flushbuffer
+ lappend manual(text) "$code [unquote $rest]"
+ }
+ .QW {
+ lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \
+ inQuote afterwards
+ addbuffer $LQ [unquote $inQuote] $RQ [unquote $afterwards]
+ }
+ .PQ {
+ lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \
+ inQuote punctuation afterwards
+ addbuffer ( $LQ [unquote $inQuote] $RQ \
+ [unquote $punctuation] ) [unquote $afterwards]
+ }
+ .QR {
+ lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \
+ rangeFrom rangeTo afterwards
+ addbuffer $LQ [unquote $rangeFrom] "&ndash;" \
+ [unquote $rangeTo] $RQ [unquote $afterwards]
+ }
+ .MT {
+ addbuffer $LQ$RQ
+ }
+ .HS - .UL - .ta {
+ flushbuffer
+ lappend manual(text) "$code [unquote $rest]"
+ }
+ .BS - .BE - .br - .fi - .sp - .nf {
+ flushbuffer
+ if {$rest ne ""} {
+ if {!$verbose} {
+ puts stderr ""
+ }
+ manerror "unexpected argument: $line"
+ }
+ lappend manual(text) $code
+ }
+ .AP {
+ flushbuffer
+ lappend manual(text) [concat .IP [process-text \
+ "[lindex $rest 0] \\fB[lindex $rest 1]\\fR ([lindex $rest 2])"]]
+ }
+ .IP {
+ flushbuffer
+ regexp {^(.*) +\d+$} $rest all rest
+ lappend manual(text) ".IP [process-text \
+ [unquote [string trim $rest]]]"
+ }
+ .TP {
+ flushbuffer
+ while {[is-a-directive [set next [gets $manual(infp)]]]} {
+ if {!$verbose} {
+ puts stderr ""
+ }
+ manerror "ignoring $next after .TP"
+ }
+ if {"$next" ne {'}} {
+ lappend manual(text) ".IP [process-text $next]"
+ }
+ }
+ .OP {
+ flushbuffer
+ lassign $rest cmdName dbName dbClass
+ lappend manual(text) [concat .OP [process-text \
+ "\\fB$cmdName\\fR \\fB$dbName\\fR \\fB$dbClass\\fR"]]
+ }
+ .PP - .LP {
+ flushbuffer
+ lappend manual(text) {.PP}
+ }
+ .RS {
+ flushbuffer
+ incr manual(.RS)
+ lappend manual(text) $code
+ }
+ .RE {
+ flushbuffer
+ incr manual(.RS) -1
+ lappend manual(text) $code
+ }
+ .SO {
+ flushbuffer
+ incr manual(.SO)
+ if {[llength $rest] == 0} {
+ lappend manual(text) "$code options"
+ } else {
+ lappend manual(text) "$code [unquote $rest]"
+ }
+ }
+ .SE {
+ flushbuffer
+ incr manual(.SO) -1
+ lappend manual(text) $code
+ }
+ .DS {
+ flushbuffer
+ incr manual(.DS)
+ lappend manual(text) $code
+ }
+ .DE {
+ flushbuffer
+ incr manual(.DS) -1
+ lappend manual(text) $code
+ }
+ .CS {
+ flushbuffer
+ incr manual(.CS)
+ lappend manual(text) $code
+ }
+ .CE {
+ flushbuffer
+ incr manual(.CS) -1
+ lappend manual(text) $code
+ }
+ .de {
+ while {[gets $manual(infp) line] >= 0} {
+ if {[string match "..*" $line]} {
+ break
+ }
+ }
+ }
+ .. {
+ if {!$verbose} {
+ puts stderr ""
+ }
+ error "found .. outside of .de"
+ }
+ default {
+ if {!$verbose} {
+ puts stderr ""
+ }
+ flushbuffer
+ manerror "unrecognized format directive: $line"
+ }
+ }
+ }
+ flushbuffer
+ close $manual(infp)
+ # fixups
+ if {$manual(.RS) != 0} {
+ if {!$verbose} {
+ puts stderr ""
+ }
+ puts "unbalanced .RS .RE"
+ }
+ if {$manual(.DS) != 0} {
+ if {!$verbose} {
+ puts stderr ""
+ }
+ puts "unbalanced .DS .DE"
+ }
+ if {$manual(.CS) != 0} {
+ if {!$verbose} {
+ puts stderr ""
+ }
+ puts "unbalanced .CS .CE"
+ }
+ if {$manual(.SO) != 0} {
+ if {!$verbose} {
+ puts stderr ""
+ }
+ puts "unbalanced .SO .SE"
+ }
+ # output conversion
+ open-text
+ set haserror 0
+ if {[next-op-is .HS rest]} {
+ set manual($manual(wing-file)-$manual(name)-title) \
+ "[join [lrange $rest 1 end] { }] [lindex $rest 0] manual page"
+ } elseif {[next-op-is .TH rest]} {
+ set manual($manual(wing-file)-$manual(name)-title) \
+ "[lindex $rest 0] manual page - [join [lrange $rest 4 end] { }]"
+ } else {
+ set haserror 1
+ if {!$verbose} {
+ puts stderr ""
+ }
+ manerror "no .HS or .TH record found"
+ }
+ if {!$haserror} {
+ while {[more-text]} {
+ set line [next-text]
+ if {[is-a-directive $line]} {
+ output-directive $line
+ } else {
+ man-puts $line
+ }
+ }
+ man-puts [copyout $manual(copyrights) "../"]
+ set manual(wing-copyrights) [merge-copyrights \
+ $manual(wing-copyrights) $manual(copyrights)]
+ }
+ #
+ # make the long table of contents for this page
+ #
+ set manual(toc-$manual(wing-file)-$manual(name)) \
+ [concat <DL> $manual(section-toc) </DL>]
+ }
+ if {!$verbose} {
+ puts stderr ""
+ }
+
+ #
+ # make the wing table of contents for the section
+ #
+ set width 0
+ foreach name $manual(wing-toc) {
+ if {[string length $name] > $width} {
+ set width [string length $name]
+ }
+ }
+ set perline [expr {118 / $width}]
+ set nrows [expr {([llength $manual(wing-toc)]+$perline)/$perline}]
+ set n 0
+ catch {unset rows}
+ foreach name [lsort -dictionary $manual(wing-toc)] {
+ set tail $manual(name-$name)
+ if {[llength $tail] > 1} {
+ manerror "$name is defined in more than one file: $tail"
+ set tail [lindex $tail [expr {[llength $tail]-1}]]
+ }
+ set tail [file tail $tail]
+ if {[info exists manual(tooltip-$manual(wing-file)/$tail.htm)]} {
+ set tooltip $manual(tooltip-$manual(wing-file)/$tail.htm)
+ set tooltip [string map {[ {\[} ] {\]} $ {\$} \\ \\\\} $tooltip]
+ regsub {^[^-]+-\s*(.)} $tooltip {[string totitle \1]} tooltip
+ append rows([expr {$n%$nrows}]) \
+ "<td> <a href=\"$tail.htm\" title=\"[subst $tooltip]\">$name</a> </td>"
+ } else {
+ append rows([expr {$n%$nrows}]) \
+ "<td> <a href=\"$tail.htm\">$name</a> </td>"
+ }
+ incr n
+ }
+ puts $manual(wing-toc-fp) <table>
+ foreach row [lsort -integer [array names rows]] {
+ puts $manual(wing-toc-fp) <tr>$rows($row)</tr>
+ }
+ puts $manual(wing-toc-fp) </table>
+
+ #
+ # insert wing copyrights
+ #
+ puts $manual(wing-toc-fp) [copyout $manual(wing-copyrights) "../"]
+ puts $manual(wing-toc-fp) "</BODY></HTML>"
+ close $manual(wing-toc-fp)
+ set manual(merge-copyrights) \
+ [merge-copyrights $manual(merge-copyrights) $manual(wing-copyrights)]
+}
+
+proc makedirhier {dir} {
+ try {
+ if {![file isdirectory $dir]} {
+ file mkdir $dir
+ }
+ } on error msg {
+ return -code error "cannot create directory $dir: $msg"
+ }
+}
+
+proc addbuffer {args} {
+ global manual
+ if {$manual(partial-text) ne ""} {
+ append manual(partial-text) \n
+ }
+ append manual(partial-text) [join $args ""]
+}
+proc flushbuffer {} {
+ global manual
+ if {$manual(partial-text) ne ""} {
+ lappend manual(text) [process-text $manual(partial-text)]
+ set manual(partial-text) ""
+ }
+}
+
+return
diff --git a/tcl8.6/tools/tcltk-man2html.tcl b/tcl8.6/tools/tcltk-man2html.tcl
new file mode 100755
index 0000000..d607905
--- /dev/null
+++ b/tcl8.6/tools/tcltk-man2html.tcl
@@ -0,0 +1,752 @@
+#!/usr/bin/env tclsh
+
+if {[catch {package require Tcl 8.6-} msg]} {
+ puts stderr "ERROR: $msg"
+ puts stderr "If running this script from 'make html', set the\
+ NATIVE_TCLSH environment\nvariable to point to an installed\
+ tclsh8.6 (or the equivalent tclsh86.exe\non Windows)."
+ exit 1
+}
+
+# Convert Ousterhout format man pages into highly crosslinked hypertext.
+#
+# Along the way detect many unmatched font changes and other odd things.
+#
+# Note well, this program is a hack rather than a piece of software
+# engineering. In that sense it's probably a good example of things
+# that a scripting language, like Tcl, can do well. It is offered as
+# an example of how someone might convert a specific set of man pages
+# into hypertext, not as a general solution to the problem. If you
+# try to use this, you'll be very much on your own.
+#
+# Copyright (c) 1995-1997 Roger E. Critchlow Jr
+# Copyright (c) 2004-2010 Donal K. Fellows
+
+set ::Version "50/8.6"
+set ::CSSFILE "docs.css"
+
+##
+## Source the utility functions that provide most of the
+## implementation of the transformation from nroff to html.
+##
+source [file join [file dirname [info script]] tcltk-man2html-utils.tcl]
+
+proc parse_command_line {} {
+ global argv Version
+
+ # These variables determine where the man pages come from and where
+ # the converted pages go to.
+ global tcltkdir tkdir tcldir webdir build_tcl build_tk verbose
+
+ # Set defaults based on original code.
+ set tcltkdir ../..
+ set tkdir {}
+ set tcldir {}
+ set webdir ../html
+ set build_tcl 0
+ set build_tk 0
+ set verbose 0
+ # Default search version is a glob pattern
+ set useversion {{,[8-9].[0-9]{,[.ab][0-9]{,[0-9]}}}}
+
+ # Handle arguments a la GNU:
+ # --version
+ # --useversion=<version>
+ # --help
+ # --srcdir=/path
+ # --htmldir=/path
+
+ foreach option $argv {
+ switch -glob -- $option {
+ --version {
+ puts "tcltk-man-html $Version"
+ exit 0
+ }
+
+ --help {
+ puts "usage: tcltk-man-html \[OPTION\] ...\n"
+ puts " --help print this help, then exit"
+ puts " --version print version number, then exit"
+ puts " --srcdir=DIR find tcl and tk source below DIR"
+ puts " --htmldir=DIR put generated HTML in DIR"
+ puts " --tcl build tcl help"
+ puts " --tk build tk help"
+ puts " --useversion version of tcl/tk to search for"
+ puts " --verbose whether to print longer messages"
+ exit 0
+ }
+
+ --srcdir=* {
+ # length of "--srcdir=" is 9.
+ set tcltkdir [string range $option 9 end]
+ }
+
+ --htmldir=* {
+ # length of "--htmldir=" is 10
+ set webdir [string range $option 10 end]
+ }
+
+ --useversion=* {
+ # length of "--useversion=" is 13
+ set useversion [string range $option 13 end]
+ }
+
+ --tcl {
+ set build_tcl 1
+ }
+
+ --tk {
+ set build_tk 1
+ }
+
+ --verbose=* {
+ set verbose [string range $option \
+ [string length --verbose=] end]
+ }
+ default {
+ puts stderr "tcltk-man-html: unrecognized option -- `$option'"
+ exit 1
+ }
+ }
+ }
+
+ if {!$build_tcl && !$build_tk} {
+ set build_tcl 1;
+ set build_tk 1
+ }
+
+ if {$build_tcl} {
+ # Find Tcl.
+ set tcldir [lindex [lsort [glob -nocomplain -tails -type d \
+ -directory $tcltkdir tcl$useversion]] end]
+ if {$tcldir eq ""} {
+ puts stderr "tcltk-man-html: couldn't find Tcl below $tcltkdir"
+ exit 1
+ }
+ puts "using Tcl source directory $tcldir"
+ }
+
+ if {$build_tk} {
+ # Find Tk.
+ set tkdir [lindex [lsort [glob -nocomplain -tails -type d \
+ -directory $tcltkdir tk$useversion]] end]
+ if {$tkdir eq ""} {
+ puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir"
+ exit 1
+ }
+ puts "using Tk source directory $tkdir"
+ }
+
+ puts "verbose messages are [expr {$verbose ? {on} : {off}}]"
+
+ # the title for the man pages overall
+ global overall_title
+ set overall_title ""
+ if {$build_tcl} {
+ append overall_title "[capitalize $tcldir]"
+ }
+ if {$build_tcl && $build_tk} {
+ append overall_title "/"
+ }
+ if {$build_tk} {
+ append overall_title "[capitalize $tkdir]"
+ }
+ append overall_title " Documentation"
+}
+
+proc capitalize {string} {
+ return [string toupper $string 0]
+}
+
+##
+## Returns the style sheet.
+##
+proc css-style args {
+ upvar 1 style style
+ set body [uplevel 1 [list subst [lindex $args end]]]
+ set tokens [join [lrange $args 0 end-1] ", "]
+ append style $tokens " \{" $body "\}\n"
+}
+proc css-stylesheet {} {
+ set hBd "1px dotted #11577b"
+
+ css-style body div p th td li dd ul ol dl dt blockquote {
+ font-family: Verdana, sans-serif;
+ }
+ css-style pre code {
+ font-family: 'Courier New', Courier, monospace;
+ }
+ css-style pre {
+ background-color: #f6fcec;
+ border-top: 1px solid #6A6A6A;
+ border-bottom: 1px solid #6A6A6A;
+ padding: 1em;
+ overflow: auto;
+ }
+ css-style body {
+ background-color: #FFFFFF;
+ font-size: 12px;
+ line-height: 1.25;
+ letter-spacing: .2px;
+ padding-left: .5em;
+ }
+ css-style h1 h2 h3 h4 {
+ font-family: Georgia, serif;
+ padding-left: 1em;
+ margin-top: 1em;
+ }
+ css-style h1 {
+ font-size: 18px;
+ color: #11577b;
+ border-bottom: $hBd;
+ margin-top: 0px;
+ }
+ css-style h2 {
+ font-size: 14px;
+ color: #11577b;
+ background-color: #c5dce8;
+ padding-left: 1em;
+ border: 1px solid #6A6A6A;
+ }
+ css-style h3 h4 {
+ color: #1674A4;
+ background-color: #e8f2f6;
+ border-bottom: $hBd;
+ border-top: $hBd;
+ }
+ css-style h3 {
+ font-size: 12px;
+ }
+ css-style h4 {
+ font-size: 11px;
+ }
+ css-style ".keylist dt" ".arguments dt" {
+ width: 20em;
+ float: left;
+ padding: 2px;
+ border-top: 1px solid #999;
+ }
+ css-style ".keylist dt" { font-weight: bold; }
+ css-style ".keylist dd" ".arguments dd" {
+ margin-left: 20em;
+ padding: 2px;
+ border-top: 1px solid #999;
+ }
+ css-style .copy {
+ background-color: #f6fcfc;
+ white-space: pre;
+ font-size: 80%;
+ border-top: 1px solid #6A6A6A;
+ margin-top: 2em;
+ }
+ css-style .tablecell {
+ font-size: 12px;
+ padding-left: .5em;
+ padding-right: .5em;
+ }
+}
+
+##
+## foreach of the man directories specified by args
+## convert manpages into hypertext in the directory
+## specified by html.
+##
+proc make-man-pages {html args} {
+ global manual overall_title tcltkdesc verbose
+ global excluded_pages forced_index_pages process_first_patterns
+
+ makedirhier $html
+ set cssfd [open $html/$::CSSFILE w]
+ puts $cssfd [css-stylesheet]
+ close $cssfd
+ set manual(short-toc-n) 1
+ set manual(short-toc-fp) [open $html/[indexfile] w]
+ puts $manual(short-toc-fp) [htmlhead $overall_title $overall_title]
+ puts $manual(short-toc-fp) "<DL class=\"keylist\">"
+ set manual(merge-copyrights) {}
+
+ foreach arg $args {
+ # preprocess to set up subheader for the rest of the files
+ if {![llength $arg]} {
+ continue
+ }
+ lassign $arg -> name file
+ if {[regexp {(.*)(?: Package)? Commands(?:, version .*)?} $name -> pkg]} {
+ set name "$pkg Commands"
+ } elseif {[regexp {(.*)(?: Package)? C API(?:, version .*)?} $name -> pkg]} {
+ set name "$pkg C API"
+ }
+ lappend manual(subheader) $name $file
+ }
+
+ ##
+ ## parse the manpages in a section of the docs (split by
+ ## package) and construct formatted manpages
+ ##
+ foreach arg $args {
+ if {[llength $arg]} {
+ make-manpage-section $html $arg
+ }
+ }
+
+ ##
+ ## build the keyword index.
+ ##
+ if {!$verbose} {
+ puts stderr "Assembling index"
+ }
+ file delete -force -- $html/Keywords
+ makedirhier $html/Keywords
+ set keyfp [open $html/Keywords/[indexfile] w]
+ puts $keyfp [htmlhead "$tcltkdesc Keywords" "$tcltkdesc Keywords" \
+ $overall_title "../[indexfile]"]
+ set letters {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z}
+ # Create header first
+ set keyheader {}
+ foreach a $letters {
+ set keys [array names manual "keyword-\[[string totitle $a$a]\]*"]
+ if {[llength $keys]} {
+ lappend keyheader "<A HREF=\"$a.htm\">$a</A>"
+ } else {
+ # No keywords for this letter
+ lappend keyheader $a
+ }
+ }
+ set keyheader <H3>[join $keyheader " |\n"]</H3>
+ puts $keyfp $keyheader
+ foreach a $letters {
+ set keys [array names manual "keyword-\[[string totitle $a$a]\]*"]
+ if {![llength $keys]} {
+ continue
+ }
+ # Per-keyword page
+ set afp [open $html/Keywords/$a.htm w]
+ puts $afp [htmlhead "$tcltkdesc Keywords - $a" \
+ "$tcltkdesc Keywords - $a" \
+ $overall_title "../[indexfile]"]
+ puts $afp $keyheader
+ puts $afp "<DL class=\"keylist\">"
+ foreach k [lsort -dictionary $keys] {
+ set k [string range $k 8 end]
+ puts $afp "<DT><A NAME=\"$k\">$k</A></DT>"
+ puts $afp "<DD>"
+ set refs {}
+ foreach man $manual(keyword-$k) {
+ set name [lindex $man 0]
+ set file [lindex $man 1]
+ if {[info exists manual(tooltip-$file)]} {
+ set tooltip $manual(tooltip-$file)
+ if {[string match {*[<>""]*} $tooltip]} {
+ manerror "bad tooltip for $file: \"$tooltip\""
+ }
+ lappend refs "<A HREF=\"../$file\" TITLE=\"$tooltip\">$name</A>"
+ } else {
+ lappend refs "<A HREF=\"../$file\">$name</A>"
+ }
+ }
+ puts $afp "[join $refs {, }]</DD>"
+ }
+ puts $afp "</DL>"
+ # insert merged copyrights
+ puts $afp [copyout $manual(merge-copyrights)]
+ puts $afp "</BODY></HTML>"
+ close $afp
+ }
+ # insert merged copyrights
+ puts $keyfp [copyout $manual(merge-copyrights)]
+ puts $keyfp "</BODY></HTML>"
+ close $keyfp
+
+ ##
+ ## finish off short table of contents
+ ##
+ puts $manual(short-toc-fp) "<DT><A HREF=\"Keywords/[indexfile]\">Keywords</A><DD>The keywords from the $tcltkdesc man pages."
+ puts $manual(short-toc-fp) "</DL>"
+ # insert merged copyrights
+ puts $manual(short-toc-fp) [copyout $manual(merge-copyrights)]
+ puts $manual(short-toc-fp) "</BODY></HTML>"
+ close $manual(short-toc-fp)
+
+ ##
+ ## output man pages
+ ##
+ unset manual(section)
+ if {!$verbose} {
+ puts stderr "Rescanning [llength $manual(all-pages)] pages to build cross links and write out"
+ }
+ foreach path $manual(all-pages) wing_name $manual(all-page-domains) {
+ set manual(wing-file) [file dirname $path]
+ set manual(tail) [file tail $path]
+ set manual(name) [file root $manual(tail)]
+ try {
+ set text $manual(output-$manual(wing-file)-$manual(name))
+ set ntext 0
+ foreach item $text {
+ incr ntext [llength [split $item \n]]
+ incr ntext
+ }
+ set toc $manual(toc-$manual(wing-file)-$manual(name))
+ set ntoc 0
+ foreach item $toc {
+ incr ntoc [llength [split $item \n]]
+ incr ntoc
+ }
+ if {$verbose} {
+ puts stderr "rescanning page $manual(name) $ntoc/$ntext"
+ } else {
+ puts -nonewline stderr .
+ }
+ set outfd [open $html/$manual(wing-file)/$manual(name).htm w]
+ puts $outfd [htmlhead "$manual($manual(wing-file)-$manual(name)-title)" \
+ $manual(name) $wing_name "[indexfile]" \
+ $overall_title "../[indexfile]"]
+ if {($ntext > 60) && ($ntoc > 32)} {
+ foreach item $toc {
+ puts $outfd $item
+ }
+ } elseif {$manual(name) in $forced_index_pages} {
+ if {!$verbose} {puts stderr ""}
+ manerror "forcing index generation"
+ foreach item $toc {
+ puts $outfd $item
+ }
+ }
+ foreach item $text {
+ puts $outfd [insert-cross-references $item]
+ }
+ puts $outfd "</BODY></HTML>"
+ } on error msg {
+ if {$verbose} {
+ puts stderr $msg
+ } else {
+ puts stderr "\nError when processing $manual(name): $msg"
+ }
+ } finally {
+ catch {close $outfd}
+ }
+ }
+ if {!$verbose} {
+ puts stderr "\nDone"
+ }
+ return {}
+}
+
+##
+## Helper for assembling the descriptions of base packages (i.e., Tcl and Tk).
+##
+proc plus-base {var root glob name dir desc} {
+ global tcltkdir
+ if {$var} {
+ if {[file exists $tcltkdir/$root/README]} {
+ set f [open $tcltkdir/$root/README]
+ set d [read $f]
+ close $f
+ if {[regexp {This is the \w+ (\S+) source distribution} $d -> version]} {
+ append name ", version $version"
+ }
+ }
+ set glob $root/$glob
+ return [list $tcltkdir/$glob $name $dir $desc]
+ }
+}
+
+##
+## Helper for assembling the descriptions of contributed packages.
+##
+proc plus-pkgs {type args} {
+ global build_tcl tcltkdir tcldir
+ if {$type ni {n 3}} {
+ error "unknown type \"$type\": must be 3 or n"
+ }
+ if {!$build_tcl} return
+ set result {}
+ set pkgsdir $tcltkdir/$tcldir/pkgs
+ foreach {dir name version} $args {
+ set globpat $pkgsdir/$dir/doc/*.$type
+ if {![llength [glob -type f -nocomplain $globpat]]} {
+ # Fallback for manpages generated using doctools
+ set globpat $pkgsdir/$dir/doc/man/*.$type
+ if {![llength [glob -type f -nocomplain $globpat]]} {
+ continue
+ }
+ }
+ set dir [string trimright $dir "0123456789-."]
+ switch $type {
+ n {
+ set title "$name Package Commands"
+ if {$version ne ""} {
+ append title ", version $version"
+ }
+ set dir [string totitle $dir]Cmd
+ set desc \
+ "The additional commands provided by the $name package."
+ }
+ 3 {
+ set title "$name Package C API"
+ if {$version ne ""} {
+ append title ", version $version"
+ }
+ set dir [string totitle $dir]Lib
+ set desc \
+ "The additional C functions provided by the $name package."
+ }
+ }
+ lappend result [list $globpat $title $dir $desc]
+ }
+ return $result
+}
+
+##
+## Set up some special cases. It would be nice if we didn't have them,
+## but we do...
+##
+set excluded_pages {case menubar pack-old}
+set forced_index_pages {GetDash}
+set process_first_patterns {*/ttk_widget.n */options.n}
+set ensemble_commands {
+ after array binary chan clock dde dict encoding file history info interp
+ memory namespace package registry self string trace update zlib
+ clipboard console font grab grid image option pack place selection tk
+ tkwait ttk::style winfo wm itcl::delete itcl::find itcl::is
+}
+array set remap_link_target {
+ stdin Tcl_GetStdChannel
+ stdout Tcl_GetStdChannel
+ stderr Tcl_GetStdChannel
+ style ttk::style
+ {style map} ttk::style
+ {tk busy} busy
+ library auto_execok
+ safe-tcl safe
+ tclvars env
+ tcl_break catch
+ tcl_continue catch
+ tcl_error catch
+ tcl_ok catch
+ tcl_return catch
+ int() mathfunc
+ wide() mathfunc
+ packagens pkg::create
+ pkgMkIndex pkg_mkIndex
+ pkg_mkIndex pkg_mkIndex
+ Tcl_Obj Tcl_NewObj
+ Tcl_ObjType Tcl_RegisterObjType
+ Tcl_OpenFileChannelProc Tcl_FSOpenFileChannel
+ errorinfo env
+ errorcode env
+ tcl_pkgpath env
+ Tcl_Command Tcl_CreateObjCommand
+ Tcl_CmdProc Tcl_CreateObjCommand
+ Tcl_CmdDeleteProc Tcl_CreateObjCommand
+ Tcl_ObjCmdProc Tcl_CreateObjCommand
+ Tcl_Channel Tcl_OpenFileChannel
+ Tcl_WideInt Tcl_NewIntObj
+ Tcl_ChannelType Tcl_CreateChannel
+ Tcl_DString Tcl_DStringInit
+ Tcl_Namespace Tcl_AppendExportList
+ Tcl_Object Tcl_NewObjectInstance
+ Tcl_Class Tcl_GetObjectAsClass
+ Tcl_Event Tcl_QueueEvent
+ Tcl_Time Tcl_GetTime
+ Tcl_ThreadId Tcl_CreateThread
+ Tk_Window Tk_WindowId
+ Tk_3DBorder Tk_Get3DBorder
+ Tk_Anchor Tk_GetAnchor
+ Tk_Cursor Tk_GetCursor
+ Tk_Dash Tk_GetDash
+ Tk_Font Tk_GetFont
+ Tk_Image Tk_GetImage
+ Tk_ImageMaster Tk_GetImage
+ Tk_ItemType Tk_CreateItemType
+ Tk_Justify Tk_GetJustify
+ Ttk_Theme Ttk_GetTheme
+}
+array set exclude_refs_map {
+ bind.n {button destroy option}
+ clock.n {next}
+ history.n {exec}
+ next.n {unknown}
+ zlib.n {binary close filename text}
+ canvas.n {bitmap text}
+ console.n {eval}
+ checkbutton.n {image}
+ clipboard.n {string}
+ entry.n {string}
+ event.n {return}
+ font.n {menu}
+ getOpenFile.n {file open text}
+ grab.n {global}
+ interp.n {time}
+ menu.n {checkbutton radiobutton}
+ messageBox.n {error info}
+ options.n {bitmap image set}
+ radiobutton.n {image}
+ safe.n {join split}
+ scale.n {label variable}
+ scrollbar.n {set}
+ selection.n {string}
+ tcltest.n {error}
+ tkvars.n {tk}
+ tkwait.n {variable}
+ tm.n {exec}
+ ttk_checkbutton.n {variable}
+ ttk_combobox.n {selection}
+ ttk_entry.n {focus variable}
+ ttk_intro.n {focus text}
+ ttk_label.n {font text}
+ ttk_labelframe.n {text}
+ ttk_menubutton.n {flush}
+ ttk_notebook.n {image text}
+ ttk_progressbar.n {variable}
+ ttk_radiobutton.n {variable}
+ ttk_scale.n {variable}
+ ttk_scrollbar.n {set}
+ ttk_spinbox.n {format}
+ ttk_treeview.n {text open}
+ ttk_widget.n {image text variable}
+ TclZlib.3 {binary flush filename text}
+}
+array set exclude_when_followed_by_map {
+ canvas.n {
+ bind widget
+ focus widget
+ image are
+ lower widget
+ raise widget
+ }
+ selection.n {
+ clipboard selection
+ clipboard ;
+ }
+ ttk_image.n {
+ image imageSpec
+ }
+ fontchooser.n {
+ tk fontchooser
+ }
+}
+
+try {
+ # Parse what the user told us to do
+ parse_command_line
+
+ # Some strings depend on what options are specified
+ set tcltkdesc ""; set cmdesc ""; set appdir ""
+ if {$build_tcl} {
+ append tcltkdesc "Tcl"
+ append cmdesc "Tcl"
+ append appdir "$tcldir"
+ }
+ if {$build_tcl && $build_tk} {
+ append tcltkdesc "/"
+ append cmdesc " and "
+ append appdir ","
+ }
+ if {$build_tk} {
+ append tcltkdesc "Tk"
+ append cmdesc "Tk"
+ append appdir "$tkdir"
+ }
+
+ apply {{} {
+ global packageBuildList tcltkdir tcldir build_tcl
+
+ # When building docs for Tcl, try to build docs for bundled packages too
+ set packageBuildList {}
+ if {$build_tcl} {
+ set pkgsDir [file join $tcltkdir $tcldir pkgs]
+ set subdirs [glob -nocomplain -types d -tails -directory $pkgsDir *]
+
+ foreach dir [lsort $subdirs] {
+ # Parse the subdir name into (name, version) as fallback...
+ set description [split $dir -]
+ if {2 != [llength $description]} {
+ regexp {([^0-9]*)(.*)} $dir -> n v
+ set description [list $n $v]
+ }
+
+ # ... but try to extract (name, version) from subdir contents
+ try {
+ try {
+ set f [open [file join $pkgsDir $dir configure.in]]
+ } trap {POSIX ENOENT} {} {
+ set f [open [file join $pkgsDir $dir configure.ac]]
+ }
+ foreach line [split [read $f] \n] {
+ if {2 == [scan $line \
+ { AC_INIT ( [%[^]]] , [%[^]]] ) } n v]} {
+ set description [list $n $v]
+ break
+ }
+ }
+ } finally {
+ catch {close $f; unset f}
+ }
+
+ if {[file exists [file join $pkgsDir $dir configure]]} {
+ # Looks like a package, record our best extraction attempt
+ lappend packageBuildList $dir {*}$description
+ }
+ }
+ }
+
+ # Get the list of packages to try, and what their human-readable names
+ # are. Note that the package directory list should be version-less.
+ try {
+ set packageDirNameMap {}
+ if {$build_tcl} {
+ set f [open $tcltkdir/$tcldir/pkgs/package.list.txt]
+ try {
+ foreach line [split [read $f] \n] {
+ if {[string trim $line] eq ""} continue
+ if {[string match #* $line]} continue
+ lassign $line dir name
+ lappend packageDirNameMap $dir $name
+ }
+ } finally {
+ close $f
+ }
+ }
+ } trap {POSIX ENOENT} {} {
+ set packageDirNameMap {
+ itcl {[incr Tcl]}
+ tdbc {TDBC}
+ thread Thread
+ }
+ }
+
+ # Convert to human readable names, if applicable
+ for {set idx 0} {$idx < [llength $packageBuildList]} {incr idx 3} {
+ lassign [lrange $packageBuildList $idx $idx+2] d n v
+ if {[dict exists $packageDirNameMap $n]} {
+ lset packageBuildList $idx+1 [dict get $packageDirNameMap $n]
+ }
+ }
+ }}
+
+ #
+ # Invoke the scraper/converter engine.
+ #
+ make-man-pages $webdir \
+ [list $tcltkdir/{$appdir}/doc/*.1 "$tcltkdesc Applications" UserCmd \
+ "The interpreters which implement $cmdesc."] \
+ [plus-base $build_tcl $tcldir doc/*.n {Tcl Commands} TclCmd \
+ "The commands which the <B>tclsh</B> interpreter implements."] \
+ [plus-base $build_tk $tkdir doc/*.n {Tk Commands} TkCmd \
+ "The additional commands which the <B>wish</B> interpreter implements."] \
+ {*}[plus-pkgs n {*}$packageBuildList] \
+ [plus-base $build_tcl $tcldir doc/*.3 {Tcl C API} TclLib \
+ "The C functions which a Tcl extended C program may use."] \
+ [plus-base $build_tk $tkdir doc/*.3 {Tk C API} TkLib \
+ "The additional C functions which a Tk extended C program may use."] \
+ {*}[plus-pkgs 3 {*}$packageBuildList]
+} on error {msg opts} {
+ # On failure make sure we show what went wrong. We're not supposed
+ # to get here though; it represents a bug in the script.
+ puts $msg\n[dict get $opts -errorinfo]
+ exit 1
+}
+
+# Local-Variables:
+# mode: tcl
+# End:
diff --git a/tcl8.6/tools/tsdPerf.tcl b/tcl8.6/tools/tsdPerf.tcl
new file mode 100644
index 0000000..360ca9c
--- /dev/null
+++ b/tcl8.6/tools/tsdPerf.tcl
@@ -0,0 +1,24 @@
+
+package require Thread
+
+set ::tids [list]
+for {set i 0} {$i < 4} {incr i} {
+ lappend ::tids [thread::create [string map [list IVALUE $i] {
+ set curdir [file dirname [info script]]
+ load [file join $curdir tsdPerf[info sharedlibextension]]
+
+ while 1 {
+ tsdPerfSet IVALUE
+ }
+ }]]
+}
+
+puts TIDS:$::tids
+
+set curdir [file dirname [info script]]
+load [file join $curdir tsdPerf[info sharedlibextension]]
+
+tsdPerfSet 1234
+while 1 {
+ puts "TIME:[time {set value [tsdPerfGet]} 1000] VALUE:$value"
+}
diff --git a/tcl8.6/tools/uniClass.tcl b/tcl8.6/tools/uniClass.tcl
new file mode 100644
index 0000000..9b4819d
--- /dev/null
+++ b/tcl8.6/tools/uniClass.tcl
@@ -0,0 +1,130 @@
+#!/bin/sh
+# The next line is executed by /bin/sh, but not tcl \
+exec tclsh "$0" ${1+"$@"}
+
+#
+# uniClass.tcl --
+#
+# Generates the character ranges and singletons that are used in
+# generic/regc_locale.c for translation of character classes.
+# This file must be generated using a tclsh that contains the
+# correct corresponding tclUniData.c file (generated by uniParse.tcl)
+# in order for the class ranges to match.
+#
+
+proc emitRange {first last} {
+ global ranges numranges chars numchars extchars extranges
+
+ if {$first < ($last-1)} {
+ if {!$extranges && ($first) > 0xffff} {
+ set extranges 1
+ set numranges 0
+ set ranges [string trimright $ranges " \n\r\t,"]
+ append ranges "\n#if TCL_UTF_MAX > 4\n ,"
+ }
+ append ranges [format "{0x%x, 0x%x}, " \
+ $first $last]
+ if {[incr numranges] % 4 == 0} {
+ set ranges [string trimright $ranges]
+ append ranges "\n "
+ }
+ } else {
+ if {!$extchars && ($first) > 0xffff} {
+ set extchars 1
+ set numchars 0
+ set chars [string trimright $chars " \n\r\t,"]
+ append chars "\n#if TCL_UTF_MAX > 4\n ,"
+ }
+ append chars [format "0x%x, " $first]
+ incr numchars
+ if {$numchars % 9 == 0} {
+ set chars [string trimright $chars]
+ append chars "\n "
+ }
+ if {$first != $last} {
+ append chars [format "0x%x, " $last]
+ incr numchars
+ if {$numchars % 9 == 0} {
+ append chars "\n "
+ }
+ }
+ }
+}
+
+proc genTable {type} {
+ global first last ranges numranges chars numchars extchars extranges
+ set first -2
+ set last -2
+
+ set ranges " "
+ set numranges 0
+ set chars " "
+ set numchars 0
+ set extchars 0
+ set extranges 0
+
+ for {set i 0} {$i <= 0x10ffff} {incr i} {
+ if {$i == 0xd800} {
+ # Skip surrogates
+ set i 0xdc00
+ }
+ if {[string is $type [format %c $i]]} {
+ if {$i == ($last + 1)} {
+ set last $i
+ } else {
+ if {$first >= 0} {
+ emitRange $first $last
+ }
+ set first $i
+ set last $i
+ }
+ }
+ }
+ emitRange $first $last
+
+ set ranges [string trimright $ranges "\t\n ,"]
+ if {$extranges} {
+ append ranges "\n#endif"
+ }
+ set chars [string trimright $chars "\t\n ,"]
+ if {$extchars} {
+ append chars "\n#endif"
+ }
+ if {$ranges ne ""} {
+ puts "static const crange ${type}RangeTable\[\] = {\n$ranges\n};\n"
+ puts "#define NUM_[string toupper $type]_RANGE (sizeof(${type}RangeTable)/sizeof(crange))\n"
+ } else {
+ puts "/* no contiguous ranges of $type characters */\n"
+ }
+ if {$chars ne ""} {
+ puts "static const chr ${type}CharTable\[\] = {\n$chars\n};\n"
+ puts "#define NUM_[string toupper $type]_CHAR (sizeof(${type}CharTable)/sizeof(chr))\n"
+ } else {
+ puts "/*\n * no singletons of $type characters.\n */\n"
+ }
+}
+
+puts "/*
+ * Declarations of Unicode character ranges. This code
+ * is automatically generated by the tools/uniClass.tcl script
+ * and used in generic/regc_locale.c. Do not modify by hand.
+ */
+"
+
+foreach {type desc} {
+ alpha "alphabetic characters"
+ control "control characters"
+ digit "decimal digit characters"
+ punct "punctuation characters"
+ space "white space characters"
+ lower "lowercase characters"
+ upper "uppercase characters"
+ graph "unicode print characters excluding space"
+} {
+ puts "/*\n * Unicode: $desc.\n */\n"
+ genTable $type
+}
+
+puts "/*
+ * End of auto-generated Unicode character ranges declarations.
+ */"
diff --git a/tcl8.6/tools/uniParse.tcl b/tcl8.6/tools/uniParse.tcl
new file mode 100644
index 0000000..8125790
--- /dev/null
+++ b/tcl8.6/tools/uniParse.tcl
@@ -0,0 +1,411 @@
+# uniParse.tcl --
+#
+# This program parses the UnicodeData file and generates the
+# corresponding tclUniData.c file with compressed character
+# data tables. The input to this program should be the latest
+# UnicodeData file from:
+# ftp://ftp.unicode.org/Public/UNIDATA/UnicodeData.txt
+#
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+
+namespace eval uni {
+ set shift 5; # number of bits of data within a page
+ # This value can be adjusted to find the
+ # best split to minimize table size
+
+ variable pMap; # map from page to page index, each entry is
+ # an index into the pages table, indexed by
+ # page number
+ variable pages; # map from page index to page info, each
+ # entry is a list of indices into the groups
+ # table, the list is indexed by the offset
+ variable groups; # list of character info values, indexed by
+ # group number, initialized with the
+ # unassigned character group
+
+ variable categories {
+ Cn Lu Ll Lt Lm Lo Mn Me Mc Nd Nl No Zs Zl Zp
+ Cc Cf Co Cs Pc Pd Ps Pe Pi Pf Po Sm Sc Sk So
+ }; # Ordered list of character categories, must
+ # match the enumeration in the header file.
+}
+
+proc uni::getValue {items index} {
+ variable categories
+
+ # Extract character info
+
+ set category [lindex $items 2]
+ if {[scan [lindex $items 12] %x toupper] == 1} {
+ set toupper [expr {$index - $toupper}]
+ } else {
+ set toupper 0
+ }
+ if {[scan [lindex $items 13] %x tolower] == 1} {
+ set tolower [expr {$tolower - $index}]
+ } else {
+ set tolower 0
+ }
+ if {[scan [lindex $items 14] %x totitle] == 1} {
+ set totitle [expr {$index - $totitle}]
+ } elseif {$tolower} {
+ set totitle 0
+ } else {
+ set totitle $toupper
+ }
+
+ set categoryIndex [lsearch -exact $categories $category]
+ if {$categoryIndex < 0} {
+ error "Unexpected character category: $index($category)"
+ }
+
+ return [list $categoryIndex $toupper $tolower $totitle]
+}
+
+proc uni::getGroup {value} {
+ variable groups
+
+ set gIndex [lsearch -exact $groups $value]
+ if {$gIndex == -1} {
+ set gIndex [llength $groups]
+ lappend groups $value
+ }
+ return $gIndex
+}
+
+proc uni::addPage {info} {
+ variable pMap
+ variable pages
+ variable shift
+
+ set pIndex [lsearch -exact $pages $info]
+ if {$pIndex == -1} {
+ set pIndex [llength $pages]
+ lappend pages $info
+ }
+ lappend pMap [expr {$pIndex << $shift}]
+ return
+}
+
+proc uni::buildTables {data} {
+ variable shift
+
+ variable pMap {}
+ variable pages {}
+ variable groups {{0 0 0 0}}
+ variable next 0
+ set info {} ;# temporary page info
+
+ set mask [expr {(1 << $shift) - 1}]
+
+ foreach line [split $data \n] {
+ if {$line eq ""} {
+ if {!($next & $mask)} {
+ # next character is already on page boundary
+ continue
+ }
+ # fill remaining page
+ set line [format %X [expr {($next-1)|$mask}]]
+ append line ";;Cn;0;ON;;;;;N;;;;;\n"
+ }
+
+ set items [split $line \;]
+
+ scan [lindex $items 0] %x index
+ if {$index > 0x2ffff} then {
+ # Ignore non-BMP characters, as long as Tcl doesn't support them
+ continue
+ }
+ set index [format %d $index]
+
+ set gIndex [getGroup [getValue $items $index]]
+
+ # Since the input table omits unassigned characters, these will
+ # show up as gaps in the index sequence. There are a few special cases
+ # where the gaps correspond to a uniform block of assigned characters.
+ # These are indicated as such in the character name.
+
+ # Enter all unassigned characters up to the current character.
+ if {($index > $next) \
+ && ![regexp "Last>$" [lindex $items 1]]} {
+ for {} {$next < $index} {incr next} {
+ lappend info 0
+ if {($next & $mask) == $mask} {
+ addPage $info
+ set info {}
+ }
+ }
+ }
+
+ # Enter all assigned characters up to the current character
+ for {set i $next} {$i <= $index} {incr i} {
+ # Add the group index to the info for the current page
+ lappend info $gIndex
+
+ # If this is the last entry in the page, add the page
+ if {($i & $mask) == $mask} {
+ addPage $info
+ set info {}
+ }
+ }
+ set next [expr {$index + 1}]
+ }
+ return
+}
+
+proc uni::main {} {
+ global argc argv0 argv
+ variable pMap
+ variable pages
+ variable groups
+ variable shift
+ variable next
+
+ if {$argc != 2} {
+ puts stderr "\nusage: $argv0 <datafile> <outdir>\n"
+ exit 1
+ }
+ set f [open [lindex $argv 0] r]
+ set data [read $f]
+ close $f
+
+ buildTables $data
+ puts "X = [llength $pMap] Y= [llength $pages] A= [llength $groups]"
+ set size [expr {[llength $pMap]*2 + ([llength $pages]<<$shift)}]
+ puts "shift = $shift, space = $size"
+
+ set f [open [file join [lindex $argv 1] tclUniData.c] w]
+ fconfigure $f -translation lf
+ puts $f "/*
+ * tclUniData.c --
+ *
+ * Declarations of Unicode character information tables. This file is
+ * automatically generated by the tools/uniParse.tcl script. Do not
+ * modify this file by hand.
+ *
+ * Copyright (c) 1998 by Scriptics Corporation.
+ * All rights reserved.
+ */
+
+/*
+ * A 16-bit Unicode character is split into two parts in order to index
+ * into the following tables. The lower OFFSET_BITS comprise an offset
+ * into a page of characters. The upper bits comprise the page number.
+ */
+
+#define OFFSET_BITS $shift
+
+/*
+ * The pageMap is indexed by page number and returns an alternate page number
+ * that identifies a unique page of characters. Many Unicode characters map
+ * to the same alternate page number.
+ */
+
+static const unsigned short pageMap\[\] = {"
+ set line " "
+ set last [expr {[llength $pMap] - 1}]
+ for {set i 0} {$i <= $last} {incr i} {
+ if {$i == [expr {0x10000 >> $shift}]} {
+ set line [string trimright $line " \t,"]
+ puts $f $line
+ set lastpage [expr {[lindex $line end] >> $shift}]
+ puts stdout "lastpage: $lastpage"
+ puts $f "#if TCL_UTF_MAX > 3"
+ set line " ,"
+ }
+ append line [lindex $pMap $i]
+ if {$i != $last} {
+ append line ", "
+ }
+ if {[string length $line] > 70} {
+ puts $f [string trimright $line]
+ set line " "
+ }
+ }
+ puts $f $line
+ puts $f "#endif /* TCL_UTF_MAX > 3 */"
+ puts $f "};
+
+/*
+ * The groupMap is indexed by combining the alternate page number with
+ * the page offset and returns a group number that identifies a unique
+ * set of character attributes.
+ */
+
+static const unsigned char groupMap\[\] = {"
+ set line " "
+ set lasti [expr {[llength $pages] - 1}]
+ for {set i 0} {$i <= $lasti} {incr i} {
+ set page [lindex $pages $i]
+ set lastj [expr {[llength $page] - 1}]
+ if {$i == ($lastpage + 1)} {
+ puts $f [string trimright $line " \t,"]
+ puts $f "#if TCL_UTF_MAX > 3"
+ set line " ,"
+ }
+ for {set j 0} {$j <= $lastj} {incr j} {
+ append line [lindex $page $j]
+ if {$j != $lastj || $i != $lasti} {
+ append line ", "
+ }
+ if {[string length $line] > 70} {
+ puts $f [string trimright $line]
+ set line " "
+ }
+ }
+ }
+ puts $f $line
+ puts $f "#endif /* TCL_UTF_MAX > 3 */"
+ puts $f "};
+
+/*
+ * Each group represents a unique set of character attributes. The attributes
+ * are encoded into a 32-bit value as follows:
+ *
+ * Bits 0-4 Character category: see the constants listed below.
+ *
+ * Bits 5-7 Case delta type: 000 = identity
+ * 010 = add delta for lower
+ * 011 = add delta for lower, add 1 for title
+ * 100 = subtract delta for title/upper
+ * 101 = sub delta for upper, sub 1 for title
+ * 110 = sub delta for upper, add delta for lower
+ *
+ * Bits 8-31 Case delta: delta for case conversions. This should be the
+ * highest field so we can easily sign extend.
+ */
+
+static const int groups\[\] = {"
+ set line " "
+ set last [expr {[llength $groups] - 1}]
+ for {set i 0} {$i <= $last} {incr i} {
+ foreach {type toupper tolower totitle} [lindex $groups $i] {}
+
+ # Compute the case conversion type and delta
+
+ if {$totitle} {
+ if {$totitle == $toupper} {
+ # subtract delta for title or upper
+ set case 4
+ set delta $toupper
+ if {$tolower} {
+ error "New case conversion type needed: $toupper $tolower $totitle"
+ }
+ } elseif {$toupper} {
+ # subtract delta for upper, subtract 1 for title
+ set case 5
+ set delta $toupper
+ if {($totitle != 1) || $tolower} {
+ error "New case conversion type needed: $toupper $tolower $totitle"
+ }
+ } else {
+ # add delta for lower, add 1 for title
+ set case 3
+ set delta $tolower
+ if {$totitle != -1} {
+ error "New case conversion type needed: $toupper $tolower $totitle"
+ }
+ }
+ } elseif {$toupper} {
+ # subtract delta for upper, add delta for lower
+ set case 6
+ set delta $toupper
+ if {$tolower != $toupper} {
+ error "New case conversion type needed: $toupper $tolower $totitle"
+ }
+ } elseif {$tolower} {
+ # add delta for lower
+ set case 2
+ set delta $tolower
+ } else {
+ # noop
+ set case 0
+ set delta 0
+ }
+
+ append line [expr {($delta << 8) | ($case << 5) | $type}]
+ if {$i != $last} {
+ append line ", "
+ }
+ if {[string length $line] > 65} {
+ puts $f [string trimright $line]
+ set line " "
+ }
+ }
+ puts $f $line
+ puts -nonewline $f "};
+
+#if TCL_UTF_MAX > 3
+# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1fffff) >= [format 0x%x $next])
+#else
+# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1f0000) != 0)
+#endif
+
+/*
+ * The following constants are used to determine the category of a
+ * Unicode character.
+ */
+
+enum {
+ UNASSIGNED,
+ UPPERCASE_LETTER,
+ LOWERCASE_LETTER,
+ TITLECASE_LETTER,
+ MODIFIER_LETTER,
+ OTHER_LETTER,
+ NON_SPACING_MARK,
+ ENCLOSING_MARK,
+ COMBINING_SPACING_MARK,
+ DECIMAL_DIGIT_NUMBER,
+ LETTER_NUMBER,
+ OTHER_NUMBER,
+ SPACE_SEPARATOR,
+ LINE_SEPARATOR,
+ PARAGRAPH_SEPARATOR,
+ CONTROL,
+ FORMAT,
+ PRIVATE_USE,
+ SURROGATE,
+ CONNECTOR_PUNCTUATION,
+ DASH_PUNCTUATION,
+ OPEN_PUNCTUATION,
+ CLOSE_PUNCTUATION,
+ INITIAL_QUOTE_PUNCTUATION,
+ FINAL_QUOTE_PUNCTUATION,
+ OTHER_PUNCTUATION,
+ MATH_SYMBOL,
+ CURRENCY_SYMBOL,
+ MODIFIER_SYMBOL,
+ OTHER_SYMBOL
+};
+
+/*
+ * The following macros extract the fields of the character info. The
+ * GetDelta() macro is complicated because we can't rely on the C compiler
+ * to do sign extension on right shifts.
+ */
+
+#define GetCaseType(info) (((info) & 0xe0) >> 5)
+#define GetCategory(ch) (GetUniCharInfo(ch) & 0x1f)
+#define GetDelta(info) ((info) >> 8)
+
+/*
+ * This macro extracts the information about a character from the
+ * Unicode character tables.
+ */
+
+#if TCL_UTF_MAX > 3
+# define GetUniCharInfo(ch) (groups\[groupMap\[pageMap\[((ch) & 0x1fffff) >> OFFSET_BITS\] | ((ch) & ((1 << OFFSET_BITS)-1))\]\])
+#else
+# define GetUniCharInfo(ch) (groups\[groupMap\[pageMap\[((ch) & 0xffff) >> OFFSET_BITS\] | ((ch) & ((1 << OFFSET_BITS)-1))\]\])
+#endif
+"
+
+ close $f
+}
+
+uni::main
+
+return
diff --git a/tcl8.6/tools/white.bmp b/tcl8.6/tools/white.bmp
new file mode 100644
index 0000000..210bc52
--- /dev/null
+++ b/tcl8.6/tools/white.bmp
Binary files differ