home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / programming / tcl / tclsrc / c / tclCmdIL < prev    next >
Text File  |  1996-01-28  |  38KB  |  1,445 lines
  1. /*
  2.  * tclCmdIL.c --
  3.  *
  4.  *    This file contains the top-level command routines for most of
  5.  *    the Tcl built-in commands whose names begin with the letters
  6.  *    I through L.  It contains only commands in the generic core
  7.  *    (i.e. those that don't depend much upon UNIX facilities).
  8.  *
  9.  * Copyright (c) 1987-1993 The Regents of the University of California.
  10.  * Copyright (c) 1994-1995 Sun Microsystems, Inc.
  11.  *
  12.  * See the file "license.terms" for information on usage and redistribution
  13.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  14.  */
  15.  
  16. #ifndef lint
  17. static char sccsid[] = "@(#) tclCmdIL.c 1.111 95/06/28 13:36:42";
  18. #endif
  19.  
  20. #include "tclInt.h"
  21. #ifndef TCL_GENERIC_ONLY /* not for RISCOS*/
  22. #include "tclPort.h"
  23. #endif
  24.  
  25. /*
  26.  * The variables below are used to implement the "lsort" command.
  27.  * Unfortunately, this use of static variables prevents "lsort"
  28.  * from being thread-safe, but there's no alternative given the
  29.  * current implementation of qsort.  In a threaded environment
  30.  * these variables should be made thread-local if possible, or else
  31.  * "lsort" needs internal mutual exclusion.
  32.  */
  33.  
  34. static Tcl_Interp *sortInterp = NULL;    /* Interpreter for "lsort" command.
  35.                      * NULL means no lsort is active. */
  36. static enum {ASCII, INTEGER, REAL, COMMAND} sortMode;
  37.                     /* Mode for sorting: compare as strings,
  38.                      * compare as numbers, or call
  39.                      * user-defined command for
  40.                      * comparison. */
  41. static Tcl_DString sortCmd;        /* Holds command if mode is COMMAND.
  42.                      * pre-initialized to hold base of
  43.                      * command. */
  44. static int sortIncreasing;        /* 0 means sort in decreasing order,
  45.                      * 1 means increasing order. */
  46. static int sortCode;            /* Anything other than TCL_OK means a
  47.                      * problem occurred while sorting; this
  48.                      * executing a comparison command, so
  49.                      * the sort was aborted. */
  50.  
  51. /*
  52.  * Forward declarations for procedures defined in this file:
  53.  */
  54.  
  55. static int        SortCompareProc _ANSI_ARGS_((CONST VOID *first,
  56.                 CONST VOID *second));
  57.  
  58. /*
  59.  *----------------------------------------------------------------------
  60.  *
  61.  * Tcl_IfCmd --
  62.  *
  63.  *    This procedure is invoked to process the "if" Tcl command.
  64.  *    See the user documentation for details on what it does.
  65.  *
  66.  * Results:
  67.  *    A standard Tcl result.
  68.  *
  69.  * Side effects:
  70.  *    See the user documentation.
  71.  *
  72.  *----------------------------------------------------------------------
  73.  */
  74.  
  75.     /* ARGSUSED */
  76. int
  77. Tcl_IfCmd(dummy, interp, argc, argv)
  78.     ClientData dummy;            /* Not used. */
  79.     Tcl_Interp *interp;            /* Current interpreter. */
  80.     int argc;                /* Number of arguments. */
  81.     char **argv;            /* Argument strings. */
  82. {
  83.     int i, result, value;
  84.  
  85.     i = 1;
  86.     while (1) {
  87.     /*
  88.      * At this point in the loop, argv and argc refer to an expression
  89.      * to test, either for the main expression or an expression
  90.      * following an "elseif".  The arguments after the expression must
  91.      * be "then" (optional) and a script to execute if the expression is
  92.      * true.
  93.      */
  94.  
  95.     if (i >= argc) {
  96.         Tcl_AppendResult(interp, "wrong # args: no expression after \"",
  97.             argv[i-1], "\" argument", (char *) NULL);
  98.         return TCL_ERROR;
  99.     }
  100.     result = Tcl_ExprBoolean(interp, argv[i], &value);
  101.     if (result != TCL_OK) {
  102.         return result;
  103.     }
  104.     i++;
  105.     if ((i < argc) && (strcmp(argv[i], "then") == 0)) {
  106.         i++;
  107.     }
  108.     if (i >= argc) {
  109.         Tcl_AppendResult(interp, "wrong # args: no script following \"",
  110.             argv[i-1], "\" argument", (char *) NULL);
  111.         return TCL_ERROR;
  112.     }
  113.     if (value) {
  114.         return Tcl_Eval(interp, argv[i]);
  115.     }
  116.  
  117.     /*
  118.      * The expression evaluated to false.  Skip the command, then
  119.      * see if there is an "else" or "elseif" clause.
  120.      */
  121.  
  122.     i++;
  123.     if (i >= argc) {
  124.         return TCL_OK;
  125.     }
  126.     if ((argv[i][0] == 'e') && (strcmp(argv[i], "elseif") == 0)) {
  127.         i++;
  128.         continue;
  129.     }
  130.     break;
  131.     }
  132.  
  133.     /*
  134.      * Couldn't find a "then" or "elseif" clause to execute.  Check now
  135.      * for an "else" clause.  We know that there's at least one more
  136.      * argument when we get here.
  137.      */
  138.  
  139.     if (strcmp(argv[i], "else") == 0) {
  140.     i++;
  141.     if (i >= argc) {
  142.         Tcl_AppendResult(interp,
  143.             "wrong # args: no script following \"else\" argument",
  144.             (char *) NULL);
  145.         return TCL_ERROR;
  146.     }
  147.     }
  148.     return Tcl_Eval(interp, argv[i]);
  149. }
  150.  
  151. /*
  152.  *----------------------------------------------------------------------
  153.  *
  154.  * Tcl_IncrCmd --
  155.  *
  156.  *    This procedure is invoked to process the "incr" Tcl command.
  157.  *    See the user documentation for details on what it does.
  158.  *
  159.  * Results:
  160.  *    A standard Tcl result.
  161.  *
  162.  * Side effects:
  163.  *    See the user documentation.
  164.  *
  165.  *----------------------------------------------------------------------
  166.  */
  167.  
  168.     /* ARGSUSED */
  169. int
  170. Tcl_IncrCmd(dummy, interp, argc, argv)
  171.     ClientData dummy;            /* Not used. */
  172.     Tcl_Interp *interp;            /* Current interpreter. */
  173.     int argc;                /* Number of arguments. */
  174.     char **argv;            /* Argument strings. */
  175. {
  176.     int value;
  177.     char *oldString, *result;
  178.     char newString[30];
  179.  
  180.     if ((argc != 2) && (argc != 3)) {
  181.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  182.         " varName ?increment?\"", (char *) NULL);
  183.     return TCL_ERROR;
  184.     }
  185.  
  186.     oldString = Tcl_GetVar(interp, argv[1], TCL_LEAVE_ERR_MSG);
  187.     if (oldString == NULL) {
  188.     return TCL_ERROR;
  189.     }
  190.     if (Tcl_GetInt(interp, oldString, &value) != TCL_OK) {
  191.     Tcl_AddErrorInfo(interp,
  192.         "\n    (reading value of variable to increment)");
  193.     return TCL_ERROR;
  194.     }
  195.     if (argc == 2) {
  196.     value += 1;
  197.     } else {
  198.     int increment;
  199.  
  200.     if (Tcl_GetInt(interp, argv[2], &increment) != TCL_OK) {
  201.         Tcl_AddErrorInfo(interp,
  202.             "\n    (reading increment)");
  203.         return TCL_ERROR;
  204.     }
  205.     value += increment;
  206.     }
  207.     sprintf(newString, "%d", value);
  208.     result = Tcl_SetVar(interp, argv[1], newString, TCL_LEAVE_ERR_MSG);
  209.     if (result == NULL) {
  210.     return TCL_ERROR;
  211.     }
  212.     interp->result = result;
  213.     return TCL_OK;
  214. }
  215.  
  216. /*
  217.  *----------------------------------------------------------------------
  218.  *
  219.  * Tcl_InfoCmd --
  220.  *
  221.  *    This procedure is invoked to process the "info" Tcl command.
  222.  *    See the user documentation for details on what it does.
  223.  *
  224.  * Results:
  225.  *    A standard Tcl result.
  226.  *
  227.  * Side effects:
  228.  *    See the user documentation.
  229.  *
  230.  *----------------------------------------------------------------------
  231.  */
  232.  
  233.     /* ARGSUSED */
  234. int
  235. Tcl_InfoCmd(dummy, interp, argc, argv)
  236.     ClientData dummy;            /* Not used. */
  237.     Tcl_Interp *interp;            /* Current interpreter. */
  238.     int argc;                /* Number of arguments. */
  239.     char **argv;            /* Argument strings. */
  240. {
  241.     register Interp *iPtr = (Interp *) interp;
  242.     size_t length;
  243.     int c;
  244.     Arg *argPtr;
  245.     Proc *procPtr;
  246.     Var *varPtr;
  247.     Command *cmdPtr;
  248.     Tcl_HashEntry *hPtr;
  249.     Tcl_HashSearch search;
  250.  
  251.     if (argc < 2) {
  252.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  253.         " option ?arg arg ...?\"", (char *) NULL);
  254.     return TCL_ERROR;
  255.     }
  256.     c = argv[1][0];
  257.     length = strlen(argv[1]);
  258.     if ((c == 'a') && (strncmp(argv[1], "args", length)) == 0) {
  259.     if (argc != 3) {
  260.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  261.             argv[0], " args procname\"", (char *) NULL);
  262.         return TCL_ERROR;
  263.     }
  264.     procPtr = TclFindProc(iPtr, argv[2]);
  265.     if (procPtr == NULL) {
  266.         infoNoSuchProc:
  267.         Tcl_AppendResult(interp, "\"", argv[2],
  268.             "\" isn't a procedure", (char *) NULL);
  269.         return TCL_ERROR;
  270.     }
  271.     for (argPtr = procPtr->argPtr; argPtr != NULL;
  272.         argPtr = argPtr->nextPtr) {
  273.         Tcl_AppendElement(interp, argPtr->name);
  274.     }
  275.     return TCL_OK;
  276.     } else if ((c == 'b') && (strncmp(argv[1], "body", length)) == 0) {
  277.     if (argc != 3) {
  278.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  279.             " body procname\"", (char *) NULL);
  280.         return TCL_ERROR;
  281.     }
  282.     procPtr = TclFindProc(iPtr, argv[2]);
  283.     if (procPtr == NULL) {
  284.         goto infoNoSuchProc;
  285.     }
  286.     iPtr->result = procPtr->command;
  287.     return TCL_OK;
  288.     } else if ((c == 'c') && (strncmp(argv[1], "cmdcount", length) == 0)
  289.         && (length >= 2)) {
  290.     if (argc != 2) {
  291.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  292.             " cmdcount\"", (char *) NULL);
  293.         return TCL_ERROR;
  294.     }
  295.     sprintf(iPtr->result, "%d", iPtr->cmdCount);
  296.     return TCL_OK;
  297.     } else if ((c == 'c') && (strncmp(argv[1], "commands", length) == 0)
  298.         && (length >= 4)) {
  299.     if (argc > 3) {
  300.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  301.             " commands [pattern]\"", (char *) NULL);
  302.         return TCL_ERROR;
  303.     }
  304.     for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
  305.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  306.         char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
  307.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  308.         continue;
  309.         }
  310.         Tcl_AppendElement(interp, name);
  311.     }
  312.     return TCL_OK;
  313.     } else if ((c == 'c') && (strncmp(argv[1], "complete", length) == 0)
  314.         && (length >= 4)) {
  315.     if (argc != 3) {
  316.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  317.             " complete command\"", (char *) NULL);
  318.         return TCL_ERROR;
  319.     }
  320.     if (Tcl_CommandComplete(argv[2])) {
  321.         interp->result = "1";
  322.     } else {
  323.         interp->result = "0";
  324.     }
  325.     return TCL_OK;
  326.     } else if ((c == 'd') && (strncmp(argv[1], "default", length)) == 0) {
  327.     if (argc != 5) {
  328.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  329.             argv[0], " default procname arg varname\"",
  330.             (char *) NULL);
  331.         return TCL_ERROR;
  332.     }
  333.     procPtr = TclFindProc(iPtr, argv[2]);
  334.     if (procPtr == NULL) {
  335.         goto infoNoSuchProc;
  336.     }
  337.     for (argPtr = procPtr->argPtr; ; argPtr = argPtr->nextPtr) {
  338.         if (argPtr == NULL) {
  339.         Tcl_AppendResult(interp, "procedure \"", argv[2],
  340.             "\" doesn't have an argument \"", argv[3],
  341.             "\"", (char *) NULL);
  342.         return TCL_ERROR;
  343.         }
  344.         if (strcmp(argv[3], argPtr->name) == 0) {
  345.         if (argPtr->defValue != NULL) {
  346.             if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4],
  347.                 argPtr->defValue, 0) == NULL) {
  348.             defStoreError:
  349.             Tcl_AppendResult(interp,
  350.                 "couldn't store default value in variable \"",
  351.                 argv[4], "\"", (char *) NULL);
  352.             return TCL_ERROR;
  353.             }
  354.             iPtr->result = "1";
  355.         } else {
  356.             if (Tcl_SetVar((Tcl_Interp *) iPtr, argv[4], "", 0)
  357.                 == NULL) {
  358.             goto defStoreError;
  359.             }
  360.             iPtr->result = "0";
  361.         }
  362.         return TCL_OK;
  363.         }
  364.     }
  365.     } else if ((c == 'e') && (strncmp(argv[1], "exists", length) == 0)) {
  366.     char *p;
  367.     if (argc != 3) {
  368.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  369.             " exists varName\"", (char *) NULL);
  370.         return TCL_ERROR;
  371.     }
  372.     p = Tcl_GetVar((Tcl_Interp *) iPtr, argv[2], 0);
  373.  
  374.     /*
  375.      * The code below handles the special case where the name is for
  376.      * an array:  Tcl_GetVar will reject this since you can't read
  377.      * an array variable without an index.
  378.      */
  379.  
  380.     if (p == NULL) {
  381.         Tcl_HashEntry *hPtr;
  382.         Var *varPtr;
  383.  
  384.         if (strchr(argv[2], '(') != NULL) {
  385.         noVar:
  386.         iPtr->result = "0";
  387.         return TCL_OK;
  388.         }
  389.         if (iPtr->varFramePtr == NULL) {
  390.         hPtr = Tcl_FindHashEntry(&iPtr->globalTable, argv[2]);
  391.         } else {
  392.         hPtr = Tcl_FindHashEntry(&iPtr->varFramePtr->varTable, argv[2]);
  393.         }
  394.         if (hPtr == NULL) {
  395.         goto noVar;
  396.         }
  397.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  398.         if (varPtr->flags & VAR_UPVAR) {
  399.         varPtr = varPtr->value.upvarPtr;
  400.         }
  401.         if (!(varPtr->flags & VAR_ARRAY)) {
  402.         goto noVar;
  403.         }
  404.     }
  405.     iPtr->result = "1";
  406.     return TCL_OK;
  407.     } else if ((c == 'g') && (strncmp(argv[1], "globals", length) == 0)) {
  408.     char *name;
  409.  
  410.     if (argc > 3) {
  411.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  412.             " globals [pattern]\"", (char *) NULL);
  413.         return TCL_ERROR;
  414.     }
  415.     for (hPtr = Tcl_FirstHashEntry(&iPtr->globalTable, &search);
  416.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  417.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  418.         if (varPtr->flags & VAR_UNDEFINED) {
  419.         continue;
  420.         }
  421.         name = Tcl_GetHashKey(&iPtr->globalTable, hPtr);
  422.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  423.         continue;
  424.         }
  425.         Tcl_AppendElement(interp, name);
  426.     }
  427.     return TCL_OK;
  428.     } else if ((c == 'l') && (strncmp(argv[1], "level", length) == 0)
  429.         && (length >= 2)) {
  430.     if (argc == 2) {
  431.         if (iPtr->varFramePtr == NULL) {
  432.         iPtr->result = "0";
  433.         } else {
  434.         sprintf(iPtr->result, "%d", iPtr->varFramePtr->level);
  435.         }
  436.         return TCL_OK;
  437.     } else if (argc == 3) {
  438.         int level;
  439.         CallFrame *framePtr;
  440.  
  441.         if (Tcl_GetInt(interp, argv[2], &level) != TCL_OK) {
  442.         return TCL_ERROR;
  443.         }
  444.         if (level <= 0) {
  445.         if (iPtr->varFramePtr == NULL) {
  446.             levelError:
  447.             Tcl_AppendResult(interp, "bad level \"", argv[2],
  448.                 "\"", (char *) NULL);
  449.             return TCL_ERROR;
  450.         }
  451.         level += iPtr->varFramePtr->level;
  452.         }
  453.         for (framePtr = iPtr->varFramePtr; framePtr != NULL;
  454.             framePtr = framePtr->callerVarPtr) {
  455.         if (framePtr->level == level) {
  456.             break;
  457.         }
  458.         }
  459.         if (framePtr == NULL) {
  460.         goto levelError;
  461.         }
  462.         iPtr->result = Tcl_Merge(framePtr->argc, framePtr->argv);
  463.         iPtr->freeProc = (Tcl_FreeProc *) free;
  464.         return TCL_OK;
  465.     }
  466.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  467.         " level [number]\"", (char *) NULL);
  468.     return TCL_ERROR;
  469.     } else if ((c == 'l') && (strncmp(argv[1], "library", length) == 0)
  470.         && (length >= 2)) {
  471.     if (argc != 2) {
  472.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  473.             " library\"", (char *) NULL);
  474.         return TCL_ERROR;
  475.     }
  476.     interp->result = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
  477.     if (interp->result == NULL) {
  478.         interp->result = "no library has been specified for Tcl";
  479.         return TCL_ERROR;
  480.     }
  481.     return TCL_OK;
  482.     } else if ((c == 'l') && (strncmp(argv[1], "locals", length) == 0)
  483.         && (length >= 2)) {
  484.     char *name;
  485.  
  486.     if (argc > 3) {
  487.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  488.             " locals [pattern]\"", (char *) NULL);
  489.         return TCL_ERROR;
  490.     }
  491.     if (iPtr->varFramePtr == NULL) {
  492.         return TCL_OK;
  493.     }
  494.     for (hPtr = Tcl_FirstHashEntry(&iPtr->varFramePtr->varTable, &search);
  495.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  496.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  497.         if (varPtr->flags & (VAR_UNDEFINED|VAR_UPVAR)) {
  498.         continue;
  499.         }
  500.         name = Tcl_GetHashKey(&iPtr->varFramePtr->varTable, hPtr);
  501.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  502.         continue;
  503.         }
  504.         Tcl_AppendElement(interp, name);
  505.     }
  506.     return TCL_OK;
  507.     } else if ((c == 'p') && (strncmp(argv[1], "patchlevel", length) == 0)
  508.         && (length >= 2)) {
  509.     char *value;
  510.  
  511.     if (argc != 2) {
  512.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  513.             " patchlevel\"", (char *) NULL);
  514.         return TCL_ERROR;
  515.     }
  516.     value = Tcl_GetVar(interp, "tcl_patchLevel",
  517.         TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
  518.     if (value == NULL) {
  519.         return TCL_ERROR;
  520.     }
  521.     interp->result = value;
  522.     return TCL_OK;
  523.     } else if ((c == 'p') && (strncmp(argv[1], "procs", length) == 0)
  524.         && (length >= 2)) {
  525.     if (argc > 3) {
  526.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  527.             " procs [pattern]\"", (char *) NULL);
  528.         return TCL_ERROR;
  529.     }
  530.     for (hPtr = Tcl_FirstHashEntry(&iPtr->commandTable, &search);
  531.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  532.         char *name = Tcl_GetHashKey(&iPtr->commandTable, hPtr);
  533.  
  534.         cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  535.         if (!TclIsProc(cmdPtr)) {
  536.         continue;
  537.         }
  538.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  539.         continue;
  540.         }
  541.         Tcl_AppendElement(interp, name);
  542.     }
  543.     return TCL_OK;
  544.     } else if ((c == 's') && (strncmp(argv[1], "script", length) == 0)) {
  545.     if (argc != 2) {
  546.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  547.             argv[0], " script\"", (char *) NULL);
  548.         return TCL_ERROR;
  549.     }
  550.     if (iPtr->scriptFile != NULL) {
  551.         /*
  552.          * Can't depend on iPtr->scriptFile to be non-volatile:
  553.          * if this command is returned as the result of the script,
  554.          * then iPtr->scriptFile will go away.
  555.          */
  556.  
  557.         Tcl_SetResult(interp, iPtr->scriptFile, TCL_VOLATILE);
  558.     }
  559.     return TCL_OK;
  560.     } else if ((c == 't') && (strncmp(argv[1], "tclversion", length) == 0)) {
  561.     char *value;
  562.  
  563.     if (argc != 2) {
  564.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  565.             argv[0], " tclversion\"", (char *) NULL);
  566.         return TCL_ERROR;
  567.     }
  568.     value = Tcl_GetVar(interp, "tcl_version",
  569.         TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
  570.     if (value == NULL) {
  571.         return TCL_ERROR;
  572.     }
  573.     interp->result = value;
  574.     return TCL_OK;
  575.     } else if ((c == 'v') && (strncmp(argv[1], "vars", length)) == 0) {
  576.     Tcl_HashTable *tablePtr;
  577.     char *name;
  578.  
  579.     if (argc > 3) {
  580.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  581.             argv[0], " vars [pattern]\"", (char *) NULL);
  582.         return TCL_ERROR;
  583.     }
  584.     if (iPtr->varFramePtr == NULL) {
  585.         tablePtr = &iPtr->globalTable;
  586.     } else {
  587.         tablePtr = &iPtr->varFramePtr->varTable;
  588.     }
  589.     for (hPtr = Tcl_FirstHashEntry(tablePtr, &search);
  590.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  591.         varPtr = (Var *) Tcl_GetHashValue(hPtr);
  592.         if (varPtr->flags & VAR_UNDEFINED) {
  593.         continue;
  594.         }
  595.         name = Tcl_GetHashKey(tablePtr, hPtr);
  596.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  597.         continue;
  598.         }
  599.         Tcl_AppendElement(interp, name);
  600.     }
  601.     return TCL_OK;
  602.     } else {
  603.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  604.         "\": should be args, body, cmdcount, commands, ",
  605.         "complete, default, ",
  606.         "exists, globals, level, library, locals, ",
  607.         "patchlevel, procs, script, tclversion, or vars",
  608.         (char *) NULL);
  609.     return TCL_ERROR;
  610.     }
  611. }
  612.  
  613. /*
  614.  *----------------------------------------------------------------------
  615.  *
  616.  * Tcl_JoinCmd --
  617.  *
  618.  *    This procedure is invoked to process the "join" Tcl command.
  619.  *    See the user documentation for details on what it does.
  620.  *
  621.  * Results:
  622.  *    A standard Tcl result.
  623.  *
  624.  * Side effects:
  625.  *    See the user documentation.
  626.  *
  627.  *----------------------------------------------------------------------
  628.  */
  629.  
  630.     /* ARGSUSED */
  631. int
  632. Tcl_JoinCmd(dummy, interp, argc, argv)
  633.     ClientData dummy;            /* Not used. */
  634.     Tcl_Interp *interp;            /* Current interpreter. */
  635.     int argc;                /* Number of arguments. */
  636.     char **argv;            /* Argument strings. */
  637. {
  638.     char *joinString;
  639.     char **listArgv;
  640.     int listArgc, i;
  641.  
  642.     if (argc == 2) {
  643.     joinString = " ";
  644.     } else if (argc == 3) {
  645.     joinString = argv[2];
  646.     } else {
  647.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  648.         " list ?joinString?\"", (char *) NULL);
  649.     return TCL_ERROR;
  650.     }
  651.  
  652.     if (Tcl_SplitList(interp, argv[1], &listArgc, &listArgv) != TCL_OK) {
  653.     return TCL_ERROR;
  654.     }
  655.     for (i = 0; i < listArgc; i++) {
  656.     if (i == 0) {
  657.         Tcl_AppendResult(interp, listArgv[0], (char *) NULL);
  658.     } else  {
  659.         Tcl_AppendResult(interp, joinString, listArgv[i], (char *) NULL);
  660.     }
  661.     }
  662.     ckfree((char *) listArgv);
  663.     return TCL_OK;
  664. }
  665.  
  666. /*
  667.  *----------------------------------------------------------------------
  668.  *
  669.  * Tcl_LindexCmd --
  670.  *
  671.  *    This procedure is invoked to process the "lindex" Tcl command.
  672.  *    See the user documentation for details on what it does.
  673.  *
  674.  * Results:
  675.  *    A standard Tcl result.
  676.  *
  677.  * Side effects:
  678.  *    See the user documentation.
  679.  *
  680.  *----------------------------------------------------------------------
  681.  */
  682.  
  683.     /* ARGSUSED */
  684. int
  685. Tcl_LindexCmd(dummy, interp, argc, argv)
  686.     ClientData dummy;            /* Not used. */
  687.     Tcl_Interp *interp;            /* Current interpreter. */
  688.     int argc;                /* Number of arguments. */
  689.     char **argv;            /* Argument strings. */
  690. {
  691.     char *p, *element, *next;
  692.     int index, size, parenthesized, result, returnLast;
  693.  
  694.     if (argc != 3) {
  695.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  696.         " list index\"", (char *) NULL);
  697.     return TCL_ERROR;
  698.     }
  699.     if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) {
  700.     returnLast = 1;
  701.     index = INT_MAX;
  702.     } else {
  703.     returnLast = 0;
  704.     if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
  705.         return TCL_ERROR;
  706.     }
  707.     }
  708.     if (index < 0) {
  709.     return TCL_OK;
  710.     }
  711.     for (p = argv[1] ; index >= 0; index--) {
  712.     result = TclFindElement(interp, p, &element, &next, &size,
  713.         &parenthesized);
  714.     if (result != TCL_OK) {
  715.         return result;
  716.     }
  717.     if ((*next == 0) && returnLast) {
  718.         break;
  719.     }
  720.     p = next;
  721.     }
  722.     if (size == 0) {
  723.     return TCL_OK;
  724.     }
  725.     if (size >= TCL_RESULT_SIZE) {
  726.     interp->result = (char *) ckalloc((unsigned) size+1);
  727.     interp->freeProc = (Tcl_FreeProc *) free;
  728.     }
  729.     if (parenthesized) {
  730.     memcpy((VOID *) interp->result, (VOID *) element, (size_t) size);
  731.     interp->result[size] = 0;
  732.     } else {
  733.     TclCopyAndCollapse(size, element, interp->result);
  734.     }
  735.     return TCL_OK;
  736. }
  737.  
  738. /*
  739.  *----------------------------------------------------------------------
  740.  *
  741.  * Tcl_LinsertCmd --
  742.  *
  743.  *    This procedure is invoked to process the "linsert" Tcl command.
  744.  *    See the user documentation for details on what it does.
  745.  *
  746.  * Results:
  747.  *    A standard Tcl result.
  748.  *
  749.  * Side effects:
  750.  *    See the user documentation.
  751.  *
  752.  *----------------------------------------------------------------------
  753.  */
  754.  
  755.     /* ARGSUSED */
  756. int
  757. Tcl_LinsertCmd(dummy, interp, argc, argv)
  758.     ClientData dummy;            /* Not used. */
  759.     Tcl_Interp *interp;            /* Current interpreter. */
  760.     int argc;                /* Number of arguments. */
  761.     char **argv;            /* Argument strings. */
  762. {
  763.     char *p, *element, savedChar;
  764.     int i, index, count, result, size;
  765.  
  766.     if (argc < 4) {
  767.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  768.         " list index element ?element ...?\"", (char *) NULL);
  769.     return TCL_ERROR;
  770.     }
  771.     if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) {
  772.     index = INT_MAX;
  773.     } else if (Tcl_GetInt(interp, argv[2], &index) != TCL_OK) {
  774.     return TCL_ERROR;
  775.     }
  776.  
  777.     /*
  778.      * Skip over the first "index" elements of the list, then add
  779.      * all of those elements to the result.
  780.      */
  781.  
  782.     size = 0;
  783.     element = argv[1];
  784.     for (count = 0, p = argv[1]; (count < index) && (*p != 0); count++) {
  785.     result = TclFindElement(interp, p, &element, &p, &size, (int *) NULL);
  786.     if (result != TCL_OK) {
  787.         return result;
  788.     }
  789.     }
  790.     if (*p == 0) {
  791.     Tcl_AppendResult(interp, argv[1], (char *) NULL);
  792.     } else {
  793.     char *end;
  794.  
  795.     end = element+size;
  796.     if (element != argv[1]) {
  797.         while ((*end != 0) && !isspace(UCHAR(*end))) {
  798.         end++;
  799.         }
  800.     }
  801.     savedChar = *end;
  802.     *end = 0;
  803.     Tcl_AppendResult(interp, argv[1], (char *) NULL);
  804.     *end = savedChar;
  805.     }
  806.  
  807.     /*
  808.      * Add the new list elements.
  809.      */
  810.  
  811.     for (i = 3; i < argc; i++) {
  812.     Tcl_AppendElement(interp, argv[i]);
  813.     }
  814.  
  815.     /*
  816.      * Append the remainder of the original list.
  817.      */
  818.  
  819.     if (*p != 0) {
  820.     Tcl_AppendResult(interp, " ", p, (char *) NULL);
  821.     }
  822.     return TCL_OK;
  823. }
  824.  
  825. /*
  826.  *----------------------------------------------------------------------
  827.  *
  828.  * Tcl_ListCmd --
  829.  *
  830.  *    This procedure is invoked to process the "list" Tcl command.
  831.  *    See the user documentation for details on what it does.
  832.  *
  833.  * Results:
  834.  *    A standard Tcl result.
  835.  *
  836.  * Side effects:
  837.  *    See the user documentation.
  838.  *
  839.  *----------------------------------------------------------------------
  840.  */
  841.  
  842.     /* ARGSUSED */
  843. int
  844. Tcl_ListCmd(dummy, interp, argc, argv)
  845.     ClientData dummy;            /* Not used. */
  846.     Tcl_Interp *interp;            /* Current interpreter. */
  847.     int argc;                /* Number of arguments. */
  848.     char **argv;            /* Argument strings. */
  849. {
  850.     if (argc >= 2) {
  851.     interp->result = Tcl_Merge(argc-1, argv+1);
  852.     interp->freeProc = (Tcl_FreeProc *) free;
  853.     }
  854.     return TCL_OK;
  855. }
  856.  
  857. /*
  858.  *----------------------------------------------------------------------
  859.  *
  860.  * Tcl_LlengthCmd --
  861.  *
  862.  *    This procedure is invoked to process the "llength" Tcl command.
  863.  *    See the user documentation for details on what it does.
  864.  *
  865.  * Results:
  866.  *    A standard Tcl result.
  867.  *
  868.  * Side effects:
  869.  *    See the user documentation.
  870.  *
  871.  *----------------------------------------------------------------------
  872.  */
  873.  
  874.     /* ARGSUSED */
  875. int
  876. Tcl_LlengthCmd(dummy, interp, argc, argv)
  877.     ClientData dummy;            /* Not used. */
  878.     Tcl_Interp *interp;            /* Current interpreter. */
  879.     int argc;                /* Number of arguments. */
  880.     char **argv;            /* Argument strings. */
  881. {
  882.     int count, result;
  883.     char *element, *p;
  884.  
  885.     if (argc != 2) {
  886.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  887.         " list\"", (char *) NULL);
  888.     return TCL_ERROR;
  889.     }
  890.     for (count = 0, p = argv[1]; *p != 0 ; count++) {
  891.     result = TclFindElement(interp, p, &element, &p, (int *) NULL,
  892.         (int *) NULL);
  893.     if (result != TCL_OK) {
  894.         return result;
  895.     }
  896.     if (*element == 0) {
  897.         break;
  898.     }
  899.     }
  900.     sprintf(interp->result, "%d", count);
  901.     return TCL_OK;
  902. }
  903.  
  904. /*
  905.  *----------------------------------------------------------------------
  906.  *
  907.  * Tcl_LrangeCmd --
  908.  *
  909.  *    This procedure is invoked to process the "lrange" Tcl command.
  910.  *    See the user documentation for details on what it does.
  911.  *
  912.  * Results:
  913.  *    A standard Tcl result.
  914.  *
  915.  * Side effects:
  916.  *    See the user documentation.
  917.  *
  918.  *----------------------------------------------------------------------
  919.  */
  920.  
  921.     /* ARGSUSED */
  922. int
  923. Tcl_LrangeCmd(notUsed, interp, argc, argv)
  924.     ClientData notUsed;            /* Not used. */
  925.     Tcl_Interp *interp;            /* Current interpreter. */
  926.     int argc;                /* Number of arguments. */
  927.     char **argv;            /* Argument strings. */
  928. {
  929.     int first, last, result;
  930.     char *begin, *end, c, *dummy, *next;
  931.     int count, firstIsEnd;
  932.  
  933.     if (argc != 4) {
  934.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  935.         " list first last\"", (char *) NULL);
  936.     return TCL_ERROR;
  937.     }
  938.     if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) {
  939.     firstIsEnd = 1;
  940.     first = INT_MAX;
  941.     } else {
  942.     firstIsEnd = 0;
  943.     if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
  944.         return TCL_ERROR;
  945.     }
  946.     }
  947.     if (first < 0) {
  948.     first = 0;
  949.     }
  950.     if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) {
  951.     last = INT_MAX;
  952.     } else {
  953.     if (Tcl_GetInt(interp, argv[3], &last) != TCL_OK) {
  954.         Tcl_ResetResult(interp);
  955.         Tcl_AppendResult(interp, "expected integer or \"end\" but got \"",
  956.             argv[3], "\"", (char *) NULL);
  957.         return TCL_ERROR;
  958.     }
  959.     }
  960.     if ((first > last) && !firstIsEnd) {
  961.     return TCL_OK;
  962.     }
  963.  
  964.     /*
  965.      * Extract a range of fields.
  966.      */
  967.  
  968.     for (count = 0, begin = argv[1]; count < first; begin = next, count++) {
  969.     result = TclFindElement(interp, begin, &dummy, &next, (int *) NULL,
  970.         (int *) NULL);
  971.     if (result != TCL_OK) {
  972.         return result;
  973.     }
  974.     if (*next == 0) {
  975.         if (firstIsEnd) {
  976.         first = count;
  977.         } else {
  978.         begin = next;
  979.         }
  980.         break;
  981.     }
  982.     }
  983.     for (count = first, end = begin; (count <= last) && (*end != 0);
  984.         count++) {
  985.     result = TclFindElement(interp, end, &dummy, &end, (int *) NULL,
  986.         (int *) NULL);
  987.     if (result != TCL_OK) {
  988.         return result;
  989.     }
  990.     }
  991.     if (end == begin) {
  992.     return TCL_OK;
  993.     }
  994.  
  995.     /*
  996.      * Chop off trailing spaces.
  997.      */
  998.  
  999.     while (isspace(UCHAR(end[-1]))) {
  1000.     end--;
  1001.     }
  1002.     c = *end;
  1003.     *end = 0;
  1004.     Tcl_SetResult(interp, begin, TCL_VOLATILE);
  1005.     *end = c;
  1006.     return TCL_OK;
  1007. }
  1008.  
  1009. /*
  1010.  *----------------------------------------------------------------------
  1011.  *
  1012.  * Tcl_LreplaceCmd --
  1013.  *
  1014.  *    This procedure is invoked to process the "lreplace" Tcl command.
  1015.  *    See the user documentation for details on what it does.
  1016.  *
  1017.  * Results:
  1018.  *    A standard Tcl result.
  1019.  *
  1020.  * Side effects:
  1021.  *    See the user documentation.
  1022.  *
  1023.  *----------------------------------------------------------------------
  1024.  */
  1025.  
  1026.     /* ARGSUSED */
  1027. int
  1028. Tcl_LreplaceCmd(notUsed, interp, argc, argv)
  1029.     ClientData notUsed;            /* Not used. */
  1030.     Tcl_Interp *interp;            /* Current interpreter. */
  1031.     int argc;                /* Number of arguments. */
  1032.     char **argv;            /* Argument strings. */
  1033. {
  1034.     char *p1, *p2, *element, savedChar, *dummy, *next;
  1035.     int i, first, last, count, result, size, firstIsEnd;
  1036.  
  1037.     if (argc < 4) {
  1038.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1039.         " list first last ?element element ...?\"", (char *) NULL);
  1040.     return TCL_ERROR;
  1041.     }
  1042.     if ((*argv[2] == 'e') && (strncmp(argv[2], "end", strlen(argv[2])) == 0)) {
  1043.     firstIsEnd = 1;
  1044.     first = INT_MAX;
  1045.     } else {
  1046.     firstIsEnd = 0;
  1047.     if (Tcl_GetInt(interp, argv[2], &first) != TCL_OK) {
  1048.         return TCL_ERROR;
  1049.     }
  1050.     }
  1051.     if ((*argv[3] == 'e') && (strncmp(argv[3], "end", strlen(argv[3])) == 0)) {
  1052.     last = INT_MAX;
  1053.     } else {
  1054.     if (TclGetListIndex(interp, argv[3], &last) != TCL_OK) {
  1055.         return TCL_ERROR;
  1056.     }
  1057.     }
  1058.     if (first < 0) {
  1059.     first = 0;
  1060.     }
  1061.     if (last < 0) {
  1062.     last = 0;
  1063.     }
  1064.  
  1065.     /*
  1066.      * Skip over the elements of the list before "first".
  1067.      */
  1068.  
  1069.     size = 0;
  1070.     element = argv[1];
  1071.     for (count = 0, p1 = argv[1]; (count < first) && (*p1 != 0); count++) {
  1072.     result = TclFindElement(interp, p1, &element, &next, &size,
  1073.         (int *) NULL);
  1074.     if (result != TCL_OK) {
  1075.         return result;
  1076.     }
  1077.     if ((*next == 0) && firstIsEnd) {
  1078.         break;
  1079.     }
  1080.     p1 = next;
  1081.     }
  1082.     if (*p1 == 0) {
  1083.     Tcl_AppendResult(interp, "list doesn't contain element ",
  1084.         argv[2], (char *) NULL);
  1085.     return TCL_ERROR;
  1086.     }
  1087.     if (count > last) {
  1088.     Tcl_AppendResult(interp, "first index must not be greater than second",
  1089.         (char *) NULL);
  1090.     return TCL_ERROR;
  1091.     }
  1092.  
  1093.     /*
  1094.      * Skip over the elements of the list up through "last".
  1095.      */
  1096.  
  1097.     for (p2 = p1 ; (count <= last) && (*p2 != 0); count++) {
  1098.     result = TclFindElement(interp, p2, &dummy, &p2, (int *) NULL,
  1099.         (int *) NULL);
  1100.     if (result != TCL_OK) {
  1101.         return result;
  1102.     }
  1103.     }
  1104.  
  1105.     /*
  1106.      * Add the elements before "first" to the result.  Drop any terminating
  1107.      * white space, since a separator will be added below, if needed.
  1108.      */
  1109.  
  1110.     while ((p1 != argv[1]) && (isspace(UCHAR(p1[-1])))) {
  1111.     p1--;
  1112.     }
  1113.     savedChar = *p1;
  1114.     *p1 = 0;
  1115.     Tcl_AppendResult(interp, argv[1], (char *) NULL);
  1116.     *p1 = savedChar;
  1117.  
  1118.     /*
  1119.      * Add the new list elements.
  1120.      */
  1121.  
  1122.     for (i = 4; i < argc; i++) {
  1123.     Tcl_AppendElement(interp, argv[i]);
  1124.     }
  1125.  
  1126.     /*
  1127.      * Append the remainder of the original list.
  1128.      */
  1129.  
  1130.     if (*p2 != 0) {
  1131.     if (*interp->result == 0) {
  1132.         Tcl_SetResult(interp, p2, TCL_VOLATILE);
  1133.     } else {
  1134.         Tcl_AppendResult(interp, " ", p2, (char *) NULL);
  1135.     }
  1136.     }
  1137.     return TCL_OK;
  1138. }
  1139.  
  1140. /*
  1141.  *----------------------------------------------------------------------
  1142.  *
  1143.  * Tcl_LsearchCmd --
  1144.  *
  1145.  *    This procedure is invoked to process the "lsearch" Tcl command.
  1146.  *    See the user documentation for details on what it does.
  1147.  *
  1148.  * Results:
  1149.  *    A standard Tcl result.
  1150.  *
  1151.  * Side effects:
  1152.  *    See the user documentation.
  1153.  *
  1154.  *----------------------------------------------------------------------
  1155.  */
  1156.  
  1157.     /* ARGSUSED */
  1158. int
  1159. Tcl_LsearchCmd(notUsed, interp, argc, argv)
  1160.     ClientData notUsed;            /* Not used. */
  1161.     Tcl_Interp *interp;            /* Current interpreter. */
  1162.     int argc;                /* Number of arguments. */
  1163.     char **argv;            /* Argument strings. */
  1164. {
  1165. #define EXACT    0
  1166. #define GLOB    1
  1167. #define REGEXP    2
  1168.     int listArgc;
  1169.     char **listArgv;
  1170.     int i, match, mode, index;
  1171.  
  1172.     mode = GLOB;
  1173.     if (argc == 4) {
  1174.     if (strcmp(argv[1], "-exact") == 0) {
  1175.         mode = EXACT;
  1176.     } else if (strcmp(argv[1], "-glob") == 0) {
  1177.         mode = GLOB;
  1178.     } else if (strcmp(argv[1], "-regexp") == 0) {
  1179.         mode = REGEXP;
  1180.     } else {
  1181.         Tcl_AppendResult(interp, "bad search mode \"", argv[1],
  1182.             "\": must be -exact, -glob, or -regexp", (char *) NULL);
  1183.         return TCL_ERROR;
  1184.     }
  1185.     } else if (argc != 3) {
  1186.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1187.         " ?mode? list pattern\"", (char *) NULL);
  1188.     return TCL_ERROR;
  1189.     }
  1190.     if (Tcl_SplitList(interp, argv[argc-2], &listArgc, &listArgv) != TCL_OK) {
  1191.     return TCL_ERROR;
  1192.     }
  1193.     index = -1;
  1194.     for (i = 0; i < listArgc; i++) {
  1195.     match = 0;
  1196.     switch (mode) {
  1197.         case EXACT:
  1198.         match = (strcmp(listArgv[i], argv[argc-1]) == 0);
  1199.         break;
  1200.         case GLOB:
  1201.         match = Tcl_StringMatch(listArgv[i], argv[argc-1]);
  1202.         break;
  1203.         case REGEXP:
  1204.         match = Tcl_RegExpMatch(interp, listArgv[i], argv[argc-1]);
  1205.         if (match < 0) {
  1206.             ckfree((char *) listArgv);
  1207.             return TCL_ERROR;
  1208.         }
  1209.         break;
  1210.     }
  1211.     if (match) {
  1212.         index = i;
  1213.         break;
  1214.     }
  1215.     }
  1216.     sprintf(interp->result, "%d", index);
  1217.     ckfree((char *) listArgv);
  1218.     return TCL_OK;
  1219. }
  1220.  
  1221. /*
  1222.  *----------------------------------------------------------------------
  1223.  *
  1224.  * Tcl_LsortCmd --
  1225.  *
  1226.  *    This procedure is invoked to process the "lsort" Tcl command.
  1227.  *    See the user documentation for details on what it does.
  1228.  *
  1229.  * Results:
  1230.  *    A standard Tcl result.
  1231.  *
  1232.  * Side effects:
  1233.  *    See the user documentation.
  1234.  *
  1235.  *----------------------------------------------------------------------
  1236.  */
  1237.  
  1238.     /* ARGSUSED */
  1239. int
  1240. Tcl_LsortCmd(notUsed, interp, argc, argv)
  1241.     ClientData notUsed;            /* Not used. */
  1242.     Tcl_Interp *interp;            /* Current interpreter. */
  1243.     int argc;                /* Number of arguments. */
  1244.     char **argv;            /* Argument strings. */
  1245. {
  1246.     int listArgc, i, c;
  1247.     size_t length;
  1248.     char **listArgv;
  1249.     char *command = NULL;        /* Initialization needed only to
  1250.                      * prevent compiler warning. */
  1251.  
  1252.     if (argc < 2) {
  1253.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1254.         " ?-ascii? ?-integer? ?-real? ?-increasing? ?-decreasing?",
  1255.         " ?-command string? list\"", (char *) NULL);
  1256.     return TCL_ERROR;
  1257.     }
  1258.  
  1259.     if (sortInterp != NULL) {
  1260.     interp->result = "can't invoke \"lsort\" recursively";
  1261.     return TCL_ERROR;
  1262.     }
  1263.  
  1264.     /*
  1265.      * Parse arguments to set up the mode for the sort.
  1266.      */
  1267.  
  1268.     sortInterp = interp;
  1269.     sortMode = ASCII;
  1270.     sortIncreasing = 1;
  1271.     sortCode = TCL_OK;
  1272.     for (i = 1; i < argc-1; i++) {
  1273.     length = strlen(argv[i]);
  1274.     if (length < 2) {
  1275.         badSwitch:
  1276.         Tcl_AppendResult(interp, "bad switch \"", argv[i],
  1277.             "\": must be -ascii, -integer, -real, -increasing",
  1278.             " -decreasing, or -command", (char *) NULL);
  1279.         sortCode = TCL_ERROR;
  1280.         goto done;
  1281.     }
  1282.     c = argv[i][1];
  1283.     if ((c == 'a') && (strncmp(argv[i], "-ascii", length) == 0)) {
  1284.         sortMode = ASCII;
  1285.     } else if ((c == 'c') && (strncmp(argv[i], "-command", length) == 0)) {
  1286.         if (i == argc-2) {
  1287.         Tcl_AppendResult(interp, "\"-command\" must be",
  1288.             " followed by comparison command", (char *) NULL);
  1289.         sortCode = TCL_ERROR;
  1290.         goto done;
  1291.         }
  1292.         sortMode = COMMAND;
  1293.         command = argv[i+1];
  1294.         i++;
  1295.     } else if ((c == 'd')
  1296.         && (strncmp(argv[i], "-decreasing", length) == 0)) {
  1297.         sortIncreasing = 0;
  1298.     } else if ((c == 'i') && (length >= 4)
  1299.         && (strncmp(argv[i], "-increasing", length) == 0)) {
  1300.         sortIncreasing = 1;
  1301.     } else if ((c == 'i') && (length >= 4)
  1302.         && (strncmp(argv[i], "-integer", length) == 0)) {
  1303.         sortMode = INTEGER;
  1304.     } else if ((c == 'r')
  1305.         && (strncmp(argv[i], "-real", length) == 0)) {
  1306.         sortMode = REAL;
  1307.     } else {
  1308.         goto badSwitch;
  1309.     }
  1310.     }
  1311.     if (sortMode == COMMAND) {
  1312.     Tcl_DStringInit(&sortCmd);
  1313.     Tcl_DStringAppend(&sortCmd, command, -1);
  1314.     }
  1315.  
  1316.     if (Tcl_SplitList(interp, argv[argc-1], &listArgc, &listArgv) != TCL_OK) {
  1317.     sortCode = TCL_ERROR;
  1318.     goto done;
  1319.     }
  1320.     qsort((VOID *) listArgv, (size_t) listArgc, sizeof (char *),
  1321.         SortCompareProc);
  1322.     if (sortCode == TCL_OK) {
  1323.     Tcl_ResetResult(interp);
  1324.     interp->result = Tcl_Merge(listArgc, listArgv);
  1325.     interp->freeProc = (Tcl_FreeProc *) free;
  1326.     }
  1327.     if (sortMode == COMMAND) {
  1328.     Tcl_DStringFree(&sortCmd);
  1329.     }
  1330.     ckfree((char *) listArgv);
  1331.  
  1332.     done:
  1333.     sortInterp = NULL;
  1334.     return sortCode;
  1335. }
  1336.  
  1337. /*
  1338.  *----------------------------------------------------------------------
  1339.  *
  1340.  * SortCompareProc --
  1341.  *
  1342.  *    This procedure is invoked by qsort to determine the proper
  1343.  *    ordering between two elements.
  1344.  *
  1345.  * Results:
  1346.  *    < 0 means first is "smaller" than "second", > 0 means "first"
  1347.  *    is larger than "second", and 0 means they should be treated
  1348.  *    as equal.
  1349.  *
  1350.  * Side effects:
  1351.  *    None, unless a user-defined comparison command does something
  1352.  *    weird.
  1353.  *
  1354.  *----------------------------------------------------------------------
  1355.  */
  1356.  
  1357. static int
  1358. SortCompareProc(first, second)
  1359.     CONST VOID *first, *second;        /* Elements to be compared. */
  1360. {
  1361.     int order;
  1362.     char *firstString = *((char **) first);
  1363.     char *secondString = *((char **) second);
  1364.  
  1365.     order = 0;
  1366.     if (sortCode != TCL_OK) {
  1367.     /*
  1368.      * Once an error has occurred, skip any future comparisons
  1369.      * so as to preserve the error message in sortInterp->result.
  1370.      */
  1371.  
  1372.     return order;
  1373.     }
  1374.     if (sortMode == ASCII) {
  1375.     order = strcmp(firstString, secondString);
  1376.     } else if (sortMode == INTEGER) {
  1377.     int a, b;
  1378.  
  1379.     if ((Tcl_GetInt(sortInterp, firstString, &a) != TCL_OK)
  1380.         || (Tcl_GetInt(sortInterp, secondString, &b) != TCL_OK)) {
  1381.         Tcl_AddErrorInfo(sortInterp,
  1382.             "\n    (converting list element from string to integer)");
  1383.         sortCode = TCL_ERROR;
  1384.         return order;
  1385.     }
  1386.     if (a > b) {
  1387.         order = 1;
  1388.     } else if (b > a) {
  1389.         order = -1;
  1390.     }
  1391.     } else if (sortMode == REAL) {
  1392.     double a, b;
  1393.  
  1394.     if ((Tcl_GetDouble(sortInterp, firstString, &a) != TCL_OK)
  1395.         || (Tcl_GetDouble(sortInterp, secondString, &b) != TCL_OK)) {
  1396.         Tcl_AddErrorInfo(sortInterp,
  1397.             "\n    (converting list element from string to real)");
  1398.         sortCode = TCL_ERROR;
  1399.         return order;
  1400.     }
  1401.     if (a > b) {
  1402.         order = 1;
  1403.     } else if (b > a) {
  1404.         order = -1;
  1405.     }
  1406.     } else {
  1407.     int oldLength;
  1408.     char *end;
  1409.  
  1410.     /*
  1411.      * Generate and evaluate a command to determine which string comes
  1412.      * first.
  1413.      */
  1414.  
  1415.     oldLength = Tcl_DStringLength(&sortCmd);
  1416.     Tcl_DStringAppendElement(&sortCmd, firstString);
  1417.     Tcl_DStringAppendElement(&sortCmd, secondString);
  1418.     sortCode = Tcl_Eval(sortInterp, Tcl_DStringValue(&sortCmd));
  1419.     Tcl_DStringTrunc(&sortCmd, oldLength);
  1420.     if (sortCode != TCL_OK) {
  1421.         Tcl_AddErrorInfo(sortInterp,
  1422.             "\n    (user-defined comparison command)");
  1423.         return order;
  1424.     }
  1425.  
  1426.     /*
  1427.      * Parse the result of the command.
  1428.      */
  1429.  
  1430.     order = strtol(sortInterp->result, &end, 0);
  1431.     if ((end == sortInterp->result) || (*end != 0)) {
  1432.         Tcl_ResetResult(sortInterp);
  1433.         Tcl_AppendResult(sortInterp,
  1434.             "comparison command returned non-numeric result",
  1435.             (char *) NULL);
  1436.         sortCode = TCL_ERROR;
  1437.         return order;
  1438.     }
  1439.     }
  1440.     if (!sortIncreasing) {
  1441.     order = -order;
  1442.     }
  1443.     return order;
  1444. }
  1445.