/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcmdmz.c
ViewVC logotype

Annotation of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcmdmz.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 71 - (hide annotations) (download)
Sat Nov 5 11:07:06 2016 UTC (7 years, 3 months ago) by dashley
File MIME type: text/plain
File size: 72012 byte(s)
Set EOL properties appropriately to facilitate simultaneous Linux and Windows development.
1 dashley 71 /* $Header$ */
2     /*
3     * tclCmdMZ.c --
4     *
5     * This file contains the top-level command routines for most of
6     * the Tcl built-in commands whose names begin with the letters
7     * M to Z. It contains only commands in the generic core (i.e.
8     * those that don't depend much upon UNIX facilities).
9     *
10     * Copyright (c) 1987-1993 The Regents of the University of California.
11     * Copyright (c) 1994-1997 Sun Microsystems, Inc.
12     * Copyright (c) 1998-1999 by Scriptics Corporation.
13     *
14     * See the file "license.terms" for information on usage and redistribution
15     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
16     *
17     * RCS: @(#) $Id: tclcmdmz.c,v 1.1.1.1 2001/06/13 04:35:16 dtashley Exp $
18     */
19    
20     #include "tclInt.h"
21     #include "tclPort.h"
22     #include "tclCompile.h"
23     #include "tclRegexp.h"
24    
25     /*
26     * Flag values used by Tcl_ScanObjCmd.
27     */
28    
29     #define SCAN_NOSKIP 0x1 /* Don't skip blanks. */
30     #define SCAN_SUPPRESS 0x2 /* Suppress assignment. */
31     #define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */
32     #define SCAN_WIDTH 0x8 /* A width value was supplied. */
33    
34     #define SCAN_SIGNOK 0x10 /* A +/- character is allowed. */
35     #define SCAN_NODIGITS 0x20 /* No digits have been scanned. */
36     #define SCAN_NOZERO 0x40 /* No zero digits have been scanned. */
37     #define SCAN_XOK 0x80 /* An 'x' is allowed. */
38     #define SCAN_PTOK 0x100 /* Decimal point is allowed. */
39     #define SCAN_EXPOK 0x200 /* An exponent is allowed. */
40    
41     /*
42     * Structure used to hold information about variable traces:
43     */
44    
45     typedef struct {
46     int flags; /* Operations for which Tcl command is
47     * to be invoked. */
48     char *errMsg; /* Error message returned from Tcl command,
49     * or NULL. Malloc'ed. */
50     size_t length; /* Number of non-NULL chars. in command. */
51     char command[4]; /* Space for Tcl command to invoke. Actual
52     * size will be as large as necessary to
53     * hold command. This field must be the
54     * last in the structure, so that it can
55     * be larger than 4 bytes. */
56     } TraceVarInfo;
57    
58     /*
59     * Forward declarations for procedures defined in this file:
60     */
61    
62     static char * TraceVarProc _ANSI_ARGS_((ClientData clientData,
63     Tcl_Interp *interp, char *name1, char *name2,
64     int flags));
65    
66     /*
67     *----------------------------------------------------------------------
68     *
69     * Tcl_PwdObjCmd --
70     *
71     * This procedure is invoked to process the "pwd" Tcl command.
72     * See the user documentation for details on what it does.
73     *
74     * Results:
75     * A standard Tcl result.
76     *
77     * Side effects:
78     * See the user documentation.
79     *
80     *----------------------------------------------------------------------
81     */
82    
83     /* ARGSUSED */
84     int
85     Tcl_PwdObjCmd(dummy, interp, objc, objv)
86     ClientData dummy; /* Not used. */
87     Tcl_Interp *interp; /* Current interpreter. */
88     int objc; /* Number of arguments. */
89     Tcl_Obj *CONST objv[]; /* Argument objects. */
90     {
91     Tcl_DString ds;
92    
93     if (objc != 1) {
94     Tcl_WrongNumArgs(interp, 1, objv, NULL);
95     return TCL_ERROR;
96     }
97    
98     if (Tcl_GetCwd(interp, &ds) == NULL) {
99     return TCL_ERROR;
100     }
101     Tcl_DStringResult(interp, &ds);
102     return TCL_OK;
103     }
104    
105     /*
106     *----------------------------------------------------------------------
107     *
108     * Tcl_RegexpObjCmd --
109     *
110     * This procedure is invoked to process the "regexp" Tcl command.
111     * See the user documentation for details on what it does.
112     *
113     * Results:
114     * A standard Tcl result.
115     *
116     * Side effects:
117     * See the user documentation.
118     *
119     *----------------------------------------------------------------------
120     */
121    
122     /* ARGSUSED */
123     int
124     Tcl_RegexpObjCmd(dummy, interp, objc, objv)
125     ClientData dummy; /* Not used. */
126     Tcl_Interp *interp; /* Current interpreter. */
127     int objc; /* Number of arguments. */
128     Tcl_Obj *CONST objv[]; /* Argument objects. */
129     {
130     int i, indices, match, about, offset, all, doinline, numMatchesSaved;
131     int cflags, eflags, stringLength;
132     Tcl_RegExp regExpr;
133     Tcl_Obj *objPtr, *resultPtr;
134     Tcl_RegExpInfo info;
135     static char *options[] = {
136     "-all", "-about", "-indices", "-inline",
137     "-expanded", "-line", "-linestop", "-lineanchor",
138     "-nocase", "-start", "--", (char *) NULL
139     };
140     enum options {
141     REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE,
142     REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR,
143     REGEXP_NOCASE, REGEXP_START, REGEXP_LAST
144     };
145    
146     indices = 0;
147     about = 0;
148     cflags = TCL_REG_ADVANCED;
149     eflags = 0;
150     offset = 0;
151     all = 0;
152     doinline = 0;
153    
154     for (i = 1; i < objc; i++) {
155     char *name;
156     int index;
157    
158     name = Tcl_GetString(objv[i]);
159     if (name[0] != '-') {
160     break;
161     }
162     if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
163     &index) != TCL_OK) {
164     return TCL_ERROR;
165     }
166     switch ((enum options) index) {
167     case REGEXP_ALL: {
168     all = 1;
169     break;
170     }
171     case REGEXP_INDICES: {
172     indices = 1;
173     break;
174     }
175     case REGEXP_INLINE: {
176     doinline = 1;
177     break;
178     }
179     case REGEXP_NOCASE: {
180     cflags |= TCL_REG_NOCASE;
181     break;
182     }
183     case REGEXP_ABOUT: {
184     about = 1;
185     break;
186     }
187     case REGEXP_EXPANDED: {
188     cflags |= TCL_REG_EXPANDED;
189     break;
190     }
191     case REGEXP_LINE: {
192     cflags |= TCL_REG_NEWLINE;
193     break;
194     }
195     case REGEXP_LINESTOP: {
196     cflags |= TCL_REG_NLSTOP;
197     break;
198     }
199     case REGEXP_LINEANCHOR: {
200     cflags |= TCL_REG_NLANCH;
201     break;
202     }
203     case REGEXP_START: {
204     if (++i >= objc) {
205     goto endOfForLoop;
206     }
207     if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) {
208     return TCL_ERROR;
209     }
210     if (offset < 0) {
211     offset = 0;
212     }
213     break;
214     }
215     case REGEXP_LAST: {
216     i++;
217     goto endOfForLoop;
218     }
219     }
220     }
221    
222     endOfForLoop:
223     if ((objc - i) < (2 - about)) {
224     Tcl_WrongNumArgs(interp, 1, objv, "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?");
225     return TCL_ERROR;
226     }
227     objc -= i;
228     objv += i;
229    
230     if (doinline && ((objc - 2) != 0)) {
231     /*
232     * User requested -inline, but specified match variables - a no-no.
233     */
234     Tcl_AppendResult(interp, "regexp match variables not allowed",
235     " when using -inline", (char *) NULL);
236     return TCL_ERROR;
237     }
238    
239     regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
240     if (regExpr == NULL) {
241     return TCL_ERROR;
242     }
243     objPtr = objv[1];
244    
245     if (about) {
246     if (TclRegAbout(interp, regExpr) < 0) {
247     return TCL_ERROR;
248     }
249     return TCL_OK;
250     }
251    
252     if (offset > 0) {
253     /*
254     * Add flag if using offset (string is part of a larger string),
255     * so that "^" won't match.
256     */
257     eflags |= TCL_REG_NOTBOL;
258     }
259    
260     objc -= 2;
261     objv += 2;
262     resultPtr = Tcl_GetObjResult(interp);
263    
264     if (doinline) {
265     /*
266     * Save all the subexpressions, as we will return them as a list
267     */
268     numMatchesSaved = -1;
269     } else {
270     /*
271     * Save only enough subexpressions for matches we want to keep,
272     * expect in the case of -all, where we need to keep at least
273     * one to know where to move the offset.
274     */
275     numMatchesSaved = (objc == 0) ? all : objc;
276     }
277    
278     /*
279     * Get the length of the string that we are matching against so
280     * we can do the termination test for -all matches.
281     */
282     stringLength = Tcl_GetCharLength(objPtr);
283    
284     /*
285     * The following loop is to handle multiple matches within the
286     * same source string; each iteration handles one match. If "-all"
287     * hasn't been specified then the loop body only gets executed once.
288     * We terminate the loop when the starting offset is past the end of the
289     * string.
290     */
291    
292     while (1) {
293     match = Tcl_RegExpExecObj(interp, regExpr, objPtr,
294     offset /* offset */, numMatchesSaved, eflags);
295    
296     if (match < 0) {
297     return TCL_ERROR;
298     }
299    
300     if (match == 0) {
301     /*
302     * We want to set the value of the intepreter result only when
303     * this is the first time through the loop.
304     */
305     if (all <= 1) {
306     /*
307     * If inlining, set the interpreter's object result to an
308     * empty list, otherwise set it to an integer object w/
309     * value 0.
310     */
311     if (doinline) {
312     Tcl_SetListObj(resultPtr, 0, NULL);
313     } else {
314     Tcl_SetIntObj(resultPtr, 0);
315     }
316     return TCL_OK;
317     }
318     break;
319     }
320    
321     /*
322     * If additional variable names have been specified, return
323     * index information in those variables.
324     */
325    
326     Tcl_RegExpGetInfo(regExpr, &info);
327     if (doinline) {
328     /*
329     * It's the number of substitutions, plus one for the matchVar
330     * at index 0
331     */
332     objc = info.nsubs + 1;
333     }
334     for (i = 0; i < objc; i++) {
335     Tcl_Obj *newPtr;
336    
337     if (indices) {
338     int start, end;
339     Tcl_Obj *objs[2];
340    
341     if (i <= info.nsubs) {
342     start = offset + info.matches[i].start;
343     end = offset + info.matches[i].end;
344    
345     /*
346     * Adjust index so it refers to the last character in the
347     * match instead of the first character after the match.
348     */
349    
350     if (end >= offset) {
351     end--;
352     }
353     } else {
354     start = -1;
355     end = -1;
356     }
357    
358     objs[0] = Tcl_NewLongObj(start);
359     objs[1] = Tcl_NewLongObj(end);
360    
361     newPtr = Tcl_NewListObj(2, objs);
362     } else {
363     if (i <= info.nsubs) {
364     newPtr = Tcl_GetRange(objPtr,
365     offset + info.matches[i].start,
366     offset + info.matches[i].end - 1);
367     } else {
368     newPtr = Tcl_NewObj();
369     }
370     }
371     if (doinline) {
372     if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr)
373     != TCL_OK) {
374     Tcl_DecrRefCount(newPtr);
375     return TCL_ERROR;
376     }
377     } else {
378     Tcl_Obj *valuePtr;
379     valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0);
380     if (valuePtr == NULL) {
381     Tcl_DecrRefCount(newPtr);
382     Tcl_AppendResult(interp, "couldn't set variable \"",
383     Tcl_GetString(objv[i]), "\"", (char *) NULL);
384     return TCL_ERROR;
385     }
386     }
387     }
388    
389     if (all == 0) {
390     break;
391     }
392     /*
393     * Adjust the offset to the character just after the last one
394     * in the matchVar and increment all to count how many times
395     * we are making a match. We always increment the offset by at least
396     * one to prevent endless looping (as in the case:
397     * regexp -all {a*} a). Otherwise, when we match the NULL string at
398     * the end of the input string, we will loop indefinately (because the
399     * length of the match is 0, so offset never changes).
400     */
401     if (info.matches[0].end == 0) {
402     offset++;
403     }
404     offset += info.matches[0].end;
405     all++;
406     if (offset >= stringLength) {
407     break;
408     }
409     }
410    
411     /*
412     * Set the interpreter's object result to an integer object
413     * with value 1 if -all wasn't specified, otherwise it's all-1
414     * (the number of times through the while - 1).
415     */
416    
417     if (!doinline) {
418     Tcl_SetIntObj(resultPtr, (all ? all-1 : 1));
419     }
420     return TCL_OK;
421     }
422    
423     /*
424     *----------------------------------------------------------------------
425     *
426     * Tcl_RegsubObjCmd --
427     *
428     * This procedure is invoked to process the "regsub" Tcl command.
429     * See the user documentation for details on what it does.
430     *
431     * Results:
432     * A standard Tcl result.
433     *
434     * Side effects:
435     * See the user documentation.
436     *
437     *----------------------------------------------------------------------
438     */
439    
440     /* ARGSUSED */
441     int
442     Tcl_RegsubObjCmd(dummy, interp, objc, objv)
443     ClientData dummy; /* Not used. */
444     Tcl_Interp *interp; /* Current interpreter. */
445     int objc; /* Number of arguments. */
446     Tcl_Obj *CONST objv[]; /* Argument objects. */
447     {
448     int i, result, cflags, all, wlen, numMatches, offset;
449     Tcl_RegExp regExpr;
450     Tcl_Obj *resultPtr, *varPtr, *objPtr;
451     Tcl_UniChar *wstring;
452     char *subspec;
453    
454     static char *options[] = {
455     "-all", "-nocase", "-expanded",
456     "-line", "-linestop", "-lineanchor", "-start",
457     "--", NULL
458     };
459     enum options {
460     REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED,
461     REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START,
462     REGSUB_LAST
463     };
464    
465     cflags = TCL_REG_ADVANCED;
466     all = 0;
467     offset = 0;
468    
469     for (i = 1; i < objc; i++) {
470     char *name;
471     int index;
472    
473     name = Tcl_GetString(objv[i]);
474     if (name[0] != '-') {
475     break;
476     }
477     if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT,
478     &index) != TCL_OK) {
479     return TCL_ERROR;
480     }
481     switch ((enum options) index) {
482     case REGSUB_ALL: {
483     all = 1;
484     break;
485     }
486     case REGSUB_NOCASE: {
487     cflags |= TCL_REG_NOCASE;
488     break;
489     }
490     case REGSUB_EXPANDED: {
491     cflags |= TCL_REG_EXPANDED;
492     break;
493     }
494     case REGSUB_LINE: {
495     cflags |= TCL_REG_NEWLINE;
496     break;
497     }
498     case REGSUB_LINESTOP: {
499     cflags |= TCL_REG_NLSTOP;
500     break;
501     }
502     case REGSUB_LINEANCHOR: {
503     cflags |= TCL_REG_NLANCH;
504     break;
505     }
506     case REGSUB_START: {
507     if (++i >= objc) {
508     goto endOfForLoop;
509     }
510     if (Tcl_GetIntFromObj(interp, objv[i], &offset) != TCL_OK) {
511     return TCL_ERROR;
512     }
513     if (offset < 0) {
514     offset = 0;
515     }
516     break;
517     }
518     case REGSUB_LAST: {
519     i++;
520     goto endOfForLoop;
521     }
522     }
523     }
524     endOfForLoop:
525     if (objc - i != 4) {
526     Tcl_WrongNumArgs(interp, 1, objv,
527     "?switches? exp string subSpec varName");
528     return TCL_ERROR;
529     }
530    
531     objv += i;
532    
533     regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
534     if (regExpr == NULL) {
535     return TCL_ERROR;
536     }
537    
538     result = TCL_OK;
539     resultPtr = Tcl_NewObj();
540     Tcl_IncrRefCount(resultPtr);
541    
542     objPtr = objv[1];
543     wlen = Tcl_GetCharLength(objPtr);
544     wstring = Tcl_GetUnicode(objPtr);
545     subspec = Tcl_GetString(objv[2]);
546     varPtr = objv[3];
547    
548     /*
549     * The following loop is to handle multiple matches within the
550     * same source string; each iteration handles one match and its
551     * corresponding substitution. If "-all" hasn't been specified
552     * then the loop body only gets executed once.
553     */
554    
555     numMatches = 0;
556     for ( ; offset < wlen; ) {
557     int start, end, subStart, subEnd, match;
558     char *src, *firstChar;
559     char c;
560     Tcl_RegExpInfo info;
561    
562     /*
563     * The flags argument is set if string is part of a larger string,
564     * so that "^" won't match.
565     */
566    
567     match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset,
568     10 /* matches */, ((offset > 0) ? TCL_REG_NOTBOL : 0));
569    
570     if (match < 0) {
571     result = TCL_ERROR;
572     goto done;
573     }
574     if (match == 0) {
575     break;
576     }
577     if ((numMatches == 0) && (offset > 0)) {
578     /* Copy the initial portion of the string in if an offset
579     * was specified.
580     */
581     Tcl_AppendUnicodeToObj(resultPtr, wstring, offset);
582     }
583     numMatches++;
584    
585     /*
586     * Copy the portion of the source string before the match to the
587     * result variable.
588     */
589    
590     Tcl_RegExpGetInfo(regExpr, &info);
591     start = info.matches[0].start;
592     end = info.matches[0].end;
593     Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start);
594    
595     /*
596     * Append the subSpec argument to the variable, making appropriate
597     * substitutions. This code is a bit hairy because of the backslash
598     * conventions and because the code saves up ranges of characters in
599     * subSpec to reduce the number of calls to Tcl_SetVar.
600     */
601    
602     src = subspec;
603     firstChar = subspec;
604     for (c = *src; c != '\0'; src++, c = *src) {
605     int index;
606    
607     if (c == '&') {
608     index = 0;
609     } else if (c == '\\') {
610     c = src[1];
611     if ((c >= '0') && (c <= '9')) {
612     index = c - '0';
613     } else if ((c == '\\') || (c == '&')) {
614     Tcl_AppendToObj(resultPtr, firstChar, src - firstChar);
615     Tcl_AppendToObj(resultPtr, &c, 1);
616     firstChar = src + 2;
617     src++;
618     continue;
619     } else {
620     continue;
621     }
622     } else {
623     continue;
624     }
625     if (firstChar != src) {
626     Tcl_AppendToObj(resultPtr, firstChar, src - firstChar);
627     }
628     if (index <= info.nsubs) {
629     subStart = info.matches[index].start;
630     subEnd = info.matches[index].end;
631     if ((subStart >= 0) && (subEnd >= 0)) {
632     Tcl_AppendUnicodeToObj(resultPtr,
633     wstring + offset + subStart, subEnd - subStart);
634     }
635     }
636     if (*src == '\\') {
637     src++;
638     }
639     firstChar = src + 1;
640     }
641     if (firstChar != src) {
642     Tcl_AppendToObj(resultPtr, firstChar, src - firstChar);
643     }
644     if (end == 0) {
645     /*
646     * Always consume at least one character of the input string
647     * in order to prevent infinite loops.
648     */
649    
650     Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
651     offset++;
652     }
653     offset += end;
654     if (!all) {
655     break;
656     }
657     }
658    
659     /*
660     * Copy the portion of the source string after the last match to the
661     * result variable.
662     */
663    
664     if (numMatches == 0) {
665     /*
666     * On zero matches, just ignore the offset, since it shouldn't
667     * matter to us in this case, and the user may have skewed it.
668     */
669     Tcl_AppendUnicodeToObj(resultPtr, wstring, wlen);
670     } else if (offset < wlen) {
671     Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset);
672     }
673     if (Tcl_ObjSetVar2(interp, varPtr, NULL, resultPtr, 0) == NULL) {
674     Tcl_AppendResult(interp, "couldn't set variable \"",
675     Tcl_GetString(varPtr), "\"", (char *) NULL);
676     result = TCL_ERROR;
677     } else {
678     /*
679     * Set the interpreter's object result to an integer object holding the
680     * number of matches.
681     */
682    
683     Tcl_SetIntObj(Tcl_GetObjResult(interp), numMatches);
684     }
685    
686     done:
687     Tcl_DecrRefCount(resultPtr);
688     return result;
689     }
690    
691     /*
692     *----------------------------------------------------------------------
693     *
694     * Tcl_RenameObjCmd --
695     *
696     * This procedure is invoked to process the "rename" Tcl command.
697     * See the user documentation for details on what it does.
698     *
699     * Results:
700     * A standard Tcl object result.
701     *
702     * Side effects:
703     * See the user documentation.
704     *
705     *----------------------------------------------------------------------
706     */
707    
708     /* ARGSUSED */
709     int
710     Tcl_RenameObjCmd(dummy, interp, objc, objv)
711     ClientData dummy; /* Arbitrary value passed to the command. */
712     Tcl_Interp *interp; /* Current interpreter. */
713     int objc; /* Number of arguments. */
714     Tcl_Obj *CONST objv[]; /* Argument objects. */
715     {
716     char *oldName, *newName;
717    
718     if (objc != 3) {
719     Tcl_WrongNumArgs(interp, 1, objv, "oldName newName");
720     return TCL_ERROR;
721     }
722    
723     oldName = Tcl_GetString(objv[1]);
724     newName = Tcl_GetString(objv[2]);
725     return TclRenameCommand(interp, oldName, newName);
726     }
727    
728     /*
729     *----------------------------------------------------------------------
730     *
731     * Tcl_ReturnObjCmd --
732     *
733     * This object-based procedure is invoked to process the "return" Tcl
734     * command. See the user documentation for details on what it does.
735     *
736     * Results:
737     * A standard Tcl object result.
738     *
739     * Side effects:
740     * See the user documentation.
741     *
742     *----------------------------------------------------------------------
743     */
744    
745     /* ARGSUSED */
746     int
747     Tcl_ReturnObjCmd(dummy, interp, objc, objv)
748     ClientData dummy; /* Not used. */
749     Tcl_Interp *interp; /* Current interpreter. */
750     int objc; /* Number of arguments. */
751     Tcl_Obj *CONST objv[]; /* Argument objects. */
752     {
753     Interp *iPtr = (Interp *) interp;
754     int optionLen, argLen, code, result;
755    
756     if (iPtr->errorInfo != NULL) {
757     ckfree(iPtr->errorInfo);
758     iPtr->errorInfo = NULL;
759     }
760     if (iPtr->errorCode != NULL) {
761     ckfree(iPtr->errorCode);
762     iPtr->errorCode = NULL;
763     }
764     code = TCL_OK;
765    
766     for (objv++, objc--; objc > 1; objv += 2, objc -= 2) {
767     char *option = Tcl_GetStringFromObj(objv[0], &optionLen);
768     char *arg = Tcl_GetStringFromObj(objv[1], &argLen);
769    
770     if (strcmp(option, "-code") == 0) {
771     register int c = arg[0];
772     if ((c == 'o') && (strcmp(arg, "ok") == 0)) {
773     code = TCL_OK;
774     } else if ((c == 'e') && (strcmp(arg, "error") == 0)) {
775     code = TCL_ERROR;
776     } else if ((c == 'r') && (strcmp(arg, "return") == 0)) {
777     code = TCL_RETURN;
778     } else if ((c == 'b') && (strcmp(arg, "break") == 0)) {
779     code = TCL_BREAK;
780     } else if ((c == 'c') && (strcmp(arg, "continue") == 0)) {
781     code = TCL_CONTINUE;
782     } else {
783     result = Tcl_GetIntFromObj((Tcl_Interp *) NULL, objv[1],
784     &code);
785     if (result != TCL_OK) {
786     Tcl_ResetResult(interp);
787     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
788     "bad completion code \"",
789     Tcl_GetString(objv[1]),
790     "\": must be ok, error, return, break, ",
791     "continue, or an integer", (char *) NULL);
792     return result;
793     }
794     }
795     } else if (strcmp(option, "-errorinfo") == 0) {
796     iPtr->errorInfo =
797     (char *) ckalloc((unsigned) (strlen(arg) + 1));
798     strcpy(iPtr->errorInfo, arg);
799     } else if (strcmp(option, "-errorcode") == 0) {
800     iPtr->errorCode =
801     (char *) ckalloc((unsigned) (strlen(arg) + 1));
802     strcpy(iPtr->errorCode, arg);
803     } else {
804     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
805     "bad option \"", option,
806     "\": must be -code, -errorcode, or -errorinfo",
807     (char *) NULL);
808     return TCL_ERROR;
809     }
810     }
811    
812     if (objc == 1) {
813     /*
814     * Set the interpreter's object result. An inline version of
815     * Tcl_SetObjResult.
816     */
817    
818     Tcl_SetObjResult(interp, objv[0]);
819     }
820     iPtr->returnCode = code;
821     return TCL_RETURN;
822     }
823    
824     /*
825     *----------------------------------------------------------------------
826     *
827     * Tcl_SourceObjCmd --
828     *
829     * This procedure is invoked to process the "source" Tcl command.
830     * See the user documentation for details on what it does.
831     *
832     * Results:
833     * A standard Tcl object result.
834     *
835     * Side effects:
836     * See the user documentation.
837     *
838     *----------------------------------------------------------------------
839     */
840    
841     /* ARGSUSED */
842     int
843     Tcl_SourceObjCmd(dummy, interp, objc, objv)
844     ClientData dummy; /* Not used. */
845     Tcl_Interp *interp; /* Current interpreter. */
846     int objc; /* Number of arguments. */
847     Tcl_Obj *CONST objv[]; /* Argument objects. */
848     {
849     char *bytes;
850     int result;
851    
852     if (objc != 2) {
853     Tcl_WrongNumArgs(interp, 1, objv, "fileName");
854     return TCL_ERROR;
855     }
856    
857     bytes = Tcl_GetString(objv[1]);
858     result = Tcl_EvalFile(interp, bytes);
859     return result;
860     }
861    
862     /*
863     *----------------------------------------------------------------------
864     *
865     * Tcl_SplitObjCmd --
866     *
867     * This procedure is invoked to process the "split" Tcl command.
868     * See the user documentation for details on what it does.
869     *
870     * Results:
871     * A standard Tcl result.
872     *
873     * Side effects:
874     * See the user documentation.
875     *
876     *----------------------------------------------------------------------
877     */
878    
879     /* ARGSUSED */
880     int
881     Tcl_SplitObjCmd(dummy, interp, objc, objv)
882     ClientData dummy; /* Not used. */
883     Tcl_Interp *interp; /* Current interpreter. */
884     int objc; /* Number of arguments. */
885     Tcl_Obj *CONST objv[]; /* Argument objects. */
886     {
887     Tcl_UniChar ch;
888     int len;
889     char *splitChars, *string, *end;
890     int splitCharLen, stringLen;
891     Tcl_Obj *listPtr, *objPtr;
892    
893     if (objc == 2) {
894     splitChars = " \n\t\r";
895     splitCharLen = 4;
896     } else if (objc == 3) {
897     splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen);
898     } else {
899     Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
900     return TCL_ERROR;
901     }
902    
903     string = Tcl_GetStringFromObj(objv[1], &stringLen);
904     end = string + stringLen;
905     listPtr = Tcl_GetObjResult(interp);
906    
907     if (stringLen == 0) {
908     /*
909     * Do nothing.
910     */
911     } else if (splitCharLen == 0) {
912     /*
913     * Handle the special case of splitting on every character.
914     */
915    
916     for ( ; string < end; string += len) {
917     len = Tcl_UtfToUniChar(string, &ch);
918     objPtr = Tcl_NewStringObj(string, len);
919     Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
920     }
921     } else {
922     char *element, *p, *splitEnd;
923     int splitLen;
924     Tcl_UniChar splitChar;
925    
926     /*
927     * Normal case: split on any of a given set of characters.
928     * Discard instances of the split characters.
929     */
930    
931     splitEnd = splitChars + splitCharLen;
932    
933     for (element = string; string < end; string += len) {
934     len = Tcl_UtfToUniChar(string, &ch);
935     for (p = splitChars; p < splitEnd; p += splitLen) {
936     splitLen = Tcl_UtfToUniChar(p, &splitChar);
937     if (ch == splitChar) {
938     objPtr = Tcl_NewStringObj(element, string - element);
939     Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
940     element = string + len;
941     break;
942     }
943     }
944     }
945     objPtr = Tcl_NewStringObj(element, string - element);
946     Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
947     }
948     return TCL_OK;
949     }
950    
951     /*
952     *----------------------------------------------------------------------
953     *
954     * Tcl_StringObjCmd --
955     *
956     * This procedure is invoked to process the "string" Tcl command.
957     * See the user documentation for details on what it does. Note
958     * that this command only functions correctly on properly formed
959     * Tcl UTF strings.
960     *
961     * Results:
962     * A standard Tcl result.
963     *
964     * Side effects:
965     * See the user documentation.
966     *
967     *----------------------------------------------------------------------
968     */
969    
970     /* ARGSUSED */
971     int
972     Tcl_StringObjCmd(dummy, interp, objc, objv)
973     ClientData dummy; /* Not used. */
974     Tcl_Interp *interp; /* Current interpreter. */
975     int objc; /* Number of arguments. */
976     Tcl_Obj *CONST objv[]; /* Argument objects. */
977     {
978     int index, left, right;
979     Tcl_Obj *resultPtr;
980     char *string1, *string2;
981     int length1, length2;
982     static char *options[] = {
983     "bytelength", "compare", "equal", "first",
984     "index", "is", "last", "length",
985     "map", "match", "range", "repeat",
986     "replace", "tolower", "toupper", "totitle",
987     "trim", "trimleft", "trimright",
988     "wordend", "wordstart", (char *) NULL
989     };
990     enum options {
991     STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST,
992     STR_INDEX, STR_IS, STR_LAST, STR_LENGTH,
993     STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT,
994     STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE,
995     STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT,
996     STR_WORDEND, STR_WORDSTART
997     };
998    
999     if (objc < 2) {
1000     Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
1001     return TCL_ERROR;
1002     }
1003    
1004     if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
1005     &index) != TCL_OK) {
1006     return TCL_ERROR;
1007     }
1008    
1009     resultPtr = Tcl_GetObjResult(interp);
1010     switch ((enum options) index) {
1011     case STR_EQUAL:
1012     case STR_COMPARE: {
1013     int i, match, length, nocase = 0, reqlength = -1;
1014    
1015     if (objc < 4 || objc > 7) {
1016     str_cmp_args:
1017     Tcl_WrongNumArgs(interp, 2, objv,
1018     "?-nocase? ?-length int? string1 string2");
1019     return TCL_ERROR;
1020     }
1021    
1022     for (i = 2; i < objc-2; i++) {
1023     string2 = Tcl_GetStringFromObj(objv[i], &length2);
1024     if ((length2 > 1)
1025     && strncmp(string2, "-nocase", (size_t) length2) == 0) {
1026     nocase = 1;
1027     } else if ((length2 > 1)
1028     && strncmp(string2, "-length", (size_t) length2) == 0) {
1029     if (i+1 >= objc-2) {
1030     goto str_cmp_args;
1031     }
1032     if (Tcl_GetIntFromObj(interp, objv[++i],
1033     &reqlength) != TCL_OK) {
1034     return TCL_ERROR;
1035     }
1036     } else {
1037     Tcl_AppendStringsToObj(resultPtr, "bad option \"",
1038     string2, "\": must be -nocase or -length",
1039     (char *) NULL);
1040     return TCL_ERROR;
1041     }
1042     }
1043    
1044     string1 = Tcl_GetStringFromObj(objv[objc-2], &length1);
1045     string2 = Tcl_GetStringFromObj(objv[objc-1], &length2);
1046     /*
1047     * This is the min length IN BYTES of the two strings
1048     */
1049     length = (length1 < length2) ? length1 : length2;
1050    
1051     if (reqlength == 0) {
1052     /*
1053     * Anything matches at 0 chars, right?
1054     */
1055    
1056     match = 0;
1057     } else if (nocase || ((reqlength > 0) && (reqlength <= length))) {
1058     /*
1059     * with -nocase or -length we have to check true char length
1060     * as it could be smaller than expected
1061     */
1062    
1063     length1 = Tcl_NumUtfChars(string1, length1);
1064     length2 = Tcl_NumUtfChars(string2, length2);
1065     length = (length1 < length2) ? length1 : length2;
1066    
1067     /*
1068     * Do the reqlength check again, against 0 as well for
1069     * the benfit of nocase
1070     */
1071    
1072     if ((reqlength > 0) && (reqlength < length)) {
1073     length = reqlength;
1074     } else if (reqlength < 0) {
1075     /*
1076     * The requested length is negative, so we ignore it by
1077     * setting it to the longer of the two lengths.
1078     */
1079    
1080     reqlength = (length1 > length2) ? length1 : length2;
1081     }
1082     if (nocase) {
1083     match = Tcl_UtfNcasecmp(string1, string2,
1084     (unsigned) length);
1085     } else {
1086     match = Tcl_UtfNcmp(string1, string2, (unsigned) length);
1087     }
1088     if ((match == 0) && (reqlength > length)) {
1089     match = length1 - length2;
1090     }
1091     } else {
1092     match = memcmp(string1, string2, (unsigned) length);
1093     if (match == 0) {
1094     match = length1 - length2;
1095     }
1096     }
1097    
1098     if ((enum options) index == STR_EQUAL) {
1099     Tcl_SetBooleanObj(resultPtr, (match) ? 0 : 1);
1100     } else {
1101     Tcl_SetIntObj(resultPtr, ((match > 0) ? 1 :
1102     (match < 0) ? -1 : 0));
1103     }
1104     break;
1105     }
1106     case STR_FIRST: {
1107     register char *p, *end;
1108     int match, utflen, start;
1109    
1110     if (objc < 4 || objc > 5) {
1111     Tcl_WrongNumArgs(interp, 2, objv,
1112     "string1 string2 ?startIndex?");
1113     return TCL_ERROR;
1114     }
1115    
1116     /*
1117     * This algorithm fails on improperly formed UTF strings.
1118     * We are searching string2 for the sequence string1.
1119     */
1120    
1121     match = -1;
1122     start = 0;
1123     utflen = -1;
1124     string1 = Tcl_GetStringFromObj(objv[2], &length1);
1125     string2 = Tcl_GetStringFromObj(objv[3], &length2);
1126    
1127     if (objc == 5) {
1128     /*
1129     * If a startIndex is specified, we will need to fast forward
1130     * to that point in the string before we think about a match
1131     */
1132     utflen = Tcl_NumUtfChars(string2, length2);
1133     if (TclGetIntForIndex(interp, objv[4], utflen-1,
1134     &start) != TCL_OK) {
1135     return TCL_ERROR;
1136     }
1137     if (start >= utflen) {
1138     goto str_first_done;
1139     } else if (start > 0) {
1140     if (length2 == utflen) {
1141     /* no unicode chars */
1142     string2 += start;
1143     length2 -= start;
1144     } else {
1145     char *s = Tcl_UtfAtIndex(string2, start);
1146     length2 -= s - string2;
1147     string2 = s;
1148     }
1149     }
1150     }
1151    
1152     if (length1 > 0) {
1153     end = string2 + length2 - length1 + 1;
1154     for (p = string2; p < end; p++) {
1155     /*
1156     * Scan forward to find the first character.
1157     */
1158    
1159     p = memchr(p, *string1, (unsigned) (end - p));
1160     if (p == NULL) {
1161     break;
1162     }
1163     if (memcmp(string1, p, (unsigned) length1) == 0) {
1164     match = p - string2;
1165     break;
1166     }
1167     }
1168     }
1169    
1170     /*
1171     * Compute the character index of the matching string by
1172     * counting the number of characters before the match.
1173     */
1174     str_first_done:
1175     if (match != -1) {
1176     if (objc == 4) {
1177     match = Tcl_NumUtfChars(string2, match);
1178     } else if (length2 == utflen) {
1179     /* no unicode chars */
1180     match += start;
1181     } else {
1182     match = start + Tcl_NumUtfChars(string2, match);
1183     }
1184     }
1185     Tcl_SetIntObj(resultPtr, match);
1186     break;
1187     }
1188     case STR_INDEX: {
1189     char buf[TCL_UTF_MAX];
1190     Tcl_UniChar unichar;
1191    
1192     if (objc != 4) {
1193     Tcl_WrongNumArgs(interp, 2, objv, "string charIndex");
1194     return TCL_ERROR;
1195     }
1196    
1197     /*
1198     * If we have a ByteArray object, avoid indexing in the
1199     * Utf string since the byte array contains one byte per
1200     * character. Otherwise, use the Unicode string rep to
1201     * get the index'th char.
1202     */
1203    
1204     if (objv[2]->typePtr == &tclByteArrayType) {
1205    
1206     string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1);
1207    
1208     if (TclGetIntForIndex(interp, objv[3], length1 - 1,
1209     &index) != TCL_OK) {
1210     return TCL_ERROR;
1211     }
1212     Tcl_SetByteArrayObj(resultPtr,
1213     (unsigned char *)(&string1[index]), 1);
1214     } else {
1215     string1 = Tcl_GetStringFromObj(objv[2], &length1);
1216    
1217     /*
1218     * convert to Unicode internal rep to calulate what
1219     * 'end' really means.
1220     */
1221    
1222     length2 = Tcl_GetCharLength(objv[2]);
1223    
1224     if (TclGetIntForIndex(interp, objv[3], length2 - 1,
1225     &index) != TCL_OK) {
1226     return TCL_ERROR;
1227     }
1228     if ((index >= 0) && (index < length2)) {
1229     unichar = Tcl_GetUniChar(objv[2], index);
1230     length2 = Tcl_UniCharToUtf((int)unichar, buf);
1231     Tcl_SetStringObj(resultPtr, buf, length2);
1232     }
1233     }
1234     break;
1235     }
1236     case STR_IS: {
1237     char *end;
1238     Tcl_UniChar ch;
1239    
1240     /*
1241     * The UniChar comparison function
1242     */
1243    
1244     int (*chcomp)_ANSI_ARGS_((int)) = NULL;
1245     int i, failat = 0, result = 1, strict = 0;
1246     Tcl_Obj *objPtr, *failVarObj = NULL;
1247    
1248     static char *isOptions[] = {
1249     "alnum", "alpha", "ascii", "control",
1250     "boolean", "digit", "double", "false",
1251     "graph", "integer", "lower", "print",
1252     "punct", "space", "true", "upper",
1253     "wordchar", "xdigit", (char *) NULL
1254     };
1255     enum isOptions {
1256     STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL,
1257     STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE,
1258     STR_IS_GRAPH, STR_IS_INT, STR_IS_LOWER, STR_IS_PRINT,
1259     STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER,
1260     STR_IS_WORD, STR_IS_XDIGIT
1261     };
1262    
1263     if (objc < 4 || objc > 7) {
1264     Tcl_WrongNumArgs(interp, 2, objv,
1265     "class ?-strict? ?-failindex var? str");
1266     return TCL_ERROR;
1267     }
1268     if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0,
1269     &index) != TCL_OK) {
1270     return TCL_ERROR;
1271     }
1272     if (objc != 4) {
1273     for (i = 3; i < objc-1; i++) {
1274     string2 = Tcl_GetStringFromObj(objv[i], &length2);
1275     if ((length2 > 1) &&
1276     strncmp(string2, "-strict", (size_t) length2) == 0) {
1277     strict = 1;
1278     } else if ((length2 > 1) &&
1279     strncmp(string2, "-failindex", (size_t) length2) == 0) {
1280     if (i+1 >= objc-1) {
1281     Tcl_WrongNumArgs(interp, 3, objv,
1282     "?-strict? ?-failindex var? str");
1283     return TCL_ERROR;
1284     }
1285     failVarObj = objv[++i];
1286     } else {
1287     Tcl_AppendStringsToObj(resultPtr, "bad option \"",
1288     string2, "\": must be -strict or -failindex",
1289     (char *) NULL);
1290     return TCL_ERROR;
1291     }
1292     }
1293     }
1294    
1295     /*
1296     * We get the objPtr so that we can short-cut for some classes
1297     * by checking the object type (int and double), but we need
1298     * the string otherwise, because we don't want any conversion
1299     * of type occuring (as, for example, Tcl_Get*FromObj would do
1300     */
1301     objPtr = objv[objc-1];
1302     string1 = Tcl_GetStringFromObj(objPtr, &length1);
1303     if (length1 == 0) {
1304     if (strict) {
1305     result = 0;
1306     }
1307     goto str_is_done;
1308     }
1309     end = string1 + length1;
1310    
1311     /*
1312     * When entering here, result == 1 and failat == 0
1313     */
1314     switch ((enum isOptions) index) {
1315     case STR_IS_ALNUM:
1316     chcomp = Tcl_UniCharIsAlnum;
1317     break;
1318     case STR_IS_ALPHA:
1319     chcomp = Tcl_UniCharIsAlpha;
1320     break;
1321     case STR_IS_ASCII:
1322     for (; string1 < end; string1++, failat++) {
1323     /*
1324     * This is a valid check in unicode, because all
1325     * bytes < 0xC0 are single byte chars (but isascii
1326     * limits that def'n to 0x80).
1327     */
1328     if (*((unsigned char *)string1) >= 0x80) {
1329     result = 0;
1330     break;
1331     }
1332     }
1333     break;
1334     case STR_IS_BOOL:
1335     case STR_IS_TRUE:
1336     case STR_IS_FALSE:
1337     if (objPtr->typePtr == &tclBooleanType) {
1338     if ((((enum isOptions) index == STR_IS_TRUE) &&
1339     objPtr->internalRep.longValue == 0) ||
1340     (((enum isOptions) index == STR_IS_FALSE) &&
1341     objPtr->internalRep.longValue != 0)) {
1342     result = 0;
1343     }
1344     } else if ((Tcl_GetBoolean(NULL, string1, &i)
1345     == TCL_ERROR) ||
1346     (((enum isOptions) index == STR_IS_TRUE) &&
1347     i == 0) ||
1348     (((enum isOptions) index == STR_IS_FALSE) &&
1349     i != 0)) {
1350     result = 0;
1351     }
1352     break;
1353     case STR_IS_CONTROL:
1354     chcomp = Tcl_UniCharIsControl;
1355     break;
1356     case STR_IS_DIGIT:
1357     chcomp = Tcl_UniCharIsDigit;
1358     break;
1359     case STR_IS_DOUBLE: {
1360     char *stop;
1361    
1362     if ((objPtr->typePtr == &tclDoubleType) ||
1363     (objPtr->typePtr == &tclIntType)) {
1364     break;
1365     }
1366     /*
1367     * This is adapted from Tcl_GetDouble
1368     *
1369     * The danger in this function is that
1370     * "12345678901234567890" is an acceptable 'double',
1371     * but will later be interp'd as an int by something
1372     * like [expr]. Therefore, we check to see if it looks
1373     * like an int, and if so we do a range check on it.
1374     * If strtoul gets to the end, we know we either
1375     * received an acceptable int, or over/underflow
1376     */
1377     if (TclLooksLikeInt(string1, length1)) {
1378     errno = 0;
1379     strtoul(string1, &stop, 0);
1380     if (stop == end) {
1381     if (errno == ERANGE) {
1382     result = 0;
1383     failat = -1;
1384     }
1385     break;
1386     }
1387     }
1388     errno = 0;
1389     strtod(string1, &stop); /* INTL: Tcl source. */
1390     if (errno == ERANGE) {
1391     /*
1392     * if (errno == ERANGE), then it was an over/underflow
1393     * problem, but in this method, we only want to know
1394     * yes or no, so bad flow returns 0 (false) and sets
1395     * the failVarObj to the string length.
1396     */
1397     result = 0;
1398     failat = -1;
1399     } else if (stop == string1) {
1400     /*
1401     * In this case, nothing like a number was found
1402     */
1403     result = 0;
1404     failat = 0;
1405     } else {
1406     /*
1407     * Assume we sucked up one char per byte
1408     * and then we go onto SPACE, since we are
1409     * allowed trailing whitespace
1410     */
1411     failat = stop - string1;
1412     string1 = stop;
1413     chcomp = Tcl_UniCharIsSpace;
1414     }
1415     break;
1416     }
1417     case STR_IS_GRAPH:
1418     chcomp = Tcl_UniCharIsGraph;
1419     break;
1420     case STR_IS_INT: {
1421     char *stop;
1422    
1423     if ((objPtr->typePtr == &tclIntType) ||
1424     (Tcl_GetInt(NULL, string1, &i) == TCL_OK)) {
1425     break;
1426     }
1427     /*
1428     * Like STR_IS_DOUBLE, but we use strtoul.
1429     * Since Tcl_GetInt already failed, we set result to 0.
1430     */
1431     result = 0;
1432     errno = 0;
1433     strtoul(string1, &stop, 0); /* INTL: Tcl source. */
1434     if (errno == ERANGE) {
1435     /*
1436     * if (errno == ERANGE), then it was an over/underflow
1437     * problem, but in this method, we only want to know
1438     * yes or no, so bad flow returns 0 (false) and sets
1439     * the failVarObj to the string length.
1440     */
1441     failat = -1;
1442     } else if (stop == string1) {
1443     /*
1444     * In this case, nothing like a number was found
1445     */
1446     failat = 0;
1447     } else {
1448     /*
1449     * Assume we sucked up one char per byte
1450     * and then we go onto SPACE, since we are
1451     * allowed trailing whitespace
1452     */
1453     failat = stop - string1;
1454     string1 = stop;
1455     chcomp = Tcl_UniCharIsSpace;
1456     }
1457     break;
1458     }
1459     case STR_IS_LOWER:
1460     chcomp = Tcl_UniCharIsLower;
1461     break;
1462     case STR_IS_PRINT:
1463     chcomp = Tcl_UniCharIsPrint;
1464     break;
1465     case STR_IS_PUNCT:
1466     chcomp = Tcl_UniCharIsPunct;
1467     break;
1468     case STR_IS_SPACE:
1469     chcomp = Tcl_UniCharIsSpace;
1470     break;
1471     case STR_IS_UPPER:
1472     chcomp = Tcl_UniCharIsUpper;
1473     break;
1474     case STR_IS_WORD:
1475     chcomp = Tcl_UniCharIsWordChar;
1476     break;
1477     case STR_IS_XDIGIT: {
1478     for (; string1 < end; string1++, failat++) {
1479     /* INTL: We assume unicode is bad for this class */
1480     if ((*((unsigned char *)string1) >= 0xC0) ||
1481     !isxdigit(*(unsigned char *)string1)) {
1482     result = 0;
1483     break;
1484     }
1485     }
1486     break;
1487     }
1488     }
1489     if (chcomp != NULL) {
1490     for (; string1 < end; string1 += length2, failat++) {
1491     length2 = Tcl_UtfToUniChar(string1, &ch);
1492     if (!chcomp(ch)) {
1493     result = 0;
1494     break;
1495     }
1496     }
1497     }
1498     str_is_done:
1499     /*
1500     * Only set the failVarObj when we will return 0
1501     * and we have indicated a valid fail index (>= 0)
1502     */
1503     if ((result == 0) && (failVarObj != NULL) &&
1504     Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat),
1505     TCL_LEAVE_ERR_MSG) == NULL) {
1506     return TCL_ERROR;
1507     }
1508     Tcl_SetBooleanObj(resultPtr, result);
1509     break;
1510     }
1511     case STR_LAST: {
1512     register char *p;
1513     int match, utflen, start;
1514    
1515     if (objc < 4 || objc > 5) {
1516     Tcl_WrongNumArgs(interp, 2, objv,
1517     "string1 string2 ?startIndex?");
1518     return TCL_ERROR;
1519     }
1520    
1521     /*
1522     * This algorithm fails on improperly formed UTF strings.
1523     */
1524    
1525     match = -1;
1526     start = 0;
1527     utflen = -1;
1528     string1 = Tcl_GetStringFromObj(objv[2], &length1);
1529     string2 = Tcl_GetStringFromObj(objv[3], &length2);
1530    
1531     if (objc == 5) {
1532     /*
1533     * If a startIndex is specified, we will need to restrict
1534     * the string range to that char index in the string
1535     */
1536     utflen = Tcl_NumUtfChars(string2, length2);
1537     if (TclGetIntForIndex(interp, objv[4], utflen-1,
1538     &start) != TCL_OK) {
1539     return TCL_ERROR;
1540     }
1541     if (start < 0) {
1542     goto str_last_done;
1543     } else if (start < utflen) {
1544     if (length2 == utflen) {
1545     /* no unicode chars */
1546     p = string2 + start + 1 - length1;
1547     } else {
1548     p = Tcl_UtfAtIndex(string2, start+1) - length1;
1549     }
1550     } else {
1551     p = string2 + length2 - length1;
1552     }
1553     } else {
1554     p = string2 + length2 - length1;
1555     }
1556    
1557     if (length1 > 0) {
1558     for (; p >= string2; p--) {
1559     /*
1560     * Scan backwards to find the first character.
1561     */
1562    
1563     while ((p != string2) && (*p != *string1)) {
1564     p--;
1565     }
1566     if (memcmp(string1, p, (unsigned) length1) == 0) {
1567     match = p - string2;
1568     break;
1569     }
1570     }
1571     }
1572    
1573     /*
1574     * Compute the character index of the matching string by counting
1575     * the number of characters before the match.
1576     */
1577     str_last_done:
1578     if (match != -1) {
1579     if ((objc == 4) || (length2 != utflen)) {
1580     /* only check when we've got unicode chars */
1581     match = Tcl_NumUtfChars(string2, match);
1582     }
1583     }
1584     Tcl_SetIntObj(resultPtr, match);
1585     break;
1586     }
1587     case STR_BYTELENGTH:
1588     case STR_LENGTH: {
1589     if (objc != 3) {
1590     Tcl_WrongNumArgs(interp, 2, objv, "string");
1591     return TCL_ERROR;
1592     }
1593    
1594     if ((enum options) index == STR_BYTELENGTH) {
1595     (void) Tcl_GetStringFromObj(objv[2], &length1);
1596     Tcl_SetIntObj(resultPtr, length1);
1597     } else {
1598     /*
1599     * If we have a ByteArray object, avoid recomputing the
1600     * string since the byte array contains one byte per
1601     * character. Otherwise, use the Unicode string rep to
1602     * calculate the length.
1603     */
1604    
1605     if (objv[2]->typePtr == &tclByteArrayType) {
1606     (void) Tcl_GetByteArrayFromObj(objv[2], &length1);
1607     Tcl_SetIntObj(resultPtr, length1);
1608     } else {
1609     Tcl_SetIntObj(resultPtr,
1610     Tcl_GetCharLength(objv[2]));
1611     }
1612     }
1613     break;
1614     }
1615     case STR_MAP: {
1616     int uselen, mapElemc, len, nocase = 0;
1617     Tcl_Obj **mapElemv;
1618     char *end;
1619     Tcl_UniChar ch;
1620     int (*str_comp_fn)();
1621    
1622     if (objc < 4 || objc > 5) {
1623     Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string");
1624     return TCL_ERROR;
1625     }
1626    
1627     if (objc == 5) {
1628     string2 = Tcl_GetStringFromObj(objv[2], &length2);
1629     if ((length2 > 1) &&
1630     strncmp(string2, "-nocase", (size_t) length2) == 0) {
1631     nocase = 1;
1632     } else {
1633     Tcl_AppendStringsToObj(resultPtr, "bad option \"",
1634     string2, "\": must be -nocase",
1635     (char *) NULL);
1636     return TCL_ERROR;
1637     }
1638     }
1639    
1640     if (Tcl_ListObjGetElements(interp, objv[objc-2], &mapElemc,
1641     &mapElemv) != TCL_OK) {
1642     return TCL_ERROR;
1643     }
1644     if (mapElemc == 0) {
1645     /*
1646     * empty charMap, just return whatever string was given
1647     */
1648     Tcl_SetObjResult(interp, objv[objc-1]);
1649     } else if (mapElemc & 1) {
1650     /*
1651     * The charMap must be an even number of key/value items
1652     */
1653     Tcl_SetStringObj(resultPtr, "char map list unbalanced", -1);
1654     return TCL_ERROR;
1655     }
1656     string1 = Tcl_GetStringFromObj(objv[objc-1], &length1);
1657     if (length1 == 0) {
1658     break;
1659     }
1660     end = string1 + length1;
1661    
1662     if (nocase) {
1663     length1 = Tcl_NumUtfChars(string1, length1);
1664     str_comp_fn = Tcl_UtfNcasecmp;
1665     } else {
1666     str_comp_fn = memcmp;
1667     }
1668    
1669     for ( ; string1 < end; string1 += len) {
1670     len = Tcl_UtfToUniChar(string1, &ch);
1671     for (index = 0; index < mapElemc; index +=2) {
1672     /*
1673     * Get the key string to match on
1674     */
1675     string2 = Tcl_GetStringFromObj(mapElemv[index],
1676     &length2);
1677     if (nocase) {
1678     uselen = Tcl_NumUtfChars(string2, length2);
1679     } else {
1680     uselen = length2;
1681     }
1682     if ((uselen > 0) && (uselen <= length1) &&
1683     (str_comp_fn(string2, string1, uselen) == 0)) {
1684     /*
1685     * Adjust len to be full length of matched string
1686     * it has to be the BYTE length
1687     */
1688     len = length2;
1689     /*
1690     * Change string2 and length2 to the map value
1691     */
1692     string2 = Tcl_GetStringFromObj(mapElemv[index+1],
1693     &length2);
1694     Tcl_AppendToObj(resultPtr, string2, length2);
1695     break;
1696     }
1697     }
1698     if (index == mapElemc) {
1699     /*
1700     * No match was found, put the char onto result
1701     */
1702     Tcl_AppendToObj(resultPtr, string1, len);
1703     }
1704     /*
1705     * in nocase, length1 is in chars
1706     * otherwise it is in bytes
1707     */
1708     if (nocase) {
1709     length1--;
1710     } else {
1711     length1 -= len;
1712     }
1713     }
1714     break;
1715     }
1716     case STR_MATCH: {
1717     int nocase = 0;
1718    
1719     if (objc < 4 || objc > 5) {
1720     Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string");
1721     return TCL_ERROR;
1722     }
1723    
1724     if (objc == 5) {
1725     string2 = Tcl_GetStringFromObj(objv[2], &length2);
1726     if ((length2 > 1) &&
1727     strncmp(string2, "-nocase", (size_t) length2) == 0) {
1728     nocase = 1;
1729     } else {
1730     Tcl_AppendStringsToObj(resultPtr, "bad option \"",
1731     string2, "\": must be -nocase",
1732     (char *) NULL);
1733     return TCL_ERROR;
1734     }
1735     }
1736    
1737     Tcl_SetBooleanObj(resultPtr,
1738     Tcl_StringCaseMatch(Tcl_GetString(objv[objc-1]),
1739     Tcl_GetString(objv[objc-2]),
1740     nocase));
1741     break;
1742     }
1743     case STR_RANGE: {
1744     int first, last;
1745    
1746     if (objc != 5) {
1747     Tcl_WrongNumArgs(interp, 2, objv, "string first last");
1748     return TCL_ERROR;
1749     }
1750    
1751     /*
1752     * If we have a ByteArray object, avoid indexing in the
1753     * Utf string since the byte array contains one byte per
1754     * character. Otherwise, use the Unicode string rep to
1755     * get the range.
1756     */
1757    
1758     if (objv[2]->typePtr == &tclByteArrayType) {
1759    
1760     string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1);
1761    
1762     if (TclGetIntForIndex(interp, objv[3], length1 - 1,
1763     &first) != TCL_OK) {
1764     return TCL_ERROR;
1765     }
1766     if (TclGetIntForIndex(interp, objv[4], length1 - 1,
1767     &last) != TCL_OK) {
1768     return TCL_ERROR;
1769     }
1770     if (first < 0) {
1771     first = 0;
1772     }
1773     if (last >= length1 - 1) {
1774     last = length1 - 1;
1775     }
1776     if (last >= first) {
1777     int numBytes = last - first + 1;
1778     resultPtr = Tcl_NewByteArrayObj(
1779     (unsigned char *) &string1[first], numBytes);
1780     Tcl_SetObjResult(interp, resultPtr);
1781     }
1782     } else {
1783     string1 = Tcl_GetStringFromObj(objv[2], &length1);
1784    
1785     /*
1786     * Convert to Unicode internal rep to calulate length and
1787     * create a result object.
1788     */
1789    
1790     length2 = Tcl_GetCharLength(objv[2]) - 1;
1791    
1792     if (TclGetIntForIndex(interp, objv[3], length2,
1793     &first) != TCL_OK) {
1794     return TCL_ERROR;
1795     }
1796     if (TclGetIntForIndex(interp, objv[4], length2,
1797     &last) != TCL_OK) {
1798     return TCL_ERROR;
1799     }
1800     if (first < 0) {
1801     first = 0;
1802     }
1803     if (last >= length2) {
1804     last = length2;
1805     }
1806     if (last >= first) {
1807     resultPtr = Tcl_GetRange(objv[2], first, last);
1808     Tcl_SetObjResult(interp, resultPtr);
1809     }
1810     }
1811     break;
1812     }
1813     case STR_REPEAT: {
1814     int count;
1815    
1816     if (objc != 4) {
1817     Tcl_WrongNumArgs(interp, 2, objv, "string count");
1818     return TCL_ERROR;
1819     }
1820    
1821     if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) {
1822     return TCL_ERROR;
1823     }
1824    
1825     string1 = Tcl_GetStringFromObj(objv[2], &length1);
1826     if (length1 > 0) {
1827     for (index = 0; index < count; index++) {
1828     Tcl_AppendToObj(resultPtr, string1, length1);
1829     }
1830     }
1831     break;
1832     }
1833     case STR_REPLACE: {
1834     int first, last;
1835    
1836     if (objc < 5 || objc > 6) {
1837     Tcl_WrongNumArgs(interp, 2, objv,
1838     "string first last ?string?");
1839     return TCL_ERROR;
1840     }
1841    
1842     string1 = Tcl_GetStringFromObj(objv[2], &length1);
1843     length1 = Tcl_NumUtfChars(string1, length1) - 1;
1844     if (TclGetIntForIndex(interp, objv[3], length1,
1845     &first) != TCL_OK) {
1846     return TCL_ERROR;
1847     }
1848     if (TclGetIntForIndex(interp, objv[4], length1,
1849     &last) != TCL_OK) {
1850     return TCL_ERROR;
1851     }
1852     if ((last < first) || (first > length1) || (last < 0)) {
1853     Tcl_SetObjResult(interp, objv[2]);
1854     } else {
1855     char *start, *end;
1856    
1857     if (first < 0) {
1858     first = 0;
1859     }
1860     start = Tcl_UtfAtIndex(string1, first);
1861     end = Tcl_UtfAtIndex(start, ((last > length1) ? length1 : last)
1862     - first + 1);
1863     Tcl_SetStringObj(resultPtr, string1, start - string1);
1864     if (objc == 6) {
1865     Tcl_AppendObjToObj(resultPtr, objv[5]);
1866     }
1867     if (last < length1) {
1868     Tcl_AppendToObj(resultPtr, end, -1);
1869     }
1870     }
1871     break;
1872     }
1873     case STR_TOLOWER:
1874     case STR_TOUPPER:
1875     case STR_TOTITLE:
1876     if (objc < 3 || objc > 5) {
1877     Tcl_WrongNumArgs(interp, 2, objv, "string ?first? ?last?");
1878     return TCL_ERROR;
1879     }
1880    
1881     string1 = Tcl_GetStringFromObj(objv[2], &length1);
1882    
1883     if (objc == 3) {
1884     /*
1885     * Since the result object is not a shared object, it is
1886     * safe to copy the string into the result and do the
1887     * conversion in place. The conversion may change the length
1888     * of the string, so reset the length after conversion.
1889     */
1890    
1891     Tcl_SetStringObj(resultPtr, string1, length1);
1892     if ((enum options) index == STR_TOLOWER) {
1893     length1 = Tcl_UtfToLower(Tcl_GetString(resultPtr));
1894     } else if ((enum options) index == STR_TOUPPER) {
1895     length1 = Tcl_UtfToUpper(Tcl_GetString(resultPtr));
1896     } else {
1897     length1 = Tcl_UtfToTitle(Tcl_GetString(resultPtr));
1898     }
1899     Tcl_SetObjLength(resultPtr, length1);
1900     } else {
1901     int first, last;
1902     char *start, *end;
1903    
1904     length1 = Tcl_NumUtfChars(string1, length1) - 1;
1905     if (TclGetIntForIndex(interp, objv[3], length1,
1906     &first) != TCL_OK) {
1907     return TCL_ERROR;
1908     }
1909     if (first < 0) {
1910     first = 0;
1911     }
1912     last = first;
1913     if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1,
1914     &last) != TCL_OK)) {
1915     return TCL_ERROR;
1916     }
1917     if (last >= length1) {
1918     last = length1;
1919     }
1920     if (last < first) {
1921     Tcl_SetObjResult(interp, objv[2]);
1922     break;
1923     }
1924     start = Tcl_UtfAtIndex(string1, first);
1925     end = Tcl_UtfAtIndex(start, last - first + 1);
1926     length2 = end-start;
1927     string2 = ckalloc((size_t) length2+1);
1928     memcpy(string2, start, (size_t) length2);
1929     string2[length2] = '\0';
1930     if ((enum options) index == STR_TOLOWER) {
1931     length2 = Tcl_UtfToLower(string2);
1932     } else if ((enum options) index == STR_TOUPPER) {
1933     length2 = Tcl_UtfToUpper(string2);
1934     } else {
1935     length2 = Tcl_UtfToTitle(string2);
1936     }
1937     Tcl_SetStringObj(resultPtr, string1, start - string1);
1938     Tcl_AppendToObj(resultPtr, string2, length2);
1939     Tcl_AppendToObj(resultPtr, end, -1);
1940     ckfree(string2);
1941     }
1942     break;
1943    
1944     case STR_TRIM: {
1945     Tcl_UniChar ch, trim;
1946     register char *p, *end;
1947     char *check, *checkEnd;
1948     int offset;
1949    
1950     left = 1;
1951     right = 1;
1952    
1953     dotrim:
1954     if (objc == 4) {
1955     string2 = Tcl_GetStringFromObj(objv[3], &length2);
1956     } else if (objc == 3) {
1957     string2 = " \t\n\r";
1958     length2 = strlen(string2);
1959     } else {
1960     Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?");
1961     return TCL_ERROR;
1962     }
1963     string1 = Tcl_GetStringFromObj(objv[2], &length1);
1964     checkEnd = string2 + length2;
1965    
1966     if (left) {
1967     end = string1 + length1;
1968     /*
1969     * The outer loop iterates over the string. The inner
1970     * loop iterates over the trim characters. The loops
1971     * terminate as soon as a non-trim character is discovered
1972     * and string1 is left pointing at the first non-trim
1973     * character.
1974     */
1975    
1976     for (p = string1; p < end; p += offset) {
1977     offset = Tcl_UtfToUniChar(p, &ch);
1978    
1979     for (check = string2; ; ) {
1980     if (check >= checkEnd) {
1981     p = end;
1982     break;
1983     }
1984     check += Tcl_UtfToUniChar(check, &trim);
1985     if (ch == trim) {
1986     length1 -= offset;
1987     string1 += offset;
1988     break;
1989     }
1990     }
1991     }
1992     }
1993     if (right) {
1994     end = string1;
1995    
1996     /*
1997     * The outer loop iterates over the string. The inner
1998     * loop iterates over the trim characters. The loops
1999     * terminate as soon as a non-trim character is discovered
2000     * and length1 marks the last non-trim character.
2001     */
2002    
2003     for (p = string1 + length1; p > end; ) {
2004     p = Tcl_UtfPrev(p, string1);
2005     offset = Tcl_UtfToUniChar(p, &ch);
2006     for (check = string2; ; ) {
2007     if (check >= checkEnd) {
2008     p = end;
2009     break;
2010     }
2011     check += Tcl_UtfToUniChar(check, &trim);
2012     if (ch == trim) {
2013     length1 -= offset;
2014     break;
2015     }
2016     }
2017     }
2018     }
2019     Tcl_SetStringObj(resultPtr, string1, length1);
2020     break;
2021     }
2022     case STR_TRIMLEFT: {
2023     left = 1;
2024     right = 0;
2025     goto dotrim;
2026     }
2027     case STR_TRIMRIGHT: {
2028     left = 0;
2029     right = 1;
2030     goto dotrim;
2031     }
2032     case STR_WORDEND: {
2033     int cur;
2034     Tcl_UniChar ch;
2035     char *p, *end;
2036     int numChars;
2037    
2038     if (objc != 4) {
2039     Tcl_WrongNumArgs(interp, 2, objv, "string index");
2040     return TCL_ERROR;
2041     }
2042    
2043     string1 = Tcl_GetStringFromObj(objv[2], &length1);
2044     numChars = Tcl_NumUtfChars(string1, length1);
2045     if (TclGetIntForIndex(interp, objv[3], numChars-1,
2046     &index) != TCL_OK) {
2047     return TCL_ERROR;
2048     }
2049     if (index < 0) {
2050     index = 0;
2051     }
2052     if (index < numChars) {
2053     p = Tcl_UtfAtIndex(string1, index);
2054     end = string1+length1;
2055     for (cur = index; p < end; cur++) {
2056     p += Tcl_UtfToUniChar(p, &ch);
2057     if (!Tcl_UniCharIsWordChar(ch)) {
2058     break;
2059     }
2060     }
2061     if (cur == index) {
2062     cur++;
2063     }
2064     } else {
2065     cur = numChars;
2066     }
2067     Tcl_SetIntObj(resultPtr, cur);
2068     break;
2069     }
2070     case STR_WORDSTART: {
2071     int cur;
2072     Tcl_UniChar ch;
2073     char *p;
2074     int numChars;
2075    
2076     if (objc != 4) {
2077     Tcl_WrongNumArgs(interp, 2, objv, "string index");
2078     return TCL_ERROR;
2079     }
2080    
2081     string1 = Tcl_GetStringFromObj(objv[2], &length1);
2082     numChars = Tcl_NumUtfChars(string1, length1);
2083     if (TclGetIntForIndex(interp, objv[3], numChars-1,
2084     &index) != TCL_OK) {
2085     return TCL_ERROR;
2086     }
2087     if (index >= numChars) {
2088     index = numChars - 1;
2089     }
2090     cur = 0;
2091     if (index > 0) {
2092     p = Tcl_UtfAtIndex(string1, index);
2093     for (cur = index; cur >= 0; cur--) {
2094     Tcl_UtfToUniChar(p, &ch);
2095     if (!Tcl_UniCharIsWordChar(ch)) {
2096     break;
2097     }
2098     p = Tcl_UtfPrev(p, string1);
2099     }
2100     if (cur != index) {
2101     cur += 1;
2102     }
2103     }
2104     Tcl_SetIntObj(resultPtr, cur);
2105     break;
2106     }
2107     }
2108     return TCL_OK;
2109     }
2110    
2111     /*
2112     *----------------------------------------------------------------------
2113     *
2114     * Tcl_SubstObjCmd --
2115     *
2116     * This procedure is invoked to process the "subst" Tcl command.
2117     * See the user documentation for details on what it does. This
2118     * command is an almost direct copy of an implementation by
2119     * Andrew Payne.
2120     *
2121     * Results:
2122     * A standard Tcl result.
2123     *
2124     * Side effects:
2125     * See the user documentation.
2126     *
2127     *----------------------------------------------------------------------
2128     */
2129    
2130     /* ARGSUSED */
2131     int
2132     Tcl_SubstObjCmd(dummy, interp, objc, objv)
2133     ClientData dummy; /* Not used. */
2134     Tcl_Interp *interp; /* Current interpreter. */
2135     int objc; /* Number of arguments. */
2136     Tcl_Obj *CONST objv[]; /* Argument objects. */
2137     {
2138     static char *substOptions[] = {
2139     "-nobackslashes", "-nocommands", "-novariables", (char *) NULL
2140     };
2141     enum substOptions {
2142     SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS
2143     };
2144     Interp *iPtr = (Interp *) interp;
2145     Tcl_DString result;
2146     char *p, *old, *value;
2147     int optionIndex, code, count, doVars, doCmds, doBackslashes, i;
2148    
2149     /*
2150     * Parse command-line options.
2151     */
2152    
2153     doVars = doCmds = doBackslashes = 1;
2154     for (i = 1; i < (objc-1); i++) {
2155     p = Tcl_GetString(objv[i]);
2156     if (*p != '-') {
2157     break;
2158     }
2159     if (Tcl_GetIndexFromObj(interp, objv[i], substOptions,
2160     "switch", 0, &optionIndex) != TCL_OK) {
2161    
2162     return TCL_ERROR;
2163     }
2164     switch (optionIndex) {
2165     case SUBST_NOBACKSLASHES: {
2166     doBackslashes = 0;
2167     break;
2168     }
2169     case SUBST_NOCOMMANDS: {
2170     doCmds = 0;
2171     break;
2172     }
2173     case SUBST_NOVARS: {
2174     doVars = 0;
2175     break;
2176     }
2177     default: {
2178     panic("Tcl_SubstObjCmd: bad option index to SubstOptions");
2179     }
2180     }
2181     }
2182     if (i != (objc-1)) {
2183     Tcl_WrongNumArgs(interp, 1, objv,
2184     "?-nobackslashes? ?-nocommands? ?-novariables? string");
2185     return TCL_ERROR;
2186     }
2187    
2188     /*
2189     * Scan through the string one character at a time, performing
2190     * command, variable, and backslash substitutions.
2191     */
2192    
2193     Tcl_DStringInit(&result);
2194     old = p = Tcl_GetString(objv[i]);
2195     while (*p != 0) {
2196     switch (*p) {
2197     case '\\':
2198     if (doBackslashes) {
2199     char buf[TCL_UTF_MAX];
2200    
2201     if (p != old) {
2202     Tcl_DStringAppend(&result, old, p-old);
2203     }
2204     Tcl_DStringAppend(&result, buf,
2205     Tcl_UtfBackslash(p, &count, buf));
2206     p += count;
2207     old = p;
2208     } else {
2209     p++;
2210     }
2211     break;
2212    
2213     case '$':
2214     if (doVars) {
2215     if (p != old) {
2216     Tcl_DStringAppend(&result, old, p-old);
2217     }
2218     value = Tcl_ParseVar(interp, p, &p);
2219     if (value == NULL) {
2220     Tcl_DStringFree(&result);
2221     return TCL_ERROR;
2222     }
2223     Tcl_DStringAppend(&result, value, -1);
2224     old = p;
2225     } else {
2226     p++;
2227     }
2228     break;
2229    
2230     case '[':
2231     if (doCmds) {
2232     if (p != old) {
2233     Tcl_DStringAppend(&result, old, p-old);
2234     }
2235     iPtr->evalFlags = TCL_BRACKET_TERM;
2236     code = Tcl_Eval(interp, p+1);
2237     if (code == TCL_ERROR) {
2238     Tcl_DStringFree(&result);
2239     return code;
2240     }
2241     old = p = (p+1 + iPtr->termOffset+1);
2242     Tcl_DStringAppend(&result, iPtr->result, -1);
2243     Tcl_ResetResult(interp);
2244     } else {
2245     p++;
2246     }
2247     break;
2248    
2249     default:
2250     p++;
2251     break;
2252     }
2253     }
2254     if (p != old) {
2255     Tcl_DStringAppend(&result, old, p-old);
2256     }
2257     Tcl_DStringResult(interp, &result);
2258     return TCL_OK;
2259     }
2260    
2261     /*
2262     *----------------------------------------------------------------------
2263     *
2264     * Tcl_SwitchObjCmd --
2265     *
2266     * This object-based procedure is invoked to process the "switch" Tcl
2267     * command. See the user documentation for details on what it does.
2268     *
2269     * Results:
2270     * A standard Tcl object result.
2271     *
2272     * Side effects:
2273     * See the user documentation.
2274     *
2275     *----------------------------------------------------------------------
2276     */
2277    
2278     /* ARGSUSED */
2279     int
2280     Tcl_SwitchObjCmd(dummy, interp, objc, objv)
2281     ClientData dummy; /* Not used. */
2282     Tcl_Interp *interp; /* Current interpreter. */
2283     int objc; /* Number of arguments. */
2284     Tcl_Obj *CONST objv[]; /* Argument objects. */
2285     {
2286     int i, j, index, mode, matched, result, splitObjs, seenComment;
2287     char *string, *pattern;
2288     Tcl_Obj *stringObj;
2289     static char *options[] = {
2290     "-exact", "-glob", "-regexp", "--",
2291     NULL
2292     };
2293     enum options {
2294     OPT_EXACT, OPT_GLOB, OPT_REGEXP, OPT_LAST
2295     };
2296    
2297     mode = OPT_EXACT;
2298     for (i = 1; i < objc; i++) {
2299     string = Tcl_GetString(objv[i]);
2300     if (string[0] != '-') {
2301     break;
2302     }
2303     if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
2304     &index) != TCL_OK) {
2305     return TCL_ERROR;
2306     }
2307     if (index == OPT_LAST) {
2308     i++;
2309     break;
2310     }
2311     mode = index;
2312     }
2313    
2314     if (objc - i < 2) {
2315     Tcl_WrongNumArgs(interp, 1, objv,
2316     "?switches? string pattern body ... ?default body?");
2317     return TCL_ERROR;
2318     }
2319    
2320     stringObj = objv[i];
2321     objc -= i + 1;
2322     objv += i + 1;
2323    
2324     /*
2325     * If all of the pattern/command pairs are lumped into a single
2326     * argument, split them out again.
2327     */
2328    
2329     splitObjs = 0;
2330     if (objc == 1) {
2331     Tcl_Obj **listv;
2332    
2333     if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) {
2334     return TCL_ERROR;
2335     }
2336     objv = listv;
2337     splitObjs = 1;
2338     }
2339    
2340     seenComment = 0;
2341     for (i = 0; i < objc; i += 2) {
2342     if (i == objc - 1) {
2343     Tcl_ResetResult(interp);
2344     Tcl_AppendToObj(Tcl_GetObjResult(interp),
2345     "extra switch pattern with no body", -1);
2346    
2347     /*
2348     * Check if this can be due to a badly placed comment
2349     * in the switch block
2350     */
2351    
2352     if (splitObjs && seenComment) {
2353     Tcl_AppendToObj(Tcl_GetObjResult(interp),
2354     ", this may be due to a comment incorrectly placed outside of a switch body - see the \"switch\" documentation", -1);
2355     }
2356    
2357     return TCL_ERROR;
2358     }
2359    
2360     /*
2361     * See if the pattern matches the string.
2362     */
2363    
2364     pattern = Tcl_GetString(objv[i]);
2365    
2366     /*
2367     * The following is an heuristic to detect the infamous
2368     * "comment in switch" error: just check if a pattern
2369     * begins with '#'.
2370     */
2371    
2372     if (splitObjs && *pattern == '#') {
2373     seenComment = 1;
2374     }
2375    
2376     matched = 0;
2377     if ((i == objc - 2)
2378     && (*pattern == 'd')
2379     && (strcmp(pattern, "default") == 0)) {
2380     matched = 1;
2381     } else {
2382     switch (mode) {
2383     case OPT_EXACT:
2384     matched = (strcmp(Tcl_GetString(stringObj), pattern) == 0);
2385     break;
2386     case OPT_GLOB:
2387     matched = Tcl_StringMatch(Tcl_GetString(stringObj),
2388     pattern);
2389     break;
2390     case OPT_REGEXP:
2391     matched = Tcl_RegExpMatchObj(interp, stringObj, objv[i]);
2392     if (matched < 0) {
2393     return TCL_ERROR;
2394     }
2395     break;
2396     }
2397     }
2398     if (matched == 0) {
2399     continue;
2400     }
2401    
2402     /*
2403     * We've got a match. Find a body to execute, skipping bodies
2404     * that are "-".
2405     */
2406    
2407     for (j = i + 1; ; j += 2) {
2408     if (j >= objc) {
2409     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
2410     "no body specified for pattern \"", pattern,
2411     "\"", (char *) NULL);
2412     return TCL_ERROR;
2413     }
2414     if (strcmp(Tcl_GetString(objv[j]), "-") != 0) {
2415     break;
2416     }
2417     }
2418     result = Tcl_EvalObjEx(interp, objv[j], 0);
2419     if (result == TCL_ERROR) {
2420     char msg[100 + TCL_INTEGER_SPACE];
2421    
2422     sprintf(msg, "\n (\"%.50s\" arm line %d)", pattern,
2423     interp->errorLine);
2424     Tcl_AddObjErrorInfo(interp, msg, -1);
2425     }
2426     return result;
2427     }
2428     return TCL_OK;
2429     }
2430    
2431     /*
2432     *----------------------------------------------------------------------
2433     *
2434     * Tcl_TimeObjCmd --
2435     *
2436     * This object-based procedure is invoked to process the "time" Tcl
2437     * command. See the user documentation for details on what it does.
2438     *
2439     * Results:
2440     * A standard Tcl object result.
2441     *
2442     * Side effects:
2443     * See the user documentation.
2444     *
2445     *----------------------------------------------------------------------
2446     */
2447    
2448     /* ARGSUSED */
2449     int
2450     Tcl_TimeObjCmd(dummy, interp, objc, objv)
2451     ClientData dummy; /* Not used. */
2452     Tcl_Interp *interp; /* Current interpreter. */
2453     int objc; /* Number of arguments. */
2454     Tcl_Obj *CONST objv[]; /* Argument objects. */
2455     {
2456     register Tcl_Obj *objPtr;
2457     register int i, result;
2458     int count;
2459     double totalMicroSec;
2460     Tcl_Time start, stop;
2461     char buf[100];
2462    
2463     if (objc == 2) {
2464     count = 1;
2465     } else if (objc == 3) {
2466     result = Tcl_GetIntFromObj(interp, objv[2], &count);
2467     if (result != TCL_OK) {
2468     return result;
2469     }
2470     } else {
2471     Tcl_WrongNumArgs(interp, 1, objv, "command ?count?");
2472     return TCL_ERROR;
2473     }
2474    
2475     objPtr = objv[1];
2476     i = count;
2477     TclpGetTime(&start);
2478     while (i-- > 0) {
2479     result = Tcl_EvalObjEx(interp, objPtr, 0);
2480     if (result != TCL_OK) {
2481     return result;
2482     }
2483     }
2484     TclpGetTime(&stop);
2485    
2486     totalMicroSec =
2487     (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
2488     sprintf(buf, "%.0f microseconds per iteration",
2489     ((count <= 0) ? 0 : totalMicroSec/count));
2490     Tcl_ResetResult(interp);
2491     Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
2492     return TCL_OK;
2493     }
2494    
2495     /*
2496     *----------------------------------------------------------------------
2497     *
2498     * Tcl_TraceObjCmd --
2499     *
2500     * This procedure is invoked to process the "trace" Tcl command.
2501     * See the user documentation for details on what it does.
2502     *
2503     * Results:
2504     * A standard Tcl result.
2505     *
2506     * Side effects:
2507     * See the user documentation.
2508     *
2509     *----------------------------------------------------------------------
2510     */
2511    
2512     /* ARGSUSED */
2513     int
2514     Tcl_TraceObjCmd(dummy, interp, objc, objv)
2515     ClientData dummy; /* Not used. */
2516     Tcl_Interp *interp; /* Current interpreter. */
2517     int objc; /* Number of arguments. */
2518     Tcl_Obj *CONST objv[]; /* Argument objects. */
2519     {
2520     int optionIndex, commandLength;
2521     char *name, *rwuOps, *command, *p;
2522     size_t length;
2523     static char *traceOptions[] = {
2524     "variable", "vdelete", "vinfo", (char *) NULL
2525     };
2526     enum traceOptions {
2527     TRACE_VARIABLE, TRACE_VDELETE, TRACE_VINFO
2528     };
2529    
2530     if (objc < 2) {
2531     Tcl_WrongNumArgs(interp, 1, objv, "option [arg arg ...]");
2532     return TCL_ERROR;
2533     }
2534    
2535     if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions,
2536     "option", 0, &optionIndex) != TCL_OK) {
2537     return TCL_ERROR;
2538     }
2539     switch ((enum traceOptions) optionIndex) {
2540     case TRACE_VARIABLE: {
2541     int flags;
2542     TraceVarInfo *tvarPtr;
2543     if (objc != 5) {
2544     Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
2545     return TCL_ERROR;
2546     }
2547    
2548     flags = 0;
2549     rwuOps = Tcl_GetString(objv[3]);
2550     for (p = rwuOps; *p != 0; p++) {
2551     if (*p == 'r') {
2552     flags |= TCL_TRACE_READS;
2553     } else if (*p == 'w') {
2554     flags |= TCL_TRACE_WRITES;
2555     } else if (*p == 'u') {
2556     flags |= TCL_TRACE_UNSETS;
2557     } else {
2558     goto badOps;
2559     }
2560     }
2561     if (flags == 0) {
2562     goto badOps;
2563     }
2564    
2565     command = Tcl_GetStringFromObj(objv[4], &commandLength);
2566     length = (size_t) commandLength;
2567     tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
2568     (sizeof(TraceVarInfo) - sizeof(tvarPtr->command)
2569     + length + 1));
2570     tvarPtr->flags = flags;
2571     tvarPtr->errMsg = NULL;
2572     tvarPtr->length = length;
2573     flags |= TCL_TRACE_UNSETS;
2574     strcpy(tvarPtr->command, command);
2575     name = Tcl_GetString(objv[2]);
2576     if (Tcl_TraceVar(interp, name, flags, TraceVarProc,
2577     (ClientData) tvarPtr) != TCL_OK) {
2578     ckfree((char *) tvarPtr);
2579     return TCL_ERROR;
2580     }
2581     break;
2582     }
2583     case TRACE_VDELETE: {
2584     int flags;
2585     TraceVarInfo *tvarPtr;
2586     ClientData clientData;
2587    
2588     if (objc != 5) {
2589     Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
2590     return TCL_ERROR;
2591     }
2592    
2593     flags = 0;
2594     rwuOps = Tcl_GetString(objv[3]);
2595     for (p = rwuOps; *p != 0; p++) {
2596     if (*p == 'r') {
2597     flags |= TCL_TRACE_READS;
2598     } else if (*p == 'w') {
2599     flags |= TCL_TRACE_WRITES;
2600     } else if (*p == 'u') {
2601     flags |= TCL_TRACE_UNSETS;
2602     } else {
2603     goto badOps;
2604     }
2605     }
2606     if (flags == 0) {
2607     goto badOps;
2608     }
2609    
2610     /*
2611     * Search through all of our traces on this variable to
2612     * see if there's one with the given command. If so, then
2613     * delete the first one that matches.
2614     */
2615    
2616     command = Tcl_GetStringFromObj(objv[4], &commandLength);
2617     length = (size_t) commandLength;
2618     clientData = 0;
2619     name = Tcl_GetString(objv[2]);
2620     while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
2621     TraceVarProc, clientData)) != 0) {
2622     tvarPtr = (TraceVarInfo *) clientData;
2623     if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
2624     && (strncmp(command, tvarPtr->command,
2625     (size_t) length) == 0)) {
2626     Tcl_UntraceVar(interp, name, flags | TCL_TRACE_UNSETS,
2627     TraceVarProc, clientData);
2628     if (tvarPtr->errMsg != NULL) {
2629     ckfree(tvarPtr->errMsg);
2630     }
2631     ckfree((char *) tvarPtr);
2632     break;
2633     }
2634     }
2635     break;
2636     }
2637     case TRACE_VINFO: {
2638     ClientData clientData;
2639     char ops[4];
2640     Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;
2641    
2642     if (objc != 3) {
2643     Tcl_WrongNumArgs(interp, 2, objv, "name");
2644     return TCL_ERROR;
2645     }
2646     resultListPtr = Tcl_GetObjResult(interp);
2647     clientData = 0;
2648     name = Tcl_GetString(objv[2]);
2649     while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
2650     TraceVarProc, clientData)) != 0) {
2651    
2652     TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
2653    
2654     pairObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
2655     p = ops;
2656     if (tvarPtr->flags & TCL_TRACE_READS) {
2657     *p = 'r';
2658     p++;
2659     }
2660     if (tvarPtr->flags & TCL_TRACE_WRITES) {
2661     *p = 'w';
2662     p++;
2663     }
2664     if (tvarPtr->flags & TCL_TRACE_UNSETS) {
2665     *p = 'u';
2666     p++;
2667     }
2668     *p = '\0';
2669    
2670     /*
2671     * Build a pair (2-item list) with the ops string as
2672     * the first obj element and the tvarPtr->command string
2673     * as the second obj element. Append the pair (as an
2674     * element) to the end of the result object list.
2675     */
2676    
2677     elemObjPtr = Tcl_NewStringObj(ops, -1);
2678     Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
2679     elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
2680     Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr);
2681     Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr);
2682     }
2683     Tcl_SetObjResult(interp, resultListPtr);
2684     break;
2685     }
2686     default: {
2687     panic("Tcl_TraceObjCmd: bad option index to TraceOptions");
2688     }
2689     }
2690     return TCL_OK;
2691    
2692     badOps:
2693     Tcl_AppendResult(interp, "bad operations \"", rwuOps,
2694     "\": should be one or more of rwu", (char *) NULL);
2695     return TCL_ERROR;
2696     }
2697    
2698     /*
2699     *----------------------------------------------------------------------
2700     *
2701     * TraceVarProc --
2702     *
2703     * This procedure is called to handle variable accesses that have
2704     * been traced using the "trace" command.
2705     *
2706     * Results:
2707     * Normally returns NULL. If the trace command returns an error,
2708     * then this procedure returns an error string.
2709     *
2710     * Side effects:
2711     * Depends on the command associated with the trace.
2712     *
2713     *----------------------------------------------------------------------
2714     */
2715    
2716     /* ARGSUSED */
2717     static char *
2718     TraceVarProc(clientData, interp, name1, name2, flags)
2719     ClientData clientData; /* Information about the variable trace. */
2720     Tcl_Interp *interp; /* Interpreter containing variable. */
2721     char *name1; /* Name of variable or array. */
2722     char *name2; /* Name of element within array; NULL means
2723     * scalar variable is being referenced. */
2724     int flags; /* OR-ed bits giving operation and other
2725     * information. */
2726     {
2727     Tcl_SavedResult state;
2728     TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
2729     char *result;
2730     int code;
2731     Tcl_DString cmd;
2732    
2733     result = NULL;
2734     if (tvarPtr->errMsg != NULL) {
2735     ckfree(tvarPtr->errMsg);
2736     tvarPtr->errMsg = NULL;
2737     }
2738     if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
2739    
2740     /*
2741     * Generate a command to execute by appending list elements
2742     * for the two variable names and the operation. The five
2743     * extra characters are for three space, the opcode character,
2744     * and the terminating null.
2745     */
2746    
2747     if (name2 == NULL) {
2748     name2 = "";
2749     }
2750     Tcl_DStringInit(&cmd);
2751     Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length);
2752     Tcl_DStringAppendElement(&cmd, name1);
2753     Tcl_DStringAppendElement(&cmd, name2);
2754     if (flags & TCL_TRACE_READS) {
2755     Tcl_DStringAppend(&cmd, " r", 2);
2756     } else if (flags & TCL_TRACE_WRITES) {
2757     Tcl_DStringAppend(&cmd, " w", 2);
2758     } else if (flags & TCL_TRACE_UNSETS) {
2759     Tcl_DStringAppend(&cmd, " u", 2);
2760     }
2761    
2762     /*
2763     * Execute the command. Save the interp's result used for
2764     * the command. We discard any object result the command returns.
2765     */
2766    
2767     Tcl_SaveResult(interp, &state);
2768    
2769     code = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
2770     if (code != TCL_OK) { /* copy error msg to result */
2771     char *string;
2772     int length;
2773    
2774     string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
2775     tvarPtr->errMsg = (char *) ckalloc((unsigned) (length + 1));
2776     memcpy(tvarPtr->errMsg, string, (size_t) (length + 1));
2777     result = tvarPtr->errMsg;
2778     }
2779    
2780     Tcl_RestoreResult(interp, &state);
2781    
2782     Tcl_DStringFree(&cmd);
2783     }
2784     if (flags & TCL_TRACE_DESTROYED) {
2785     result = NULL;
2786     if (tvarPtr->errMsg != NULL) {
2787     ckfree(tvarPtr->errMsg);
2788     }
2789     ckfree((char *) tvarPtr);
2790     }
2791     return result;
2792     }
2793    
2794     /*
2795     *----------------------------------------------------------------------
2796     *
2797     * Tcl_WhileObjCmd --
2798     *
2799     * This procedure is invoked to process the "while" Tcl command.
2800     * See the user documentation for details on what it does.
2801     *
2802     * With the bytecode compiler, this procedure is only called when
2803     * a command name is computed at runtime, and is "while" or the name
2804     * to which "while" was renamed: e.g., "set z while; $z {$i<100} {}"
2805     *
2806     * Results:
2807     * A standard Tcl result.
2808     *
2809     * Side effects:
2810     * See the user documentation.
2811     *
2812     *----------------------------------------------------------------------
2813     */
2814    
2815     /* ARGSUSED */
2816     int
2817     Tcl_WhileObjCmd(dummy, interp, objc, objv)
2818     ClientData dummy; /* Not used. */
2819     Tcl_Interp *interp; /* Current interpreter. */
2820     int objc; /* Number of arguments. */
2821     Tcl_Obj *CONST objv[]; /* Argument objects. */
2822     {
2823     int result, value;
2824    
2825     if (objc != 3) {
2826     Tcl_WrongNumArgs(interp, 1, objv, "test command");
2827     return TCL_ERROR;
2828     }
2829    
2830     while (1) {
2831     result = Tcl_ExprBooleanObj(interp, objv[1], &value);
2832     if (result != TCL_OK) {
2833     return result;
2834     }
2835     if (!value) {
2836     break;
2837     }
2838     result = Tcl_EvalObjEx(interp, objv[2], 0);
2839     if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
2840     if (result == TCL_ERROR) {
2841     char msg[32 + TCL_INTEGER_SPACE];
2842    
2843     sprintf(msg, "\n (\"while\" body line %d)",
2844     interp->errorLine);
2845     Tcl_AddErrorInfo(interp, msg);
2846     }
2847     break;
2848     }
2849     }
2850     if (result == TCL_BREAK) {
2851     result = TCL_OK;
2852     }
2853     if (result == TCL_OK) {
2854     Tcl_ResetResult(interp);
2855     }
2856     return result;
2857     }
2858    
2859     /* End of tclcmdmz.c */

Properties

Name Value
svn:eol-style native
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25