diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2018-01-02 21:03:49 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2018-01-02 21:03:49 (GMT) |
commit | 914501b5b992e7b6c7e0a4c958712a8ba9cab41c (patch) | |
tree | edbc059b9557d5fdb79e5a5c47889bc54708da53 /tcl8.6/tools | |
parent | f88c190a01bc7f57e79dfaf91a3c0c48c2031549 (diff) | |
download | blt-914501b5b992e7b6c7e0a4c958712a8ba9cab41c.zip blt-914501b5b992e7b6c7e0a4c958712a8ba9cab41c.tar.gz blt-914501b5b992e7b6c7e0a4c958712a8ba9cab41c.tar.bz2 |
upgrade to tcl/tk 8.6.8
Diffstat (limited to 'tcl8.6/tools')
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 Binary files differnew file mode 100644 index 0000000..23aa02e --- /dev/null +++ b/tcl8.6/tools/feather.bmp 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 © 1989-1994 The Regents of the University of California." + lappend f "Copyright © 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 {\&} string + regsub -all {<} $string {\<} string + regsub -all {>} $string {\>} string + regsub -all \" $string {\"} 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 "±" + } + \\% {} ;# \% + \\| { ;# \| + } + 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> © [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 © [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>></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 \ + "–" "–" \ + {&} {&} \ + {\\} "\" \ + {\e} "\" \ + {\ } { } \ + {\|} { } \ + {\0} { } \ + \" {"} \ + {<} {<} \ + {>} {>} \ + \u201c "“" \ + \u201d "”" + + 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" \ + {\(+-} "±" \ + {\(co} "©" \ + {\(em} "—" \ + {\(en} "–" \ + {\(fm} "′" \ + {\(mu} "×" \ + {\(mi} "−" \ + {\(->} "<font size=\"+1\">→</font>" \ + {\fP} {\fR} \ + {\.} . \ + {\(bu} "•" \ + {\*(qo} "ô" \ + ] + 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 "\\" "\"] $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 {"•" 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 {"•" 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 — $tail" + # output line to long table of contents + lappend manual(section-toc) "<DL><DD>$head — $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 {" " " "} $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|©) +(\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 © [lindex $list 0] $who" + } else { + lappend merge "Copyright © [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] "–" \ + [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 Binary files differnew file mode 100644 index 0000000..210bc52 --- /dev/null +++ b/tcl8.6/tools/white.bmp |