/[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 44 - (show annotations) (download)
Fri Oct 14 02:09:58 2016 UTC (7 years, 9 months ago) by dashley
File MIME type: text/plain
File size: 75198 byte(s)
Rename for reorganization.
1 /* $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