home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tcl2-73c.zip / tcl7.3 / tclUtil.c < prev    next >
C/C++ Source or Header  |  1993-10-11  |  52KB  |  1,979 lines
  1. /* 
  2.  * tclUtil.c --
  3.  *
  4.  *    This file contains utility procedures that are used by many Tcl
  5.  *    commands.
  6.  *
  7.  * Copyright (c) 1987-1993 The Regents of the University of California.
  8.  * All rights reserved.
  9.  *
  10.  * Permission is hereby granted, without written agreement and without
  11.  * license or royalty fees, to use, copy, modify, and distribute this
  12.  * software and its documentation for any purpose, provided that the
  13.  * above copyright notice and the following two paragraphs appear in
  14.  * all copies of this software.
  15.  * 
  16.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  17.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  18.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  19.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  20.  *
  21.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  22.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  23.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  24.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  25.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  26.  */
  27.  
  28. #ifndef lint
  29. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUtil.c,v 1.84 93/10/11 09:18:49 ouster Exp $ SPRITE (Berkeley)";
  30. #endif
  31.  
  32. #include "tclInt.h"
  33.  
  34. /*
  35.  * The following values are used in the flags returned by Tcl_ScanElement
  36.  * and used by Tcl_ConvertElement.  The value TCL_DONT_USE_BRACES is also
  37.  * defined in tcl.h;  make sure its value doesn't overlap with any of the
  38.  * values below.
  39.  *
  40.  * TCL_DONT_USE_BRACES -    1 means the string mustn't be enclosed in
  41.  *                braces (e.g. it contains unmatched braces,
  42.  *                or ends in a backslash character, or user
  43.  *                just doesn't want braces);  handle all
  44.  *                special characters by adding backslashes.
  45.  * USE_BRACES -            1 means the string contains a special
  46.  *                character that can be handled simply by
  47.  *                enclosing the entire argument in braces.
  48.  * BRACES_UNMATCHED -        1 means that braces aren't properly matched
  49.  *                in the argument.
  50.  */
  51.  
  52. #define USE_BRACES        2
  53. #define BRACES_UNMATCHED    4
  54.  
  55. /*
  56.  * The variable below is set to NULL before invoking regexp functions
  57.  * and checked after those functions.  If an error occurred then TclRegError
  58.  * will set the variable to point to a (static) error message.  This
  59.  * mechanism unfortunately does not support multi-threading, but then
  60.  * neither does the rest of the regexp facilities.
  61.  */
  62.  
  63. char *tclRegexpError = NULL;
  64.  
  65. /*
  66.  * Function prototypes for local procedures in this file:
  67.  */
  68.  
  69. static void        SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
  70.                 int newSpace));
  71.  
  72. /*
  73.  *----------------------------------------------------------------------
  74.  *
  75.  * TclFindElement --
  76.  *
  77.  *    Given a pointer into a Tcl list, locate the first (or next)
  78.  *    element in the list.
  79.  *
  80.  * Results:
  81.  *    The return value is normally TCL_OK, which means that the
  82.  *    element was successfully located.  If TCL_ERROR is returned
  83.  *    it means that list didn't have proper list structure;
  84.  *    interp->result contains a more detailed error message.
  85.  *
  86.  *    If TCL_OK is returned, then *elementPtr will be set to point
  87.  *    to the first element of list, and *nextPtr will be set to point
  88.  *    to the character just after any white space following the last
  89.  *    character that's part of the element.  If this is the last argument
  90.  *    in the list, then *nextPtr will point to the NULL character at the
  91.  *    end of list.  If sizePtr is non-NULL, *sizePtr is filled in with
  92.  *    the number of characters in the element.  If the element is in
  93.  *    braces, then *elementPtr will point to the character after the
  94.  *    opening brace and *sizePtr will not include either of the braces.
  95.  *    If there isn't an element in the list, *sizePtr will be zero, and
  96.  *    both *elementPtr and *termPtr will refer to the null character at
  97.  *    the end of list.  Note:  this procedure does NOT collapse backslash
  98.  *    sequences.
  99.  *
  100.  * Side effects:
  101.  *    None.
  102.  *
  103.  *----------------------------------------------------------------------
  104.  */
  105.  
  106. int
  107. TclFindElement(interp, list, elementPtr, nextPtr, sizePtr, bracePtr)
  108.     Tcl_Interp *interp;        /* Interpreter to use for error reporting. */
  109.     register char *list;    /* String containing Tcl list with zero
  110.                  * or more elements (possibly in braces). */
  111.     char **elementPtr;        /* Fill in with location of first significant
  112.                  * character in first element of list. */
  113.     char **nextPtr;        /* Fill in with location of character just
  114.                  * after all white space following end of
  115.                  * argument (i.e. next argument or end of
  116.                  * list). */
  117.     int *sizePtr;        /* If non-zero, fill in with size of
  118.                  * element. */
  119.     int *bracePtr;        /* If non-zero fill in with non-zero/zero
  120.                  * to indicate that arg was/wasn't
  121.                  * in braces. */
  122. {
  123.     register char *p;
  124.     int openBraces = 0;
  125.     int inQuotes = 0;
  126.     int size;
  127.  
  128.     /*
  129.      * Skim off leading white space and check for an opening brace or
  130.      * quote.   Note:  use of "isascii" below and elsewhere in this
  131.      * procedure is a temporary hack (7/27/90) because Mx uses characters
  132.      * with the high-order bit set for some things.  This should probably
  133.      * be changed back eventually, or all of Tcl should call isascii.
  134.      */
  135.  
  136.     while (isspace(UCHAR(*list))) {
  137.     list++;
  138.     }
  139.     if (*list == '{') {
  140.     openBraces = 1;
  141.     list++;
  142.     } else if (*list == '"') {
  143.     inQuotes = 1;
  144.     list++;
  145.     }
  146.     if (bracePtr != 0) {
  147.     *bracePtr = openBraces;
  148.     }
  149.     p = list;
  150.  
  151.     /*
  152.      * Find the end of the element (either a space or a close brace or
  153.      * the end of the string).
  154.      */
  155.  
  156.     while (1) {
  157.     switch (*p) {
  158.  
  159.         /*
  160.          * Open brace: don't treat specially unless the element is
  161.          * in braces.  In this case, keep a nesting count.
  162.          */
  163.  
  164.         case '{':
  165.         if (openBraces != 0) {
  166.             openBraces++;
  167.         }
  168.         break;
  169.  
  170.         /*
  171.          * Close brace: if element is in braces, keep nesting
  172.          * count and quit when the last close brace is seen.
  173.          */
  174.  
  175.         case '}':
  176.         if (openBraces == 1) {
  177.             char *p2;
  178.  
  179.             size = p - list;
  180.             p++;
  181.             if (isspace(UCHAR(*p)) || (*p == 0)) {
  182.             goto done;
  183.             }
  184.             for (p2 = p; (*p2 != 0) && (!isspace(UCHAR(*p2)))
  185.                 && (p2 < p+20); p2++) {
  186.             /* null body */
  187.             }
  188.             Tcl_ResetResult(interp);
  189.             sprintf(interp->result,
  190.                 "list element in braces followed by \"%.*s\" instead of space",
  191.                 p2-p, p);
  192.             return TCL_ERROR;
  193.         } else if (openBraces != 0) {
  194.             openBraces--;
  195.         }
  196.         break;
  197.  
  198.         /*
  199.          * Backslash:  skip over everything up to the end of the
  200.          * backslash sequence.
  201.          */
  202.  
  203.         case '\\': {
  204.         int size;
  205.  
  206.         (void) Tcl_Backslash(p, &size);
  207.         p += size - 1;
  208.         break;
  209.         }
  210.  
  211.         /*
  212.          * Space: ignore if element is in braces or quotes;  otherwise
  213.          * terminate element.
  214.          */
  215.  
  216.         case ' ':
  217.         case '\f':
  218.         case '\n':
  219.         case '\r':
  220.         case '\t':
  221.         case '\v':
  222.         if ((openBraces == 0) && !inQuotes) {
  223.             size = p - list;
  224.             goto done;
  225.         }
  226.         break;
  227.  
  228.         /*
  229.          * Double-quote:  if element is in quotes then terminate it.
  230.          */
  231.  
  232.         case '"':
  233.         if (inQuotes) {
  234.             char *p2;
  235.  
  236.             size = p-list;
  237.             p++;
  238.             if (isspace(UCHAR(*p)) || (*p == 0)) {
  239.             goto done;
  240.             }
  241.             for (p2 = p; (*p2 != 0) && (!isspace(UCHAR(*p2)))
  242.                 && (p2 < p+20); p2++) {
  243.             /* null body */
  244.             }
  245.             Tcl_ResetResult(interp);
  246.             sprintf(interp->result,
  247.                 "list element in quotes followed by \"%.*s\" %s",
  248.                 p2-p, p, "instead of space");
  249.             return TCL_ERROR;
  250.         }
  251.         break;
  252.  
  253.         /*
  254.          * End of list:  terminate element.
  255.          */
  256.  
  257.         case 0:
  258.         if (openBraces != 0) {
  259.             Tcl_SetResult(interp, "unmatched open brace in list",
  260.                 TCL_STATIC);
  261.             return TCL_ERROR;
  262.         } else if (inQuotes) {
  263.             Tcl_SetResult(interp, "unmatched open quote in list",
  264.                 TCL_STATIC);
  265.             return TCL_ERROR;
  266.         }
  267.         size = p - list;
  268.         goto done;
  269.  
  270.     }
  271.     p++;
  272.     }
  273.  
  274.     done:
  275.     while (isspace(UCHAR(*p))) {
  276.     p++;
  277.     }
  278.     *elementPtr = list;
  279.     *nextPtr = p;
  280.     if (sizePtr != 0) {
  281.     *sizePtr = size;
  282.     }
  283.     return TCL_OK;
  284. }
  285.  
  286. /*
  287.  *----------------------------------------------------------------------
  288.  *
  289.  * TclCopyAndCollapse --
  290.  *
  291.  *    Copy a string and eliminate any backslashes that aren't in braces.
  292.  *
  293.  * Results:
  294.  *    There is no return value.  Count chars. get copied from src
  295.  *    to dst.  Along the way, if backslash sequences are found outside
  296.  *    braces, the backslashes are eliminated in the copy.
  297.  *    After scanning count chars. from source, a null character is
  298.  *    placed at the end of dst.
  299.  *
  300.  * Side effects:
  301.  *    None.
  302.  *
  303.  *----------------------------------------------------------------------
  304.  */
  305.  
  306. void
  307. TclCopyAndCollapse(count, src, dst)
  308.     int count;            /* Total number of characters to copy
  309.                  * from src. */
  310.     register char *src;        /* Copy from here... */
  311.     register char *dst;        /* ... to here. */
  312. {
  313.     register char c;
  314.     int numRead;
  315.  
  316.     for (c = *src; count > 0; src++, c = *src, count--) {
  317.     if (c == '\\') {
  318.         *dst = Tcl_Backslash(src, &numRead);
  319.         dst++;
  320.         src += numRead-1;
  321.         count -= numRead-1;
  322.     } else {
  323.         *dst = c;
  324.         dst++;
  325.     }
  326.     }
  327.     *dst = 0;
  328. }
  329.  
  330. /*
  331.  *----------------------------------------------------------------------
  332.  *
  333.  * Tcl_SplitList --
  334.  *
  335.  *    Splits a list up into its constituent fields.
  336.  *
  337.  * Results
  338.  *    The return value is normally TCL_OK, which means that
  339.  *    the list was successfully split up.  If TCL_ERROR is
  340.  *    returned, it means that "list" didn't have proper list
  341.  *    structure;  interp->result will contain a more detailed
  342.  *    error message.
  343.  *
  344.  *    *argvPtr will be filled in with the address of an array
  345.  *    whose elements point to the elements of list, in order.
  346.  *    *argcPtr will get filled in with the number of valid elements
  347.  *    in the array.  A single block of memory is dynamically allocated
  348.  *    to hold both the argv array and a copy of the list (with
  349.  *    backslashes and braces removed in the standard way).
  350.  *    The caller must eventually free this memory by calling free()
  351.  *    on *argvPtr.  Note:  *argvPtr and *argcPtr are only modified
  352.  *    if the procedure returns normally.
  353.  *
  354.  * Side effects:
  355.  *    Memory is allocated.
  356.  *
  357.  *----------------------------------------------------------------------
  358.  */
  359.  
  360. int
  361. Tcl_SplitList(interp, list, argcPtr, argvPtr)
  362.     Tcl_Interp *interp;        /* Interpreter to use for error reporting. */
  363.     char *list;            /* Pointer to string with list structure. */
  364.     int *argcPtr;        /* Pointer to location to fill in with
  365.                  * the number of elements in the list. */
  366.     char ***argvPtr;        /* Pointer to place to store pointer to array
  367.                  * of pointers to list elements. */
  368. {
  369.     char **argv;
  370.     register char *p;
  371.     int size, i, result, elSize, brace;
  372.     char *element;
  373.  
  374.     /*
  375.      * Figure out how much space to allocate.  There must be enough
  376.      * space for both the array of pointers and also for a copy of
  377.      * the list.  To estimate the number of pointers needed, count
  378.      * the number of space characters in the list.
  379.      */
  380.  
  381.     for (size = 1, p = list; *p != 0; p++) {
  382.     if (isspace(UCHAR(*p))) {
  383.         size++;
  384.     }
  385.     }
  386.     size++;            /* Leave space for final NULL pointer. */
  387.     argv = (char **) ckalloc((unsigned)
  388.         ((size * sizeof(char *)) + (p - list) + 1));
  389.     for (i = 0, p = ((char *) argv) + size*sizeof(char *);
  390.         *list != 0; i++) {
  391.     result = TclFindElement(interp, list, &element, &list, &elSize, &brace);
  392.     if (result != TCL_OK) {
  393.         ckfree((char *) argv);
  394.         return result;
  395.     }
  396.     if (*element == 0) {
  397.         break;
  398.     }
  399.     if (i >= size) {
  400.         ckfree((char *) argv);
  401.         Tcl_SetResult(interp, "internal error in Tcl_SplitList",
  402.             TCL_STATIC);
  403.         return TCL_ERROR;
  404.     }
  405.     argv[i] = p;
  406.     if (brace) {
  407.         strncpy(p, element, elSize);
  408.         p += elSize;
  409.         *p = 0;
  410.         p++;
  411.     } else {
  412.         TclCopyAndCollapse(elSize, element, p);
  413.         p += elSize+1;
  414.     }
  415.     }
  416.  
  417.     argv[i] = NULL;
  418.     *argvPtr = argv;
  419.     *argcPtr = i;
  420.     return TCL_OK;
  421. }
  422.  
  423. /*
  424.  *----------------------------------------------------------------------
  425.  *
  426.  * Tcl_ScanElement --
  427.  *
  428.  *    This procedure is a companion procedure to Tcl_ConvertElement.
  429.  *    It scans a string to see what needs to be done to it (e.g.
  430.  *    add backslashes or enclosing braces) to make the string into
  431.  *    a valid Tcl list element.
  432.  *
  433.  * Results:
  434.  *    The return value is an overestimate of the number of characters
  435.  *    that will be needed by Tcl_ConvertElement to produce a valid
  436.  *    list element from string.  The word at *flagPtr is filled in
  437.  *    with a value needed by Tcl_ConvertElement when doing the actual
  438.  *    conversion.
  439.  *
  440.  * Side effects:
  441.  *    None.
  442.  *
  443.  *----------------------------------------------------------------------
  444.  */
  445.  
  446. int
  447. Tcl_ScanElement(string, flagPtr)
  448.     char *string;        /* String to convert to Tcl list element. */
  449.     int *flagPtr;        /* Where to store information to guide
  450.                  * Tcl_ConvertElement. */
  451. {
  452.     int flags, nestingLevel;
  453.     register char *p;
  454.  
  455.     /*
  456.      * This procedure and Tcl_ConvertElement together do two things:
  457.      *
  458.      * 1. They produce a proper list, one that will yield back the
  459.      * argument strings when evaluated or when disassembled with
  460.      * Tcl_SplitList.  This is the most important thing.
  461.      * 
  462.      * 2. They try to produce legible output, which means minimizing the
  463.      * use of backslashes (using braces instead).  However, there are
  464.      * some situations where backslashes must be used (e.g. an element
  465.      * like "{abc": the leading brace will have to be backslashed.  For
  466.      * each element, one of three things must be done:
  467.      *
  468.      * (a) Use the element as-is (it doesn't contain anything special
  469.      * characters).  This is the most desirable option.
  470.      *
  471.      * (b) Enclose the element in braces, but leave the contents alone.
  472.      * This happens if the element contains embedded space, or if it
  473.      * contains characters with special interpretation ($, [, ;, or \),
  474.      * or if it starts with a brace or double-quote, or if there are
  475.      * no characters in the element.
  476.      *
  477.      * (c) Don't enclose the element in braces, but add backslashes to
  478.      * prevent special interpretation of special characters.  This is a
  479.      * last resort used when the argument would normally fall under case
  480.      * (b) but contains unmatched braces.  It also occurs if the last
  481.      * character of the argument is a backslash or if the element contains
  482.      * a backslash followed by newline.
  483.      *
  484.      * The procedure figures out how many bytes will be needed to store
  485.      * the result (actually, it overestimates).  It also collects information
  486.      * about the element in the form of a flags word.
  487.      */
  488.  
  489.     nestingLevel = 0;
  490.     flags = 0;
  491.     if (string == NULL) {
  492.     string = "";
  493.     }
  494.     p = string;
  495.     if ((*p == '{') || (*p == '"') || (*p == 0)) {
  496.     flags |= USE_BRACES;
  497.     }
  498.     for ( ; *p != 0; p++) {
  499.     switch (*p) {
  500.         case '{':
  501.         nestingLevel++;
  502.         break;
  503.         case '}':
  504.         nestingLevel--;
  505.         if (nestingLevel < 0) {
  506.             flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED;
  507.         }
  508.         break;
  509.         case '[':
  510.         case '$':
  511.         case ';':
  512.         case ' ':
  513.         case '\f':
  514.         case '\n':
  515.         case '\r':
  516.         case '\t':
  517.         case '\v':
  518.         flags |= USE_BRACES;
  519.         break;
  520.         case '\\':
  521.         if ((p[1] == 0) || (p[1] == '\n')) {
  522.             flags = TCL_DONT_USE_BRACES;
  523.         } else {
  524.             int size;
  525.  
  526.             (void) Tcl_Backslash(p, &size);
  527.             p += size-1;
  528.             flags |= USE_BRACES;
  529.         }
  530.         break;
  531.     }
  532.     }
  533.     if (nestingLevel != 0) {
  534.     flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;
  535.     }
  536.     *flagPtr = flags;
  537.  
  538.     /*
  539.      * Allow enough space to backslash every character plus leave
  540.      * two spaces for braces.
  541.      */
  542.  
  543.     return 2*(p-string) + 2;
  544. }
  545.  
  546. /*
  547.  *----------------------------------------------------------------------
  548.  *
  549.  * Tcl_ConvertElement --
  550.  *
  551.  *    This is a companion procedure to Tcl_ScanElement.  Given the
  552.  *    information produced by Tcl_ScanElement, this procedure converts
  553.  *    a string to a list element equal to that string.
  554.  *
  555.  * Results:
  556.  *    Information is copied to *dst in the form of a list element
  557.  *    identical to src (i.e. if Tcl_SplitList is applied to dst it
  558.  *    will produce a string identical to src).  The return value is
  559.  *    a count of the number of characters copied (not including the
  560.  *    terminating NULL character).
  561.  *
  562.  * Side effects:
  563.  *    None.
  564.  *
  565.  *----------------------------------------------------------------------
  566.  */
  567.  
  568. int
  569. Tcl_ConvertElement(src, dst, flags)
  570.     register char *src;        /* Source information for list element. */
  571.     char *dst;            /* Place to put list-ified element. */
  572.     int flags;            /* Flags produced by Tcl_ScanElement. */
  573. {
  574.     register char *p = dst;
  575.  
  576.     /*
  577.      * See the comment block at the beginning of the Tcl_ScanElement
  578.      * code for details of how this works.
  579.      */
  580.  
  581.     if (src == NULL) {
  582.     src = "";
  583.     }
  584.     if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) {
  585.     *p = '{';
  586.     p++;
  587.     for ( ; *src != 0; src++, p++) {
  588.         *p = *src;
  589.     }
  590.     *p = '}';
  591.     p++;
  592.     } else if (*src == 0) {
  593.     /*
  594.      * If string is empty but can't use braces, then use special
  595.      * backslash sequence that maps to empty string.
  596.      */
  597.  
  598.     p[0] = '\\';
  599.     p[1] = '0';
  600.     p += 2;
  601.     } else {
  602.     if (*src == '{') {
  603.         /*
  604.          * Can't have a leading brace unless the whole element is
  605.          * enclosed in braces.  Add a backslash before the brace.
  606.          * Furthermore, this may destroy the balance between open
  607.          * and close braces, so set BRACES_UNMATCHED.
  608.          */
  609.  
  610.         p[0] = '\\';
  611.         p[1] = '{';
  612.         p += 2;
  613.         src++;
  614.         flags |= BRACES_UNMATCHED;
  615.     }
  616.     for (; *src != 0 ; src++) {
  617.         switch (*src) {
  618.         case ']':
  619.         case '[':
  620.         case '$':
  621.         case ';':
  622.         case ' ':
  623.         case '\\':
  624.         case '"':
  625.             *p = '\\';
  626.             p++;
  627.             break;
  628.         case '{':
  629.         case '}':
  630.             /*
  631.              * It may not seem necessary to backslash braces, but
  632.              * it is.  The reason for this is that the resulting
  633.              * list element may actually be an element of a sub-list
  634.              * enclosed in braces (e.g. if Tcl_DStringStartSublist
  635.              * has been invoked), so there may be a brace mismatch
  636.              * if the braces aren't backslashed.
  637.              */
  638.  
  639.             if (flags & BRACES_UNMATCHED) {
  640.             *p = '\\';
  641.             p++;
  642.             }
  643.             break;
  644.         case '\f':
  645.             *p = '\\';
  646.             p++;
  647.             *p = 'f';
  648.             p++;
  649.             continue;
  650.         case '\n':
  651.             *p = '\\';
  652.             p++;
  653.             *p = 'n';
  654.             p++;
  655.             continue;
  656.         case '\r':
  657.             *p = '\\';
  658.             p++;
  659.             *p = 'r';
  660.             p++;
  661.             continue;
  662.         case '\t':
  663.             *p = '\\';
  664.             p++;
  665.             *p = 't';
  666.             p++;
  667.             continue;
  668.         case '\v':
  669.             *p = '\\';
  670.             p++;
  671.             *p = 'v';
  672.             p++;
  673.             continue;
  674.         }
  675.         *p = *src;
  676.         p++;
  677.     }
  678.     }
  679.     *p = '\0';
  680.     return p-dst;
  681. }
  682.  
  683. /*
  684.  *----------------------------------------------------------------------
  685.  *
  686.  * Tcl_Merge --
  687.  *
  688.  *    Given a collection of strings, merge them together into a
  689.  *    single string that has proper Tcl list structured (i.e.
  690.  *    Tcl_SplitList may be used to retrieve strings equal to the
  691.  *    original elements, and Tcl_Eval will parse the string back
  692.  *    into its original elements).
  693.  *
  694.  * Results:
  695.  *    The return value is the address of a dynamically-allocated
  696.  *    string containing the merged list.
  697.  *
  698.  * Side effects:
  699.  *    None.
  700.  *
  701.  *----------------------------------------------------------------------
  702.  */
  703.  
  704. char *
  705. Tcl_Merge(argc, argv)
  706.     int argc;            /* How many strings to merge. */
  707.     char **argv;        /* Array of string values. */
  708. {
  709. #   define LOCAL_SIZE 20
  710.     int localFlags[LOCAL_SIZE], *flagPtr;
  711.     int numChars;
  712.     char *result;
  713.     register char *dst;
  714.     int i;
  715.  
  716.     /*
  717.      * Pass 1: estimate space, gather flags.
  718.      */
  719.  
  720.     if (argc <= LOCAL_SIZE) {
  721.     flagPtr = localFlags;
  722.     } else {
  723.     flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int));
  724.     }
  725.     numChars = 1;
  726.     for (i = 0; i < argc; i++) {
  727.     numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1;
  728.     }
  729.  
  730.     /*
  731.      * Pass two: copy into the result area.
  732.      */
  733.  
  734.     result = (char *) ckalloc((unsigned) numChars);
  735.     dst = result;
  736.     for (i = 0; i < argc; i++) {
  737.     numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]);
  738.     dst += numChars;
  739.     *dst = ' ';
  740.     dst++;
  741.     }
  742.     if (dst == result) {
  743.     *dst = 0;
  744.     } else {
  745.     dst[-1] = 0;
  746.     }
  747.  
  748.     if (flagPtr != localFlags) {
  749.     ckfree((char *) flagPtr);
  750.     }
  751.     return result;
  752. }
  753.  
  754. /*
  755.  *----------------------------------------------------------------------
  756.  *
  757.  * Tcl_Concat --
  758.  *
  759.  *    Concatenate a set of strings into a single large string.
  760.  *
  761.  * Results:
  762.  *    The return value is dynamically-allocated string containing
  763.  *    a concatenation of all the strings in argv, with spaces between
  764.  *    the original argv elements.
  765.  *
  766.  * Side effects:
  767.  *    Memory is allocated for the result;  the caller is responsible
  768.  *    for freeing the memory.
  769.  *
  770.  *----------------------------------------------------------------------
  771.  */
  772.  
  773. char *
  774. Tcl_Concat(argc, argv)
  775.     int argc;            /* Number of strings to concatenate. */
  776.     char **argv;        /* Array of strings to concatenate. */
  777. {
  778.     int totalSize, i;
  779.     register char *p;
  780.     char *result;
  781.  
  782.     for (totalSize = 1, i = 0; i < argc; i++) {
  783.     totalSize += strlen(argv[i]) + 1;
  784.     }
  785.     result = (char *) ckalloc((unsigned) totalSize);
  786.     if (argc == 0) {
  787.     *result = '\0';
  788.     return result;
  789.     }
  790.     for (p = result, i = 0; i < argc; i++) {
  791.     char *element;
  792.     int length;
  793.  
  794.     /*
  795.      * Clip white space off the front and back of the string
  796.      * to generate a neater result, and ignore any empty
  797.      * elements.
  798.      */
  799.  
  800.     element = argv[i];
  801.     while (isspace(UCHAR(*element))) {
  802.         element++;
  803.     }
  804.     for (length = strlen(element);
  805.         (length > 0) && (isspace(UCHAR(element[length-1])));
  806.         length--) {
  807.         /* Null loop body. */
  808.     }
  809.     if (length == 0) {
  810.         continue;
  811.     }
  812.     (void) strncpy(p, element, length);
  813.     p += length;
  814.     *p = ' ';
  815.     p++;
  816.     }
  817.     if (p != result) {
  818.     p[-1] = 0;
  819.     } else {
  820.     *p = 0;
  821.     }
  822.     return result;
  823. }
  824.  
  825. /*
  826.  *----------------------------------------------------------------------
  827.  *
  828.  * Tcl_StringMatch --
  829.  *
  830.  *    See if a particular string matches a particular pattern.
  831.  *
  832.  * Results:
  833.  *    The return value is 1 if string matches pattern, and
  834.  *    0 otherwise.  The matching operation permits the following
  835.  *    special characters in the pattern: *?\[] (see the manual
  836.  *    entry for details on what these mean).
  837.  *
  838.  * Side effects:
  839.  *    None.
  840.  *
  841.  *----------------------------------------------------------------------
  842.  */
  843.  
  844. int
  845. Tcl_StringMatch(string, pattern)
  846.     register char *string;    /* String. */
  847.     register char *pattern;    /* Pattern, which may contain
  848.                  * special characters. */
  849. {
  850.     char c2;
  851.  
  852.     while (1) {
  853.     /* See if we're at the end of both the pattern and the string.
  854.      * If so, we succeeded.  If we're at the end of the pattern
  855.      * but not at the end of the string, we failed.
  856.      */
  857.     
  858.     if (*pattern == 0) {
  859.         if (*string == 0) {
  860.         return 1;
  861.         } else {
  862.         return 0;
  863.         }
  864.     }
  865.     if ((*string == 0) && (*pattern != '*')) {
  866.         return 0;
  867.     }
  868.  
  869.     /* Check for a "*" as the next pattern character.  It matches
  870.      * any substring.  We handle this by calling ourselves
  871.      * recursively for each postfix of string, until either we
  872.      * match or we reach the end of the string.
  873.      */
  874.     
  875.     if (*pattern == '*') {
  876.         pattern += 1;
  877.         if (*pattern == 0) {
  878.         return 1;
  879.         }
  880.         while (1) {
  881.         if (Tcl_StringMatch(string, pattern)) {
  882.             return 1;
  883.         }
  884.         if (*string == 0) {
  885.             return 0;
  886.         }
  887.         string += 1;
  888.         }
  889.     }
  890.     
  891.     /* Check for a "?" as the next pattern character.  It matches
  892.      * any single character.
  893.      */
  894.  
  895.     if (*pattern == '?') {
  896.         goto thisCharOK;
  897.     }
  898.  
  899.     /* Check for a "[" as the next pattern character.  It is followed
  900.      * by a list of characters that are acceptable, or by a range
  901.      * (two characters separated by "-").
  902.      */
  903.     
  904.     if (*pattern == '[') {
  905.         pattern += 1;
  906.         while (1) {
  907.         if ((*pattern == ']') || (*pattern == 0)) {
  908.             return 0;
  909.         }
  910.         if (*pattern == *string) {
  911.             break;
  912.         }
  913.         if (pattern[1] == '-') {
  914.             c2 = pattern[2];
  915.             if (c2 == 0) {
  916.             return 0;
  917.             }
  918.             if ((*pattern <= *string) && (c2 >= *string)) {
  919.             break;
  920.             }
  921.             if ((*pattern >= *string) && (c2 <= *string)) {
  922.             break;
  923.             }
  924.             pattern += 2;
  925.         }
  926.         pattern += 1;
  927.         }
  928.         while ((*pattern != ']') && (*pattern != 0)) {
  929.         pattern += 1;
  930.         }
  931.         goto thisCharOK;
  932.     }
  933.     
  934.     /* If the next pattern character is '/', just strip off the '/'
  935.      * so we do exact matching on the character that follows.
  936.      */
  937.     
  938.     if (*pattern == '\\') {
  939.         pattern += 1;
  940.         if (*pattern == 0) {
  941.         return 0;
  942.         }
  943.     }
  944.  
  945.     /* There's no special character.  Just make sure that the next
  946.      * characters of each string match.
  947.      */
  948.     
  949.     if (*pattern != *string) {
  950.         return 0;
  951.     }
  952.  
  953.     thisCharOK: pattern += 1;
  954.     string += 1;
  955.     }
  956. }
  957.  
  958. /*
  959.  *----------------------------------------------------------------------
  960.  *
  961.  * Tcl_SetResult --
  962.  *
  963.  *    Arrange for "string" to be the Tcl return value.
  964.  *
  965.  * Results:
  966.  *    None.
  967.  *
  968.  * Side effects:
  969.  *    interp->result is left pointing either to "string" (if "copy" is 0)
  970.  *    or to a copy of string.
  971.  *
  972.  *----------------------------------------------------------------------
  973.  */
  974.  
  975. void
  976. Tcl_SetResult(interp, string, freeProc)
  977.     Tcl_Interp *interp;        /* Interpreter with which to associate the
  978.                  * return value. */
  979.     char *string;        /* Value to be returned.  If NULL,
  980.                  * the result is set to an empty string. */
  981.     Tcl_FreeProc *freeProc;    /* Gives information about the string:
  982.                  * TCL_STATIC, TCL_VOLATILE, or the address
  983.                  * of a Tcl_FreeProc such as free. */
  984. {
  985.     register Interp *iPtr = (Interp *) interp;
  986.     int length;
  987.     Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
  988.     char *oldResult = iPtr->result;
  989.  
  990.     iPtr->freeProc = freeProc;
  991.     if (string == NULL) {
  992.     iPtr->resultSpace[0] = 0;
  993.     iPtr->result = iPtr->resultSpace;
  994.     iPtr->freeProc = 0;
  995.     } else if (freeProc == TCL_VOLATILE) {
  996.     length = strlen(string);
  997.     if (length > TCL_RESULT_SIZE) {
  998.         iPtr->result = (char *) ckalloc((unsigned) length+1);
  999.         iPtr->freeProc = (Tcl_FreeProc *) free;
  1000.     } else {
  1001.         iPtr->result = iPtr->resultSpace;
  1002.         iPtr->freeProc = 0;
  1003.     }
  1004.     strcpy(iPtr->result, string);
  1005.     } else {
  1006.     iPtr->result = string;
  1007.     }
  1008.  
  1009.     /*
  1010.      * If the old result was dynamically-allocated, free it up.  Do it
  1011.      * here, rather than at the beginning, in case the new result value
  1012.      * was part of the old result value.
  1013.      */
  1014.  
  1015.     if (oldFreeProc != 0) {
  1016.     if (oldFreeProc == (Tcl_FreeProc *) free) {
  1017.         ckfree(oldResult);
  1018.     } else {
  1019.         (*oldFreeProc)(oldResult);
  1020.     }
  1021.     }
  1022. }
  1023.  
  1024. /*
  1025.  *----------------------------------------------------------------------
  1026.  *
  1027.  * Tcl_AppendResult --
  1028.  *
  1029.  *    Append a variable number of strings onto the result already
  1030.  *    present for an interpreter.
  1031.  *
  1032.  * Results:
  1033.  *    None.
  1034.  *
  1035.  * Side effects:
  1036.  *    The result in the interpreter given by the first argument
  1037.  *    is extended by the strings given by the second and following
  1038.  *    arguments (up to a terminating NULL argument).
  1039.  *
  1040.  *----------------------------------------------------------------------
  1041.  */
  1042.  
  1043.     /* VARARGS2 */
  1044. #ifndef lint
  1045. void
  1046. Tcl_AppendResult(va_alist)
  1047. #else
  1048. void
  1049.     /* VARARGS2 */ /* ARGSUSED */
  1050. Tcl_AppendResult(interp, p, va_alist)
  1051.     Tcl_Interp *interp;        /* Interpreter whose result is to be
  1052.                  * extended. */
  1053.     char *p;            /* One or more strings to add to the
  1054.                  * result, terminated with NULL. */
  1055. #endif
  1056.     va_dcl
  1057. {
  1058.     va_list argList;
  1059.     register Interp *iPtr;
  1060.     char *string;
  1061.     int newSpace;
  1062.  
  1063.     /*
  1064.      * First, scan through all the arguments to see how much space is
  1065.      * needed.
  1066.      */
  1067.  
  1068.     va_start(argList);
  1069.     iPtr = va_arg(argList, Interp *);
  1070.     newSpace = 0;
  1071.     while (1) {
  1072.     string = va_arg(argList, char *);
  1073.     if (string == NULL) {
  1074.         break;
  1075.     }
  1076.     newSpace += strlen(string);
  1077.     }
  1078.     va_end(argList);
  1079.  
  1080.     /*
  1081.      * If the append buffer isn't already setup and large enough
  1082.      * to hold the new data, set it up.
  1083.      */
  1084.  
  1085.     if ((iPtr->result != iPtr->appendResult)
  1086.         || (iPtr->appendResult[iPtr->appendUsed] != 0)
  1087.         || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
  1088.        SetupAppendBuffer(iPtr, newSpace);
  1089.     }
  1090.  
  1091.     /*
  1092.      * Final step:  go through all the argument strings again, copying
  1093.      * them into the buffer.
  1094.      */
  1095.  
  1096.     va_start(argList);
  1097.     (void) va_arg(argList, Tcl_Interp *);
  1098.     while (1) {
  1099.     string = va_arg(argList, char *);
  1100.     if (string == NULL) {
  1101.         break;
  1102.     }
  1103.     strcpy(iPtr->appendResult + iPtr->appendUsed, string);
  1104.     iPtr->appendUsed += strlen(string);
  1105.     }
  1106.     va_end(argList);
  1107. }
  1108.  
  1109. /*
  1110.  *----------------------------------------------------------------------
  1111.  *
  1112.  * Tcl_AppendElement --
  1113.  *
  1114.  *    Convert a string to a valid Tcl list element and append it
  1115.  *    to the current result (which is ostensibly a list).
  1116.  *
  1117.  * Results:
  1118.  *    None.
  1119.  *
  1120.  * Side effects:
  1121.  *    The result in the interpreter given by the first argument
  1122.  *    is extended with a list element converted from string.  A
  1123.  *    separator space is added before the converted list element
  1124.  *    unless the current result is empty, contains the single
  1125.  *    character "{", or ends in " {".
  1126.  *
  1127.  *----------------------------------------------------------------------
  1128.  */
  1129.  
  1130. void
  1131. Tcl_AppendElement(interp, string)
  1132.     Tcl_Interp *interp;        /* Interpreter whose result is to be
  1133.                  * extended. */
  1134.     char *string;        /* String to convert to list element and
  1135.                  * add to result. */
  1136. {
  1137.     register Interp *iPtr = (Interp *) interp;
  1138.     int size, flags;
  1139.     char *dst;
  1140.  
  1141.     /*
  1142.      * See how much space is needed, and grow the append buffer if
  1143.      * needed to accommodate the list element.
  1144.      */
  1145.  
  1146.     size = Tcl_ScanElement(string, &flags) + 1;
  1147.     if ((iPtr->result != iPtr->appendResult)
  1148.         || (iPtr->appendResult[iPtr->appendUsed] != 0)
  1149.         || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
  1150.        SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
  1151.     }
  1152.  
  1153.     /*
  1154.      * Convert the string into a list element and copy it to the
  1155.      * buffer that's forming.
  1156.      */
  1157.  
  1158.     dst = iPtr->appendResult + iPtr->appendUsed;
  1159.     if ((iPtr->appendUsed > 0) && ((dst[-1] != '{')
  1160.         || ((iPtr->appendUsed > 1) && (dst[-2] == '\\')))) {
  1161.     iPtr->appendUsed++;
  1162.     *dst = ' ';
  1163.     dst++;
  1164.     }
  1165.     iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);
  1166. }
  1167.  
  1168. /*
  1169.  *----------------------------------------------------------------------
  1170.  *
  1171.  * SetupAppendBuffer --
  1172.  *
  1173.  *    This procedure makes sure that there is an append buffer
  1174.  *    properly initialized for interp, and that it has at least
  1175.  *    enough room to accommodate newSpace new bytes of information.
  1176.  *
  1177.  * Results:
  1178.  *    None.
  1179.  *
  1180.  * Side effects:
  1181.  *    None.
  1182.  *
  1183.  *----------------------------------------------------------------------
  1184.  */
  1185.  
  1186. static void
  1187. SetupAppendBuffer(iPtr, newSpace)
  1188.     register Interp *iPtr;    /* Interpreter whose result is being set up. */
  1189.     int newSpace;        /* Make sure that at least this many bytes
  1190.                  * of new information may be added. */
  1191. {
  1192.     int totalSpace;
  1193.  
  1194.     /*
  1195.      * Make the append buffer larger, if that's necessary, then
  1196.      * copy the current result into the append buffer and make the
  1197.      * append buffer the official Tcl result.
  1198.      */
  1199.  
  1200.     if (iPtr->result != iPtr->appendResult) {
  1201.     /*
  1202.      * If an oversized buffer was used recently, then free it up
  1203.      * so we go back to a smaller buffer.  This avoids tying up
  1204.      * memory forever after a large operation.
  1205.      */
  1206.  
  1207.     if (iPtr->appendAvl > 500) {
  1208.         ckfree(iPtr->appendResult);
  1209.         iPtr->appendResult = NULL;
  1210.         iPtr->appendAvl = 0;
  1211.     }
  1212.     iPtr->appendUsed = strlen(iPtr->result);
  1213.     } else if (iPtr->result[iPtr->appendUsed] != 0) {
  1214.     /*
  1215.      * Most likely someone has modified a result created by
  1216.      * Tcl_AppendResult et al. so that it has a different size.
  1217.      * Just recompute the size.
  1218.      */
  1219.  
  1220.     iPtr->appendUsed = strlen(iPtr->result);
  1221.     }
  1222.     totalSpace = newSpace + iPtr->appendUsed;
  1223.     if (totalSpace >= iPtr->appendAvl) {
  1224.     char *new;
  1225.  
  1226.     if (totalSpace < 100) {
  1227.         totalSpace = 200;
  1228.     } else {
  1229.         totalSpace *= 2;
  1230.     }
  1231.     new = (char *) ckalloc((unsigned) totalSpace);
  1232.     strcpy(new, iPtr->result);
  1233.     if (iPtr->appendResult != NULL) {
  1234.         ckfree(iPtr->appendResult);
  1235.     }
  1236.     iPtr->appendResult = new;
  1237.     iPtr->appendAvl = totalSpace;
  1238.     } else if (iPtr->result != iPtr->appendResult) {
  1239.     strcpy(iPtr->appendResult, iPtr->result);
  1240.     }
  1241.     Tcl_FreeResult(iPtr);
  1242.     iPtr->result = iPtr->appendResult;
  1243. }
  1244.  
  1245. /*
  1246.  *----------------------------------------------------------------------
  1247.  *
  1248.  * Tcl_ResetResult --
  1249.  *
  1250.  *    This procedure restores the result area for an interpreter
  1251.  *    to its default initialized state, freeing up any memory that
  1252.  *    may have been allocated for the result and clearing any
  1253.  *    error information for the interpreter.
  1254.  *
  1255.  * Results:
  1256.  *    None.
  1257.  *
  1258.  * Side effects:
  1259.  *    None.
  1260.  *
  1261.  *----------------------------------------------------------------------
  1262.  */
  1263.  
  1264. void
  1265. Tcl_ResetResult(interp)
  1266.     Tcl_Interp *interp;        /* Interpreter for which to clear result. */
  1267. {
  1268.     register Interp *iPtr = (Interp *) interp;
  1269.  
  1270.     Tcl_FreeResult(iPtr);
  1271.     iPtr->result = iPtr->resultSpace;
  1272.     iPtr->resultSpace[0] = 0;
  1273.     iPtr->flags &=
  1274.         ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);
  1275. }
  1276.  
  1277. /*
  1278.  *----------------------------------------------------------------------
  1279.  *
  1280.  * Tcl_SetErrorCode --
  1281.  *
  1282.  *    This procedure is called to record machine-readable information
  1283.  *    about an error that is about to be returned.
  1284.  *
  1285.  * Results:
  1286.  *    None.
  1287.  *
  1288.  * Side effects:
  1289.  *    The errorCode global variable is modified to hold all of the
  1290.  *    arguments to this procedure, in a list form with each argument
  1291.  *    becoming one element of the list.  A flag is set internally
  1292.  *    to remember that errorCode has been set, so the variable doesn't
  1293.  *    get set automatically when the error is returned.
  1294.  *
  1295.  *----------------------------------------------------------------------
  1296.  */
  1297.     /* VARARGS2 */
  1298. #ifndef lint
  1299. void
  1300. Tcl_SetErrorCode(va_alist)
  1301. #else
  1302. void
  1303.     /* VARARGS2 */ /* ARGSUSED */
  1304. Tcl_SetErrorCode(interp, p, va_alist)
  1305.     Tcl_Interp *interp;        /* Interpreter whose errorCode variable is
  1306.                  * to be set. */
  1307.     char *p;            /* One or more elements to add to errorCode,
  1308.                  * terminated with NULL. */
  1309. #endif
  1310.     va_dcl
  1311. {
  1312.     va_list argList;
  1313.     char *string;
  1314.     int flags;
  1315.     Interp *iPtr;
  1316.  
  1317.     /*
  1318.      * Scan through the arguments one at a time, appending them to
  1319.      * $errorCode as list elements.
  1320.      */
  1321.  
  1322.     va_start(argList);
  1323.     iPtr = va_arg(argList, Interp *);
  1324.     flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
  1325.     while (1) {
  1326.     string = va_arg(argList, char *);
  1327.     if (string == NULL) {
  1328.         break;
  1329.     }
  1330.     (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
  1331.         (char *) NULL, string, flags);
  1332.     flags |= TCL_APPEND_VALUE;
  1333.     }
  1334.     va_end(argList);
  1335.     iPtr->flags |= ERROR_CODE_SET;
  1336. }
  1337.  
  1338. /*
  1339.  *----------------------------------------------------------------------
  1340.  *
  1341.  * TclGetListIndex --
  1342.  *
  1343.  *    Parse a list index, which may be either an integer or the
  1344.  *    value "end".
  1345.  *
  1346.  * Results:
  1347.  *    The return value is either TCL_OK or TCL_ERROR.  If it is
  1348.  *    TCL_OK, then the index corresponding to string is left in
  1349.  *    *indexPtr.  If the return value is TCL_ERROR, then string
  1350.  *    was bogus;  an error message is returned in interp->result.
  1351.  *    If a negative index is specified, it is rounded up to 0.
  1352.  *    The index value may be larger than the size of the list
  1353.  *    (this happens when "end" is specified).
  1354.  *
  1355.  * Side effects:
  1356.  *    None.
  1357.  *
  1358.  *----------------------------------------------------------------------
  1359.  */
  1360.  
  1361. int
  1362. TclGetListIndex(interp, string, indexPtr)
  1363.     Tcl_Interp *interp;            /* Interpreter for error reporting. */
  1364.     char *string;            /* String containing list index. */
  1365.     int *indexPtr;            /* Where to store index. */
  1366. {
  1367.     if (isdigit(UCHAR(*string)) || (*string == '-')) {
  1368.     if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) {
  1369.         return TCL_ERROR;
  1370.     }
  1371.     if (*indexPtr < 0) {
  1372.         *indexPtr = 0;
  1373.     }
  1374.     } else if (strncmp(string, "end", strlen(string)) == 0) {
  1375.     *indexPtr = 1<<30;
  1376.     } else {
  1377.     Tcl_AppendResult(interp, "bad index \"", string,
  1378.         "\": must be integer or \"end\"", (char *) NULL);
  1379.     return TCL_ERROR;
  1380.     }
  1381.     return TCL_OK;
  1382. }
  1383.  
  1384. /*
  1385.  *----------------------------------------------------------------------
  1386.  *
  1387.  * TclCompileRegexp --
  1388.  *
  1389.  *    Compile a regular expression into a form suitable for fast
  1390.  *    matching.  This procedure retains a small cache of pre-compiled
  1391.  *    regular expressions in the interpreter, in order to avoid
  1392.  *    compilation costs as much as possible.
  1393.  *
  1394.  * Results:
  1395.  *    The return value is a pointer to the compiled form of string,
  1396.  *    suitable for passing to TclRegExec.  If an error occurred while
  1397.  *    compiling the pattern, then NULL is returned and an error
  1398.  *    message is left in interp->result.
  1399.  *
  1400.  * Side effects:
  1401.  *    The cache of compiled regexp's in interp will be modified to
  1402.  *    hold information for string, if such information isn't already
  1403.  *    present in the cache.
  1404.  *
  1405.  *----------------------------------------------------------------------
  1406.  */
  1407.  
  1408. regexp *
  1409. TclCompileRegexp(interp, string)
  1410.     Tcl_Interp *interp;            /* For use in error reporting. */
  1411.     char *string;            /* String for which to produce
  1412.                      * compiled regular expression. */
  1413. {
  1414.     register Interp *iPtr = (Interp *) interp;
  1415.     int i, length;
  1416.     regexp *result;
  1417.  
  1418.     length = strlen(string);
  1419.     for (i = 0; i < NUM_REGEXPS; i++) {
  1420.     if ((length == iPtr->patLengths[i])
  1421.         && (strcmp(string, iPtr->patterns[i]) == 0)) {
  1422.         /*
  1423.          * Move the matched pattern to the first slot in the
  1424.          * cache and shift the other patterns down one position.
  1425.          */
  1426.  
  1427.         if (i != 0) {
  1428.         int j;
  1429.         char *cachedString;
  1430.  
  1431.         cachedString = iPtr->patterns[i];
  1432.         result = iPtr->regexps[i];
  1433.         for (j = i-1; j >= 0; j--) {
  1434.             iPtr->patterns[j+1] = iPtr->patterns[j];
  1435.             iPtr->patLengths[j+1] = iPtr->patLengths[j];
  1436.             iPtr->regexps[j+1] = iPtr->regexps[j];
  1437.         }
  1438.         iPtr->patterns[0] = cachedString;
  1439.         iPtr->patLengths[0] = length;
  1440.         iPtr->regexps[0] = result;
  1441.         }
  1442.         return iPtr->regexps[0];
  1443.     }
  1444.     }
  1445.  
  1446.     /*
  1447.      * No match in the cache.  Compile the string and add it to the
  1448.      * cache.
  1449.      */
  1450.  
  1451.     tclRegexpError = NULL;
  1452.     result = TclRegComp(string);
  1453.     if (tclRegexpError != NULL) {
  1454.     Tcl_AppendResult(interp,
  1455.         "couldn't compile regular expression pattern: ",
  1456.         tclRegexpError, (char *) NULL);
  1457.     return NULL;
  1458.     }
  1459.     if (iPtr->patterns[NUM_REGEXPS-1] != NULL) {
  1460.     ckfree(iPtr->patterns[NUM_REGEXPS-1]);
  1461.     ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]);
  1462.     }
  1463.     for (i = NUM_REGEXPS - 2; i >= 0; i--) {
  1464.     iPtr->patterns[i+1] = iPtr->patterns[i];
  1465.     iPtr->patLengths[i+1] = iPtr->patLengths[i];
  1466.     iPtr->regexps[i+1] = iPtr->regexps[i];
  1467.     }
  1468.     iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1));
  1469.     strcpy(iPtr->patterns[0], string);
  1470.     iPtr->patLengths[0] = length;
  1471.     iPtr->regexps[0] = result;
  1472.     return result;
  1473. }
  1474.  
  1475. /*
  1476.  *----------------------------------------------------------------------
  1477.  *
  1478.  * TclRegError --
  1479.  *
  1480.  *    This procedure is invoked by the Henry Spencer's regexp code
  1481.  *    when an error occurs.  It saves the error message so it can
  1482.  *    be seen by the code that called Spencer's code.
  1483.  *
  1484.  * Results:
  1485.  *    None.
  1486.  *
  1487.  * Side effects:
  1488.  *    The value of "string" is saved in "tclRegexpError".
  1489.  *
  1490.  *----------------------------------------------------------------------
  1491.  */
  1492.  
  1493. void
  1494. TclRegError(string)
  1495.     char *string;            /* Error message. */
  1496. {
  1497.     tclRegexpError = string;
  1498. }
  1499.  
  1500. /*
  1501.  *----------------------------------------------------------------------
  1502.  *
  1503.  * Tcl_RegExpMatch --
  1504.  *
  1505.  *    See if a string matches a regular expression.
  1506.  *
  1507.  * Results:
  1508.  *    If an error occurs during the matching operation then -1
  1509.  *    is returned and interp->result contains an error message.
  1510.  *    Otherwise the return value is 1 if "string" matches "pattern"
  1511.  *    and 0 otherwise.
  1512.  *
  1513.  * Side effects:
  1514.  *    None.
  1515.  *
  1516.  *----------------------------------------------------------------------
  1517.  */
  1518.  
  1519. int
  1520. Tcl_RegExpMatch(interp, string, pattern)
  1521.     Tcl_Interp *interp;        /* Used for error reporting. */
  1522.     char *string;        /* String. */
  1523.     char *pattern;        /* Regular expression to match against
  1524.                  * string. */
  1525. {
  1526.     regexp *regexpPtr;
  1527.     int match;
  1528.  
  1529.     regexpPtr = TclCompileRegexp(interp, pattern);
  1530.     if (regexpPtr == NULL) {
  1531.     return -1;
  1532.     }
  1533.     tclRegexpError = NULL;
  1534.     match = TclRegExec(regexpPtr, string, string);
  1535.     if (tclRegexpError != NULL) {
  1536.     Tcl_ResetResult(interp);
  1537.     Tcl_AppendResult(interp, "error while matching regular expression: ",
  1538.         tclRegexpError, (char *) NULL);
  1539.     return -1;
  1540.     }
  1541.     return match;
  1542. }
  1543.  
  1544. /*
  1545.  *----------------------------------------------------------------------
  1546.  *
  1547.  * Tcl_DStringInit --
  1548.  *
  1549.  *    Initializes a dynamic string, discarding any previous contents
  1550.  *    of the string (Tcl_DStringFree should have been called already
  1551.  *    if the dynamic string was previously in use).
  1552.  *
  1553.  * Results:
  1554.  *    None.
  1555.  *
  1556.  * Side effects:
  1557.  *    The dynamic string is initialized to be empty.
  1558.  *
  1559.  *----------------------------------------------------------------------
  1560.  */
  1561.  
  1562. void
  1563. Tcl_DStringInit(dsPtr)
  1564.     register Tcl_DString *dsPtr;    /* Pointer to structure for
  1565.                      * dynamic string. */
  1566. {
  1567.     dsPtr->string = dsPtr->staticSpace;
  1568.     dsPtr->length = 0;
  1569.     dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
  1570.     dsPtr->staticSpace[0] = 0;
  1571. }
  1572.  
  1573. /*
  1574.  *----------------------------------------------------------------------
  1575.  *
  1576.  * Tcl_DStringAppend --
  1577.  *
  1578.  *    Append more characters to the current value of a dynamic string.
  1579.  *
  1580.  * Results:
  1581.  *    The return value is a pointer to the dynamic string's new value.
  1582.  *
  1583.  * Side effects:
  1584.  *    Length bytes from string (or all of string if length is less
  1585.  *    than zero) are added to the current value of the string.  Memory
  1586.  *    gets reallocated if needed to accomodate the string's new size.
  1587.  *
  1588.  *----------------------------------------------------------------------
  1589.  */
  1590.  
  1591. char *
  1592. Tcl_DStringAppend(dsPtr, string, length)
  1593.     register Tcl_DString *dsPtr;    /* Structure describing dynamic
  1594.                      * string. */
  1595.     char *string;            /* String to append.  If length is
  1596.                      * -1 then this must be
  1597.                      * null-terminated. */
  1598.     int length;                /* Number of characters from string
  1599.                      * to append.  If < 0, then append all
  1600.                      * of string, up to null at end. */
  1601. {
  1602.     int newSize;
  1603.     char *newString;
  1604.  
  1605.     if (length < 0) {
  1606.     length = strlen(string);
  1607.     }
  1608.     newSize = length + dsPtr->length;
  1609.  
  1610.     /*
  1611.      * Allocate a larger buffer for the string if the current one isn't
  1612.      * large enough.  Allocate extra space in the new buffer so that there
  1613.      * will be room to grow before we have to allocate again.
  1614.      */
  1615.  
  1616.     if (newSize >= dsPtr->spaceAvl) {
  1617.     dsPtr->spaceAvl = newSize*2;
  1618.     newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
  1619.     strcpy(newString, dsPtr->string);
  1620.     if (dsPtr->string != dsPtr->staticSpace) {
  1621.         ckfree(dsPtr->string);
  1622.     }
  1623.     dsPtr->string = newString;
  1624.     }
  1625.  
  1626.     /*
  1627.      * Copy the new string into the buffer at the end of the old
  1628.      * one.
  1629.      */
  1630.  
  1631.     strncpy(dsPtr->string + dsPtr->length, string, length);
  1632.     dsPtr->length += length;
  1633.     dsPtr->string[dsPtr->length] = 0;
  1634.     return dsPtr->string;
  1635. }
  1636.  
  1637. /*
  1638.  *----------------------------------------------------------------------
  1639.  *
  1640.  * Tcl_DStringAppendElement --
  1641.  *
  1642.  *    Append a list element to the current value of a dynamic string.
  1643.  *
  1644.  * Results:
  1645.  *    The return value is a pointer to the dynamic string's new value.
  1646.  *
  1647.  * Side effects:
  1648.  *    String is reformatted as a list element and added to the current
  1649.  *    value of the string.  Memory gets reallocated if needed to
  1650.  *    accomodate the string's new size.
  1651.  *
  1652.  *----------------------------------------------------------------------
  1653.  */
  1654.  
  1655. char *
  1656. Tcl_DStringAppendElement(dsPtr, string)
  1657.     register Tcl_DString *dsPtr;    /* Structure describing dynamic
  1658.                      * string. */
  1659.     char *string;            /* String to append.  Must be
  1660.                      * null-terminated. */
  1661. {
  1662.     int newSize, flags;
  1663.     char *dst, *newString;
  1664.  
  1665.     newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1;
  1666.  
  1667.     /*
  1668.      * Allocate a larger buffer for the string if the current one isn't
  1669.      * large enough.  Allocate extra space in the new buffer so that there
  1670.      * will be room to grow before we have to allocate again.
  1671.      */
  1672.  
  1673.     if (newSize >= dsPtr->spaceAvl) {
  1674.     dsPtr->spaceAvl = newSize*2;
  1675.     newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
  1676.     strcpy(newString, dsPtr->string);
  1677.     if (dsPtr->string != dsPtr->staticSpace) {
  1678.         ckfree(dsPtr->string);
  1679.     }
  1680.     dsPtr->string = newString;
  1681.     }
  1682.  
  1683.     /*
  1684.      * Convert the new string to a list element and copy it into the
  1685.      * buffer at the end.  Add a space separator unless we're at the
  1686.      * start of the string or just after an unbackslashed "{".
  1687.      */
  1688.  
  1689.     dst = dsPtr->string + dsPtr->length;
  1690.     if ((dsPtr->length > 0) && ((dst[-1] != '{')
  1691.         || ((dsPtr->length > 1) && (dst[-2] == '\\')))) {
  1692.     *dst = ' ';
  1693.     dst++;
  1694.     dsPtr->length++;
  1695.     }
  1696.     dsPtr->length += Tcl_ConvertElement(string, dst, flags);
  1697.     return dsPtr->string;
  1698. }
  1699.  
  1700. /*
  1701.  *----------------------------------------------------------------------
  1702.  *
  1703.  * Tcl_DStringTrunc --
  1704.  *
  1705.  *    Truncate a dynamic string to a given length without freeing
  1706.  *    up its storage.
  1707.  *
  1708.  * Results:
  1709.  *    None.
  1710.  *
  1711.  * Side effects:
  1712.  *    The length of dsPtr is reduced to length unless it was already
  1713.  *    shorter than that.
  1714.  *
  1715.  *----------------------------------------------------------------------
  1716.  */
  1717.  
  1718. void
  1719. Tcl_DStringTrunc(dsPtr, length)
  1720.     register Tcl_DString *dsPtr;    /* Structure describing dynamic
  1721.                      * string. */
  1722.     int length;                /* New length for dynamic string. */
  1723. {
  1724.     if (length < 0) {
  1725.     length = 0;
  1726.     }
  1727.     if (length < dsPtr->length) {
  1728.     dsPtr->length = length;
  1729.     dsPtr->string[length] = 0;
  1730.     }
  1731. }
  1732.  
  1733. /*
  1734.  *----------------------------------------------------------------------
  1735.  *
  1736.  * Tcl_DStringFree --
  1737.  *
  1738.  *    Frees up any memory allocated for the dynamic string and
  1739.  *    reinitializes the string to an empty state.
  1740.  *
  1741.  * Results:
  1742.  *    None.
  1743.  *
  1744.  * Side effects:
  1745.  *    The previous contents of the dynamic string are lost, and
  1746.  *    the new value is an empty string.
  1747.  *
  1748.  *----------------------------------------------------------------------
  1749.  */
  1750.  
  1751. void
  1752. Tcl_DStringFree(dsPtr)
  1753.     register Tcl_DString *dsPtr;    /* Structure describing dynamic
  1754.                      * string. */
  1755. {
  1756.     if (dsPtr->string != dsPtr->staticSpace) {
  1757.     ckfree(dsPtr->string);
  1758.     }
  1759.     dsPtr->string = dsPtr->staticSpace;
  1760.     dsPtr->length = 0;
  1761.     dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
  1762.     dsPtr->staticSpace[0] = 0;
  1763. }
  1764.  
  1765. /*
  1766.  *----------------------------------------------------------------------
  1767.  *
  1768.  * Tcl_DStringResult --
  1769.  *
  1770.  *    This procedure moves the value of a dynamic string into an
  1771.  *    interpreter as its result.  The string itself is reinitialized
  1772.  *    to an empty string.
  1773.  *
  1774.  * Results:
  1775.  *    None.
  1776.  *
  1777.  * Side effects:
  1778.  *    The string is "moved" to interp's result, and any existing
  1779.  *    result for interp is freed up.  DsPtr is reinitialized to
  1780.  *    an empty string.
  1781.  *
  1782.  *----------------------------------------------------------------------
  1783.  */
  1784.  
  1785. void
  1786. Tcl_DStringResult(interp, dsPtr)
  1787.     Tcl_Interp *interp;            /* Interpreter whose result is to be
  1788.                      * reset. */
  1789.     Tcl_DString *dsPtr;            /* Dynamic string that is to become
  1790.                      * the result of interp. */
  1791. {
  1792.     Tcl_FreeResult(interp);
  1793.     if (dsPtr->string != dsPtr->staticSpace) {
  1794.     interp->result = dsPtr->string;
  1795.     interp->freeProc = (Tcl_FreeProc *) free;
  1796.     } else if (dsPtr->length < TCL_RESULT_SIZE) {
  1797.     strcpy(interp->result, dsPtr->string);
  1798.     } else {
  1799.     Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE);
  1800.     }
  1801.     dsPtr->string = dsPtr->staticSpace;
  1802.     dsPtr->length = 0;
  1803.     dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
  1804.     dsPtr->staticSpace[0] = 0;
  1805. }
  1806.  
  1807. /*
  1808.  *----------------------------------------------------------------------
  1809.  *
  1810.  * Tcl_DStringStartSublist --
  1811.  *
  1812.  *    This procedure adds the necessary information to a dynamic
  1813.  *    string (e.g. " {" to start a sublist.  Future element
  1814.  *    appends will be in the sublist rather than the main list.
  1815.  *
  1816.  * Results:
  1817.  *    None.
  1818.  *
  1819.  * Side effects:
  1820.  *    Characters get added to the dynamic string.
  1821.  *
  1822.  *----------------------------------------------------------------------
  1823.  */
  1824.  
  1825. void
  1826. Tcl_DStringStartSublist(dsPtr)
  1827.     Tcl_DString *dsPtr;            /* Dynamic string. */
  1828. {
  1829.     if ((dsPtr->length == 0)
  1830.         || ((dsPtr->length == 1) && (dsPtr->string[0] == '{'))
  1831.         || ((dsPtr->length > 1) && (dsPtr->string[dsPtr->length-1] == '{')
  1832.             && (dsPtr->string[dsPtr->length-2] != '\\'))) {
  1833.     Tcl_DStringAppend(dsPtr, "{", -1);
  1834.     } else {
  1835.     Tcl_DStringAppend(dsPtr, " {", -1);
  1836.     }
  1837. }
  1838.  
  1839. /*
  1840.  *----------------------------------------------------------------------
  1841.  *
  1842.  * Tcl_DStringEndSublist --
  1843.  *
  1844.  *    This procedure adds the necessary characters to a dynamic
  1845.  *    string to end a sublist (e.g. "}").  Future element appends
  1846.  *    will be in the enclosing (sub)list rather than the current
  1847.  *    sublist.
  1848.  *
  1849.  * Results:
  1850.  *    None.
  1851.  *
  1852.  * Side effects:
  1853.  *    None.
  1854.  *
  1855.  *----------------------------------------------------------------------
  1856.  */
  1857.  
  1858. void
  1859. Tcl_DStringEndSublist(dsPtr)
  1860.     Tcl_DString *dsPtr;            /* Dynamic string. */
  1861. {
  1862.     Tcl_DStringAppend(dsPtr, "}", -1);
  1863. }
  1864.  
  1865. /*
  1866.  *----------------------------------------------------------------------
  1867.  *
  1868.  * Tcl_PrintDouble --
  1869.  *
  1870.  *    Given a floating-point value, this procedure converts it to
  1871.  *    an ASCII string using.
  1872.  *
  1873.  * Results:
  1874.  *    The ASCII equivalent of "value" is written at "dst".  It is
  1875.  *    written using the current precision, and it is guaranteed to
  1876.  *    contain a decimal point or exponent, so that it looks like
  1877.  *    a floating-point value and not an integer.
  1878.  *
  1879.  * Side effects:
  1880.  *    None.
  1881.  *
  1882.  *----------------------------------------------------------------------
  1883.  */
  1884.  
  1885. void
  1886. Tcl_PrintDouble(interp, value, dst)
  1887.     Tcl_Interp *interp;            /* Interpreter whose tcl_precision
  1888.                      * variable controls printing. */
  1889.     double value;            /* Value to print as string. */
  1890.     char *dst;                /* Where to store converted value;
  1891.                      * must have at least TCL_DOUBLE_SPACE
  1892.                      * characters. */
  1893. {
  1894.     register char *p;
  1895.     sprintf(dst, ((Interp *) interp)->pdFormat, value);
  1896.  
  1897.     /*
  1898.      * If the ASCII result looks like an integer, add ".0" so that it
  1899.      * doesn't look like an integer anymore.  This prevents floating-point
  1900.      * values from being converted to integers unintentionally.
  1901.      */
  1902.  
  1903.     for (p = dst; *p != 0; p++) {
  1904.     if ((*p == '.') || (isalpha(UCHAR(*p)))) {
  1905.         return;
  1906.     }
  1907.     }
  1908.     p[0] = '.';
  1909.     p[1] = '0';
  1910.     p[2] = 0;
  1911. }
  1912.  
  1913. /*
  1914.  *----------------------------------------------------------------------
  1915.  *
  1916.  * TclPrecTraceProc --
  1917.  *
  1918.  *    This procedure is invoked whenever the variable "tcl_precision"
  1919.  *    is written.
  1920.  *
  1921.  * Results:
  1922.  *    Returns NULL if all went well, or an error message if the
  1923.  *    new value for the variable doesn't make sense.
  1924.  *
  1925.  * Side effects:
  1926.  *    If the new value doesn't make sense then this procedure
  1927.  *    undoes the effect of the variable modification.  Otherwise
  1928.  *    it modifies the format string that's used by Tcl_PrintDouble.
  1929.  *
  1930.  *----------------------------------------------------------------------
  1931.  */
  1932.  
  1933.     /* ARGSUSED */
  1934. char *
  1935. TclPrecTraceProc(clientData, interp, name1, name2, flags)
  1936.     ClientData clientData;    /* Not used. */
  1937.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  1938.     char *name1;        /* Name of variable. */
  1939.     char *name2;        /* Second part of variable name. */
  1940.     int flags;            /* Information about what happened. */
  1941. {
  1942.     register Interp *iPtr = (Interp *) interp;
  1943.     char *value, *end;
  1944.     int prec;
  1945.  
  1946.     /*
  1947.      * If the variable is unset, then recreate the trace and restore
  1948.      * the default value of the format string.
  1949.      */
  1950.  
  1951.     if (flags & TCL_TRACE_UNSETS) {
  1952.     if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) {
  1953.         Tcl_TraceVar2(interp, name1, name2,
  1954.             TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
  1955.             TclPrecTraceProc, clientData);
  1956.     }
  1957.     strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT);
  1958.     iPtr->pdPrec = DEFAULT_PD_PREC;
  1959.     return (char *) NULL;
  1960.     }
  1961.  
  1962.     value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
  1963.     if (value == NULL) {
  1964.     value = "";
  1965.     }
  1966.     prec = strtoul(value, &end, 10);
  1967.     if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) ||
  1968.         (end == value) || (*end != 0)) {
  1969.     char oldValue[10];
  1970.  
  1971.     sprintf(oldValue, "%d", iPtr->pdPrec);
  1972.     Tcl_SetVar2(interp, name1, name2, oldValue, flags & TCL_GLOBAL_ONLY);
  1973.     return "improper value for precision";
  1974.     }
  1975.     sprintf(iPtr->pdFormat, "%%.%dg", prec);
  1976.     iPtr->pdPrec = prec;
  1977.     return (char *) NULL;
  1978. }
  1979.