diff options
Diffstat (limited to 'tcl8.6/tools')
30 files changed, 0 insertions, 14046 deletions
diff --git a/tcl8.6/tools/Makefile.in b/tcl8.6/tools/Makefile.in deleted file mode 100644 index 5e9f88e..0000000 --- a/tcl8.6/tools/Makefile.in +++ /dev/null @@ -1,67 +0,0 @@ -# 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 deleted file mode 100644 index f4bf627..0000000 --- a/tcl8.6/tools/README +++ /dev/null @@ -1,25 +0,0 @@ -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 deleted file mode 100755 index 6d147ac..0000000 --- a/tcl8.6/tools/checkLibraryDoc.tcl +++ /dev/null @@ -1,293 +0,0 @@ -# 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 deleted file mode 100755 index 3d30039..0000000 --- a/tcl8.6/tools/configure +++ /dev/null @@ -1,2170 +0,0 @@ -#! /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 deleted file mode 100644 index 6aebcaa..0000000 --- a/tcl8.6/tools/configure.in +++ /dev/null @@ -1,35 +0,0 @@ -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 deleted file mode 100644 index 3f35ed4..0000000 --- a/tcl8.6/tools/eolFix.tcl +++ /dev/null @@ -1,80 +0,0 @@ -## 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 differdeleted file mode 100644 index 23aa02e..0000000 --- a/tcl8.6/tools/feather.bmp +++ /dev/null diff --git a/tcl8.6/tools/findBadExternals.tcl b/tcl8.6/tools/findBadExternals.tcl deleted file mode 100755 index 2228357..0000000 --- a/tcl8.6/tools/findBadExternals.tcl +++ /dev/null @@ -1,53 +0,0 @@ -# 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 deleted file mode 100755 index 04bf857..0000000 --- a/tcl8.6/tools/fix_tommath_h.tcl +++ /dev/null @@ -1,102 +0,0 @@ -# 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 deleted file mode 100644 index 9f2c6ca..0000000 --- a/tcl8.6/tools/genStubs.tcl +++ /dev/null @@ -1,1179 +0,0 @@ -# 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 deleted file mode 100644 index 71329c2..0000000 --- a/tcl8.6/tools/index.tcl +++ /dev/null @@ -1,199 +0,0 @@ -# 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 deleted file mode 100644 index 4b43f1e..0000000 --- a/tcl8.6/tools/installData.tcl +++ /dev/null @@ -1,50 +0,0 @@ -#!/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 deleted file mode 100755 index 31f1e54..0000000 --- a/tcl8.6/tools/loadICU.tcl +++ /dev/null @@ -1,619 +0,0 @@ -#---------------------------------------------------------------------- -# -# 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 deleted file mode 100755 index 6cc033b..0000000 --- a/tcl8.6/tools/makeTestCases.tcl +++ /dev/null @@ -1,1180 +0,0 @@ -# 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 deleted file mode 100644 index ca29226..0000000 --- a/tcl8.6/tools/man2help.tcl +++ /dev/null @@ -1,141 +0,0 @@ -# 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 deleted file mode 100644 index 9c8f503..0000000 --- a/tcl8.6/tools/man2help2.tcl +++ /dev/null @@ -1,1033 +0,0 @@ -# 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 deleted file mode 100644 index 2d03ab6..0000000 --- a/tcl8.6/tools/man2html.tcl +++ /dev/null @@ -1,185 +0,0 @@ -#!/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 deleted file mode 100644 index 64982ff..0000000 --- a/tcl8.6/tools/man2html1.tcl +++ /dev/null @@ -1,258 +0,0 @@ -# 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 deleted file mode 100644 index e4ccedf..0000000 --- a/tcl8.6/tools/man2html2.tcl +++ /dev/null @@ -1,927 +0,0 @@ -############################################################################## -# 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 deleted file mode 100644 index 8e59bea..0000000 --- a/tcl8.6/tools/man2tcl.c +++ /dev/null @@ -1,424 +0,0 @@ -/* - * 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 deleted file mode 100644 index ecb2206..0000000 --- a/tcl8.6/tools/mkdepend.tcl +++ /dev/null @@ -1,420 +0,0 @@ -#============================================================================== -# -# 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 deleted file mode 100644 index d84a012..0000000 --- a/tcl8.6/tools/regexpTestLib.tcl +++ /dev/null @@ -1,263 +0,0 @@ -# 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 deleted file mode 100644 index a94cea6..0000000 --- a/tcl8.6/tools/tcl.hpj.in +++ /dev/null @@ -1,19 +0,0 @@ -; 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 deleted file mode 100755 index 85c9ba9..0000000 --- a/tcl8.6/tools/tclZIC.tcl +++ /dev/null @@ -1,1373 +0,0 @@ -#---------------------------------------------------------------------- -# -# 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 deleted file mode 100644 index 9052049..0000000 --- a/tcl8.6/tools/tcltk-man2html-utils.tcl +++ /dev/null @@ -1,1634 +0,0 @@ -## -## 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 deleted file mode 100755 index d607905..0000000 --- a/tcl8.6/tools/tcltk-man2html.tcl +++ /dev/null @@ -1,752 +0,0 @@ -#!/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 deleted file mode 100644 index 360ca9c..0000000 --- a/tcl8.6/tools/tsdPerf.tcl +++ /dev/null @@ -1,24 +0,0 @@ - -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 deleted file mode 100644 index 9b4819d..0000000 --- a/tcl8.6/tools/uniClass.tcl +++ /dev/null @@ -1,130 +0,0 @@ -#!/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 deleted file mode 100644 index 8125790..0000000 --- a/tcl8.6/tools/uniParse.tcl +++ /dev/null @@ -1,411 +0,0 @@ -# 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 differdeleted file mode 100644 index 210bc52..0000000 --- a/tcl8.6/tools/white.bmp +++ /dev/null |
