Tcl Source Code

			    int *srcReadPtr, int *dstWrotePtr,
			    int *dstCharsPtr);
static int		Iso88591ToUtfProc(ClientData clientData,
			    const char *src, int srcLen, int flags,
			    Tcl_EncodingState *statePtr, char *dst,
			    int dstLen, int *srcReadPtr, int *dstWrotePtr,
			    int *dstCharsPtr);
#if TCL_UTF_MAX > 4
static int		Utf16ToUtfProc(ClientData clientData,
			    const char *src, int srcLen, int flags,
			    Tcl_EncodingState *statePtr, char *dst, int dstLen,
			    int *srcReadPtr, int *dstWrotePtr,
			    int *dstCharsPtr);
static int		UtfToUtf16Proc(ClientData clientData,
			    const char *src, int srcLen, int flags,
			    Tcl_EncodingState *statePtr, char *dst, int dstLen,
			    int *srcReadPtr, int *dstWrotePtr,
			    int *dstCharsPtr);
#endif

/*
 * A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1 field
 * of the intrep. This should help the lifetime of encodings be more useful.
 * See concerns raised in [Bug 1077262].
 */

    type.toUtfProc	= UtfExtToUtfIntProc;
    type.fromUtfProc	= UtfIntToUtfExtProc;
    type.freeProc	= NULL;
    type.nullSize	= 1;
    type.clientData	= NULL;
    Tcl_CreateEncoding(&type);

#if TCL_UTF_MAX > 4
    type.encodingName   = "utf-32";
#else
    type.encodingName   = "unicode";
#endif
    type.toUtfProc	= UnicodeToUtfProc;
    type.fromUtfProc    = UtfToUnicodeProc;
    type.freeProc	= NULL;
#if TCL_UTF_MAX > 4
    type.nullSize	= 4;
#else
    type.nullSize	= 2;
#endif
    type.clientData	= NULL;
    Tcl_CreateEncoding(&type);

#if TCL_UTF_MAX > 4
    type.encodingName   = "unicode";
    type.toUtfProc	= Utf16ToUtfProc;
    type.fromUtfProc    = UtfToUtf16Proc;
    type.freeProc	= NULL;
    type.nullSize	= 2;
    type.clientData	= NULL;
    Tcl_CreateEncoding(&type);
#endif

    /*
     * Need the iso8859-1 encoding in order to process binary data, so force
     * it to always be embedded. Note that this encoding *must* be a proper
     * table encoding or some of the escape encodings crash! Hence the ugly
     * code to duplicate the structure of a table encoding here.
     */

    }

    *srcReadPtr = src - srcStart;
    *dstWrotePtr = dst - dstStart;
    *dstCharsPtr = numChars;
    return result;
}

#if TCL_UTF_MAX > 4
/*
 *-------------------------------------------------------------------------
 *
 * Utf16ToUtfProc --
 *
 *	Convert from UTF-16 to UTF-8.
 *
 * Results:
 *	Returns TCL_OK if conversion was successful.
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
Utf16ToUtfProc(
    ClientData clientData,	/* Not used. */
    const char *src,		/* Source string in Unicode. */
    int srcLen,			/* Source string length in bytes. */
    int flags,			/* Conversion control flags. */
    Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion. Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst,			/* Output buffer in which converted string is
				 * stored. */
    int dstLen,			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr,		/* Filled with the number of bytes from the
				 * source string that were converted. This may
				 * be less than the original source length if
				 * there was a problem converting some source
				 * characters. */
    int *dstWrotePtr,		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */
    int *dstCharsPtr)		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
{
    const char *srcStart, *srcEnd;
    const char *dstEnd, *dstStart;
    int result, numChars, charLimit = INT_MAX;
    Tcl_UniChar ch;

    if (flags & TCL_ENCODING_CHAR_LIMIT) {
	charLimit = *dstCharsPtr;
    }
    result = TCL_OK;
    if ((srcLen % sizeof(unsigned short)) != 0) {
	result = TCL_CONVERT_MULTIBYTE;
	srcLen /= sizeof(unsigned short);
	srcLen *= sizeof(unsigned short);
    }

    srcStart = src;
    srcEnd = src + srcLen;

    dstStart = dst;
    dstEnd = dst + dstLen - sizeof(unsigned short);

    for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
	if (dst > dstEnd) {
	    result = TCL_CONVERT_NOSPACE;
	    break;
	}
	ch = *(unsigned short *)src;
	if (ch && ch < 0x80) {
	    *dst++ = (ch & 0xFF);
	} else if ((ch >= 0xD800) && (ch <= 0xDBFF)) {
	    Tcl_UniChar ch2 = *(unsigned short *)(src + sizeof(unsigned short));

	    if ((ch2 >= 0xDC00) && (ch2 <= 0xDFFF)) {
		ch = ((ch & 0x3FF) << 10) + 0x10000 + (ch2 & 0x3FF);
		src += sizeof(unsigned short);
	    }
	    dst += Tcl_UniCharToUtf(ch, dst);
	} else {
	    dst += Tcl_UniCharToUtf(ch, dst);
	}
	src += sizeof(unsigned short);
    }

    *srcReadPtr = src - srcStart;
    *dstWrotePtr = dst - dstStart;
    *dstCharsPtr = numChars;
    return result;
}
#endif

#if TCL_UTF_MAX > 4
/*
 *-------------------------------------------------------------------------
 *
 * UtfToUtf16Proc --
 *
 *	Convert from UTF-8 to UTF-16.
 *
 * Results:
 *	Returns TCL_OK if conversion was successful.
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------------
 */

static int
UtfToUtf16Proc(
    ClientData clientData,	/* TableEncodingData that specifies
				 * encoding. */
    const char *src,		/* Source string in UTF-8. */
    int srcLen,			/* Source string length in bytes. */
    int flags,			/* Conversion control flags. */
    Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
				 * information used during a piecewise
				 * conversion. Contents of statePtr are
				 * initialized and/or reset by conversion
				 * routine under control of flags argument. */
    char *dst,			/* Output buffer in which converted string is
				 * stored. */
    int dstLen,			/* The maximum length of output buffer in
				 * bytes. */
    int *srcReadPtr,		/* Filled with the number of bytes from the
				 * source string that were converted. This may
				 * be less than the original source length if
				 * there was a problem converting some source
				 * characters. */
    int *dstWrotePtr,		/* Filled with the number of bytes that were
				 * stored in the output buffer as a result of
				 * the conversion. */
    int *dstCharsPtr)		/* Filled with the number of characters that
				 * correspond to the bytes stored in the
				 * output buffer. */
{
    const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd;
    int result, numChars;
    Tcl_UniChar ch;

    srcStart = src;
    srcEnd = src + srcLen;
    srcClose = srcEnd;
    if ((flags & TCL_ENCODING_END) == 0) {
	srcClose -= TCL_UTF_MAX;
    }

    dstStart = dst;
    dstEnd   = dst + dstLen - 2 * sizeof(unsigned short);

    result = TCL_OK;
    for (numChars = 0; src < srcEnd; numChars++) {
	if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
	    /*
	     * If there is more string to follow, this will ensure that the
	     * last UTF-8 character in the source buffer hasn't been cut off.
	     */

	    result = TCL_CONVERT_MULTIBYTE;
	    break;
	}
	if (dst > dstEnd) {
	    result = TCL_CONVERT_NOSPACE;
	    break;
        }
	src += TclUtfToUniChar(src, &ch);

	if (ch > 0x10FFFF) {
	    ch = 0xFFFD;
	}

	/*
	 * Need to handle this in a way that won't cause misalignment by
	 * casting dst to a Tcl_UniChar. [Bug 1122671]
	 */

	if (ch > 0xFFFF) {
	    int high = (((ch - 0x10000) >> 10) & 0x3FF) | 0xD800;

	    ch = ((ch - 0x10000) & 0x3FF) | 0xDC00;
#ifdef WORDS_BIGENDIAN
	    *dst++ = ((high >> 8) & 0xFF);
    	    *dst++ = (high & 0xFF);
#else
    	    *dst++ = (high & 0xFF);
	    *dst++ = ((high >> 8) & 0xFF);
#endif
	}
#ifdef WORDS_BIGENDIAN
	*dst++ = ((ch >> 8) & 0xFF);
	*dst++ = (ch & 0xFF);
#else
    	*dst++ = (ch & 0xFF);
	*dst++ = ((ch >> 8) & 0xFF);
#endif
    }
    *srcReadPtr = src - srcStart;
    *dstWrotePtr = dst - dstStart;
    *dstCharsPtr = numChars;
    return result;
}
#endif

/*
 *---------------------------------------------------------------------------
 *
 * TableFreeProc --
 *
 *	This function is invoked when an encoding is deleted. It deletes the

#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

{
    if ((ch > 0) && (ch < UNICODE_SELF)) {
	return 1;
    }
    if (ch <= 0x7FF) {
	return 2;
    }



#if TCL_UTF_MAX > 3
    if ((ch > 0xFFFF) && (ch <= 0x10FFFF)) {
	return 4;
    }






#endif
    return 3;
}

/*
 *---------------------------------------------------------------------------
 *

    if (ch >= 0) {
	if (ch <= 0x7FF) {
	    buf[1] = (char) ((ch | 0x80) & 0xBF);
	    buf[0] = (char) ((ch >> 6) | 0xC0);
	    return 2;
	}
	if (ch <= 0xFFFF) {
#if TCL_UTF_MAX == 4
	    if ((ch & 0xF800) == 0xD800) {
		if (ch & 0x0400) {
		    /* Low surrogate */
		    buf[3] = (char) ((ch | 0x80) & 0xBF);
		    buf[2] |= (char) (((ch >> 6) | 0x80) & 0x8F);
		    return 4;
		} else {
		    /* High surrogate */
		    ch += 0x40;
		    buf[2] = (char) (((ch << 4) | 0x80) & 0xB0);
		    buf[1] = (char) (((ch >> 2) | 0x80) & 0xBF);
		    buf[0] = (char) (((ch >> 8) | 0xF0) & 0xF7);
		    return 0;
		}
	    }
#endif
	three:
	    buf[2] = (char) ((ch | 0x80) & 0xBF);
	    buf[1] = (char) (((ch >> 6) | 0x80) & 0xBF);
	    buf[0] = (char) ((ch >> 12) | 0xE0);
	    return 3;
	}

#if TCL_UTF_MAX > 3
	if (ch <= 0x10FFFF) {
	    buf[3] = (char) ((ch | 0x80) & 0xBF);
	    buf[2] = (char) (((ch >> 6) | 0x80) & 0xBF);
	    buf[1] = (char) (((ch >> 12) | 0x80) & 0xBF);
	    buf[0] = (char) ((ch >> 18) | 0xF0);
	    return 4;
	}

















#endif
    }

    ch = 0xFFFD;
    goto three;
}


 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsAlnum(
    int ch)			/* Unicode character to test. */
{
#if TCL_UTF_MAX > 3
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }
#endif
    return (((ALPHA_BITS | DIGIT_BITS) >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsAlpha --

 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsAlpha(
    int ch)			/* Unicode character to test. */
{
#if TCL_UTF_MAX > 3
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }
#endif
    return ((ALPHA_BITS >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsControl --

 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsControl(
    int ch)			/* Unicode character to test. */
{
#if TCL_UTF_MAX > 3
    if (UNICODE_OUT_OF_RANGE(ch)) {
	ch &= 0x1fffff;
	if ((ch == 0xe0001) || ((ch >= 0xe0020) && (ch <= 0xe007f))) {
	    return 1;
	}
	if ((ch >= 0xf0000) && ((ch & 0xffff) <= 0xfffd)) {
	    return 1;
	}
	return 0;
    }
#endif
    return ((CONTROL_BITS >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsDigit --

 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsDigit(
    int ch)			/* Unicode character to test. */
{
#if TCL_UTF_MAX > 3
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }
#endif
    return (GetCategory(ch) == DECIMAL_DIGIT_NUMBER);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsGraph --

 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsGraph(
    int ch)			/* Unicode character to test. */
{
#if TCL_UTF_MAX > 3
    if (UNICODE_OUT_OF_RANGE(ch)) {
	ch &= 0x1fffff;
	return (ch >= 0xe0100) && (ch <= 0xe01ef);
    }
#endif
    return ((GRAPH_BITS >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsLower --

 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsLower(
    int ch)			/* Unicode character to test. */
{
#if TCL_UTF_MAX > 3
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }
#endif
    return (GetCategory(ch) == LOWERCASE_LETTER);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsPrint --

 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsPrint(
    int ch)			/* Unicode character to test. */
{
#if TCL_UTF_MAX > 3
    if (UNICODE_OUT_OF_RANGE(ch)) {
	ch &= 0x1fffff;
	return (ch >= 0xe0100) && (ch <= 0xe01ef);
    }
#endif
    return (((GRAPH_BITS|SPACE_BITS) >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsPunct --

 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsPunct(
    int ch)			/* Unicode character to test. */
{
#if TCL_UTF_MAX > 3
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }
#endif
    return ((PUNCT_BITS >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsSpace --

 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsSpace(
    int ch)			/* Unicode character to test. */
{
#if TCL_UTF_MAX > 3
    /* Ignore upper 11 bits. */
    ch &= 0x1fffff;
#else
    /* Ignore upper 16 bits. */
    ch &= 0xffff;
#endif

    /*
     * If the character is within the first 127 characters, just use the
     * standard C function, otherwise consult the Unicode table.
     */

    if (ch < 0x80) {
	return TclIsSpaceProc((char) ch);
#if TCL_UTF_MAX > 3
    } else if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
#endif
    } else if (ch == 0x0085 || ch == 0x180e || ch == 0x200b
	    || ch == 0x202f || ch == 0x2060 || ch == 0xfeff) {
	return 1;
    } else {
	return ((SPACE_BITS >> GetCategory(ch)) & 1);
    }
}

/*

 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsUpper(
    int ch)			/* Unicode character to test. */
{
#if TCL_UTF_MAX > 3
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }
#endif
    return (GetCategory(ch) == UPPERCASE_LETTER);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharIsWordChar --

 *----------------------------------------------------------------------
 */

int
Tcl_UniCharIsWordChar(
    int ch)			/* Unicode character to test. */
{
#if TCL_UTF_MAX > 3
    if (UNICODE_OUT_OF_RANGE(ch)) {
	return 0;
    }
#endif
    return ((WORD_BITS >> GetCategory(ch)) & 1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_UniCharCaseMatch --

# Copyright (c) 1998-1999 Scriptics Corporation.
# 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.
#

# This test intentionally written in pre-7.5 Tcl
if {[info commands package] == ""} {
    error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
}
package require -exact Tcl 8.6.4

# Compute the auto path to use in this interpreter.
# The values on the path come from several locations:

	    } else {
		dict incr opts -level
		return -options $opts $msg
	    }
	}
    }

    if {([info level] == 1) && ([info script] eq "")
	    && [info exists tcl_interactive] && $tcl_interactive} {
	if {![info exists auto_noexec]} {
	    set new [auto_execok $name]
	    if {$new ne ""} {
		set redir ""
		if {[namespace which -command console] eq ""} {
		    set redir ">&@stdout <@stdin"

		return -code error "wrong # args: should be\
			\"[lindex [info level 0] 0] ?-exactnamespace?\
			?-exactlocale? src\""
	    }
	}
    }
    set src [lindex $args 0]

    while {$ns ne ""} {
	foreach loc $loclist {
	    if {[dict exists $Msgs $ns $loc $src]} {
		return 1
	    }
	}
	if {[info exists exactnamespace]} {return 0}

	set newLocale [string tolower [lindex $args 0]]
	if {$newLocale ne [file tail $newLocale]} {
	    return -code error "invalid newLocale value \"$newLocale\":\
		    could be path to unsafe code."
	}
	if {[lindex $Loclist 0] ne $newLocale} {
	    set Loclist [GetPreferences $newLocale]

	    # locale not loaded jet
	    LoadAll $Loclist
	    # Invoke callback
	    Invoke changecmd $Loclist
	}
    }
    return [lindex $Loclist 0]

		{"get" "isset" "unset" "preferences" "loaded" "clear"} } {
	    return -code error "wrong # args: should be\
		    \"[lrange [info level 0] 0 1]\""
	}
        set locale [string tolower $locale]
    }
    set ns [uplevel 1 {::namespace current}]

    switch -exact -- $subcommand {
	get { return [lindex [PackagePreferences $ns] 0] }
	preferences { return [PackagePreferences $ns] }
	loaded { return [PackageLocales $ns] }
	present { return [expr {$locale in [PackageLocales $ns]} ]}
	isset { return [dict exists $PackageConfig loclist $ns] }
	set { # set a package locale or add a package locale

		return -code error "package option \"$option\" not set"
	    }
	    return [dict get $PackageConfig $option $ns]
	}
	isset {	return [dict exists $PackageConfig $option $ns] }
	unset {	dict unset PackageConfig $option $ns }
	set {	# Set option

	    if {$option eq "mcfolder"} {
		set value [file normalize $value]
	    }
	    # Check if changed
	    if { [dict exists $PackageConfig $option $ns]
		    && $value eq [dict get $PackageConfig $option $ns] } {
		return 0

    variable PackageConfig
    variable LoadedLocales
    if {0 == [llength $locales]} { return {} }
    # filter jet unloaded locales
    set locales [ListComplement $LoadedLocales $locales]
    if {0 == [llength $locales]} { return {} }
    lappend LoadedLocales {*}$locales

    set packages [lsort -unique [concat\
	    [dict keys [dict get $PackageConfig loadcmd]]\
	    [dict keys [dict get $PackageConfig mcfolder]]]]
    foreach ns $packages {
	if {! [dict exists $PackageConfig loclist $ns] } {
	    Load $ns $locales
	}

    variable PackageConfig
    variable LoadedLocals

    if {0 == [llength $locales]} { return 0 }

    # Invoke callback
    Invoke loadcmd $locales $ns

    if {$callbackonly || ![dict exists $PackageConfig mcfolder $ns]} {
	return 0
    }

    # Invoke file load
    set langdir [dict get $PackageConfig mcfolder $ns]

    # Save the file locale if we are recursively called
    if {[info exists FileLocale]} {
	set nestedFileLocale $FileLocale
    }
    set x 0
    foreach p $locales {
	if {$p eq {}} {

	    if {$state == "flags"} {
		# no argument and no flags : we're done
#                puts "returning to previous (sub)prg (no more args)"
		return -code return
	    } elseif {$state == "optValue"} {
		set state next; # not used, for debug only
		# go to next state
		return
	    } else {
		return -code error [OptMissingValue $descriptions]
	    }
	} else {
	    set arg [OptCurrentArg $arguments]
	}

    if {![Lempty $arglist]} {
	return -code error [OptTooManyArgs $desc $arglist]
    }

    # Analyse the result
    # Walk through the tree:
    OptTreeVars $desc "#[expr {[info level]-1}]"
}

    # determine string length for nice tabulated output
    proc OptTreeVars {desc level {vnamesLst {}}} {
	foreach item $desc {
	    if {[OptIsCounter $item]} continue
	    if {[OptIsPrg $item]} {

    set cmdList {}
    set lazyFileList {}

    # Handle -load and -source specs
    foreach key {load source} {
	foreach filespec $opts(-$key) {
	    lassign $filespec filename proclist

	    if { [llength $proclist] == 0 } {
		set cmd "\[list $key \[file join \$dir [list $filename]\]\]"
		lappend cmdList $cmd
	    } else {
		lappend lazyFileList [list $filename $key $proclist]
	    }
	}

	macosx-x86_64 {
	    lappend res macosx-i386-x86_64
	}
	macosx-ix86 {
	    lappend res macosx-universal macosx-i386-x86_64
	}
	macosx*-*    {
	    # 10.5+
	    if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} {

		switch -exact -- $cpu {
		    ix86    {
			lappend alt i386-x86_64
			lappend alt universal
		    }

    }
    if {$argc != 1} {
	set msg "wrong # args: should be \"source ?-encoding E? fileName\""
	Log $slave "$msg ($args)"
	return -code error $msg
    }
    set file [lindex $args $at]

    # get the real path from the virtual one.
    if {[catch {
	set realfile [TranslatePath $slave $file]
    } msg]} {
	Log $slave $msg
	return -code error "permission denied"
    }

    # check that the path is in the access path of that slave
    if {[catch {
	FileInAccessPath $slave $realfile
    } msg]} {
	Log $slave $msg
	return -code error "permission denied"
    }

    proc outputChannel { {filename ""} } {
	variable outputChannel
	variable ChannelsWeOpened

	# This is very subtle and tricky, so let me try to explain.
	# (Hopefully this longer comment will be clear when I come
	# back in a few months, unlike its predecessor :) )
	#
	# The [outputChannel] command (and underlying variable) have to
	# be kept in sync with the [configure -outfile] configuration
	# option ( and underlying variable Option(-outfile) ).  This is
	# accomplished with a write trace on Option(-outfile) that will
	# update [outputChannel] whenver a new value is written.  That
	# much is easy.
	#
	# The trick is that in order to maintain compatibility with
	# version 1 of tcltest, we must allow every configuration option
	# to get its inital value from command line arguments.  This is
	# accomplished by setting initial read traces on all the
	# configuration options to parse the command line option the first
	# time they are read.  These traces are cancelled whenever the
	# program itself calls [configure].
	#
	# OK, then so to support tcltest 1 compatibility, it seems we want
	# to get the return from [outputFile] to trigger the read traces,
	# just in case.
	#
	# BUT!  A little known feature of Tcl variable traces is that
	# traces are disabled during the handling of other traces.  So,
	# if we trigger read traces on Option(-outfile) and that triggers
	# command line parsing which turns around and sets an initial
	# value for Option(-outfile) -- <whew!> -- the write trace that
	# would keep [outputChannel] in sync with that new initial value
	# would not fire!
	#

    proc configure args {
	if {[llength $args] > 1} {
	    RemoveAutoConfigureTraces
	}
	set code [catch {Configure {*}$args} msg]
	return -code $code $msg
    }

    proc AcceptVerbose { level } {
	set level [AcceptList $level]
	if {[llength $level] == 1} {
	    if {![regexp {^(pass|body|skip|start|error|line)$} $level]} {
		# translate single characters abbreviations to expanded list
		set level [string map {p pass b body s skip t start e error l line} \
			[split $level {}]]

    # Default verbosity is to show bodies of failed tests
    Option -verbose {body error} {
	Takes any combination of the values 'p', 's', 'b', 't', 'e' and 'l'.
	Test suite will display all passed tests if 'p' is specified, all
	skipped tests if 's' is specified, the bodies of failed tests if
	'b' is specified, and when tests start if 't' is specified.
	ErrorInfo is displayed if 'e' is specified. Source file line
	information of failed tests is displayed if 'l' is specified.
    } AcceptVerbose verbose

    # Match and skip patterns default to the empty list, except for
    # matchFiles, which defaults to all .test files in the
    # testsDirectory and matchDirectories, which defaults to all
    # directories.
    Option -match * {

    # debug output doesn't get printed by default; debug level 1 spits
    # up only the tests that were skipped because they didn't match or
    # were specifically skipped.  A debug level of 2 would spit up the
    # tcltest variables and flags provided; a debug level of 3 causes
    # some additional output regarding operations of the test harness.
    # The tcltest package currently implements only up to debug level 3.
    Option -debug 0 {
	Internal debug level
    } AcceptInteger debug

    proc SetSelectedConstraints args {
	variable Option
	foreach c $Option(-constraints) {
	    testConstraint $c 1
	}

	    if {$c ni $Option(-constraints)} {
		testConstraint $c 0
	    }
	}
    }
    Option -limitconstraints 0 {
	whether to run only tests with the constraints
    } AcceptBoolean limitConstraints
    trace add variable Option(-limitconstraints) write \
	    [namespace code {ClearUnselectedConstraints ;#}]

    # A test application has to know how to load the tested commands
    # into the interpreter.
    Option -load {} {
	Specifies the script to load the tested commands.
    } AcceptScript loadScript

    # Default is to run each test file in a separate process
    Option -singleproc 0 {
	whether to run all tests in one process
    } AcceptBoolean singleProcess

    proc AcceptTemporaryDirectory { directory } {
	set directory [AcceptAbsolutePath $directory]
	if {![file exists $directory]} {
	    file mkdir $directory
	}
	set directory [AcceptDirectory $directory]

		    ($::tcl_platform(user) in {root {}})}}
    ConstraintInitializer notRoot {expr {![testConstraint root]}}

    # Set nonBlockFiles constraint: 1 means this platform supports
    # setting files into nonblocking mode.

    ConstraintInitializer nonBlockFiles {
	    set code [expr {[catch {set f [open defs r]}]
		    || [catch {chan configure $f -blocking off}]}]
	    catch {close $f}
	    set code
    }

    # Set asyncPipeClose constraint: 1 means this platform supports
    # async flush and async close on a pipe.
    #
    # Test for SCO Unix - cannot run async flushing tests because a
    # potential problem with select is apparently interfering.
    # (Mark Diekhans).

    ConstraintInitializer asyncPipeClose {expr {
	    !([string equal unix $::tcl_platform(platform)]
	    && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}}

    # Test to see if we have a broken version of sprintf with respect
    # to the "e" format of floating-point numbers.

    ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05}

    }

    if {[Skipped $name $constraints]} {
	incr testLevel -1
	return
    }

    # Save information about the core file.
    if {[preserveCore]} {
	if {[file exists [file join [workingDirectory] core]]} {
	    set coreModTime [file mtime [file join [workingDirectory] core]]
	}
    }

    # First, run the setup script

		if {$coreModTime != [file mtime \
			[file join [workingDirectory] core]]} {
		    set coreFailure 1
		}
	    } else {
		set coreFailure 1
	    }

	    if {([preserveCore] > 1) && ($coreFailure)} {
		append coreMsg "\nMoving file to:\
		    [file join [temporaryDirectory] core-$name]"
		catch {file rename -force -- \
		    [file join [workingDirectory] core] \
		    [file join [temporaryDirectory] core-$name]
		} msg

	incr numTests(Failed)
    }

    # ... then report according to the type of failure
    variable currentFailure true
    if {![IsVerbose body]} {
	set body ""
    }
    puts [outputChannel] "\n"
    if {[IsVerbose line]} {
	if {![catch {set testFrame [info frame -1]}] &&
		[dict get $testFrame type] eq "source"} {
	    set testFile [dict get $testFrame file]
	    set testLine [dict get $testFrame line]
	} else {
	    set testFile [file normalize [uplevel 1 {info script}]]
	    if {[file readable $testFile]} {
		set testFd [open $testFile r]
		set testLine [expr {[lsearch -regexp \
			[split [read $testFd] "\n"] \
			"^\[ \t\]*test [string map {. \\.} $name] "] + 1}]
		close $testFd
	    }
	}
	if {[info exists testLine]} {
	    puts [outputChannel] "$testFile:$testLine: error: test failed:\
		    $name [string trim $description]"
	}
    }
    puts [outputChannel] "==== $name\
	    [string trim $description] FAILED"
    if {[string length $body]} {
	puts [outputChannel] "==== Contents of test case:"
	puts [outputChannel] $body
    }
    if {$setupFailure} {

		    # store the constraint that kept the test from
		    # running
		    set constraints $constraint
		    break
		}
	    }
	}

	if {!$doTest} {
	    if {[IsVerbose skip]} {
		puts [outputChannel] "++++ $name SKIPPED: $constraints"
	    }

	    if {$testLevel == 1} {
		incr numTests(Skipped)

    }

    # Checking for subdirectories in which to run tests
    foreach directory [GetMatchingDirectories [testsDirectory]] {
	set dir [file tail $directory]
	puts [outputChannel] [string repeat ~ 44]
	puts [outputChannel] "$dir test began at [eval $timeCmd]\n"

	uplevel 1 [list ::source [file join $directory all.tcl]]

	set endTime [eval $timeCmd]
	puts [outputChannel] "\n$dir test ended at $endTime"
	puts [outputChannel] ""
	puts [outputChannel] [string repeat ~ 44]
    }
    return
}

    DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"
    set idx [lsearch -exact $filesMade $fullName]
    set filesMade [lreplace $filesMade $idx $idx]
    if {$idx == -1} {
	DebugDo 1 {
	    Warn "removeFile removing \"$fullName\":\n  not created by makeFile"
	}
    }
    if {![file isfile $fullName]} {
	DebugDo 1 {
	    Warn "removeFile removing \"$fullName\":\n  not a file"
	}
    }
    return [file delete -- $fullName]
}

    set idx [lsearch -exact $filesMade $fullName]
    set filesMade [lreplace $filesMade $idx $idx]
    if {$idx == -1} {
	DebugDo 1 {
	    Warn "removeDirectory removing \"$fullName\":\n  not created\
		    by makeDirectory"
	}
    }
    if {![file isdirectory $fullName]} {
	DebugDo 1 {
	    Warn "removeDirectory removing \"$fullName\":\n  not a directory"
	}
    }
    return [file delete -force -- $fullName]
}

	    ## room to kill themselves off, otherwise the end up with a
	    ## massive queue of repeated events
	    after 1
	}
	testthread errorproc ThreadError
	return [llength [testthread names]]
    } elseif {[info commands thread::id] ne {}} {

	# Thread extension

	thread::errorproc ThreadNullError
	while {[llength [thread::names]] > 1} {
	    foreach tid [thread::names] {
		if {$tid != [mainThread]} {
		    catch {thread::send -async $tid {thread::exit}}

proc get-chunks {data {compression gzip}} {
    switch -exact -- $compression {
        gzip     { set data [zlib gzip $data] }
        deflate  { set data [zlib deflate $data] }
        compress { set data [zlib compress $data] }
    }

    set data ""
    set chunker [make-chunk-generator $data 512]
    while {[string length [set chunk [$chunker]]]} {
        append data $chunk
    }
    return $data
}

proc blow-chunks {data {ochan stdout} {compression gzip}} {
    switch -exact -- $compression {
        gzip     { set data [zlib gzip $data] }
        deflate  { set data [zlib deflate $data] }
        compress { set data [zlib compress $data] }
    }

    set chunker [make-chunk-generator $data 512]
    while {[string length [set chunk [$chunker]]]} {
        puts -nonewline $ochan $chunk
    }
    return
}

            set f [open $path r]
            if {$what eq "binary"} {chan configure $f -translation binary}
            set data [read $f]
            close $f
            set code "200 OK"
            set close [expr {[dict get? $meta connection] eq "close"}]
        }

        if {$protocol eq "HTTP/1.1"} {
	    foreach enc [split [dict get? $meta accept-encoding] ,] {
		set enc [string trim $enc]
		if {$enc in {deflate gzip compress}} {
		    set encoding $enc
		    break
		}
	    }
            set transfer chunked
        } else {
            set close 1
        }

        foreach pair [split $query &] {
            if {[scan $pair {%[^=]=%s} key val] != 2} {set val ""}
            switch -exact -- $key {
                close        {set close 1 ; set transfer 0}
                transfer     {set transfer $val}
                content-type {set type $val}
            }

        if {$transfer eq "chunked"} {
            blow-chunks $data $chan $encoding
        } elseif {$encoding ne "identity"} {
            puts -nonewline $chan [zlib $encoding $data]
        } else {
            puts -nonewline $chan $data
        }

        if {$close} {
            chan event $chan readable {}
            close $chan
            puts "close $chan"
            return
        } else {
            flush $chan

# 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:

    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 { [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 \

    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 \

		$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)] "\""

#----------------------------------------------------------------------

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]
	}
    }

	    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}

#
# 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.

	    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

	}
    }

}

#----------------------------------------------------------------------
#
# 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] } {

#----------------------------------------------------------------------

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

 	? 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 [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 }]]	\
		" " $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"
}

		    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.

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 } {

		puts $f2 "} {$result}"
	    }
	}
    }

    puts "testcases4: $i test cases."
}

#----------------------------------------------------------------------
#
# testcases5 --
#
#	Generates the test cases for Daylight Saving Time
#
# Parameters:

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]
	    }

#	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]"

#	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
    }

#	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" \

#	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"
}

#	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" \

#	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"
}

#	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 \

#	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"
}

#	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]

#	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} \

			    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

            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

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
}

    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)

# 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.

package require Tcl 8.4

# 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

		    }
		}
		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

    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 {}

# 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

#==============================================================================
#
# 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 <[email protected]> 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]

#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