source: HiSusy/trunk/Delphes-3.0.0/external/tcl/tclCmdMZ.c @ 1

Last change on this file since 1 was 1, checked in by zerwas, 11 years ago

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