cde/programs/dtdocbook/tcl/tclUtil.c

   1 /*
   2  * CDE - Common Desktop Environment
   3  *
   4  * Copyright (c) 1993-2012, The Open Group. All rights reserved.
   5  *
   6  * These libraries and programs are free software; you can
   7  * redistribute them and/or modify them under the terms of the GNU
   8  * Lesser General Public License as published by the Free Software
   9  * Foundation; either version 2 of the License, or (at your option)
  10  * any later version.
  11  *
  12  * These libraries and programs are distributed in the hope that
  13  * they will be useful, but WITHOUT ANY WARRANTY; without even the
  14  * implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
  15  * PURPOSE. See the GNU Lesser General Public License for more
  16  * details.
  17  *
  18  * You should have received a copy of the GNU Lesser General Public
  19  * License along with these librararies and programs; if not, write
  20  * to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
  21  * Floor, Boston, MA 02110-1301 USA
  22  */
  23 /* $XConsortium: tclUtil.c /main/5 1996/08/08 14:47:12 cde-hp $ */
  24 /*
  25  * tclUtil.c --
  26  *
  27  *      This file contains utility procedures that are used by many Tcl
  28  *      commands.
  29  *
  30  * Copyright (c) 1987-1993 The Regents of the University of California.
  31  * Copyright (c) 1994-1995 Sun Microsystems, Inc.
  32  *
  33  * See the file "license.terms" for information on usage and redistribution
  34  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  35  *
  36  * SCCS: @(#) tclUtil.c 1.112 96/02/15 11:42:52
  37  */
  38
  39 #include "tclInt.h"
  40 #include "tclPort.h"
  41
  42 /*
  43  * The following values are used in the flags returned by Tcl_ScanElement
  44  * and used by Tcl_ConvertElement.  The value TCL_DONT_USE_BRACES is also
  45  * defined in tcl.h;  make sure its value doesn't overlap with any of the
  46  * values below.
  47  *
  48  * TCL_DONT_USE_BRACES -        1 means the string mustn't be enclosed in
  49  *                              braces (e.g. it contains unmatched braces,
  50  *                              or ends in a backslash character, or user
  51  *                              just doesn't want braces);  handle all
  52  *                              special characters by adding backslashes.
  53  * USE_BRACES -                 1 means the string contains a special
  54  *                              character that can be handled simply by
  55  *                              enclosing the entire argument in braces.
  56  * BRACES_UNMATCHED -           1 means that braces aren't properly matched
  57  *                              in the argument.
  58  */
  59
  60 #define USE_BRACES              2
  61 #define BRACES_UNMATCHED        4
  62
  63 /*
  64  * Function prototypes for local procedures in this file:
  65  */
  66
  67 static void             SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
  68                             int newSpace));
  69 \f
  70 /*
  71  *----------------------------------------------------------------------
  72  *
  73  * TclFindElement --
  74  *
  75  *      Given a pointer into a Tcl list, locate the first (or next)
  76  *      element in the list.
  77  *
  78  * Results:
  79  *      The return value is normally TCL_OK, which means that the
  80  *      element was successfully located.  If TCL_ERROR is returned
  81  *      it means that list didn't have proper list structure;
  82  *      interp->result contains a more detailed error message.
  83  *
  84  *      If TCL_OK is returned, then *elementPtr will be set to point
  85  *      to the first element of list, and *nextPtr will be set to point
  86  *      to the character just after any white space following the last
  87  *      character that's part of the element.  If this is the last argument
  88  *      in the list, then *nextPtr will point to the NULL character at the
  89  *      end of list.  If sizePtr is non-NULL, *sizePtr is filled in with
  90  *      the number of characters in the element.  If the element is in
  91  *      braces, then *elementPtr will point to the character after the
  92  *      opening brace and *sizePtr will not include either of the braces.
  93  *      If there isn't an element in the list, *sizePtr will be zero, and
  94  *      both *elementPtr and *termPtr will refer to the null character at
  95  *      the end of list.  Note:  this procedure does NOT collapse backslash
  96  *      sequences.
  97  *
  98  * Side effects:
  99  *      None.
 100  *
 101  *----------------------------------------------------------------------
 102  */
 103
 104 int
 105 TclFindElement(interp, list, elementPtr, nextPtr, sizePtr, bracePtr)
 106     Tcl_Interp *interp;         /* Interpreter to use for error reporting.
 107                                  * If NULL, then no error message is left
 108                                  * after errors. */
 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                     if (interp != NULL) {
 189                         Tcl_ResetResult(interp);
 190                         sprintf(interp->result,
 191                                 "list element in braces followed by \"%.*s\" instead of space",
 192                                 (int) (p2-p), p);
 193                     }
 194                     return TCL_ERROR;
 195                 } else if (openBraces != 0) {
 196                     openBraces--;
 197                 }
 198                 break;
 199
 200             /*
 201              * Backslash:  skip over everything up to the end of the
 202              * backslash sequence.
 203              */
 204
 205             case '\\': {
 206                 int size;
 207
 208                 (void) Tcl_Backslash(p, &size);
 209                 p += size - 1;
 210                 break;
 211             }
 212
 213             /*
 214              * Space: ignore if element is in braces or quotes;  otherwise
 215              * terminate element.
 216              */
 217
 218             case ' ':
 219             case '\f':
 220             case '\n':
 221             case '\r':
 222             case '\t':
 223             case '\v':
 224                 if ((openBraces == 0) && !inQuotes) {
 225                     size = p - list;
 226                     goto done;
 227                 }
 228                 break;
 229
 230             /*
 231              * Double-quote:  if element is in quotes then terminate it.
 232              */
 233
 234             case '"':
 235                 if (inQuotes) {
 236                     char *p2;
 237
 238                     size = p-list;
 239                     p++;
 240                     if (isspace(UCHAR(*p)) || (*p == 0)) {
 241                         goto done;
 242                     }
 243                     for (p2 = p; (*p2 != 0) && (!isspace(UCHAR(*p2)))
 244                             && (p2 < p+20); p2++) {
 245                         /* null body */
 246                     }
 247                     if (interp != NULL) {
 248                         Tcl_ResetResult(interp);
 249                         sprintf(interp->result,
 250                                 "list element in quotes followed by \"%.*s\" %s", (int) (p2-p), p,
 251                                 "instead of space");
 252                     }
 253                     return TCL_ERROR;
 254                 }
 255                 break;
 256
 257             /*
 258              * End of list:  terminate element.
 259              */
 260
 261             case 0:
 262                 if (openBraces != 0) {
 263                     if (interp != NULL) {
 264                         Tcl_SetResult(interp, "unmatched open brace in list",
 265                                 TCL_STATIC);
 266                     }
 267                     return TCL_ERROR;
 268                 } else if (inQuotes) {
 269                     if (interp != NULL) {
 270                         Tcl_SetResult(interp, "unmatched open quote in list",
 271                                 TCL_STATIC);
 272                     }
 273                     return TCL_ERROR;
 274                 }
 275                 size = p - list;
 276                 goto done;
 277
 278         }
 279         p++;
 280     }
 281
 282     done:
 283     while (isspace(UCHAR(*p))) {
 284         p++;
 285     }
 286     *elementPtr = list;
 287     *nextPtr = p;
 288     if (sizePtr != 0) {
 289         *sizePtr = size;
 290     }
 291     return TCL_OK;
 292 }
 293 \f
 294 /*
 295  *----------------------------------------------------------------------
 296  *
 297  * TclCopyAndCollapse --
 298  *
 299  *      Copy a string and eliminate any backslashes that aren't in braces.
 300  *
 301  * Results:
 302  *      There is no return value.  Count chars. get copied from src
 303  *      to dst.  Along the way, if backslash sequences are found outside
 304  *      braces, the backslashes are eliminated in the copy.
 305  *      After scanning count chars. from source, a null character is
 306  *      placed at the end of dst.
 307  *
 308  * Side effects:
 309  *      None.
 310  *
 311  *----------------------------------------------------------------------
 312  */
 313
 314 void
 315 TclCopyAndCollapse(count, src, dst)
 316     int count;                  /* Total number of characters to copy
 317                                  * from src. */
 318     register char *src;         /* Copy from here... */
 319     register char *dst;         /* ... to here. */
 320 {
 321     register char c;
 322     int numRead;
 323
 324     for (c = *src; count > 0; src++, c = *src, count--) {
 325         if (c == '\\') {
 326             *dst = Tcl_Backslash(src, &numRead);
 327             dst++;
 328             src += numRead-1;
 329             count -= numRead-1;
 330         } else {
 331             *dst = c;
 332             dst++;
 333         }
 334     }
 335     *dst = 0;
 336 }
 337 \f
 338 /*
 339  *----------------------------------------------------------------------
 340  *
 341  * Tcl_SplitList --
 342  *
 343  *      Splits a list up into its constituent fields.
 344  *
 345  * Results
 346  *      The return value is normally TCL_OK, which means that
 347  *      the list was successfully split up.  If TCL_ERROR is
 348  *      returned, it means that "list" didn't have proper list
 349  *      structure;  interp->result will contain a more detailed
 350  *      error message.
 351  *
 352  *      *argvPtr will be filled in with the address of an array
 353  *      whose elements point to the elements of list, in order.
 354  *      *argcPtr will get filled in with the number of valid elements
 355  *      in the array.  A single block of memory is dynamically allocated
 356  *      to hold both the argv array and a copy of the list (with
 357  *      backslashes and braces removed in the standard way).
 358  *      The caller must eventually free this memory by calling free()
 359  *      on *argvPtr.  Note:  *argvPtr and *argcPtr are only modified
 360  *      if the procedure returns normally.
 361  *
 362  * Side effects:
 363  *      Memory is allocated.
 364  *
 365  *----------------------------------------------------------------------
 366  */
 367
 368 int
 369 Tcl_SplitList(interp, list, argcPtr, argvPtr)
 370     Tcl_Interp *interp;         /* Interpreter to use for error reporting.
 371                                  * If NULL, then no error message is left. */
 372     char *list;                 /* Pointer to string with list structure. */
 373     int *argcPtr;               /* Pointer to location to fill in with
 374                                  * the number of elements in the list. */
 375     char ***argvPtr;            /* Pointer to place to store pointer to array
 376                                  * of pointers to list elements. */
 377 {
 378     char **argv;
 379     register char *p;
 380     int size, i, result, elSize, brace;
 381     char *element;
 382
 383     /*
 384      * Figure out how much space to allocate.  There must be enough
 385      * space for both the array of pointers and also for a copy of
 386      * the list.  To estimate the number of pointers needed, count
 387      * the number of space characters in the list.
 388      */
 389
 390     for (size = 1, p = list; *p != 0; p++) {
 391         if (isspace(UCHAR(*p))) {
 392             size++;
 393         }
 394     }
 395     size++;                     /* Leave space for final NULL pointer. */
 396     argv = (char **) ckalloc((unsigned)
 397             ((size * sizeof(char *)) + (p - list) + 1));
 398     for (i = 0, p = ((char *) argv) + size*sizeof(char *);
 399             *list != 0; i++) {
 400         result = TclFindElement(interp, list, &element, &list, &elSize, &brace);
 401         if (result != TCL_OK) {
 402             ckfree((char *) argv);
 403             return result;
 404         }
 405         if (*element == 0) {
 406             break;
 407         }
 408         if (i >= size) {
 409             ckfree((char *) argv);
 410             if (interp != NULL) {
 411                 Tcl_SetResult(interp, "internal error in Tcl_SplitList",
 412                         TCL_STATIC);
 413             }
 414             return TCL_ERROR;
 415         }
 416         argv[i] = p;
 417         if (brace) {
 418             strncpy(p, element, (size_t) elSize);
 419             p += elSize;
 420             *p = 0;
 421             p++;
 422         } else {
 423             TclCopyAndCollapse(elSize, element, p);
 424             p += elSize+1;
 425         }
 426     }
 427
 428     argv[i] = NULL;
 429     *argvPtr = argv;
 430     *argcPtr = i;
 431     return TCL_OK;
 432 }
 433 \f
 434 /*
 435  *----------------------------------------------------------------------
 436  *
 437  * Tcl_ScanElement --
 438  *
 439  *      This procedure is a companion procedure to Tcl_ConvertElement.
 440  *      It scans a string to see what needs to be done to it (e.g.
 441  *      add backslashes or enclosing braces) to make the string into
 442  *      a valid Tcl list element.
 443  *
 444  * Results:
 445  *      The return value is an overestimate of the number of characters
 446  *      that will be needed by Tcl_ConvertElement to produce a valid
 447  *      list element from string.  The word at *flagPtr is filled in
 448  *      with a value needed by Tcl_ConvertElement when doing the actual
 449  *      conversion.
 450  *
 451  * Side effects:
 452  *      None.
 453  *
 454  *----------------------------------------------------------------------
 455  */
 456
 457 int
 458 Tcl_ScanElement(string, flagPtr)
 459     char *string;               /* String to convert to Tcl list element. */
 460     int *flagPtr;               /* Where to store information to guide
 461                                  * Tcl_ConvertElement. */
 462 {
 463     int flags, nestingLevel;
 464     register char *p;
 465
 466     /*
 467      * This procedure and Tcl_ConvertElement together do two things:
 468      *
 469      * 1. They produce a proper list, one that will yield back the
 470      * argument strings when evaluated or when disassembled with
 471      * Tcl_SplitList.  This is the most important thing.
 472      *
 473      * 2. They try to produce legible output, which means minimizing the
 474      * use of backslashes (using braces instead).  However, there are
 475      * some situations where backslashes must be used (e.g. an element
 476      * like "{abc": the leading brace will have to be backslashed.  For
 477      * each element, one of three things must be done:
 478      *
 479      * (a) Use the element as-is (it doesn't contain anything special
 480      * characters).  This is the most desirable option.
 481      *
 482      * (b) Enclose the element in braces, but leave the contents alone.
 483      * This happens if the element contains embedded space, or if it
 484      * contains characters with special interpretation ($, [, ;, or \),
 485      * or if it starts with a brace or double-quote, or if there are
 486      * no characters in the element.
 487      *
 488      * (c) Don't enclose the element in braces, but add backslashes to
 489      * prevent special interpretation of special characters.  This is a
 490      * last resort used when the argument would normally fall under case
 491      * (b) but contains unmatched braces.  It also occurs if the last
 492      * character of the argument is a backslash or if the element contains
 493      * a backslash followed by newline.
 494      *
 495      * The procedure figures out how many bytes will be needed to store
 496      * the result (actually, it overestimates).  It also collects information
 497      * about the element in the form of a flags word.
 498      */
 499
 500     nestingLevel = 0;
 501     flags = 0;
 502     if (string == NULL) {
 503         string = "";
 504     }
 505     p = string;
 506     if ((*p == '{') || (*p == '"') || (*p == 0)) {
 507         flags |= USE_BRACES;
 508     }
 509     for ( ; *p != 0; p++) {
 510         switch (*p) {
 511             case '{':
 512                 nestingLevel++;
 513                 break;
 514             case '}':
 515                 nestingLevel--;
 516                 if (nestingLevel < 0) {
 517                     flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED;
 518                 }
 519                 break;
 520             case '[':
 521             case '$':
 522             case ';':
 523             case ' ':
 524             case '\f':
 525             case '\n':
 526             case '\r':
 527             case '\t':
 528             case '\v':
 529                 flags |= USE_BRACES;
 530                 break;
 531             case '\\':
 532                 if ((p[1] == 0) || (p[1] == '\n')) {
 533                     flags = TCL_DONT_USE_BRACES;
 534                 } else {
 535                     int size;
 536
 537                     (void) Tcl_Backslash(p, &size);
 538                     p += size-1;
 539                     flags |= USE_BRACES;
 540                 }
 541                 break;
 542         }
 543     }
 544     if (nestingLevel != 0) {
 545         flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;
 546     }
 547     *flagPtr = flags;
 548
 549     /*
 550      * Allow enough space to backslash every character plus leave
 551      * two spaces for braces.
 552      */
 553
 554     return 2*(p-string) + 2;
 555 }
 556 \f
 557 /*
 558  *----------------------------------------------------------------------
 559  *
 560  * Tcl_ConvertElement --
 561  *
 562  *      This is a companion procedure to Tcl_ScanElement.  Given the
 563  *      information produced by Tcl_ScanElement, this procedure converts
 564  *      a string to a list element equal to that string.
 565  *
 566  * Results:
 567  *      Information is copied to *dst in the form of a list element
 568  *      identical to src (i.e. if Tcl_SplitList is applied to dst it
 569  *      will produce a string identical to src).  The return value is
 570  *      a count of the number of characters copied (not including the
 571  *      terminating NULL character).
 572  *
 573  * Side effects:
 574  *      None.
 575  *
 576  *----------------------------------------------------------------------
 577  */
 578
 579 int
 580 Tcl_ConvertElement(src, dst, flags)
 581     register char *src;         /* Source information for list element. */
 582     char *dst;                  /* Place to put list-ified element. */
 583     int flags;                  /* Flags produced by Tcl_ScanElement. */
 584 {
 585     register char *p = dst;
 586
 587     /*
 588      * See the comment block at the beginning of the Tcl_ScanElement
 589      * code for details of how this works.
 590      */
 591
 592     if ((src == NULL) || (*src == 0)) {
 593         p[0] = '{';
 594         p[1] = '}';
 595         p[2] = 0;
 596         return 2;
 597     }
 598     if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) {
 599         *p = '{';
 600         p++;
 601         for ( ; *src != 0; src++, p++) {
 602             *p = *src;
 603         }
 604         *p = '}';
 605         p++;
 606     } else {
 607         if (*src == '{') {
 608             /*
 609              * Can't have a leading brace unless the whole element is
 610              * enclosed in braces.  Add a backslash before the brace.
 611              * Furthermore, this may destroy the balance between open
 612              * and close braces, so set BRACES_UNMATCHED.
 613              */
 614
 615             p[0] = '\\';
 616             p[1] = '{';
 617             p += 2;
 618             src++;
 619             flags |= BRACES_UNMATCHED;
 620         }
 621         for (; *src != 0 ; src++) {
 622             switch (*src) {
 623                 case ']':
 624                 case '[':
 625                 case '$':
 626                 case ';':
 627                 case ' ':
 628                 case '\\':
 629                 case '"':
 630                     *p = '\\';
 631                     p++;
 632                     break;
 633                 case '{':
 634                 case '}':
 635                     /*
 636                      * It may not seem necessary to backslash braces, but
 637                      * it is.  The reason for this is that the resulting
 638                      * list element may actually be an element of a sub-list
 639                      * enclosed in braces (e.g. if Tcl_DStringStartSublist
 640                      * has been invoked), so there may be a brace mismatch
 641                      * if the braces aren't backslashed.
 642                      */
 643
 644                     if (flags & BRACES_UNMATCHED) {
 645                         *p = '\\';
 646                         p++;
 647                     }
 648                     break;
 649                 case '\f':
 650                     *p = '\\';
 651                     p++;
 652                     *p = 'f';
 653                     p++;
 654                     continue;
 655                 case '\n':
 656                     *p = '\\';
 657                     p++;
 658                     *p = 'n';
 659                     p++;
 660                     continue;
 661                 case '\r':
 662                     *p = '\\';
 663                     p++;
 664                     *p = 'r';
 665                     p++;
 666                     continue;
 667                 case '\t':
 668                     *p = '\\';
 669                     p++;
 670                     *p = 't';
 671                     p++;
 672                     continue;
 673                 case '\v':
 674                     *p = '\\';
 675                     p++;
 676                     *p = 'v';
 677                     p++;
 678                     continue;
 679             }
 680             *p = *src;
 681             p++;
 682         }
 683     }
 684     *p = '\0';
 685     return p-dst;
 686 }
 687 \f
 688 /*
 689  *----------------------------------------------------------------------
 690  *
 691  * Tcl_Merge --
 692  *
 693  *      Given a collection of strings, merge them together into a
 694  *      single string that has proper Tcl list structured (i.e.
 695  *      Tcl_SplitList may be used to retrieve strings equal to the
 696  *      original elements, and Tcl_Eval will parse the string back
 697  *      into its original elements).
 698  *
 699  * Results:
 700  *      The return value is the address of a dynamically-allocated
 701  *      string containing the merged list.
 702  *
 703  * Side effects:
 704  *      None.
 705  *
 706  *----------------------------------------------------------------------
 707  */
 708
 709 char *
 710 Tcl_Merge(argc, argv)
 711     int argc;                   /* How many strings to merge. */
 712     char **argv;                /* Array of string values. */
 713 {
 714 #   define LOCAL_SIZE 20
 715     int localFlags[LOCAL_SIZE], *flagPtr;
 716     int numChars;
 717     char *result;
 718     register char *dst;
 719     int i;
 720
 721     /*
 722      * Pass 1: estimate space, gather flags.
 723      */
 724
 725     if (argc <= LOCAL_SIZE) {
 726         flagPtr = localFlags;
 727     } else {
 728         flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int));
 729     }
 730     numChars = 1;
 731     for (i = 0; i < argc; i++) {
 732         numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1;
 733     }
 734
 735     /*
 736      * Pass two: copy into the result area.
 737      */
 738
 739     result = (char *) ckalloc((unsigned) numChars);
 740     dst = result;
 741     for (i = 0; i < argc; i++) {
 742         numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]);
 743         dst += numChars;
 744         *dst = ' ';
 745         dst++;
 746     }
 747     if (dst == result) {
 748         *dst = 0;
 749     } else {
 750         dst[-1] = 0;
 751     }
 752
 753     if (flagPtr != localFlags) {
 754         ckfree((char *) flagPtr);
 755     }
 756     return result;
 757 }
 758 \f
 759 /*
 760  *----------------------------------------------------------------------
 761  *
 762  * Tcl_Concat --
 763  *
 764  *      Concatenate a set of strings into a single large string.
 765  *
 766  * Results:
 767  *      The return value is dynamically-allocated string containing
 768  *      a concatenation of all the strings in argv, with spaces between
 769  *      the original argv elements.
 770  *
 771  * Side effects:
 772  *      Memory is allocated for the result;  the caller is responsible
 773  *      for freeing the memory.
 774  *
 775  *----------------------------------------------------------------------
 776  */
 777
 778 char *
 779 Tcl_Concat(argc, argv)
 780     int argc;                   /* Number of strings to concatenate. */
 781     char **argv;                /* Array of strings to concatenate. */
 782 {
 783     int totalSize, i;
 784     register char *p;
 785     char *result;
 786
 787     for (totalSize = 1, i = 0; i < argc; i++) {
 788         totalSize += strlen(argv[i]) + 1;
 789     }
 790     result = (char *) ckalloc((unsigned) totalSize);
 791     if (argc == 0) {
 792         *result = '\0';
 793         return result;
 794     }
 795     for (p = result, i = 0; i < argc; i++) {
 796         char *element;
 797         int length;
 798
 799         /*
 800          * Clip white space off the front and back of the string
 801          * to generate a neater result, and ignore any empty
 802          * elements.
 803          */
 804
 805         element = argv[i];
 806         while (isspace(UCHAR(*element))) {
 807             element++;
 808         }
 809         for (length = strlen(element);
 810                 (length > 0) && (isspace(UCHAR(element[length-1])));
 811                 length--) {
 812             /* Null loop body. */
 813         }
 814         if (length == 0) {
 815             continue;
 816         }
 817         (void) strncpy(p, element, (size_t) length);
 818         p += length;
 819         *p = ' ';
 820         p++;
 821     }
 822     if (p != result) {
 823         p[-1] = 0;
 824     } else {
 825         *p = 0;
 826     }
 827     return result;
 828 }
 829 \f
 830 /*
 831  *----------------------------------------------------------------------
 832  *
 833  * Tcl_StringMatch --
 834  *
 835  *      See if a particular string matches a particular pattern.
 836  *
 837  * Results:
 838  *      The return value is 1 if string matches pattern, and
 839  *      0 otherwise.  The matching operation permits the following
 840  *      special characters in the pattern: *?\[] (see the manual
 841  *      entry for details on what these mean).
 842  *
 843  * Side effects:
 844  *      None.
 845  *
 846  *----------------------------------------------------------------------
 847  */
 848
 849 int
 850 Tcl_StringMatch(string, pattern)
 851     register char *string;      /* String. */
 852     register char *pattern;     /* Pattern, which may contain
 853                                  * special characters. */
 854 {
 855     char c2;
 856
 857     while (1) {
 858         /* See if we're at the end of both the pattern and the string.
 859          * If so, we succeeded.  If we're at the end of the pattern
 860          * but not at the end of the string, we failed.
 861          */
 862
 863         if (*pattern == 0) {
 864             if (*string == 0) {
 865                 return 1;
 866             } else {
 867                 return 0;
 868             }
 869         }
 870         if ((*string == 0) && (*pattern != '*')) {
 871             return 0;
 872         }
 873
 874         /* Check for a "*" as the next pattern character.  It matches
 875          * any substring.  We handle this by calling ourselves
 876          * recursively for each postfix of string, until either we
 877          * match or we reach the end of the string.
 878          */
 879
 880         if (*pattern == '*') {
 881             pattern += 1;
 882             if (*pattern == 0) {
 883                 return 1;
 884             }
 885             while (1) {
 886                 if (Tcl_StringMatch(string, pattern)) {
 887                     return 1;
 888                 }
 889                 if (*string == 0) {
 890                     return 0;
 891                 }
 892                 string += 1;
 893             }
 894         }
 895
 896         /* Check for a "?" as the next pattern character.  It matches
 897          * any single character.
 898          */
 899
 900         if (*pattern == '?') {
 901             goto thisCharOK;
 902         }
 903
 904         /* Check for a "[" as the next pattern character.  It is followed
 905          * by a list of characters that are acceptable, or by a range
 906          * (two characters separated by "-").
 907          */
 908
 909         if (*pattern == '[') {
 910             pattern += 1;
 911             while (1) {
 912                 if ((*pattern == ']') || (*pattern == 0)) {
 913                     return 0;
 914                 }
 915                 if (*pattern == *string) {
 916                     break;
 917                 }
 918                 if (pattern[1] == '-') {
 919                     c2 = pattern[2];
 920                     if (c2 == 0) {
 921                         return 0;
 922                     }
 923                     if ((*pattern <= *string) && (c2 >= *string)) {
 924                         break;
 925                     }
 926                     if ((*pattern >= *string) && (c2 <= *string)) {
 927                         break;
 928                     }
 929                     pattern += 2;
 930                 }
 931                 pattern += 1;
 932             }
 933             while (*pattern != ']') {
 934                 if (*pattern == 0) {
 935                     pattern--;
 936                     break;
 937                 }
 938                 pattern += 1;
 939             }
 940             goto thisCharOK;
 941         }
 942
 943         /* If the next pattern character is '/', just strip off the '/'
 944          * so we do exact matching on the character that follows.
 945          */
 946
 947         if (*pattern == '\\') {
 948             pattern += 1;
 949             if (*pattern == 0) {
 950                 return 0;
 951             }
 952         }
 953
 954         /* There's no special character.  Just make sure that the next
 955          * characters of each string match.
 956          */
 957
 958         if (*pattern != *string) {
 959             return 0;
 960         }
 961
 962         thisCharOK: pattern += 1;
 963         string += 1;
 964     }
 965 }
 966 \f
 967 /*
 968  *----------------------------------------------------------------------
 969  *
 970  * Tcl_SetResult --
 971  *
 972  *      Arrange for "string" to be the Tcl return value.
 973  *
 974  * Results:
 975  *      None.
 976  *
 977  * Side effects:
 978  *      interp->result is left pointing either to "string" (if "copy" is 0)
 979  *      or to a copy of string.
 980  *
 981  *----------------------------------------------------------------------
 982  */
 983
 984 void
 985 Tcl_SetResult(interp, string, freeProc)
 986     Tcl_Interp *interp;         /* Interpreter with which to associate the
 987                                  * return value. */
 988     char *string;               /* Value to be returned.  If NULL,
 989                                  * the result is set to an empty string. */
 990     Tcl_FreeProc *freeProc;     /* Gives information about the string:
 991                                  * TCL_STATIC, TCL_VOLATILE, or the address
 992                                  * of a Tcl_FreeProc such as free. */
 993 {
 994     register Interp *iPtr = (Interp *) interp;
 995     int length;
 996     Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
 997     char *oldResult = iPtr->result;
 998
 999     if (string == NULL) {
1000         iPtr->resultSpace[0] = 0;
1001         iPtr->result = iPtr->resultSpace;
1002         iPtr->freeProc = 0;
1003     } else if (freeProc == TCL_DYNAMIC) {
1004         iPtr->result = string;
1005         iPtr->freeProc = TCL_DYNAMIC;
1006     } else if (freeProc == TCL_VOLATILE) {
1007         length = strlen(string);
1008         if (length > TCL_RESULT_SIZE) {
1009             iPtr->result = (char *) ckalloc((unsigned) length+1);
1010             iPtr->freeProc = TCL_DYNAMIC;
1011         } else {
1012             iPtr->result = iPtr->resultSpace;
1013             iPtr->freeProc = 0;
1014         }
1015         strcpy(iPtr->result, string);
1016     } else {
1017         iPtr->result = string;
1018         iPtr->freeProc = freeProc;
1019     }
1020
1021     /*
1022      * If the old result was dynamically-allocated, free it up.  Do it
1023      * here, rather than at the beginning, in case the new result value
1024      * was part of the old result value.
1025      */
1026
1027     if (oldFreeProc != 0) {
1028         if ((oldFreeProc == TCL_DYNAMIC)
1029                 || (oldFreeProc == (Tcl_FreeProc *) free)) {
1030             ckfree(oldResult);
1031         } else {
1032             (*oldFreeProc)(oldResult);
1033         }
1034     }
1035 }
1036 \f
1037 /*
1038  *----------------------------------------------------------------------
1039  *
1040  * Tcl_AppendResult --
1041  *
1042  *      Append a variable number of strings onto the result already
1043  *      present for an interpreter.
1044  *
1045  * Results:
1046  *      None.
1047  *
1048  * Side effects:
1049  *      The result in the interpreter given by the first argument
1050  *      is extended by the strings given by the second and following
1051  *      arguments (up to a terminating NULL argument).
1052  *
1053  *----------------------------------------------------------------------
1054  */
1055
1056         /* VARARGS2 */
1057 void
1058 Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
1059 {
1060     va_list argList;
1061     register Interp *iPtr;
1062     char *string;
1063     int newSpace;
1064
1065     /*
1066      * First, scan through all the arguments to see how much space is
1067      * needed.
1068      */
1069
1070     iPtr = (Interp *)arg1;
1071     va_start(argList, arg1);
1072     newSpace = 0;
1073     while (1) {
1074         string = va_arg(argList, char *);
1075         if (string == NULL) {
1076             break;
1077         }
1078         newSpace += strlen(string);
1079     }
1080     va_end(argList);
1081
1082     /*
1083      * If the append buffer isn't already setup and large enough
1084      * to hold the new data, set it up.
1085      */
1086
1087     if ((iPtr->result != iPtr->appendResult)
1088             || (iPtr->appendResult[iPtr->appendUsed] != 0)
1089             || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
1090        SetupAppendBuffer(iPtr, newSpace);
1091     }
1092
1093     /*
1094      * Final step:  go through all the argument strings again, copying
1095      * them into the buffer.
1096      */
1097
1098     va_start(argList, arg1);
1099     while (1) {
1100         string = va_arg(argList, char *);
1101         if (string == NULL) {
1102             break;
1103         }
1104         strcpy(iPtr->appendResult + iPtr->appendUsed, string);
1105         iPtr->appendUsed += strlen(string);
1106     }
1107     va_end(argList);
1108 }
1109 \f
1110 /*
1111  *----------------------------------------------------------------------
1112  *
1113  * Tcl_AppendElement --
1114  *
1115  *      Convert a string to a valid Tcl list element and append it
1116  *      to the current result (which is ostensibly a list).
1117  *
1118  * Results:
1119  *      None.
1120  *
1121  * Side effects:
1122  *      The result in the interpreter given by the first argument
1123  *      is extended with a list element converted from string.  A
1124  *      separator space is added before the converted list element
1125  *      unless the current result is empty, contains the single
1126  *      character "{", or ends in " {".
1127  *
1128  *----------------------------------------------------------------------
1129  */
1130
1131 void
1132 Tcl_AppendElement(interp, string)
1133     Tcl_Interp *interp;         /* Interpreter whose result is to be
1134                                  * extended. */
1135     char *string;               /* String to convert to list element and
1136                                  * add to result. */
1137 {
1138     register Interp *iPtr = (Interp *) interp;
1139     int size, flags;
1140     char *dst;
1141
1142     /*
1143      * See how much space is needed, and grow the append buffer if
1144      * needed to accommodate the list element.
1145      */
1146
1147     size = Tcl_ScanElement(string, &flags) + 1;
1148     if ((iPtr->result != iPtr->appendResult)
1149             || (iPtr->appendResult[iPtr->appendUsed] != 0)
1150             || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
1151        SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
1152     }
1153
1154     /*
1155      * Convert the string into a list element and copy it to the
1156      * buffer that's forming, with a space separator if needed.
1157      */
1158
1159     dst = iPtr->appendResult + iPtr->appendUsed;
1160     if (TclNeedSpace(iPtr->appendResult, dst)) {
1161         iPtr->appendUsed++;
1162         *dst = ' ';
1163         dst++;
1164     }
1165     iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);
1166 }
1167 \f
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 \f
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 \f
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 void
1299 Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1)
1300 {
1301     va_list argList;
1302     char *string;
1303     int flags;
1304     Interp *iPtr;
1305
1306     /*
1307      * Scan through the arguments one at a time, appending them to
1308      * $errorCode as list elements.
1309      */
1310
1311     iPtr = (Interp *)arg1;
1312     va_start(argList, arg1);
1313     flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
1314     while (1) {
1315         string = va_arg(argList, char *);
1316         if (string == NULL) {
1317             break;
1318         }
1319         (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
1320                 (char *) NULL, string, flags);
1321         flags |= TCL_APPEND_VALUE;
1322     }
1323     va_end(argList);
1324     iPtr->flags |= ERROR_CODE_SET;
1325 }
1326 \f
1327 /*
1328  *----------------------------------------------------------------------
1329  *
1330  * TclGetListIndex --
1331  *
1332  *      Parse a list index, which may be either an integer or the
1333  *      value "end".
1334  *
1335  * Results:
1336  *      The return value is either TCL_OK or TCL_ERROR.  If it is
1337  *      TCL_OK, then the index corresponding to string is left in
1338  *      *indexPtr.  If the return value is TCL_ERROR, then string
1339  *      was bogus;  an error message is returned in interp->result.
1340  *      If a negative index is specified, it is rounded up to 0.
1341  *      The index value may be larger than the size of the list
1342  *      (this happens when "end" is specified).
1343  *
1344  * Side effects:
1345  *      None.
1346  *
1347  *----------------------------------------------------------------------
1348  */
1349
1350 int
1351 TclGetListIndex(interp, string, indexPtr)
1352     Tcl_Interp *interp;                 /* Interpreter for error reporting. */
1353     char *string;                       /* String containing list index. */
1354     int *indexPtr;                      /* Where to store index. */
1355 {
1356     if (isdigit(UCHAR(*string)) || (*string == '-')) {
1357         if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) {
1358             return TCL_ERROR;
1359         }
1360         if (*indexPtr < 0) {
1361             *indexPtr = 0;
1362         }
1363     } else if (strncmp(string, "end", strlen(string)) == 0) {
1364         *indexPtr = INT_MAX;
1365     } else {
1366         Tcl_AppendResult(interp, "bad index \"", string,
1367                 "\": must be integer or \"end\"", (char *) NULL);
1368         return TCL_ERROR;
1369     }
1370     return TCL_OK;
1371 }
1372 \f
1373 /*
1374  *----------------------------------------------------------------------
1375  *
1376  * Tcl_RegExpCompile --
1377  *
1378  *      Compile a regular expression into a form suitable for fast
1379  *      matching.  This procedure retains a small cache of pre-compiled
1380  *      regular expressions in the interpreter, in order to avoid
1381  *      compilation costs as much as possible.
1382  *
1383  * Results:
1384  *      The return value is a pointer to the compiled form of string,
1385  *      suitable for passing to Tcl_RegExpExec.  This compiled form
1386  *      is only valid up until the next call to this procedure, so
1387  *      don't keep these around for a long time!  If an error occurred
1388  *      while compiling the pattern, then NULL is returned and an error
1389  *      message is left in interp->result.
1390  *
1391  * Side effects:
1392  *      The cache of compiled regexp's in interp will be modified to
1393  *      hold information for string, if such information isn't already
1394  *      present in the cache.
1395  *
1396  *----------------------------------------------------------------------
1397  */
1398
1399 Tcl_RegExp
1400 Tcl_RegExpCompile(interp, string)
1401     Tcl_Interp *interp;                 /* For use in error reporting. */
1402     char *string;                       /* String for which to produce
1403                                          * compiled regular expression. */
1404 {
1405     register Interp *iPtr = (Interp *) interp;
1406     int i, length;
1407     regexp *result;
1408
1409     length = strlen(string);
1410     for (i = 0; i < NUM_REGEXPS; i++) {
1411         if ((length == iPtr->patLengths[i])
1412                 && (strcmp(string, iPtr->patterns[i]) == 0)) {
1413             /*
1414              * Move the matched pattern to the first slot in the
1415              * cache and shift the other patterns down one position.
1416              */
1417
1418             if (i != 0) {
1419                 int j;
1420                 char *cachedString;
1421
1422                 cachedString = iPtr->patterns[i];
1423                 result = iPtr->regexps[i];
1424                 for (j = i-1; j >= 0; j--) {
1425                     iPtr->patterns[j+1] = iPtr->patterns[j];
1426                     iPtr->patLengths[j+1] = iPtr->patLengths[j];
1427                     iPtr->regexps[j+1] = iPtr->regexps[j];
1428                 }
1429                 iPtr->patterns[0] = cachedString;
1430                 iPtr->patLengths[0] = length;
1431                 iPtr->regexps[0] = result;
1432             }
1433             return (Tcl_RegExp) iPtr->regexps[0];
1434         }
1435     }
1436
1437     /*
1438      * No match in the cache.  Compile the string and add it to the
1439      * cache.
1440      */
1441
1442     TclRegError((char *) NULL);
1443     result = TclRegComp(string);
1444     if (TclGetRegError() != NULL) {
1445         Tcl_AppendResult(interp,
1446             "couldn't compile regular expression pattern: ",
1447             TclGetRegError(), (char *) NULL);
1448         return NULL;
1449     }
1450     if (iPtr->patterns[NUM_REGEXPS-1] != NULL) {
1451         ckfree(iPtr->patterns[NUM_REGEXPS-1]);
1452         ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]);
1453     }
1454     for (i = NUM_REGEXPS - 2; i >= 0; i--) {
1455         iPtr->patterns[i+1] = iPtr->patterns[i];
1456         iPtr->patLengths[i+1] = iPtr->patLengths[i];
1457         iPtr->regexps[i+1] = iPtr->regexps[i];
1458     }
1459     iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1));
1460     strcpy(iPtr->patterns[0], string);
1461     iPtr->patLengths[0] = length;
1462     iPtr->regexps[0] = result;
1463     return (Tcl_RegExp) result;
1464 }
1465 \f
1466 /*
1467  *----------------------------------------------------------------------
1468  *
1469  * Tcl_RegExpExec --
1470  *
1471  *      Execute the regular expression matcher using a compiled form
1472  *      of a regular expression and save information about any match
1473  *      that is found.
1474  *
1475  * Results:
1476  *      If an error occurs during the matching operation then -1
1477  *      is returned and interp->result contains an error message.
1478  *      Otherwise the return value is 1 if a matching range is
1479  *      found and 0 if there is no matching range.
1480  *
1481  * Side effects:
1482  *      None.
1483  *
1484  *----------------------------------------------------------------------
1485  */
1486
1487 int
1488 Tcl_RegExpExec(interp, re, string, start)
1489     Tcl_Interp *interp;         /* Interpreter to use for error reporting. */
1490     Tcl_RegExp re;              /* Compiled regular expression;  must have
1491                                  * been returned by previous call to
1492                                  * Tcl_RegExpCompile. */
1493     char *string;               /* String against which to match re. */
1494     char *start;                /* If string is part of a larger string,
1495                                  * this identifies beginning of larger
1496                                  * string, so that "^" won't match. */
1497 {
1498     int match;
1499
1500     regexp *regexpPtr = (regexp *) re;
1501     TclRegError((char *) NULL);
1502     match = TclRegExec(regexpPtr, string, start);
1503     if (TclGetRegError() != NULL) {
1504         Tcl_ResetResult(interp);
1505         Tcl_AppendResult(interp, "error while matching regular expression: ",
1506                 TclGetRegError(), (char *) NULL);
1507         return -1;
1508     }
1509     return match;
1510 }
1511 \f
1512 /*
1513  *----------------------------------------------------------------------
1514  *
1515  * Tcl_RegExpRange --
1516  *
1517  *      Returns pointers describing the range of a regular expression match,
1518  *      or one of the subranges within the match.
1519  *
1520  * Results:
1521  *      The variables at *startPtr and *endPtr are modified to hold the
1522  *      addresses of the endpoints of the range given by index.  If the
1523  *      specified range doesn't exist then NULLs are returned.
1524  *
1525  * Side effects:
1526  *      None.
1527  *
1528  *----------------------------------------------------------------------
1529  */
1530
1531 void
1532 Tcl_RegExpRange(re, index, startPtr, endPtr)
1533     Tcl_RegExp re;              /* Compiled regular expression that has
1534                                  * been passed to Tcl_RegExpExec. */
1535     int index;                  /* 0 means give the range of the entire
1536                                  * match, > 0 means give the range of
1537                                  * a matching subrange.  Must be no greater
1538                                  * than NSUBEXP. */
1539     char **startPtr;            /* Store address of first character in
1540                                  * (sub-) range here. */
1541     char **endPtr;              /* Store address of character just after last
1542                                  * in (sub-) range here. */
1543 {
1544     regexp *regexpPtr = (regexp *) re;
1545
1546     if (index >= NSUBEXP) {
1547         *startPtr = *endPtr = NULL;
1548     } else {
1549         *startPtr = regexpPtr->startp[index];
1550         *endPtr = regexpPtr->endp[index];
1551     }
1552 }
1553 \f
1554 /*
1555  *----------------------------------------------------------------------
1556  *
1557  * Tcl_RegExpMatch --
1558  *
1559  *      See if a string matches a regular expression.
1560  *
1561  * Results:
1562  *      If an error occurs during the matching operation then -1
1563  *      is returned and interp->result contains an error message.
1564  *      Otherwise the return value is 1 if "string" matches "pattern"
1565  *      and 0 otherwise.
1566  *
1567  * Side effects:
1568  *      None.
1569  *
1570  *----------------------------------------------------------------------
1571  */
1572
1573 int
1574 Tcl_RegExpMatch(interp, string, pattern)
1575     Tcl_Interp *interp;         /* Used for error reporting. */
1576     char *string;               /* String. */
1577     char *pattern;              /* Regular expression to match against
1578                                  * string. */
1579 {
1580     Tcl_RegExp re;
1581
1582     re = Tcl_RegExpCompile(interp, pattern);
1583     if (re == NULL) {
1584         return -1;
1585     }
1586     return Tcl_RegExpExec(interp, re, string, string);
1587 }
1588 \f
1589 /*
1590  *----------------------------------------------------------------------
1591  *
1592  * Tcl_DStringInit --
1593  *
1594  *      Initializes a dynamic string, discarding any previous contents
1595  *      of the string (Tcl_DStringFree should have been called already
1596  *      if the dynamic string was previously in use).
1597  *
1598  * Results:
1599  *      None.
1600  *
1601  * Side effects:
1602  *      The dynamic string is initialized to be empty.
1603  *
1604  *----------------------------------------------------------------------
1605  */
1606
1607 void
1608 Tcl_DStringInit(dsPtr)
1609     register Tcl_DString *dsPtr;        /* Pointer to structure for
1610                                          * dynamic string. */
1611 {
1612     dsPtr->string = dsPtr->staticSpace;
1613     dsPtr->length = 0;
1614     dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
1615     dsPtr->staticSpace[0] = 0;
1616 }
1617 \f
1618 /*
1619  *----------------------------------------------------------------------
1620  *
1621  * Tcl_DStringAppend --
1622  *
1623  *      Append more characters to the current value of a dynamic string.
1624  *
1625  * Results:
1626  *      The return value is a pointer to the dynamic string's new value.
1627  *
1628  * Side effects:
1629  *      Length bytes from string (or all of string if length is less
1630  *      than zero) are added to the current value of the string.  Memory
1631  *      gets reallocated if needed to accomodate the string's new size.
1632  *
1633  *----------------------------------------------------------------------
1634  */
1635
1636 char *
1637 Tcl_DStringAppend(dsPtr, string, length)
1638     register Tcl_DString *dsPtr;        /* Structure describing dynamic
1639                                          * string. */
1640     char *string;                       /* String to append.  If length is
1641                                          * -1 then this must be
1642                                          * null-terminated. */
1643     int length;                         /* Number of characters from string
1644                                          * to append.  If < 0, then append all
1645                                          * of string, up to null at end. */
1646 {
1647     int newSize;
1648     char *newString, *dst, *end;
1649
1650     if (length < 0) {
1651         length = strlen(string);
1652     }
1653     newSize = length + dsPtr->length;
1654
1655     /*
1656      * Allocate a larger buffer for the string if the current one isn't
1657      * large enough.  Allocate extra space in the new buffer so that there
1658      * will be room to grow before we have to allocate again.
1659      */
1660
1661     if (newSize >= dsPtr->spaceAvl) {
1662         dsPtr->spaceAvl = newSize*2;
1663         newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
1664         memcpy((VOID *)newString, (VOID *) dsPtr->string,
1665                 (size_t) dsPtr->length);
1666         if (dsPtr->string != dsPtr->staticSpace) {
1667             ckfree(dsPtr->string);
1668         }
1669         dsPtr->string = newString;
1670     }
1671
1672     /*
1673      * Copy the new string into the buffer at the end of the old
1674      * one.
1675      */
1676
1677     for (dst = dsPtr->string + dsPtr->length, end = string+length;
1678             string < end; string++, dst++) {
1679         *dst = *string;
1680     }
1681     *dst = 0;
1682     dsPtr->length += length;
1683     return dsPtr->string;
1684 }
1685 \f
1686 /*
1687  *----------------------------------------------------------------------
1688  *
1689  * Tcl_DStringAppendElement --
1690  *
1691  *      Append a list element to the current value of a dynamic string.
1692  *
1693  * Results:
1694  *      The return value is a pointer to the dynamic string's new value.
1695  *
1696  * Side effects:
1697  *      String is reformatted as a list element and added to the current
1698  *      value of the string.  Memory gets reallocated if needed to
1699  *      accomodate the string's new size.
1700  *
1701  *----------------------------------------------------------------------
1702  */
1703
1704 char *
1705 Tcl_DStringAppendElement(dsPtr, string)
1706     register Tcl_DString *dsPtr;        /* Structure describing dynamic
1707                                          * string. */
1708     char *string;                       /* String to append.  Must be
1709                                          * null-terminated. */
1710 {
1711     int newSize, flags;
1712     char *dst, *newString;
1713
1714     newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1;
1715
1716     /*
1717      * Allocate a larger buffer for the string if the current one isn't
1718      * large enough.  Allocate extra space in the new buffer so that there
1719      * will be room to grow before we have to allocate again.
1720      * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string
1721      * to a larger buffer, since there may be embedded NULLs in the
1722      * string in some cases.
1723      */
1724
1725     if (newSize >= dsPtr->spaceAvl) {
1726         dsPtr->spaceAvl = newSize*2;
1727         newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
1728         memcpy((VOID *) newString, (VOID *) dsPtr->string,
1729                 (size_t) dsPtr->length);
1730         if (dsPtr->string != dsPtr->staticSpace) {
1731             ckfree(dsPtr->string);
1732         }
1733         dsPtr->string = newString;
1734     }
1735
1736     /*
1737      * Convert the new string to a list element and copy it into the
1738      * buffer at the end, with a space, if needed.
1739      */
1740
1741     dst = dsPtr->string + dsPtr->length;
1742     if (TclNeedSpace(dsPtr->string, dst)) {
1743         *dst = ' ';
1744         dst++;
1745         dsPtr->length++;
1746     }
1747     dsPtr->length += Tcl_ConvertElement(string, dst, flags);
1748     return dsPtr->string;
1749 }
1750 \f
1751 /*
1752  *----------------------------------------------------------------------
1753  *
1754  * Tcl_DStringSetLength --
1755  *
1756  *      Change the length of a dynamic string.  This can cause the
1757  *      string to either grow or shrink, depending on the value of
1758  *      length.
1759  *
1760  * Results:
1761  *      None.
1762  *
1763  * Side effects:
1764  *      The length of dsPtr is changed to length and a null byte is
1765  *      stored at that position in the string.  If length is larger
1766  *      than the space allocated for dsPtr, then a panic occurs.
1767  *
1768  *----------------------------------------------------------------------
1769  */
1770
1771 void
1772 Tcl_DStringSetLength(dsPtr, length)
1773     register Tcl_DString *dsPtr;        /* Structure describing dynamic
1774                                          * string. */
1775     int length;                         /* New length for dynamic string. */
1776 {
1777     if (length < 0) {
1778         length = 0;
1779     }
1780     if (length >= dsPtr->spaceAvl) {
1781         char *newString;
1782
1783         dsPtr->spaceAvl = length+1;
1784         newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl);
1785
1786         /*
1787          * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string
1788          * to a larger buffer, since there may be embedded NULLs in the
1789          * string in some cases.
1790          */
1791
1792         memcpy((VOID *) newString, (VOID *) dsPtr->string,
1793                 (size_t) dsPtr->length);
1794         if (dsPtr->string != dsPtr->staticSpace) {
1795             ckfree(dsPtr->string);
1796         }
1797         dsPtr->string = newString;
1798     }
1799     dsPtr->length = length;
1800     dsPtr->string[length] = 0;
1801 }
1802 \f
1803 /*
1804  *----------------------------------------------------------------------
1805  *
1806  * Tcl_DStringFree --
1807  *
1808  *      Frees up any memory allocated for the dynamic string and
1809  *      reinitializes the string to an empty state.
1810  *
1811  * Results:
1812  *      None.
1813  *
1814  * Side effects:
1815  *      The previous contents of the dynamic string are lost, and
1816  *      the new value is an empty string.
1817  *
1818  *----------------------------------------------------------------------
1819  */
1820
1821 void
1822 Tcl_DStringFree(dsPtr)
1823     register Tcl_DString *dsPtr;        /* Structure describing dynamic
1824                                          * string. */
1825 {
1826     if (dsPtr->string != dsPtr->staticSpace) {
1827         ckfree(dsPtr->string);
1828     }
1829     dsPtr->string = dsPtr->staticSpace;
1830     dsPtr->length = 0;
1831     dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
1832     dsPtr->staticSpace[0] = 0;
1833 }
1834 \f
1835 /*
1836  *----------------------------------------------------------------------
1837  *
1838  * Tcl_DStringResult --
1839  *
1840  *      This procedure moves the value of a dynamic string into an
1841  *      interpreter as its result.  The string itself is reinitialized
1842  *      to an empty string.
1843  *
1844  * Results:
1845  *      None.
1846  *
1847  * Side effects:
1848  *      The string is "moved" to interp's result, and any existing
1849  *      result for interp is freed up.  DsPtr is reinitialized to
1850  *      an empty string.
1851  *
1852  *----------------------------------------------------------------------
1853  */
1854
1855 void
1856 Tcl_DStringResult(interp, dsPtr)
1857     Tcl_Interp *interp;                 /* Interpreter whose result is to be
1858                                          * reset. */
1859     Tcl_DString *dsPtr;                 /* Dynamic string that is to become
1860                                          * the result of interp. */
1861 {
1862     Tcl_ResetResult(interp);
1863     if (dsPtr->string != dsPtr->staticSpace) {
1864         interp->result = dsPtr->string;
1865         interp->freeProc = TCL_DYNAMIC;
1866     } else if (dsPtr->length < TCL_RESULT_SIZE) {
1867         interp->result = ((Interp *) interp)->resultSpace;
1868         strcpy(interp->result, dsPtr->string);
1869     } else {
1870         Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE);
1871     }
1872     dsPtr->string = dsPtr->staticSpace;
1873     dsPtr->length = 0;
1874     dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
1875     dsPtr->staticSpace[0] = 0;
1876 }
1877 \f
1878 /*
1879  *----------------------------------------------------------------------
1880  *
1881  * Tcl_DStringGetResult --
1882  *
1883  *      This procedure moves the result of an interpreter into a
1884  *      dynamic string.
1885  *
1886  * Results:
1887  *      None.
1888  *
1889  * Side effects:
1890  *      The interpreter's result is cleared, and the previous contents
1891  *      of dsPtr are freed.
1892  *
1893  *----------------------------------------------------------------------
1894  */
1895
1896 void
1897 Tcl_DStringGetResult(interp, dsPtr)
1898     Tcl_Interp *interp;                 /* Interpreter whose result is to be
1899                                          * reset. */
1900     Tcl_DString *dsPtr;                 /* Dynamic string that is to become
1901                                          * the result of interp. */
1902 {
1903     Interp *iPtr = (Interp *) interp;
1904     if (dsPtr->string != dsPtr->staticSpace) {
1905         ckfree(dsPtr->string);
1906     }
1907     dsPtr->length = strlen(iPtr->result);
1908     if (iPtr->freeProc != NULL) {
1909         if ((iPtr->freeProc == TCL_DYNAMIC)
1910                 || (iPtr->freeProc == (Tcl_FreeProc *) free)) {
1911             dsPtr->string = iPtr->result;
1912             dsPtr->spaceAvl = dsPtr->length+1;
1913         } else {
1914             dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length+1));
1915             strcpy(dsPtr->string, iPtr->result);
1916             (*iPtr->freeProc)(iPtr->result);
1917         }
1918         dsPtr->spaceAvl = dsPtr->length+1;
1919         iPtr->freeProc = NULL;
1920     } else {
1921         if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) {
1922             dsPtr->string = dsPtr->staticSpace;
1923             dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
1924         } else {
1925             dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1));
1926             dsPtr->spaceAvl = dsPtr->length + 1;
1927         }
1928         strcpy(dsPtr->string, iPtr->result);
1929     }
1930     iPtr->result = iPtr->resultSpace;
1931     iPtr->resultSpace[0] = 0;
1932 }
1933 \f
1934 /*
1935  *----------------------------------------------------------------------
1936  *
1937  * Tcl_DStringStartSublist --
1938  *
1939  *      This procedure adds the necessary information to a dynamic
1940  *      string (e.g. " {" to start a sublist.  Future element
1941  *      appends will be in the sublist rather than the main list.
1942  *
1943  * Results:
1944  *      None.
1945  *
1946  * Side effects:
1947  *      Characters get added to the dynamic string.
1948  *
1949  *----------------------------------------------------------------------
1950  */
1951
1952 void
1953 Tcl_DStringStartSublist(dsPtr)
1954     Tcl_DString *dsPtr;                 /* Dynamic string. */
1955 {
1956     if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) {
1957         Tcl_DStringAppend(dsPtr, " {", -1);
1958     } else {
1959         Tcl_DStringAppend(dsPtr, "{", -1);
1960     }
1961 }
1962 \f
1963 /*
1964  *----------------------------------------------------------------------
1965  *
1966  * Tcl_DStringEndSublist --
1967  *
1968  *      This procedure adds the necessary characters to a dynamic
1969  *      string to end a sublist (e.g. "}").  Future element appends
1970  *      will be in the enclosing (sub)list rather than the current
1971  *      sublist.
1972  *
1973  * Results:
1974  *      None.
1975  *
1976  * Side effects:
1977  *      None.
1978  *
1979  *----------------------------------------------------------------------
1980  */
1981
1982 void
1983 Tcl_DStringEndSublist(dsPtr)
1984     Tcl_DString *dsPtr;                 /* Dynamic string. */
1985 {
1986     Tcl_DStringAppend(dsPtr, "}", -1);
1987 }
1988 \f
1989 /*
1990  *----------------------------------------------------------------------
1991  *
1992  * Tcl_PrintDouble --
1993  *
1994  *      Given a floating-point value, this procedure converts it to
1995  *      an ASCII string using.
1996  *
1997  * Results:
1998  *      The ASCII equivalent of "value" is written at "dst".  It is
1999  *      written using the current precision, and it is guaranteed to
2000  *      contain a decimal point or exponent, so that it looks like
2001  *      a floating-point value and not an integer.
2002  *
2003  * Side effects:
2004  *      None.
2005  *
2006  *----------------------------------------------------------------------
2007  */
2008
2009 void
2010 Tcl_PrintDouble(interp, value, dst)
2011     Tcl_Interp *interp;                 /* Interpreter whose tcl_precision
2012                                          * variable controls printing. */
2013     double value;                       /* Value to print as string. */
2014     char *dst;                          /* Where to store converted value;
2015                                          * must have at least TCL_DOUBLE_SPACE
2016                                          * characters. */
2017 {
2018     register char *p;
2019     sprintf(dst, ((Interp *) interp)->pdFormat, value);
2020
2021     /*
2022      * If the ASCII result looks like an integer, add ".0" so that it
2023      * doesn't look like an integer anymore.  This prevents floating-point
2024      * values from being converted to integers unintentionally.
2025      */
2026
2027     for (p = dst; *p != 0; p++) {
2028         if ((*p == '.') || (isalpha(UCHAR(*p)))) {
2029             return;
2030         }
2031     }
2032     p[0] = '.';
2033     p[1] = '0';
2034     p[2] = 0;
2035 }
2036 \f
2037 /*
2038  *----------------------------------------------------------------------
2039  *
2040  * TclPrecTraceProc --
2041  *
2042  *      This procedure is invoked whenever the variable "tcl_precision"
2043  *      is written.
2044  *
2045  * Results:
2046  *      Returns NULL if all went well, or an error message if the
2047  *      new value for the variable doesn't make sense.
2048  *
2049  * Side effects:
2050  *      If the new value doesn't make sense then this procedure
2051  *      undoes the effect of the variable modification.  Otherwise
2052  *      it modifies the format string that's used by Tcl_PrintDouble.
2053  *
2054  *----------------------------------------------------------------------
2055  */
2056
2057         /* ARGSUSED */
2058 char *
2059 TclPrecTraceProc(clientData, interp, name1, name2, flags)
2060     ClientData clientData;      /* Not used. */
2061     Tcl_Interp *interp;         /* Interpreter containing variable. */
2062     char *name1;                /* Name of variable. */
2063     char *name2;                /* Second part of variable name. */
2064     int flags;                  /* Information about what happened. */
2065 {
2066     register Interp *iPtr = (Interp *) interp;
2067     char *value, *end;
2068     int prec;
2069
2070     /*
2071      * If the variable is unset, then recreate the trace and restore
2072      * the default value of the format string.
2073      */
2074
2075     if (flags & TCL_TRACE_UNSETS) {
2076         if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) {
2077             Tcl_TraceVar2(interp, name1, name2,
2078                     TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
2079                     TclPrecTraceProc, clientData);
2080         }
2081         strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT);
2082         iPtr->pdPrec = DEFAULT_PD_PREC;
2083         return (char *) NULL;
2084     }
2085
2086     value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
2087     if (value == NULL) {
2088         value = "";
2089     }
2090     prec = strtoul(value, &end, 10);
2091     if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) ||
2092             (end == value) || (*end != 0)) {
2093         char oldValue[10];
2094
2095         sprintf(oldValue, "%d", iPtr->pdPrec);
2096         Tcl_SetVar2(interp, name1, name2, oldValue, flags & TCL_GLOBAL_ONLY);
2097         return "improper value for precision";
2098     }
2099     sprintf(iPtr->pdFormat, "%%.%dg", prec);
2100     iPtr->pdPrec = prec;
2101     return (char *) NULL;
2102 }
2103 \f
2104 /*
2105  *----------------------------------------------------------------------
2106  *
2107  * TclNeedSpace --
2108  *
2109  *      This procedure checks to see whether it is appropriate to
2110  *      add a space before appending a new list element to an
2111  *      existing string.
2112  *
2113  * Results:
2114  *      The return value is 1 if a space is appropriate, 0 otherwise.
2115  *
2116  * Side effects:
2117  *      None.
2118  *
2119  *----------------------------------------------------------------------
2120  */
2121
2122 int
2123 TclNeedSpace(start, end)
2124     char *start;                /* First character in string. */
2125     char *end;                  /* End of string (place where space will
2126                                  * be added, if appropriate). */
2127 {
2128     /*
2129      * A space is needed unless either
2130      * (a) we're at the start of the string, or
2131      * (b) the trailing characters of the string consist of one or more
2132      *     open curly braces preceded by a space or extending back to
2133      *     the beginning of the string.
2134      * (c) the trailing characters of the string consist of a space
2135      *     preceded by a character other than backslash.
2136      */
2137
2138     if (end == start) {
2139         return 0;
2140     }
2141     end--;
2142     if (*end != '{') {
2143         if (isspace(UCHAR(*end)) && ((end == start) || (end[-1] != '\\'))) {
2144             return 0;
2145         }
2146         return 1;
2147     }
2148     do {
2149         if (end == start) {
2150             return 0;
2151         }
2152         end--;
2153     } while (*end == '{');
2154     if (isspace(UCHAR(*end))) {
2155         return 0;
2156     }
2157     return 1;
2158 }