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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25