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