/* 
 * tclCmdIL.c --
 *
 *	This file contains the top-level command routines for most of
 *	the Tcl built-in commands whose names begin with the letters
 *	I through L.  It contains only commands in the generic core
 *	(i.e. those that don't depend much upon UNIX facilities).
 *
 * 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/tclCmdIL.c,v 1.103 93/10/28 16:19:29 ouster Exp $ SPRITE (Berkeley)";
#endif

#include "tclInt.h"
#include "patchlevel.h"

/*
 * The variables below are used to implement the "lsort" command.
 * Unfortunately, this use of static variables prevents "lsort"
 * from being thread-safe, but there's no alternative given the
 * current implementation of qsort.  In a threaded environment
 * these variables should be made thread-local if possible, or else
 * "lsort" needs internal mutual exclusion.
 */

static Tcl_Interp *sortInterp;		/* Interpreter for "lsort" command. */
static enum {ASCII, INTEGER, REAL, COMMAND} sortMode;
					/* Mode for sorting: compare as strings,
					 * compare as numbers, or call
					 * user-defined command for
					 * comparison. */
static Tcl_DString sortCmd;		/* Holds command if mode is COMMAND.
					 * pre-initialized to hold base of
					 * command. */
static int sortIncreasing;		/* 0 means sort in decreasing order,
					 * 1 means increasing order. */
static int sortCode;			/* Anything other than TCL_OK means a
					 * problem occurred while sorting; this
					 * executing a comparison command, so
					 * the sort was aborted. */

/*
 * Forward declarations for procedures defined in this file:
 */

static int		SortCompareProc _ANSI_ARGS_((CONST VOID *first,
			    CONST VOID *second));
#ifdef KANJI
static int		SortKanjiCompareProc _ANSI_ARGS_((CONST VOID *first,
			    CONST VOID *second));
#endif /* KANJI */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_IfCmd --
 *
 *	This procedure is invoked to process the "if" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_IfCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int i, result, value;

    i = 1;
    while (1) {
	/*
	 * At this point in the loop, argv and argc refer to an expression
	 * to test, either for the main expression or an expression
	 * following an "elseif".  The arguments after the expression must
	 * be "then" (optional) and a script to execute if the expression is
	 * true.
	 */

	if (i >= argc) {
	    Tcl_AppendResult(interp, "wrong # args: no expression after \"",
		    argv[i-1], "\" argument", (char *) NULL);
	    return TCL_ERROR;
	}
	result = Tcl_ExprBoolean(interp, argv[i], &value);
	if (result != TCL_OK) {
	    return result;
	}
	i++;
	if ((i < argc) && (strcmp(argv[i], "then") == 0)) {
	    i++;
	}
	if (i >= argc) {
	    Tcl_AppendResult(interp, "wrong # args: no script following \"",
		    argv[i-1], "\" argument", (char *) NULL);
	    return TCL_ERROR;
	}
	if (value) {
	    return Tcl_Eval(interp, argv[i]);
	}

	/*
	 * The expression evaluated to false.  Skip the command, then
	 * see if there is an "else" or "elseif" clause.
	 */

	i++;
	if (i >= argc) {
	    return TCL_OK;
	}
	if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0)) {
	    i++;
	    continue;
	}
	break;
    }

    /*
     * Couldn't find a "then" or "elseif" clause to execute.  Check now
     * for an "else" clause.  We know that there's at least one more
     * argument when we get here.
     */

    if (strcmp(argv[i], "else") == 0) {
	i++;
	if (i >= argc) {
	    Tcl_AppendResult(interp,
		    "wrong # args: no script following \"else\" argument",
		    (char *) NULL);
	    return TCL_ERROR;
	}
    }
    return Tcl_Eval(interp, argv[i]);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_IncrCmd --
 *
 *	This procedure is invoked to process the "incr" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

    /* ARGSUSED */
int
Tcl_IncrCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int value;
    char *oldString, *result;
    char newString[30];

    if ((argc != 2) && (argc != 3)) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" varName ?increment?\"", (char *) NULL);
	return TCL_ERROR;
    }

    oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
    if (oldString == NULL) {
	return TCL_ERROR;
    }
    if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
	Tcl_AddErrorInfo(interp,
		"\n    (reading value of variable to increment)");
	return TCL_ERROR;
    }
    if (argc == 2) {
	value += 1;
    } else {
	int increment;

	if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
	    Tcl_AddErrorInfo(interp,
		    "\n    (reading increment)");
	    return TCL_ERROR;
	}
	value += increment;
    }
    sprintf(newString, "%d", value);
    result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
    if (result == NULL) {
	return TCL_ERROR;
    }
    interp->result = result;
    return TCL_OK; 
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_InfoCmd --
 *
 *	This procedure is invoked to process the "info" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_InfoCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    register Interp *iPtr = (Interp *) interp;
    int length;
    char c;
    Arg *argPtr;
    Proc *procPtr;
    Var *varPtr;
    Command *cmdPtr;
    Tcl_HashEntry *hPtr;
    Tcl_HashSearch search;

    if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" option ?arg arg ...?\"", (char *) NULL);
	return TCL_ERROR;
    }
    c = argv[1][0];
    length = strlen(argv[1]);
    if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) {
	if (argc != 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " args procname\"", (char *) NULL);
	    return TCL_ERROR;
	}
	procPtr = TclFindProc(iPtr, argv[2]);
	if (procPtr == NULL) {
	    infoNoSuchProc:
	    Tcl_AppendResult(interp, "\"", argv[2],
		    "\" isn't a procedure", (char *) NULL);
	    return TCL_ERROR;
	}
	for (argPtr = procPtr->argPtr; argPtr != NULL;
		argPtr = argPtr->nextPtr) {
	    Tcl_AppendElement(interp, argPtr->name);
	}
	return TCL_OK;
    } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) {
	if (argc != 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " body procname\"", (char *) NULL);
	    return TCL_ERROR;
	}
	procPtr = TclFindProc(iPtr, argv[2]);
	if (procPtr == NULL) {
	    goto infoNoSuchProc;
	}
	iPtr->result = procPtr->command;
	return TCL_OK;
    } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0)
	    && (length >= 2)) {
	if (argc != 2) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " cmdcount\"", (char *) NULL);
	    return TCL_ERROR;
	}
	sprintf(iPtr->result, "%d", iPtr->cmdCount);
	return TCL_OK;
    } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0)
	    && (length >= 4)) {
	if (argc > 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " commands [pattern]\"", (char *) NULL);
	    return TCL_ERROR;
	}
	for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
		hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	    char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
	    if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
		continue;
	    }
	    Tcl_AppendElement(interp, name);
	}
	return TCL_OK;
    } else if ((c == 'c') && (strncmp(argv[1], "complete", length) == 0)
	    && (length >= 4)) {
	if (argc != 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " complete command\"", (char *) NULL);
	    return TCL_ERROR;
	}
	if (Tcl_CommandComplete(argv[2])) {
	    interp->result = "1";
	} else {
	    interp->result = "0";
	}
	return TCL_OK;
    } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) {
	if (argc != 5) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " default procname arg varname\"",
		    (char *) NULL);
	    return TCL_ERROR;
	}
	procPtr = TclFindProc(iPtr, argv[2]);
	if (procPtr == NULL) {
	    goto infoNoSuchProc;
	}
	for (argPtr = procPtr->argPtr; ; argPtr = argPtr->nextPtr) {
	    if (argPtr == NULL) {
		Tcl_AppendResult(interp, "procedure \"", argv[2],
			"\" doesn't have an argument \"", argv[3],
			"\"", (char *) NULL);
		return TCL_ERROR;
	    }
	    if (strcmp(argv[3], argPtr->name) == 0) {
		if (argPtr->defValue != NULL) {
		    if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4],
			    argPtr->defValue, 0) == NULL) {
			defStoreError:
			Tcl_AppendResult(interp,
				"couldn't store default value in variable \"",
				argv[4], "\"", (char *) NULL);
			return TCL_ERROR;
		    }
		    iPtr->result = "1";
		} else {
		    if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0)
			    == NULL) {
			goto defStoreError;
		    }
		    iPtr->result = "0";
		}
		return TCL_OK;
	    }
	}
    } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) {
	char *p;
	if (argc != 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " exists varName\"", (char *) NULL);
	    return TCL_ERROR;
	}
	p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0);

	/*
	 * The code below handles the special case where the name is for
	 * an array:  Tcl_GetVar will reject this since you can't read
	 * an array variable without an index.
	 */

	if (p == NULL) {
	    Tcl_HashEntry *hPtr;
	    Var *varPtr;

	    if (strchr(argv[2], '(') != NULL) {
		noVar:
		iPtr->result = "0";
		return TCL_OK;
	    }
	    if (iPtr->varFramePtr == NULL) {
		hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
	    } else {
		hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
	    }
	    if (hPtr == NULL) {
		goto noVar;
	    }
	    varPtr = (Var *) Tcl_GetHashValue(hPtr);
	    if (varPtr->flags & VAR_UPVAR) {
		varPtr = varPtr->value.upvarPtr;
	    }
	    if (!(varPtr->flags & VAR_ARRAY)) {
		goto noVar;
	    }
	}
	iPtr->result = "1";
	return TCL_OK;
    } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) {
	char *name;

	if (argc > 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " globals [pattern]\"", (char *) NULL);
	    return TCL_ERROR;
	}
	for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search);
		hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	    varPtr = (Var *) Tcl_GetHashValue(hPtr);
	    if (varPtr->flags & VAR_UNDEFINED) {
		continue;
	    }
	    name = Tcl_GetHashKey(&iPtr->globalTable, hPtr);
	    if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
		continue;
	    }
	    Tcl_AppendElement(interp, name);
	}
	return TCL_OK;
    } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0)
	    && (length >= 2)) {
	if (argc == 2) {
	    if (iPtr->varFramePtr == NULL) {
		iPtr->result = "0";
	    } else {
		sprintf(iPtr->result, "%d", iPtr->varFramePtr->level);
	    }
	    return TCL_OK;
	} else if (argc == 3) {
	    int level;
	    CallFrame *framePtr;

	    if (Tcl_GetInt(interp, argv[2], &level) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (level <= 0) {
		if (iPtr->varFramePtr == NULL) {
		    levelError:
		    Tcl_AppendResult(interp, "bad level \"", argv[2],
			    "\"", (char *) NULL);
		    return TCL_ERROR;
		}
		level += iPtr->varFramePtr->level;
	    }
	    for (framePtr = iPtr->varFramePtr; framePtr != NULL;
		    framePtr = framePtr->callerVarPtr) {
		if (framePtr->level == level) {
		    break;
		}
	    }
	    if (framePtr == NULL) {
		goto levelError;
	    }
	    iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv);
	    iPtr->freeProc = (Tcl_FreeProc *) free;
	    return TCL_OK;
	}
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" level [number]\"", (char *) NULL);
	return TCL_ERROR;
    } else if ((c == 'l') && (strncmp(argv[1], "library", length) == 0)
	    && (length >= 2)) {
	if (argc != 2) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " library\"", (char *) NULL);
	    return TCL_ERROR;
	}
	interp->result = getenv("TCL_LIBRARY");
	if (interp->result == NULL) {
#ifdef TCL_LIBRARY
	    interp->result = TCL_LIBRARY;
#else
	    interp->result = "there is no Tcl library at this installation";
	    return TCL_ERROR;
#endif
	}
	return TCL_OK;
    } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0)
	    && (length >= 2)) {
	char *name;

	if (argc > 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " locals [pattern]\"", (char *) NULL);
	    return TCL_ERROR;
	}
	if (iPtr->varFramePtr == NULL) {
	    return TCL_OK;
	}
	for (hPtr = Tcl_FirstHashEntry(&iPtr->varFramePtr->varTable, &search);
		hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	    varPtr = (Var *) Tcl_GetHashValue(hPtr);
	    if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR)) {
		continue;
	    }
	    name = Tcl_GetHashKey(&iPtr->varFramePtr->varTable, hPtr);
	    if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
		continue;
	    }
	    Tcl_AppendElement(interp, name);
	}
	return TCL_OK;
    } else if ((c == 'p') && (strncmp(argv[1], "patchlevel", length) == 0)
	    && (length >= 2)) {
	if (argc != 2) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " patchlevel\"", (char *) NULL);
	    return TCL_ERROR;
	}
	sprintf(interp->result, "%d", TCL_PATCH_LEVEL);
	return TCL_OK;
    } else if ((c == 'p') && (strncmp(argv[1], "procs", length) == 0)
	    && (length >= 2)) {
	if (argc > 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " procs [pattern]\"", (char *) NULL);
	    return TCL_ERROR;
	}
	for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
		hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	    char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);

	    cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
	    if (!TclIsProc(cmdPtr)) {
		continue;
	    }
	    if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
		continue;
	    }
	    Tcl_AppendElement(interp, name);
	}
	return TCL_OK;
    } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0)) {
	if (argc != 2) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " script\"", (char *) NULL);
	    return TCL_ERROR;
	}
	if (iPtr->scriptFile != NULL) {
	    /*
	     * Can't depend on iPtr->scriptFile to be non-volatile:
	     * if this command is returned as the result of the script,
	     * then iPtr->scriptFile will go away.
	     */

	    Tcl_SetResult(interp, iPtr->scriptFile, TCL_VOLATILE);
	}
	return TCL_OK;
    } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) {
	if (argc != 2) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " tclversion\"", (char *) NULL);
	    return TCL_ERROR;
	}

	/*
	 * Note:  TCL_VERSION below is expected to be set with a "-D"
	 * switch in the Makefile.
	 */

	strcpy(iPtr->result, TCL_VERSION);
	return TCL_OK;
    } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) {
	Tcl_HashTable *tablePtr;
	char *name;

	if (argc > 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"",
		    argv[0], " vars [pattern]\"", (char *) NULL);
	    return TCL_ERROR;
	}
	if (iPtr->varFramePtr == NULL) {
	    tablePtr = &iPtr->globalTable;
	} else {
	    tablePtr = &iPtr->varFramePtr->varTable;
	}
	for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);
		hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
	    varPtr = (Var *) Tcl_GetHashValue(hPtr);
	    if (varPtr->flags & VAR_UNDEFINED) {
		continue;
	    }
	    name = Tcl_GetHashKey(tablePtr, hPtr);
	    if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
		continue;
	    }
	    Tcl_AppendElement(interp, name);
	}
	return TCL_OK;
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": should be args, body, cmdcount, commands, ",
		"complete, default, ",
		"exists, globals, level, library, locals, ",
		"patchlevel, procs, script, tclversion, or vars",
		(char *) NULL);
	return TCL_ERROR;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_JoinCmd --
 *
 *	This procedure is invoked to process the "join" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_JoinCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    char *joinString;
    char **listArgv;
    int listArgc, i;

    if (argc == 2) {
	joinString = " ";
    } else if (argc == 3) {
	joinString = argv[2];
    } else {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" list ?joinString?\"", (char *) NULL);
	return TCL_ERROR;
    }

    if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
	return TCL_ERROR;
    }
    for (i = 0; i < listArgc; i++) {
	if (i == 0) {
	    Tcl_AppendResult(interp, listArgv[0], (char *) NULL);
	} else  {
	    Tcl_AppendResult(interp, joinString, listArgv[i], (char *) NULL);
	}
    }
    ckfree((char *) listArgv);
    return TCL_OK;
}

#ifdef KANJI
/*
 *----------------------------------------------------------------------
 *
 * Tcl_KanjiCmd --
 *
 *	This procedure is invoked to process the "kanji" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_KanjiCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    register char c;
    int length;

    if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" option arg ?arg ...?\"", (char *) NULL);
	return TCL_ERROR;
    }
    c = argv[1][0];
    length = strlen(argv[1]);
    if ((c == 'c') && (strncmp(argv[1], "code", length) == 0)) {
	int kanjiCode;

	if (argc != 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " code string\"", (char *) NULL);
	    return TCL_ERROR;
	}
	(void )Tcl_KanjiString(interp, argv[2], &kanjiCode);
	Tcl_SetResult(interp, Tcl_KanjiCodeStr[kanjiCode], 0);
	return TCL_OK;
    } else if ((c == 'c') && (strncmp(argv[1], "conversion", length) == 0)
	    && (length >= 4)) {
	int from, to;
	wchar *wstr;
	char *str;

	if (argc != 5) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " conversion fromCode toCode string\"", (char *) NULL);
	    return TCL_ERROR;
	}
	if (Tcl_GetKanjiCode(interp, argv[2], &from) == TCL_ERROR) return TCL_ERROR;
	if (Tcl_GetKanjiCode(interp, argv[3], &to) == TCL_ERROR) return TCL_ERROR;

	if (from == to) {
	    Tcl_SetResult(interp, argv[4], TCL_VOLATILE);
	    return TCL_OK;
	}
	wstr = (wchar *)ckalloc((unsigned)((Tcl_KanjiEncode[from])(argv[4], NULL) + 1) * 2);
	(void )(Tcl_KanjiEncode[from])(argv[4], wstr);
	str = (char *)ckalloc((unsigned)((Tcl_KanjiDecode[to])(wstr, NULL) + 1));
	(void )(Tcl_KanjiDecode[to])(wstr, str);
	Tcl_SetResult(interp, str, TCL_VOLATILE);
	ckfree((char *)wstr);
	ckfree(str);
	return TCL_OK;
    } else if ((c == 'd') && (strncmp(argv[1], "defaultInputCode", length) == 0)
	    && (length >= 8)) {
	Interp *iPtr = (Interp *)interp;

	if (argc > 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " defaultInputCode ?value?\"", (char *) NULL);
	    return TCL_ERROR;
	}
	if (argc == 3) {
	    if (Tcl_GetKanjiCode(interp, argv[2], &(iPtr->kanjiCodeInput))
		    == TCL_ERROR) {
		return TCL_ERROR;
	    }
	}
	Tcl_SetResult(interp, Tcl_KanjiCodeStr[iPtr->kanjiCodeInput], 0);
	return TCL_OK;
    } else if ((c == 'd') && (strncmp(argv[1], "defaultOutputCode", length) == 0)
	    && (length >= 8)) {
	Interp *iPtr = (Interp *)interp;

	if (argc > 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " defaultOutputCode ?value?\"", (char *) NULL);
	    return TCL_ERROR;
	}
	if (argc == 3) {
	    if (Tcl_GetKanjiCode(interp, argv[2], &(iPtr->kanjiCodeOutput))
		    == TCL_ERROR) {
		return TCL_ERROR;
	    }
	}
	Tcl_SetResult(interp, Tcl_KanjiCodeStr[iPtr->kanjiCodeOutput], 0);
	return TCL_OK;
    } else if ((c == 'i') && (strncmp(argv[1], "inputCode", length) == 0)
	    && (length >= 3)) {
	Interp *iPtr = (Interp *)interp;
	FILE *f;
	OpenFile *oFilePtr;

	if (argc != 3 && argc != 4) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " inputCode fileId ?value?\"", (char *) NULL);
	    return TCL_ERROR;
	}
	if (Tcl_GetOpenFile(interp, argv[2], 0, 1, &f) != TCL_OK) {
	    return TCL_ERROR;
	}
	oFilePtr = tclOpenFiles[fileno(f)];
	if (argc == 4) {
	    if (Tcl_GetKanjiCode(interp, argv[3], &(oFilePtr->kanjiCodeInput))
		    == TCL_ERROR) {
		return TCL_ERROR;
	    }
	}
	Tcl_SetResult(interp, Tcl_KanjiCodeStr[oFilePtr->kanjiCodeInput], 0);
	return TCL_OK;
    } else if ((c == 'i') && (strncmp(argv[1], "internalCode", length) == 0)
	    && (length >= 3)) {
	Interp *iPtr = (Interp *)interp;

	if (argc > 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " code ?value?\"", (char *) NULL);
	    return TCL_ERROR;
	}
	if (argc == 3) {
	    if (Tcl_GetKanjiCode(interp, argv[2], &(iPtr->kanjiCode)) == TCL_ERROR) {
		return TCL_ERROR;
	    }
	}
	Tcl_SetResult(interp, Tcl_KanjiCodeStr[iPtr->kanjiCode], 0);
	return TCL_OK;
    } else if ((c == 'l') && (strncmp(argv[1], "lsearch", length) == 0)
	    && (length >= 3)) {
	if (argc != 4) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " lsearch list pattern\"", (char *) NULL);
	    return TCL_ERROR;
	}
	return Tcl_KlsearchCmd(dummy, interp, argc-1, argv+1);
    } else if ((c == 'l') && (strncmp(argv[1], "lsort", length) == 0)
	    && (length >= 3)) {
	if (argc != 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " lsort list\"", (char *) NULL);
	    return TCL_ERROR;
	}
	return Tcl_KlsortCmd(dummy, interp, argc-1, argv+1);
    } else if ((c == 'o') && (strncmp(argv[1], "outputCode", length) == 0)) {
	Interp *iPtr = (Interp *)interp;
	FILE *f;
	OpenFile *oFilePtr;

	if (argc != 3 && argc != 4) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " outputCode fileId ?value?\"", (char *) NULL);
	    return TCL_ERROR;
	}
	if (Tcl_GetOpenFile(interp, argv[2], 1, 1, &f) != TCL_OK) {
	    return TCL_ERROR;
	}
	oFilePtr = tclOpenFiles[fileno(f)];
	if (argc == 4) {
	    if (Tcl_GetKanjiCode(interp, argv[3], &(oFilePtr->kanjiCodeOutput))
		    == TCL_ERROR) {
		return TCL_ERROR;
	    }
	}
	Tcl_SetResult(interp, Tcl_KanjiCodeStr[oFilePtr->kanjiCodeOutput], 0);
	return TCL_OK;
    } else if ((c == 's') && (strncmp(argv[1], "split", length) == 0)
	    && (length >= 2)) {
	if (argc != 3 && argc != 4) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " split string ?splitChars?\"", (char *) NULL);
	    return TCL_ERROR;
	}
	return Tcl_KsplitCmd(dummy, interp, argc-1, argv+1);
    } else if ((c == 's') && (strncmp(argv[1], "string", length) == 0)
	    && (length >= 2)) {
	if (argc < 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " string option arg ?arg ...?\"", (char *) NULL);
	    return TCL_ERROR;
	}
	return Tcl_KstringCmd(dummy, interp, argc-1, argv+1);
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": should be code, conversion, defalutInputCode,",
		" defaultOutputCode, internalCode, inputCode, lsearch,",
		" lsort, outputCode, split, or string",
		(char *) NULL);
	return TCL_ERROR;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_KlsearchCmd --
 *
 *	This procedure is invoked to process the "klsearch" Tcl command.
 *	This is the "lsearch" which handles kanji characters.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_KlsearchCmd(notUsed, interp, argc, argv)
    ClientData notUsed;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int listArgc;
    char **listArgv;
    int i, match;
    int maxlen;
    wchar *string, *pattern;
    int kanjiCode = ((Interp *)interp)->kanjiCode;
    register int (*kanjiEncode)() = Tcl_KanjiEncode[kanjiCode];

    if (argc != 3) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" list pattern\"", (char *) NULL);
	return TCL_ERROR;
    }
    if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
	return TCL_ERROR;
    }
    for (i = 0, maxlen = 0; i < listArgc; i++) {
	int len;

	len = strlen(listArgv[i]);
	if (maxlen < len) maxlen = len;
    }
    string = (wchar *) ckalloc((unsigned)(maxlen + 1) * 2);
    pattern = (wchar *) ckalloc((unsigned)((*kanjiEncode)(argv[2], NULL) + 1) * 2);
    (void )(*kanjiEncode)(argv[2], pattern);
    match = -1;
    for (i = 0; i < listArgc; i++) {
	(*kanjiEncode)(listArgv[i], string);
	if (Tcl_WStringMatch(string, pattern)) {
	    match = i;
	    break;
	}
    }
    sprintf(interp->result, "%d", match);
    ckfree((char *) listArgv);
    ckfree((char *) string);
    ckfree((char *) pattern);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_KlsortCmd --
 *
 *	This procedure is invoked to process the "lsort" Tcl command.
 *	This is the "lsort" which handles kanji characters.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_KlsortCmd(notUsed, interp, argc, argv)
    ClientData notUsed;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int listArgc;
    char **listArgv;

    if (argc != 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" list\"", (char *) NULL);
	return TCL_ERROR;
    }
    if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
	return TCL_ERROR;
    }
    qsort((VOID *) listArgv, listArgc, sizeof (char *), SortKanjiCompareProc);
    interp->result = Tcl_Merge(listArgc, listArgv);
    interp->freeProc = (Tcl_FreeProc *) free;
    ckfree((char *) listArgv);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_KsplitCmd --
 *
 *	This procedure is invoked to process the "ksplit" Tcl command.
 *	This is the "split" which handles kanji characters.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_KsplitCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int kanjiCode = ((Interp *)interp)->kanjiCode, code;
    register int (*kanjiEncode)() = Tcl_KanjiEncode[kanjiCode];
    register int (*kanjiDecode)() = Tcl_KanjiDecode[kanjiCode];
    wchar *splitChars;
    register char *p;
    register wchar *wp;
    char *elementStart;
    char *elementStr;
    int i;

    if (argc == 2) {
	splitChars = (wchar *)ckalloc((unsigned)(4 + 1) * 2);
	(void )(*kanjiEncode)(" \n\t\r", splitChars);
    } else if (argc == 3) {
	splitChars = (wchar *)ckalloc((unsigned)
				((*kanjiEncode)(argv[2], NULL) + 1) * 2);
	(void )(*kanjiEncode)(argv[2], splitChars);
    } else {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" string ?splitChars?\"", (char *) NULL);
	return TCL_ERROR;
    }

    /*
     * Handle the special case of splitting on every character.
     */

    if (*splitChars == 0) {
#define MAX_BYTES_FOR_ONE_WCHAR	10	/* hope this is enough */
	char str[MAX_BYTES_FOR_ONE_WCHAR];

	for (p = argv[1]; *p != 0; ) {
	    if (Tcl_KanjiStart(p, &kanjiCode)) {
		int num;
		char c;
		wchar *ws, wstr[2];

		num = Tcl_KanjiLength(p, kanjiCode);
		c = p[num];
		p[num] = 0;
		ws = (wchar *) ckalloc((unsigned)((*kanjiEncode)(p, NULL) + 1) * 2);
		(void )(*kanjiEncode)(p, ws);

		wstr[1] = 0;
		for (wp = ws; *wp != 0; wp++) {
		    wstr[0] = *wp;
		    if ((*kanjiDecode)(wstr, str) >= MAX_BYTES_FOR_ONE_WCHAR) {
			panic("Tcl_KsplitCmd : need larger MAX_BYTES_FOR_ONE_WCHAR");
		    }
		    Tcl_AppendElement(interp, str);
		}

		ckfree((char *) ws);
		p[num] = c;
		p += num;
	    } else {
		str[0] = *p;
		str[1] = 0;
		Tcl_AppendElement(interp, str);
		p++;
	    }
	}
	goto done;
    }

    /*
     * Normal case: split on any of a given set of characters.
     * Discard instances of the split characters.
     */

    elementStr = (char *) ckalloc((unsigned)(strlen(argv[1]) + 1));
    i = 0;
    for (p = argv[1]; *p != 0; ) {
	if (Tcl_KanjiStart(p, &kanjiCode)) {
	    int n;
	    char c;
	    wchar *wstr, *wstrp, *start;

	    n = Tcl_KanjiLength(p, kanjiCode);
	    c = p[n];
	    p[n] = 0;
	    wstr = (wchar *) ckalloc((unsigned)((*kanjiEncode)(p, NULL) + 1) * 2);
	    (void )(*kanjiEncode)(p, wstr);

	    for (wstrp = start = wstr;  *wstrp != 0; wstrp++) {
		wchar wc = *wstrp;

		for (wp = splitChars; *wp != 0; wp++) {
		    if (*wp == wc) {
			*wstrp = 0;
			i += (*kanjiDecode)(start, elementStr+i);
			elementStr[i] = 0;
			Tcl_AppendElement(interp, elementStr);
			i = 0;
			*wstrp = wc;
			start = wstrp + 1;
			break;
		    }
		}
	    }
	    if (wstrp != start) {
		i += (*kanjiDecode)(start, elementStr+i);
	    }
	    ckfree((char *) wstr);
	    p[n] = c;
	    p += n;
	} else {
	    for (wp = splitChars; *wp != 0; wp++) {
		if (*wp == (wchar )*p) {
		    elementStr[i] = 0;
		    Tcl_AppendElement(interp, elementStr);
		    i = 0;
		    break;
		}
	    }
	    if (*wp == 0) elementStr[i++] = *p;
	    p++;
	}
    }
    if (p != argv[1]) {
	elementStr[i] = 0;
	Tcl_AppendElement(interp, elementStr);
    }

    ckfree((char *) elementStr);
  done:
    ckfree((char *) splitChars);
    return TCL_OK;
#undef MAX_BYTES_FOR_ONE_WCHAR
#undef MAX_BYTES_FOR_AN_ELEMENT
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_KstringCmd --
 *
 *	This procedure is invoked to process the "kstring" Tcl command.
 *	This is the "string" which handles kanji characters.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_KstringCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int kanjiCode = ((Interp *)interp)->kanjiCode;
    register int (*kanjiEncode)() = Tcl_KanjiEncode[kanjiCode];
    register int (*kanjiDecode)() = Tcl_KanjiDecode[kanjiCode];
    int length;
    register char c;
    wchar *wstr1, *wstr2;
    register wchar *wp, wc;
    int match;
    int first;
    int left = 0, right = 0;

    if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" option arg ?arg ...?\"", (char *) NULL);
	return TCL_ERROR;
    }
    c = argv[1][0];
    length = strlen(argv[1]);
    if ((c == 'c') && (strncmp(argv[1], "compare", length) == 0)) {
	if (argc != 4) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " compare string1 string2\"", (char *) NULL);
	    return TCL_ERROR;
	}
	wstr1 = (wchar *)ckalloc((unsigned)((*kanjiEncode)(argv[2], NULL) + 1) * 2);
	(void )(*kanjiEncode)(argv[2], wstr1);
	wstr2 = (wchar *)ckalloc((unsigned)((*kanjiEncode)(argv[3], NULL) + 1) * 2);
	(void )(*kanjiEncode)(argv[3], wstr2);
	match = Tcl_WStrcmp(wstr1, wstr2);
	if (match > 0) {
	    interp->result = "1";
	} else if (match < 0) {
	    interp->result = "-1";
	} else {
	    interp->result = "0";
	}
	ckfree((char *)wstr1);
	ckfree((char *)wstr2);
	return TCL_OK;
    } else if ((c == 'f') && (strncmp(argv[1], "first", length) == 0)) {
	if (argc != 4) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " first string1 string2\"", (char *) NULL);
	    return TCL_ERROR;
	}
	first = 1;

      firstLast:
	wstr1 = (wchar *)ckalloc((unsigned)((*kanjiEncode)(argv[2], NULL) + 1) * 2);
	(void )(*kanjiEncode)(argv[2], wstr1);
	wstr2 = (wchar *)ckalloc((unsigned)((*kanjiEncode)(argv[3], NULL) + 1) * 2);
	(void )(*kanjiEncode)(argv[3], wstr2);
	match = -1;
	wc = *wstr1;
	length = Tcl_WStrlen(wstr1);
	for (wp = wstr2; *wp != 0; wp++) {
	    if (*wp != wc) {
		continue;
	    }
	    if (Tcl_WStrncmp(wstr1, wp, length) == 0) {
		match = wp - wstr2;
		if (first) {
		    break;
		}
	    }
	}
	sprintf(interp->result, "%d", match);
	ckfree((char *)wstr1);
	ckfree((char *)wstr2);
	return TCL_OK;
    } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0)) {
	int index;

	if (argc != 4) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " index string charIndex\"", (char *) NULL);
	    return TCL_ERROR;
	}
	if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) {
	    return TCL_ERROR;
	}
	if ((index >= 0) && ((unsigned) index < strlen(argv[2]))) {
	    wchar wstr[2];
	    wstr1 = (wchar *)ckalloc((unsigned)((*kanjiEncode)(argv[2], NULL) + 1) * 2);
	    (void )(*kanjiEncode)(argv[2], wstr1);
	    wstr[0] = wstr1[index];
	    wstr[1] = 0;
	    (void )(*kanjiDecode)(wstr, interp->result);
	    ckfree((char *)wstr1);
	}
	return TCL_OK;
    } else if ((c == 'l') && (strncmp(argv[1], "last", length) == 0)
	    && (length >= 2)) {
	if (argc != 4) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " last string1 string2\"", (char *) NULL);
	    return TCL_ERROR;
	}
	first = 0;
	goto firstLast;
    } else if ((c == 'l') && (strncmp(argv[1], "length", length) == 0)
	    && (length >= 2)) {
	if (argc != 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " length string\"", (char *) NULL);
	    return TCL_ERROR;
	}
	wstr1 = (wchar *)ckalloc((unsigned)((*kanjiEncode)(argv[2], NULL) + 1) * 2);
	(void )(*kanjiEncode)(argv[2], wstr1);
	sprintf(interp->result, "%d", Tcl_WStrlen(wstr1));
	ckfree((char *)wstr1);
	return TCL_OK;
    } else if ((c == 'm') && (strncmp(argv[1], "match", length) == 0)) {
	if (argc != 4) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " match pattern string\"", (char *) NULL);
	    return TCL_ERROR;
	}
	wstr1 = (wchar *)ckalloc((unsigned)((*kanjiEncode)(argv[2], NULL) + 1) * 2);
	(void )(*kanjiEncode)(argv[2], wstr1);
	wstr2 = (wchar *)ckalloc((unsigned)((*kanjiEncode)(argv[3], NULL) + 1) * 2);
	(void )(*kanjiEncode)(argv[3], wstr2);
	if (Tcl_WStringMatch(wstr2, wstr1) != 0) {
	    interp->result = "1";
	} else {
	    interp->result = "0";
	}
	ckfree((char *)wstr1);
	ckfree((char *)wstr2);
	return TCL_OK;
    } else if ((c == 'r') && (strncmp(argv[1], "range", length) == 0)) {
	int first, last, stringLength;

	if (argc != 5) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " range string first last\"", (char *) NULL);
	    return TCL_ERROR;
	}
	if (Tcl_GetInt(interp, argv[3], &first) != TCL_OK) {
	    return TCL_ERROR;
	}
	wstr1 = (wchar *)ckalloc((unsigned)((*kanjiEncode)(argv[2], NULL) + 1) * 2);
	(void )(*kanjiEncode)(argv[2], wstr1);
	stringLength = Tcl_WStrlen(wstr1);
	if ((*argv[4] == 'e')
		&& (strncmp(argv[4], "end", strlen(argv[4])) == 0)) {
	    last = stringLength-1;
	} else {
	    if (Tcl_GetInt(interp, argv[4], &last) != TCL_OK) {
		Tcl_ResetResult(interp);
		Tcl_AppendResult(interp,
			"expected integer or \"end\" but got \"",
			argv[4], "\"", (char *) NULL);
		ckfree((char *)wstr1);
		return TCL_ERROR;
	    }
	}
	if (first < 0) {
	    first = 0;
	}
	if (last >= stringLength) {
	    last = stringLength-1;
	}
	if (last >= first) {
	    char *str;
	    wchar saved;

	    wp = wstr1 + last + 1;
	    saved = *wp;
	    *wp = 0;
	    str = (char *)ckalloc((unsigned)((*kanjiDecode)(wstr1+first, NULL) + 1));
	    (void )(*kanjiDecode)(wstr1+first, str);
	    Tcl_SetResult(interp, str, TCL_VOLATILE);
	    *wp = saved;
	    ckfree(str);
	}
	ckfree((char *)wstr1);
	return TCL_OK;
    } else if ((c == 't') && (strncmp(argv[1], "tolower", length) == 0)
	    && (length >= 3)) {
	char *str;

	if (argc != 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " tolower string\"", (char *) NULL);
	    return TCL_ERROR;
	}
	wstr1 = (wchar *)ckalloc((unsigned)((*kanjiEncode)(argv[2], NULL) + 1) * 2);
	(void )(*kanjiEncode)(argv[2], wstr1);
	for (wp = wstr1; *wp != 0;  wp++) {
	    if (ISWUPPER(*wp)) {
		*wp = tolower((char )*wp);
	    }
	}
	str = (char *)ckalloc((unsigned)((*kanjiDecode)(wstr1, NULL) + 1));
	(void )(*kanjiDecode)(wstr1, str);
	Tcl_SetResult(interp, str, TCL_VOLATILE);
	ckfree(str);
	ckfree((char *)wstr1);
	return TCL_OK;
    } else if ((c == 't') && (strncmp(argv[1], "toupper", length) == 0)
	    && (length >= 3)) {
	char *str;

	if (argc != 3) {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " toupper string\"", (char *) NULL);
	    return TCL_ERROR;
	}
	wstr1 = (wchar *)ckalloc((unsigned)((*kanjiEncode)(argv[2], NULL) + 1) * 2);
	(void )(*kanjiEncode)(argv[2], wstr1);
	for (wp = wstr1; *wp != 0; wp++) {
	    if (ISWLOWER(*wp)) {
		*wp = toupper((char )*wp);
	    }
	}
	str = (char *)ckalloc((unsigned)((*kanjiDecode)(wstr1, NULL) + 1));
	(void )(*kanjiDecode)(wstr1, str);
	Tcl_SetResult(interp, str, TCL_VOLATILE);
	ckfree(str);
	ckfree((char *)wstr1);
	return TCL_OK;
    } else if ((c == 't') && (strncmp(argv[1], "trim", length) == 0)
	    && (length == 4)) {
	wchar *trimChars, *wstr;
	register wchar *checkPtr;
	char *str;

	left = right = 1;

	trim:
	if (argc == 4) {
	    trimChars = (wchar *)ckalloc((unsigned)((*kanjiEncode)(argv[3], NULL) + 1) * 2);
	    (void )(*kanjiEncode)(argv[3], trimChars);
	} else if (argc == 3) {
	    trimChars = (wchar *)ckalloc((unsigned)(4 + 1) * 2);
	    (void )(*kanjiEncode)(" \t\n\r", trimChars);
	} else {
	    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		    " ", argv[1], " string ?chars?\"", (char *) NULL);
	    return TCL_ERROR;
	}
	wstr1 = (wchar *)ckalloc((unsigned)((*kanjiEncode)(argv[2], NULL) + 1) * 2);
	(void )(*kanjiEncode)(argv[2], wstr1);
	wp = wstr1;
	if (left) {
	    for (wc = *wp; wc != 0; wp++, wc = *wp) {
		for (checkPtr = trimChars; *checkPtr != wc; checkPtr++) {
		    if (*checkPtr == 0) {
			goto doneLeft;
		    }
		}
	    }
	}
	doneLeft:
	wstr = wp;
	if (right) {
	    wchar *donePtr;

	    wp = wstr + Tcl_WStrlen(wstr) - 1;
	    donePtr = &wstr[-1];
	    for (wc = *wp; wp != donePtr; wp--, wc = *wp) {
		for (checkPtr = trimChars; *checkPtr != wc; checkPtr++) {
		    if (*checkPtr == 0) {
			goto doneRight;
		    }
		}
	    }
	    doneRight:
	    wp[1] = 0;
	}
	str = (char *)ckalloc((unsigned)((*kanjiDecode)(wstr, NULL) + 1));
	(void )(*kanjiDecode)(wstr, str);
	Tcl_SetResult(interp, str, TCL_VOLATILE);
	ckfree(str);
	ckfree((char *)trimChars);
	ckfree((char *)wstr1);
	return TCL_OK;
    } else if ((c == 't') && (strncmp(argv[1], "trimleft", length) == 0)
	    && (length > 4)) {
	left = 1;
	argv[1] = "trimleft";
	goto trim;
    } else if ((c == 't') && (strncmp(argv[1], "trimright", length) == 0)
	    && (length > 4)) {
	right = 1;
	argv[1] = "trimright";
	goto trim;
    } else {
	Tcl_AppendResult(interp, "bad option \"", argv[1],
		"\": should be compare, first, index, last, length, match, ",
		"range, tolower, toupper, trim, trimleft, or trimright",
		(char *) NULL);
	return TCL_ERROR;
    }
}
#endif /* KANJI */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LindexCmd --
 *
 *	This procedure is invoked to process the "lindex" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

    /* ARGSUSED */
int
Tcl_LindexCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    char *p, *element;
    int index, size, parenthesized, result;

    if (argc != 3) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" list index\"", (char *) NULL);
	return TCL_ERROR;
    }
    if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
	return TCL_ERROR;
    }
    if (index < 0) {
	return TCL_OK;
    }
    for (p = argv[1] ; index >= 0; index--) {
	result = TclFindElement(interp, p, &element, &p, &size,
		&parenthesized);
	if (result != TCL_OK) {
	    return result;
	}
    }
    if (size == 0) {
	return TCL_OK;
    }
    if (size >= TCL_RESULT_SIZE) {
	interp->result = (char *) ckalloc((unsigned) size+1);
	interp->freeProc = (Tcl_FreeProc *) free;
    }
    if (parenthesized) {
	memcpy((VOID *) interp->result, (VOID *) element, size);
	interp->result[size] = 0;
    } else {
	TclCopyAndCollapse(size, element, interp->result);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LinsertCmd --
 *
 *	This procedure is invoked to process the "linsert" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_LinsertCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    char *p, *element, savedChar;
    int i, index, count, result, size;

    if (argc < 4) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" list index element ?element ...?\"", (char *) NULL);
	return TCL_ERROR;
    }
    if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
	return TCL_ERROR;
    }

    /*
     * Skip over the first "index" elements of the list, then add
     * all of those elements to the result.
     */

    size = 0;
    element = argv[1];
    for (count = 0, p = argv[1]; (count < index) && (*p != 0); count++) {
	result = TclFindElement(interp, p, &element, &p, &size, (int *) NULL);
	if (result != TCL_OK) {
	    return result;
	}
    }
    if (*p == 0) {
	Tcl_AppendResult(interp, argv[1], (char *) NULL);
    } else {
	char *end;

	end = element+size;
	if (element != argv[1]) {
	    while ((*end != 0) && !isspace(UCHAR(*end))) {
		end++;
	    }
	}
	savedChar = *end;
	*end = 0;
	Tcl_AppendResult(interp, argv[1], (char *) NULL);
	*end = savedChar;
    }

    /*
     * Add the new list elements.
     */

    for (i = 3; i < argc; i++) {
	Tcl_AppendElement(interp, argv[i]);
    }

    /*
     * Append the remainder of the original list.
     */

    if (*p != 0) {
	Tcl_AppendResult(interp, " ", p, (char *) NULL);
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_ListCmd --
 *
 *	This procedure is invoked to process the "list" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_ListCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    if (argc >= 2) {
	interp->result = Tcl_Merge(argc-1, argv+1);
	interp->freeProc = (Tcl_FreeProc *) free;
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LlengthCmd --
 *
 *	This procedure is invoked to process the "llength" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_LlengthCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int count, result;
    char *element, *p;

    if (argc != 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" list\"", (char *) NULL);
	return TCL_ERROR;
    }
    for (count = 0, p = argv[1]; *p != 0 ; count++) {
	result = TclFindElement(interp, p, &element, &p, (int *) NULL,
		(int *) NULL);
	if (result != TCL_OK) {
	    return result;
	}
	if (*element == 0) {
	    break;
	}
    }
    sprintf(interp->result, "%d", count);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LrangeCmd --
 *
 *	This procedure is invoked to process the "lrange" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_LrangeCmd(notUsed, interp, argc, argv)
    ClientData notUsed;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int first, last, result;
    char *begin, *end, c, *dummy;
    int count;

    if (argc != 4) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" list first last\"", (char *) NULL);
	return TCL_ERROR;
    }
    if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
	return TCL_ERROR;
    }
    if (first < 0) {
	first = 0;
    }
    if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) {
	last = 1000000;
    } else {
	if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) {
	    Tcl_ResetResult(interp);
	    Tcl_AppendResult(interp,
		    "expected integer or \"end\" but got \"",
		    argv[3], "\"", (char *) NULL);
	    return TCL_ERROR;
	}
    }
    if (first > last) {
	return TCL_OK;
    }

    /*
     * Extract a range of fields.
     */

    for (count = 0, begin = argv[1]; count < first; count++) {
	result = TclFindElement(interp, begin, &dummy, &begin, (int *) NULL,
		(int *) NULL);
	if (result != TCL_OK) {
	    return result;
	}
	if (*begin == 0) {
	    break;
	}
    }
    for (count = first, end = begin; (count <= last) && (*end != 0);
	    count++) {
	result = TclFindElement(interp, end, &dummy, &end, (int *) NULL,
		(int *) NULL);
	if (result != TCL_OK) {
	    return result;
	}
    }

    /*
     * Chop off trailing spaces.
     */

    while (isspace(UCHAR(end[-1]))) {
	end--;
    }
    c = *end;
    *end = 0;
    Tcl_SetResult(interp, begin, TCL_VOLATILE);
    *end = c;
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LreplaceCmd --
 *
 *	This procedure is invoked to process the "lreplace" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_LreplaceCmd(notUsed, interp, argc, argv)
    ClientData notUsed;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    char *p1, *p2, *element, savedChar, *dummy;
    int i, first, last, count, result, size;

    if (argc < 4) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" list first last ?element element ...?\"", (char *) NULL);
	return TCL_ERROR;
    }
    if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
	return TCL_ERROR;
    }
    if (TclGetListIndex(interp, argv[3], &last) != TCL_OK) {
	return TCL_ERROR;
    }
    if (first < 0) {
	first = 0;
    }
    if (last < 0) {
	last = 0;
    }
    if (first > last) {
	Tcl_AppendResult(interp, "first index must not be greater than second",
		(char *) NULL);
	return TCL_ERROR;
    }

    /*
     * Skip over the elements of the list before "first".
     */

    size = 0;
    element = argv[1];
    for (count = 0, p1 = argv[1]; (count < first) && (*p1 != 0); count++) {
	result = TclFindElement(interp, p1, &element, &p1, &size,
		(int *) NULL);
	if (result != TCL_OK) {
	    return result;
	}
    }
    if (*p1 == 0) {
	Tcl_AppendResult(interp, "list doesn't contain element ",
		argv[2], (char *) NULL);
	return TCL_ERROR;
    }

    /*
     * Skip over the elements of the list up through "last".
     */

    for (p2 = p1 ; (count <= last) && (*p2 != 0); count++) {
	result = TclFindElement(interp, p2, &dummy, &p2, (int *) NULL,
		(int *) NULL);
	if (result != TCL_OK) {
	    return result;
	}
    }

    /*
     * Add the elements before "first" to the result.  Be sure to
     * include quote or brace characters that might terminate the
     * last of these elements.
     */

    p1 = element+size;
    if (element != argv[1]) {
	while ((*p1 != 0) && !isspace(UCHAR(*p1))) {
	    p1++;
	}
    }
    savedChar = *p1;
    *p1 = 0;
    Tcl_AppendResult(interp, argv[1], (char *) NULL);
    *p1 = savedChar;

    /*
     * Add the new list elements.
     */

    for (i = 4; i < argc; i++) {
	Tcl_AppendElement(interp, argv[i]);
    }

    /*
     * Append the remainder of the original list.
     */

    if (*p2 != 0) {
	if (*interp->result == 0) {
	    Tcl_SetResult(interp, p2, TCL_VOLATILE);
	} else {
	    Tcl_AppendResult(interp, " ", p2, (char *) NULL);
	}
    }
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LsearchCmd --
 *
 *	This procedure is invoked to process the "lsearch" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_LsearchCmd(notUsed, interp, argc, argv)
    ClientData notUsed;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
#define EXACT	0
#define GLOB	1
#define REGEXP	2
    int listArgc;
    char **listArgv;
    int i, match, mode, index;

    mode = GLOB;
    if (argc == 4) {
	if (strcmp(argv[1], "-exact") == 0) {
	    mode = EXACT;
	} else if (strcmp(argv[1], "-glob") == 0) {
	    mode = GLOB;
	} else if (strcmp(argv[1], "-regexp") == 0) {
	    mode = REGEXP;
	} else {
	    Tcl_AppendResult(interp, "bad search mode \"", argv[1],
		    "\": must be -exact, -glob, or -regexp", (char *) NULL);
	    return TCL_ERROR;
	}
    } else if (argc != 3) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" ?mode? list pattern\"", (char *) NULL);
	return TCL_ERROR;
    }
    if (Tcl_SplitList(interp, argv[argc-2], &listArgc, &listArgv) != TCL_OK) {
	return TCL_ERROR;
    }
    index = -1;
    for (i = 0; i < listArgc; i++) {
	match = 0;
	switch (mode) {
	    case EXACT:
		match = (strcmp(listArgv[i], argv[argc-1]) == 0);
		break;
	    case GLOB:
		match = Tcl_StringMatch(listArgv[i], argv[argc-1]);
		break;
	    case REGEXP:
		match = Tcl_RegExpMatch(interp, listArgv[i], argv[argc-1]);
		if (match < 0) {
		    ckfree((char *) listArgv);
		    return TCL_ERROR;
		}
		break;
	}
	if (match) {
	    index = i;
	    break;
	}
    }
    sprintf(interp->result, "%d", index);
    ckfree((char *) listArgv);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_LsortCmd --
 *
 *	This procedure is invoked to process the "lsort" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_LsortCmd(notUsed, interp, argc, argv)
    ClientData notUsed;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int listArgc, i, c, length;
    char **listArgv;
    char *command = NULL;		/* Initialization needed only to
					 * prevent compiler warning. */

    if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" ?-ascii? ?-integer? ?-real? ?-increasing? ?-decreasing?",
		" ?-command string? list\"", (char *) NULL);
	return TCL_ERROR;
    }

    /*
     * Parse arguments to set up the mode for the sort.
     */

    sortInterp = interp;
    sortMode = ASCII;
    sortIncreasing = 1;
    sortCode = TCL_OK;
    for (i = 1; i < argc-1; i++) {
	length = strlen(argv[i]);
	if (length < 2) {
	    badSwitch:
	    Tcl_AppendResult(interp, "bad switch \"", argv[i],
		    "\": must be -ascii, -integer, -real, -increasing",
		    " -decreasing, or -command", (char *) NULL);
	    return TCL_ERROR;
	}
	c = argv[i][1];
	if ((c == 'a') && (strncmp(argv[i], "-ascii", length) == 0)) {
	    sortMode = ASCII;
	} else if ((c == 'c') && (strncmp(argv[i], "-command", length) == 0)) {
	    if (i == argc-2) {
		Tcl_AppendResult(interp, "\"-command\" must be",
			" followed by comparison command", (char *) NULL);
		return TCL_ERROR;
	    }
	    sortMode = COMMAND;
	    command = argv[i+1];
	    i++;
	} else if ((c == 'd')
		&& (strncmp(argv[i], "-decreasing", length) == 0)) {
	    sortIncreasing = 0;
	} else if ((c == 'i') && (length >= 4)
		&& (strncmp(argv[i], "-increasing", length) == 0)) {
	    sortIncreasing = 1;
	} else if ((c == 'i') && (length >= 4)
		&& (strncmp(argv[i], "-integer", length) == 0)) {
	    sortMode = INTEGER;
	} else if ((c == 'r')
		&& (strncmp(argv[i], "-real", length) == 0)) {
	    sortMode = REAL;
	} else {
	    goto badSwitch;
	}
    }
    if (sortMode == COMMAND) {
	Tcl_DStringInit(&sortCmd);
	Tcl_DStringAppend(&sortCmd, command, -1);
    }

    if (Tcl_SplitList(interp, argv[argc-1], &listArgc, &listArgv) != TCL_OK) {
	return TCL_ERROR;
    }
    qsort((VOID *) listArgv, listArgc, sizeof (char *), SortCompareProc);
    if (sortCode == TCL_OK) {
	Tcl_ResetResult(interp);
	interp->result = Tcl_Merge(listArgc, listArgv);
	interp->freeProc = (Tcl_FreeProc *) free;
    }
    if (sortMode == COMMAND) {
	Tcl_DStringFree(&sortCmd);
    }
    ckfree((char *) listArgv);
    return sortCode;
}

/*
 *----------------------------------------------------------------------
 *
 * SortCompareProc --
 *
 *	This procedure is invoked by qsort to determine the proper
 *	ordering between two elements.
 *
 * Results:
 *	< 0 means first is "smaller" than "second", > 0 means "first"
 *	is larger than "second", and 0 means they should be treated
 *	as equal.
 *
 * Side effects:
 *	None, unless a user-defined comparison command does something
 *	weird.
 *
 *----------------------------------------------------------------------
 */

static int
SortCompareProc(first, second)
    CONST VOID *first, *second;		/* Elements to be compared. */
{
    int order;
    char *firstString = *((char **) first);
    char *secondString = *((char **) second);

    order = 0;
    if (sortCode != TCL_OK) {
	/*
	 * Once an error has occurred, skip any future comparisons
	 * so as to preserve the error message in sortInterp->result.
	 */

	return order;
    }
    if (sortMode == ASCII) {
	order = strcmp(firstString, secondString);
    } else if (sortMode == INTEGER) {
	int a, b;

	if ((Tcl_GetInt(sortInterp, firstString, &a) != TCL_OK)
		|| (Tcl_GetInt(sortInterp, secondString, &b) != TCL_OK)) {
	    Tcl_AddErrorInfo(sortInterp,
		    "\n    (converting list element from string to integer)");
	    sortCode = TCL_ERROR;
	    return order;
	}
	if (a > b) {
	    order = 1;
	} else if (b > a) {
	    order = -1;
	}
    } else if (sortMode == REAL) {
	double a, b;

	if ((Tcl_GetDouble(sortInterp, firstString, &a) != TCL_OK)
		|| (Tcl_GetDouble(sortInterp, secondString, &b) != TCL_OK)) {
	    Tcl_AddErrorInfo(sortInterp,
		    "\n    (converting list element from string to real)");
	    sortCode = TCL_ERROR;
	    return order;
	}
	if (a > b) {
	    order = 1;
	} else if (b > a) {
	    order = -1;
	}
    } else {
	int oldLength;
	char *end;

	/*
	 * Generate and evaluate a command to determine which string comes
	 * first.
	 */

	oldLength = Tcl_DStringLength(&sortCmd);
	Tcl_DStringAppendElement(&sortCmd, firstString);
	Tcl_DStringAppendElement(&sortCmd, secondString);
	sortCode = Tcl_Eval(sortInterp, Tcl_DStringValue(&sortCmd));
	Tcl_DStringTrunc(&sortCmd, oldLength);
	if (sortCode != TCL_OK) {
	    Tcl_AddErrorInfo(sortInterp,
		    "\n    (user-defined comparison command)");
	    return order;
	}

	/*
	 * Parse the result of the command.
	 */

	order = (int) strtol(sortInterp->result, &end, 0);
	if ((end == sortInterp->result) || (*end != 0)) {
	    Tcl_ResetResult(sortInterp);
	    Tcl_AppendResult(sortInterp,
		    "comparison command returned non-numeric result",
		    (char *) NULL);
	    sortCode = TCL_ERROR;
	    return order;
	}
    }
    if (!sortIncreasing) {
	order = -order;
    }
    return order;
}

#ifdef KANJI
static int
SortKanjiCompareProc(first, second)
    CONST VOID *first, *second;		/* Elements to be compared. */
{
    unsigned char *s1 = *((unsigned char **) first);
    unsigned char *s2 = *((unsigned char **) second);

    for ( ; *s1 == *s2; s1++, s2++) {
	if (*s1 == '\0') return 0;
    }
    return (*s1 - *s2);
}
#endif /* KANJI */
