1 | /* |
---|
2 | * tclCmdMZ.c -- |
---|
3 | * |
---|
4 | * This file contains the top-level command routines for most of the Tcl |
---|
5 | * built-in commands whose names begin with the letters M to Z. It |
---|
6 | * contains only commands in the generic core (i.e. those that don't |
---|
7 | * depend much upon UNIX facilities). |
---|
8 | * |
---|
9 | * Copyright (c) 1987-1993 The Regents of the University of California. |
---|
10 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. |
---|
11 | * Copyright (c) 1998-2000 Scriptics Corporation. |
---|
12 | * Copyright (c) 2002 ActiveState Corporation. |
---|
13 | * Copyright (c) 2003 Donal K. Fellows. |
---|
14 | * |
---|
15 | * See the file "license.terms" for information on usage and redistribution of |
---|
16 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
17 | * |
---|
18 | * RCS: @(#) $Id: tclCmdMZ.c,v 1.163 2007/12/13 15:23:15 dgp Exp $ |
---|
19 | */ |
---|
20 | |
---|
21 | #include "tclInt.h" |
---|
22 | #include "tclRegexp.h" |
---|
23 | |
---|
24 | static int UniCharIsAscii(int character); |
---|
25 | |
---|
26 | /* |
---|
27 | *---------------------------------------------------------------------- |
---|
28 | * |
---|
29 | * Tcl_PwdObjCmd -- |
---|
30 | * |
---|
31 | * This procedure is invoked to process the "pwd" Tcl command. See the |
---|
32 | * user documentation for details on what it does. |
---|
33 | * |
---|
34 | * Results: |
---|
35 | * A standard Tcl result. |
---|
36 | * |
---|
37 | * Side effects: |
---|
38 | * See the user documentation. |
---|
39 | * |
---|
40 | *---------------------------------------------------------------------- |
---|
41 | */ |
---|
42 | |
---|
43 | int |
---|
44 | Tcl_PwdObjCmd( |
---|
45 | ClientData dummy, /* Not used. */ |
---|
46 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
47 | int objc, /* Number of arguments. */ |
---|
48 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
49 | { |
---|
50 | Tcl_Obj *retVal; |
---|
51 | |
---|
52 | if (objc != 1) { |
---|
53 | Tcl_WrongNumArgs(interp, 1, objv, NULL); |
---|
54 | return TCL_ERROR; |
---|
55 | } |
---|
56 | |
---|
57 | retVal = Tcl_FSGetCwd(interp); |
---|
58 | if (retVal == NULL) { |
---|
59 | return TCL_ERROR; |
---|
60 | } |
---|
61 | Tcl_SetObjResult(interp, retVal); |
---|
62 | Tcl_DecrRefCount(retVal); |
---|
63 | return TCL_OK; |
---|
64 | } |
---|
65 | |
---|
66 | /* |
---|
67 | *---------------------------------------------------------------------- |
---|
68 | * |
---|
69 | * Tcl_RegexpObjCmd -- |
---|
70 | * |
---|
71 | * This procedure is invoked to process the "regexp" Tcl command. See |
---|
72 | * 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 | int |
---|
84 | Tcl_RegexpObjCmd( |
---|
85 | ClientData dummy, /* Not used. */ |
---|
86 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
87 | int objc, /* Number of arguments. */ |
---|
88 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
89 | { |
---|
90 | int i, indices, match, about, offset, all, doinline, numMatchesSaved; |
---|
91 | int cflags, eflags, stringLength; |
---|
92 | Tcl_RegExp regExpr; |
---|
93 | Tcl_Obj *objPtr, *startIndex = NULL, *resultPtr = NULL; |
---|
94 | Tcl_RegExpInfo info; |
---|
95 | static CONST char *options[] = { |
---|
96 | "-all", "-about", "-indices", "-inline", |
---|
97 | "-expanded", "-line", "-linestop", "-lineanchor", |
---|
98 | "-nocase", "-start", "--", NULL |
---|
99 | }; |
---|
100 | enum options { |
---|
101 | REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE, |
---|
102 | REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR, |
---|
103 | REGEXP_NOCASE, REGEXP_START, REGEXP_LAST |
---|
104 | }; |
---|
105 | |
---|
106 | indices = 0; |
---|
107 | about = 0; |
---|
108 | cflags = TCL_REG_ADVANCED; |
---|
109 | eflags = 0; |
---|
110 | offset = 0; |
---|
111 | all = 0; |
---|
112 | doinline = 0; |
---|
113 | |
---|
114 | for (i = 1; i < objc; i++) { |
---|
115 | char *name; |
---|
116 | int index; |
---|
117 | |
---|
118 | name = TclGetString(objv[i]); |
---|
119 | if (name[0] != '-') { |
---|
120 | break; |
---|
121 | } |
---|
122 | if (Tcl_GetIndexFromObj(interp, objv[i], options, "switch", TCL_EXACT, |
---|
123 | &index) != TCL_OK) { |
---|
124 | goto optionError; |
---|
125 | } |
---|
126 | switch ((enum options) index) { |
---|
127 | case REGEXP_ALL: |
---|
128 | all = 1; |
---|
129 | break; |
---|
130 | case REGEXP_INDICES: |
---|
131 | indices = 1; |
---|
132 | break; |
---|
133 | case REGEXP_INLINE: |
---|
134 | doinline = 1; |
---|
135 | break; |
---|
136 | case REGEXP_NOCASE: |
---|
137 | cflags |= TCL_REG_NOCASE; |
---|
138 | break; |
---|
139 | case REGEXP_ABOUT: |
---|
140 | about = 1; |
---|
141 | break; |
---|
142 | case REGEXP_EXPANDED: |
---|
143 | cflags |= TCL_REG_EXPANDED; |
---|
144 | break; |
---|
145 | case REGEXP_LINE: |
---|
146 | cflags |= TCL_REG_NEWLINE; |
---|
147 | break; |
---|
148 | case REGEXP_LINESTOP: |
---|
149 | cflags |= TCL_REG_NLSTOP; |
---|
150 | break; |
---|
151 | case REGEXP_LINEANCHOR: |
---|
152 | cflags |= TCL_REG_NLANCH; |
---|
153 | break; |
---|
154 | case REGEXP_START: { |
---|
155 | int temp; |
---|
156 | if (++i >= objc) { |
---|
157 | goto endOfForLoop; |
---|
158 | } |
---|
159 | if (TclGetIntForIndexM(interp, objv[i], 0, &temp) != TCL_OK) { |
---|
160 | goto optionError; |
---|
161 | } |
---|
162 | if (startIndex) { |
---|
163 | Tcl_DecrRefCount(startIndex); |
---|
164 | } |
---|
165 | startIndex = objv[i]; |
---|
166 | Tcl_IncrRefCount(startIndex); |
---|
167 | break; |
---|
168 | } |
---|
169 | case REGEXP_LAST: |
---|
170 | i++; |
---|
171 | goto endOfForLoop; |
---|
172 | } |
---|
173 | } |
---|
174 | |
---|
175 | endOfForLoop: |
---|
176 | if ((objc - i) < (2 - about)) { |
---|
177 | Tcl_WrongNumArgs(interp, 1, objv, |
---|
178 | "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); |
---|
179 | goto optionError; |
---|
180 | } |
---|
181 | objc -= i; |
---|
182 | objv += i; |
---|
183 | |
---|
184 | /* |
---|
185 | * Check if the user requested -inline, but specified match variables; a |
---|
186 | * no-no. |
---|
187 | */ |
---|
188 | |
---|
189 | if (doinline && ((objc - 2) != 0)) { |
---|
190 | Tcl_AppendResult(interp, "regexp match variables not allowed" |
---|
191 | " when using -inline", NULL); |
---|
192 | goto optionError; |
---|
193 | } |
---|
194 | |
---|
195 | /* |
---|
196 | * Handle the odd about case separately. |
---|
197 | */ |
---|
198 | |
---|
199 | if (about) { |
---|
200 | regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); |
---|
201 | if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) { |
---|
202 | optionError: |
---|
203 | if (startIndex) { |
---|
204 | Tcl_DecrRefCount(startIndex); |
---|
205 | } |
---|
206 | return TCL_ERROR; |
---|
207 | } |
---|
208 | return TCL_OK; |
---|
209 | } |
---|
210 | |
---|
211 | /* |
---|
212 | * Get the length of the string that we are matching against so we can do |
---|
213 | * the termination test for -all matches. Do this before getting the |
---|
214 | * regexp to avoid shimmering problems. |
---|
215 | */ |
---|
216 | |
---|
217 | objPtr = objv[1]; |
---|
218 | stringLength = Tcl_GetCharLength(objPtr); |
---|
219 | |
---|
220 | if (startIndex) { |
---|
221 | TclGetIntForIndexM(NULL, startIndex, stringLength, &offset); |
---|
222 | Tcl_DecrRefCount(startIndex); |
---|
223 | if (offset < 0) { |
---|
224 | offset = 0; |
---|
225 | } |
---|
226 | } |
---|
227 | |
---|
228 | regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); |
---|
229 | if (regExpr == NULL) { |
---|
230 | return TCL_ERROR; |
---|
231 | } |
---|
232 | |
---|
233 | if (offset > 0) { |
---|
234 | /* |
---|
235 | * Add flag if using offset (string is part of a larger string), so |
---|
236 | * that "^" won't match. |
---|
237 | */ |
---|
238 | |
---|
239 | eflags |= TCL_REG_NOTBOL; |
---|
240 | } |
---|
241 | |
---|
242 | objc -= 2; |
---|
243 | objv += 2; |
---|
244 | |
---|
245 | if (doinline) { |
---|
246 | /* |
---|
247 | * Save all the subexpressions, as we will return them as a list |
---|
248 | */ |
---|
249 | |
---|
250 | numMatchesSaved = -1; |
---|
251 | } else { |
---|
252 | /* |
---|
253 | * Save only enough subexpressions for matches we want to keep, expect |
---|
254 | * in the case of -all, where we need to keep at least one to know |
---|
255 | * where to move the offset. |
---|
256 | */ |
---|
257 | |
---|
258 | numMatchesSaved = (objc == 0) ? all : objc; |
---|
259 | } |
---|
260 | |
---|
261 | /* |
---|
262 | * The following loop is to handle multiple matches within the same source |
---|
263 | * string; each iteration handles one match. If "-all" hasn't been |
---|
264 | * specified then the loop body only gets executed once. We terminate the |
---|
265 | * loop when the starting offset is past the end of the string. |
---|
266 | */ |
---|
267 | |
---|
268 | while (1) { |
---|
269 | match = Tcl_RegExpExecObj(interp, regExpr, objPtr, |
---|
270 | offset /* offset */, numMatchesSaved, eflags |
---|
271 | | ((offset > 0 && |
---|
272 | (Tcl_GetUniChar(objPtr,offset-1) != (Tcl_UniChar)'\n')) |
---|
273 | ? TCL_REG_NOTBOL : 0)); |
---|
274 | |
---|
275 | if (match < 0) { |
---|
276 | return TCL_ERROR; |
---|
277 | } |
---|
278 | |
---|
279 | if (match == 0) { |
---|
280 | /* |
---|
281 | * We want to set the value of the intepreter result only when |
---|
282 | * this is the first time through the loop. |
---|
283 | */ |
---|
284 | |
---|
285 | if (all <= 1) { |
---|
286 | /* |
---|
287 | * If inlining, the interpreter's object result remains an |
---|
288 | * empty list, otherwise set it to an integer object w/ value |
---|
289 | * 0. |
---|
290 | */ |
---|
291 | |
---|
292 | if (!doinline) { |
---|
293 | Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); |
---|
294 | } |
---|
295 | return TCL_OK; |
---|
296 | } |
---|
297 | break; |
---|
298 | } |
---|
299 | |
---|
300 | /* |
---|
301 | * If additional variable names have been specified, return index |
---|
302 | * information in those variables. |
---|
303 | */ |
---|
304 | |
---|
305 | Tcl_RegExpGetInfo(regExpr, &info); |
---|
306 | if (doinline) { |
---|
307 | /* |
---|
308 | * It's the number of substitutions, plus one for the matchVar at |
---|
309 | * index 0 |
---|
310 | */ |
---|
311 | |
---|
312 | objc = info.nsubs + 1; |
---|
313 | if (all <= 1) { |
---|
314 | resultPtr = Tcl_NewObj(); |
---|
315 | } |
---|
316 | } |
---|
317 | for (i = 0; i < objc; i++) { |
---|
318 | Tcl_Obj *newPtr; |
---|
319 | |
---|
320 | if (indices) { |
---|
321 | int start, end; |
---|
322 | Tcl_Obj *objs[2]; |
---|
323 | |
---|
324 | /* |
---|
325 | * Only adjust the match area if there was a match for that |
---|
326 | * area. (Scriptics Bug 4391/SF Bug #219232) |
---|
327 | */ |
---|
328 | |
---|
329 | if (i <= info.nsubs && info.matches[i].start >= 0) { |
---|
330 | start = offset + info.matches[i].start; |
---|
331 | end = offset + info.matches[i].end; |
---|
332 | |
---|
333 | /* |
---|
334 | * Adjust index so it refers to the last character in the |
---|
335 | * match instead of the first character after the match. |
---|
336 | */ |
---|
337 | |
---|
338 | if (end >= offset) { |
---|
339 | end--; |
---|
340 | } |
---|
341 | } else { |
---|
342 | start = -1; |
---|
343 | end = -1; |
---|
344 | } |
---|
345 | |
---|
346 | objs[0] = Tcl_NewLongObj(start); |
---|
347 | objs[1] = Tcl_NewLongObj(end); |
---|
348 | |
---|
349 | newPtr = Tcl_NewListObj(2, objs); |
---|
350 | } else { |
---|
351 | if (i <= info.nsubs) { |
---|
352 | newPtr = Tcl_GetRange(objPtr, |
---|
353 | offset + info.matches[i].start, |
---|
354 | offset + info.matches[i].end - 1); |
---|
355 | } else { |
---|
356 | newPtr = Tcl_NewObj(); |
---|
357 | } |
---|
358 | } |
---|
359 | if (doinline) { |
---|
360 | if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr) |
---|
361 | != TCL_OK) { |
---|
362 | Tcl_DecrRefCount(newPtr); |
---|
363 | Tcl_DecrRefCount(resultPtr); |
---|
364 | return TCL_ERROR; |
---|
365 | } |
---|
366 | } else { |
---|
367 | Tcl_Obj *valuePtr; |
---|
368 | valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0); |
---|
369 | if (valuePtr == NULL) { |
---|
370 | Tcl_AppendResult(interp, "couldn't set variable \"", |
---|
371 | TclGetString(objv[i]), "\"", NULL); |
---|
372 | return TCL_ERROR; |
---|
373 | } |
---|
374 | } |
---|
375 | } |
---|
376 | |
---|
377 | if (all == 0) { |
---|
378 | break; |
---|
379 | } |
---|
380 | |
---|
381 | /* |
---|
382 | * Adjust the offset to the character just after the last one in the |
---|
383 | * matchVar and increment all to count how many times we are making a |
---|
384 | * match. We always increment the offset by at least one to prevent |
---|
385 | * endless looping (as in the case: regexp -all {a*} a). Otherwise, |
---|
386 | * when we match the NULL string at the end of the input string, we |
---|
387 | * will loop indefinately (because the length of the match is 0, so |
---|
388 | * offset never changes). |
---|
389 | */ |
---|
390 | |
---|
391 | if (info.matches[0].end == 0) { |
---|
392 | offset++; |
---|
393 | } |
---|
394 | offset += info.matches[0].end; |
---|
395 | all++; |
---|
396 | eflags |= TCL_REG_NOTBOL; |
---|
397 | if (offset >= stringLength) { |
---|
398 | break; |
---|
399 | } |
---|
400 | } |
---|
401 | |
---|
402 | /* |
---|
403 | * Set the interpreter's object result to an integer object with value 1 |
---|
404 | * if -all wasn't specified, otherwise it's all-1 (the number of times |
---|
405 | * through the while - 1). |
---|
406 | */ |
---|
407 | |
---|
408 | if (doinline) { |
---|
409 | Tcl_SetObjResult(interp, resultPtr); |
---|
410 | } else { |
---|
411 | Tcl_SetObjResult(interp, Tcl_NewIntObj(all ? all-1 : 1)); |
---|
412 | } |
---|
413 | return TCL_OK; |
---|
414 | } |
---|
415 | |
---|
416 | /* |
---|
417 | *---------------------------------------------------------------------- |
---|
418 | * |
---|
419 | * Tcl_RegsubObjCmd -- |
---|
420 | * |
---|
421 | * This procedure is invoked to process the "regsub" Tcl command. See the |
---|
422 | * user documentation for details on what it does. |
---|
423 | * |
---|
424 | * Results: |
---|
425 | * A standard Tcl result. |
---|
426 | * |
---|
427 | * Side effects: |
---|
428 | * See the user documentation. |
---|
429 | * |
---|
430 | *---------------------------------------------------------------------- |
---|
431 | */ |
---|
432 | |
---|
433 | int |
---|
434 | Tcl_RegsubObjCmd( |
---|
435 | ClientData dummy, /* Not used. */ |
---|
436 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
437 | int objc, /* Number of arguments. */ |
---|
438 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
439 | { |
---|
440 | int idx, result, cflags, all, wlen, wsublen, numMatches, offset; |
---|
441 | int start, end, subStart, subEnd, match; |
---|
442 | Tcl_RegExp regExpr; |
---|
443 | Tcl_RegExpInfo info; |
---|
444 | Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL; |
---|
445 | Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend; |
---|
446 | |
---|
447 | static CONST char *options[] = { |
---|
448 | "-all", "-nocase", "-expanded", |
---|
449 | "-line", "-linestop", "-lineanchor", "-start", |
---|
450 | "--", NULL |
---|
451 | }; |
---|
452 | enum options { |
---|
453 | REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED, |
---|
454 | REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START, |
---|
455 | REGSUB_LAST |
---|
456 | }; |
---|
457 | |
---|
458 | cflags = TCL_REG_ADVANCED; |
---|
459 | all = 0; |
---|
460 | offset = 0; |
---|
461 | resultPtr = NULL; |
---|
462 | |
---|
463 | for (idx = 1; idx < objc; idx++) { |
---|
464 | char *name; |
---|
465 | int index; |
---|
466 | |
---|
467 | name = TclGetString(objv[idx]); |
---|
468 | if (name[0] != '-') { |
---|
469 | break; |
---|
470 | } |
---|
471 | if (Tcl_GetIndexFromObj(interp, objv[idx], options, "switch", |
---|
472 | TCL_EXACT, &index) != TCL_OK) { |
---|
473 | goto optionError; |
---|
474 | } |
---|
475 | switch ((enum options) index) { |
---|
476 | case REGSUB_ALL: |
---|
477 | all = 1; |
---|
478 | break; |
---|
479 | case REGSUB_NOCASE: |
---|
480 | cflags |= TCL_REG_NOCASE; |
---|
481 | break; |
---|
482 | case REGSUB_EXPANDED: |
---|
483 | cflags |= TCL_REG_EXPANDED; |
---|
484 | break; |
---|
485 | case REGSUB_LINE: |
---|
486 | cflags |= TCL_REG_NEWLINE; |
---|
487 | break; |
---|
488 | case REGSUB_LINESTOP: |
---|
489 | cflags |= TCL_REG_NLSTOP; |
---|
490 | break; |
---|
491 | case REGSUB_LINEANCHOR: |
---|
492 | cflags |= TCL_REG_NLANCH; |
---|
493 | break; |
---|
494 | case REGSUB_START: { |
---|
495 | int temp; |
---|
496 | if (++idx >= objc) { |
---|
497 | goto endOfForLoop; |
---|
498 | } |
---|
499 | if (TclGetIntForIndexM(interp, objv[idx], 0, &temp) != TCL_OK) { |
---|
500 | goto optionError; |
---|
501 | } |
---|
502 | if (startIndex) { |
---|
503 | Tcl_DecrRefCount(startIndex); |
---|
504 | } |
---|
505 | startIndex = objv[idx]; |
---|
506 | Tcl_IncrRefCount(startIndex); |
---|
507 | break; |
---|
508 | } |
---|
509 | case REGSUB_LAST: |
---|
510 | idx++; |
---|
511 | goto endOfForLoop; |
---|
512 | } |
---|
513 | } |
---|
514 | |
---|
515 | endOfForLoop: |
---|
516 | if (objc-idx < 3 || objc-idx > 4) { |
---|
517 | Tcl_WrongNumArgs(interp, 1, objv, |
---|
518 | "?switches? exp string subSpec ?varName?"); |
---|
519 | optionError: |
---|
520 | if (startIndex) { |
---|
521 | Tcl_DecrRefCount(startIndex); |
---|
522 | } |
---|
523 | return TCL_ERROR; |
---|
524 | } |
---|
525 | |
---|
526 | objc -= idx; |
---|
527 | objv += idx; |
---|
528 | |
---|
529 | if (startIndex) { |
---|
530 | int stringLength = Tcl_GetCharLength(objv[1]); |
---|
531 | |
---|
532 | TclGetIntForIndexM(NULL, startIndex, stringLength, &offset); |
---|
533 | Tcl_DecrRefCount(startIndex); |
---|
534 | if (offset < 0) { |
---|
535 | offset = 0; |
---|
536 | } |
---|
537 | } |
---|
538 | |
---|
539 | if (all && (offset == 0) |
---|
540 | && (strpbrk(TclGetString(objv[2]), "&\\") == NULL) |
---|
541 | && (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) { |
---|
542 | /* |
---|
543 | * This is a simple one pair string map situation. We make use of a |
---|
544 | * slightly modified version of the one pair STR_MAP code. |
---|
545 | */ |
---|
546 | |
---|
547 | int slen, nocase; |
---|
548 | int (*strCmpFn)(CONST Tcl_UniChar*,CONST Tcl_UniChar*,unsigned long); |
---|
549 | Tcl_UniChar *p, wsrclc; |
---|
550 | |
---|
551 | numMatches = 0; |
---|
552 | nocase = (cflags & TCL_REG_NOCASE); |
---|
553 | strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; |
---|
554 | |
---|
555 | wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen); |
---|
556 | wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen); |
---|
557 | wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen); |
---|
558 | wend = wstring + wlen - (slen ? slen - 1 : 0); |
---|
559 | result = TCL_OK; |
---|
560 | |
---|
561 | if (slen == 0) { |
---|
562 | /* |
---|
563 | * regsub behavior for "" matches between each character. 'string |
---|
564 | * map' skips the "" case. |
---|
565 | */ |
---|
566 | |
---|
567 | if (wstring < wend) { |
---|
568 | resultPtr = Tcl_NewUnicodeObj(wstring, 0); |
---|
569 | Tcl_IncrRefCount(resultPtr); |
---|
570 | for (; wstring < wend; wstring++) { |
---|
571 | Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); |
---|
572 | Tcl_AppendUnicodeToObj(resultPtr, wstring, 1); |
---|
573 | numMatches++; |
---|
574 | } |
---|
575 | wlen = 0; |
---|
576 | } |
---|
577 | } else { |
---|
578 | wsrclc = Tcl_UniCharToLower(*wsrc); |
---|
579 | for (p = wfirstChar = wstring; wstring < wend; wstring++) { |
---|
580 | if ((*wstring == *wsrc || |
---|
581 | (nocase && Tcl_UniCharToLower(*wstring)==wsrclc)) && |
---|
582 | (slen==1 || (strCmpFn(wstring, wsrc, |
---|
583 | (unsigned long) slen) == 0))) { |
---|
584 | if (numMatches == 0) { |
---|
585 | resultPtr = Tcl_NewUnicodeObj(wstring, 0); |
---|
586 | Tcl_IncrRefCount(resultPtr); |
---|
587 | } |
---|
588 | if (p != wstring) { |
---|
589 | Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p); |
---|
590 | p = wstring + slen; |
---|
591 | } else { |
---|
592 | p += slen; |
---|
593 | } |
---|
594 | wstring = p - 1; |
---|
595 | |
---|
596 | Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); |
---|
597 | numMatches++; |
---|
598 | } |
---|
599 | } |
---|
600 | if (numMatches) { |
---|
601 | wlen = wfirstChar + wlen - p; |
---|
602 | wstring = p; |
---|
603 | } |
---|
604 | } |
---|
605 | objPtr = NULL; |
---|
606 | subPtr = NULL; |
---|
607 | goto regsubDone; |
---|
608 | } |
---|
609 | |
---|
610 | regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); |
---|
611 | if (regExpr == NULL) { |
---|
612 | return TCL_ERROR; |
---|
613 | } |
---|
614 | |
---|
615 | /* |
---|
616 | * Make sure to avoid problems where the objects are shared. This can |
---|
617 | * cause RegExpObj <> UnicodeObj shimmering that causes data corruption. |
---|
618 | * [Bug #461322] |
---|
619 | */ |
---|
620 | |
---|
621 | if (objv[1] == objv[0]) { |
---|
622 | objPtr = Tcl_DuplicateObj(objv[1]); |
---|
623 | } else { |
---|
624 | objPtr = objv[1]; |
---|
625 | } |
---|
626 | wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); |
---|
627 | if (objv[2] == objv[0]) { |
---|
628 | subPtr = Tcl_DuplicateObj(objv[2]); |
---|
629 | } else { |
---|
630 | subPtr = objv[2]; |
---|
631 | } |
---|
632 | wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); |
---|
633 | |
---|
634 | result = TCL_OK; |
---|
635 | |
---|
636 | /* |
---|
637 | * The following loop is to handle multiple matches within the same source |
---|
638 | * string; each iteration handles one match and its corresponding |
---|
639 | * substitution. If "-all" hasn't been specified then the loop body only |
---|
640 | * gets executed once. We must use 'offset <= wlen' in particular for the |
---|
641 | * case where the regexp pattern can match the empty string - this is |
---|
642 | * useful when doing, say, 'regsub -- ^ $str ...' when $str might be |
---|
643 | * empty. |
---|
644 | */ |
---|
645 | |
---|
646 | numMatches = 0; |
---|
647 | for ( ; offset <= wlen; ) { |
---|
648 | |
---|
649 | /* |
---|
650 | * The flags argument is set if string is part of a larger string, so |
---|
651 | * that "^" won't match. |
---|
652 | */ |
---|
653 | |
---|
654 | match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset, |
---|
655 | 10 /* matches */, ((offset > 0 && |
---|
656 | (wstring[offset-1] != (Tcl_UniChar)'\n')) |
---|
657 | ? TCL_REG_NOTBOL : 0)); |
---|
658 | |
---|
659 | if (match < 0) { |
---|
660 | result = TCL_ERROR; |
---|
661 | goto done; |
---|
662 | } |
---|
663 | if (match == 0) { |
---|
664 | break; |
---|
665 | } |
---|
666 | if (numMatches == 0) { |
---|
667 | resultPtr = Tcl_NewUnicodeObj(wstring, 0); |
---|
668 | Tcl_IncrRefCount(resultPtr); |
---|
669 | if (offset > 0) { |
---|
670 | /* |
---|
671 | * Copy the initial portion of the string in if an offset was |
---|
672 | * specified. |
---|
673 | */ |
---|
674 | |
---|
675 | Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); |
---|
676 | } |
---|
677 | } |
---|
678 | numMatches++; |
---|
679 | |
---|
680 | /* |
---|
681 | * Copy the portion of the source string before the match to the |
---|
682 | * result variable. |
---|
683 | */ |
---|
684 | |
---|
685 | Tcl_RegExpGetInfo(regExpr, &info); |
---|
686 | start = info.matches[0].start; |
---|
687 | end = info.matches[0].end; |
---|
688 | Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start); |
---|
689 | |
---|
690 | /* |
---|
691 | * Append the subSpec argument to the variable, making appropriate |
---|
692 | * substitutions. This code is a bit hairy because of the backslash |
---|
693 | * conventions and because the code saves up ranges of characters in |
---|
694 | * subSpec to reduce the number of calls to Tcl_SetVar. |
---|
695 | */ |
---|
696 | |
---|
697 | wsrc = wfirstChar = wsubspec; |
---|
698 | wend = wsubspec + wsublen; |
---|
699 | for (ch = *wsrc; wsrc != wend; wsrc++, ch = *wsrc) { |
---|
700 | if (ch == '&') { |
---|
701 | idx = 0; |
---|
702 | } else if (ch == '\\') { |
---|
703 | ch = wsrc[1]; |
---|
704 | if ((ch >= '0') && (ch <= '9')) { |
---|
705 | idx = ch - '0'; |
---|
706 | } else if ((ch == '\\') || (ch == '&')) { |
---|
707 | *wsrc = ch; |
---|
708 | Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, |
---|
709 | wsrc - wfirstChar + 1); |
---|
710 | *wsrc = '\\'; |
---|
711 | wfirstChar = wsrc + 2; |
---|
712 | wsrc++; |
---|
713 | continue; |
---|
714 | } else { |
---|
715 | continue; |
---|
716 | } |
---|
717 | } else { |
---|
718 | continue; |
---|
719 | } |
---|
720 | |
---|
721 | if (wfirstChar != wsrc) { |
---|
722 | Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, |
---|
723 | wsrc - wfirstChar); |
---|
724 | } |
---|
725 | |
---|
726 | if (idx <= info.nsubs) { |
---|
727 | subStart = info.matches[idx].start; |
---|
728 | subEnd = info.matches[idx].end; |
---|
729 | if ((subStart >= 0) && (subEnd >= 0)) { |
---|
730 | Tcl_AppendUnicodeToObj(resultPtr, |
---|
731 | wstring + offset + subStart, subEnd - subStart); |
---|
732 | } |
---|
733 | } |
---|
734 | |
---|
735 | if (*wsrc == '\\') { |
---|
736 | wsrc++; |
---|
737 | } |
---|
738 | wfirstChar = wsrc + 1; |
---|
739 | } |
---|
740 | |
---|
741 | if (wfirstChar != wsrc) { |
---|
742 | Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); |
---|
743 | } |
---|
744 | |
---|
745 | if (end == 0) { |
---|
746 | /* |
---|
747 | * Always consume at least one character of the input string in |
---|
748 | * order to prevent infinite loops. |
---|
749 | */ |
---|
750 | |
---|
751 | if (offset < wlen) { |
---|
752 | Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); |
---|
753 | } |
---|
754 | offset++; |
---|
755 | } else { |
---|
756 | offset += end; |
---|
757 | if (start == end) { |
---|
758 | /* |
---|
759 | * We matched an empty string, which means we must go forward |
---|
760 | * one more step so we don't match again at the same spot. |
---|
761 | */ |
---|
762 | |
---|
763 | if (offset < wlen) { |
---|
764 | Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); |
---|
765 | } |
---|
766 | offset++; |
---|
767 | } |
---|
768 | } |
---|
769 | if (!all) { |
---|
770 | break; |
---|
771 | } |
---|
772 | } |
---|
773 | |
---|
774 | /* |
---|
775 | * Copy the portion of the source string after the last match to the |
---|
776 | * result variable. |
---|
777 | */ |
---|
778 | |
---|
779 | regsubDone: |
---|
780 | if (numMatches == 0) { |
---|
781 | /* |
---|
782 | * On zero matches, just ignore the offset, since it shouldn't matter |
---|
783 | * to us in this case, and the user may have skewed it. |
---|
784 | */ |
---|
785 | |
---|
786 | resultPtr = objv[1]; |
---|
787 | Tcl_IncrRefCount(resultPtr); |
---|
788 | } else if (offset < wlen) { |
---|
789 | Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); |
---|
790 | } |
---|
791 | if (objc == 4) { |
---|
792 | if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) { |
---|
793 | Tcl_AppendResult(interp, "couldn't set variable \"", |
---|
794 | TclGetString(objv[3]), "\"", NULL); |
---|
795 | result = TCL_ERROR; |
---|
796 | } else { |
---|
797 | /* |
---|
798 | * Set the interpreter's object result to an integer object |
---|
799 | * holding the number of matches. |
---|
800 | */ |
---|
801 | |
---|
802 | Tcl_SetObjResult(interp, Tcl_NewIntObj(numMatches)); |
---|
803 | } |
---|
804 | } else { |
---|
805 | /* |
---|
806 | * No varname supplied, so just return the modified string. |
---|
807 | */ |
---|
808 | |
---|
809 | Tcl_SetObjResult(interp, resultPtr); |
---|
810 | } |
---|
811 | |
---|
812 | done: |
---|
813 | if (objPtr && (objv[1] == objv[0])) { |
---|
814 | Tcl_DecrRefCount(objPtr); |
---|
815 | } |
---|
816 | if (subPtr && (objv[2] == objv[0])) { |
---|
817 | Tcl_DecrRefCount(subPtr); |
---|
818 | } |
---|
819 | if (resultPtr) { |
---|
820 | Tcl_DecrRefCount(resultPtr); |
---|
821 | } |
---|
822 | return result; |
---|
823 | } |
---|
824 | |
---|
825 | /* |
---|
826 | *---------------------------------------------------------------------- |
---|
827 | * |
---|
828 | * Tcl_RenameObjCmd -- |
---|
829 | * |
---|
830 | * This procedure is invoked to process the "rename" Tcl command. See the |
---|
831 | * 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 | int |
---|
843 | Tcl_RenameObjCmd( |
---|
844 | ClientData dummy, /* Arbitrary value passed to the command. */ |
---|
845 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
846 | int objc, /* Number of arguments. */ |
---|
847 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
848 | { |
---|
849 | char *oldName, *newName; |
---|
850 | |
---|
851 | if (objc != 3) { |
---|
852 | Tcl_WrongNumArgs(interp, 1, objv, "oldName newName"); |
---|
853 | return TCL_ERROR; |
---|
854 | } |
---|
855 | |
---|
856 | oldName = TclGetString(objv[1]); |
---|
857 | newName = TclGetString(objv[2]); |
---|
858 | return TclRenameCommand(interp, oldName, newName); |
---|
859 | } |
---|
860 | |
---|
861 | /* |
---|
862 | *---------------------------------------------------------------------- |
---|
863 | * |
---|
864 | * Tcl_ReturnObjCmd -- |
---|
865 | * |
---|
866 | * This object-based procedure is invoked to process the "return" Tcl |
---|
867 | * command. See the user documentation for details on what it does. |
---|
868 | * |
---|
869 | * Results: |
---|
870 | * A standard Tcl object result. |
---|
871 | * |
---|
872 | * Side effects: |
---|
873 | * See the user documentation. |
---|
874 | * |
---|
875 | *---------------------------------------------------------------------- |
---|
876 | */ |
---|
877 | |
---|
878 | int |
---|
879 | Tcl_ReturnObjCmd( |
---|
880 | ClientData dummy, /* Not used. */ |
---|
881 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
882 | int objc, /* Number of arguments. */ |
---|
883 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
884 | { |
---|
885 | int code, level; |
---|
886 | Tcl_Obj *returnOpts; |
---|
887 | |
---|
888 | /* |
---|
889 | * General syntax: [return ?-option value ...? ?result?] |
---|
890 | * An even number of words means an explicit result argument is present. |
---|
891 | */ |
---|
892 | |
---|
893 | int explicitResult = (0 == (objc % 2)); |
---|
894 | int numOptionWords = objc - 1 - explicitResult; |
---|
895 | |
---|
896 | if (TCL_ERROR == TclMergeReturnOptions(interp, numOptionWords, objv+1, |
---|
897 | &returnOpts, &code, &level)) { |
---|
898 | return TCL_ERROR; |
---|
899 | } |
---|
900 | |
---|
901 | code = TclProcessReturn(interp, code, level, returnOpts); |
---|
902 | if (explicitResult) { |
---|
903 | Tcl_SetObjResult(interp, objv[objc-1]); |
---|
904 | } |
---|
905 | return code; |
---|
906 | } |
---|
907 | |
---|
908 | /* |
---|
909 | *---------------------------------------------------------------------- |
---|
910 | * |
---|
911 | * Tcl_SourceObjCmd -- |
---|
912 | * |
---|
913 | * This procedure is invoked to process the "source" Tcl command. See the |
---|
914 | * user documentation for details on what it does. |
---|
915 | * |
---|
916 | * Results: |
---|
917 | * A standard Tcl object result. |
---|
918 | * |
---|
919 | * Side effects: |
---|
920 | * See the user documentation. |
---|
921 | * |
---|
922 | *---------------------------------------------------------------------- |
---|
923 | */ |
---|
924 | |
---|
925 | int |
---|
926 | Tcl_SourceObjCmd( |
---|
927 | ClientData dummy, /* Not used. */ |
---|
928 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
929 | int objc, /* Number of arguments. */ |
---|
930 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
931 | { |
---|
932 | CONST char *encodingName = NULL; |
---|
933 | Tcl_Obj *fileName; |
---|
934 | |
---|
935 | if (objc != 2 && objc !=4) { |
---|
936 | Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName"); |
---|
937 | return TCL_ERROR; |
---|
938 | } |
---|
939 | |
---|
940 | fileName = objv[objc-1]; |
---|
941 | |
---|
942 | if (objc == 4) { |
---|
943 | static CONST char *options[] = { |
---|
944 | "-encoding", NULL |
---|
945 | }; |
---|
946 | int index; |
---|
947 | |
---|
948 | if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], options, |
---|
949 | "option", TCL_EXACT, &index)) { |
---|
950 | return TCL_ERROR; |
---|
951 | } |
---|
952 | encodingName = TclGetString(objv[2]); |
---|
953 | } |
---|
954 | |
---|
955 | return Tcl_FSEvalFileEx(interp, fileName, encodingName); |
---|
956 | } |
---|
957 | |
---|
958 | /* |
---|
959 | *---------------------------------------------------------------------- |
---|
960 | * |
---|
961 | * Tcl_SplitObjCmd -- |
---|
962 | * |
---|
963 | * This procedure is invoked to process the "split" Tcl command. See the |
---|
964 | * user documentation for details on what it does. |
---|
965 | * |
---|
966 | * Results: |
---|
967 | * A standard Tcl result. |
---|
968 | * |
---|
969 | * Side effects: |
---|
970 | * See the user documentation. |
---|
971 | * |
---|
972 | *---------------------------------------------------------------------- |
---|
973 | */ |
---|
974 | |
---|
975 | int |
---|
976 | Tcl_SplitObjCmd( |
---|
977 | ClientData dummy, /* Not used. */ |
---|
978 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
979 | int objc, /* Number of arguments. */ |
---|
980 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
981 | { |
---|
982 | Tcl_UniChar ch; |
---|
983 | int len; |
---|
984 | char *splitChars, *stringPtr, *end; |
---|
985 | int splitCharLen, stringLen; |
---|
986 | Tcl_Obj *listPtr, *objPtr; |
---|
987 | |
---|
988 | if (objc == 2) { |
---|
989 | splitChars = " \n\t\r"; |
---|
990 | splitCharLen = 4; |
---|
991 | } else if (objc == 3) { |
---|
992 | splitChars = TclGetStringFromObj(objv[2], &splitCharLen); |
---|
993 | } else { |
---|
994 | Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?"); |
---|
995 | return TCL_ERROR; |
---|
996 | } |
---|
997 | |
---|
998 | stringPtr = TclGetStringFromObj(objv[1], &stringLen); |
---|
999 | end = stringPtr + stringLen; |
---|
1000 | listPtr = Tcl_NewObj(); |
---|
1001 | |
---|
1002 | if (stringLen == 0) { |
---|
1003 | /* |
---|
1004 | * Do nothing. |
---|
1005 | */ |
---|
1006 | } else if (splitCharLen == 0) { |
---|
1007 | Tcl_HashTable charReuseTable; |
---|
1008 | Tcl_HashEntry *hPtr; |
---|
1009 | int isNew; |
---|
1010 | |
---|
1011 | /* |
---|
1012 | * Handle the special case of splitting on every character. |
---|
1013 | * |
---|
1014 | * Uses a hash table to ensure that each kind of character has only |
---|
1015 | * one Tcl_Obj instance (multiply-referenced) in the final list. This |
---|
1016 | * is a *major* win when splitting on a long string (especially in the |
---|
1017 | * megabyte range!) - DKF |
---|
1018 | */ |
---|
1019 | |
---|
1020 | Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); |
---|
1021 | |
---|
1022 | for ( ; stringPtr < end; stringPtr += len) { |
---|
1023 | len = TclUtfToUniChar(stringPtr, &ch); |
---|
1024 | |
---|
1025 | /* |
---|
1026 | * Assume Tcl_UniChar is an integral type... |
---|
1027 | */ |
---|
1028 | |
---|
1029 | hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0+ch, &isNew); |
---|
1030 | if (isNew) { |
---|
1031 | TclNewStringObj(objPtr, stringPtr, len); |
---|
1032 | |
---|
1033 | /* |
---|
1034 | * Don't need to fiddle with refcount... |
---|
1035 | */ |
---|
1036 | |
---|
1037 | Tcl_SetHashValue(hPtr, (ClientData) objPtr); |
---|
1038 | } else { |
---|
1039 | objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr); |
---|
1040 | } |
---|
1041 | Tcl_ListObjAppendElement(NULL, listPtr, objPtr); |
---|
1042 | } |
---|
1043 | Tcl_DeleteHashTable(&charReuseTable); |
---|
1044 | |
---|
1045 | } else if (splitCharLen == 1) { |
---|
1046 | char *p; |
---|
1047 | |
---|
1048 | /* |
---|
1049 | * Handle the special case of splitting on a single character. This is |
---|
1050 | * only true for the one-char ASCII case, as one unicode char is > 1 |
---|
1051 | * byte in length. |
---|
1052 | */ |
---|
1053 | |
---|
1054 | while (*stringPtr && (p=strchr(stringPtr,(int)*splitChars)) != NULL) { |
---|
1055 | objPtr = Tcl_NewStringObj(stringPtr, p - stringPtr); |
---|
1056 | Tcl_ListObjAppendElement(NULL, listPtr, objPtr); |
---|
1057 | stringPtr = p + 1; |
---|
1058 | } |
---|
1059 | TclNewStringObj(objPtr, stringPtr, end - stringPtr); |
---|
1060 | Tcl_ListObjAppendElement(NULL, listPtr, objPtr); |
---|
1061 | } else { |
---|
1062 | char *element, *p, *splitEnd; |
---|
1063 | int splitLen; |
---|
1064 | Tcl_UniChar splitChar; |
---|
1065 | |
---|
1066 | /* |
---|
1067 | * Normal case: split on any of a given set of characters. Discard |
---|
1068 | * instances of the split characters. |
---|
1069 | */ |
---|
1070 | |
---|
1071 | splitEnd = splitChars + splitCharLen; |
---|
1072 | |
---|
1073 | for (element = stringPtr; stringPtr < end; stringPtr += len) { |
---|
1074 | len = TclUtfToUniChar(stringPtr, &ch); |
---|
1075 | for (p = splitChars; p < splitEnd; p += splitLen) { |
---|
1076 | splitLen = TclUtfToUniChar(p, &splitChar); |
---|
1077 | if (ch == splitChar) { |
---|
1078 | TclNewStringObj(objPtr, element, stringPtr - element); |
---|
1079 | Tcl_ListObjAppendElement(NULL, listPtr, objPtr); |
---|
1080 | element = stringPtr + len; |
---|
1081 | break; |
---|
1082 | } |
---|
1083 | } |
---|
1084 | } |
---|
1085 | |
---|
1086 | TclNewStringObj(objPtr, element, stringPtr - element); |
---|
1087 | Tcl_ListObjAppendElement(NULL, listPtr, objPtr); |
---|
1088 | } |
---|
1089 | Tcl_SetObjResult(interp, listPtr); |
---|
1090 | return TCL_OK; |
---|
1091 | } |
---|
1092 | |
---|
1093 | /* |
---|
1094 | *---------------------------------------------------------------------- |
---|
1095 | * |
---|
1096 | * StringFirstCmd -- |
---|
1097 | * |
---|
1098 | * This procedure is invoked to process the "string first" Tcl command. |
---|
1099 | * See the user documentation for details on what it does. Note that this |
---|
1100 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
1101 | * |
---|
1102 | * Results: |
---|
1103 | * A standard Tcl result. |
---|
1104 | * |
---|
1105 | * Side effects: |
---|
1106 | * See the user documentation. |
---|
1107 | * |
---|
1108 | *---------------------------------------------------------------------- |
---|
1109 | */ |
---|
1110 | |
---|
1111 | static int |
---|
1112 | StringFirstCmd( |
---|
1113 | ClientData dummy, /* Not used. */ |
---|
1114 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
1115 | int objc, /* Number of arguments. */ |
---|
1116 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
1117 | { |
---|
1118 | Tcl_UniChar *ustring1, *ustring2; |
---|
1119 | int match, start, length1, length2; |
---|
1120 | |
---|
1121 | if (objc < 3 || objc > 4) { |
---|
1122 | Tcl_WrongNumArgs(interp, 1, objv, |
---|
1123 | "needleString haystackString ?startIndex?"); |
---|
1124 | return TCL_ERROR; |
---|
1125 | } |
---|
1126 | |
---|
1127 | /* |
---|
1128 | * We are searching string2 for the sequence string1. |
---|
1129 | */ |
---|
1130 | |
---|
1131 | match = -1; |
---|
1132 | start = 0; |
---|
1133 | length2 = -1; |
---|
1134 | |
---|
1135 | ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); |
---|
1136 | ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); |
---|
1137 | |
---|
1138 | if (objc == 4) { |
---|
1139 | /* |
---|
1140 | * If a startIndex is specified, we will need to fast forward to that |
---|
1141 | * point in the string before we think about a match. |
---|
1142 | */ |
---|
1143 | |
---|
1144 | if (TclGetIntForIndexM(interp, objv[3], length2-1, &start) != TCL_OK){ |
---|
1145 | return TCL_ERROR; |
---|
1146 | } |
---|
1147 | |
---|
1148 | /* |
---|
1149 | * Reread to prevent shimmering problems. |
---|
1150 | */ |
---|
1151 | |
---|
1152 | ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); |
---|
1153 | ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); |
---|
1154 | |
---|
1155 | if (start >= length2) { |
---|
1156 | goto str_first_done; |
---|
1157 | } else if (start > 0) { |
---|
1158 | ustring2 += start; |
---|
1159 | length2 -= start; |
---|
1160 | } else if (start < 0) { |
---|
1161 | /* |
---|
1162 | * Invalid start index mapped to string start; Bug #423581 |
---|
1163 | */ |
---|
1164 | |
---|
1165 | start = 0; |
---|
1166 | } |
---|
1167 | } |
---|
1168 | |
---|
1169 | if (length1 > 0) { |
---|
1170 | register Tcl_UniChar *p, *end; |
---|
1171 | |
---|
1172 | end = ustring2 + length2 - length1 + 1; |
---|
1173 | for (p = ustring2; p < end; p++) { |
---|
1174 | /* |
---|
1175 | * Scan forward to find the first character. |
---|
1176 | */ |
---|
1177 | |
---|
1178 | if ((*p == *ustring1) && (TclUniCharNcmp(ustring1, p, |
---|
1179 | (unsigned long) length1) == 0)) { |
---|
1180 | match = p - ustring2; |
---|
1181 | break; |
---|
1182 | } |
---|
1183 | } |
---|
1184 | } |
---|
1185 | |
---|
1186 | /* |
---|
1187 | * Compute the character index of the matching string by counting the |
---|
1188 | * number of characters before the match. |
---|
1189 | */ |
---|
1190 | |
---|
1191 | if ((match != -1) && (objc == 4)) { |
---|
1192 | match += start; |
---|
1193 | } |
---|
1194 | |
---|
1195 | str_first_done: |
---|
1196 | Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); |
---|
1197 | return TCL_OK; |
---|
1198 | } |
---|
1199 | |
---|
1200 | /* |
---|
1201 | *---------------------------------------------------------------------- |
---|
1202 | * |
---|
1203 | * StringLastCmd -- |
---|
1204 | * |
---|
1205 | * This procedure is invoked to process the "string last" Tcl command. |
---|
1206 | * See the user documentation for details on what it does. Note that this |
---|
1207 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
1208 | * |
---|
1209 | * Results: |
---|
1210 | * A standard Tcl result. |
---|
1211 | * |
---|
1212 | * Side effects: |
---|
1213 | * See the user documentation. |
---|
1214 | * |
---|
1215 | *---------------------------------------------------------------------- |
---|
1216 | */ |
---|
1217 | |
---|
1218 | static int |
---|
1219 | StringLastCmd( |
---|
1220 | ClientData dummy, /* Not used. */ |
---|
1221 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
1222 | int objc, /* Number of arguments. */ |
---|
1223 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
1224 | { |
---|
1225 | Tcl_UniChar *ustring1, *ustring2, *p; |
---|
1226 | int match, start, length1, length2; |
---|
1227 | |
---|
1228 | if (objc < 3 || objc > 4) { |
---|
1229 | Tcl_WrongNumArgs(interp, 1, objv, |
---|
1230 | "needleString haystackString ?startIndex?"); |
---|
1231 | return TCL_ERROR; |
---|
1232 | } |
---|
1233 | |
---|
1234 | /* |
---|
1235 | * We are searching string2 for the sequence string1. |
---|
1236 | */ |
---|
1237 | |
---|
1238 | match = -1; |
---|
1239 | start = 0; |
---|
1240 | length2 = -1; |
---|
1241 | |
---|
1242 | ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); |
---|
1243 | ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); |
---|
1244 | |
---|
1245 | if (objc == 4) { |
---|
1246 | /* |
---|
1247 | * If a startIndex is specified, we will need to restrict the string |
---|
1248 | * range to that char index in the string |
---|
1249 | */ |
---|
1250 | |
---|
1251 | if (TclGetIntForIndexM(interp, objv[3], length2-1, &start) != TCL_OK){ |
---|
1252 | return TCL_ERROR; |
---|
1253 | } |
---|
1254 | |
---|
1255 | /* |
---|
1256 | * Reread to prevent shimmering problems. |
---|
1257 | */ |
---|
1258 | |
---|
1259 | ustring1 = Tcl_GetUnicodeFromObj(objv[1], &length1); |
---|
1260 | ustring2 = Tcl_GetUnicodeFromObj(objv[2], &length2); |
---|
1261 | |
---|
1262 | if (start < 0) { |
---|
1263 | goto str_last_done; |
---|
1264 | } else if (start < length2) { |
---|
1265 | p = ustring2 + start + 1 - length1; |
---|
1266 | } else { |
---|
1267 | p = ustring2 + length2 - length1; |
---|
1268 | } |
---|
1269 | } else { |
---|
1270 | p = ustring2 + length2 - length1; |
---|
1271 | } |
---|
1272 | |
---|
1273 | if (length1 > 0) { |
---|
1274 | for (; p >= ustring2; p--) { |
---|
1275 | /* |
---|
1276 | * Scan backwards to find the first character. |
---|
1277 | */ |
---|
1278 | |
---|
1279 | if ((*p == *ustring1) && !memcmp(ustring1, p, |
---|
1280 | sizeof(Tcl_UniChar) * (size_t)length1)) { |
---|
1281 | match = p - ustring2; |
---|
1282 | break; |
---|
1283 | } |
---|
1284 | } |
---|
1285 | } |
---|
1286 | |
---|
1287 | str_last_done: |
---|
1288 | Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); |
---|
1289 | return TCL_OK; |
---|
1290 | } |
---|
1291 | |
---|
1292 | /* |
---|
1293 | *---------------------------------------------------------------------- |
---|
1294 | * |
---|
1295 | * StringIndexCmd -- |
---|
1296 | * |
---|
1297 | * This procedure is invoked to process the "string index" Tcl command. |
---|
1298 | * See the user documentation for details on what it does. Note that this |
---|
1299 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
1300 | * |
---|
1301 | * Results: |
---|
1302 | * A standard Tcl result. |
---|
1303 | * |
---|
1304 | * Side effects: |
---|
1305 | * See the user documentation. |
---|
1306 | * |
---|
1307 | *---------------------------------------------------------------------- |
---|
1308 | */ |
---|
1309 | |
---|
1310 | static int |
---|
1311 | StringIndexCmd( |
---|
1312 | ClientData dummy, /* Not used. */ |
---|
1313 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
1314 | int objc, /* Number of arguments. */ |
---|
1315 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
1316 | { |
---|
1317 | int length, index; |
---|
1318 | |
---|
1319 | if (objc != 3) { |
---|
1320 | Tcl_WrongNumArgs(interp, 1, objv, "string charIndex"); |
---|
1321 | return TCL_ERROR; |
---|
1322 | } |
---|
1323 | |
---|
1324 | /* |
---|
1325 | * If we have a ByteArray object, avoid indexing in the Utf string since |
---|
1326 | * the byte array contains one byte per character. Otherwise, use the |
---|
1327 | * Unicode string rep to get the index'th char. |
---|
1328 | */ |
---|
1329 | |
---|
1330 | if (objv[1]->typePtr == &tclByteArrayType) { |
---|
1331 | const unsigned char *string = |
---|
1332 | Tcl_GetByteArrayFromObj(objv[1], &length); |
---|
1333 | |
---|
1334 | if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK){ |
---|
1335 | return TCL_ERROR; |
---|
1336 | } |
---|
1337 | string = Tcl_GetByteArrayFromObj(objv[1], &length); |
---|
1338 | if ((index >= 0) && (index < length)) { |
---|
1339 | Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(string + index, 1)); |
---|
1340 | } |
---|
1341 | } else { |
---|
1342 | /* |
---|
1343 | * Get Unicode char length to calulate what 'end' means. |
---|
1344 | */ |
---|
1345 | |
---|
1346 | length = Tcl_GetCharLength(objv[1]); |
---|
1347 | |
---|
1348 | if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK){ |
---|
1349 | return TCL_ERROR; |
---|
1350 | } |
---|
1351 | if ((index >= 0) && (index < length)) { |
---|
1352 | char buf[TCL_UTF_MAX]; |
---|
1353 | Tcl_UniChar ch; |
---|
1354 | |
---|
1355 | ch = Tcl_GetUniChar(objv[1], index); |
---|
1356 | length = Tcl_UniCharToUtf(ch, buf); |
---|
1357 | Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length)); |
---|
1358 | } |
---|
1359 | } |
---|
1360 | return TCL_OK; |
---|
1361 | } |
---|
1362 | |
---|
1363 | /* |
---|
1364 | *---------------------------------------------------------------------- |
---|
1365 | * |
---|
1366 | * StringIsCmd -- |
---|
1367 | * |
---|
1368 | * This procedure is invoked to process the "string is" Tcl command. See |
---|
1369 | * the user documentation for details on what it does. Note that this |
---|
1370 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
1371 | * |
---|
1372 | * Results: |
---|
1373 | * A standard Tcl result. |
---|
1374 | * |
---|
1375 | * Side effects: |
---|
1376 | * See the user documentation. |
---|
1377 | * |
---|
1378 | *---------------------------------------------------------------------- |
---|
1379 | */ |
---|
1380 | |
---|
1381 | static int |
---|
1382 | StringIsCmd( |
---|
1383 | ClientData dummy, /* Not used. */ |
---|
1384 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
1385 | int objc, /* Number of arguments. */ |
---|
1386 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
1387 | { |
---|
1388 | const char *string1, *string2, *end, *stop; |
---|
1389 | Tcl_UniChar ch; |
---|
1390 | int (*chcomp)(int) = NULL; /* The UniChar comparison function. */ |
---|
1391 | int i, failat = 0, result = 1, strict = 0, index, length1, length2; |
---|
1392 | Tcl_Obj *objPtr, *failVarObj = NULL; |
---|
1393 | Tcl_WideInt w; |
---|
1394 | |
---|
1395 | static const char *isOptions[] = { |
---|
1396 | "alnum", "alpha", "ascii", "control", |
---|
1397 | "boolean", "digit", "double", "false", |
---|
1398 | "graph", "integer", "list", "lower", |
---|
1399 | "print", "punct", "space", "true", |
---|
1400 | "upper", "wideinteger", "wordchar", "xdigit", |
---|
1401 | NULL |
---|
1402 | }; |
---|
1403 | enum isOptions { |
---|
1404 | STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, |
---|
1405 | STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE, |
---|
1406 | STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, STR_IS_LOWER, |
---|
1407 | STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, |
---|
1408 | STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT |
---|
1409 | }; |
---|
1410 | |
---|
1411 | if (objc < 3 || objc > 6) { |
---|
1412 | Tcl_WrongNumArgs(interp, 1, objv, |
---|
1413 | "class ?-strict? ?-failindex var? str"); |
---|
1414 | return TCL_ERROR; |
---|
1415 | } |
---|
1416 | if (Tcl_GetIndexFromObj(interp, objv[1], isOptions, "class", 0, |
---|
1417 | &index) != TCL_OK) { |
---|
1418 | return TCL_ERROR; |
---|
1419 | } |
---|
1420 | |
---|
1421 | if (objc != 3) { |
---|
1422 | for (i = 2; i < objc-1; i++) { |
---|
1423 | string2 = TclGetStringFromObj(objv[i], &length2); |
---|
1424 | if ((length2 > 1) && |
---|
1425 | strncmp(string2, "-strict", (size_t) length2) == 0) { |
---|
1426 | strict = 1; |
---|
1427 | } else if ((length2 > 1) && |
---|
1428 | strncmp(string2, "-failindex", (size_t)length2) == 0){ |
---|
1429 | if (i+1 >= objc-1) { |
---|
1430 | Tcl_WrongNumArgs(interp, 2, objv, |
---|
1431 | "?-strict? ?-failindex var? str"); |
---|
1432 | return TCL_ERROR; |
---|
1433 | } |
---|
1434 | failVarObj = objv[++i]; |
---|
1435 | } else { |
---|
1436 | Tcl_AppendResult(interp, "bad option \"", string2, |
---|
1437 | "\": must be -strict or -failindex", NULL); |
---|
1438 | return TCL_ERROR; |
---|
1439 | } |
---|
1440 | } |
---|
1441 | } |
---|
1442 | |
---|
1443 | /* |
---|
1444 | * We get the objPtr so that we can short-cut for some classes by checking |
---|
1445 | * the object type (int and double), but we need the string otherwise, |
---|
1446 | * because we don't want any conversion of type occuring (as, for example, |
---|
1447 | * Tcl_Get*FromObj would do). |
---|
1448 | */ |
---|
1449 | |
---|
1450 | objPtr = objv[objc-1]; |
---|
1451 | string1 = TclGetStringFromObj(objPtr, &length1); |
---|
1452 | if (length1 == 0 && index != STR_IS_LIST) { |
---|
1453 | if (strict) { |
---|
1454 | result = 0; |
---|
1455 | } |
---|
1456 | goto str_is_done; |
---|
1457 | } |
---|
1458 | end = string1 + length1; |
---|
1459 | |
---|
1460 | /* |
---|
1461 | * When entering here, result == 1 and failat == 0. |
---|
1462 | */ |
---|
1463 | |
---|
1464 | switch ((enum isOptions) index) { |
---|
1465 | case STR_IS_ALNUM: |
---|
1466 | chcomp = Tcl_UniCharIsAlnum; |
---|
1467 | break; |
---|
1468 | case STR_IS_ALPHA: |
---|
1469 | chcomp = Tcl_UniCharIsAlpha; |
---|
1470 | break; |
---|
1471 | case STR_IS_ASCII: |
---|
1472 | chcomp = UniCharIsAscii; |
---|
1473 | break; |
---|
1474 | case STR_IS_BOOL: |
---|
1475 | case STR_IS_TRUE: |
---|
1476 | case STR_IS_FALSE: |
---|
1477 | if (TCL_OK != Tcl_ConvertToType(NULL, objPtr, &tclBooleanType)) { |
---|
1478 | result = 0; |
---|
1479 | } else if (((index == STR_IS_TRUE) && |
---|
1480 | objPtr->internalRep.longValue == 0) |
---|
1481 | || ((index == STR_IS_FALSE) && |
---|
1482 | objPtr->internalRep.longValue != 0)) { |
---|
1483 | result = 0; |
---|
1484 | } |
---|
1485 | break; |
---|
1486 | case STR_IS_CONTROL: |
---|
1487 | chcomp = Tcl_UniCharIsControl; |
---|
1488 | break; |
---|
1489 | case STR_IS_DIGIT: |
---|
1490 | chcomp = Tcl_UniCharIsDigit; |
---|
1491 | break; |
---|
1492 | case STR_IS_DOUBLE: { |
---|
1493 | /* TODO */ |
---|
1494 | if ((objPtr->typePtr == &tclDoubleType) || |
---|
1495 | (objPtr->typePtr == &tclIntType) || |
---|
1496 | #ifndef NO_WIDE_TYPE |
---|
1497 | (objPtr->typePtr == &tclWideIntType) || |
---|
1498 | #endif |
---|
1499 | (objPtr->typePtr == &tclBignumType)) { |
---|
1500 | break; |
---|
1501 | } |
---|
1502 | if (TclParseNumber(NULL, objPtr, NULL, NULL, -1, |
---|
1503 | (const char **) &stop, 0) != TCL_OK) { |
---|
1504 | result = 0; |
---|
1505 | failat = 0; |
---|
1506 | } else { |
---|
1507 | failat = stop - string1; |
---|
1508 | if (stop < end) { |
---|
1509 | result = 0; |
---|
1510 | TclFreeIntRep(objPtr); |
---|
1511 | objPtr->typePtr = NULL; |
---|
1512 | } |
---|
1513 | } |
---|
1514 | break; |
---|
1515 | } |
---|
1516 | case STR_IS_GRAPH: |
---|
1517 | chcomp = Tcl_UniCharIsGraph; |
---|
1518 | break; |
---|
1519 | case STR_IS_INT: |
---|
1520 | if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &i)) { |
---|
1521 | break; |
---|
1522 | } |
---|
1523 | goto failedIntParse; |
---|
1524 | case STR_IS_WIDE: |
---|
1525 | if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) { |
---|
1526 | break; |
---|
1527 | } |
---|
1528 | |
---|
1529 | failedIntParse: |
---|
1530 | result = 0; |
---|
1531 | |
---|
1532 | if (failVarObj == NULL) { |
---|
1533 | /* |
---|
1534 | * Don't bother computing the failure point if we're not going to |
---|
1535 | * return it. |
---|
1536 | */ |
---|
1537 | |
---|
1538 | break; |
---|
1539 | } |
---|
1540 | if (TclParseNumber(NULL, objPtr, NULL, NULL, -1, |
---|
1541 | (const char **) &stop, TCL_PARSE_INTEGER_ONLY) == TCL_OK) { |
---|
1542 | if (stop == end) { |
---|
1543 | /* |
---|
1544 | * Entire string parses as an integer, but rejected by |
---|
1545 | * Tcl_Get(Wide)IntFromObj() so we must have overflowed the |
---|
1546 | * target type, and our convention is to return failure at |
---|
1547 | * index -1 in that situation. |
---|
1548 | */ |
---|
1549 | |
---|
1550 | failat = -1; |
---|
1551 | } else { |
---|
1552 | /* |
---|
1553 | * Some prefix parsed as an integer, but not the whole string, |
---|
1554 | * so return failure index as the point where parsing stopped. |
---|
1555 | * Clear out the internal rep, since keeping it would leave |
---|
1556 | * *objPtr in an inconsistent state. |
---|
1557 | */ |
---|
1558 | |
---|
1559 | failat = stop - string1; |
---|
1560 | TclFreeIntRep(objPtr); |
---|
1561 | objPtr->typePtr = NULL; |
---|
1562 | } |
---|
1563 | } else { |
---|
1564 | /* |
---|
1565 | * No prefix is a valid integer. Fail at beginning. |
---|
1566 | */ |
---|
1567 | |
---|
1568 | failat = 0; |
---|
1569 | } |
---|
1570 | break; |
---|
1571 | case STR_IS_LIST: |
---|
1572 | /* |
---|
1573 | * We ignore the strictness here, since empty strings are always |
---|
1574 | * well-formed lists. |
---|
1575 | */ |
---|
1576 | |
---|
1577 | if (TCL_OK == TclListObjLength(NULL, objPtr, &length2)) { |
---|
1578 | break; |
---|
1579 | } |
---|
1580 | |
---|
1581 | if (failVarObj != NULL) { |
---|
1582 | /* |
---|
1583 | * Need to figure out where the list parsing failed, which is |
---|
1584 | * fairly expensive. This is adapted from the core of |
---|
1585 | * SetListFromAny(). |
---|
1586 | */ |
---|
1587 | |
---|
1588 | const char *elemStart, *nextElem, *limit; |
---|
1589 | int lenRemain, elemSize, hasBrace; |
---|
1590 | register const char *p; |
---|
1591 | |
---|
1592 | limit = string1 + length1; |
---|
1593 | failat = -1; |
---|
1594 | for (p=string1, lenRemain=length1; lenRemain > 0; |
---|
1595 | p=nextElem, lenRemain=limit-nextElem) { |
---|
1596 | if (TCL_ERROR == TclFindElement(NULL, p, lenRemain, |
---|
1597 | &elemStart, &nextElem, &elemSize, &hasBrace)) { |
---|
1598 | Tcl_Obj *tmpStr; |
---|
1599 | |
---|
1600 | /* |
---|
1601 | * This is the simplest way of getting the number of |
---|
1602 | * characters parsed. Note that this is not the same as |
---|
1603 | * the number of bytes when parsing strings with non-ASCII |
---|
1604 | * characters in them. |
---|
1605 | * |
---|
1606 | * Skip leading spaces first. This is only really an issue |
---|
1607 | * if it is the first "element" that has the failure. |
---|
1608 | */ |
---|
1609 | |
---|
1610 | while (isspace(UCHAR(*p))) { /* INTL: ? */ |
---|
1611 | p++; |
---|
1612 | } |
---|
1613 | TclNewStringObj(tmpStr, string1, p-string1); |
---|
1614 | failat = Tcl_GetCharLength(tmpStr); |
---|
1615 | TclDecrRefCount(tmpStr); |
---|
1616 | break; |
---|
1617 | } |
---|
1618 | } |
---|
1619 | } |
---|
1620 | result = 0; |
---|
1621 | break; |
---|
1622 | case STR_IS_LOWER: |
---|
1623 | chcomp = Tcl_UniCharIsLower; |
---|
1624 | break; |
---|
1625 | case STR_IS_PRINT: |
---|
1626 | chcomp = Tcl_UniCharIsPrint; |
---|
1627 | break; |
---|
1628 | case STR_IS_PUNCT: |
---|
1629 | chcomp = Tcl_UniCharIsPunct; |
---|
1630 | break; |
---|
1631 | case STR_IS_SPACE: |
---|
1632 | chcomp = Tcl_UniCharIsSpace; |
---|
1633 | break; |
---|
1634 | case STR_IS_UPPER: |
---|
1635 | chcomp = Tcl_UniCharIsUpper; |
---|
1636 | break; |
---|
1637 | case STR_IS_WORD: |
---|
1638 | chcomp = Tcl_UniCharIsWordChar; |
---|
1639 | break; |
---|
1640 | case STR_IS_XDIGIT: |
---|
1641 | for (; string1 < end; string1++, failat++) { |
---|
1642 | /* INTL: We assume unicode is bad for this class. */ |
---|
1643 | if ((*((unsigned char *)string1) >= 0xC0) || |
---|
1644 | !isxdigit(*(unsigned char *)string1)) { |
---|
1645 | result = 0; |
---|
1646 | break; |
---|
1647 | } |
---|
1648 | } |
---|
1649 | break; |
---|
1650 | } |
---|
1651 | if (chcomp != NULL) { |
---|
1652 | for (; string1 < end; string1 += length2, failat++) { |
---|
1653 | length2 = TclUtfToUniChar(string1, &ch); |
---|
1654 | if (!chcomp(ch)) { |
---|
1655 | result = 0; |
---|
1656 | break; |
---|
1657 | } |
---|
1658 | } |
---|
1659 | } |
---|
1660 | |
---|
1661 | /* |
---|
1662 | * Only set the failVarObj when we will return 0 and we have indicated a |
---|
1663 | * valid fail index (>= 0). |
---|
1664 | */ |
---|
1665 | |
---|
1666 | str_is_done: |
---|
1667 | if ((result == 0) && (failVarObj != NULL) && |
---|
1668 | Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat), |
---|
1669 | TCL_LEAVE_ERR_MSG) == NULL) { |
---|
1670 | return TCL_ERROR; |
---|
1671 | } |
---|
1672 | Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); |
---|
1673 | return TCL_OK; |
---|
1674 | } |
---|
1675 | |
---|
1676 | static int |
---|
1677 | UniCharIsAscii( |
---|
1678 | int character) |
---|
1679 | { |
---|
1680 | return (character >= 0) && (character < 0x80); |
---|
1681 | } |
---|
1682 | |
---|
1683 | /* |
---|
1684 | *---------------------------------------------------------------------- |
---|
1685 | * |
---|
1686 | * StringMapCmd -- |
---|
1687 | * |
---|
1688 | * This procedure is invoked to process the "string map" Tcl command. See |
---|
1689 | * the user documentation for details on what it does. Note that this |
---|
1690 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
1691 | * |
---|
1692 | * Results: |
---|
1693 | * A standard Tcl result. |
---|
1694 | * |
---|
1695 | * Side effects: |
---|
1696 | * See the user documentation. |
---|
1697 | * |
---|
1698 | *---------------------------------------------------------------------- |
---|
1699 | */ |
---|
1700 | |
---|
1701 | static int |
---|
1702 | StringMapCmd( |
---|
1703 | ClientData dummy, /* Not used. */ |
---|
1704 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
1705 | int objc, /* Number of arguments. */ |
---|
1706 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
1707 | { |
---|
1708 | int length1, length2, mapElemc, index; |
---|
1709 | int nocase = 0, mapWithDict = 0, copySource = 0; |
---|
1710 | Tcl_Obj **mapElemv, *sourceObj, *resultPtr; |
---|
1711 | Tcl_UniChar *ustring1, *ustring2, *p, *end; |
---|
1712 | int (*strCmpFn)(const Tcl_UniChar*, const Tcl_UniChar*, unsigned long); |
---|
1713 | |
---|
1714 | if (objc < 3 || objc > 4) { |
---|
1715 | Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? charMap string"); |
---|
1716 | return TCL_ERROR; |
---|
1717 | } |
---|
1718 | |
---|
1719 | if (objc == 4) { |
---|
1720 | const char *string = TclGetStringFromObj(objv[1], &length2); |
---|
1721 | |
---|
1722 | if ((length2 > 1) && |
---|
1723 | strncmp(string, "-nocase", (size_t) length2) == 0) { |
---|
1724 | nocase = 1; |
---|
1725 | } else { |
---|
1726 | Tcl_AppendResult(interp, "bad option \"", string, |
---|
1727 | "\": must be -nocase", NULL); |
---|
1728 | return TCL_ERROR; |
---|
1729 | } |
---|
1730 | } |
---|
1731 | |
---|
1732 | /* |
---|
1733 | * This test is tricky, but has to be that way or you get other strange |
---|
1734 | * inconsistencies (see test string-10.20 for illustration why!) |
---|
1735 | */ |
---|
1736 | |
---|
1737 | if (objv[objc-2]->typePtr == &tclDictType && objv[objc-2]->bytes == NULL){ |
---|
1738 | int i, done; |
---|
1739 | Tcl_DictSearch search; |
---|
1740 | |
---|
1741 | /* |
---|
1742 | * We know the type exactly, so all dict operations will succeed for |
---|
1743 | * sure. This shortens this code quite a bit. |
---|
1744 | */ |
---|
1745 | |
---|
1746 | Tcl_DictObjSize(interp, objv[objc-2], &mapElemc); |
---|
1747 | if (mapElemc == 0) { |
---|
1748 | /* |
---|
1749 | * Empty charMap, just return whatever string was given. |
---|
1750 | */ |
---|
1751 | |
---|
1752 | Tcl_SetObjResult(interp, objv[objc-1]); |
---|
1753 | return TCL_OK; |
---|
1754 | } |
---|
1755 | |
---|
1756 | mapElemc *= 2; |
---|
1757 | mapWithDict = 1; |
---|
1758 | |
---|
1759 | /* |
---|
1760 | * Copy the dictionary out into an array; that's the easiest way to |
---|
1761 | * adapt this code... |
---|
1762 | */ |
---|
1763 | |
---|
1764 | mapElemv = (Tcl_Obj **) |
---|
1765 | TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc); |
---|
1766 | Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0, |
---|
1767 | mapElemv+1, &done); |
---|
1768 | for (i=2 ; i<mapElemc ; i+=2) { |
---|
1769 | Tcl_DictObjNext(&search, mapElemv+i, mapElemv+i+1, &done); |
---|
1770 | } |
---|
1771 | Tcl_DictObjDone(&search); |
---|
1772 | } else { |
---|
1773 | if (TclListObjGetElements(interp, objv[objc-2], &mapElemc, |
---|
1774 | &mapElemv) != TCL_OK) { |
---|
1775 | return TCL_ERROR; |
---|
1776 | } |
---|
1777 | if (mapElemc == 0) { |
---|
1778 | /* |
---|
1779 | * empty charMap, just return whatever string was given. |
---|
1780 | */ |
---|
1781 | |
---|
1782 | Tcl_SetObjResult(interp, objv[objc-1]); |
---|
1783 | return TCL_OK; |
---|
1784 | } else if (mapElemc & 1) { |
---|
1785 | /* |
---|
1786 | * The charMap must be an even number of key/value items. |
---|
1787 | */ |
---|
1788 | |
---|
1789 | Tcl_SetObjResult(interp, |
---|
1790 | Tcl_NewStringObj("char map list unbalanced", -1)); |
---|
1791 | return TCL_ERROR; |
---|
1792 | } |
---|
1793 | } |
---|
1794 | |
---|
1795 | /* |
---|
1796 | * Take a copy of the source string object if it is the same as the map |
---|
1797 | * string to cut out nasty sharing crashes. [Bug 1018562] |
---|
1798 | */ |
---|
1799 | |
---|
1800 | if (objv[objc-2] == objv[objc-1]) { |
---|
1801 | sourceObj = Tcl_DuplicateObj(objv[objc-1]); |
---|
1802 | copySource = 1; |
---|
1803 | } else { |
---|
1804 | sourceObj = objv[objc-1]; |
---|
1805 | } |
---|
1806 | ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1); |
---|
1807 | if (length1 == 0) { |
---|
1808 | /* |
---|
1809 | * Empty input string, just stop now. |
---|
1810 | */ |
---|
1811 | |
---|
1812 | goto done; |
---|
1813 | } |
---|
1814 | end = ustring1 + length1; |
---|
1815 | |
---|
1816 | strCmpFn = (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); |
---|
1817 | |
---|
1818 | /* |
---|
1819 | * Force result to be Unicode |
---|
1820 | */ |
---|
1821 | |
---|
1822 | resultPtr = Tcl_NewUnicodeObj(ustring1, 0); |
---|
1823 | |
---|
1824 | if (mapElemc == 2) { |
---|
1825 | /* |
---|
1826 | * Special case for one map pair which avoids the extra for loop and |
---|
1827 | * extra calls to get Unicode data. The algorithm is otherwise |
---|
1828 | * identical to the multi-pair case. This will be >30% faster on |
---|
1829 | * larger strings. |
---|
1830 | */ |
---|
1831 | |
---|
1832 | int mapLen; |
---|
1833 | Tcl_UniChar *mapString, u2lc; |
---|
1834 | |
---|
1835 | ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); |
---|
1836 | p = ustring1; |
---|
1837 | if ((length2 > length1) || (length2 == 0)) { |
---|
1838 | /* |
---|
1839 | * Match string is either longer than input or empty. |
---|
1840 | */ |
---|
1841 | |
---|
1842 | ustring1 = end; |
---|
1843 | } else { |
---|
1844 | mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); |
---|
1845 | u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); |
---|
1846 | for (; ustring1 < end; ustring1++) { |
---|
1847 | if (((*ustring1 == *ustring2) || |
---|
1848 | (nocase&&Tcl_UniCharToLower(*ustring1)==u2lc)) && |
---|
1849 | (length2==1 || strCmpFn(ustring1, ustring2, |
---|
1850 | (unsigned long) length2) == 0)) { |
---|
1851 | if (p != ustring1) { |
---|
1852 | Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); |
---|
1853 | p = ustring1 + length2; |
---|
1854 | } else { |
---|
1855 | p += length2; |
---|
1856 | } |
---|
1857 | ustring1 = p - 1; |
---|
1858 | |
---|
1859 | Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen); |
---|
1860 | } |
---|
1861 | } |
---|
1862 | } |
---|
1863 | } else { |
---|
1864 | Tcl_UniChar **mapStrings, *u2lc = NULL; |
---|
1865 | int *mapLens; |
---|
1866 | |
---|
1867 | /* |
---|
1868 | * Precompute pointers to the unicode string and length. This saves us |
---|
1869 | * repeated function calls later, significantly speeding up the |
---|
1870 | * algorithm. We only need the lowercase first char in the nocase |
---|
1871 | * case. |
---|
1872 | */ |
---|
1873 | |
---|
1874 | mapStrings = (Tcl_UniChar **) TclStackAlloc(interp, |
---|
1875 | mapElemc * 2 * sizeof(Tcl_UniChar *)); |
---|
1876 | mapLens = (int *) TclStackAlloc(interp, mapElemc * 2 * sizeof(int)); |
---|
1877 | if (nocase) { |
---|
1878 | u2lc = (Tcl_UniChar *) TclStackAlloc(interp, |
---|
1879 | mapElemc * sizeof(Tcl_UniChar)); |
---|
1880 | } |
---|
1881 | for (index = 0; index < mapElemc; index++) { |
---|
1882 | mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], |
---|
1883 | mapLens+index); |
---|
1884 | if (nocase && ((index % 2) == 0)) { |
---|
1885 | u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]); |
---|
1886 | } |
---|
1887 | } |
---|
1888 | for (p = ustring1; ustring1 < end; ustring1++) { |
---|
1889 | for (index = 0; index < mapElemc; index += 2) { |
---|
1890 | /* |
---|
1891 | * Get the key string to match on. |
---|
1892 | */ |
---|
1893 | |
---|
1894 | ustring2 = mapStrings[index]; |
---|
1895 | length2 = mapLens[index]; |
---|
1896 | if ((length2 > 0) && ((*ustring1 == *ustring2) || (nocase && |
---|
1897 | (Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) && |
---|
1898 | /* Restrict max compare length. */ |
---|
1899 | (end-ustring1 >= length2) && ((length2 == 1) || |
---|
1900 | !strCmpFn(ustring2, ustring1, (unsigned) length2))) { |
---|
1901 | if (p != ustring1) { |
---|
1902 | /* |
---|
1903 | * Put the skipped chars onto the result first. |
---|
1904 | */ |
---|
1905 | |
---|
1906 | Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); |
---|
1907 | p = ustring1 + length2; |
---|
1908 | } else { |
---|
1909 | p += length2; |
---|
1910 | } |
---|
1911 | |
---|
1912 | /* |
---|
1913 | * Adjust len to be full length of matched string. |
---|
1914 | */ |
---|
1915 | |
---|
1916 | ustring1 = p - 1; |
---|
1917 | |
---|
1918 | /* |
---|
1919 | * Append the map value to the unicode string. |
---|
1920 | */ |
---|
1921 | |
---|
1922 | Tcl_AppendUnicodeToObj(resultPtr, |
---|
1923 | mapStrings[index+1], mapLens[index+1]); |
---|
1924 | break; |
---|
1925 | } |
---|
1926 | } |
---|
1927 | } |
---|
1928 | if (nocase) { |
---|
1929 | TclStackFree(interp, u2lc); |
---|
1930 | } |
---|
1931 | TclStackFree(interp, mapLens); |
---|
1932 | TclStackFree(interp, mapStrings); |
---|
1933 | } |
---|
1934 | if (p != ustring1) { |
---|
1935 | /* |
---|
1936 | * Put the rest of the unmapped chars onto result. |
---|
1937 | */ |
---|
1938 | |
---|
1939 | Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); |
---|
1940 | } |
---|
1941 | Tcl_SetObjResult(interp, resultPtr); |
---|
1942 | done: |
---|
1943 | if (mapWithDict) { |
---|
1944 | TclStackFree(interp, mapElemv); |
---|
1945 | } |
---|
1946 | if (copySource) { |
---|
1947 | Tcl_DecrRefCount(sourceObj); |
---|
1948 | } |
---|
1949 | return TCL_OK; |
---|
1950 | } |
---|
1951 | |
---|
1952 | /* |
---|
1953 | *---------------------------------------------------------------------- |
---|
1954 | * |
---|
1955 | * StringMatchCmd -- |
---|
1956 | * |
---|
1957 | * This procedure is invoked to process the "string match" Tcl command. |
---|
1958 | * See the user documentation for details on what it does. Note that this |
---|
1959 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
1960 | * |
---|
1961 | * Results: |
---|
1962 | * A standard Tcl result. |
---|
1963 | * |
---|
1964 | * Side effects: |
---|
1965 | * See the user documentation. |
---|
1966 | * |
---|
1967 | *---------------------------------------------------------------------- |
---|
1968 | */ |
---|
1969 | |
---|
1970 | static int |
---|
1971 | StringMatchCmd( |
---|
1972 | ClientData dummy, /* Not used. */ |
---|
1973 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
1974 | int objc, /* Number of arguments. */ |
---|
1975 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
1976 | { |
---|
1977 | int nocase = 0; |
---|
1978 | |
---|
1979 | if (objc < 3 || objc > 4) { |
---|
1980 | Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? pattern string"); |
---|
1981 | return TCL_ERROR; |
---|
1982 | } |
---|
1983 | |
---|
1984 | if (objc == 4) { |
---|
1985 | int length; |
---|
1986 | const char *string = TclGetStringFromObj(objv[1], &length); |
---|
1987 | |
---|
1988 | if ((length > 1) && |
---|
1989 | strncmp(string, "-nocase", (size_t) length) == 0) { |
---|
1990 | nocase = TCL_MATCH_NOCASE; |
---|
1991 | } else { |
---|
1992 | Tcl_AppendResult(interp, "bad option \"", string, |
---|
1993 | "\": must be -nocase", NULL); |
---|
1994 | return TCL_ERROR; |
---|
1995 | } |
---|
1996 | } |
---|
1997 | Tcl_SetObjResult(interp, Tcl_NewBooleanObj( |
---|
1998 | TclStringMatchObj(objv[objc-1], objv[objc-2], nocase))); |
---|
1999 | return TCL_OK; |
---|
2000 | } |
---|
2001 | |
---|
2002 | /* |
---|
2003 | *---------------------------------------------------------------------- |
---|
2004 | * |
---|
2005 | * StringRangeCmd -- |
---|
2006 | * |
---|
2007 | * This procedure is invoked to process the "string range" Tcl command. |
---|
2008 | * See the user documentation for details on what it does. Note that this |
---|
2009 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
2010 | * |
---|
2011 | * Results: |
---|
2012 | * A standard Tcl result. |
---|
2013 | * |
---|
2014 | * Side effects: |
---|
2015 | * See the user documentation. |
---|
2016 | * |
---|
2017 | *---------------------------------------------------------------------- |
---|
2018 | */ |
---|
2019 | |
---|
2020 | static int |
---|
2021 | StringRangeCmd( |
---|
2022 | ClientData dummy, /* Not used. */ |
---|
2023 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
2024 | int objc, /* Number of arguments. */ |
---|
2025 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
2026 | { |
---|
2027 | const unsigned char *string; |
---|
2028 | int length, first, last; |
---|
2029 | |
---|
2030 | if (objc != 4) { |
---|
2031 | Tcl_WrongNumArgs(interp, 1, objv, "string first last"); |
---|
2032 | return TCL_ERROR; |
---|
2033 | } |
---|
2034 | |
---|
2035 | /* |
---|
2036 | * If we have a ByteArray object, avoid indexing in the Utf string since |
---|
2037 | * the byte array contains one byte per character. Otherwise, use the |
---|
2038 | * Unicode string rep to get the range. |
---|
2039 | */ |
---|
2040 | |
---|
2041 | if (objv[1]->typePtr == &tclByteArrayType) { |
---|
2042 | string = Tcl_GetByteArrayFromObj(objv[1], &length); |
---|
2043 | length--; |
---|
2044 | } else { |
---|
2045 | /* |
---|
2046 | * Get the length in actual characters. |
---|
2047 | */ |
---|
2048 | |
---|
2049 | string = NULL; |
---|
2050 | length = Tcl_GetCharLength(objv[1]) - 1; |
---|
2051 | } |
---|
2052 | |
---|
2053 | if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK || |
---|
2054 | TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK) { |
---|
2055 | return TCL_ERROR; |
---|
2056 | } |
---|
2057 | |
---|
2058 | if (first < 0) { |
---|
2059 | first = 0; |
---|
2060 | } |
---|
2061 | if (last >= length) { |
---|
2062 | last = length; |
---|
2063 | } |
---|
2064 | if (last >= first) { |
---|
2065 | if (string != NULL) { |
---|
2066 | /* |
---|
2067 | * Reread the string to prevent shimmering nasties. |
---|
2068 | */ |
---|
2069 | |
---|
2070 | string = Tcl_GetByteArrayFromObj(objv[1], &length); |
---|
2071 | Tcl_SetObjResult(interp, |
---|
2072 | Tcl_NewByteArrayObj(string+first, last - first + 1)); |
---|
2073 | } else { |
---|
2074 | Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last)); |
---|
2075 | } |
---|
2076 | } |
---|
2077 | return TCL_OK; |
---|
2078 | } |
---|
2079 | |
---|
2080 | /* |
---|
2081 | *---------------------------------------------------------------------- |
---|
2082 | * |
---|
2083 | * StringReptCmd -- |
---|
2084 | * |
---|
2085 | * This procedure is invoked to process the "string repeat" Tcl command. |
---|
2086 | * See the user documentation for details on what it does. Note that this |
---|
2087 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
2088 | * |
---|
2089 | * Results: |
---|
2090 | * A standard Tcl result. |
---|
2091 | * |
---|
2092 | * Side effects: |
---|
2093 | * See the user documentation. |
---|
2094 | * |
---|
2095 | *---------------------------------------------------------------------- |
---|
2096 | */ |
---|
2097 | |
---|
2098 | static int |
---|
2099 | StringReptCmd( |
---|
2100 | ClientData dummy, /* Not used. */ |
---|
2101 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
2102 | int objc, /* Number of arguments. */ |
---|
2103 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
2104 | { |
---|
2105 | const char *string1; |
---|
2106 | char *string2; |
---|
2107 | int count, index, length1, length2; |
---|
2108 | Tcl_Obj *resultPtr; |
---|
2109 | |
---|
2110 | if (objc != 3) { |
---|
2111 | Tcl_WrongNumArgs(interp, 1, objv, "string count"); |
---|
2112 | return TCL_ERROR; |
---|
2113 | } |
---|
2114 | |
---|
2115 | if (TclGetIntFromObj(interp, objv[2], &count) != TCL_OK) { |
---|
2116 | return TCL_ERROR; |
---|
2117 | } |
---|
2118 | |
---|
2119 | /* |
---|
2120 | * Check for cases that allow us to skip copying stuff. |
---|
2121 | */ |
---|
2122 | |
---|
2123 | if (count == 1) { |
---|
2124 | Tcl_SetObjResult(interp, objv[1]); |
---|
2125 | goto done; |
---|
2126 | } else if (count < 1) { |
---|
2127 | goto done; |
---|
2128 | } |
---|
2129 | string1 = TclGetStringFromObj(objv[1], &length1); |
---|
2130 | if (length1 <= 0) { |
---|
2131 | goto done; |
---|
2132 | } |
---|
2133 | |
---|
2134 | /* |
---|
2135 | * Only build up a string that has data. Instead of building it up with |
---|
2136 | * repeated appends, we just allocate the necessary space once and copy |
---|
2137 | * the string value in. Check for overflow with back-division. [Bug |
---|
2138 | * #714106] |
---|
2139 | */ |
---|
2140 | |
---|
2141 | length2 = length1 * count + 1; |
---|
2142 | if ((length2-1) / count != length1) { |
---|
2143 | Tcl_SetObjResult(interp, Tcl_ObjPrintf( |
---|
2144 | "string size overflow, must be less than %d", INT_MAX)); |
---|
2145 | return TCL_ERROR; |
---|
2146 | } |
---|
2147 | |
---|
2148 | /* |
---|
2149 | * Include space for the NUL. |
---|
2150 | */ |
---|
2151 | |
---|
2152 | string2 = attemptckalloc((size_t) length2); |
---|
2153 | if (string2 == NULL) { |
---|
2154 | /* |
---|
2155 | * Alloc failed. Note that in this case we try to do an error message |
---|
2156 | * since this is a case that's most likely when the alloc is large and |
---|
2157 | * that's easy to do with this API. Note that if we fail allocating a |
---|
2158 | * short string, this will likely keel over too (and fatally). |
---|
2159 | */ |
---|
2160 | |
---|
2161 | Tcl_SetObjResult(interp, Tcl_ObjPrintf( |
---|
2162 | "string size overflow, out of memory allocating %d bytes", |
---|
2163 | length2)); |
---|
2164 | return TCL_ERROR; |
---|
2165 | } |
---|
2166 | for (index = 0; index < count; index++) { |
---|
2167 | memcpy(string2 + (length1 * index), string1, (size_t) length1); |
---|
2168 | } |
---|
2169 | string2[length2-1] = '\0'; |
---|
2170 | |
---|
2171 | /* |
---|
2172 | * We have to directly assign this instead of using Tcl_SetStringObj (and |
---|
2173 | * indirectly TclInitStringRep) because that makes another copy of the |
---|
2174 | * data. |
---|
2175 | */ |
---|
2176 | |
---|
2177 | TclNewObj(resultPtr); |
---|
2178 | resultPtr->bytes = string2; |
---|
2179 | resultPtr->length = length2-1; |
---|
2180 | Tcl_SetObjResult(interp, resultPtr); |
---|
2181 | |
---|
2182 | done: |
---|
2183 | return TCL_OK; |
---|
2184 | } |
---|
2185 | |
---|
2186 | /* |
---|
2187 | *---------------------------------------------------------------------- |
---|
2188 | * |
---|
2189 | * StringRplcCmd -- |
---|
2190 | * |
---|
2191 | * This procedure is invoked to process the "string replace" Tcl command. |
---|
2192 | * See the user documentation for details on what it does. Note that this |
---|
2193 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
2194 | * |
---|
2195 | * Results: |
---|
2196 | * A standard Tcl result. |
---|
2197 | * |
---|
2198 | * Side effects: |
---|
2199 | * See the user documentation. |
---|
2200 | * |
---|
2201 | *---------------------------------------------------------------------- |
---|
2202 | */ |
---|
2203 | |
---|
2204 | static int |
---|
2205 | StringRplcCmd( |
---|
2206 | ClientData dummy, /* Not used. */ |
---|
2207 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
2208 | int objc, /* Number of arguments. */ |
---|
2209 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
2210 | { |
---|
2211 | Tcl_UniChar *ustring; |
---|
2212 | int first, last, length; |
---|
2213 | |
---|
2214 | if (objc < 4 || objc > 5) { |
---|
2215 | Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?"); |
---|
2216 | return TCL_ERROR; |
---|
2217 | } |
---|
2218 | |
---|
2219 | ustring = Tcl_GetUnicodeFromObj(objv[1], &length); |
---|
2220 | length--; |
---|
2221 | |
---|
2222 | if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK || |
---|
2223 | TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK){ |
---|
2224 | return TCL_ERROR; |
---|
2225 | } |
---|
2226 | |
---|
2227 | if ((last < first) || (last < 0) || (first > length)) { |
---|
2228 | Tcl_SetObjResult(interp, objv[1]); |
---|
2229 | } else { |
---|
2230 | Tcl_Obj *resultPtr; |
---|
2231 | |
---|
2232 | ustring = Tcl_GetUnicodeFromObj(objv[1], &length); |
---|
2233 | length--; |
---|
2234 | |
---|
2235 | if (first < 0) { |
---|
2236 | first = 0; |
---|
2237 | } |
---|
2238 | |
---|
2239 | resultPtr = Tcl_NewUnicodeObj(ustring, first); |
---|
2240 | if (objc == 5) { |
---|
2241 | Tcl_AppendObjToObj(resultPtr, objv[4]); |
---|
2242 | } |
---|
2243 | if (last < length) { |
---|
2244 | Tcl_AppendUnicodeToObj(resultPtr, ustring + last + 1, |
---|
2245 | length - last); |
---|
2246 | } |
---|
2247 | Tcl_SetObjResult(interp, resultPtr); |
---|
2248 | } |
---|
2249 | return TCL_OK; |
---|
2250 | } |
---|
2251 | |
---|
2252 | /* |
---|
2253 | *---------------------------------------------------------------------- |
---|
2254 | * |
---|
2255 | * StringRevCmd -- |
---|
2256 | * |
---|
2257 | * This procedure is invoked to process the "string reverse" Tcl command. |
---|
2258 | * See the user documentation for details on what it does. Note that this |
---|
2259 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
2260 | * |
---|
2261 | * Results: |
---|
2262 | * A standard Tcl result. |
---|
2263 | * |
---|
2264 | * Side effects: |
---|
2265 | * See the user documentation. |
---|
2266 | * |
---|
2267 | *---------------------------------------------------------------------- |
---|
2268 | */ |
---|
2269 | |
---|
2270 | static int |
---|
2271 | StringRevCmd( |
---|
2272 | ClientData dummy, /* Not used. */ |
---|
2273 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
2274 | int objc, /* Number of arguments. */ |
---|
2275 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
2276 | { |
---|
2277 | if (objc != 2) { |
---|
2278 | Tcl_WrongNumArgs(interp, 1, objv, "string"); |
---|
2279 | return TCL_ERROR; |
---|
2280 | } |
---|
2281 | |
---|
2282 | Tcl_SetObjResult(interp, TclStringObjReverse(objv[1])); |
---|
2283 | return TCL_OK; |
---|
2284 | } |
---|
2285 | |
---|
2286 | /* |
---|
2287 | *---------------------------------------------------------------------- |
---|
2288 | * |
---|
2289 | * StringStartCmd -- |
---|
2290 | * |
---|
2291 | * This procedure is invoked to process the "string wordstart" Tcl |
---|
2292 | * command. See the user documentation for details on what it does. Note |
---|
2293 | * that this command only functions correctly on properly formed Tcl UTF |
---|
2294 | * strings. |
---|
2295 | * |
---|
2296 | * Results: |
---|
2297 | * A standard Tcl result. |
---|
2298 | * |
---|
2299 | * Side effects: |
---|
2300 | * See the user documentation. |
---|
2301 | * |
---|
2302 | *---------------------------------------------------------------------- |
---|
2303 | */ |
---|
2304 | |
---|
2305 | static int |
---|
2306 | StringStartCmd( |
---|
2307 | ClientData dummy, /* Not used. */ |
---|
2308 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
2309 | int objc, /* Number of arguments. */ |
---|
2310 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
2311 | { |
---|
2312 | Tcl_UniChar ch; |
---|
2313 | const char *p, *string; |
---|
2314 | int cur, index, length, numChars; |
---|
2315 | |
---|
2316 | if (objc != 3) { |
---|
2317 | Tcl_WrongNumArgs(interp, 1, objv, "string index"); |
---|
2318 | return TCL_ERROR; |
---|
2319 | } |
---|
2320 | |
---|
2321 | string = TclGetStringFromObj(objv[1], &length); |
---|
2322 | numChars = Tcl_NumUtfChars(string, length); |
---|
2323 | if (TclGetIntForIndexM(interp, objv[2], numChars-1, &index) != TCL_OK) { |
---|
2324 | return TCL_ERROR; |
---|
2325 | } |
---|
2326 | string = TclGetStringFromObj(objv[1], &length); |
---|
2327 | if (index >= numChars) { |
---|
2328 | index = numChars - 1; |
---|
2329 | } |
---|
2330 | cur = 0; |
---|
2331 | if (index > 0) { |
---|
2332 | p = Tcl_UtfAtIndex(string, index); |
---|
2333 | for (cur = index; cur >= 0; cur--) { |
---|
2334 | TclUtfToUniChar(p, &ch); |
---|
2335 | if (!Tcl_UniCharIsWordChar(ch)) { |
---|
2336 | break; |
---|
2337 | } |
---|
2338 | p = Tcl_UtfPrev(p, string); |
---|
2339 | } |
---|
2340 | if (cur != index) { |
---|
2341 | cur += 1; |
---|
2342 | } |
---|
2343 | } |
---|
2344 | Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); |
---|
2345 | return TCL_OK; |
---|
2346 | } |
---|
2347 | |
---|
2348 | /* |
---|
2349 | *---------------------------------------------------------------------- |
---|
2350 | * |
---|
2351 | * StringEndCmd -- |
---|
2352 | * |
---|
2353 | * This procedure is invoked to process the "string wordend" Tcl command. |
---|
2354 | * See the user documentation for details on what it does. Note that this |
---|
2355 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
2356 | * |
---|
2357 | * Results: |
---|
2358 | * A standard Tcl result. |
---|
2359 | * |
---|
2360 | * Side effects: |
---|
2361 | * See the user documentation. |
---|
2362 | * |
---|
2363 | *---------------------------------------------------------------------- |
---|
2364 | */ |
---|
2365 | |
---|
2366 | static int |
---|
2367 | StringEndCmd( |
---|
2368 | ClientData dummy, /* Not used. */ |
---|
2369 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
2370 | int objc, /* Number of arguments. */ |
---|
2371 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
2372 | { |
---|
2373 | Tcl_UniChar ch; |
---|
2374 | const char *p, *end, *string; |
---|
2375 | int cur, index, length, numChars; |
---|
2376 | |
---|
2377 | if (objc != 3) { |
---|
2378 | Tcl_WrongNumArgs(interp, 1, objv, "string index"); |
---|
2379 | return TCL_ERROR; |
---|
2380 | } |
---|
2381 | |
---|
2382 | string = TclGetStringFromObj(objv[1], &length); |
---|
2383 | numChars = Tcl_NumUtfChars(string, length); |
---|
2384 | if (TclGetIntForIndexM(interp, objv[2], numChars-1, &index) != TCL_OK) { |
---|
2385 | return TCL_ERROR; |
---|
2386 | } |
---|
2387 | string = TclGetStringFromObj(objv[1], &length); |
---|
2388 | if (index < 0) { |
---|
2389 | index = 0; |
---|
2390 | } |
---|
2391 | if (index < numChars) { |
---|
2392 | p = Tcl_UtfAtIndex(string, index); |
---|
2393 | end = string+length; |
---|
2394 | for (cur = index; p < end; cur++) { |
---|
2395 | p += TclUtfToUniChar(p, &ch); |
---|
2396 | if (!Tcl_UniCharIsWordChar(ch)) { |
---|
2397 | break; |
---|
2398 | } |
---|
2399 | } |
---|
2400 | if (cur == index) { |
---|
2401 | cur++; |
---|
2402 | } |
---|
2403 | } else { |
---|
2404 | cur = numChars; |
---|
2405 | } |
---|
2406 | Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); |
---|
2407 | return TCL_OK; |
---|
2408 | } |
---|
2409 | |
---|
2410 | /* |
---|
2411 | *---------------------------------------------------------------------- |
---|
2412 | * |
---|
2413 | * StringEqualCmd -- |
---|
2414 | * |
---|
2415 | * This procedure is invoked to process the "string equal" Tcl command. |
---|
2416 | * See the user documentation for details on what it does. Note that this |
---|
2417 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
2418 | * |
---|
2419 | * Results: |
---|
2420 | * A standard Tcl result. |
---|
2421 | * |
---|
2422 | * Side effects: |
---|
2423 | * See the user documentation. |
---|
2424 | * |
---|
2425 | *---------------------------------------------------------------------- |
---|
2426 | */ |
---|
2427 | |
---|
2428 | static int |
---|
2429 | StringEqualCmd( |
---|
2430 | ClientData dummy, /* Not used. */ |
---|
2431 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
2432 | int objc, /* Number of arguments. */ |
---|
2433 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
2434 | { |
---|
2435 | /* |
---|
2436 | * Remember to keep code here in some sync with the byte-compiled versions |
---|
2437 | * in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as |
---|
2438 | * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). |
---|
2439 | */ |
---|
2440 | |
---|
2441 | char *string1, *string2; |
---|
2442 | int length1, length2, i, match, length, nocase = 0, reqlength = -1; |
---|
2443 | typedef int (*strCmpFn_t)(const char *, const char *, unsigned int); |
---|
2444 | strCmpFn_t strCmpFn; |
---|
2445 | |
---|
2446 | if (objc < 3 || objc > 6) { |
---|
2447 | str_cmp_args: |
---|
2448 | Tcl_WrongNumArgs(interp, 1, objv, |
---|
2449 | "?-nocase? ?-length int? string1 string2"); |
---|
2450 | return TCL_ERROR; |
---|
2451 | } |
---|
2452 | |
---|
2453 | for (i = 1; i < objc-2; i++) { |
---|
2454 | string2 = TclGetStringFromObj(objv[i], &length2); |
---|
2455 | if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) { |
---|
2456 | nocase = 1; |
---|
2457 | } else if ((length2 > 1) |
---|
2458 | && !strncmp(string2, "-length", (size_t)length2)) { |
---|
2459 | if (i+1 >= objc-2) { |
---|
2460 | goto str_cmp_args; |
---|
2461 | } |
---|
2462 | ++i; |
---|
2463 | if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { |
---|
2464 | return TCL_ERROR; |
---|
2465 | } |
---|
2466 | } else { |
---|
2467 | Tcl_AppendResult(interp, "bad option \"", string2, |
---|
2468 | "\": must be -nocase or -length", NULL); |
---|
2469 | return TCL_ERROR; |
---|
2470 | } |
---|
2471 | } |
---|
2472 | |
---|
2473 | /* |
---|
2474 | * From now on, we only access the two objects at the end of the argument |
---|
2475 | * array. |
---|
2476 | */ |
---|
2477 | |
---|
2478 | objv += objc-2; |
---|
2479 | |
---|
2480 | if ((reqlength == 0) || (objv[0] == objv[1])) { |
---|
2481 | /* |
---|
2482 | * Always match at 0 chars of if it is the same obj. |
---|
2483 | */ |
---|
2484 | |
---|
2485 | Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); |
---|
2486 | return TCL_OK; |
---|
2487 | } |
---|
2488 | |
---|
2489 | if (!nocase && objv[0]->typePtr == &tclByteArrayType && |
---|
2490 | objv[1]->typePtr == &tclByteArrayType) { |
---|
2491 | /* |
---|
2492 | * Use binary versions of comparisons since that won't cause undue |
---|
2493 | * type conversions and it is much faster. Only do this if we're |
---|
2494 | * case-sensitive (which is all that really makes sense with byte |
---|
2495 | * arrays anyway, and we have no memcasecmp() for some reason... :^) |
---|
2496 | */ |
---|
2497 | |
---|
2498 | string1 = (char *) Tcl_GetByteArrayFromObj(objv[0], &length1); |
---|
2499 | string2 = (char *) Tcl_GetByteArrayFromObj(objv[1], &length2); |
---|
2500 | strCmpFn = (strCmpFn_t) memcmp; |
---|
2501 | } else if ((objv[0]->typePtr == &tclStringType) |
---|
2502 | && (objv[1]->typePtr == &tclStringType)) { |
---|
2503 | /* |
---|
2504 | * Do a unicode-specific comparison if both of the args are of String |
---|
2505 | * type. In benchmark testing this proved the most efficient check |
---|
2506 | * between the unicode and string comparison operations. |
---|
2507 | */ |
---|
2508 | |
---|
2509 | string1 = (char *) Tcl_GetUnicodeFromObj(objv[0], &length1); |
---|
2510 | string2 = (char *) Tcl_GetUnicodeFromObj(objv[1], &length2); |
---|
2511 | strCmpFn = (strCmpFn_t) |
---|
2512 | (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); |
---|
2513 | } else { |
---|
2514 | /* |
---|
2515 | * As a catch-all we will work with UTF-8. We cannot use memcmp() as |
---|
2516 | * that is unsafe with any string containing NUL (\xC0\x80 in Tcl's |
---|
2517 | * utf rep). We can use the more efficient TclpUtfNcmp2 if we are |
---|
2518 | * case-sensitive and no specific length was requested. |
---|
2519 | */ |
---|
2520 | |
---|
2521 | string1 = (char *) TclGetStringFromObj(objv[0], &length1); |
---|
2522 | string2 = (char *) TclGetStringFromObj(objv[1], &length2); |
---|
2523 | if ((reqlength < 0) && !nocase) { |
---|
2524 | strCmpFn = (strCmpFn_t) TclpUtfNcmp2; |
---|
2525 | } else { |
---|
2526 | length1 = Tcl_NumUtfChars(string1, length1); |
---|
2527 | length2 = Tcl_NumUtfChars(string2, length2); |
---|
2528 | strCmpFn = (strCmpFn_t) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); |
---|
2529 | } |
---|
2530 | } |
---|
2531 | |
---|
2532 | if ((reqlength < 0) && (length1 != length2)) { |
---|
2533 | match = 1; /* This will be reversed below. */ |
---|
2534 | } else { |
---|
2535 | length = (length1 < length2) ? length1 : length2; |
---|
2536 | if (reqlength > 0 && reqlength < length) { |
---|
2537 | length = reqlength; |
---|
2538 | } else if (reqlength < 0) { |
---|
2539 | /* |
---|
2540 | * The requested length is negative, so we ignore it by setting it |
---|
2541 | * to length + 1 so we correct the match var. |
---|
2542 | */ |
---|
2543 | |
---|
2544 | reqlength = length + 1; |
---|
2545 | } |
---|
2546 | |
---|
2547 | match = strCmpFn(string1, string2, (unsigned) length); |
---|
2548 | if ((match == 0) && (reqlength > length)) { |
---|
2549 | match = length1 - length2; |
---|
2550 | } |
---|
2551 | } |
---|
2552 | |
---|
2553 | Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1)); |
---|
2554 | return TCL_OK; |
---|
2555 | } |
---|
2556 | |
---|
2557 | /* |
---|
2558 | *---------------------------------------------------------------------- |
---|
2559 | * |
---|
2560 | * StringCmpCmd -- |
---|
2561 | * |
---|
2562 | * This procedure is invoked to process the "string compare" Tcl command. |
---|
2563 | * See the user documentation for details on what it does. Note that this |
---|
2564 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
2565 | * |
---|
2566 | * Results: |
---|
2567 | * A standard Tcl result. |
---|
2568 | * |
---|
2569 | * Side effects: |
---|
2570 | * See the user documentation. |
---|
2571 | * |
---|
2572 | *---------------------------------------------------------------------- |
---|
2573 | */ |
---|
2574 | |
---|
2575 | static int |
---|
2576 | StringCmpCmd( |
---|
2577 | ClientData dummy, /* Not used. */ |
---|
2578 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
2579 | int objc, /* Number of arguments. */ |
---|
2580 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
2581 | { |
---|
2582 | /* |
---|
2583 | * Remember to keep code here in some sync with the byte-compiled versions |
---|
2584 | * in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as |
---|
2585 | * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). |
---|
2586 | */ |
---|
2587 | |
---|
2588 | char *string1, *string2; |
---|
2589 | int length1, length2, i, match, length, nocase = 0, reqlength = -1; |
---|
2590 | typedef int (*strCmpFn_t)(const char *, const char *, unsigned int); |
---|
2591 | strCmpFn_t strCmpFn; |
---|
2592 | |
---|
2593 | if (objc < 3 || objc > 6) { |
---|
2594 | str_cmp_args: |
---|
2595 | Tcl_WrongNumArgs(interp, 1, objv, |
---|
2596 | "?-nocase? ?-length int? string1 string2"); |
---|
2597 | return TCL_ERROR; |
---|
2598 | } |
---|
2599 | |
---|
2600 | for (i = 1; i < objc-2; i++) { |
---|
2601 | string2 = TclGetStringFromObj(objv[i], &length2); |
---|
2602 | if ((length2 > 1) && !strncmp(string2, "-nocase", (size_t)length2)) { |
---|
2603 | nocase = 1; |
---|
2604 | } else if ((length2 > 1) |
---|
2605 | && !strncmp(string2, "-length", (size_t)length2)) { |
---|
2606 | if (i+1 >= objc-2) { |
---|
2607 | goto str_cmp_args; |
---|
2608 | } |
---|
2609 | ++i; |
---|
2610 | if (TclGetIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { |
---|
2611 | return TCL_ERROR; |
---|
2612 | } |
---|
2613 | } else { |
---|
2614 | Tcl_AppendResult(interp, "bad option \"", string2, |
---|
2615 | "\": must be -nocase or -length", NULL); |
---|
2616 | return TCL_ERROR; |
---|
2617 | } |
---|
2618 | } |
---|
2619 | |
---|
2620 | /* |
---|
2621 | * From now on, we only access the two objects at the end of the argument |
---|
2622 | * array. |
---|
2623 | */ |
---|
2624 | |
---|
2625 | objv += objc-2; |
---|
2626 | |
---|
2627 | if ((reqlength == 0) || (objv[0] == objv[1])) { |
---|
2628 | /* |
---|
2629 | * Always match at 0 chars of if it is the same obj. |
---|
2630 | */ |
---|
2631 | |
---|
2632 | Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); |
---|
2633 | return TCL_OK; |
---|
2634 | } |
---|
2635 | |
---|
2636 | if (!nocase && objv[0]->typePtr == &tclByteArrayType && |
---|
2637 | objv[1]->typePtr == &tclByteArrayType) { |
---|
2638 | /* |
---|
2639 | * Use binary versions of comparisons since that won't cause undue |
---|
2640 | * type conversions and it is much faster. Only do this if we're |
---|
2641 | * case-sensitive (which is all that really makes sense with byte |
---|
2642 | * arrays anyway, and we have no memcasecmp() for some reason... :^) |
---|
2643 | */ |
---|
2644 | |
---|
2645 | string1 = (char *) Tcl_GetByteArrayFromObj(objv[0], &length1); |
---|
2646 | string2 = (char *) Tcl_GetByteArrayFromObj(objv[1], &length2); |
---|
2647 | strCmpFn = (strCmpFn_t) memcmp; |
---|
2648 | } else if ((objv[0]->typePtr == &tclStringType) |
---|
2649 | && (objv[1]->typePtr == &tclStringType)) { |
---|
2650 | /* |
---|
2651 | * Do a unicode-specific comparison if both of the args are of String |
---|
2652 | * type. In benchmark testing this proved the most efficient check |
---|
2653 | * between the unicode and string comparison operations. |
---|
2654 | */ |
---|
2655 | |
---|
2656 | string1 = (char *) Tcl_GetUnicodeFromObj(objv[0], &length1); |
---|
2657 | string2 = (char *) Tcl_GetUnicodeFromObj(objv[1], &length2); |
---|
2658 | strCmpFn = (strCmpFn_t) |
---|
2659 | (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); |
---|
2660 | } else { |
---|
2661 | /* |
---|
2662 | * As a catch-all we will work with UTF-8. We cannot use memcmp() as |
---|
2663 | * that is unsafe with any string containing NUL (\xC0\x80 in Tcl's |
---|
2664 | * utf rep). We can use the more efficient TclpUtfNcmp2 if we are |
---|
2665 | * case-sensitive and no specific length was requested. |
---|
2666 | */ |
---|
2667 | |
---|
2668 | string1 = (char *) TclGetStringFromObj(objv[0], &length1); |
---|
2669 | string2 = (char *) TclGetStringFromObj(objv[1], &length2); |
---|
2670 | if ((reqlength < 0) && !nocase) { |
---|
2671 | strCmpFn = (strCmpFn_t) TclpUtfNcmp2; |
---|
2672 | } else { |
---|
2673 | length1 = Tcl_NumUtfChars(string1, length1); |
---|
2674 | length2 = Tcl_NumUtfChars(string2, length2); |
---|
2675 | strCmpFn = (strCmpFn_t) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); |
---|
2676 | } |
---|
2677 | } |
---|
2678 | |
---|
2679 | length = (length1 < length2) ? length1 : length2; |
---|
2680 | if (reqlength > 0 && reqlength < length) { |
---|
2681 | length = reqlength; |
---|
2682 | } else if (reqlength < 0) { |
---|
2683 | /* |
---|
2684 | * The requested length is negative, so we ignore it by setting it to |
---|
2685 | * length + 1 so we correct the match var. |
---|
2686 | */ |
---|
2687 | |
---|
2688 | reqlength = length + 1; |
---|
2689 | } |
---|
2690 | |
---|
2691 | match = strCmpFn(string1, string2, (unsigned) length); |
---|
2692 | if ((match == 0) && (reqlength > length)) { |
---|
2693 | match = length1 - length2; |
---|
2694 | } |
---|
2695 | |
---|
2696 | Tcl_SetObjResult(interp, |
---|
2697 | Tcl_NewIntObj((match > 0) ? 1 : (match < 0) ? -1 : 0)); |
---|
2698 | return TCL_OK; |
---|
2699 | } |
---|
2700 | |
---|
2701 | /* |
---|
2702 | *---------------------------------------------------------------------- |
---|
2703 | * |
---|
2704 | * StringBytesCmd -- |
---|
2705 | * |
---|
2706 | * This procedure is invoked to process the "string bytelength" Tcl |
---|
2707 | * command. See the user documentation for details on what it does. Note |
---|
2708 | * that this command only functions correctly on properly formed Tcl UTF |
---|
2709 | * strings. |
---|
2710 | * |
---|
2711 | * Results: |
---|
2712 | * A standard Tcl result. |
---|
2713 | * |
---|
2714 | * Side effects: |
---|
2715 | * See the user documentation. |
---|
2716 | * |
---|
2717 | *---------------------------------------------------------------------- |
---|
2718 | */ |
---|
2719 | |
---|
2720 | static int |
---|
2721 | StringBytesCmd( |
---|
2722 | ClientData dummy, /* Not used. */ |
---|
2723 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
2724 | int objc, /* Number of arguments. */ |
---|
2725 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
2726 | { |
---|
2727 | int length; |
---|
2728 | |
---|
2729 | if (objc != 2) { |
---|
2730 | Tcl_WrongNumArgs(interp, 1, objv, "string"); |
---|
2731 | return TCL_ERROR; |
---|
2732 | } |
---|
2733 | |
---|
2734 | (void) TclGetStringFromObj(objv[1], &length); |
---|
2735 | Tcl_SetObjResult(interp, Tcl_NewIntObj(length)); |
---|
2736 | return TCL_OK; |
---|
2737 | } |
---|
2738 | |
---|
2739 | /* |
---|
2740 | *---------------------------------------------------------------------- |
---|
2741 | * |
---|
2742 | * StringLenCmd -- |
---|
2743 | * |
---|
2744 | * This procedure is invoked to process the "string length" Tcl command. |
---|
2745 | * See the user documentation for details on what it does. Note that this |
---|
2746 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
2747 | * |
---|
2748 | * Results: |
---|
2749 | * A standard Tcl result. |
---|
2750 | * |
---|
2751 | * Side effects: |
---|
2752 | * See the user documentation. |
---|
2753 | * |
---|
2754 | *---------------------------------------------------------------------- |
---|
2755 | */ |
---|
2756 | |
---|
2757 | static int |
---|
2758 | StringLenCmd( |
---|
2759 | ClientData dummy, /* Not used. */ |
---|
2760 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
2761 | int objc, /* Number of arguments. */ |
---|
2762 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
2763 | { |
---|
2764 | int length; |
---|
2765 | |
---|
2766 | if (objc != 2) { |
---|
2767 | Tcl_WrongNumArgs(interp, 1, objv, "string"); |
---|
2768 | return TCL_ERROR; |
---|
2769 | } |
---|
2770 | |
---|
2771 | /* |
---|
2772 | * If we have a ByteArray object, avoid recomputing the string since the |
---|
2773 | * byte array contains one byte per character. Otherwise, use the Unicode |
---|
2774 | * string rep to calculate the length. |
---|
2775 | */ |
---|
2776 | |
---|
2777 | if (objv[1]->typePtr == &tclByteArrayType) { |
---|
2778 | (void) Tcl_GetByteArrayFromObj(objv[1], &length); |
---|
2779 | } else { |
---|
2780 | length = Tcl_GetCharLength(objv[1]); |
---|
2781 | } |
---|
2782 | Tcl_SetObjResult(interp, Tcl_NewIntObj(length)); |
---|
2783 | return TCL_OK; |
---|
2784 | } |
---|
2785 | |
---|
2786 | /* |
---|
2787 | *---------------------------------------------------------------------- |
---|
2788 | * |
---|
2789 | * StringLowerCmd -- |
---|
2790 | * |
---|
2791 | * This procedure is invoked to process the "string tolower" Tcl command. |
---|
2792 | * See the user documentation for details on what it does. Note that this |
---|
2793 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
2794 | * |
---|
2795 | * Results: |
---|
2796 | * A standard Tcl result. |
---|
2797 | * |
---|
2798 | * Side effects: |
---|
2799 | * See the user documentation. |
---|
2800 | * |
---|
2801 | *---------------------------------------------------------------------- |
---|
2802 | */ |
---|
2803 | |
---|
2804 | static int |
---|
2805 | StringLowerCmd( |
---|
2806 | ClientData dummy, /* Not used. */ |
---|
2807 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
2808 | int objc, /* Number of arguments. */ |
---|
2809 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
2810 | { |
---|
2811 | int length1, length2; |
---|
2812 | char *string1, *string2; |
---|
2813 | |
---|
2814 | if (objc < 2 || objc > 4) { |
---|
2815 | Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); |
---|
2816 | return TCL_ERROR; |
---|
2817 | } |
---|
2818 | |
---|
2819 | string1 = TclGetStringFromObj(objv[1], &length1); |
---|
2820 | |
---|
2821 | if (objc == 2) { |
---|
2822 | Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1); |
---|
2823 | |
---|
2824 | length1 = Tcl_UtfToLower(TclGetString(resultPtr)); |
---|
2825 | Tcl_SetObjLength(resultPtr, length1); |
---|
2826 | Tcl_SetObjResult(interp, resultPtr); |
---|
2827 | } else { |
---|
2828 | int first, last; |
---|
2829 | const char *start, *end; |
---|
2830 | Tcl_Obj *resultPtr; |
---|
2831 | |
---|
2832 | length1 = Tcl_NumUtfChars(string1, length1) - 1; |
---|
2833 | if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { |
---|
2834 | return TCL_ERROR; |
---|
2835 | } |
---|
2836 | if (first < 0) { |
---|
2837 | first = 0; |
---|
2838 | } |
---|
2839 | last = first; |
---|
2840 | |
---|
2841 | if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1, |
---|
2842 | &last) != TCL_OK)) { |
---|
2843 | return TCL_ERROR; |
---|
2844 | } |
---|
2845 | |
---|
2846 | if (last >= length1) { |
---|
2847 | last = length1; |
---|
2848 | } |
---|
2849 | if (last < first) { |
---|
2850 | Tcl_SetObjResult(interp, objv[1]); |
---|
2851 | return TCL_OK; |
---|
2852 | } |
---|
2853 | |
---|
2854 | string1 = TclGetStringFromObj(objv[1], &length1); |
---|
2855 | start = Tcl_UtfAtIndex(string1, first); |
---|
2856 | end = Tcl_UtfAtIndex(start, last - first + 1); |
---|
2857 | resultPtr = Tcl_NewStringObj(string1, end - string1); |
---|
2858 | string2 = TclGetString(resultPtr) + (start - string1); |
---|
2859 | |
---|
2860 | length2 = Tcl_UtfToLower(string2); |
---|
2861 | Tcl_SetObjLength(resultPtr, length2 + (start - string1)); |
---|
2862 | |
---|
2863 | Tcl_AppendToObj(resultPtr, end, -1); |
---|
2864 | Tcl_SetObjResult(interp, resultPtr); |
---|
2865 | } |
---|
2866 | |
---|
2867 | return TCL_OK; |
---|
2868 | } |
---|
2869 | |
---|
2870 | /* |
---|
2871 | *---------------------------------------------------------------------- |
---|
2872 | * |
---|
2873 | * StringUpperCmd -- |
---|
2874 | * |
---|
2875 | * This procedure is invoked to process the "string toupper" Tcl command. |
---|
2876 | * See the user documentation for details on what it does. Note that this |
---|
2877 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
2878 | * |
---|
2879 | * Results: |
---|
2880 | * A standard Tcl result. |
---|
2881 | * |
---|
2882 | * Side effects: |
---|
2883 | * See the user documentation. |
---|
2884 | * |
---|
2885 | *---------------------------------------------------------------------- |
---|
2886 | */ |
---|
2887 | |
---|
2888 | static int |
---|
2889 | StringUpperCmd( |
---|
2890 | ClientData dummy, /* Not used. */ |
---|
2891 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
2892 | int objc, /* Number of arguments. */ |
---|
2893 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
2894 | { |
---|
2895 | int length1, length2; |
---|
2896 | char *string1, *string2; |
---|
2897 | |
---|
2898 | if (objc < 2 || objc > 4) { |
---|
2899 | Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); |
---|
2900 | return TCL_ERROR; |
---|
2901 | } |
---|
2902 | |
---|
2903 | string1 = TclGetStringFromObj(objv[1], &length1); |
---|
2904 | |
---|
2905 | if (objc == 2) { |
---|
2906 | Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1); |
---|
2907 | |
---|
2908 | length1 = Tcl_UtfToUpper(TclGetString(resultPtr)); |
---|
2909 | Tcl_SetObjLength(resultPtr, length1); |
---|
2910 | Tcl_SetObjResult(interp, resultPtr); |
---|
2911 | } else { |
---|
2912 | int first, last; |
---|
2913 | const char *start, *end; |
---|
2914 | Tcl_Obj *resultPtr; |
---|
2915 | |
---|
2916 | length1 = Tcl_NumUtfChars(string1, length1) - 1; |
---|
2917 | if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { |
---|
2918 | return TCL_ERROR; |
---|
2919 | } |
---|
2920 | if (first < 0) { |
---|
2921 | first = 0; |
---|
2922 | } |
---|
2923 | last = first; |
---|
2924 | |
---|
2925 | if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1, |
---|
2926 | &last) != TCL_OK)) { |
---|
2927 | return TCL_ERROR; |
---|
2928 | } |
---|
2929 | |
---|
2930 | if (last >= length1) { |
---|
2931 | last = length1; |
---|
2932 | } |
---|
2933 | if (last < first) { |
---|
2934 | Tcl_SetObjResult(interp, objv[1]); |
---|
2935 | return TCL_OK; |
---|
2936 | } |
---|
2937 | |
---|
2938 | string1 = TclGetStringFromObj(objv[1], &length1); |
---|
2939 | start = Tcl_UtfAtIndex(string1, first); |
---|
2940 | end = Tcl_UtfAtIndex(start, last - first + 1); |
---|
2941 | resultPtr = Tcl_NewStringObj(string1, end - string1); |
---|
2942 | string2 = TclGetString(resultPtr) + (start - string1); |
---|
2943 | |
---|
2944 | length2 = Tcl_UtfToUpper(string2); |
---|
2945 | Tcl_SetObjLength(resultPtr, length2 + (start - string1)); |
---|
2946 | |
---|
2947 | Tcl_AppendToObj(resultPtr, end, -1); |
---|
2948 | Tcl_SetObjResult(interp, resultPtr); |
---|
2949 | } |
---|
2950 | |
---|
2951 | return TCL_OK; |
---|
2952 | } |
---|
2953 | |
---|
2954 | /* |
---|
2955 | *---------------------------------------------------------------------- |
---|
2956 | * |
---|
2957 | * StringTitleCmd -- |
---|
2958 | * |
---|
2959 | * This procedure is invoked to process the "string totitle" Tcl command. |
---|
2960 | * See the user documentation for details on what it does. Note that this |
---|
2961 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
2962 | * |
---|
2963 | * Results: |
---|
2964 | * A standard Tcl result. |
---|
2965 | * |
---|
2966 | * Side effects: |
---|
2967 | * See the user documentation. |
---|
2968 | * |
---|
2969 | *---------------------------------------------------------------------- |
---|
2970 | */ |
---|
2971 | |
---|
2972 | static int |
---|
2973 | StringTitleCmd( |
---|
2974 | ClientData dummy, /* Not used. */ |
---|
2975 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
2976 | int objc, /* Number of arguments. */ |
---|
2977 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
2978 | { |
---|
2979 | int length1, length2; |
---|
2980 | char *string1, *string2; |
---|
2981 | |
---|
2982 | if (objc < 2 || objc > 4) { |
---|
2983 | Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?"); |
---|
2984 | return TCL_ERROR; |
---|
2985 | } |
---|
2986 | |
---|
2987 | string1 = TclGetStringFromObj(objv[1], &length1); |
---|
2988 | |
---|
2989 | if (objc == 2) { |
---|
2990 | Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1); |
---|
2991 | |
---|
2992 | length1 = Tcl_UtfToTitle(TclGetString(resultPtr)); |
---|
2993 | Tcl_SetObjLength(resultPtr, length1); |
---|
2994 | Tcl_SetObjResult(interp, resultPtr); |
---|
2995 | } else { |
---|
2996 | int first, last; |
---|
2997 | const char *start, *end; |
---|
2998 | Tcl_Obj *resultPtr; |
---|
2999 | |
---|
3000 | length1 = Tcl_NumUtfChars(string1, length1) - 1; |
---|
3001 | if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { |
---|
3002 | return TCL_ERROR; |
---|
3003 | } |
---|
3004 | if (first < 0) { |
---|
3005 | first = 0; |
---|
3006 | } |
---|
3007 | last = first; |
---|
3008 | |
---|
3009 | if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1, |
---|
3010 | &last) != TCL_OK)) { |
---|
3011 | return TCL_ERROR; |
---|
3012 | } |
---|
3013 | |
---|
3014 | if (last >= length1) { |
---|
3015 | last = length1; |
---|
3016 | } |
---|
3017 | if (last < first) { |
---|
3018 | Tcl_SetObjResult(interp, objv[1]); |
---|
3019 | return TCL_OK; |
---|
3020 | } |
---|
3021 | |
---|
3022 | string1 = TclGetStringFromObj(objv[1], &length1); |
---|
3023 | start = Tcl_UtfAtIndex(string1, first); |
---|
3024 | end = Tcl_UtfAtIndex(start, last - first + 1); |
---|
3025 | resultPtr = Tcl_NewStringObj(string1, end - string1); |
---|
3026 | string2 = TclGetString(resultPtr) + (start - string1); |
---|
3027 | |
---|
3028 | length2 = Tcl_UtfToTitle(string2); |
---|
3029 | Tcl_SetObjLength(resultPtr, length2 + (start - string1)); |
---|
3030 | |
---|
3031 | Tcl_AppendToObj(resultPtr, end, -1); |
---|
3032 | Tcl_SetObjResult(interp, resultPtr); |
---|
3033 | } |
---|
3034 | |
---|
3035 | return TCL_OK; |
---|
3036 | } |
---|
3037 | |
---|
3038 | /* |
---|
3039 | *---------------------------------------------------------------------- |
---|
3040 | * |
---|
3041 | * StringTrimCmd -- |
---|
3042 | * |
---|
3043 | * This procedure is invoked to process the "string trim" Tcl command. |
---|
3044 | * See the user documentation for details on what it does. Note that this |
---|
3045 | * command only functions correctly on properly formed Tcl UTF strings. |
---|
3046 | * |
---|
3047 | * Results: |
---|
3048 | * A standard Tcl result. |
---|
3049 | * |
---|
3050 | * Side effects: |
---|
3051 | * See the user documentation. |
---|
3052 | * |
---|
3053 | *---------------------------------------------------------------------- |
---|
3054 | */ |
---|
3055 | |
---|
3056 | static int |
---|
3057 | StringTrimCmd( |
---|
3058 | ClientData dummy, /* Not used. */ |
---|
3059 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
3060 | int objc, /* Number of arguments. */ |
---|
3061 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
3062 | { |
---|
3063 | Tcl_UniChar ch, trim; |
---|
3064 | register const char *p, *end; |
---|
3065 | const char *check, *checkEnd, *string1, *string2; |
---|
3066 | int offset, length1, length2; |
---|
3067 | |
---|
3068 | if (objc == 3) { |
---|
3069 | string2 = TclGetStringFromObj(objv[2], &length2); |
---|
3070 | } else if (objc == 2) { |
---|
3071 | string2 = " \t\n\r"; |
---|
3072 | length2 = strlen(string2); |
---|
3073 | } else { |
---|
3074 | Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); |
---|
3075 | return TCL_ERROR; |
---|
3076 | } |
---|
3077 | string1 = TclGetStringFromObj(objv[1], &length1); |
---|
3078 | checkEnd = string2 + length2; |
---|
3079 | |
---|
3080 | /* |
---|
3081 | * The outer loop iterates over the string. The inner loop iterates over |
---|
3082 | * the trim characters. The loops terminate as soon as a non-trim |
---|
3083 | * character is discovered and string1 is left pointing at the first |
---|
3084 | * non-trim character. |
---|
3085 | */ |
---|
3086 | |
---|
3087 | end = string1 + length1; |
---|
3088 | for (p = string1; p < end; p += offset) { |
---|
3089 | offset = TclUtfToUniChar(p, &ch); |
---|
3090 | |
---|
3091 | for (check = string2; ; ) { |
---|
3092 | if (check >= checkEnd) { |
---|
3093 | p = end; |
---|
3094 | break; |
---|
3095 | } |
---|
3096 | check += TclUtfToUniChar(check, &trim); |
---|
3097 | if (ch == trim) { |
---|
3098 | length1 -= offset; |
---|
3099 | string1 += offset; |
---|
3100 | break; |
---|
3101 | } |
---|
3102 | } |
---|
3103 | } |
---|
3104 | |
---|
3105 | /* |
---|
3106 | * The outer loop iterates over the string. The inner loop iterates over |
---|
3107 | * the trim characters. The loops terminate as soon as a non-trim |
---|
3108 | * character is discovered and length1 marks the last non-trim character. |
---|
3109 | */ |
---|
3110 | |
---|
3111 | end = string1; |
---|
3112 | for (p = string1 + length1; p > end; ) { |
---|
3113 | p = Tcl_UtfPrev(p, string1); |
---|
3114 | offset = TclUtfToUniChar(p, &ch); |
---|
3115 | check = string2; |
---|
3116 | while (1) { |
---|
3117 | if (check >= checkEnd) { |
---|
3118 | p = end; |
---|
3119 | break; |
---|
3120 | } |
---|
3121 | check += TclUtfToUniChar(check, &trim); |
---|
3122 | if (ch == trim) { |
---|
3123 | length1 -= offset; |
---|
3124 | break; |
---|
3125 | } |
---|
3126 | } |
---|
3127 | } |
---|
3128 | |
---|
3129 | Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1)); |
---|
3130 | return TCL_OK; |
---|
3131 | } |
---|
3132 | |
---|
3133 | /* |
---|
3134 | *---------------------------------------------------------------------- |
---|
3135 | * |
---|
3136 | * StringTrimLCmd -- |
---|
3137 | * |
---|
3138 | * This procedure is invoked to process the "string trimleft" Tcl |
---|
3139 | * command. See the user documentation for details on what it does. Note |
---|
3140 | * that this command only functions correctly on properly formed Tcl UTF |
---|
3141 | * strings. |
---|
3142 | * |
---|
3143 | * Results: |
---|
3144 | * A standard Tcl result. |
---|
3145 | * |
---|
3146 | * Side effects: |
---|
3147 | * See the user documentation. |
---|
3148 | * |
---|
3149 | *---------------------------------------------------------------------- |
---|
3150 | */ |
---|
3151 | |
---|
3152 | static int |
---|
3153 | StringTrimLCmd( |
---|
3154 | ClientData dummy, /* Not used. */ |
---|
3155 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
3156 | int objc, /* Number of arguments. */ |
---|
3157 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
3158 | { |
---|
3159 | Tcl_UniChar ch, trim; |
---|
3160 | register const char *p, *end; |
---|
3161 | const char *check, *checkEnd, *string1, *string2; |
---|
3162 | int offset, length1, length2; |
---|
3163 | |
---|
3164 | if (objc == 3) { |
---|
3165 | string2 = TclGetStringFromObj(objv[2], &length2); |
---|
3166 | } else if (objc == 2) { |
---|
3167 | string2 = " \t\n\r"; |
---|
3168 | length2 = strlen(string2); |
---|
3169 | } else { |
---|
3170 | Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); |
---|
3171 | return TCL_ERROR; |
---|
3172 | } |
---|
3173 | string1 = TclGetStringFromObj(objv[1], &length1); |
---|
3174 | checkEnd = string2 + length2; |
---|
3175 | |
---|
3176 | /* |
---|
3177 | * The outer loop iterates over the string. The inner loop iterates over |
---|
3178 | * the trim characters. The loops terminate as soon as a non-trim |
---|
3179 | * character is discovered and string1 is left pointing at the first |
---|
3180 | * non-trim character. |
---|
3181 | */ |
---|
3182 | |
---|
3183 | end = string1 + length1; |
---|
3184 | for (p = string1; p < end; p += offset) { |
---|
3185 | offset = TclUtfToUniChar(p, &ch); |
---|
3186 | |
---|
3187 | for (check = string2; ; ) { |
---|
3188 | if (check >= checkEnd) { |
---|
3189 | p = end; |
---|
3190 | break; |
---|
3191 | } |
---|
3192 | check += TclUtfToUniChar(check, &trim); |
---|
3193 | if (ch == trim) { |
---|
3194 | length1 -= offset; |
---|
3195 | string1 += offset; |
---|
3196 | break; |
---|
3197 | } |
---|
3198 | } |
---|
3199 | } |
---|
3200 | |
---|
3201 | Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1)); |
---|
3202 | return TCL_OK; |
---|
3203 | } |
---|
3204 | |
---|
3205 | /* |
---|
3206 | *---------------------------------------------------------------------- |
---|
3207 | * |
---|
3208 | * StringTrimRCmd -- |
---|
3209 | * |
---|
3210 | * This procedure is invoked to process the "string trimright" Tcl |
---|
3211 | * command. See the user documentation for details on what it does. Note |
---|
3212 | * that this command only functions correctly on properly formed Tcl UTF |
---|
3213 | * strings. |
---|
3214 | * |
---|
3215 | * Results: |
---|
3216 | * A standard Tcl result. |
---|
3217 | * |
---|
3218 | * Side effects: |
---|
3219 | * See the user documentation. |
---|
3220 | * |
---|
3221 | *---------------------------------------------------------------------- |
---|
3222 | */ |
---|
3223 | |
---|
3224 | static int |
---|
3225 | StringTrimRCmd( |
---|
3226 | ClientData dummy, /* Not used. */ |
---|
3227 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
3228 | int objc, /* Number of arguments. */ |
---|
3229 | Tcl_Obj *const objv[]) /* Argument objects. */ |
---|
3230 | { |
---|
3231 | Tcl_UniChar ch, trim; |
---|
3232 | register const char *p, *end; |
---|
3233 | const char *check, *checkEnd, *string1, *string2; |
---|
3234 | int offset, length1, length2; |
---|
3235 | |
---|
3236 | if (objc == 3) { |
---|
3237 | string2 = TclGetStringFromObj(objv[2], &length2); |
---|
3238 | } else if (objc == 2) { |
---|
3239 | string2 = " \t\n\r"; |
---|
3240 | length2 = strlen(string2); |
---|
3241 | } else { |
---|
3242 | Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); |
---|
3243 | return TCL_ERROR; |
---|
3244 | } |
---|
3245 | string1 = TclGetStringFromObj(objv[1], &length1); |
---|
3246 | checkEnd = string2 + length2; |
---|
3247 | |
---|
3248 | /* |
---|
3249 | * The outer loop iterates over the string. The inner loop iterates over |
---|
3250 | * the trim characters. The loops terminate as soon as a non-trim |
---|
3251 | * character is discovered and length1 marks the last non-trim character. |
---|
3252 | */ |
---|
3253 | |
---|
3254 | end = string1; |
---|
3255 | for (p = string1 + length1; p > end; ) { |
---|
3256 | p = Tcl_UtfPrev(p, string1); |
---|
3257 | offset = TclUtfToUniChar(p, &ch); |
---|
3258 | check = string2; |
---|
3259 | while (1) { |
---|
3260 | if (check >= checkEnd) { |
---|
3261 | p = end; |
---|
3262 | break; |
---|
3263 | } |
---|
3264 | check += TclUtfToUniChar(check, &trim); |
---|
3265 | if (ch == trim) { |
---|
3266 | length1 -= offset; |
---|
3267 | break; |
---|
3268 | } |
---|
3269 | } |
---|
3270 | } |
---|
3271 | |
---|
3272 | Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1)); |
---|
3273 | return TCL_OK; |
---|
3274 | } |
---|
3275 | |
---|
3276 | /* |
---|
3277 | *---------------------------------------------------------------------- |
---|
3278 | * |
---|
3279 | * TclInitStringCmd -- |
---|
3280 | * |
---|
3281 | * This procedure creates the "string" Tcl command. See the user |
---|
3282 | * documentation for details on what it does. Note that this command only |
---|
3283 | * functions correctly on properly formed Tcl UTF strings. |
---|
3284 | * |
---|
3285 | * Also note that the primary methods here (equal, compare, match, ...) |
---|
3286 | * have bytecode equivalents. You will find the code for those in |
---|
3287 | * tclExecute.c. The code here will only be used in the non-bc case (like |
---|
3288 | * in an 'eval'). |
---|
3289 | * |
---|
3290 | * Results: |
---|
3291 | * A standard Tcl result. |
---|
3292 | * |
---|
3293 | * Side effects: |
---|
3294 | * See the user documentation. |
---|
3295 | * |
---|
3296 | *---------------------------------------------------------------------- |
---|
3297 | */ |
---|
3298 | |
---|
3299 | Tcl_Command |
---|
3300 | TclInitStringCmd( |
---|
3301 | Tcl_Interp *interp) /* Current interpreter. */ |
---|
3302 | { |
---|
3303 | static const EnsembleImplMap stringImplMap[] = { |
---|
3304 | {"bytelength", StringBytesCmd, NULL}, |
---|
3305 | {"compare", StringCmpCmd, TclCompileStringCmpCmd}, |
---|
3306 | {"equal", StringEqualCmd, TclCompileStringEqualCmd}, |
---|
3307 | {"first", StringFirstCmd, NULL}, |
---|
3308 | {"index", StringIndexCmd, TclCompileStringIndexCmd}, |
---|
3309 | {"is", StringIsCmd, NULL}, |
---|
3310 | {"last", StringLastCmd, NULL}, |
---|
3311 | {"length", StringLenCmd, TclCompileStringLenCmd}, |
---|
3312 | {"map", StringMapCmd, NULL}, |
---|
3313 | {"match", StringMatchCmd, TclCompileStringMatchCmd}, |
---|
3314 | {"range", StringRangeCmd, NULL}, |
---|
3315 | {"repeat", StringReptCmd, NULL}, |
---|
3316 | {"replace", StringRplcCmd, NULL}, |
---|
3317 | {"reverse", StringRevCmd, NULL}, |
---|
3318 | {"tolower", StringLowerCmd, NULL}, |
---|
3319 | {"toupper", StringUpperCmd, NULL}, |
---|
3320 | {"totitle", StringTitleCmd, NULL}, |
---|
3321 | {"trim", StringTrimCmd, NULL}, |
---|
3322 | {"trimleft", StringTrimLCmd, NULL}, |
---|
3323 | {"trimright", StringTrimRCmd, NULL}, |
---|
3324 | {"wordend", StringEndCmd, NULL}, |
---|
3325 | {"wordstart", StringStartCmd, NULL}, |
---|
3326 | {NULL} |
---|
3327 | }; |
---|
3328 | |
---|
3329 | return TclMakeEnsemble(interp, "string", stringImplMap); |
---|
3330 | } |
---|
3331 | |
---|
3332 | /* |
---|
3333 | *---------------------------------------------------------------------- |
---|
3334 | * |
---|
3335 | * Tcl_SubstObjCmd -- |
---|
3336 | * |
---|
3337 | * This procedure is invoked to process the "subst" Tcl command. See the |
---|
3338 | * user documentation for details on what it does. This command relies on |
---|
3339 | * Tcl_SubstObj() for its implementation. |
---|
3340 | * |
---|
3341 | * Results: |
---|
3342 | * A standard Tcl result. |
---|
3343 | * |
---|
3344 | * Side effects: |
---|
3345 | * See the user documentation. |
---|
3346 | * |
---|
3347 | *---------------------------------------------------------------------- |
---|
3348 | */ |
---|
3349 | |
---|
3350 | int |
---|
3351 | Tcl_SubstObjCmd( |
---|
3352 | ClientData dummy, /* Not used. */ |
---|
3353 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
3354 | int objc, /* Number of arguments. */ |
---|
3355 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
3356 | { |
---|
3357 | static CONST char *substOptions[] = { |
---|
3358 | "-nobackslashes", "-nocommands", "-novariables", NULL |
---|
3359 | }; |
---|
3360 | enum substOptions { |
---|
3361 | SUBST_NOBACKSLASHES, SUBST_NOCOMMANDS, SUBST_NOVARS |
---|
3362 | }; |
---|
3363 | Tcl_Obj *resultPtr; |
---|
3364 | int flags, i; |
---|
3365 | |
---|
3366 | /* |
---|
3367 | * Parse command-line options. |
---|
3368 | */ |
---|
3369 | |
---|
3370 | flags = TCL_SUBST_ALL; |
---|
3371 | for (i = 1; i < (objc-1); i++) { |
---|
3372 | int optionIndex; |
---|
3373 | |
---|
3374 | if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, "switch", 0, |
---|
3375 | &optionIndex) != TCL_OK) { |
---|
3376 | return TCL_ERROR; |
---|
3377 | } |
---|
3378 | switch (optionIndex) { |
---|
3379 | case SUBST_NOBACKSLASHES: |
---|
3380 | flags &= ~TCL_SUBST_BACKSLASHES; |
---|
3381 | break; |
---|
3382 | case SUBST_NOCOMMANDS: |
---|
3383 | flags &= ~TCL_SUBST_COMMANDS; |
---|
3384 | break; |
---|
3385 | case SUBST_NOVARS: |
---|
3386 | flags &= ~TCL_SUBST_VARIABLES; |
---|
3387 | break; |
---|
3388 | default: |
---|
3389 | Tcl_Panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); |
---|
3390 | } |
---|
3391 | } |
---|
3392 | if (i != objc-1) { |
---|
3393 | Tcl_WrongNumArgs(interp, 1, objv, |
---|
3394 | "?-nobackslashes? ?-nocommands? ?-novariables? string"); |
---|
3395 | return TCL_ERROR; |
---|
3396 | } |
---|
3397 | |
---|
3398 | /* |
---|
3399 | * Perform the substitution. |
---|
3400 | */ |
---|
3401 | |
---|
3402 | resultPtr = Tcl_SubstObj(interp, objv[i], flags); |
---|
3403 | |
---|
3404 | if (resultPtr == NULL) { |
---|
3405 | return TCL_ERROR; |
---|
3406 | } |
---|
3407 | Tcl_SetObjResult(interp, resultPtr); |
---|
3408 | return TCL_OK; |
---|
3409 | } |
---|
3410 | |
---|
3411 | /* |
---|
3412 | *---------------------------------------------------------------------- |
---|
3413 | * |
---|
3414 | * Tcl_SwitchObjCmd -- |
---|
3415 | * |
---|
3416 | * This object-based procedure is invoked to process the "switch" Tcl |
---|
3417 | * command. See the user documentation for details on what it does. |
---|
3418 | * |
---|
3419 | * Results: |
---|
3420 | * A standard Tcl object result. |
---|
3421 | * |
---|
3422 | * Side effects: |
---|
3423 | * See the user documentation. |
---|
3424 | * |
---|
3425 | *---------------------------------------------------------------------- |
---|
3426 | */ |
---|
3427 | |
---|
3428 | int |
---|
3429 | Tcl_SwitchObjCmd( |
---|
3430 | ClientData dummy, /* Not used. */ |
---|
3431 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
3432 | int objc, /* Number of arguments. */ |
---|
3433 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
3434 | { |
---|
3435 | int i,j, index, mode, foundmode, result, splitObjs, numMatchesSaved; |
---|
3436 | int noCase, patternLength; |
---|
3437 | char *pattern; |
---|
3438 | Tcl_Obj *stringObj, *indexVarObj, *matchVarObj; |
---|
3439 | Tcl_Obj *CONST *savedObjv = objv; |
---|
3440 | Tcl_RegExp regExpr = NULL; |
---|
3441 | Interp *iPtr = (Interp *) interp; |
---|
3442 | int pc = 0; |
---|
3443 | int bidx = 0; /* Index of body argument. */ |
---|
3444 | Tcl_Obj *blist = NULL; /* List obj which is the body */ |
---|
3445 | CmdFrame *ctxPtr; /* Copy of the topmost cmdframe, to allow us |
---|
3446 | * to mess with the line information */ |
---|
3447 | |
---|
3448 | /* |
---|
3449 | * If you add options that make -e and -g not unique prefixes of -exact or |
---|
3450 | * -glob, you *must* fix TclCompileSwitchCmd's option parser as well. |
---|
3451 | */ |
---|
3452 | |
---|
3453 | static CONST char *options[] = { |
---|
3454 | "-exact", "-glob", "-indexvar", "-matchvar", "-nocase", "-regexp", |
---|
3455 | "--", NULL |
---|
3456 | }; |
---|
3457 | enum options { |
---|
3458 | OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP, |
---|
3459 | OPT_LAST |
---|
3460 | }; |
---|
3461 | typedef int (*strCmpFn_t)(const char *, const char *); |
---|
3462 | strCmpFn_t strCmpFn = strcmp; |
---|
3463 | |
---|
3464 | mode = OPT_EXACT; |
---|
3465 | foundmode = 0; |
---|
3466 | indexVarObj = NULL; |
---|
3467 | matchVarObj = NULL; |
---|
3468 | numMatchesSaved = 0; |
---|
3469 | noCase = 0; |
---|
3470 | for (i = 1; i < objc-2; i++) { |
---|
3471 | if (TclGetString(objv[i])[0] != '-') { |
---|
3472 | break; |
---|
3473 | } |
---|
3474 | if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, |
---|
3475 | &index) != TCL_OK) { |
---|
3476 | return TCL_ERROR; |
---|
3477 | } |
---|
3478 | switch ((enum options) index) { |
---|
3479 | /* |
---|
3480 | * General options. |
---|
3481 | */ |
---|
3482 | |
---|
3483 | case OPT_LAST: |
---|
3484 | i++; |
---|
3485 | goto finishedOptions; |
---|
3486 | case OPT_NOCASE: |
---|
3487 | strCmpFn = strcasecmp; |
---|
3488 | noCase = 1; |
---|
3489 | break; |
---|
3490 | |
---|
3491 | /* |
---|
3492 | * Handle the different switch mode options. |
---|
3493 | */ |
---|
3494 | |
---|
3495 | default: |
---|
3496 | if (foundmode) { |
---|
3497 | /* |
---|
3498 | * Mode already set via -exact, -glob, or -regexp. |
---|
3499 | */ |
---|
3500 | |
---|
3501 | Tcl_AppendResult(interp, "bad option \"", |
---|
3502 | TclGetString(objv[i]), "\": ", options[mode], |
---|
3503 | " option already found", NULL); |
---|
3504 | return TCL_ERROR; |
---|
3505 | } else { |
---|
3506 | foundmode = 1; |
---|
3507 | mode = index; |
---|
3508 | break; |
---|
3509 | } |
---|
3510 | |
---|
3511 | /* |
---|
3512 | * Check for TIP#75 options specifying the variables to write |
---|
3513 | * regexp information into. |
---|
3514 | */ |
---|
3515 | |
---|
3516 | case OPT_INDEXV: |
---|
3517 | i++; |
---|
3518 | if (i >= objc-2) { |
---|
3519 | Tcl_AppendResult(interp, "missing variable name argument to ", |
---|
3520 | "-indexvar", " option", NULL); |
---|
3521 | return TCL_ERROR; |
---|
3522 | } |
---|
3523 | indexVarObj = objv[i]; |
---|
3524 | numMatchesSaved = -1; |
---|
3525 | break; |
---|
3526 | case OPT_MATCHV: |
---|
3527 | i++; |
---|
3528 | if (i >= objc-2) { |
---|
3529 | Tcl_AppendResult(interp, "missing variable name argument to ", |
---|
3530 | "-matchvar", " option", NULL); |
---|
3531 | return TCL_ERROR; |
---|
3532 | } |
---|
3533 | matchVarObj = objv[i]; |
---|
3534 | numMatchesSaved = -1; |
---|
3535 | break; |
---|
3536 | } |
---|
3537 | } |
---|
3538 | |
---|
3539 | finishedOptions: |
---|
3540 | if (objc - i < 2) { |
---|
3541 | Tcl_WrongNumArgs(interp, 1, objv, |
---|
3542 | "?switches? string pattern body ... ?default body?"); |
---|
3543 | return TCL_ERROR; |
---|
3544 | } |
---|
3545 | if (indexVarObj != NULL && mode != OPT_REGEXP) { |
---|
3546 | Tcl_AppendResult(interp, |
---|
3547 | "-indexvar option requires -regexp option", NULL); |
---|
3548 | return TCL_ERROR; |
---|
3549 | } |
---|
3550 | if (matchVarObj != NULL && mode != OPT_REGEXP) { |
---|
3551 | Tcl_AppendResult(interp, |
---|
3552 | "-matchvar option requires -regexp option", NULL); |
---|
3553 | return TCL_ERROR; |
---|
3554 | } |
---|
3555 | |
---|
3556 | stringObj = objv[i]; |
---|
3557 | objc -= i + 1; |
---|
3558 | objv += i + 1; |
---|
3559 | bidx = i + 1; /* First after the match string. */ |
---|
3560 | |
---|
3561 | /* |
---|
3562 | * If all of the pattern/command pairs are lumped into a single argument, |
---|
3563 | * split them out again. |
---|
3564 | * |
---|
3565 | * TIP #280: Determine the lines the words in the list start at, based on |
---|
3566 | * the same data for the list word itself. The cmdFramePtr line |
---|
3567 | * information is manipulated directly. |
---|
3568 | */ |
---|
3569 | |
---|
3570 | splitObjs = 0; |
---|
3571 | if (objc == 1) { |
---|
3572 | Tcl_Obj **listv; |
---|
3573 | blist = objv[0]; |
---|
3574 | |
---|
3575 | if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK){ |
---|
3576 | return TCL_ERROR; |
---|
3577 | } |
---|
3578 | |
---|
3579 | /* |
---|
3580 | * Ensure that the list is non-empty. |
---|
3581 | */ |
---|
3582 | |
---|
3583 | if (objc < 1) { |
---|
3584 | Tcl_WrongNumArgs(interp, 1, savedObjv, |
---|
3585 | "?switches? string {pattern body ... ?default body?}"); |
---|
3586 | return TCL_ERROR; |
---|
3587 | } |
---|
3588 | objv = listv; |
---|
3589 | splitObjs = 1; |
---|
3590 | } |
---|
3591 | |
---|
3592 | /* |
---|
3593 | * Complain if there is an odd number of words in the list of patterns and |
---|
3594 | * bodies. |
---|
3595 | */ |
---|
3596 | |
---|
3597 | if (objc % 2) { |
---|
3598 | Tcl_ResetResult(interp); |
---|
3599 | Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); |
---|
3600 | |
---|
3601 | /* |
---|
3602 | * Check if this can be due to a badly placed comment in the switch |
---|
3603 | * block. |
---|
3604 | * |
---|
3605 | * The following is an heuristic to detect the infamous "comment in |
---|
3606 | * switch" error: just check if a pattern begins with '#'. |
---|
3607 | */ |
---|
3608 | |
---|
3609 | if (splitObjs) { |
---|
3610 | for (i=0 ; i<objc ; i+=2) { |
---|
3611 | if (TclGetString(objv[i])[0] == '#') { |
---|
3612 | Tcl_AppendResult(interp, ", this may be due to a " |
---|
3613 | "comment incorrectly placed outside of a " |
---|
3614 | "switch body - see the \"switch\" " |
---|
3615 | "documentation", NULL); |
---|
3616 | break; |
---|
3617 | } |
---|
3618 | } |
---|
3619 | } |
---|
3620 | |
---|
3621 | return TCL_ERROR; |
---|
3622 | } |
---|
3623 | |
---|
3624 | /* |
---|
3625 | * Complain if the last body is a continuation. Note that this check |
---|
3626 | * assumes that the list is non-empty! |
---|
3627 | */ |
---|
3628 | |
---|
3629 | if (strcmp(TclGetString(objv[objc-1]), "-") == 0) { |
---|
3630 | Tcl_ResetResult(interp); |
---|
3631 | Tcl_AppendResult(interp, "no body specified for pattern \"", |
---|
3632 | TclGetString(objv[objc-2]), "\"", NULL); |
---|
3633 | return TCL_ERROR; |
---|
3634 | } |
---|
3635 | |
---|
3636 | for (i = 0; i < objc; i += 2) { |
---|
3637 | /* |
---|
3638 | * See if the pattern matches the string. |
---|
3639 | */ |
---|
3640 | |
---|
3641 | pattern = TclGetStringFromObj(objv[i], &patternLength); |
---|
3642 | |
---|
3643 | if ((i == objc - 2) && (*pattern == 'd') |
---|
3644 | && (strcmp(pattern, "default") == 0)) { |
---|
3645 | Tcl_Obj *emptyObj = NULL; |
---|
3646 | |
---|
3647 | /* |
---|
3648 | * If either indexVarObj or matchVarObj are non-NULL, we're in |
---|
3649 | * REGEXP mode but have reached the default clause anyway. TIP#75 |
---|
3650 | * specifies that we set the variables to empty lists (== empty |
---|
3651 | * objects) in that case. |
---|
3652 | */ |
---|
3653 | |
---|
3654 | if (indexVarObj != NULL) { |
---|
3655 | TclNewObj(emptyObj); |
---|
3656 | if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, emptyObj, |
---|
3657 | TCL_LEAVE_ERR_MSG) == NULL) { |
---|
3658 | return TCL_ERROR; |
---|
3659 | } |
---|
3660 | } |
---|
3661 | if (matchVarObj != NULL) { |
---|
3662 | if (emptyObj == NULL) { |
---|
3663 | TclNewObj(emptyObj); |
---|
3664 | } |
---|
3665 | if (Tcl_ObjSetVar2(interp, matchVarObj, NULL, emptyObj, |
---|
3666 | TCL_LEAVE_ERR_MSG) == NULL) { |
---|
3667 | return TCL_ERROR; |
---|
3668 | } |
---|
3669 | } |
---|
3670 | goto matchFound; |
---|
3671 | } else { |
---|
3672 | switch (mode) { |
---|
3673 | case OPT_EXACT: |
---|
3674 | if (strCmpFn(TclGetString(stringObj), pattern) == 0) { |
---|
3675 | goto matchFound; |
---|
3676 | } |
---|
3677 | break; |
---|
3678 | case OPT_GLOB: |
---|
3679 | if (Tcl_StringCaseMatch(TclGetString(stringObj), pattern, |
---|
3680 | noCase)) { |
---|
3681 | goto matchFound; |
---|
3682 | } |
---|
3683 | break; |
---|
3684 | case OPT_REGEXP: |
---|
3685 | regExpr = Tcl_GetRegExpFromObj(interp, objv[i], |
---|
3686 | TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0)); |
---|
3687 | if (regExpr == NULL) { |
---|
3688 | return TCL_ERROR; |
---|
3689 | } else { |
---|
3690 | int matched = Tcl_RegExpExecObj(interp, regExpr, |
---|
3691 | stringObj, 0, numMatchesSaved, 0); |
---|
3692 | |
---|
3693 | if (matched < 0) { |
---|
3694 | return TCL_ERROR; |
---|
3695 | } else if (matched) { |
---|
3696 | goto matchFoundRegexp; |
---|
3697 | } |
---|
3698 | } |
---|
3699 | break; |
---|
3700 | } |
---|
3701 | } |
---|
3702 | } |
---|
3703 | return TCL_OK; |
---|
3704 | |
---|
3705 | matchFoundRegexp: |
---|
3706 | /* |
---|
3707 | * We are operating in REGEXP mode and we need to store information about |
---|
3708 | * what we matched in some user-nominated arrays. So build the lists of |
---|
3709 | * values and indices to write here. [TIP#75] |
---|
3710 | */ |
---|
3711 | |
---|
3712 | if (numMatchesSaved) { |
---|
3713 | Tcl_RegExpInfo info; |
---|
3714 | Tcl_Obj *matchesObj, *indicesObj = NULL; |
---|
3715 | |
---|
3716 | Tcl_RegExpGetInfo(regExpr, &info); |
---|
3717 | if (matchVarObj != NULL) { |
---|
3718 | TclNewObj(matchesObj); |
---|
3719 | } else { |
---|
3720 | matchesObj = NULL; |
---|
3721 | } |
---|
3722 | if (indexVarObj != NULL) { |
---|
3723 | TclNewObj(indicesObj); |
---|
3724 | } |
---|
3725 | |
---|
3726 | for (j=0 ; j<=info.nsubs ; j++) { |
---|
3727 | if (indexVarObj != NULL) { |
---|
3728 | Tcl_Obj *rangeObjAry[2]; |
---|
3729 | |
---|
3730 | rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start); |
---|
3731 | rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end); |
---|
3732 | |
---|
3733 | /* |
---|
3734 | * Never fails; the object is always clean at this point. |
---|
3735 | */ |
---|
3736 | |
---|
3737 | Tcl_ListObjAppendElement(NULL, indicesObj, |
---|
3738 | Tcl_NewListObj(2, rangeObjAry)); |
---|
3739 | } |
---|
3740 | |
---|
3741 | if (matchVarObj != NULL) { |
---|
3742 | Tcl_Obj *substringObj; |
---|
3743 | |
---|
3744 | substringObj = Tcl_GetRange(stringObj, |
---|
3745 | info.matches[j].start, info.matches[j].end-1); |
---|
3746 | |
---|
3747 | /* |
---|
3748 | * Never fails; the object is always clean at this point. |
---|
3749 | */ |
---|
3750 | |
---|
3751 | Tcl_ListObjAppendElement(NULL, matchesObj, substringObj); |
---|
3752 | } |
---|
3753 | } |
---|
3754 | |
---|
3755 | if (indexVarObj != NULL) { |
---|
3756 | if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, indicesObj, |
---|
3757 | TCL_LEAVE_ERR_MSG) == NULL) { |
---|
3758 | /* |
---|
3759 | * Careful! Check to see if we have allocated the list of |
---|
3760 | * matched strings; if so (but there was an error assigning |
---|
3761 | * the indices list) we have a potential memory leak because |
---|
3762 | * the match list has not been written to a variable. Except |
---|
3763 | * that we'll clean that up right now. |
---|
3764 | */ |
---|
3765 | |
---|
3766 | if (matchesObj != NULL) { |
---|
3767 | Tcl_DecrRefCount(matchesObj); |
---|
3768 | } |
---|
3769 | return TCL_ERROR; |
---|
3770 | } |
---|
3771 | } |
---|
3772 | if (matchVarObj != NULL) { |
---|
3773 | if (Tcl_ObjSetVar2(interp, matchVarObj, NULL, matchesObj, |
---|
3774 | TCL_LEAVE_ERR_MSG) == NULL) { |
---|
3775 | /* |
---|
3776 | * Unlike above, if indicesObj is non-NULL at this point, it |
---|
3777 | * will have been written to a variable already and will hence |
---|
3778 | * not be leaked. |
---|
3779 | */ |
---|
3780 | |
---|
3781 | return TCL_ERROR; |
---|
3782 | } |
---|
3783 | } |
---|
3784 | } |
---|
3785 | |
---|
3786 | /* |
---|
3787 | * We've got a match. Find a body to execute, skipping bodies that are |
---|
3788 | * "-". |
---|
3789 | */ |
---|
3790 | |
---|
3791 | matchFound: |
---|
3792 | ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); |
---|
3793 | *ctxPtr = *iPtr->cmdFramePtr; |
---|
3794 | |
---|
3795 | if (splitObjs) { |
---|
3796 | /* |
---|
3797 | * We have to perform the GetSrc and other type dependent handling of |
---|
3798 | * the frame here because we are munging with the line numbers, |
---|
3799 | * something the other commands like if, etc. are not doing. Them are |
---|
3800 | * fine with simply passing the CmdFrame through and having the |
---|
3801 | * special handling done in 'info frame', or the bc compiler |
---|
3802 | */ |
---|
3803 | |
---|
3804 | if (ctxPtr->type == TCL_LOCATION_BC) { |
---|
3805 | /* |
---|
3806 | * Type BC => ctxPtr->data.eval.path is not used. |
---|
3807 | * ctxPtr->data.tebc.codePtr is used instead. |
---|
3808 | */ |
---|
3809 | |
---|
3810 | TclGetSrcInfoForPc(ctxPtr); |
---|
3811 | pc = 1; |
---|
3812 | |
---|
3813 | /* |
---|
3814 | * The line information in the cmdFrame is now a copy we do not |
---|
3815 | * own. |
---|
3816 | */ |
---|
3817 | } |
---|
3818 | |
---|
3819 | if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) { |
---|
3820 | int bline = ctxPtr->line[bidx]; |
---|
3821 | |
---|
3822 | ctxPtr->line = (int *) ckalloc(objc * sizeof(int)); |
---|
3823 | ctxPtr->nline = objc; |
---|
3824 | TclListLines(TclGetString(blist), bline, objc, ctxPtr->line); |
---|
3825 | } else { |
---|
3826 | /* |
---|
3827 | * This is either a dynamic code word, when all elements are |
---|
3828 | * relative to themselves, or something else less expected and |
---|
3829 | * where we have no information. The result is the same in both |
---|
3830 | * cases; tell the code to come that it doesn't know where it is, |
---|
3831 | * which triggers reversion to the old behavior. |
---|
3832 | */ |
---|
3833 | |
---|
3834 | int k; |
---|
3835 | |
---|
3836 | ctxPtr->line = (int *) ckalloc(objc * sizeof(int)); |
---|
3837 | ctxPtr->nline = objc; |
---|
3838 | for (k=0; k < objc; k++) { |
---|
3839 | ctxPtr->line[k] = -1; |
---|
3840 | } |
---|
3841 | } |
---|
3842 | } |
---|
3843 | |
---|
3844 | for (j = i + 1; ; j += 2) { |
---|
3845 | if (j >= objc) { |
---|
3846 | /* |
---|
3847 | * This shouldn't happen since we've checked that the last body is |
---|
3848 | * not a continuation... |
---|
3849 | */ |
---|
3850 | |
---|
3851 | Tcl_Panic("fall-out when searching for body to match pattern"); |
---|
3852 | } |
---|
3853 | if (strcmp(TclGetString(objv[j]), "-") != 0) { |
---|
3854 | break; |
---|
3855 | } |
---|
3856 | } |
---|
3857 | |
---|
3858 | /* |
---|
3859 | * TIP #280: Make invoking context available to switch branch. |
---|
3860 | */ |
---|
3861 | |
---|
3862 | result = TclEvalObjEx(interp, objv[j], 0, ctxPtr, j); |
---|
3863 | if (splitObjs) { |
---|
3864 | ckfree((char *) ctxPtr->line); |
---|
3865 | if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { |
---|
3866 | /* |
---|
3867 | * Death of SrcInfo reference. |
---|
3868 | */ |
---|
3869 | |
---|
3870 | Tcl_DecrRefCount(ctxPtr->data.eval.path); |
---|
3871 | } |
---|
3872 | } |
---|
3873 | |
---|
3874 | /* |
---|
3875 | * Generate an error message if necessary. |
---|
3876 | */ |
---|
3877 | |
---|
3878 | if (result == TCL_ERROR) { |
---|
3879 | int limit = 50; |
---|
3880 | int overflow = (patternLength > limit); |
---|
3881 | |
---|
3882 | Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( |
---|
3883 | "\n (\"%.*s%s\" arm line %d)", |
---|
3884 | (overflow ? limit : patternLength), pattern, |
---|
3885 | (overflow ? "..." : ""), interp->errorLine)); |
---|
3886 | } |
---|
3887 | TclStackFree(interp, ctxPtr); |
---|
3888 | return result; |
---|
3889 | } |
---|
3890 | |
---|
3891 | /* |
---|
3892 | *---------------------------------------------------------------------- |
---|
3893 | * |
---|
3894 | * Tcl_TimeObjCmd -- |
---|
3895 | * |
---|
3896 | * This object-based procedure is invoked to process the "time" Tcl |
---|
3897 | * command. See the user documentation for details on what it does. |
---|
3898 | * |
---|
3899 | * Results: |
---|
3900 | * A standard Tcl object result. |
---|
3901 | * |
---|
3902 | * Side effects: |
---|
3903 | * See the user documentation. |
---|
3904 | * |
---|
3905 | *---------------------------------------------------------------------- |
---|
3906 | */ |
---|
3907 | |
---|
3908 | int |
---|
3909 | Tcl_TimeObjCmd( |
---|
3910 | ClientData dummy, /* Not used. */ |
---|
3911 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
3912 | int objc, /* Number of arguments. */ |
---|
3913 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
3914 | { |
---|
3915 | register Tcl_Obj *objPtr; |
---|
3916 | Tcl_Obj *objs[4]; |
---|
3917 | register int i, result; |
---|
3918 | int count; |
---|
3919 | double totalMicroSec; |
---|
3920 | #ifndef TCL_WIDE_CLICKS |
---|
3921 | Tcl_Time start, stop; |
---|
3922 | #else |
---|
3923 | Tcl_WideInt start, stop; |
---|
3924 | #endif |
---|
3925 | |
---|
3926 | if (objc == 2) { |
---|
3927 | count = 1; |
---|
3928 | } else if (objc == 3) { |
---|
3929 | result = TclGetIntFromObj(interp, objv[2], &count); |
---|
3930 | if (result != TCL_OK) { |
---|
3931 | return result; |
---|
3932 | } |
---|
3933 | } else { |
---|
3934 | Tcl_WrongNumArgs(interp, 1, objv, "command ?count?"); |
---|
3935 | return TCL_ERROR; |
---|
3936 | } |
---|
3937 | |
---|
3938 | objPtr = objv[1]; |
---|
3939 | i = count; |
---|
3940 | #ifndef TCL_WIDE_CLICKS |
---|
3941 | Tcl_GetTime(&start); |
---|
3942 | #else |
---|
3943 | start = TclpGetWideClicks(); |
---|
3944 | #endif |
---|
3945 | while (i-- > 0) { |
---|
3946 | result = Tcl_EvalObjEx(interp, objPtr, 0); |
---|
3947 | if (result != TCL_OK) { |
---|
3948 | return result; |
---|
3949 | } |
---|
3950 | } |
---|
3951 | #ifndef TCL_WIDE_CLICKS |
---|
3952 | Tcl_GetTime(&stop); |
---|
3953 | totalMicroSec = ((double) (stop.sec - start.sec)) * 1.0e6 |
---|
3954 | + (stop.usec - start.usec); |
---|
3955 | #else |
---|
3956 | stop = TclpGetWideClicks(); |
---|
3957 | totalMicroSec = ((double) TclpWideClicksToNanoseconds(stop - start))/1.0e3; |
---|
3958 | #endif |
---|
3959 | |
---|
3960 | if (count <= 1) { |
---|
3961 | /* |
---|
3962 | * Use int obj since we know time is not fractional. [Bug 1202178] |
---|
3963 | */ |
---|
3964 | |
---|
3965 | objs[0] = Tcl_NewIntObj((count <= 0) ? 0 : (int) totalMicroSec); |
---|
3966 | } else { |
---|
3967 | objs[0] = Tcl_NewDoubleObj(totalMicroSec/count); |
---|
3968 | } |
---|
3969 | |
---|
3970 | /* |
---|
3971 | * Construct the result as a list because many programs have always parsed |
---|
3972 | * as such (extracting the first element, typically). |
---|
3973 | */ |
---|
3974 | |
---|
3975 | TclNewLiteralStringObj(objs[1], "microseconds"); |
---|
3976 | TclNewLiteralStringObj(objs[2], "per"); |
---|
3977 | TclNewLiteralStringObj(objs[3], "iteration"); |
---|
3978 | Tcl_SetObjResult(interp, Tcl_NewListObj(4, objs)); |
---|
3979 | |
---|
3980 | return TCL_OK; |
---|
3981 | } |
---|
3982 | |
---|
3983 | /* |
---|
3984 | *---------------------------------------------------------------------- |
---|
3985 | * |
---|
3986 | * Tcl_WhileObjCmd -- |
---|
3987 | * |
---|
3988 | * This procedure is invoked to process the "while" Tcl command. See the |
---|
3989 | * user documentation for details on what it does. |
---|
3990 | * |
---|
3991 | * With the bytecode compiler, this procedure is only called when a |
---|
3992 | * command name is computed at runtime, and is "while" or the name to |
---|
3993 | * which "while" was renamed: e.g., "set z while; $z {$i<100} {}" |
---|
3994 | * |
---|
3995 | * Results: |
---|
3996 | * A standard Tcl result. |
---|
3997 | * |
---|
3998 | * Side effects: |
---|
3999 | * See the user documentation. |
---|
4000 | * |
---|
4001 | *---------------------------------------------------------------------- |
---|
4002 | */ |
---|
4003 | |
---|
4004 | int |
---|
4005 | Tcl_WhileObjCmd( |
---|
4006 | ClientData dummy, /* Not used. */ |
---|
4007 | Tcl_Interp *interp, /* Current interpreter. */ |
---|
4008 | int objc, /* Number of arguments. */ |
---|
4009 | Tcl_Obj *CONST objv[]) /* Argument objects. */ |
---|
4010 | { |
---|
4011 | int result, value; |
---|
4012 | Interp *iPtr = (Interp *) interp; |
---|
4013 | |
---|
4014 | if (objc != 3) { |
---|
4015 | Tcl_WrongNumArgs(interp, 1, objv, "test command"); |
---|
4016 | return TCL_ERROR; |
---|
4017 | } |
---|
4018 | |
---|
4019 | while (1) { |
---|
4020 | result = Tcl_ExprBooleanObj(interp, objv[1], &value); |
---|
4021 | if (result != TCL_OK) { |
---|
4022 | return result; |
---|
4023 | } |
---|
4024 | if (!value) { |
---|
4025 | break; |
---|
4026 | } |
---|
4027 | |
---|
4028 | /* TIP #280. */ |
---|
4029 | result = TclEvalObjEx(interp, objv[2], 0, iPtr->cmdFramePtr, 2); |
---|
4030 | if ((result != TCL_OK) && (result != TCL_CONTINUE)) { |
---|
4031 | if (result == TCL_ERROR) { |
---|
4032 | Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( |
---|
4033 | "\n (\"while\" body line %d)", interp->errorLine)); |
---|
4034 | } |
---|
4035 | break; |
---|
4036 | } |
---|
4037 | } |
---|
4038 | if (result == TCL_BREAK) { |
---|
4039 | result = TCL_OK; |
---|
4040 | } |
---|
4041 | if (result == TCL_OK) { |
---|
4042 | Tcl_ResetResult(interp); |
---|
4043 | } |
---|
4044 | return result; |
---|
4045 | } |
---|
4046 | |
---|
4047 | /* |
---|
4048 | *---------------------------------------------------------------------- |
---|
4049 | * |
---|
4050 | * TclListLines -- |
---|
4051 | * |
---|
4052 | * ??? |
---|
4053 | * |
---|
4054 | * Results: |
---|
4055 | * Filled in array of line numbers? |
---|
4056 | * |
---|
4057 | * Side effects: |
---|
4058 | * None. |
---|
4059 | * |
---|
4060 | *---------------------------------------------------------------------- |
---|
4061 | */ |
---|
4062 | |
---|
4063 | void |
---|
4064 | TclListLines( |
---|
4065 | CONST char *listStr, /* Pointer to string with list structure. |
---|
4066 | * Assumed to be valid. Assumed to contain n |
---|
4067 | * elements. */ |
---|
4068 | int line, /* Line the list as a whole starts on. */ |
---|
4069 | int n, /* #elements in lines */ |
---|
4070 | int *lines) /* Array of line numbers, to fill. */ |
---|
4071 | { |
---|
4072 | int i, length = strlen(listStr); |
---|
4073 | CONST char *element = NULL, *next = NULL; |
---|
4074 | |
---|
4075 | for (i = 0; i < n; i++) { |
---|
4076 | TclFindElement(NULL, listStr, length, &element, &next, NULL, NULL); |
---|
4077 | |
---|
4078 | TclAdvanceLines(&line, listStr, element); |
---|
4079 | /* Leading whitespace */ |
---|
4080 | lines[i] = line; |
---|
4081 | length -= (next - listStr); |
---|
4082 | TclAdvanceLines(&line, element, next); |
---|
4083 | /* Element */ |
---|
4084 | listStr = next; |
---|
4085 | |
---|
4086 | if (*element == 0) { |
---|
4087 | /* ASSERT i == n */ |
---|
4088 | break; |
---|
4089 | } |
---|
4090 | } |
---|
4091 | } |
---|
4092 | |
---|
4093 | /* |
---|
4094 | * Local Variables: |
---|
4095 | * mode: c |
---|
4096 | * c-basic-offset: 4 |
---|
4097 | * fill-column: 78 |
---|
4098 | * End: |
---|
4099 | */ |
---|