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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 67 - (show annotations) (download)
Mon Oct 31 00:57:34 2016 UTC (6 years, 2 months ago) by dashley
File MIME type: text/plain
File size: 31098 byte(s)
Header and footer cleanup.
1 /* $Header$ */
2 /*
3 * tclRegexp.c --
4 *
5 * This file contains the public interfaces to the Tcl regular
6 * expression mechanism.
7 *
8 * Copyright (c) 1998 by Sun Microsystems, Inc.
9 * Copyright (c) 1998-1999 by Scriptics Corporation.
10 *
11 * See the file "license.terms" for information on usage and redistribution
12 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13 *
14 * RCS: @(#) $Id: tclregexp.c,v 1.1.1.1 2001/06/13 04:45:39 dtashley Exp $
15 */
16
17 #include "tclInt.h"
18 #include "tclPort.h"
19 #include "tclRegexp.h"
20
21 /*
22 *----------------------------------------------------------------------
23 * The routines in this file use Henry Spencer's regular expression
24 * package contained in the following additional source files:
25 *
26 * regc_color.c regc_cvec.c regc_lex.c
27 * regc_nfa.c regcomp.c regcustom.h
28 * rege_dfa.c regerror.c regerrs.h
29 * regex.h regexec.c regfree.c
30 * regfronts.c regguts.h
31 *
32 * Copyright (c) 1998 Henry Spencer. All rights reserved.
33 *
34 * Development of this software was funded, in part, by Cray Research Inc.,
35 * UUNET Communications Services Inc., Sun Microsystems Inc., and Scriptics
36 * Corporation, none of whom are responsible for the results. The author
37 * thanks all of them.
38 *
39 * Redistribution and use in source and binary forms -- with or without
40 * modification -- are permitted for any purpose, provided that
41 * redistributions in source form retain this entire copyright notice and
42 * indicate the origin and nature of any modifications.
43 *
44 * I'd appreciate being given credit for this package in the documentation
45 * of software which uses it, but that is not a requirement.
46 *
47 * THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
48 * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
49 * AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
50 * HENRY SPENCER BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
51 * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
52 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
53 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
54 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
55 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
56 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
57 *
58 * *** NOTE: this code has been altered slightly for use in Tcl: ***
59 * *** 1. Names have been changed, e.g. from re_comp to ***
60 * *** TclRegComp, to avoid clashes with other ***
61 * *** regexp implementations used by applications. ***
62 */
63
64 /*
65 * Thread local storage used to maintain a per-thread cache of compiled
66 * regular expressions.
67 */
68
69 #define NUM_REGEXPS 30
70
71 typedef struct ThreadSpecificData {
72 int initialized; /* Set to 1 when the module is initialized. */
73 char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled
74 * regular expression patterns. NULL
75 * means that this slot isn't used.
76 * Malloc-ed. */
77 int patLengths[NUM_REGEXPS];/* Number of non-null characters in
78 * corresponding entry in patterns.
79 * -1 means entry isn't used. */
80 struct TclRegexp *regexps[NUM_REGEXPS];
81 /* Compiled forms of above strings. Also
82 * malloc-ed, or NULL if not in use yet. */
83 } ThreadSpecificData;
84
85 static Tcl_ThreadDataKey dataKey;
86
87 /*
88 * Declarations for functions used only in this file.
89 */
90
91 static TclRegexp * CompileRegexp _ANSI_ARGS_((Tcl_Interp *interp,
92 char *pattern, int length, int flags));
93 static void DupRegexpInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
94 Tcl_Obj *copyPtr));
95 static void FinalizeRegexp _ANSI_ARGS_((ClientData clientData));
96 static void FreeRegexp _ANSI_ARGS_((TclRegexp *regexpPtr));
97 static void FreeRegexpInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
98 static int RegExpExecUniChar _ANSI_ARGS_((Tcl_Interp *interp,
99 Tcl_RegExp re, CONST Tcl_UniChar *uniString,
100 int numChars, int nmatches, int flags));
101 static int SetRegexpFromAny _ANSI_ARGS_((Tcl_Interp *interp,
102 Tcl_Obj *objPtr));
103
104 /*
105 * The regular expression Tcl object type. This serves as a cache
106 * of the compiled form of the regular expression.
107 */
108
109 Tcl_ObjType tclRegexpType = {
110 "regexp", /* name */
111 FreeRegexpInternalRep, /* freeIntRepProc */
112 DupRegexpInternalRep, /* dupIntRepProc */
113 NULL, /* updateStringProc */
114 SetRegexpFromAny /* setFromAnyProc */
115 };
116
117
118 /*
119 *----------------------------------------------------------------------
120 *
121 * Tcl_RegExpCompile --
122 *
123 * Compile a regular expression into a form suitable for fast
124 * matching. This procedure is DEPRECATED in favor of the
125 * object version of the command.
126 *
127 * Results:
128 * The return value is a pointer to the compiled form of string,
129 * suitable for passing to Tcl_RegExpExec. This compiled form
130 * is only valid up until the next call to this procedure, so
131 * don't keep these around for a long time! If an error occurred
132 * while compiling the pattern, then NULL is returned and an error
133 * message is left in the interp's result.
134 *
135 * Side effects:
136 * Updates the cache of compiled regexps.
137 *
138 *----------------------------------------------------------------------
139 */
140
141 Tcl_RegExp
142 Tcl_RegExpCompile(interp, string)
143 Tcl_Interp *interp; /* For use in error reporting and
144 * to access the interp regexp cache. */
145 char *string; /* String for which to produce
146 * compiled regular expression. */
147 {
148 return (Tcl_RegExp) CompileRegexp(interp, string, (int) strlen(string),
149 REG_ADVANCED);
150 }
151
152 /*
153 *----------------------------------------------------------------------
154 *
155 * Tcl_RegExpExec --
156 *
157 * Execute the regular expression matcher using a compiled form
158 * of a regular expression and save information about any match
159 * that is found.
160 *
161 * Results:
162 * If an error occurs during the matching operation then -1
163 * is returned and the interp's result contains an error message.
164 * Otherwise the return value is 1 if a matching range is
165 * found and 0 if there is no matching range.
166 *
167 * Side effects:
168 * None.
169 *
170 *----------------------------------------------------------------------
171 */
172
173 int
174 Tcl_RegExpExec(interp, re, string, start)
175 Tcl_Interp *interp; /* Interpreter to use for error reporting. */
176 Tcl_RegExp re; /* Compiled regular expression; must have
177 * been returned by previous call to
178 * Tcl_GetRegExpFromObj. */
179 CONST char *string; /* String against which to match re. */
180 CONST char *start; /* If string is part of a larger string,
181 * this identifies beginning of larger
182 * string, so that "^" won't match. */
183 {
184 int flags, result, numChars;
185 TclRegexp *regexp = (TclRegexp *)re;
186 Tcl_DString ds;
187 Tcl_UniChar *ustr;
188
189 /*
190 * If the starting point is offset from the beginning of the buffer,
191 * then we need to tell the regexp engine not to match "^".
192 */
193
194 if (string > start) {
195 flags = REG_NOTBOL;
196 } else {
197 flags = 0;
198 }
199
200 /*
201 * Remember the string for use by Tcl_RegExpRange().
202 */
203
204 regexp->string = string;
205 regexp->objPtr = NULL;
206
207 /*
208 * Convert the string to Unicode and perform the match.
209 */
210
211 Tcl_DStringInit(&ds);
212 ustr = Tcl_UtfToUniCharDString(string, -1, &ds);
213 numChars = Tcl_DStringLength(&ds) / sizeof(Tcl_UniChar);
214 result = RegExpExecUniChar(interp, re, ustr, numChars,
215 -1 /* nmatches */, flags);
216 Tcl_DStringFree(&ds);
217
218 return result;
219 }
220
221 /*
222 *---------------------------------------------------------------------------
223 *
224 * Tcl_RegExpRange --
225 *
226 * Returns pointers describing the range of a regular expression match,
227 * or one of the subranges within the match.
228 *
229 * Results:
230 * The variables at *startPtr and *endPtr are modified to hold the
231 * addresses of the endpoints of the range given by index. If the
232 * specified range doesn't exist then NULLs are returned.
233 *
234 * Side effects:
235 * None.
236 *
237 *---------------------------------------------------------------------------
238 */
239
240 void
241 Tcl_RegExpRange(re, index, startPtr, endPtr)
242 Tcl_RegExp re; /* Compiled regular expression that has
243 * been passed to Tcl_RegExpExec. */
244 int index; /* 0 means give the range of the entire
245 * match, > 0 means give the range of
246 * a matching subrange. */
247 char **startPtr; /* Store address of first character in
248 * (sub-) range here. */
249 char **endPtr; /* Store address of character just after last
250 * in (sub-) range here. */
251 {
252 TclRegexp *regexpPtr = (TclRegexp *) re;
253 CONST char *string;
254
255 if ((size_t) index > regexpPtr->re.re_nsub) {
256 *startPtr = *endPtr = NULL;
257 } else if (regexpPtr->matches[index].rm_so < 0) {
258 *startPtr = *endPtr = NULL;
259 } else {
260 if (regexpPtr->objPtr) {
261 string = Tcl_GetString(regexpPtr->objPtr);
262 } else {
263 string = regexpPtr->string;
264 }
265 *startPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_so);
266 *endPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_eo);
267 }
268 }
269
270 /*
271 *---------------------------------------------------------------------------
272 *
273 * RegExpExecUniChar --
274 *
275 * Execute the regular expression matcher using a compiled form of a
276 * regular expression and save information about any match that is
277 * found.
278 *
279 * Results:
280 * If an error occurs during the matching operation then -1 is
281 * returned and an error message is left in interp's result.
282 * Otherwise the return value is 1 if a matching range was found or
283 * 0 if there was no matching range.
284 *
285 * Side effects:
286 * None.
287 *
288 *----------------------------------------------------------------------
289 */
290
291 static int
292 RegExpExecUniChar(interp, re, wString, numChars, nmatches, flags)
293 Tcl_Interp *interp; /* Interpreter to use for error reporting. */
294 Tcl_RegExp re; /* Compiled regular expression; returned by
295 * a previous call to Tcl_GetRegExpFromObj */
296 CONST Tcl_UniChar *wString; /* String against which to match re. */
297 int numChars; /* Length of Tcl_UniChar string (must
298 * be >= 0). */
299 int nmatches; /* How many subexpression matches (counting
300 * the whole match as subexpression 0) are
301 * of interest. -1 means "don't know". */
302 int flags; /* Regular expression flags. */
303 {
304 int status;
305 TclRegexp *regexpPtr = (TclRegexp *) re;
306 size_t last = regexpPtr->re.re_nsub + 1;
307 size_t nm = last;
308
309 if (nmatches >= 0 && (size_t) nmatches < nm) {
310 nm = (size_t) nmatches;
311 }
312
313 status = TclReExec(&regexpPtr->re, wString, (size_t) numChars,
314 &regexpPtr->details, nm, regexpPtr->matches, flags);
315
316 /*
317 * Check for errors.
318 */
319
320 if (status != REG_OKAY) {
321 if (status == REG_NOMATCH) {
322 return 0;
323 }
324 if (interp != NULL) {
325 TclRegError(interp, "error while matching regular expression: ",
326 status);
327 }
328 return -1;
329 }
330 return 1;
331 }
332
333 /*
334 *---------------------------------------------------------------------------
335 *
336 * TclRegExpRangeUniChar --
337 *
338 * Returns pointers describing the range of a regular expression match,
339 * or one of the subranges within the match, or the hypothetical range
340 * represented by the rm_extend field of the rm_detail_t.
341 *
342 * Results:
343 * The variables at *startPtr and *endPtr are modified to hold the
344 * offsets of the endpoints of the range given by index. If the
345 * specified range doesn't exist then -1s are supplied.
346 *
347 * Side effects:
348 * None.
349 *
350 *---------------------------------------------------------------------------
351 */
352
353 void
354 TclRegExpRangeUniChar(re, index, startPtr, endPtr)
355 Tcl_RegExp re; /* Compiled regular expression that has
356 * been passed to Tcl_RegExpExec. */
357 int index; /* 0 means give the range of the entire
358 * match, > 0 means give the range of
359 * a matching subrange, -1 means the
360 * range of the rm_extend field. */
361 int *startPtr; /* Store address of first character in
362 * (sub-) range here. */
363 int *endPtr; /* Store address of character just after last
364 * in (sub-) range here. */
365 {
366 TclRegexp *regexpPtr = (TclRegexp *) re;
367
368 if ((regexpPtr->flags&REG_EXPECT) && index == -1) {
369 *startPtr = regexpPtr->details.rm_extend.rm_so;
370 *endPtr = regexpPtr->details.rm_extend.rm_eo;
371 } else if ((size_t) index > regexpPtr->re.re_nsub) {
372 *startPtr = -1;
373 *endPtr = -1;
374 } else {
375 *startPtr = regexpPtr->matches[index].rm_so;
376 *endPtr = regexpPtr->matches[index].rm_eo;
377 }
378 }
379
380 /*
381 *----------------------------------------------------------------------
382 *
383 * Tcl_RegExpMatch --
384 *
385 * See if a string matches a regular expression.
386 *
387 * Results:
388 * If an error occurs during the matching operation then -1
389 * is returned and the interp's result contains an error message.
390 * Otherwise the return value is 1 if "string" matches "pattern"
391 * and 0 otherwise.
392 *
393 * Side effects:
394 * None.
395 *
396 *----------------------------------------------------------------------
397 */
398
399 int
400 Tcl_RegExpMatch(interp, string, pattern)
401 Tcl_Interp *interp; /* Used for error reporting. May be NULL. */
402 char *string; /* String. */
403 char *pattern; /* Regular expression to match against
404 * string. */
405 {
406 Tcl_RegExp re;
407
408 re = Tcl_RegExpCompile(interp, pattern);
409 if (re == NULL) {
410 return -1;
411 }
412 return Tcl_RegExpExec(interp, re, string, string);
413 }
414
415 /*
416 *----------------------------------------------------------------------
417 *
418 * Tcl_RegExpExecObj --
419 *
420 * Execute a precompiled regexp against the given object.
421 *
422 * Results:
423 * If an error occurs during the matching operation then -1
424 * is returned and the interp's result contains an error message.
425 * Otherwise the return value is 1 if "string" matches "pattern"
426 * and 0 otherwise.
427 *
428 * Side effects:
429 * Converts the object to a Unicode object.
430 *
431 *----------------------------------------------------------------------
432 */
433
434 int
435 Tcl_RegExpExecObj(interp, re, objPtr, offset, nmatches, flags)
436 Tcl_Interp *interp; /* Interpreter to use for error reporting. */
437 Tcl_RegExp re; /* Compiled regular expression; must have
438 * been returned by previous call to
439 * Tcl_GetRegExpFromObj. */
440 Tcl_Obj *objPtr; /* String against which to match re. */
441 int offset; /* Character index that marks where matching
442 * should begin. */
443 int nmatches; /* How many subexpression matches (counting
444 * the whole match as subexpression 0) are
445 * of interest. -1 means all of them. */
446 int flags; /* Regular expression execution flags. */
447 {
448 TclRegexp *regexpPtr = (TclRegexp *) re;
449 Tcl_UniChar *udata;
450 int length;
451
452 /*
453 * Save the target object so we can extract strings from it later.
454 */
455
456 regexpPtr->string = NULL;
457 regexpPtr->objPtr = objPtr;
458
459 udata = Tcl_GetUnicode(objPtr);
460 length = Tcl_GetCharLength(objPtr);
461
462 if (offset > length) {
463 offset = length;
464 }
465 udata += offset;
466 length -= offset;
467
468 return RegExpExecUniChar(interp, re, udata, length, nmatches, flags);
469 }
470
471 /*
472 *----------------------------------------------------------------------
473 *
474 * Tcl_RegExpMatchObj --
475 *
476 * See if an object matches a regular expression.
477 *
478 * Results:
479 * If an error occurs during the matching operation then -1
480 * is returned and the interp's result contains an error message.
481 * Otherwise the return value is 1 if "string" matches "pattern"
482 * and 0 otherwise.
483 *
484 * Side effects:
485 * Changes the internal rep of the pattern and string objects.
486 *
487 *----------------------------------------------------------------------
488 */
489
490 int
491 Tcl_RegExpMatchObj(interp, stringObj, patternObj)
492 Tcl_Interp *interp; /* Used for error reporting. May be NULL. */
493 Tcl_Obj *stringObj; /* Object containing the String to search. */
494 Tcl_Obj *patternObj; /* Regular expression to match against
495 * string. */
496 {
497 Tcl_RegExp re;
498
499 re = Tcl_GetRegExpFromObj(interp, patternObj,
500 TCL_REG_ADVANCED | TCL_REG_NOSUB);
501 if (re == NULL) {
502 return -1;
503 }
504 return Tcl_RegExpExecObj(interp, re, stringObj, 0 /* offset */,
505 0 /* nmatches */, 0 /* flags */);
506 }
507
508 /*
509 *----------------------------------------------------------------------
510 *
511 * Tcl_RegExpGetInfo --
512 *
513 * Retrieve information about the current match.
514 *
515 * Results:
516 * None.
517 *
518 * Side effects:
519 * None.
520 *
521 *----------------------------------------------------------------------
522 */
523
524 void
525 Tcl_RegExpGetInfo(regexp, infoPtr)
526 Tcl_RegExp regexp; /* Pattern from which to get subexpressions. */
527 Tcl_RegExpInfo *infoPtr; /* Match information is stored here. */
528 {
529 TclRegexp *regexpPtr = (TclRegexp *) regexp;
530
531 infoPtr->nsubs = regexpPtr->re.re_nsub;
532 infoPtr->matches = (Tcl_RegExpIndices *) regexpPtr->matches;
533 infoPtr->extendStart = regexpPtr->details.rm_extend.rm_so;
534 }
535
536 /*
537 *----------------------------------------------------------------------
538 *
539 * Tcl_GetRegExpFromObj --
540 *
541 * Compile a regular expression into a form suitable for fast
542 * matching. This procedure caches the result in a Tcl_Obj.
543 *
544 * Results:
545 * The return value is a pointer to the compiled form of string,
546 * suitable for passing to Tcl_RegExpExec. If an error occurred
547 * while compiling the pattern, then NULL is returned and an error
548 * message is left in the interp's result.
549 *
550 * Side effects:
551 * Updates the native rep of the Tcl_Obj.
552 *
553 *----------------------------------------------------------------------
554 */
555
556 Tcl_RegExp
557 Tcl_GetRegExpFromObj(interp, objPtr, flags)
558 Tcl_Interp *interp; /* For use in error reporting, and to access
559 * the interp regexp cache. */
560 Tcl_Obj *objPtr; /* Object whose string rep contains regular
561 * expression pattern. Internal rep will be
562 * changed to compiled form of this regular
563 * expression. */
564 int flags; /* Regular expression compilation flags. */
565 {
566 int length;
567 Tcl_ObjType *typePtr;
568 TclRegexp *regexpPtr;
569 char *pattern;
570
571 typePtr = objPtr->typePtr;
572 regexpPtr = (TclRegexp *) objPtr->internalRep.otherValuePtr;
573
574 if ((typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) {
575 pattern = Tcl_GetStringFromObj(objPtr, &length);
576
577 regexpPtr = CompileRegexp(interp, pattern, length, flags);
578 if (regexpPtr == NULL) {
579 return NULL;
580 }
581
582 /*
583 * Add a reference to the regexp so it will persist even if it is
584 * pushed out of the current thread's regexp cache. This reference
585 * will be removed when the object's internal rep is freed.
586 */
587
588 regexpPtr->refCount++;
589
590 /*
591 * Free the old representation and set our type.
592 */
593
594 if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
595 (*typePtr->freeIntRepProc)(objPtr);
596 }
597 objPtr->internalRep.otherValuePtr = (VOID *) regexpPtr;
598 objPtr->typePtr = &tclRegexpType;
599 }
600 return (Tcl_RegExp) regexpPtr;
601 }
602
603 /*
604 *----------------------------------------------------------------------
605 *
606 * TclRegAbout --
607 *
608 * Return information about a compiled regular expression.
609 *
610 * Results:
611 * The return value is -1 for failure, 0 for success, although at
612 * the moment there's nothing that could fail. On success, a list
613 * is left in the interp's result: first element is the subexpression
614 * count, second is a list of re_info bit names.
615 *
616 * Side effects:
617 * None.
618 *
619 *----------------------------------------------------------------------
620 */
621
622 int
623 TclRegAbout(interp, re)
624 Tcl_Interp *interp; /* For use in variable assignment. */
625 Tcl_RegExp re; /* The compiled regular expression. */
626 {
627 TclRegexp *regexpPtr = (TclRegexp *)re;
628 char buf[TCL_INTEGER_SPACE];
629 static struct infoname {
630 int bit;
631 char *text;
632 } infonames[] = {
633 {REG_UBACKREF, "REG_UBACKREF"},
634 {REG_ULOOKAHEAD, "REG_ULOOKAHEAD"},
635 {REG_UBOUNDS, "REG_UBOUNDS"},
636 {REG_UBRACES, "REG_UBRACES"},
637 {REG_UBSALNUM, "REG_UBSALNUM"},
638 {REG_UPBOTCH, "REG_UPBOTCH"},
639 {REG_UBBS, "REG_UBBS"},
640 {REG_UNONPOSIX, "REG_UNONPOSIX"},
641 {REG_UUNSPEC, "REG_UUNSPEC"},
642 {REG_UUNPORT, "REG_UUNPORT"},
643 {REG_ULOCALE, "REG_ULOCALE"},
644 {REG_UEMPTYMATCH, "REG_UEMPTYMATCH"},
645 {REG_UIMPOSSIBLE, "REG_UIMPOSSIBLE"},
646 {REG_USHORTEST, "REG_USHORTEST"},
647 {0, ""}
648 };
649 struct infoname *inf;
650 int n;
651
652 Tcl_ResetResult(interp);
653
654 sprintf(buf, "%u", (unsigned)(regexpPtr->re.re_nsub));
655 Tcl_AppendElement(interp, buf);
656
657 /*
658 * Must count bits before generating list, because we must know
659 * whether {} are needed before we start appending names.
660 */
661 n = 0;
662 for (inf = infonames; inf->bit != 0; inf++) {
663 if (regexpPtr->re.re_info&inf->bit) {
664 n++;
665 }
666 }
667 if (n != 1) {
668 Tcl_AppendResult(interp, " {", NULL);
669 }
670 for (inf = infonames; inf->bit != 0; inf++) {
671 if (regexpPtr->re.re_info&inf->bit) {
672 Tcl_AppendElement(interp, inf->text);
673 }
674 }
675 if (n != 1) {
676 Tcl_AppendResult(interp, "}", NULL);
677 }
678
679 return 0;
680 }
681
682 /*
683 *----------------------------------------------------------------------
684 *
685 * TclRegError --
686 *
687 * Generate an error message based on the regexp status code.
688 *
689 * Results:
690 * Places an error in the interpreter.
691 *
692 * Side effects:
693 * Sets errorCode as well.
694 *
695 *----------------------------------------------------------------------
696 */
697
698 void
699 TclRegError(interp, msg, status)
700 Tcl_Interp *interp; /* Interpreter for error reporting. */
701 char *msg; /* Message to prepend to error. */
702 int status; /* Status code to report. */
703 {
704 char buf[100]; /* ample in practice */
705 char cbuf[100]; /* lots in practice */
706 size_t n;
707 char *p;
708
709 Tcl_ResetResult(interp);
710 n = TclReError(status, (regex_t *)NULL, buf, sizeof(buf));
711 p = (n > sizeof(buf)) ? "..." : "";
712 Tcl_AppendResult(interp, msg, buf, p, NULL);
713
714 sprintf(cbuf, "%d", status);
715 (VOID) TclReError(REG_ITOA, (regex_t *)NULL, cbuf, sizeof(cbuf));
716 Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, NULL);
717 }
718
719
720 /*
721 *----------------------------------------------------------------------
722 *
723 * FreeRegexpInternalRep --
724 *
725 * Deallocate the storage associated with a regexp object's internal
726 * representation.
727 *
728 * Results:
729 * None.
730 *
731 * Side effects:
732 * Frees the compiled regular expression.
733 *
734 *----------------------------------------------------------------------
735 */
736
737 static void
738 FreeRegexpInternalRep(objPtr)
739 Tcl_Obj *objPtr; /* Regexp object with internal rep to free. */
740 {
741 TclRegexp *regexpRepPtr = (TclRegexp *) objPtr->internalRep.otherValuePtr;
742
743 /*
744 * If this is the last reference to the regexp, free it.
745 */
746
747 if (--(regexpRepPtr->refCount) <= 0) {
748 FreeRegexp(regexpRepPtr);
749 }
750 }
751
752 /*
753 *----------------------------------------------------------------------
754 *
755 * DupRegexpInternalRep --
756 *
757 * We copy the reference to the compiled regexp and bump its
758 * reference count.
759 *
760 * Results:
761 * None.
762 *
763 * Side effects:
764 * Increments the reference count of the regexp.
765 *
766 *----------------------------------------------------------------------
767 */
768
769 static void
770 DupRegexpInternalRep(srcPtr, copyPtr)
771 Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
772 Tcl_Obj *copyPtr; /* Object with internal rep to set. */
773 {
774 TclRegexp *regexpPtr = (TclRegexp *) srcPtr->internalRep.otherValuePtr;
775 regexpPtr->refCount++;
776 copyPtr->internalRep.otherValuePtr = srcPtr->internalRep.otherValuePtr;
777 copyPtr->typePtr = &tclRegexpType;
778 }
779
780 /*
781 *----------------------------------------------------------------------
782 *
783 * SetRegexpFromAny --
784 *
785 * Attempt to generate a compiled regular expression for the Tcl object
786 * "objPtr".
787 *
788 * Results:
789 * The return value is TCL_OK or TCL_ERROR. If an error occurs during
790 * conversion, an error message is left in the interpreter's result
791 * unless "interp" is NULL.
792 *
793 * Side effects:
794 * If no error occurs, a regular expression is stored as "objPtr"s
795 * internal representation.
796 *
797 *----------------------------------------------------------------------
798 */
799
800 static int
801 SetRegexpFromAny(interp, objPtr)
802 Tcl_Interp *interp; /* Used for error reporting if not NULL. */
803 Tcl_Obj *objPtr; /* The object to convert. */
804 {
805 if (Tcl_GetRegExpFromObj(interp, objPtr, REG_ADVANCED) == NULL) {
806 return TCL_ERROR;
807 }
808 return TCL_OK;
809 }
810
811 /*
812 *---------------------------------------------------------------------------
813 *
814 * CompileRegexp --
815 *
816 * Attempt to compile the given regexp pattern. If the compiled
817 * regular expression can be found in the per-thread cache, it
818 * will be used instead of compiling a new copy.
819 *
820 * Results:
821 * The return value is a pointer to a newly allocated TclRegexp
822 * that represents the compiled pattern, or NULL if the pattern
823 * could not be compiled. If NULL is returned, an error message is
824 * left in the interp's result.
825 *
826 * Side effects:
827 * The thread-local regexp cache is updated and a new TclRegexp may
828 * be allocated.
829 *
830 *----------------------------------------------------------------------
831 */
832
833 static TclRegexp *
834 CompileRegexp(interp, string, length, flags)
835 Tcl_Interp *interp; /* Used for error reporting if not NULL. */
836 char *string; /* The regexp to compile (UTF-8). */
837 int length; /* The length of the string in bytes. */
838 int flags; /* Compilation flags. */
839 {
840 TclRegexp *regexpPtr;
841 Tcl_UniChar *uniString;
842 int numChars;
843 Tcl_DString stringBuf;
844 int status, i;
845 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
846
847 if (!tsdPtr->initialized) {
848 tsdPtr->initialized = 1;
849 Tcl_CreateThreadExitHandler(FinalizeRegexp, NULL);
850 }
851
852 /*
853 * This routine maintains a second-level regular expression cache in
854 * addition to the per-object regexp cache. The per-thread cache is needed
855 * to handle the case where for various reasons the object is lost between
856 * invocations of the regexp command, but the literal pattern is the same.
857 */
858
859 /*
860 * Check the per-thread compiled regexp cache. We can only reuse
861 * a regexp if it has the same pattern and the same flags.
862 */
863
864 for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) {
865 if ((length == tsdPtr->patLengths[i])
866 && (tsdPtr->regexps[i]->flags == flags)
867 && (strcmp(string, tsdPtr->patterns[i]) == 0)) {
868 /*
869 * Move the matched pattern to the first slot in the
870 * cache and shift the other patterns down one position.
871 */
872
873 if (i != 0) {
874 int j;
875 char *cachedString;
876
877 cachedString = tsdPtr->patterns[i];
878 regexpPtr = tsdPtr->regexps[i];
879 for (j = i-1; j >= 0; j--) {
880 tsdPtr->patterns[j+1] = tsdPtr->patterns[j];
881 tsdPtr->patLengths[j+1] = tsdPtr->patLengths[j];
882 tsdPtr->regexps[j+1] = tsdPtr->regexps[j];
883 }
884 tsdPtr->patterns[0] = cachedString;
885 tsdPtr->patLengths[0] = length;
886 tsdPtr->regexps[0] = regexpPtr;
887 }
888 return tsdPtr->regexps[0];
889 }
890 }
891
892 /*
893 * This is a new expression, so compile it and add it to the cache.
894 */
895
896 regexpPtr = (TclRegexp *) ckalloc(sizeof(TclRegexp));
897 regexpPtr->objPtr = NULL;
898 regexpPtr->string = NULL;
899 regexpPtr->details.rm_extend.rm_so = -1;
900 regexpPtr->details.rm_extend.rm_eo = -1;
901
902 /*
903 * Get the up-to-date string representation and map to unicode.
904 */
905
906 Tcl_DStringInit(&stringBuf);
907 uniString = Tcl_UtfToUniCharDString(string, length, &stringBuf);
908 numChars = Tcl_DStringLength(&stringBuf) / sizeof(Tcl_UniChar);
909
910 /*
911 * Compile the string and check for errors.
912 */
913
914 regexpPtr->flags = flags;
915 status = TclReComp(&regexpPtr->re, uniString, (size_t) numChars, flags);
916 Tcl_DStringFree(&stringBuf);
917
918 if (status != REG_OKAY) {
919 /*
920 * Clean up and report errors in the interpreter, if possible.
921 */
922
923 ckfree((char *)regexpPtr);
924 if (interp) {
925 TclRegError(interp,
926 "couldn't compile regular expression pattern: ",
927 status);
928 }
929 return NULL;
930 }
931
932 /*
933 * Allocate enough space for all of the subexpressions, plus one
934 * extra for the entire pattern.
935 */
936
937 regexpPtr->matches = (regmatch_t *) ckalloc(
938 sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1));
939
940 /*
941 * Initialize the refcount to one initially, since it is in the cache.
942 */
943
944 regexpPtr->refCount = 1;
945
946 /*
947 * Free the last regexp, if necessary, and make room at the head of the
948 * list for the new regexp.
949 */
950
951 if (tsdPtr->patterns[NUM_REGEXPS-1] != NULL) {
952 TclRegexp *oldRegexpPtr = tsdPtr->regexps[NUM_REGEXPS-1];
953 if (--(oldRegexpPtr->refCount) <= 0) {
954 FreeRegexp(oldRegexpPtr);
955 }
956 ckfree(tsdPtr->patterns[NUM_REGEXPS-1]);
957 }
958 for (i = NUM_REGEXPS - 2; i >= 0; i--) {
959 tsdPtr->patterns[i+1] = tsdPtr->patterns[i];
960 tsdPtr->patLengths[i+1] = tsdPtr->patLengths[i];
961 tsdPtr->regexps[i+1] = tsdPtr->regexps[i];
962 }
963 tsdPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1));
964 strcpy(tsdPtr->patterns[0], string);
965 tsdPtr->patLengths[0] = length;
966 tsdPtr->regexps[0] = regexpPtr;
967
968 return regexpPtr;
969 }
970
971 /*
972 *----------------------------------------------------------------------
973 *
974 * FreeRegexp --
975 *
976 * Release the storage associated with a TclRegexp.
977 *
978 * Results:
979 * None.
980 *
981 * Side effects:
982 * None.
983 *
984 *----------------------------------------------------------------------
985 */
986
987 static void
988 FreeRegexp(regexpPtr)
989 TclRegexp *regexpPtr; /* Compiled regular expression to free. */
990 {
991 TclReFree(&regexpPtr->re);
992 if (regexpPtr->matches) {
993 ckfree((char *) regexpPtr->matches);
994 }
995 ckfree((char *) regexpPtr);
996 }
997
998 /*
999 *----------------------------------------------------------------------
1000 *
1001 * FinalizeRegexp --
1002 *
1003 * Release the storage associated with the per-thread regexp
1004 * cache.
1005 *
1006 * Results:
1007 * None.
1008 *
1009 * Side effects:
1010 * None.
1011 *
1012 *----------------------------------------------------------------------
1013 */
1014
1015 static void
1016 FinalizeRegexp(clientData)
1017 ClientData clientData; /* Not used. */
1018 {
1019 int i;
1020 TclRegexp *regexpPtr;
1021 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1022
1023 for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) {
1024 regexpPtr = tsdPtr->regexps[i];
1025 if (--(regexpPtr->refCount) <= 0) {
1026 FreeRegexp(regexpPtr);
1027 }
1028 ckfree(tsdPtr->patterns[i]);
1029 }
1030 }
1031
1032 /* End of tclregexp.c */

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25