cvs.zerfleddert.de Git - micropolis/blob - src/tcl/tclcmdmz.c

   1 /*
   2  * tclCmdMZ.c --
   3  *
   4  *      This file contains the top-level command routines for most of
   5  *      the Tcl built-in commands whose names begin with the letters
   6  *      M to Z.  It contains only commands in the generic core (i.e.
   7  *      those that don't depend much upon UNIX facilities).
   8  *
   9  * Copyright 1987-1991 Regents of the University of California
  10  * Permission to use, copy, modify, and distribute this
  11  * software and its documentation for any purpose and without
  12  * fee is hereby granted, provided that the above copyright
  13  * notice appear in all copies.  The University of California
  14  * makes no representations about the suitability of this
  15  * software for any purpose.  It is provided "as is" without
  16  * express or implied warranty.
  17  */
  18
  19 #ifndef lint
  20 static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdMZ.c,v 1.13 92/04/23 11:07:54 ouster Exp $ SPRITE (Berkeley)";
  21 #endif
  22
  23 #include "tclint.h"
  24
  25 /*
  26  * Structure used to hold information about variable traces:
  27  */
  28
  29 typedef struct {
  30     int flags;                  /* Operations for which Tcl command is
  31                                  * to be invoked. */
  32     int length;                 /* Number of non-NULL chars. in command. */
  33     char command[4];            /* Space for Tcl command to invoke.  Actual
  34                                  * size will be as large as necessary to
  35                                  * hold command.  This field must be the
  36                                  * last in the structure, so that it can
  37                                  * be larger than 4 bytes. */
  38 } TraceVarInfo;
  39
  40 /*
  41  * Forward declarations for procedures defined in this file:
  42  */
  43
  44 static char *           TraceVarProc _ANSI_ARGS_((ClientData clientData,
  45                             Tcl_Interp *interp, char *name1, char *name2,
  46                             int flags));
  47 \f
  48 /*
  49  *----------------------------------------------------------------------
  50  *
  51  * Tcl_RegexpCmd --
  52  *
  53  *      This procedure is invoked to process the "regexp" Tcl command.
  54  *      See the user documentation for details on what it does.
  55  *
  56  * Results:
  57  *      A standard Tcl result.
  58  *
  59  * Side effects:
  60  *      See the user documentation.
  61  *
  62  *----------------------------------------------------------------------
  63  */
  64
  65         /* ARGSUSED */
  66 int
  67 Tcl_RegexpCmd(dummy, interp, argc, argv)
  68     ClientData dummy;                   /* Not used. */
  69     Tcl_Interp *interp;                 /* Current interpreter. */
  70     int argc;                           /* Number of arguments. */
  71     char **argv;                        /* Argument strings. */
  72 {
  73     int noCase = 0;
  74     int indices = 0;
  75     regexp *regexpPtr;
  76     char **argPtr, *string;
  77     int match, i;
  78
  79     if (argc < 3) {
  80         wrongNumArgs:
  81         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  82                 " ?-nocase? exp string ?matchVar? ?subMatchVar ",
  83                 "subMatchVar ...?\"", (char *) NULL);
  84         return TCL_ERROR;
  85     }
  86     argPtr = argv+1;
  87     argc--;
  88     while ((argc > 0) && (argPtr[0][0] == '-')) {
  89         if (strcmp(argPtr[0], "-indices") == 0) {
  90             argPtr++;
  91             argc--;
  92             indices = 1;
  93         } else if (strcmp(argPtr[0], "-nocase") == 0) {
  94             argPtr++;
  95             argc--;
  96             noCase = 1;
  97         } else {
  98             break;
  99         }
 100     }
 101     if (argc < 2) {
 102         goto wrongNumArgs;
 103     }
 104     regexpPtr = TclCompileRegexp(interp, argPtr[0]);
 105     if (regexpPtr == NULL) {
 106         return TCL_ERROR;
 107     }
 108
 109     /*
 110      * Convert the string to lower case, if desired, and perform
 111      * the match.
 112      */
 113
 114     if (noCase) {
 115         register char *dst, *src;
 116
 117         string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
 118         for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
 119             if (isupper(*src)) {
 120                 *dst = tolower(*src);
 121             } else {
 122                 *dst = *src;
 123             }
 124         }
 125         *dst = 0;
 126     } else {
 127         string = argPtr[1];
 128     }
 129     tclRegexpError = NULL;
 130     match = regexec(regexpPtr, string);
 131     if (string != argPtr[1]) {
 132         ckfree(string);
 133     }
 134     if (tclRegexpError != NULL) {
 135         Tcl_AppendResult(interp, "error while matching pattern: ",
 136                 tclRegexpError, (char *) NULL);
 137         return TCL_ERROR;
 138     }
 139     if (!match) {
 140         interp->result = "0";
 141         return TCL_OK;
 142     }
 143
 144     /*
 145      * If additional variable names have been specified, return
 146      * index information in those variables.
 147      */
 148
 149     argc -= 2;
 150     if (argc > NSUBEXP) {
 151         interp->result = "too many substring variables";
 152         return TCL_ERROR;
 153     }
 154     for (i = 0; i < argc; i++) {
 155         char *result, info[50];
 156
 157         if (regexpPtr->startp[i] == NULL) {
 158             if (indices) {
 159                 result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0);
 160             } else {
 161                 result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
 162             }
 163         } else {
 164             if (indices) {
 165                 sprintf(info, "%d %d", regexpPtr->startp[i] - string,
 166                         regexpPtr->endp[i] - string - 1);
 167                 result = Tcl_SetVar(interp, argPtr[i+2], info, 0);
 168             } else {
 169                 char savedChar, *first, *last;
 170
 171                 first = argPtr[1] + (regexpPtr->startp[i] - string);
 172                 last = argPtr[1] + (regexpPtr->endp[i] - string);
 173                 savedChar = *last;
 174                 *last = 0;
 175                 result = Tcl_SetVar(interp, argPtr[i+2], first, 0);
 176                 *last = savedChar;
 177             }
 178         }
 179         if (result == NULL) {
 180             Tcl_AppendResult(interp, "couldn't set variable \"",
 181                     argPtr[i+2], "\"", (char *) NULL);
 182             return TCL_ERROR;
 183         }
 184     }
 185     interp->result = "1";
 186     return TCL_OK;
 187 }
 188 \f
 189 /*
 190  *----------------------------------------------------------------------
 191  *
 192  * Tcl_RegsubCmd --
 193  *
 194  *      This procedure is invoked to process the "regsub" Tcl command.
 195  *      See the user documentation for details on what it does.
 196  *
 197  * Results:
 198  *      A standard Tcl result.
 199  *
 200  * Side effects:
 201  *      See the user documentation.
 202  *
 203  *----------------------------------------------------------------------
 204  */
 205
 206         /* ARGSUSED */
 207 int
 208 Tcl_RegsubCmd(dummy, interp, argc, argv)
 209     ClientData dummy;                   /* Not used. */
 210     Tcl_Interp *interp;                 /* Current interpreter. */
 211     int argc;                           /* Number of arguments. */
 212     char **argv;                        /* Argument strings. */
 213 {
 214     int noCase = 0, all = 0;
 215     regexp *regexpPtr;
 216     char *string, *p, *firstChar, *newValue, **argPtr;
 217     int match, result, flags;
 218     register char *src, c;
 219
 220     if (argc < 5) {
 221         wrongNumArgs:
 222         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 223                 " ?-nocase? ?-all? exp string subSpec varName\"", (char *) NULL);
 224         return TCL_ERROR;
 225     }
 226     argPtr = argv+1;
 227     argc--;
 228     while (argPtr[0][0] == '-') {
 229         if (strcmp(argPtr[0], "-nocase") == 0) {
 230             argPtr++;
 231             argc--;
 232             noCase = 1;
 233         } else if (strcmp(argPtr[0], "-all") == 0) {
 234             argPtr++;
 235             argc--;
 236             all = 1;
 237         } else {
 238             break;
 239         }
 240     }
 241     if (argc != 4) {
 242         goto wrongNumArgs;
 243     }
 244     regexpPtr = TclCompileRegexp(interp, argPtr[0]);
 245     if (regexpPtr == NULL) {
 246         return TCL_ERROR;
 247     }
 248
 249     /*
 250      * Convert the string to lower case, if desired.
 251      */
 252
 253     if (noCase) {
 254         register char *dst;
 255
 256         string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
 257         for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
 258             if (isupper(*src)) {
 259                 *dst = tolower(*src);
 260             } else {
 261                 *dst = *src;
 262             }
 263         }
 264         *dst = 0;
 265     } else {
 266         string = argPtr[1];
 267     }
 268
 269     /*
 270      * The following loop is to handle multiple matches within the
 271      * same source string;  each iteration handles one match and its
 272      * corresponding substitution.  If "-all" hasn't been specified
 273      * then the loop body only gets executed once.
 274      */
 275
 276     flags = 0;
 277     for (p = string; *p != 0; ) {
 278         tclRegexpError = NULL;
 279         match = regexec(regexpPtr, p);
 280         if (tclRegexpError != NULL) {
 281             Tcl_AppendResult(interp, "error while matching pattern: ",
 282                     tclRegexpError, (char *) NULL);
 283             result = TCL_ERROR;
 284             goto done;
 285         }
 286         if (!match) {
 287             break;
 288         }
 289
 290         /*
 291          * Copy the portion of the source string before the match to the
 292          * result variable.
 293          */
 294
 295         src = argPtr[1] + (regexpPtr->startp[0] - string);
 296         c = *src;
 297         *src = 0;
 298         newValue = Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string),
 299                 flags);
 300         *src = c;
 301         flags = TCL_APPEND_VALUE;
 302         if (newValue == NULL) {
 303             cantSet:
 304             Tcl_AppendResult(interp, "couldn't set variable \"",
 305                     argPtr[3], "\"", (char *) NULL);
 306             result = TCL_ERROR;
 307             goto done;
 308         }
 309
 310         /*
 311          * Append the subSpec argument to the variable, making appropriate
 312          * substitutions.  This code is a bit hairy because of the backslash
 313          * conventions and because the code saves up ranges of characters in
 314          * subSpec to reduce the number of calls to Tcl_SetVar.
 315          */
 316
 317         for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) {
 318             int index;
 319
 320             if (c == '&') {
 321                 index = 0;
 322             } else if (c == '\\') {
 323                 c = src[1];
 324                 if ((c >= '0') && (c <= '9')) {
 325                     index = c - '0';
 326                 } else if ((c == '\\') || (c == '&')) {
 327                     *src = c;
 328                     src[1] = 0;
 329                     newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
 330                             TCL_APPEND_VALUE);
 331                     *src = '\\';
 332                     src[1] = c;
 333                     if (newValue == NULL) {
 334                         goto cantSet;
 335                     }
 336                     firstChar = src+2;
 337                     src++;
 338                     continue;
 339                 } else {
 340                     continue;
 341                 }
 342             } else {
 343                 continue;
 344             }
 345             if (firstChar != src) {
 346                 c = *src;
 347                 *src = 0;
 348                 newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
 349                         TCL_APPEND_VALUE);
 350                 *src = c;
 351                 if (newValue == NULL) {
 352                     goto cantSet;
 353                 }
 354             }
 355             if ((index < NSUBEXP) && (regexpPtr->startp[index] != NULL)
 356                     && (regexpPtr->endp[index] != NULL)) {
 357                 char *first, *last, saved;
 358
 359                 first = argPtr[1] + (regexpPtr->startp[index] - string);
 360                 last = argPtr[1] + (regexpPtr->endp[index] - string);
 361                 saved = *last;
 362                 *last = 0;
 363                 newValue = Tcl_SetVar(interp, argPtr[3], first,
 364                         TCL_APPEND_VALUE);
 365                 *last = saved;
 366                 if (newValue == NULL) {
 367                     goto cantSet;
 368                 }
 369             }
 370             if (*src == '\\') {
 371                 src++;
 372             }
 373             firstChar = src+1;
 374         }
 375         if (firstChar != src) {
 376             if (Tcl_SetVar(interp, argPtr[3], firstChar,
 377                     TCL_APPEND_VALUE) == NULL) {
 378                 goto cantSet;
 379             }
 380         }
 381         p = regexpPtr->endp[0];
 382         if (!all) {
 383             break;
 384         }
 385     }
 386
 387     /*
 388      * If there were no matches at all, then return a "0" result.
 389      */
 390
 391     if (p == string) {
 392         interp->result = "0";
 393         result = TCL_OK;
 394         goto done;
 395     }
 396
 397     /*
 398      * Copy the portion of the source string after the last match to the
 399      * result variable.
 400      */
 401
 402     if (*p != 0) {
 403         if (Tcl_SetVar(interp, argPtr[3], p, TCL_APPEND_VALUE) == NULL) {
 404             goto cantSet;
 405         }
 406     }
 407     interp->result = "1";
 408     result = TCL_OK;
 409
 410     done:
 411     if (string != argPtr[1]) {
 412         ckfree(string);
 413     }
 414     return result;
 415 }
 416 \f
 417 /*
 418  *----------------------------------------------------------------------
 419  *
 420  * Tcl_RenameCmd --
 421  *
 422  *      This procedure is invoked to process the "rename" Tcl command.
 423  *      See the user documentation for details on what it does.
 424  *
 425  * Results:
 426  *      A standard Tcl result.
 427  *
 428  * Side effects:
 429  *      See the user documentation.
 430  *
 431  *----------------------------------------------------------------------
 432  */
 433
 434         /* ARGSUSED */
 435 int
 436 Tcl_RenameCmd(dummy, interp, argc, argv)
 437     ClientData dummy;                   /* Not used. */
 438     Tcl_Interp *interp;                 /* Current interpreter. */
 439     int argc;                           /* Number of arguments. */
 440     char **argv;                        /* Argument strings. */
 441 {
 442     register Command *cmdPtr;
 443     Interp *iPtr = (Interp *) interp;
 444     Tcl_HashEntry *hPtr;
 445     int new;
 446
 447     if (argc != 3) {
 448         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 449                 " oldName newName\"", (char *) NULL);
 450         return TCL_ERROR;
 451     }
 452     if (argv[2][0] == '\0') {
 453         if (Tcl_DeleteCommand(interp, argv[1]) != 0) {
 454             Tcl_AppendResult(interp, "can't delete \"", argv[1],
 455                     "\": command doesn't exist", (char *) NULL);
 456             return TCL_ERROR;
 457         }
 458         return TCL_OK;
 459     }
 460     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[2]);
 461     if (hPtr != NULL) {
 462         Tcl_AppendResult(interp, "can't rename to \"", argv[2],
 463                 "\": command already exists", (char *) NULL);
 464         return TCL_ERROR;
 465     }
 466     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[1]);
 467     if (hPtr == NULL) {
 468         Tcl_AppendResult(interp, "can't rename \"", argv[1],
 469                 "\":  command doesn't exist", (char *) NULL);
 470         return TCL_ERROR;
 471     }
 472     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
 473     Tcl_DeleteHashEntry(hPtr);
 474     hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, argv[2], &new);
 475     Tcl_SetHashValue(hPtr, cmdPtr);
 476     return TCL_OK;
 477 }
 478 \f
 479 /*
 480  *----------------------------------------------------------------------
 481  *
 482  * Tcl_ReturnCmd --
 483  *
 484  *      This procedure is invoked to process the "return" Tcl command.
 485  *      See the user documentation for details on what it does.
 486  *
 487  * Results:
 488  *      A standard Tcl result.
 489  *
 490  * Side effects:
 491  *      See the user documentation.
 492  *
 493  *----------------------------------------------------------------------
 494  */
 495
 496         /* ARGSUSED */
 497 int
 498 Tcl_ReturnCmd(dummy, interp, argc, argv)
 499     ClientData dummy;                   /* Not used. */
 500     Tcl_Interp *interp;                 /* Current interpreter. */
 501     int argc;                           /* Number of arguments. */
 502     char **argv;                        /* Argument strings. */
 503 {
 504     if (argc > 2) {
 505         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 506                 " ?value?\"", (char *) NULL);
 507         return TCL_ERROR;
 508     }
 509     if (argc == 2) {
 510         Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
 511     }
 512     return TCL_RETURN;
 513 }
 514 \f
 515 /*
 516  *----------------------------------------------------------------------
 517  *
 518  * Tcl_ScanCmd --
 519  *
 520  *      This procedure is invoked to process the "scan" Tcl command.
 521  *      See the user documentation for details on what it does.
 522  *
 523  * Results:
 524  *      A standard Tcl result.
 525  *
 526  * Side effects:
 527  *      See the user documentation.
 528  *
 529  *----------------------------------------------------------------------
 530  */
 531
 532         /* ARGSUSED */
 533 int
 534 Tcl_ScanCmd(dummy, interp, argc, argv)
 535     ClientData dummy;                   /* Not used. */
 536     Tcl_Interp *interp;                 /* Current interpreter. */
 537     int argc;                           /* Number of arguments. */
 538     char **argv;                        /* Argument strings. */
 539 {
 540     int arg1Length;                     /* Number of bytes in argument to be
 541                                          * scanned.  This gives an upper limit
 542                                          * on string field sizes. */
 543 #   define MAX_FIELDS 20
 544     typedef struct {
 545         char fmt;                       /* Format for field. */
 546         int size;                       /* How many bytes to allow for
 547                                          * field. */
 548         char *location;                 /* Where field will be stored. */
 549     } Field;
 550     Field fields[MAX_FIELDS];           /* Info about all the fields in the
 551                                          * format string. */
 552     register Field *curField;
 553     int numFields = 0;                  /* Number of fields actually
 554                                          * specified. */
 555     int suppress;                       /* Current field is assignment-
 556                                          * suppressed. */
 557     int totalSize = 0;                  /* Number of bytes needed to store
 558                                          * all results combined. */
 559     char *results;                      /* Where scanned output goes.  */
 560     int numScanned;                     /* sscanf's result. */
 561     register char *fmt;
 562     int i, widthSpecified;
 563
 564     if (argc < 3) {
 565         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 566                 " string format ?varName varName ...?\"", (char *) NULL);
 567         return TCL_ERROR;
 568     }
 569
 570     /*
 571      * This procedure operates in four stages:
 572      * 1. Scan the format string, collecting information about each field.
 573      * 2. Allocate an array to hold all of the scanned fields.
 574      * 3. Call sscanf to do all the dirty work, and have it store the
 575      *    parsed fields in the array.
 576      * 4. Pick off the fields from the array and assign them to variables.
 577      */
 578
 579     arg1Length = (strlen(argv[1]) + 4) & ~03;
 580     for (fmt = argv[2]; *fmt != 0; fmt++) {
 581         if (*fmt != '%') {
 582             continue;
 583         }
 584         fmt++;
 585         if (*fmt == '*') {
 586             suppress = 1;
 587             fmt++;
 588         } else {
 589             suppress = 0;
 590         }
 591         widthSpecified = 0;
 592         while (isdigit(*fmt)) {
 593             widthSpecified = 1;
 594             fmt++;
 595         }
 596         if (suppress) {
 597             continue;
 598         }
 599         if (numFields == MAX_FIELDS) {
 600             interp->result = "too many fields to scan";
 601             return TCL_ERROR;
 602         }
 603         curField = &fields[numFields];
 604         numFields++;
 605         switch (*fmt) {
 606             case 'D':
 607             case 'O':
 608             case 'X':
 609             case 'd':
 610             case 'o':
 611             case 'x':
 612                 curField->fmt = 'd';
 613                 curField->size = sizeof(int);
 614                 break;
 615
 616             case 's':
 617                 curField->fmt = 's';
 618                 curField->size = arg1Length;
 619                 break;
 620
 621             case 'c':
 622                 if (widthSpecified) {
 623                     interp->result =
 624                          "field width may not be specified in %c conversion";
 625                     return TCL_ERROR;
 626                 }
 627                 curField->fmt = 'c';
 628                 curField->size = sizeof(int);
 629                 break;
 630
 631             case 'E':
 632             case 'F':
 633                 curField->fmt = 'F';
 634                 curField->size = sizeof(double);
 635                 break;
 636
 637             case 'e':
 638             case 'f':
 639                 curField->fmt = 'f';
 640                 curField->size = sizeof(float);
 641                 break;
 642
 643             case '[':
 644                 curField->fmt = 's';
 645                 curField->size = arg1Length;
 646                 do {
 647                     fmt++;
 648                 } while (*fmt != ']');
 649                 break;
 650
 651             default:
 652                 sprintf(interp->result, "bad scan conversion character \"%c\"",
 653                         *fmt);
 654                 return TCL_ERROR;
 655         }
 656         totalSize += curField->size;
 657     }
 658
 659     if (numFields != (argc-3)) {
 660         interp->result =
 661                 "different numbers of variable names and field specifiers";
 662         return TCL_ERROR;
 663     }
 664
 665     /*
 666      * Step 2:
 667      */
 668
 669     results = (char *) ckalloc((unsigned) totalSize);
 670     for (i = 0, totalSize = 0, curField = fields;
 671             i < numFields; i++, curField++) {
 672         curField->location = results + totalSize;
 673         totalSize += curField->size;
 674     }
 675
 676     /*
 677      * Step 3:
 678      */
 679
 680     numScanned = sscanf(argv[1], argv[2],
 681             fields[0].location, fields[1].location, fields[2].location,
 682             fields[3].location, fields[4].location, fields[5].location,
 683             fields[6].location, fields[7].location, fields[8].location,
 684             fields[9].location, fields[10].location, fields[11].location,
 685             fields[12].location, fields[13].location, fields[14].location,
 686             fields[15].location, fields[16].location, fields[17].location,
 687             fields[18].location, fields[19].location);
 688
 689     /*
 690      * Step 4:
 691      */
 692
 693     if (numScanned < numFields) {
 694         numFields = numScanned;
 695     }
 696     for (i = 0, curField = fields; i < numFields; i++, curField++) {
 697         switch (curField->fmt) {
 698             char string[120];
 699
 700             case 'd':
 701                 sprintf(string, "%d", *((int *) curField->location));
 702                 if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
 703                     storeError:
 704                     Tcl_AppendResult(interp,
 705                             "couldn't set variable \"", argv[i+3], "\"",
 706                             (char *) NULL);
 707                     ckfree((char *) results);
 708                     return TCL_ERROR;
 709                 }
 710                 break;
 711
 712             case 'c':
 713                 sprintf(string, "%d", *((char *) curField->location) & 0xff);
 714                 if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
 715                     goto storeError;
 716                 }
 717                 break;
 718
 719             case 's':
 720                 if (Tcl_SetVar(interp, argv[i+3], curField->location, 0)
 721                         == NULL) {
 722                     goto storeError;
 723                 }
 724                 break;
 725
 726             case 'F':
 727                 sprintf(string, "%g", *((double *) curField->location));
 728                 if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
 729                     goto storeError;
 730                 }
 731                 break;
 732
 733             case 'f':
 734                 sprintf(string, "%g", *((float *) curField->location));
 735                 if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
 736                     goto storeError;
 737                 }
 738                 break;
 739         }
 740     }
 741     ckfree(results);
 742     sprintf(interp->result, "%d", numScanned);
 743     return TCL_OK;
 744 }
 745 \f
 746 /*
 747  *----------------------------------------------------------------------
 748  *
 749  * Tcl_SplitCmd --
 750  *
 751  *      This procedure is invoked to process the "split" Tcl command.
 752  *      See the user documentation for details on what it does.
 753  *
 754  * Results:
 755  *      A standard Tcl result.
 756  *
 757  * Side effects:
 758  *      See the user documentation.
 759  *
 760  *----------------------------------------------------------------------
 761  */
 762
 763         /* ARGSUSED */
 764 int
 765 Tcl_SplitCmd(dummy, interp, argc, argv)
 766     ClientData dummy;                   /* Not used. */
 767     Tcl_Interp *interp;                 /* Current interpreter. */
 768     int argc;                           /* Number of arguments. */
 769     char **argv;                        /* Argument strings. */
 770 {
 771     char *splitChars;
 772     register char *p, *p2;
 773     char *elementStart;
 774
 775     if (argc == 2) {
 776         splitChars = " \n\t\r";
 777     } else if (argc == 3) {
 778         splitChars = argv[2];
 779     } else {
 780         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 781                 " string ?splitChars?\"", (char *) NULL);
 782         return TCL_ERROR;
 783     }
 784
 785     /*
 786      * Handle the special case of splitting on every character.
 787      */
 788
 789     if (*splitChars == 0) {
 790         char string[2];
 791         string[1] = 0;
 792         for (p = argv[1]; *p != 0; p++) {
 793             string[0] = *p;
 794             Tcl_AppendElement(interp, string, 0);
 795         }
 796         return TCL_OK;
 797     }
 798
 799     /*
 800      * Normal case: split on any of a given set of characters.
 801      * Discard instances of the split characters.
 802      */
 803
 804     for (p = elementStart = argv[1]; *p != 0; p++) {
 805         char c = *p;
 806         for (p2 = splitChars; *p2 != 0; p2++) {
 807             if (*p2 == c) {
 808                 *p = 0;
 809                 Tcl_AppendElement(interp, elementStart, 0);
 810                 *p = c;
 811                 elementStart = p+1;
 812                 break;
 813             }
 814         }
 815     }
 816     if (p != argv[1]) {
 817         Tcl_AppendElement(interp, elementStart, 0);
 818     }
 819     return TCL_OK;
 820 }
 821 \f
 822 /*
 823  *----------------------------------------------------------------------
 824  *
 825  * Tcl_StringCmd --
 826  *
 827  *      This procedure is invoked to process the "string" Tcl command.
 828  *      See the user documentation for details on what it does.
 829  *
 830  * Results:
 831  *      A standard Tcl result.
 832  *
 833  * Side effects:
 834  *      See the user documentation.
 835  *
 836  *----------------------------------------------------------------------
 837  */
 838
 839         /* ARGSUSED */
 840 int
 841 Tcl_StringCmd(dummy, interp, argc, argv)
 842     ClientData dummy;                   /* Not used. */
 843     Tcl_Interp *interp;                 /* Current interpreter. */
 844     int argc;                           /* Number of arguments. */
 845     char **argv;                        /* Argument strings. */
 846 {
 847     int length;
 848     register char *p, c;
 849     int match;
 850     int first;
 851     int left = 0, right = 0;
 852
 853     if (argc < 2) {
 854         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 855                 " option arg ?arg ...?\"", (char *) NULL);
 856         return TCL_ERROR;
 857     }
 858     c = argv[1][0];
 859     length = strlen(argv[1]);
 860     if ((c == 'c') && (strncmp(argv[1], "compare", length) == 0)) {
 861         if (argc != 4) {
 862             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 863                     " compare string1 string2\"", (char *) NULL);
 864             return TCL_ERROR;
 865         }
 866         match = strcmp(argv[2], argv[3]);
 867         if (match > 0) {
 868             interp->result = "1";
 869         } else if (match < 0) {
 870             interp->result = "-1";
 871         } else {
 872             interp->result = "0";
 873         }
 874         return TCL_OK;
 875     } else if ((c == 'f') && (strncmp(argv[1], "first", length) == 0)) {
 876         if (argc != 4) {
 877             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 878                     " first string1 string2\"", (char *) NULL);
 879             return TCL_ERROR;
 880         }
 881         first = 1;
 882
 883         firstLast:
 884         match = -1;
 885         c = *argv[2];
 886         length = strlen(argv[2]);
 887         for (p = argv[3]; *p != 0; p++) {
 888             if (*p != c) {
 889                 continue;
 890             }
 891             if (strncmp(argv[2], p, length) == 0) {
 892                 match = p-argv[3];
 893                 if (first) {
 894                     break;
 895                 }
 896             }
 897         }
 898         sprintf(interp->result, "%d", match);
 899         return TCL_OK;
 900     } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0)) {
 901         int index;
 902
 903         if (argc != 4) {
 904             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 905                     " index string charIndex\"", (char *) NULL);
 906             return TCL_ERROR;
 907         }
 908         if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) {
 909             return TCL_ERROR;
 910         }
 911         if ((index >= 0) && (index < strlen(argv[2]))) {
 912             interp->result[0] = argv[2][index];
 913             interp->result[1] = 0;
 914         }
 915         return TCL_OK;
 916     } else if ((c == 'l') && (strncmp(argv[1], "last", length) == 0)
 917             && (length >= 2)) {
 918         if (argc != 4) {
 919             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 920                     " last string1 string2\"", (char *) NULL);
 921             return TCL_ERROR;
 922         }
 923         first = 0;
 924         goto firstLast;
 925     } else if ((c == 'l') && (strncmp(argv[1], "length", length) == 0)
 926             && (length >= 2)) {
 927         if (argc != 3) {
 928             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 929                     " length string\"", (char *) NULL);
 930             return TCL_ERROR;
 931         }
 932         sprintf(interp->result, "%d", strlen(argv[2]));
 933         return TCL_OK;
 934     } else if ((c == 'm') && (strncmp(argv[1], "match", length) == 0)) {
 935         if (argc != 4) {
 936             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 937                     " match pattern string\"", (char *) NULL);
 938             return TCL_ERROR;
 939         }
 940         if (Tcl_StringMatch(argv[3], argv[2]) != 0) {
 941             interp->result = "1";
 942         } else {
 943             interp->result = "0";
 944         }
 945         return TCL_OK;
 946     } else if ((c == 'r') && (strncmp(argv[1], "range", length) == 0)) {
 947         int first, last, stringLength;
 948
 949         if (argc != 5) {
 950             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 951                     " range string first last\"", (char *) NULL);
 952             return TCL_ERROR;
 953         }
 954         stringLength = strlen(argv[2]);
 955         if (Tcl_GetInt(interp, argv[3], &first) != TCL_OK) {
 956             return TCL_ERROR;
 957         }
 958         if ((*argv[4] == 'e')
 959                 && (strncmp(argv[4], "end", strlen(argv[4])) == 0)) {
 960             last = stringLength-1;
 961         } else {
 962             if (Tcl_GetInt(interp, argv[4], &last) != TCL_OK) {
 963                 Tcl_ResetResult(interp);
 964                 Tcl_AppendResult(interp,
 965                         "expected integer or \"end\" but got \"",
 966                         argv[4], "\"", (char *) NULL);
 967                 return TCL_ERROR;
 968             }
 969         }
 970         if (first < 0) {
 971             first = 0;
 972         }
 973         if (last >= stringLength) {
 974             last = stringLength-1;
 975         }
 976         if (last >= first) {
 977             char saved, *p;
 978
 979             p = argv[2] + last + 1;
 980             saved = *p;
 981             *p = 0;
 982             Tcl_SetResult(interp, argv[2] + first, TCL_VOLATILE);
 983             *p = saved;
 984         }
 985         return TCL_OK;
 986     } else if ((c == 't') && (strncmp(argv[1], "tolower", length) == 0)
 987             && (length >= 3)) {
 988         register char *p;
 989
 990         if (argc != 3) {
 991             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 992                     " tolower string\"", (char *) NULL);
 993             return TCL_ERROR;
 994         }
 995         Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
 996         for (p = interp->result; *p != 0; p++) {
 997             if (isupper(*p)) {
 998                 *p = tolower(*p);
 999             }
1000         }
1001         return TCL_OK;
1002     } else if ((c == 't') && (strncmp(argv[1], "toupper", length) == 0)
1003             && (length >= 3)) {
1004         register char *p;
1005
1006         if (argc != 3) {
1007             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1008                     " toupper string\"", (char *) NULL);
1009             return TCL_ERROR;
1010         }
1011         Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
1012         for (p = interp->result; *p != 0; p++) {
1013             if (islower(*p)) {
1014                 *p = toupper(*p);
1015             }
1016         }
1017         return TCL_OK;
1018     } else if ((c == 't') && (strncmp(argv[1], "trim", length) == 0)
1019             && (length == 4)) {
1020         char *trimChars;
1021         register char *p, *checkPtr;
1022
1023         left = right = 1;
1024
1025         trim:
1026         if (argc == 4) {
1027             trimChars = argv[3];
1028         } else if (argc == 3) {
1029             trimChars = " \t\n\r";
1030         } else {
1031             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
1032                     " ", argv[1], " string ?chars?\"", (char *) NULL);
1033             return TCL_ERROR;
1034         }
1035         p = argv[2];
1036         if (left) {
1037             for (c = *p; c != 0; p++, c = *p) {
1038                 for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
1039                     if (*checkPtr == 0) {
1040                         goto doneLeft;
1041                     }
1042                 }
1043             }
1044         }
1045         doneLeft:
1046         Tcl_SetResult(interp, p, TCL_VOLATILE);
1047         if (right) {
1048             char *donePtr;
1049
1050             p = interp->result + strlen(interp->result) - 1;
1051             donePtr = &interp->result[-1];
1052             for (c = *p; p != donePtr; p--, c = *p) {
1053                 for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
1054                     if (*checkPtr == 0) {
1055                         goto doneRight;
1056                     }
1057                 }
1058             }
1059             doneRight:
1060             p[1] = 0;
1061         }
1062         return TCL_OK;
1063     } else if ((c == 't') && (strncmp(argv[1], "trimleft", length) == 0)
1064             && (length > 4)) {
1065         left = 1;
1066         argv[1] = "trimleft";
1067         goto trim;
1068     } else if ((c == 't') && (strncmp(argv[1], "trimright", length) == 0)
1069             && (length > 4)) {
1070         right = 1;
1071         argv[1] = "trimright";
1072         goto trim;
1073     } else {
1074         Tcl_AppendResult(interp, "bad option \"", argv[1],
1075                 "\": should be compare, first, index, last, length, match, ",
1076                 "range, tolower, toupper, trim, trimleft, or trimright",
1077                 (char *) NULL);
1078         return TCL_ERROR;
1079     }
1080 }
1081 \f
1082 /*
1083  *----------------------------------------------------------------------
1084  *
1085  * Tcl_TraceCmd --
1086  *
1087  *      This procedure is invoked to process the "trace" Tcl command.
1088  *      See the user documentation for details on what it does.
1089  *
1090  * Results:
1091  *      A standard Tcl result.
1092  *
1093  * Side effects:
1094  *      See the user documentation.
1095  *
1096  *----------------------------------------------------------------------
1097  */
1098
1099         /* ARGSUSED */
1100 int
1101 Tcl_TraceCmd(dummy, interp, argc, argv)
1102     ClientData dummy;                   /* Not used. */
1103     Tcl_Interp *interp;                 /* Current interpreter. */
1104     int argc;                           /* Number of arguments. */
1105     char **argv;                        /* Argument strings. */
1106 {
1107     char c;
1108     int length;
1109
1110     if (argc < 2) {
1111         Tcl_AppendResult(interp, "too few args: should be \"",
1112                 argv[0], " option [arg arg ...]\"", (char *) NULL);
1113         return TCL_ERROR;
1114     }
1115     c = argv[1][1];
1116     length = strlen(argv[1]);
1117     if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0)
1118             && (length >= 2)) {
1119         char *p;
1120         int flags, length;
1121         TraceVarInfo *tvarPtr;
1122
1123         if (argc != 5) {
1124             Tcl_AppendResult(interp, "wrong # args: should be \"",
1125                     argv[0], " variable name ops command\"", (char *) NULL);
1126             return TCL_ERROR;
1127         }
1128
1129         flags = 0;
1130         for (p = argv[3] ; *p != 0; p++) {
1131             if (*p == 'r') {
1132                 flags |= TCL_TRACE_READS;
1133             } else if (*p == 'w') {
1134                 flags |= TCL_TRACE_WRITES;
1135             } else if (*p == 'u') {
1136                 flags |= TCL_TRACE_UNSETS;
1137             } else {
1138                 goto badOps;
1139             }
1140         }
1141         if (flags == 0) {
1142             goto badOps;
1143         }
1144
1145         length = strlen(argv[4]);
1146         tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
1147                 (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1));
1148         tvarPtr->flags = flags;
1149         tvarPtr->length = length;
1150         flags |= TCL_TRACE_UNSETS;
1151         strcpy(tvarPtr->command, argv[4]);
1152         if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc,
1153                 (ClientData) tvarPtr) != TCL_OK) {
1154             ckfree((char *) tvarPtr);
1155             return TCL_ERROR;
1156         }
1157     } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length)
1158             && (length >= 2)) == 0) {
1159         char *p;
1160         int flags, length;
1161         TraceVarInfo *tvarPtr;
1162         ClientData clientData;
1163
1164         if (argc != 5) {
1165             Tcl_AppendResult(interp, "wrong # args: should be \"",
1166                     argv[0], " vdelete name ops command\"", (char *) NULL);
1167             return TCL_ERROR;
1168         }
1169
1170         flags = 0;
1171         for (p = argv[3] ; *p != 0; p++) {
1172             if (*p == 'r') {
1173                 flags |= TCL_TRACE_READS;
1174             } else if (*p == 'w') {
1175                 flags |= TCL_TRACE_WRITES;
1176             } else if (*p == 'u') {
1177                 flags |= TCL_TRACE_UNSETS;
1178             } else {
1179                 goto badOps;
1180             }
1181         }
1182         if (flags == 0) {
1183             goto badOps;
1184         }
1185
1186         /*
1187          * Search through all of our traces on this variable to
1188          * see if there's one with the given command.  If so, then
1189          * delete the first one that matches.
1190          */
1191
1192         length = strlen(argv[4]);
1193         clientData = 0;
1194         while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
1195                 TraceVarProc, clientData)) != 0) {
1196             tvarPtr = (TraceVarInfo *) clientData;
1197             if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
1198                     && (strncmp(argv[4], tvarPtr->command, length) == 0)) {
1199                 Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS,
1200                         TraceVarProc, clientData);
1201                 ckfree((char *) tvarPtr);
1202                 break;
1203             }
1204         }
1205     } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0)
1206             && (length >= 2)) {
1207         ClientData clientData;
1208         char ops[4], *p;
1209         char *prefix = "{";
1210
1211         if (argc != 3) {
1212             Tcl_AppendResult(interp, "wrong # args: should be \"",
1213                     argv[0], " vinfo name\"", (char *) NULL);
1214             return TCL_ERROR;
1215         }
1216         clientData = 0;
1217         while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
1218                 TraceVarProc, clientData)) != 0) {
1219             TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
1220             p = ops;
1221             if (tvarPtr->flags & TCL_TRACE_READS) {
1222                 *p = 'r';
1223                 p++;
1224             }
1225             if (tvarPtr->flags & TCL_TRACE_WRITES) {
1226                 *p = 'w';
1227                 p++;
1228             }
1229             if (tvarPtr->flags & TCL_TRACE_UNSETS) {
1230                 *p = 'u';
1231                 p++;
1232             }
1233             *p = '\0';
1234             Tcl_AppendResult(interp, prefix, (char *) NULL);
1235             Tcl_AppendElement(interp, ops, 1);
1236             Tcl_AppendElement(interp, tvarPtr->command, 0);
1237             Tcl_AppendResult(interp, "}", (char *) NULL);
1238             prefix = " {";
1239         }
1240     } else {
1241         Tcl_AppendResult(interp, "bad option \"", argv[1],
1242                 "\": should be variable, vdelete, or vinfo",
1243                 (char *) NULL);
1244         return TCL_ERROR;
1245     }
1246     return TCL_OK;
1247
1248     badOps:
1249     Tcl_AppendResult(interp, "bad operations \"", argv[3],
1250             "\": should be one or more of rwu", (char *) NULL);
1251     return TCL_ERROR;
1252 }
1253 \f
1254 /*
1255  *----------------------------------------------------------------------
1256  *
1257  * TraceVarProc --
1258  *
1259  *      This procedure is called to handle variable accesses that have
1260  *      been traced using the "trace" command.
1261  *
1262  * Results:
1263  *      Normally returns NULL.  If the trace command returns an error,
1264  *      then this procedure returns an error string.
1265  *
1266  * Side effects:
1267  *      Depends on the command associated with the trace.
1268  *
1269  *----------------------------------------------------------------------
1270  */
1271
1272         /* ARGSUSED */
1273 static char *
1274 TraceVarProc(clientData, interp, name1, name2, flags)
1275     ClientData clientData;      /* Information about the variable trace. */
1276     Tcl_Interp *interp;         /* Interpreter containing variable. */
1277     char *name1;                /* Name of variable or array. */
1278     char *name2;                /* Name of element within array;  NULL means
1279                                  * scalar variable is being referenced. */
1280     int flags;                  /* OR-ed bits giving operation and other
1281                                  * information. */
1282 {
1283     TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
1284     char *result;
1285     int code, cmdLength, flags1, flags2;
1286     Interp dummy;
1287 #define STATIC_SIZE 199
1288     char staticSpace[STATIC_SIZE+1];
1289     char *cmdPtr, *p;
1290
1291     result = NULL;
1292     if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
1293
1294         /*
1295          * Generate a command to execute by appending list elements
1296          * for the two variable names and the operation.  The five
1297          * extra characters are for three space, the opcode character,
1298          * and the terminating null.
1299          */
1300
1301         if (name2 == NULL) {
1302             name2 = "";
1303         }
1304         cmdLength = tvarPtr->length + Tcl_ScanElement(name1, &flags1) +
1305                 Tcl_ScanElement(name2, &flags2) + 5;
1306         if (cmdLength < STATIC_SIZE) {
1307             cmdPtr = staticSpace;
1308         } else {
1309             cmdPtr = (char *) ckalloc((unsigned) cmdLength);
1310         }
1311         p = cmdPtr;
1312         strcpy(p, tvarPtr->command);
1313         p += tvarPtr->length;
1314         *p = ' ';
1315         p++;
1316         p += Tcl_ConvertElement(name1, p, flags1);
1317         *p = ' ';
1318         p++;
1319         p += Tcl_ConvertElement(name2, p, flags2);
1320         *p = ' ';
1321         if (flags & TCL_TRACE_READS) {
1322             p[1] = 'r';
1323         } else if (flags & TCL_TRACE_WRITES) {
1324             p[1] = 'w';
1325         } else if (flags & TCL_TRACE_UNSETS) {
1326             p[1] = 'u';
1327         }
1328         p[2] = '\0';
1329
1330         /*
1331          * Execute the command.  Be careful to save and restore the
1332          * result from the interpreter used for the command.
1333          */
1334
1335         dummy.freeProc = interp->freeProc;
1336         if (interp->freeProc == 0) {
1337             Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, TCL_VOLATILE);
1338         } else {
1339             dummy.result = interp->result;
1340         }
1341         code = Tcl_Eval(interp, cmdPtr, 0, (char **) NULL);
1342         if (cmdPtr != staticSpace) {
1343             ckfree(cmdPtr);
1344         }
1345         if (code != TCL_OK) {
1346             result = "access disallowed by trace command";
1347             Tcl_ResetResult(interp);            /* Must clear error state. */
1348         }
1349         Tcl_FreeResult(interp);
1350         interp->result = dummy.result;
1351         interp->freeProc = dummy.freeProc;
1352     }
1353     if (flags & TCL_TRACE_DESTROYED) {
1354         ckfree((char *) tvarPtr);
1355     }
1356     return result;
1357 }
1358 \f
1359 /*
1360  *----------------------------------------------------------------------
1361  *
1362  * Tcl_WhileCmd --
1363  *
1364  *      This procedure is invoked to process the "while" Tcl command.
1365  *      See the user documentation for details on what it does.
1366  *
1367  * Results:
1368  *      A standard Tcl result.
1369  *
1370  * Side effects:
1371  *      See the user documentation.
1372  *
1373  *----------------------------------------------------------------------
1374  */
1375
1376         /* ARGSUSED */
1377 int
1378 Tcl_WhileCmd(dummy, interp, argc, argv)
1379     ClientData dummy;                   /* Not used. */
1380     Tcl_Interp *interp;                 /* Current interpreter. */
1381     int argc;                           /* Number of arguments. */
1382     char **argv;                        /* Argument strings. */
1383 {
1384     int result, value;
1385
1386     if (argc != 3) {
1387         Tcl_AppendResult(interp, "wrong # args: should be \"",
1388                 argv[0], " test command\"", (char *) NULL);
1389         return TCL_ERROR;
1390     }
1391
1392     while (1) {
1393         result = Tcl_ExprBoolean(interp, argv[1], &value);
1394         if (result != TCL_OK) {
1395             return result;
1396         }
1397         if (!value) {
1398             break;
1399         }
1400         result = Tcl_Eval(interp, argv[2], 0, (char **) NULL);
1401         if (result == TCL_CONTINUE) {
1402             result = TCL_OK;
1403         } else if (result != TCL_OK) {
1404             if (result == TCL_ERROR) {
1405                 char msg[60];
1406                 sprintf(msg, "\n    (\"while\" body line %d)",
1407                         interp->errorLine);
1408                 Tcl_AddErrorInfo(interp, msg);
1409             }
1410             break;
1411         }
1412     }
1413     if (result == TCL_BREAK) {
1414         result = TCL_OK;
1415     }
1416     if (result == TCL_OK) {
1417         Tcl_ResetResult(interp);
1418     }
1419     return result;
1420 }