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 */
|