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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 66 - (show annotations) (download)
Sun Oct 30 21:57:38 2016 UTC (7 years, 7 months ago) by dashley
File MIME type: text/plain
File size: 74871 byte(s)
Header and footer cleanup.
1 /* $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:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25