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