/* 
 * tclUtil.c --
 *
 *	This file contains utility procedures that are used by many Tcl
 *	commands.
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * All rights reserved.
 *
 * 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 UNIVERSITY OF CALIFORNIA 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 UNIVERSITY OF
 * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *
 * THE UNIVERSITY OF CALIFORNIA 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 UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
 * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
 */
/*
 * Copyright (c) 1994 Software Research Associates, Inc.
 *
 * Permission to use, copy, modify, and distribute this software and its
 * documentation for any purpose and without fee is hereby granted, provided
 * that the above copyright notice appear in all copies and that both that
 * copyright notice and this permission notice appear in supporting
 * documentation, and that the name of Software Research Associates not be
 * used in advertising or publicity pertaining to distribution of the
 * software without specific, written prior permission.  Software Research
 * Associates makes no representations about the suitability of this software
 * for any purpose.  It is provided "as is" without express or implied
 * warranty.
 */

#ifndef lint
static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUtil.c,v 1.84 93/10/11 09:18:49 ouster Exp $ SPRITE (Berkeley)";
#endif

#include "tclInt.h"

/*
 * The following values are used in the flags returned by Tcl_ScanElement
 * and used by Tcl_ConvertElement.  The value TCL_DONT_USE_BRACES is also
 * defined in tcl.h;  make sure its value doesn't overlap with any of the
 * values below.
 *
 * TCL_DONT_USE_BRACES -	1 means the string mustn't be enclosed in
 *				braces (e.g. it contains unmatched braces,
 *				or ends in a backslash character, or user
 *				just doesn't want braces);  handle all
 *				special characters by adding backslashes.
 * USE_BRACES -			1 means the string contains a special
 *				character that can be handled simply by
 *				enclosing the entire argument in braces.
 * BRACES_UNMATCHED -		1 means that braces aren't properly matched
 *				in the argument.
 */

#define USE_BRACES		2
#define BRACES_UNMATCHED	4

/*
 * The variable below is set to NULL before invoking regexp functions
 * and checked after those functions.  If an error occurred then TclRegError
 * will set the variable to point to a (static) error message.  This
 * mechanism unfortunately does not support multi-threading, but then
 * neither does the rest of the regexp facilities.
 */

char *tclRegexpError = NULL;

#ifdef KANJI

/*
 * If C_LOCALE_SPECIAL is defined, C locale is treated specially.
 * When the locale is C, the automatic kanji encoding detection
 * feature is disabled, so that any string is recognized as a normal
 * (ISO Latin-1) string.
 * This makes Japanized Tcl to behave just like the original Tcl.
 */
#define C_LOCALE_SPECIAL

/*
 * For setlocale() call.
 */
#ifdef HAVE_SETLOCALE
#include <locale.h>
#endif

/*
 * This array holds the printable kanji code name corresponding to
 * the kanji code defined in tcl.h.
 */

char *Tcl_KanjiCodeStr[4] = { "JIS", "SJIS", "EUC", "ANY" };

#ifdef C_LOCALE_SPECIAL
/*
 * This variable indicates whether some special Kanji related feature
 * is disabled nor not.
 */
static int	noKanjiFeature = 0;
#endif /* C_LOCALE_SPECIAL */

#endif /* KANJI */

/*
 * Function prototypes for local procedures in this file:
 */

static void		SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
			    int newSpace));
#ifdef KANJI
static int		EncodingDetection _ANSI_ARGS_((Tcl_Interp *interp,
			    char *string));
#endif /* KANJI */

/*
 *----------------------------------------------------------------------
 *
 * TclFindElement --
 *
 *	Given a pointer into a Tcl list, locate the first (or next)
 *	element in the list.
 *
 * Results:
 *	The return value is normally TCL_OK, which means that the
 *	element was successfully located.  If TCL_ERROR is returned
 *	it means that list didn't have proper list structure;
 *	interp->result contains a more detailed error message.
 *
 *	If TCL_OK is returned, then *elementPtr will be set to point
 *	to the first element of list, and *nextPtr will be set to point
 *	to the character just after any white space following the last
 *	character that's part of the element.  If this is the last argument
 *	in the list, then *nextPtr will point to the NULL character at the
 *	end of list.  If sizePtr is non-NULL, *sizePtr is filled in with
 *	the number of characters in the element.  If the element is in
 *	braces, then *elementPtr will point to the character after the
 *	opening brace and *sizePtr will not include either of the braces.
 *	If there isn't an element in the list, *sizePtr will be zero, and
 *	both *elementPtr and *termPtr will refer to the null character at
 *	the end of list.  Note:  this procedure does NOT collapse backslash
 *	sequences.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclFindElement(interp, list, elementPtr, nextPtr, sizePtr, bracePtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting. */
    register char *list;	/* String containing Tcl list with zero
				 * or more elements (possibly in braces). */
    char **elementPtr;		/* Fill in with location of first significant
				 * character in first element of list. */
    char **nextPtr;		/* Fill in with location of character just
				 * after all white space following end of
				 * argument (i.e. next argument or end of
				 * list). */
    int *sizePtr;		/* If non-zero, fill in with size of
				 * element. */
    int *bracePtr;		/* If non-zero fill in with non-zero/zero
				 * to indicate that arg was/wasn't
				 * in braces. */
{
    register char *p;
    int openBraces = 0;
    int inQuotes = 0;
    int size;
#ifdef KANJI
    int kanjiCode = TCL_ANY;
#endif /* KANJI */

    /*
     * Skim off leading white space and check for an opening brace or
     * quote.   Note:  use of "isascii" below and elsewhere in this
     * procedure is a temporary hack (7/27/90) because Mx uses characters
     * with the high-order bit set for some things.  This should probably
     * be changed back eventually, or all of Tcl should call isascii.
     */

    while (isspace(UCHAR(*list))) {
	list++;
    }
    if (*list == '{') {
	openBraces = 1;
	list++;
    } else if (*list == '"') {
	inQuotes = 1;
	list++;
    }
    if (bracePtr != 0) {
	*bracePtr = openBraces;
    }
    p = list;

    /*
     * Find the end of the element (either a space or a close brace or
     * the end of the string).
     */

    while (1) {
#ifdef KANJI
	if (Tcl_KanjiStart(p, &kanjiCode)) {
	    p += Tcl_KanjiLength(p, kanjiCode);
	}
#endif /* KANJI */
	switch (*p) {

	    /*
	     * Open brace: don't treat specially unless the element is
	     * in braces.  In this case, keep a nesting count.
	     */

	    case '{':
		if (openBraces != 0) {
		    openBraces++;
		}
		break;

	    /*
	     * Close brace: if element is in braces, keep nesting
	     * count and quit when the last close brace is seen.
	     */

	    case '}':
		if (openBraces == 1) {
		    char *p2;

		    size = p - list;
		    p++;
		    if (isspace(UCHAR(*p)) || (*p == 0)) {
			goto done;
		    }
		    for (p2 = p; (*p2 != 0) && (!isspace(UCHAR(*p2)))
			    && (p2 < p+20); p2++) {
			/* null body */
		    }
		    Tcl_ResetResult(interp);
		    sprintf(interp->result,
			    "list element in braces followed by \"%.*s\" instead of space",
			    p2-p, p);
		    return TCL_ERROR;
		} else if (openBraces != 0) {
		    openBraces--;
		}
		break;

	    /*
	     * Backslash:  skip over everything up to the end of the
	     * backslash sequence.
	     */

	    case '\\': {
		int size;

		(void) Tcl_Backslash(p, &size);
		p += size - 1;
		break;
	    }

	    /*
	     * Space: ignore if element is in braces or quotes;  otherwise
	     * terminate element.
	     */

	    case ' ':
	    case '\f':
	    case '\n':
	    case '\r':
	    case '\t':
	    case '\v':
		if ((openBraces == 0) && !inQuotes) {
		    size = p - list;
		    goto done;
		}
		break;

	    /*
	     * Double-quote:  if element is in quotes then terminate it.
	     */

	    case '"':
		if (inQuotes) {
		    char *p2;

		    size = p-list;
		    p++;
		    if (isspace(UCHAR(*p)) || (*p == 0)) {
			goto done;
		    }
		    for (p2 = p; (*p2 != 0) && (!isspace(UCHAR(*p2)))
			    && (p2 < p+20); p2++) {
			/* null body */
		    }
		    Tcl_ResetResult(interp);
		    sprintf(interp->result,
			    "list element in quotes followed by \"%.*s\" %s",
			    p2-p, p, "instead of space");
		    return TCL_ERROR;
		}
		break;

	    /*
	     * End of list:  terminate element.
	     */

	    case 0:
		if (openBraces != 0) {
		    Tcl_SetResult(interp, "unmatched open brace in list",
			    TCL_STATIC);
		    return TCL_ERROR;
		} else if (inQuotes) {
		    Tcl_SetResult(interp, "unmatched open quote in list",
			    TCL_STATIC);
		    return TCL_ERROR;
		}
		size = p - list;
		goto done;

	}
	p++;
    }

    done:
    while (isspace(UCHAR(*p))) {
	p++;
    }
    *elementPtr = list;
    *nextPtr = p;
    if (sizePtr != 0) {
	*sizePtr = size;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCopyAndCollapse --
 *
 *	Copy a string and eliminate any backslashes that aren't in braces.
 *
 * Results:
 *	There is no return value.  Count chars. get copied from src
 *	to dst.  Along the way, if backslash sequences are found outside
 *	braces, the backslashes are eliminated in the copy.
 *	After scanning count chars. from source, a null character is
 *	placed at the end of dst.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
TclCopyAndCollapse(count, src, dst)
    int count;			/* Total number of characters to copy
				 * from src. */
    register char *src;		/* Copy from here... */
    register char *dst;		/* ... to here. */
{
    register char c;
    int numRead;
#ifdef KANJI
    int kanjiCode = TCL_ANY;
#endif /* KANJI */

    for (c = *src; count > 0; src++, c = *src, count--) {
#ifdef KANJI
	if (Tcl_KanjiStart(src, &kanjiCode)) {
	    numRead = Tcl_KanjiLength(src, kanjiCode);
	    strncpy(dst, src, numRead);
	    dst += numRead;
	    src += numRead-1;
	    count -= numRead-1;
	} else
#endif /* KANJI */
	if (c == '\\') {
	    *dst = Tcl_Backslash(src, &numRead);
	    dst++;
	    src += numRead-1;
	    count -= numRead-1;
	} else {
	    *dst = c;
	    dst++;
	}
    }
    *dst = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SplitList --
 *
 *	Splits a list up into its constituent fields.
 *
 * Results
 *	The return value is normally TCL_OK, which means that
 *	the list was successfully split up.  If TCL_ERROR is
 *	returned, it means that "list" didn't have proper list
 *	structure;  interp->result will contain a more detailed
 *	error message.
 *
 *	*argvPtr will be filled in with the address of an array
 *	whose elements point to the elements of list, in order.
 *	*argcPtr will get filled in with the number of valid elements
 *	in the array.  A single block of memory is dynamically allocated
 *	to hold both the argv array and a copy of the list (with
 *	backslashes and braces removed in the standard way).
 *	The caller must eventually free this memory by calling free()
 *	on *argvPtr.  Note:  *argvPtr and *argcPtr are only modified
 *	if the procedure returns normally.
 *
 * Side effects:
 *	Memory is allocated.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_SplitList(interp, list, argcPtr, argvPtr)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting. */
    char *list;			/* Pointer to string with list structure. */
    int *argcPtr;		/* Pointer to location to fill in with
				 * the number of elements in the list. */
    char ***argvPtr;		/* Pointer to place to store pointer to array
				 * of pointers to list elements. */
{
    char **argv;
    register char *p;
    int size, i, result, elSize, brace;
    char *element;

    /*
     * Figure out how much space to allocate.  There must be enough
     * space for both the array of pointers and also for a copy of
     * the list.  To estimate the number of pointers needed, count
     * the number of space characters in the list.
     */

    for (size = 1, p = list; *p != 0; p++) {
	if (isspace(UCHAR(*p))) {
	    size++;
	}
    }
    size++;			/* Leave space for final NULL pointer. */
    argv = (char **) ckalloc((unsigned)
	    ((size * sizeof(char *)) + (p - list) + 1));
    for (i = 0, p = ((char *) argv) + size*sizeof(char *);
	    *list != 0; i++) {
	result = TclFindElement(interp, list, &element, &list, &elSize, &brace);
	if (result != TCL_OK) {
	    ckfree((char *) argv);
	    return result;
	}
	if (*element == 0) {
	    break;
	}
	if (i >= size) {
	    ckfree((char *) argv);
	    Tcl_SetResult(interp, "internal error in Tcl_SplitList",
		    TCL_STATIC);
	    return TCL_ERROR;
	}
	argv[i] = p;
	if (brace) {
	    strncpy(p, element, elSize);
	    p += elSize;
	    *p = 0;
	    p++;
	} else {
	    TclCopyAndCollapse(elSize, element, p);
	    p += elSize+1;
	}
    }

    argv[i] = NULL;
    *argvPtr = argv;
    *argcPtr = i;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ScanElement --
 *
 *	This procedure is a companion procedure to Tcl_ConvertElement.
 *	It scans a string to see what needs to be done to it (e.g.
 *	add backslashes or enclosing braces) to make the string into
 *	a valid Tcl list element.
 *
 * Results:
 *	The return value is an overestimate of the number of characters
 *	that will be needed by Tcl_ConvertElement to produce a valid
 *	list element from string.  The word at *flagPtr is filled in
 *	with a value needed by Tcl_ConvertElement when doing the actual
 *	conversion.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ScanElement(string, flagPtr)
    char *string;		/* String to convert to Tcl list element. */
    int *flagPtr;		/* Where to store information to guide
				 * Tcl_ConvertElement. */
{
    int flags, nestingLevel;
    register char *p;
#ifdef KANJI
    int kanjiCode = TCL_ANY;
#endif /* KANJI */

    /*
     * This procedure and Tcl_ConvertElement together do two things:
     *
     * 1. They produce a proper list, one that will yield back the
     * argument strings when evaluated or when disassembled with
     * Tcl_SplitList.  This is the most important thing.
     * 
     * 2. They try to produce legible output, which means minimizing the
     * use of backslashes (using braces instead).  However, there are
     * some situations where backslashes must be used (e.g. an element
     * like "{abc": the leading brace will have to be backslashed.  For
     * each element, one of three things must be done:
     *
     * (a) Use the element as-is (it doesn't contain anything special
     * characters).  This is the most desirable option.
     *
     * (b) Enclose the element in braces, but leave the contents alone.
     * This happens if the element contains embedded space, or if it
     * contains characters with special interpretation ($, [, ;, or \),
     * or if it starts with a brace or double-quote, or if there are
     * no characters in the element.
     *
     * (c) Don't enclose the element in braces, but add backslashes to
     * prevent special interpretation of special characters.  This is a
     * last resort used when the argument would normally fall under case
     * (b) but contains unmatched braces.  It also occurs if the last
     * character of the argument is a backslash or if the element contains
     * a backslash followed by newline.
     *
     * The procedure figures out how many bytes will be needed to store
     * the result (actually, it overestimates).  It also collects information
     * about the element in the form of a flags word.
     */

    nestingLevel = 0;
    flags = 0;
    if (string == NULL) {
	string = "";
    }
    p = string;
    if ((*p == '{') || (*p == '"') || (*p == 0)) {
	flags |= USE_BRACES;
    }
    for ( ; *p != 0; p++) {
#ifdef KANJI
	if (Tcl_KanjiStart(p, &kanjiCode)) {
	    p += (Tcl_KanjiLength(p, kanjiCode) - 1);
	    continue;
	}
#endif /* KANJI */
	switch (*p) {
	    case '{':
		nestingLevel++;
		break;
	    case '}':
		nestingLevel--;
		if (nestingLevel < 0) {
		    flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED;
		}
		break;
	    case '[':
	    case '$':
	    case ';':
	    case ' ':
	    case '\f':
	    case '\n':
	    case '\r':
	    case '\t':
	    case '\v':
		flags |= USE_BRACES;
		break;
	    case '\\':
		if ((p[1] == 0) || (p[1] == '\n')) {
		    flags = TCL_DONT_USE_BRACES;
		} else {
		    int size;

		    (void) Tcl_Backslash(p, &size);
		    p += size-1;
		    flags |= USE_BRACES;
		}
		break;
	}
    }
    if (nestingLevel != 0) {
	flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;
    }
    *flagPtr = flags;

    /*
     * Allow enough space to backslash every character plus leave
     * two spaces for braces.
     */

    return 2*(p-string) + 2;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ConvertElement --
 *
 *	This is a companion procedure to Tcl_ScanElement.  Given the
 *	information produced by Tcl_ScanElement, this procedure converts
 *	a string to a list element equal to that string.
 *
 * Results:
 *	Information is copied to *dst in the form of a list element
 *	identical to src (i.e. if Tcl_SplitList is applied to dst it
 *	will produce a string identical to src).  The return value is
 *	a count of the number of characters copied (not including the
 *	terminating NULL character).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_ConvertElement(src, dst, flags)
    register char *src;		/* Source information for list element. */
    char *dst;			/* Place to put list-ified element. */
    int flags;			/* Flags produced by Tcl_ScanElement. */
{
    register char *p = dst;
#ifdef KANJI
    int kanjiCode = TCL_ANY, length;
#endif /* KANJI */

    /*
     * See the comment block at the beginning of the Tcl_ScanElement
     * code for details of how this works.
     */

    if (src == NULL) {
	src = "";
    }
    if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) {
	*p = '{';
	p++;
	for ( ; *src != 0; src++, p++) {
	    *p = *src;
	}
	*p = '}';
	p++;
    } else if (*src == 0) {
	/*
	 * If string is empty but can't use braces, then use special
	 * backslash sequence that maps to empty string.
	 */

	p[0] = '\\';
	p[1] = '0';
	p += 2;
    } else {
	if (*src == '{') {
	    /*
	     * Can't have a leading brace unless the whole element is
	     * enclosed in braces.  Add a backslash before the brace.
	     * Furthermore, this may destroy the balance between open
	     * and close braces, so set BRACES_UNMATCHED.
	     */

	    p[0] = '\\';
	    p[1] = '{';
	    p += 2;
	    src++;
	    flags |= BRACES_UNMATCHED;
	}
	for (; *src != 0 ; src++) {
#ifdef KANJI
	    if (Tcl_KanjiStart(src, &kanjiCode)) {
		length = Tcl_KanjiLength(src, kanjiCode);
		strncpy(p, src, length);
		src += (length - 1);
		p += length;
		continue;
	    }
#endif /* KANJI */
	    switch (*src) {
		case ']':
		case '[':
		case '$':
		case ';':
		case ' ':
		case '\\':
		case '"':
		    *p = '\\';
		    p++;
		    break;
		case '{':
		case '}':
		    /*
		     * It may not seem necessary to backslash braces, but
		     * it is.  The reason for this is that the resulting
		     * list element may actually be an element of a sub-list
		     * enclosed in braces (e.g. if Tcl_DStringStartSublist
		     * has been invoked), so there may be a brace mismatch
		     * if the braces aren't backslashed.
		     */

		    if (flags & BRACES_UNMATCHED) {
			*p = '\\';
			p++;
		    }
		    break;
		case '\f':
		    *p = '\\';
		    p++;
		    *p = 'f';
		    p++;
		    continue;
		case '\n':
		    *p = '\\';
		    p++;
		    *p = 'n';
		    p++;
		    continue;
		case '\r':
		    *p = '\\';
		    p++;
		    *p = 'r';
		    p++;
		    continue;
		case '\t':
		    *p = '\\';
		    p++;
		    *p = 't';
		    p++;
		    continue;
		case '\v':
		    *p = '\\';
		    p++;
		    *p = 'v';
		    p++;
		    continue;
	    }
	    *p = *src;
	    p++;
	}
    }
    *p = '\0';
    return p-dst;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Merge --
 *
 *	Given a collection of strings, merge them together into a
 *	single string that has proper Tcl list structured (i.e.
 *	Tcl_SplitList may be used to retrieve strings equal to the
 *	original elements, and Tcl_Eval will parse the string back
 *	into its original elements).
 *
 * Results:
 *	The return value is the address of a dynamically-allocated
 *	string containing the merged list.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_Merge(argc, argv)
    int argc;			/* How many strings to merge. */
    char **argv;		/* Array of string values. */
{
#   define LOCAL_SIZE 20
    int localFlags[LOCAL_SIZE], *flagPtr;
    int numChars;
    char *result;
    register char *dst;
    int i;

    /*
     * Pass 1: estimate space, gather flags.
     */

    if (argc <= LOCAL_SIZE) {
	flagPtr = localFlags;
    } else {
	flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int));
    }
    numChars = 1;
    for (i = 0; i < argc; i++) {
	numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1;
    }

    /*
     * Pass two: copy into the result area.
     */

    result = (char *) ckalloc((unsigned) numChars);
    dst = result;
    for (i = 0; i < argc; i++) {
	numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]);
	dst += numChars;
	*dst = ' ';
	dst++;
    }
    if (dst == result) {
	*dst = 0;
    } else {
	dst[-1] = 0;
    }

    if (flagPtr != localFlags) {
	ckfree((char *) flagPtr);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_Concat --
 *
 *	Concatenate a set of strings into a single large string.
 *
 * Results:
 *	The return value is dynamically-allocated string containing
 *	a concatenation of all the strings in argv, with spaces between
 *	the original argv elements.
 *
 * Side effects:
 *	Memory is allocated for the result;  the caller is responsible
 *	for freeing the memory.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_Concat(argc, argv)
    int argc;			/* Number of strings to concatenate. */
    char **argv;		/* Array of strings to concatenate. */
{
    int totalSize, i;
    register char *p;
    char *result;

    for (totalSize = 1, i = 0; i < argc; i++) {
	totalSize += strlen(argv[i]) + 1;
    }
    result = (char *) ckalloc((unsigned) totalSize);
    if (argc == 0) {
	*result = '\0';
	return result;
    }
    for (p = result, i = 0; i < argc; i++) {
	char *element;
	int length;

	/*
	 * Clip white space off the front and back of the string
	 * to generate a neater result, and ignore any empty
	 * elements.
	 */

	element = argv[i];
	while (isspace(UCHAR(*element))) {
	    element++;
	}
	for (length = strlen(element);
		(length > 0) && (isspace(UCHAR(element[length-1])));
		length--) {
	    /* Null loop body. */
	}
	if (length == 0) {
	    continue;
	}
	(void) strncpy(p, element, length);
	p += length;
	*p = ' ';
	p++;
    }
    if (p != result) {
	p[-1] = 0;
    } else {
	*p = 0;
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_StringMatch --
 *
 *	See if a particular string matches a particular pattern.
 *
 * Results:
 *	The return value is 1 if string matches pattern, and
 *	0 otherwise.  The matching operation permits the following
 *	special characters in the pattern: *?\[] (see the manual
 *	entry for details on what these mean).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_StringMatch(string, pattern)
    register char *string;	/* String. */
    register char *pattern;	/* Pattern, which may contain
				 * special characters. */
{
    char c2;

    while (1) {
	/* See if we're at the end of both the pattern and the string.
	 * If so, we succeeded.  If we're at the end of the pattern
	 * but not at the end of the string, we failed.
	 */
	
	if (*pattern == 0) {
	    if (*string == 0) {
		return 1;
	    } else {
		return 0;
	    }
	}
	if ((*string == 0) && (*pattern != '*')) {
	    return 0;
	}

	/* Check for a "*" as the next pattern character.  It matches
	 * any substring.  We handle this by calling ourselves
	 * recursively for each postfix of string, until either we
	 * match or we reach the end of the string.
	 */
	
	if (*pattern == '*') {
	    pattern += 1;
	    if (*pattern == 0) {
		return 1;
	    }
	    while (1) {
		if (Tcl_StringMatch(string, pattern)) {
		    return 1;
		}
		if (*string == 0) {
		    return 0;
		}
		string += 1;
	    }
	}
    
	/* Check for a "?" as the next pattern character.  It matches
	 * any single character.
	 */

	if (*pattern == '?') {
	    goto thisCharOK;
	}

	/* Check for a "[" as the next pattern character.  It is followed
	 * by a list of characters that are acceptable, or by a range
	 * (two characters separated by "-").
	 */
	
	if (*pattern == '[') {
	    pattern += 1;
	    while (1) {
		if ((*pattern == ']') || (*pattern == 0)) {
		    return 0;
		}
		if (*pattern == *string) {
		    break;
		}
		if (pattern[1] == '-') {
		    c2 = pattern[2];
		    if (c2 == 0) {
			return 0;
		    }
		    if ((*pattern <= *string) && (c2 >= *string)) {
			break;
		    }
		    if ((*pattern >= *string) && (c2 <= *string)) {
			break;
		    }
		    pattern += 2;
		}
		pattern += 1;
	    }
	    while ((*pattern != ']') && (*pattern != 0)) {
		pattern += 1;
	    }
	    goto thisCharOK;
	}
    
	/* If the next pattern character is '/', just strip off the '/'
	 * so we do exact matching on the character that follows.
	 */
	
	if (*pattern == '\\') {
	    pattern += 1;
	    if (*pattern == 0) {
		return 0;
	    }
	}

	/* There's no special character.  Just make sure that the next
	 * characters of each string match.
	 */
	
	if (*pattern != *string) {
	    return 0;
	}

	thisCharOK: pattern += 1;
	string += 1;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetResult --
 *
 *	Arrange for "string" to be the Tcl return value.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	interp->result is left pointing either to "string" (if "copy" is 0)
 *	or to a copy of string.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetResult(interp, string, freeProc)
    Tcl_Interp *interp;		/* Interpreter with which to associate the
				 * return value. */
    char *string;		/* Value to be returned.  If NULL,
				 * the result is set to an empty string. */
    Tcl_FreeProc *freeProc;	/* Gives information about the string:
				 * TCL_STATIC, TCL_VOLATILE, or the address
				 * of a Tcl_FreeProc such as free. */
{
    register Interp *iPtr = (Interp *) interp;
    int length;
    Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
    char *oldResult = iPtr->result;

    iPtr->freeProc = freeProc;
    if (string == NULL) {
	iPtr->resultSpace[0] = 0;
	iPtr->result = iPtr->resultSpace;
	iPtr->freeProc = 0;
    } else if (freeProc == TCL_VOLATILE) {
	length = strlen(string);
	if (length > TCL_RESULT_SIZE) {
	    iPtr->result = (char *) ckalloc((unsigned) length+1);
	    iPtr->freeProc = (Tcl_FreeProc *) free;
	} else {
	    iPtr->result = iPtr->resultSpace;
	    iPtr->freeProc = 0;
	}
	strcpy(iPtr->result, string);
    } else {
	iPtr->result = string;
    }

    /*
     * If the old result was dynamically-allocated, free it up.  Do it
     * here, rather than at the beginning, in case the new result value
     * was part of the old result value.
     */

    if (oldFreeProc != 0) {
	if (oldFreeProc == (Tcl_FreeProc *) free) {
	    ckfree(oldResult);
	} else {
	    (*oldFreeProc)(oldResult);
	}
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendResult --
 *
 *	Append a variable number of strings onto the result already
 *	present for an interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The result in the interpreter given by the first argument
 *	is extended by the strings given by the second and following
 *	arguments (up to a terminating NULL argument).
 *
 *----------------------------------------------------------------------
 */

	/* VARARGS2 */
#ifndef lint
void
Tcl_AppendResult(va_alist)
#else
void
	/* VARARGS2 */ /* ARGSUSED */
Tcl_AppendResult(interp, p, va_alist)
    Tcl_Interp *interp;		/* Interpreter whose result is to be
				 * extended. */
    char *p;			/* One or more strings to add to the
				 * result, terminated with NULL. */
#endif
    va_dcl
{
    va_list argList;
    register Interp *iPtr;
    char *string;
    int newSpace;

    /*
     * First, scan through all the arguments to see how much space is
     * needed.
     */

    va_start(argList);
    iPtr = va_arg(argList, Interp *);
    newSpace = 0;
    while (1) {
	string = va_arg(argList, char *);
	if (string == NULL) {
	    break;
	}
	newSpace += strlen(string);
    }
    va_end(argList);

    /*
     * If the append buffer isn't already setup and large enough
     * to hold the new data, set it up.
     */

    if ((iPtr->result != iPtr->appendResult)
	    || (iPtr->appendResult[iPtr->appendUsed] != 0)
	    || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
       SetupAppendBuffer(iPtr, newSpace);
    }

    /*
     * Final step:  go through all the argument strings again, copying
     * them into the buffer.
     */

    va_start(argList);
    (void) va_arg(argList, Tcl_Interp *);
    while (1) {
	string = va_arg(argList, char *);
	if (string == NULL) {
	    break;
	}
	strcpy(iPtr->appendResult + iPtr->appendUsed, string);
	iPtr->appendUsed += strlen(string);
    }
    va_end(argList);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_AppendElement --
 *
 *	Convert a string to a valid Tcl list element and append it
 *	to the current result (which is ostensibly a list).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The result in the interpreter given by the first argument
 *	is extended with a list element converted from string.  A
 *	separator space is added before the converted list element
 *	unless the current result is empty, contains the single
 *	character "{", or ends in " {".
 *
 *----------------------------------------------------------------------
 */

void
Tcl_AppendElement(interp, string)
    Tcl_Interp *interp;		/* Interpreter whose result is to be
				 * extended. */
    char *string;		/* String to convert to list element and
				 * add to result. */
{
    register Interp *iPtr = (Interp *) interp;
    int size, flags;
    char *dst;
#ifdef KANJI
    int kanjiCode = TCL_ANY;
#endif /* KANJI */

    /*
     * See how much space is needed, and grow the append buffer if
     * needed to accommodate the list element.
     */

    size = Tcl_ScanElement(string, &flags) + 1;
    if ((iPtr->result != iPtr->appendResult)
	    || (iPtr->appendResult[iPtr->appendUsed] != 0)
	    || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
       SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
    }

    /*
     * Convert the string into a list element and copy it to the
     * buffer that's forming.
     */

    dst = iPtr->appendResult + iPtr->appendUsed;
    if ((iPtr->appendUsed > 0) && ((dst[-1] != '{')
#ifdef KANJI
	    || ((iPtr->appendUsed > 1) && ((dst[-2] == '\\')
		|| Tcl_KanjiEnd(iPtr->appendResult, &kanjiCode))))) {
#else
	    || ((iPtr->appendUsed > 1) && (dst[-2] == '\\')))) {
#endif /* KANJI */
	iPtr->appendUsed++;
	*dst = ' ';
	dst++;
    }
    iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);
}

/*
 *----------------------------------------------------------------------
 *
 * SetupAppendBuffer --
 *
 *	This procedure makes sure that there is an append buffer
 *	properly initialized for interp, and that it has at least
 *	enough room to accommodate newSpace new bytes of information.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
SetupAppendBuffer(iPtr, newSpace)
    register Interp *iPtr;	/* Interpreter whose result is being set up. */
    int newSpace;		/* Make sure that at least this many bytes
				 * of new information may be added. */
{
    int totalSpace;

    /*
     * Make the append buffer larger, if that's necessary, then
     * copy the current result into the append buffer and make the
     * append buffer the official Tcl result.
     */

    if (iPtr->result != iPtr->appendResult) {
	/*
	 * If an oversized buffer was used recently, then free it up
	 * so we go back to a smaller buffer.  This avoids tying up
	 * memory forever after a large operation.
	 */

	if (iPtr->appendAvl > 500) {
	    ckfree(iPtr->appendResult);
	    iPtr->appendResult = NULL;
	    iPtr->appendAvl = 0;
	}
	iPtr->appendUsed = strlen(iPtr->result);
    } else if (iPtr->result[iPtr->appendUsed] != 0) {
	/*
	 * Most likely someone has modified a result created by
	 * Tcl_AppendResult et al. so that it has a different size.
	 * Just recompute the size.
	 */

	iPtr->appendUsed = strlen(iPtr->result);
    }
    totalSpace = newSpace + iPtr->appendUsed;
    if (totalSpace >= iPtr->appendAvl) {
	char *new;

	if (totalSpace < 100) {
	    totalSpace = 200;
	} else {
	    totalSpace *= 2;
	}
	new = (char *) ckalloc((unsigned) totalSpace);
	strcpy(new, iPtr->result);
	if (iPtr->appendResult != NULL) {
	    ckfree(iPtr->appendResult);
	}
	iPtr->appendResult = new;
	iPtr->appendAvl = totalSpace;
    } else if (iPtr->result != iPtr->appendResult) {
	strcpy(iPtr->appendResult, iPtr->result);
    }
    Tcl_FreeResult(iPtr);
    iPtr->result = iPtr->appendResult;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ResetResult --
 *
 *	This procedure restores the result area for an interpreter
 *	to its default initialized state, freeing up any memory that
 *	may have been allocated for the result and clearing any
 *	error information for the interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_ResetResult(interp)
    Tcl_Interp *interp;		/* Interpreter for which to clear result. */
{
    register Interp *iPtr = (Interp *) interp;

    Tcl_FreeResult(iPtr);
    iPtr->result = iPtr->resultSpace;
    iPtr->resultSpace[0] = 0;
    iPtr->flags &=
	    ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SetErrorCode --
 *
 *	This procedure is called to record machine-readable information
 *	about an error that is about to be returned.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The errorCode global variable is modified to hold all of the
 *	arguments to this procedure, in a list form with each argument
 *	becoming one element of the list.  A flag is set internally
 *	to remember that errorCode has been set, so the variable doesn't
 *	get set automatically when the error is returned.
 *
 *----------------------------------------------------------------------
 */
	/* VARARGS2 */
#ifndef lint
void
Tcl_SetErrorCode(va_alist)
#else
void
	/* VARARGS2 */ /* ARGSUSED */
Tcl_SetErrorCode(interp, p, va_alist)
    Tcl_Interp *interp;		/* Interpreter whose errorCode variable is
				 * to be set. */
    char *p;			/* One or more elements to add to errorCode,
				 * terminated with NULL. */
#endif
    va_dcl
{
    va_list argList;
    char *string;
    int flags;
    Interp *iPtr;

    /*
     * Scan through the arguments one at a time, appending them to
     * $errorCode as list elements.
     */

    va_start(argList);
    iPtr = va_arg(argList, Interp *);
    flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
    while (1) {
	string = va_arg(argList, char *);
	if (string == NULL) {
	    break;
	}
	(void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
		(char *) NULL, string, flags);
	flags |= TCL_APPEND_VALUE;
    }
    va_end(argList);
    iPtr->flags |= ERROR_CODE_SET;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetListIndex --
 *
 *	Parse a list index, which may be either an integer or the
 *	value "end".
 *
 * Results:
 *	The return value is either TCL_OK or TCL_ERROR.  If it is
 *	TCL_OK, then the index corresponding to string is left in
 *	*indexPtr.  If the return value is TCL_ERROR, then string
 *	was bogus;  an error message is returned in interp->result.
 *	If a negative index is specified, it is rounded up to 0.
 *	The index value may be larger than the size of the list
 *	(this happens when "end" is specified).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclGetListIndex(interp, string, indexPtr)
    Tcl_Interp *interp;			/* Interpreter for error reporting. */
    char *string;			/* String containing list index. */
    int *indexPtr;			/* Where to store index. */
{
    if (isdigit(UCHAR(*string)) || (*string == '-')) {
	if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (*indexPtr < 0) {
	    *indexPtr = 0;
	}
    } else if (strncmp(string, "end", strlen(string)) == 0) {
	*indexPtr = 1<<30;
    } else {
	Tcl_AppendResult(interp, "bad index \"", string,
		"\": must be integer or \"end\"", (char *) NULL);
	return TCL_ERROR;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileRegexp --
 *
 *	Compile a regular expression into a form suitable for fast
 *	matching.  This procedure retains a small cache of pre-compiled
 *	regular expressions in the interpreter, in order to avoid
 *	compilation costs as much as possible.
 *
 * Results:
 *	The return value is a pointer to the compiled form of string,
 *	suitable for passing to TclRegExec.  If an error occurred while
 *	compiling the pattern, then NULL is returned and an error
 *	message is left in interp->result.
 *
 * Side effects:
 *	The cache of compiled regexp's in interp will be modified to
 *	hold information for string, if such information isn't already
 *	present in the cache.
 *
 *----------------------------------------------------------------------
 */

regexp *
TclCompileRegexp(interp, string)
    Tcl_Interp *interp;			/* For use in error reporting. */
    char *string;			/* String for which to produce
					 * compiled regular expression. */
{
    register Interp *iPtr = (Interp *) interp;
    int i, length;
    regexp *result;

    length = strlen(string);
    for (i = 0; i < NUM_REGEXPS; i++) {
	if ((length == iPtr->patLengths[i])
		&& (strcmp(string, iPtr->patterns[i]) == 0)) {
	    /*
	     * Move the matched pattern to the first slot in the
	     * cache and shift the other patterns down one position.
	     */

	    if (i != 0) {
		int j;
		char *cachedString;

		cachedString = iPtr->patterns[i];
		result = iPtr->regexps[i];
		for (j = i-1; j >= 0; j--) {
		    iPtr->patterns[j+1] = iPtr->patterns[j];
		    iPtr->patLengths[j+1] = iPtr->patLengths[j];
		    iPtr->regexps[j+1] = iPtr->regexps[j];
		}
		iPtr->patterns[0] = cachedString;
		iPtr->patLengths[0] = length;
		iPtr->regexps[0] = result;
	    }
	    return iPtr->regexps[0];
	}
    }

    /*
     * No match in the cache.  Compile the string and add it to the
     * cache.
     */

    tclRegexpError = NULL;
    result = TclRegComp(string);
    if (tclRegexpError != NULL) {
	Tcl_AppendResult(interp,
	    "couldn't compile regular expression pattern: ",
	    tclRegexpError, (char *) NULL);
	return NULL;
    }
    if (iPtr->patterns[NUM_REGEXPS-1] != NULL) {
	ckfree(iPtr->patterns[NUM_REGEXPS-1]);
	ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]);
    }
    for (i = NUM_REGEXPS - 2; i >= 0; i--) {
	iPtr->patterns[i+1] = iPtr->patterns[i];
	iPtr->patLengths[i+1] = iPtr->patLengths[i];
	iPtr->regexps[i+1] = iPtr->regexps[i];
    }
    iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1));
    strcpy(iPtr->patterns[0], string);
    iPtr->patLengths[0] = length;
    iPtr->regexps[0] = result;
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclRegError --
 *
 *	This procedure is invoked by the Henry Spencer's regexp code
 *	when an error occurs.  It saves the error message so it can
 *	be seen by the code that called Spencer's code.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The value of "string" is saved in "tclRegexpError".
 *
 *----------------------------------------------------------------------
 */

void
TclRegError(string)
    char *string;			/* Error message. */
{
    tclRegexpError = string;
}

#ifdef KANJI

Tcl_KanjiEncodeProc Tcl_KanjiEncode = { Tcl_EncodeJIS,
					Tcl_EncodeSJIS,
					Tcl_EncodeEUC,
					Tcl_EncodeANY };
Tcl_KanjiDecodeProc Tcl_KanjiDecode = { Tcl_DecodeJIS,
					Tcl_DecodeSJIS,
					Tcl_DecodeEUC,
					Tcl_DecodeANY };

#define ASCII	0
#define KANJI	1
#define KANA	2

/*
 *----------------------------------------------------------------------
 *
 * Tcl_EncodeJIS --
 *
 *	Encode JIS kanji string to wide string.
 *
 * Results:
 *	Number of the encoded characters. (Not bytes)
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_EncodeJIS(js, ws)
     unsigned char *js;
     wchar *ws;
{
    int	c, c1;
    int	kanji = ASCII;
    int	n = 0;

    while( c = *js++ ) {
	if( c == '\033' ) {
	    if( !strncmp(js, "$B", 2) || !strncmp(js, "$@", 2)) {
		kanji = KANJI;
		js += 2;
	    } else if( !strncmp(js, "(J", 2) || !strncmp(js, "(B", 2) ) {
		kanji = ASCII;
		js += 2;
	    } else if( !strncmp(js, "(I", 2) ) {
		kanji = KANA;
		js += 2;
	    } else {
		if( ws ) *ws++ = c;
		n++;
	    }
	} else if( kanji == KANJI ) {
	    c1 = *js++;
	    if( c1 == '\0' ) break;
	    if( ws ) *ws++ = (c << 8) | c1 | 0x8080;
	    n++;
	} else {
	    if( ws ) *ws++ = c | ((kanji == KANA) ? 0x80 : 0);
	    n++;
	}
    }
    if( ws ) *ws = 0;

    return n;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DecodeJIS --
 *
 *	Decode wide string to JIS kanji string.
 *
 * Results:
 *	Bytes of the decoded kanji string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DecodeJIS(ws, js)
     wchar *ws;
     unsigned char *js;
{
    int	c;
    int	kanji = ASCII;
    int	n = 0;

    while( c = *ws++ ) {
	switch( c & 0x8080 ) {
	  case 0:
	    if( kanji != ASCII ) {
		if( js ) {
		    *js++ = '\033';
		    *js++ = '(';
		    *js++ = 'B';
		}
		n += 3;
	    }
	    if( js ) *js++ = c & 0x7f;
	    n++;
	    kanji = ASCII;
	    break;
	  case 0x80:
	    if( kanji != KANA ) {
		if( js ) {
		    *js++ = '\033';
		    *js++ = '(';
		    *js++ = 'I';
		}
		n += 3;
	    }
	    if( js ) *js++ = c & 0x7f;
	    n++;
	    kanji = KANA;
	    break;
	  case 0x8080:
	    if( kanji != KANJI ) {
		if( js ) {
		    *js++ = '\033';
		    *js++ = '$';
		    *js++ = 'B';
		}
		n += 3;
	    }
	    if( js ) {
		*js++ = (c >> 8) & 0x7f;
		*js++ = c & 0x7f;
	    }
	    n += 2;
	    kanji = KANJI;
	    break;
	}
    }
    if( kanji != ASCII ) {
	if( js ) {
	    *js++ = '\033';
	    *js++ = '(';
	    *js++ = 'B';
	}
	n += 3;
    }
    if( js ) *js = '\0';

    return n;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_EncodeSJIS --
 *
 *	Encode SJIS kanji string to wide string.
 *
 * Results:
 *	Number of the encoded characters. (Not bytes)
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

#define IS_SJIS(c) (((c) >= 0x81 && (c) <= 0x9f) || ((c) >= 0xe0 && (c) <= 0xfc))

int
Tcl_EncodeSJIS(ss, ws)
     unsigned char *ss;
     wchar *ws;
{
    int	c, c1;
    int	n = 0;

    while( c = *ss++ ) {
	if( IS_SJIS(c) ) {
	    c1 = *ss++;
	    c -= (c>=0xa0) ? 0xc1 : 0x81;
	    if( ws ) {
		if( c1 >= 0x9f ) {
		    *ws++ = ((c<<9) + 0x2200 + c1 - 0x7e) | 0x8080;
		} else {
		    *ws++ = ((c<<9) + 0x2100 + c1
			     - ((c1<=0x7e) ? 0x1f : 0x20)) | 0x8080;
		}
	    }
	    n++;
	} else {
	    if( ws ) *ws++ = c;
	    n++;
	}
    }
    if( ws ) *ws = 0;

    return n;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DecodeSJIS --
 *
 *	Decode wide string to SJIS kanji string.
 *
 * Results:
 *	Bytes of the decoded kanji string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DecodeSJIS(ws, ss)
     wchar *ws;
     unsigned char *ss;
{
    int	c1, c2;
    int	n = 0;

    while( c1 = *ws++ ) {
	switch( c1 & 0x8080 ) {
	  case 0:
	  case 0x80:
	    if( ss ) *ss++ = c1 & 0xff;
	    n++;
	    break;
	  case 0x8080:
	    c2 = c1 & 0x7f;
	    c1 = (c1 >> 8) & 0x7f;
	    if( ss ) {
		*ss++ = (c1 - 0x21) / 2 + ((c1 <= 0x5e) ? 0x81 : 0xc1);
		if( c1 & 1 ) {	/* odd */
		    *ss++ = c2 + ((c2 <= 0x5f) ? 0x1f : 0x20);
		} else {
		    *ss++ = c2 + 0x7e;
		}
	    }
	    n += 2;
	    break;
	}
    }
    if( ss ) *ss = '\0';

    return n;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_EncodeEUC --
 *
 *	Encode EUC kanji string to wide string.
 *
 * Results:
 *	Number of the encoded characters. (Not bytes)
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_EncodeEUC(es, ws)
     unsigned char *es;
     wchar *ws;
{
    int	c;
    int	n = 0;

    while( c = *es++ ) {
	if( c == 0x8e ) {	/* SS2 */
	    if( ws ) *ws++ = *es | 0x80;
	    es++;
	    n++;
	} else if( c == 0x8f ) {	/* SS3 */
	    c = *es++;
	    if( ws ) *ws++ = (c << 8) | (*es & 0x7f) | 0x8000;
	    es++;
	    n++;
	} else if( c & 0x80 ) {
	    if( ws ) *ws++ = (c << 8) | *es | 0x8080;
	    es++;
	    n++;
	} else {
	    if( ws ) *ws++ = c;
	    n++;
	}
    }
    if( ws ) *ws = 0;

    return n;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DecodeEUC --
 *
 *	Decode wide string to EUC kanji string.
 *
 * Results:
 *	Bytes of the decoded kanji string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DecodeEUC(ws, es)
     wchar *ws;
     unsigned char *es;
{
    int	c;
    int	n = 0;

    while( c = *ws++ ) {
	switch( c & 0x8080 ) {
	  case 0:
	    if( es ) *es++ = c & 0x7f;
	    n++;
	    break;
	  case 0x80:
	    if( es ) {
		*es++ = 0x8e;	/* SS2 */
		*es++ = c & 0xff;
	    }
	    n += 2;
	    break;
	  case 0x8000:
	    if( es ) {
		*es++ = 0x8f;	/* SS3 */
		*es++ = (c >> 8) | 0x80;
		*es++ = (c & 0xff) | 0x80;
	    }
	    n += 3;
	    break;
	  case 0x8080:
	    if( es ) {
		*es++ = c >> 8;
		*es++ = c & 0xff;
	    }
	    n += 2;
	    break;
	}
    }
    if( es ) *es = '\0';

    return n;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_EncodeANY --
 *
 *	Encode ANY kanji string to wide string. (as ascii string)
 *
 * Results:
 *	Number of the encoded characters. (Not bytes)
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_EncodeANY(as, ws)
     unsigned char *as;
     wchar *ws;
{
    int c;
    int	n = 0;

    while( c = *as++ ) {
	if( ws ) *ws++ = c;
	n++;
    }
    if( ws ) *ws = 0;

    return n;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DecodeANY --
 *
 *	Decode wide string to ANY kanji string. (as ascii string)
 *
 * Results:
 *	Bytes of the decoded kanji string.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_DecodeANY(ws, as)
     wchar *ws;
     unsigned char *as;
{
    int	c;
    int	n = 0;

    while( c = *ws++ ) {
	switch( c & 0x8080 ) {
	  case 0:
	  case 0x80:
	    if( as ) *as++ = c & 0xff;
	    n++;
	    break;
	  case 0x8000:
	  case 0x8080:
	    if( as ) {
		*as++ = c >> 8;
		*as++ = c & 0xff;
	    }
	    n += 2;
	    break;
	}
    }
    if( as ) *as = '\0';

    return n;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DefaultKanjiCode --
 *
 *	Determine the default Kanji code from current locale.
 *
 * Results:
 *	This procudure returns a kanji code to be used as a default.
 *
 * Side effects:
 *	None.
 *----------------------------------------------------------------------
 */

int
Tcl_DefaultKanjiCode()
{
    char *lang;
    int i;
    static struct lang {
	char *lang;
	int code;
    } langtab[] = {
	"ja_JP.SJIS",	TCL_SJIS,
	"ja_JP.EUC",	TCL_EUC,
	"ja_JP.JIS",	TCL_JIS,
	"ja_JP.mscode",	TCL_SJIS,	/* from Xsi nls database */
	"ja_JP.ujis",	TCL_EUC,	/* from Xsi nls database */
	"ja_JP",	TCL_EUC,	/* IBM */
	"Ja_JP",	TCL_SJIS,	/* IBM */
	"Jp_JP",	TCL_SJIS,	/* IBM */
	"japan",	TCL_EUC,	/* MIPS, NEC */
#ifdef hpux
	"japanese",	TCL_SJIS,	/* HP */
#else
	"japanese",	TCL_EUC,	/* SUN */
#endif
	"japanese.sjis",TCL_SJIS,	/* HP? */
	"japanese.euc",	TCL_EUC,	/* HP */
	"japanese-sjis",TCL_SJIS,	/* IBM */
	"japanese-ujis",TCL_EUC,	/* IBM */
	"C",		TCL_ANY,
	NULL,		0,
    };

#ifdef HAVE_SETLOCALE
    static int firstcall = 1;

    if (firstcall) {
	setlocale(LC_ALL, "");
	firstcall = 0;
    }

    lang = setlocale(LC_CTYPE, NULL);
#else /* HAVE_SETLOCALE */
    lang = getenv("LANG");
#endif /* HAVE_SETLOCALE */

    if (lang != NULL) {
	/*
	 * If the LANG variable is "C", skip some of the
	 * Kanji related feature (e.g. automatic encoding detection)
	 */
#ifdef C_LOCALE_SPECIAL
	if (!strcmp(lang, "C")) noKanjiFeature = 1;
#endif /* C_LOCALE_SPECIAL */
	for (i = 0; langtab[i].lang != NULL; i++) {
	    if (!strcmp(langtab[i].lang, lang)) {
		return langtab[i].code;
	    }
	}
    }
    return TCL_DEFAULT_KANJI_CODE;
}


/*
 *----------------------------------------------------------------------
 *
 * Tcl_KanjiCode --
 *
 *	Returns the internal kanji code of the interpreter.
 *
 * Results:
 *	The internal kanji code.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_KanjiCode(interp)
     Tcl_Interp *interp;
{
    return ((Interp *)interp)->kanjiCode;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_KanjiStart --
 *
 *	Check if the string starts with kanji or not.
 *
 *	KanjiCodePtr is a pointer to an int which specifies
 *	the encoding of the given string.  This procedure
 *	checks if the first character of the string is a
 *	kanji.
 *
 *	If the value pointed by kanjiCodePtr is TCL_ANY,
 *	and if the first character of the string seems to be
 *	a kanji character, this procedure examines the string
 *	further, determines the encoding used, and assign the
 *	encoding value to *kanjiCodePtr.
 *
 * Results:
 *	If the first character of the given string is kanji,
 *	this procedure returns 1. Otherwise 0 is returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_KanjiStart(string, kanjiCodePtr)
     register unsigned char *string;
     register int *kanjiCodePtr;
{
    register unsigned char c = *string;

#ifdef C_LOCALE_SPECIAL
    if (noKanjiFeature) return 0;
#endif /* C_LOCALE_SPECIAL */
 retry:
    switch (*kanjiCodePtr) {
    case TCL_ANY:
	if (c != '\033' && c < 0x80) return 0;
	*kanjiCodePtr = EncodingDetection((Tcl_Interp *)NULL, string);
	goto retry;
    case TCL_JIS:
	return (c == '\033' && string[1] == '$' &&
		(string[2] == 'B' || string[2] == '@'));
    case TCL_SJIS:
	return ((0x81 <= c && c <= 0x9f) || (0xe0 <= c && c <= 0xfc));
    case TCL_EUC:
	return (c == 0x8e || c == 0x8f || (c & 0x80));
    default:	/* TCL_NOT_KANJI */
	return 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_KanjiEnd --
 *
 *	Check if the string ends with kanji or not.
 *
 *	KanjiCodePtr is a pointer to an int which specifies
 *	the encoding of the given string.  This procedure
 *	checks if the last character of the string is a
 *	kanji.
 *
 *	If the value pointed by kanjiCodePtr is TCL_ANY,
 *	and if the last character of the string seems to be
 *	a kanji character, this procedure examines the string
 *	further, determines the encoding used, and assign the
 *	encoding value to *kanjiCodePtr.
 *
 * Results:
 *	If the last character of the given string is kanji,
 *	this procedure returns 1. Otherwise 0 is returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_KanjiEnd(string, kanjiCodePtr)
     register unsigned char *string;
     register int *kanjiCodePtr;
{
    int len = strlen(string);
    unsigned char *p;
    int kanjiCode, result;

#ifdef C_LOCALE_SPECIAL
    if (noKanjiFeature) return 0;
#endif /* C_LOCALE_SPECIAL */

    switch (*kanjiCodePtr) {
    case TCL_ANY:
	while (*string != 0 && *string != '\033' && *string < 0x80) string++;
	break;
    case TCL_JIS:
	p = string + len;
	return (len > 3 && p[-3] == '\033' && p[-2] == '(' &&
		(p[-1] == 'J' || p[-1] == 'B'));
    case TCL_SJIS:
	while (len > 0 && string[--len] > 0x3F) ;
	string += len;
	while (*string != 0 && *string < 0x80) string++;
	break;
    case TCL_EUC:
	while (len > 0 && string[--len] > 0x7F) ;
	if (len > 0) string += (len + 1);
	break;
    default:	/* TCL_NOT_KANJI */
	return 0;
    }

    if ((len = strlen(string)) < 2) return 0;
    for (p = string; *p != 0; p++) {
	kanjiCode = *kanjiCodePtr;
	if ((result = Tcl_KanjiStart(p, &kanjiCode))) {
	    p += (Tcl_KanjiLength(p, kanjiCode) - 1);
	}
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_KanjiLength --
 *
 *	Count a byte number of the given kanji sequence.
 *
 * Results:
 *	Return value is a byte number of the kanji sequence.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_KanjiLength(string, kanjiCode)
     register unsigned char *string;
     register int kanjiCode;
{
    register unsigned char c, *src = string;

    switch( kanjiCode ) {
      case TCL_JIS:
	while( c = *src++ ) {
	    if( c == '\033' && *src == '(' &&
	       (*(src+1) == 'J' || *(src+1) == 'B') ) {
		src += 3;
		break;
	    }
	}
	break;
      case TCL_SJIS:
	while( c = *src++ ) {
	    if( (c >= 0x81 && c <= 0x9f) || (c >= 0xe0 && c <= 0xfc) ) {
		src++;
	    } else {
		break;
	    }
	}
	break;
      case TCL_EUC:
	while( c = *src++ ) {
	    if( c == 0x8e ) {
		src++;
	    } else if( c == 0x8f ) {
		src += 2;
	    } else if( c & 0x80 ) {
		src++;
	    } else {
		break;
	    }
	}
	break;
    }

    return (int )(src - string - 1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_KanjiString --
 *
 *	Check if the string contains kanji.
 *
 * Results:
 *	If the string contains kanji, set its kanji code
 *	and return TCL_OK.  Otherwise return TCL_NOT_KANJI.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_KanjiString(interp, string, kanjiCodePtr)
     Tcl_Interp *interp;
     char *string;
     int *kanjiCodePtr;
{
    int encoding;

    if (
#ifdef C_LOCALE_SPECIAL
	noKanjiFeature ||
#endif /* C_LOCALE_SPECIAL */
	(encoding = EncodingDetection(interp, string)) == TCL_NOT_KANJI) {
	*kanjiCodePtr = TCL_ANY;
	return TCL_NOT_KANJI;
    } else {
	*kanjiCodePtr = encoding;
	return TCL_OK;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * EncodingDetection --
 *
 *	Determine the encoding (kanji code) of the given string.
 *	This procedure assumes that the given string contains
 *	only ASCII and kanji (defined by the standard JIS X0208)
 *	characters. (i.e. no 1byte-kana and no user-defined
 *	characters are present)
 *
 *	The interp argument is used to retrieve the internal code
 *	of the interpreter, and the internal code is used to help
 *	determining the encoding when it is ambiguous.  Interp might
 *	be NULL.
 *
 * Results:
 *	The return value is the encoding (kanji code) of the
 *	given string.  If the string contains only ASCII
 *	characters, TCL_NOT_KANJI will be returned.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
EncodingDetection(interp, string)
    Tcl_Interp *interp;
    char *string;
{
    unsigned char *s = (unsigned char *)string;
    int c;
    int kanji_found = 0;

    while ((c = *s++) != '\0') {
	if (c == '\033') {
	    /*
	     * It might be JIS encoding.  The valid JIS
	     * sequences are:
	     *    ESC $ B  ESC $ ( B   -- designate JIS X0208
	     *    ESC $ @  ESC $ ( @   -- designate old JIS X0208
	     *    ESC ( B              -- designate ASCII
	     *    ESC ( J              -- designate JIS X0201
	     */
	    if (((c = *s++) == '$' &&
		 (((c = *s++) == '(' && ((c = *s++) == 'B' || c == '@')) ||
		  (c == 'B' || c == '@'))) ||
		(c == '(' && ((c = *s++) == 'B' || c == 'J'))) {
		return TCL_JIS;
	    }
	} else if (c <= 0x80) {
	    /*
	     * ASCII character or 0x80 (which is not a
	     * valid EUC/SJIS/JIS character) -- skip it
	     */
	    continue;
	} else if (c < 0xa1) {
	    /* SJIS character */
	    return TCL_SJIS;
	} else if (c < 0xdf) {
	    /* EUC character */
	    return TCL_EUC;
	} else if (c <= 0xea) {
	    /* SJIS or EUC character -- ambiguous */
	    /* get the second byte */
	    if ((c = *s++) < 0xa1) {
		return TCL_SJIS;
	    } else if (c > 0xfc) {
		return TCL_EUC;
	    }
	    /*
	     * Still ambiguous.  Continue examining, and
	     * remember that kanji is found.
	     */
	    kanji_found = 1;
	} else if (c <= 0xf4) {
	    /* EUC character */
	    return TCL_EUC;
	    break;
	}
	if (c == '\0') break;
    }

    if (kanji_found) {
	/*
	 * The given string contains kanji character(s),
	 * but the encoding cannot be determined. It is
	 * either SJIS or EUC.  So we have to make a guess,
	 * based on the following hypothesis:
	 *
	 * a) It is likely that the encoding of the string
	 *    is the same as the internal encoding of the interpreter,
	 *    which is determined by the environmental variable $LANG.
	 * b) If above fails (ie the internal code is neither
	 *    SJIS nor EUC), it is likely that the encoding
	 *    is the same as TCL_DEFAULT_KANJI_CODE, which
	 *    is chosen by the installer at compilation time.
	 */
	int internalCode;

	if (interp != NULL &&
	    ((internalCode = Tcl_KanjiCode(interp)) == TCL_SJIS ||
	     internalCode == TCL_EUC)) {
	    return internalCode;
	} else if (TCL_DEFAULT_KANJI_CODE == TCL_SJIS ||
		   TCL_DEFAULT_KANJI_CODE == TCL_EUC) {
	    return TCL_DEFAULT_KANJI_CODE;
	}
	return TCL_EUC;		/* no luck. just a wild guess */
    }

    /* no kanji found */
    return TCL_NOT_KANJI;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GetKanjiCode --
 *
 *	Get the kanji code according to the string.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_GetKanjiCode(interp, string, kanjiCodePtr)
     Tcl_Interp *interp;
     char *string;
     int *kanjiCodePtr;
{
    if( strcmp(string, "JIS") == 0 ) {
	*kanjiCodePtr = TCL_JIS;
    } else if( strcmp(string, "SJIS") == 0 ) {
	*kanjiCodePtr = TCL_SJIS;
    } else if( strcmp(string, "EUC") == 0 ) {
	*kanjiCodePtr = TCL_EUC;
    } else if( strcmp(string, "ANY") == 0 ) {
	*kanjiCodePtr = TCL_ANY;
    } else {
	Tcl_AppendResult(interp, "bad kanjiCode \"", string,
		"\": should be JIS, SJIS, EUC, or ANY", (char *) NULL);
	return TCL_ERROR;
    }

    return TCL_OK;
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_WStrlen --
 *
 *	Get the length of the wide string.
 *
 * Results:
 *	Number of the wide characters.
 *
 * Side effects:
 *	None.
 *
 *--------------------------------------------------------------
 */

int
Tcl_WStrlen(wstr)
     wchar *wstr;
{
    int n = 0;

    while( *wstr++ ) n++;

    return n;
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_WStrcpy --
 *
 *	Copy the wide string.
 *
 * Results:
 *	Pointer to the original string.
 *
 * Side effects:
 *	None.
 *
 *--------------------------------------------------------------
 */

wchar *
Tcl_WStrcpy(wstr1, wstr2)
     wchar *wstr1, *wstr2;
{
    wchar *ans = wstr1;

    while( *wstr1++ = *wstr2++ ) ;

    return( ans );
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_WStrncpy --
 *
 *	Copy the specific number of wide characters.
 *
 * Results:
 *	Pointer to the original string.
 *
 * Side effects:
 *	None.
 *
 *--------------------------------------------------------------
 */

wchar *
Tcl_WStrncpy(wstr1, wstr2, n)
     wchar *wstr1, *wstr2;
     int n;
{
    wchar *ans = wstr1;

    while( n-- > 0 && (*wstr1++ = *wstr2++) ) ;

    while( n-- > 0 ) *wstr1++ = 0;

    return( ans );
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_WStrcmp --
 *
 *	Compare two wide strings.
 *
 * Results:
 *	Return 0 if two strings are same.
 *
 * Side effects:
 *	None.
 *
 *--------------------------------------------------------------
 */

int
Tcl_WStrcmp(wstr1, wstr2)
     wchar *wstr1, *wstr2;
{
    while( *wstr1 && *wstr1 == *wstr2 ) wstr1++, wstr2++;

    return( *wstr1 - *wstr2 );
}

/*
 *--------------------------------------------------------------
 *
 * Tcl_WStrncmp --
 *
 *	Compare two wide strings.
 *
 * Results:
 *	Return 0 if two strings are same.
 *
 * Side effects:
 *	None.
 *
 *--------------------------------------------------------------
 */

int
Tcl_WStrncmp(wstr1, wstr2, n)
     wchar *wstr1, *wstr2;
     int n;
{
    while( n-- > 0 && *wstr1 && *wstr1 == *wstr2 ) wstr1++, wstr2++;

    if( n < 0 ) return( 0 );

    return( *wstr1 - *wstr2 );
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_WStringMatch --
 *
 *	See if a particular wide string matches a particular pattern.
 *
 * Results:
 *	The return value is 1 if string matches pattern, and
 *	0 otherwise.  The matching operation permits the following
 *	special characters in the pattern: *?\[] (see the manual
 *	entry for details on what these mean).
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_WStringMatch(string, pattern)
    register wchar *string;	/* String. */
    register wchar *pattern;	/* Pattern, which may contain
				 * special characters. */
{
    wchar c2;

    while (1) {
	/* See if we're at the end of both the pattern and the string.
	 * If so, we succeeded.  If we're at the end of the pattern
	 * but not at the end of the string, we failed.
	 */
	
	if (*pattern == 0) {
	    if (*string == 0) {
		return 1;
	    } else {
		return 0;
	    }
	}
	if ((*string == 0) && (*pattern != '*')) {
	    return 0;
	}

	/* Check for a "*" as the next pattern character.  It matches
	 * any substring.  We handle this by calling ourselves
	 * recursively for each postfix of string, until either we
	 * match or we reach the end of the string.
	 */
	
	if (*pattern == '*') {
	    pattern += 1;
	    if (*pattern == 0) {
		return 1;
	    }
	    while (1) {
		if (Tcl_WStringMatch(string, pattern)) {
		    return 1;
		}
		if (*string == 0) {
		    return 0;
		}
		string += 1;
	    }
	}
    
	/* Check for a "?" as the next pattern character.  It matches
	 * any single character.
	 */

	if (*pattern == '?') {
	    goto thisCharOK;
	}

	/* Check for a "[" as the next pattern character.  It is followed
	 * by a list of characters that are acceptable, or by a range
	 * (two characters separated by "-").
	 */
	
	if (*pattern == '[') {
	    pattern += 1;
	    while (1) {
		if ((*pattern == ']') || (*pattern == 0)) {
		    return 0;
		}
		if (*pattern == *string) {
		    break;
		}
		if (pattern[1] == '-') {
		    c2 = pattern[2];
		    if (c2 == 0) {
			return 0;
		    }
		    if ((*pattern <= *string) && (c2 >= *string)) {
			break;
		    }
		    if ((*pattern >= *string) && (c2 <= *string)) {
			break;
		    }
		    pattern += 2;
		}
		pattern += 1;
	    }
	    while ((*pattern != ']') && (*pattern != 0)) {
		pattern += 1;
	    }
	    goto thisCharOK;
	}
    
	/* If the next pattern character is '/', just strip off the '/'
	 * so we do exact matching on the character that follows.
	 */
	
	if (*pattern == '\\') {
	    pattern += 1;
	    if (*pattern == 0) {
		return 0;
	    }
	}

	/* There's no special character.  Just make sure that the next
	 * characters of each string match.
	 */
	
	if (*pattern != *string) {
	    return 0;
	}

	thisCharOK: pattern += 1;
	string += 1;
    }
}
#endif /* KANJI */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_RegExpMatch --
 *
 *	See if a string matches a regular expression.
 *
 * Results:
 *	If an error occurs during the matching operation then -1
 *	is returned and interp->result contains an error message.
 *	Otherwise the return value is 1 if "string" matches "pattern"
 *	and 0 otherwise.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
Tcl_RegExpMatch(interp, string, pattern)
    Tcl_Interp *interp;		/* Used for error reporting. */
    char *string;		/* String. */
    char *pattern;		/* Regular expression to match against
				 * string. */
{
    regexp *regexpPtr;
    int match;

    regexpPtr = TclCompileRegexp(interp, pattern);
    if (regexpPtr == NULL) {
	return -1;
    }
    tclRegexpError = NULL;
    match = TclRegExec(regexpPtr, string, string);
    if (tclRegexpError != NULL) {
	Tcl_ResetResult(interp);
	Tcl_AppendResult(interp, "error while matching regular expression: ",
		tclRegexpError, (char *) NULL);
	return -1;
    }
    return match;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringInit --
 *
 *	Initializes a dynamic string, discarding any previous contents
 *	of the string (Tcl_DStringFree should have been called already
 *	if the dynamic string was previously in use).
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The dynamic string is initialized to be empty.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DStringInit(dsPtr)
    register Tcl_DString *dsPtr;	/* Pointer to structure for
					 * dynamic string. */
{
    dsPtr->string = dsPtr->staticSpace;
    dsPtr->length = 0;
    dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
    dsPtr->staticSpace[0] = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringAppend --
 *
 *	Append more characters to the current value of a dynamic string.
 *
 * Results:
 *	The return value is a pointer to the dynamic string's new value.
 *
 * Side effects:
 *	Length bytes from string (or all of string if length is less
 *	than zero) are added to the current value of the string.  Memory
 *	gets reallocated if needed to accomodate the string's new size.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_DStringAppend(dsPtr, string, length)
    register Tcl_DString *dsPtr;	/* Structure describing dynamic
					 * string. */
    char *string;			/* String to append.  If length is
					 * -1 then this must be
					 * null-terminated. */
    int length;				/* Number of characters from string
					 * to append.  If < 0, then append all
					 * of string, up to null at end. */
{
    int newSize;
    char *newString;

    if (length < 0) {
	length = strlen(string);
    }
    newSize = length + dsPtr->length;

    /*
     * Allocate a larger buffer for the string if the current one isn't
     * large enough.  Allocate extra space in the new buffer so that there
     * will be room to grow before we have to allocate again.
     */

    if (newSize >= dsPtr->spaceAvl) {
	dsPtr->spaceAvl = newSize*2;
	newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
	strcpy(newString, dsPtr->string);
	if (dsPtr->string != dsPtr->staticSpace) {
	    ckfree(dsPtr->string);
	}
	dsPtr->string = newString;
    }

    /*
     * Copy the new string into the buffer at the end of the old
     * one.
     */

    strncpy(dsPtr->string + dsPtr->length, string, length);
    dsPtr->length += length;
    dsPtr->string[dsPtr->length] = 0;
    return dsPtr->string;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringAppendElement --
 *
 *	Append a list element to the current value of a dynamic string.
 *
 * Results:
 *	The return value is a pointer to the dynamic string's new value.
 *
 * Side effects:
 *	String is reformatted as a list element and added to the current
 *	value of the string.  Memory gets reallocated if needed to
 *	accomodate the string's new size.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_DStringAppendElement(dsPtr, string)
    register Tcl_DString *dsPtr;	/* Structure describing dynamic
					 * string. */
    char *string;			/* String to append.  Must be
					 * null-terminated. */
{
    int newSize, flags;
    char *dst, *newString;
#ifdef KANJI
    int kanjiCode = TCL_ANY;
#endif /* KANJI */

    newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1;

    /*
     * Allocate a larger buffer for the string if the current one isn't
     * large enough.  Allocate extra space in the new buffer so that there
     * will be room to grow before we have to allocate again.
     */

    if (newSize >= dsPtr->spaceAvl) {
	dsPtr->spaceAvl = newSize*2;
	newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
	strcpy(newString, dsPtr->string);
	if (dsPtr->string != dsPtr->staticSpace) {
	    ckfree(dsPtr->string);
	}
	dsPtr->string = newString;
    }

    /*
     * Convert the new string to a list element and copy it into the
     * buffer at the end.  Add a space separator unless we're at the
     * start of the string or just after an unbackslashed "{".
     */

    dst = dsPtr->string + dsPtr->length;
    if ((dsPtr->length > 0) && ((dst[-1] != '{')
#ifdef KANJI
	    || ((dsPtr->length > 1) && ((dst[-2] == '\\')
		|| Tcl_KanjiEnd(dsPtr->string, &kanjiCode))))) {
#else
	    || ((dsPtr->length > 1) && (dst[-2] == '\\')))) {
#endif /* KANJI */
	*dst = ' ';
	dst++;
	dsPtr->length++;
    }
    dsPtr->length += Tcl_ConvertElement(string, dst, flags);
    return dsPtr->string;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringTrunc --
 *
 *	Truncate a dynamic string to a given length without freeing
 *	up its storage.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The length of dsPtr is reduced to length unless it was already
 *	shorter than that.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DStringTrunc(dsPtr, length)
    register Tcl_DString *dsPtr;	/* Structure describing dynamic
					 * string. */
    int length;				/* New length for dynamic string. */
{
    if (length < 0) {
	length = 0;
    }
    if (length < dsPtr->length) {
	dsPtr->length = length;
	dsPtr->string[length] = 0;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringFree --
 *
 *	Frees up any memory allocated for the dynamic string and
 *	reinitializes the string to an empty state.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The previous contents of the dynamic string are lost, and
 *	the new value is an empty string.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DStringFree(dsPtr)
    register Tcl_DString *dsPtr;	/* Structure describing dynamic
					 * string. */
{
    if (dsPtr->string != dsPtr->staticSpace) {
	ckfree(dsPtr->string);
    }
    dsPtr->string = dsPtr->staticSpace;
    dsPtr->length = 0;
    dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
    dsPtr->staticSpace[0] = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringResult --
 *
 *	This procedure moves the value of a dynamic string into an
 *	interpreter as its result.  The string itself is reinitialized
 *	to an empty string.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The string is "moved" to interp's result, and any existing
 *	result for interp is freed up.  DsPtr is reinitialized to
 *	an empty string.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DStringResult(interp, dsPtr)
    Tcl_Interp *interp;			/* Interpreter whose result is to be
					 * reset. */
    Tcl_DString *dsPtr;			/* Dynamic string that is to become
					 * the result of interp. */
{
    Tcl_FreeResult(interp);
    if (dsPtr->string != dsPtr->staticSpace) {
	interp->result = dsPtr->string;
	interp->freeProc = (Tcl_FreeProc *) free;
    } else if (dsPtr->length < TCL_RESULT_SIZE) {
	strcpy(interp->result, dsPtr->string);
    } else {
	Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE);
    }
    dsPtr->string = dsPtr->staticSpace;
    dsPtr->length = 0;
    dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
    dsPtr->staticSpace[0] = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringStartSublist --
 *
 *	This procedure adds the necessary information to a dynamic
 *	string (e.g. " {" to start a sublist.  Future element
 *	appends will be in the sublist rather than the main list.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Characters get added to the dynamic string.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DStringStartSublist(dsPtr)
    Tcl_DString *dsPtr;			/* Dynamic string. */
{
#ifdef KANJI
    int kanjiCode = TCL_ANY;
#endif /* KANJI */
    if ((dsPtr->length == 0)
	    || ((dsPtr->length == 1) && (dsPtr->string[0] == '{'))
#ifdef KANJI
	    || ((dsPtr->length > 1) && (dsPtr->string[dsPtr->length-1] == '{')
		    && (dsPtr->string[dsPtr->length-2] != '\\')
		    && !Tcl_KanjiEnd(dsPtr->string, &kanjiCode))) {
#else
	    || ((dsPtr->length > 1) && (dsPtr->string[dsPtr->length-1] == '{')
		    && (dsPtr->string[dsPtr->length-2] != '\\'))) {
#endif /* KANJI */
	Tcl_DStringAppend(dsPtr, "{", -1);
    } else {
	Tcl_DStringAppend(dsPtr, " {", -1);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_DStringEndSublist --
 *
 *	This procedure adds the necessary characters to a dynamic
 *	string to end a sublist (e.g. "}").  Future element appends
 *	will be in the enclosing (sub)list rather than the current
 *	sublist.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_DStringEndSublist(dsPtr)
    Tcl_DString *dsPtr;			/* Dynamic string. */
{
    Tcl_DStringAppend(dsPtr, "}", -1);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_PrintDouble --
 *
 *	Given a floating-point value, this procedure converts it to
 *	an ASCII string using.
 *
 * Results:
 *	The ASCII equivalent of "value" is written at "dst".  It is
 *	written using the current precision, and it is guaranteed to
 *	contain a decimal point or exponent, so that it looks like
 *	a floating-point value and not an integer.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_PrintDouble(interp, value, dst)
    Tcl_Interp *interp;			/* Interpreter whose tcl_precision
					 * variable controls printing. */
    double value;			/* Value to print as string. */
    char *dst;				/* Where to store converted value;
					 * must have at least TCL_DOUBLE_SPACE
					 * characters. */
{
    register char *p;
    sprintf(dst, ((Interp *) interp)->pdFormat, value);

    /*
     * If the ASCII result looks like an integer, add ".0" so that it
     * doesn't look like an integer anymore.  This prevents floating-point
     * values from being converted to integers unintentionally.
     */

    for (p = dst; *p != 0; p++) {
	if ((*p == '.') || (isalpha(UCHAR(*p)))) {
	    return;
	}
    }
    p[0] = '.';
    p[1] = '0';
    p[2] = 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclPrecTraceProc --
 *
 *	This procedure is invoked whenever the variable "tcl_precision"
 *	is written.
 *
 * Results:
 *	Returns NULL if all went well, or an error message if the
 *	new value for the variable doesn't make sense.
 *
 * Side effects:
 *	If the new value doesn't make sense then this procedure
 *	undoes the effect of the variable modification.  Otherwise
 *	it modifies the format string that's used by Tcl_PrintDouble.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
char *
TclPrecTraceProc(clientData, interp, name1, name2, flags)
    ClientData clientData;	/* Not used. */
    Tcl_Interp *interp;		/* Interpreter containing variable. */
    char *name1;		/* Name of variable. */
    char *name2;		/* Second part of variable name. */
    int flags;			/* Information about what happened. */
{
    register Interp *iPtr = (Interp *) interp;
    char *value, *end;
    int prec;

    /*
     * If the variable is unset, then recreate the trace and restore
     * the default value of the format string.
     */

    if (flags & TCL_TRACE_UNSETS) {
	if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) {
	    Tcl_TraceVar2(interp, name1, name2,
		    TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
		    TclPrecTraceProc, clientData);
	}
	strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT);
	iPtr->pdPrec = DEFAULT_PD_PREC;
	return (char *) NULL;
    }

    value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
    if (value == NULL) {
	value = "";
    }
    prec = (int) strtoul(value, &end, 10);
    if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) ||
	    (end == value) || (*end != 0)) {
	char oldValue[10];

	sprintf(oldValue, "%d", iPtr->pdPrec);
	Tcl_SetVar2(interp, name1, name2, oldValue, flags & TCL_GLOBAL_ONLY);
	return "improper value for precision";
    }
    sprintf(iPtr->pdFormat, "%%.%dg", prec);
    iPtr->pdPrec = prec;
    return (char *) NULL;
}
