git.zerfleddert.de Git - micropolis/blob

1 /*

2 * tclUtil.c --

3 *

4 * This file contains utility procedures that are used by many Tcl

5 * commands.

6 *

8 * Permission to use, copy, modify, and distribute this

9 * software and its documentation for any purpose and without

10 * fee is hereby granted, provided that the above copyright

11 * notice appear in all copies. The University of California

12 * makes no representations about the suitability of this

13 * software for any purpose. It is provided "as is" without

14 * express or implied warranty.

15 */

17 #ifndef lint

18 static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUtil.c,v 1.63 92/07/02 08:50:54 ouster Exp $ SPRITE (Berkeley)";

19 #endif

21 #include "tclint.h"

23 /*

24 * The following values are used in the flags returned by Tcl_ScanElement

25 * and used by Tcl_ConvertElement. The value TCL_DONT_USE_BRACES is also

26 * defined in tcl.h; make sure its value doesn't overlap with any of the

27 * values below.

28 *

29 * TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in

30 * braces (e.g. it contains unmatched braces,

31 * or ends in a backslash character, or user

32 * just doesn't want braces); handle all

33 * special characters by adding backslashes.

34 * USE_BRACES - 1 means the string contains a special

35 * character that can be handled simply by

36 * enclosing the entire argument in braces.

37 * BRACES_UNMATCHED - 1 means that braces aren't properly matched

38 * in the argument.

39 */

41 #define USE_BRACES 2

42 #define BRACES_UNMATCHED 4

44 /*

45 * The variable below is set to NULL before invoking regexp functions

46 * and checked after those functions. If an error occurred then regerror

47 * will set the variable to point to a (static) error message. This

48 * mechanism unfortunately does not support multi-threading, but then

49 * neither does the rest of the regexp facilities.

50 */

52 char *tclRegexpError = NULL;

54 /*

55 * Function prototypes for local procedures in this file:

56 */

 static void             SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,

59 int newSpace));

60 \f

61 /*

62 *----------------------------------------------------------------------

63 *

64 * TclFindElement --

65 *

66 * Given a pointer into a Tcl list, locate the first (or next)

67 * element in the list.

68 *

69 * Results:

70 * The return value is normally TCL_OK, which means that the

71 * element was successfully located. If TCL_ERROR is returned

72 * it means that list didn't have proper list structure;

73 * interp->result contains a more detailed error message.

74 *

75 * If TCL_OK is returned, then *elementPtr will be set to point

76 * to the first element of list, and *nextPtr will be set to point

77 * to the character just after any white space following the last

78 * character that's part of the element. If this is the last argument

79 * in the list, then *nextPtr will point to the NULL character at the

80 * end of list. If sizePtr is non-NULL, *sizePtr is filled in with

81 * the number of characters in the element. If the element is in

82 * braces, then *elementPtr will point to the character after the

83 * opening brace and *sizePtr will not include either of the braces.

84 * If there isn't an element in the list, *sizePtr will be zero, and

85 * both *elementPtr and *termPtr will refer to the null character at

86 * the end of list. Note: this procedure does NOT collapse backslash

87 * sequences.

88 *

89 * Side effects:

90 * None.

91 *

92 *----------------------------------------------------------------------

93 */

95 int

 TclFindElement(interp, list, elementPtr, nextPtr, sizePtr, bracePtr)

97 Tcl_Interp *interp; /* Interpreter to use for error reporting. */

     register char *list;        /* String containing Tcl list with zero

99 * or more elements (possibly in braces). */

100 char **elementPtr; /* Fill in with location of first significant

101 * character in first element of list. */

102 char **nextPtr; /* Fill in with location of character just

103 * after all white space following end of

104 * argument (i.e. next argument or end of

105 * list). */

106 int *sizePtr; /* If non-zero, fill in with size of

107 * element. */

108 int *bracePtr; /* If non-zero fill in with non-zero/zero

109 * to indicate that arg was/wasn't

110 * in braces. */

111 {

112 register char *p;

113 int openBraces = 0;

114 int inQuotes = 0;

115 int size;

116

117 /*

118 * Skim off leading white space and check for an opening brace or

119 * quote. Note: use of "isascii" below and elsewhere in this

120 * procedure is a temporary workaround (7/27/90) because Mx uses characters

121 * with the high-order bit set for some things. This should probably

122 * be changed back eventually, or all of Tcl should call isascii.

123 */

124

     while (isascii(*list) && isspace(*list)) {

126 list++;

127 }

     if (*list == '{') {

129 openBraces = 1;

130 list++;

     } else if (*list == '"') {

132 inQuotes = 1;

133 list++;

134 }

     if (bracePtr != 0) {

136 *bracePtr = openBraces;

137 }

138 p = list;

139

140 /*

141 * Find the end of the element (either a space or a close brace or

142 * the end of the string).

143 */

144

145 while (1) {

146 switch (*p) {

147

148 /*

149 * Open brace: don't treat specially unless the element is

150 * in braces. In this case, keep a nesting count.

151 */

152

153 case '{':

                 if (openBraces != 0) {

155 openBraces++;

156 }

157 break;

158

159 /*

160 * Close brace: if element is in braces, keep nesting

161 * count and quit when the last close brace is seen.

162 */

163

164 case '}':

                 if (openBraces == 1) {

166 char *p2;

167

168 size = p - list;

169 p++;

                     if ((isascii(*p) && isspace(*p)) || (*p == 0)) {

171 goto done;

172 }

                     for (p2 = p; (*p2 != 0) && (!isspace(*p2)) && (p2 < p+20);

174 p2++) {

175 /* null body */

176 }

177 Tcl_ResetResult(interp);

178 sprintf(interp->result,

                             "list element in braces followed by \"%.*s\" instead of space",

180 p2-p, p);

181 return TCL_ERROR;

                 } else if (openBraces != 0) {

183 openBraces--;

184 }

185 break;

186

187 /*

188 * Backslash: skip over everything up to the end of the

189 * backslash sequence.

190 */

191

             case '\\': {

193 int size;

194

                 (void) Tcl_Backslash(p, &size);

196 p += size - 1;

197 break;

198 }

199

200 /*

201 * Space: ignore if element is in braces or quotes; otherwise

202 * terminate element.

203 */

204

205 case ' ':

             case '\f':

             case '\n':

             case '\r':

             case '\t':

             case '\v':

                 if ((openBraces == 0) && !inQuotes) {

212 size = p - list;

213 goto done;

214 }

215 break;

216

217 /*

218 * Double-quote: if element is in quotes then terminate it.

219 */

220

221 case '"':

222 if (inQuotes) {

223 char *p2;

224

225 size = p-list;

226 p++;

                     if ((isascii(*p) && isspace(*p)) || (*p == 0)) {

228 goto done;

229 }

                     for (p2 = p; (*p2 != 0) && (!isspace(*p2)) && (p2 < p+20);

231 p2++) {

232 /* null body */

233 }

234 Tcl_ResetResult(interp);

235 sprintf(interp->result,

                             "list element in quotes followed by \"%.*s\" %s",

                             p2-p, p, "instead of space");

238 return TCL_ERROR;

239 }

240 break;

241

242 /*

243 * End of list: terminate element.

244 */

245

246 case 0:

                 if (openBraces != 0) {

                     Tcl_SetResult(interp, "unmatched open brace in list",

249 TCL_STATIC);

250 return TCL_ERROR;

251 } else if (inQuotes) {

                     Tcl_SetResult(interp, "unmatched open quote in list",

253 TCL_STATIC);

254 return TCL_ERROR;

255 }

256 size = p - list;

257 goto done;

258

259 }

260 p++;

261 }

262

263 done:

     while (isascii(*p) && isspace(*p)) {

265 p++;

266 }

267 *elementPtr = list;

268 *nextPtr = p;

     if (sizePtr != 0) {

270 *sizePtr = size;

271 }

272 return TCL_OK;

273 }

274 \f

275 /*

276 *----------------------------------------------------------------------

277 *

278 * TclCopyAndCollapse --

279 *

280 * Copy a string and eliminate any backslashes that aren't in braces.

281 *

282 * Results:

283 * There is no return value. Count chars. get copied from src

284 * to dst. Along the way, if backslash sequences are found outside

285 * braces, the backslashes are eliminated in the copy.

286 * After scanning count chars. from source, a null character is

287 * placed at the end of dst.

288 *

289 * Side effects:

290 * None.

291 *

292 *----------------------------------------------------------------------

293 */

294

295 void

 TclCopyAndCollapse(count, src, dst)

297 int count; /* Total number of characters to copy

298 * from src. */

     register char *src;         /* Copy from here... */

     register char *dst;         /* ... to here. */

301 {

302 register char c;

303 int numRead;

304

     for (c = *src; count > 0; src++, c = *src, count--) {

         if (c == '\\') {

             *dst = Tcl_Backslash(src, &numRead);

             if (*dst != 0) {

309 dst++;

310 }

311 src += numRead-1;

312 count -= numRead-1;

313 } else {

314 *dst = c;

315 dst++;

316 }

317 }

318 *dst = 0;

319 }

320 \f

321 /*

322 *----------------------------------------------------------------------

323 *

324 * Tcl_SplitList --

325 *

326 * Splits a list up into its constituent fields.

327 *

328 * Results

329 * The return value is normally TCL_OK, which means that

330 * the list was successfully split up. If TCL_ERROR is

331 * returned, it means that "list" didn't have proper list

332 * structure; interp->result will contain a more detailed

333 * error message.

334 *

335 * *argvPtr will be filled in with the address of an array

336 * whose elements point to the elements of list, in order.

337 * *argcPtr will get filled in with the number of valid elements

338 * in the array. A single block of memory is dynamically allocated

339 * to hold both the argv array and a copy of the list (with

340 * backslashes and braces removed in the standard way).

341 * The caller must eventually free this memory by calling free()

342 * on *argvPtr. Note: *argvPtr and *argcPtr are only modified

343 * if the procedure returns normally.

344 *

345 * Side effects:

346 * Memory is allocated.

347 *

348 *----------------------------------------------------------------------

349 */

350

351 int

 Tcl_SplitList(interp, list, argcPtr, argvPtr)

353 Tcl_Interp *interp; /* Interpreter to use for error reporting. */

354 char *list; /* Pointer to string with list structure. */

355 int *argcPtr; /* Pointer to location to fill in with

356 * the number of elements in the list. */

357 char ***argvPtr; /* Pointer to place to store pointer to array

358 * of pointers to list elements. */

359 {

360 char **argv;

361 register char *p;

     int size, i, result, elSize, brace;

363 char *element;

364

365 /*

366 * Figure out how much space to allocate. There must be enough

367 * space for both the array of pointers and also for a copy of

368 * the list. To estimate the number of pointers needed, count

369 * the number of space characters in the list.

370 */

371

     for (size = 1, p = list; *p != 0; p++) {

         if (isspace(*p)) {

374 size++;

375 }

376 }

377 size++; /* Leave space for final NULL pointer. */

     argv = (char **) ckalloc((unsigned)

             ((size * sizeof(char *)) + (p - list) + 1));

     for (i = 0, p = ((char *) argv) + size*sizeof(char *);

             *list != 0; i++) {

         result = TclFindElement(interp, list, &element, &list, &elSize, &brace);

383 if (result != TCL_OK) {

             ckfree((char *) argv);

385 return result;

386 }

         if (*element == 0) {

388 break;

389 }

390 if (i >= size) {

             ckfree((char *) argv);

             Tcl_SetResult(interp, "internal error in Tcl_SplitList",

393 TCL_STATIC);

394 return TCL_ERROR;

395 }

396 argv[i] = p;

397 if (brace) {

             strncpy(p, element, elSize);

399 p += elSize;

400 *p = 0;

401 p++;

402 } else {

             TclCopyAndCollapse(elSize, element, p);

404 p += elSize+1;

405 }

406 }

407

408 argv[i] = NULL;

409 *argvPtr = argv;

410 *argcPtr = i;

411 return TCL_OK;

412 }

413 \f

414 /*

415 *----------------------------------------------------------------------

416 *

417 * Tcl_ScanElement --

418 *

419 * This procedure is a companion procedure to Tcl_ConvertElement.

420 * It scans a string to see what needs to be done to it (e.g.

421 * add backslashes or enclosing braces) to make the string into

422 * a valid Tcl list element.

423 *

424 * Results:

425 * The return value is an overestimate of the number of characters

426 * that will be needed by Tcl_ConvertElement to produce a valid

427 * list element from string. The word at *flagPtr is filled in

428 * with a value needed by Tcl_ConvertElement when doing the actual

429 * conversion.

430 *

431 * Side effects:

432 * None.

433 *

434 *----------------------------------------------------------------------

435 */

436

437 int

438 Tcl_ScanElement(string, flagPtr)

439 char *string; /* String to convert to Tcl list element. */

440 int *flagPtr; /* Where to store information to guide

441 * Tcl_ConvertElement. */

442 {

443 int flags, nestingLevel;

444 register char *p;

445

446 /*

447 * This procedure and Tcl_ConvertElement together do two things:

448 *

449 * 1. They produce a proper list, one that will yield back the

450 * argument strings when evaluated or when disassembled with

451 * Tcl_SplitList. This is the most important thing.

452 *

453 * 2. They try to produce legible output, which means minimizing the

454 * use of backslashes (using braces instead). However, there are

455 * some situations where backslashes must be used (e.g. an element

456 * like "{abc": the leading brace will have to be backslashed. For

457 * each element, one of three things must be done:

458 *

459 * (a) Use the element as-is (it doesn't contain anything special

460 * characters). This is the most desirable option.

461 *

462 * (b) Enclose the element in braces, but leave the contents alone.

463 * This happens if the element contains embedded space, or if it

464 * contains characters with special interpretation ($, [, ;, or \),

465 * or if it starts with a brace or double-quote, or if there are

466 * no characters in the element.

467 *

468 * (c) Don't enclose the element in braces, but add backslashes to

469 * prevent special interpretation of special characters. This is a

470 * last resort used when the argument would normally fall under case

471 * (b) but contains unmatched braces. It also occurs if the last

472 * character of the argument is a backslash.

473 *

474 * The procedure figures out how many bytes will be needed to store

475 * the result (actually, it overestimates). It also collects information

476 * about the element in the form of a flags word.

477 */

478

479 nestingLevel = 0;

480 flags = 0;

481 p = string;

     if ((*p == '{') || (*p == '"') || (*p == 0)) {

483 flags |= USE_BRACES;

484 }

     for ( ; *p != 0; p++) {

486 switch (*p) {

487 case '{':

488 nestingLevel++;

489 break;

490 case '}':

491 nestingLevel--;

                 if (nestingLevel < 0) {

493 flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED;

494 }

495 break;

496 case '[':

497 case '$':

498 case ';':

499 case ' ':

             case '\f':

             case '\n':

             case '\r':

             case '\t':

             case '\v':

505 flags |= USE_BRACES;

506 break;

             case '\\':

                 if (p[1] == 0) {

509 flags = TCL_DONT_USE_BRACES;

510 } else {

511 int size;

512

                     (void) Tcl_Backslash(p, &size);

514 p += size-1;

515 flags |= USE_BRACES;

516 }

517 break;

518 }

519 }

     if (nestingLevel != 0) {

521 flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED;

522 }

523 *flagPtr = flags;

524

525 /*

526 * Allow enough space to backslash every character plus leave

527 * two spaces for braces.

528 */

529

     return 2*(p-string) + 2;

531 }

532 \f

533 /*

534 *----------------------------------------------------------------------

535 *

536 * Tcl_ConvertElement --

537 *

538 * This is a companion procedure to Tcl_ScanElement. Given the

539 * information produced by Tcl_ScanElement, this procedure converts

540 * a string to a list element equal to that string.

541 *

542 * Results:

543 * Information is copied to *dst in the form of a list element

544 * identical to src (i.e. if Tcl_SplitList is applied to dst it

545 * will produce a string identical to src). The return value is

546 * a count of the number of characters copied (not including the

547 * terminating NULL character).

548 *

549 * Side effects:

550 * None.

551 *

552 *----------------------------------------------------------------------

553 */

554

555 int

 Tcl_ConvertElement(src, dst, flags)

     register char *src;         /* Source information for list element. */

558 char *dst; /* Place to put list-ified element. */

559 int flags; /* Flags produced by Tcl_ScanElement. */

560 {

     register char *p = dst;

562

563 /*

564 * See the comment block at the beginning of the Tcl_ScanElement

565 * code for details of how this works.

566 */

567

     if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) {

569 *p = '{';

570 p++;

         for ( ; *src != 0; src++, p++) {

572 *p = *src;

573 }

574 *p = '}';

575 p++;

     } else if (*src == 0) {

577 /*

578 * If string is empty but can't use braces, then use special

579 * backslash sequence that maps to empty string.

580 */

581

         p[0] = '\\';

         p[1] = '0';

584 p += 2;

585 } else {

         for (; *src != 0 ; src++) {

587 switch (*src) {

588 case ']':

589 case '[':

590 case '$':

591 case ';':

592 case ' ':

                 case '\\':

594 case '"':

                     *p = '\\';

596 p++;

597 break;

598 case '{':

599 case '}':

600 if (flags & BRACES_UNMATCHED) {

                         *p = '\\';

602 p++;

603 }

604 break;

                 case '\f':

                     *p = '\\';

607 p++;

608 *p = 'f';

609 p++;

610 continue;

                 case '\n':

                     *p = '\\';

613 p++;

614 *p = 'n';

615 p++;

616 continue;

                 case '\r':

                     *p = '\\';

619 p++;

620 *p = 'r';

621 p++;

622 continue;

                 case '\t':

                     *p = '\\';

625 p++;

626 *p = 't';

627 p++;

628 continue;

                 case '\v':

                     *p = '\\';

631 p++;

632 *p = 'v';

633 p++;

634 continue;

635 }

636 *p = *src;

637 p++;

638 }

639 }

640 *p = '\0';

641 return p-dst;

642 }

643 \f

644 /*

645 *----------------------------------------------------------------------

646 *

647 * Tcl_Merge --

648 *

649 * Given a collection of strings, merge them together into a

650 * single string that has proper Tcl list structured (i.e.

651 * Tcl_SplitList may be used to retrieve strings equal to the

652 * original elements, and Tcl_Eval will parse the string back

653 * into its original elements).

654 *

655 * Results:

656 * The return value is the address of a dynamically-allocated

657 * string containing the merged list.

658 *

659 * Side effects:

660 * None.

661 *

662 *----------------------------------------------------------------------

663 */

664

665 char *

666 Tcl_Merge(argc, argv)

667 int argc; /* How many strings to merge. */

668 char **argv; /* Array of string values. */

669 {

670 # define LOCAL_SIZE 20

671 int localFlags[LOCAL_SIZE], *flagPtr;

672 int numChars;

673 char *result;

674 register char *dst;

675 int i;

676

677 /*

678 * Pass 1: estimate space, gather flags.

679 */

680

681 if (argc <= LOCAL_SIZE) {

682 flagPtr = localFlags;

683 } else {

         flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int));

685 }

686 numChars = 1;

     for (i = 0; i < argc; i++) {

         numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1;

689 }

690

691 /*

692 * Pass two: copy into the result area.

693 */

694

     result = (char *) ckalloc((unsigned) numChars);

696 dst = result;

     for (i = 0; i < argc; i++) {

         numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]);

699 dst += numChars;

700 *dst = ' ';

701 dst++;

702 }

703 if (dst == result) {

704 *dst = 0;

705 } else {

         dst[-1] = 0;

707 }

708

709 if (flagPtr != localFlags) {

         ckfree((char *) flagPtr);

711 }

712 return result;

713 }

714 \f

715 /*

716 *----------------------------------------------------------------------

717 *

718 * Tcl_Concat --

719 *

720 * Concatenate a set of strings into a single large string.

721 *

722 * Results:

723 * The return value is dynamically-allocated string containing

724 * a concatenation of all the strings in argv, with spaces between

725 * the original argv elements.

726 *

727 * Side effects:

728 * Memory is allocated for the result; the caller is responsible

729 * for freeing the memory.

730 *

731 *----------------------------------------------------------------------

732 */

733

734 char *

735 Tcl_Concat(argc, argv)

736 int argc; /* Number of strings to concatenate. */

737 char **argv; /* Array of strings to concatenate. */

738 {

739 int totalSize, i;

740 register char *p;

741 char *result;

742

     for (totalSize = 1, i = 0; i < argc; i++) {

         totalSize += strlen(argv[i]) + 1;

745 }

     result = (char *) ckalloc((unsigned) totalSize);

     if (argc == 0) {

748 *result = '\0';

749 return result;

750 }

     for (p = result, i = 0; i < argc; i++) {

752 char *element;

753 int length;

754

755 /*

756 * Clip white space off the front and back of the string

757 * to generate a neater result, and ignore any empty

758 * elements.

759 */

760

761 element = argv[i];

         while (isspace(*element)) {

763 element++;

764 }

         for (length = strlen(element);

                 (length > 0) && (isspace(element[length-1]));

767 length--) {

768 /* Null loop body. */

769 }

         if (length == 0) {

771 continue;

772 }

         (void) strncpy(p, element, length);

774 p += length;

775 *p = ' ';

776 p++;

777 }

778 if (p != result) {

         p[-1] = 0;

780 } else {

781 *p = 0;

782 }

783 return result;

784 }

785 \f

786 /*

787 *----------------------------------------------------------------------

788 *

789 * Tcl_StringMatch --

790 *

791 * See if a particular string matches a particular pattern.

792 *

793 * Results:

794 * The return value is 1 if string matches pattern, and

795 * 0 otherwise. The matching operation permits the following

796 * special characters in the pattern: *?\[] (see the manual

797 * entry for details on what these mean).

798 *

799 * Side effects:

800 * None.

801 *

802 *----------------------------------------------------------------------

803 */

804

805 int

806 Tcl_StringMatch(string, pattern)

     register char *string;      /* String. */

     register char *pattern;     /* Pattern, which may contain

809 * special characters. */

810 {

811 char c2;

812

813 while (1) {

814 /* See if we're at the end of both the pattern and the string.

815 * If so, we succeeded. If we're at the end of the pattern

816 * but not at the end of the string, we failed.

817 */

818

         if (*pattern == 0) {

             if (*string == 0) {

821 return 1;

822 } else {

823 return 0;

824 }

825 }

         if ((*string == 0) && (*pattern != '*')) {

827 return 0;

828 }

829

830 /* Check for a "*" as the next pattern character. It matches

831 * any substring. We handle this by calling ourselves

832 * recursively for each postfix of string, until either we

833 * match or we reach the end of the string.

834 */

835

         if (*pattern == '*') {

837 pattern += 1;

             if (*pattern == 0) {

839 return 1;

840 }

841 while (1) {

                 if (Tcl_StringMatch(string, pattern)) {

843 return 1;

844 }

                 if (*string == 0) {

846 return 0;

847 }

848 string += 1;

849 }

850 }

851

852 /* Check for a "?" as the next pattern character. It matches

853 * any single character.

854 */

855

         if (*pattern == '?') {

857 goto thisCharOK;

858 }

859

860 /* Check for a "[" as the next pattern character. It is followed

861 * by a list of characters that are acceptable, or by a range

862 * (two characters separated by "-").

863 */

864

         if (*pattern == '[') {

866 pattern += 1;

867 while (1) {

                 if ((*pattern == ']') || (*pattern == 0)) {

869 return 0;

870 }

871 if (*pattern == *string) {

872 break;

873 }

                 if (pattern[1] == '-') {

875 c2 = pattern[2];

                     if (c2 == 0) {

877 return 0;

878 }

                     if ((*pattern <= *string) && (c2 >= *string)) {

880 break;

881 }

                     if ((*pattern >= *string) && (c2 <= *string)) {

883 break;

884 }

885 pattern += 2;

886 }

887 pattern += 1;

888 }

             while ((*pattern != ']') && (*pattern != 0)) {

890 pattern += 1;

891 }

892 goto thisCharOK;

893 }

894

895 /* If the next pattern character is '/', just strip off the '/'

896 * so we do exact matching on the character that follows.

897 */

898

         if (*pattern == '\\') {

900 pattern += 1;

             if (*pattern == 0) {

902 return 0;

903 }

904 }

905

906 /* There's no special character. Just make sure that the next

907 * characters of each string match.

908 */

909

910 if (*pattern != *string) {

911 return 0;

912 }

913

914 thisCharOK: pattern += 1;

915 string += 1;

916 }

917 }

918 \f

919 /*

920 *----------------------------------------------------------------------

921 *

922 * Tcl_SetResult --

923 *

924 * Arrange for "string" to be the Tcl return value.

925 *

926 * Results:

927 * None.

928 *

929 * Side effects:

930 * interp->result is left pointing either to "string" (if "copy" is 0)

931 * or to a copy of string.

932 *

933 *----------------------------------------------------------------------

934 */

935

936 void

 Tcl_SetResult(interp, string, freeProc)

938 Tcl_Interp *interp; /* Interpreter with which to associate the

939 * return value. */

940 char *string; /* Value to be returned. If NULL,

941 * the result is set to an empty string. */

942 Tcl_FreeProc *freeProc; /* Gives information about the string:

943 * TCL_STATIC, TCL_VOLATILE, or the address

944 * of a Tcl_FreeProc such as free. */

945 {

     register Interp *iPtr = (Interp *) interp;

947 int length;

948 Tcl_FreeProc *oldFreeProc = iPtr->freeProc;

     char *oldResult = iPtr->result;

950

951 iPtr->freeProc = freeProc;

952 if (string == NULL) {

         iPtr->resultSpace[0] = 0;

954 iPtr->result = iPtr->resultSpace;

955 iPtr->freeProc = 0;

     } else if (freeProc == TCL_VOLATILE) {

957 length = strlen(string);

958 if (length > TCL_RESULT_SIZE) {

             iPtr->result = (char *) ckalloc((unsigned) length+1);

960 iPtr->freeProc = (Tcl_FreeProc *) free;

961 } else {

962 iPtr->result = iPtr->resultSpace;

963 iPtr->freeProc = 0;

964 }

         strcpy(iPtr->result, string);

966 } else {

967 iPtr->result = string;

968 }

969

970 /*

971 * If the old result was dynamically-allocated, free it up. Do it

972 * here, rather than at the beginning, in case the new result value

973 * was part of the old result value.

974 */

975

     if (oldFreeProc != 0) {

977 (*oldFreeProc)(oldResult);

978 }

979 }

980 \f

981 /*

982 *----------------------------------------------------------------------

983 *

984 * Tcl_AppendResult --

985 *

986 * Append a variable number of strings onto the result already

987 * present for an interpreter.

988 *

989 * Results:

990 * None.

991 *

992 * Side effects:

993 * The result in the interpreter given by the first argument

994 * is extended by the strings given by the second and following

995 * arguments (up to a terminating NULL argument).

996 *

997 *----------------------------------------------------------------------

998 */

999

1000 void

1001 Tcl_AppendResult(Tcl_Interp *interp, ...)

1002 {

1003 va_list argList;

1004 register Interp *iPtr;

1005 char *string;

1006 int newSpace;

1007

1008 /*

1009 * First, scan through all the arguments to see how much space is

1010 * needed.

1011 */

1012

1013 va_start(argList, interp);

1014 iPtr = (Interp *)interp;

1015 newSpace = 0;

1016 while (1) {

         string = va_arg(argList, char *);

1018 if (string == NULL) {

1019 break;

1020 }

1021 newSpace += strlen(string);

1022 }

1023 va_end(argList);

1024

1025 /*

1026 * If the append buffer isn't already setup and large enough

1027 * to hold the new data, set it up.

1028 */

1029

     if ((iPtr->result != iPtr->appendResult)

            || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {

1032 SetupAppendBuffer(iPtr, newSpace);

1033 }

1034

1035 /*

1036 * Final step: go through all the argument strings again, copying

1037 * them into the buffer.

1038 */

1039

1040 va_start(argList, interp);

1041 while (1) {

         string = va_arg(argList, char *);

1043 if (string == NULL) {

1044 break;

1045 }

         strcpy(iPtr->appendResult + iPtr->appendUsed, string);

         iPtr->appendUsed += strlen(string);

1048 }

1049 va_end(argList);

1050 }

1051 \f

1052 /*

1053 *----------------------------------------------------------------------

1054 *

1055 * Tcl_AppendElement --

1056 *

1057 * Convert a string to a valid Tcl list element and append it

1058 * to the current result (which is ostensibly a list).

1059 *

1060 * Results:

1061 * None.

1062 *

1063 * Side effects:

1064 * The result in the interpreter given by the first argument

1065 * is extended with a list element converted from string. If

1066 * the original result wasn't empty, then a blank is added before

1067 * the converted list element.

1068 *

1069 *----------------------------------------------------------------------

1070 */

1071

1072 void

 Tcl_AppendElement(interp, string, noSep)

1074 Tcl_Interp *interp; /* Interpreter whose result is to be

1075 * extended. */

1076 char *string; /* String to convert to list element and

1077 * add to result. */

1078 int noSep; /* If non-zero, then don't output a

1079 * space character before this element,

1080 * even if the element isn't the first

1081 * thing in the output buffer. */

1082 {

     register Interp *iPtr = (Interp *) interp;

1084 int size, flags;

1085 char *dst;

1086

1087 /*

1088 * See how much space is needed, and grow the append buffer if

1089 * needed to accommodate the list element.

1090 */

1091

     size = Tcl_ScanElement(string, &flags) + 1;

     if ((iPtr->result != iPtr->appendResult)

            || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {

        SetupAppendBuffer(iPtr, size+iPtr->appendUsed);

1096 }

1097

1098 /*

1099 * Convert the string into a list element and copy it to the

1100 * buffer that's forming.

1101 */

1102

     dst = iPtr->appendResult + iPtr->appendUsed;

     if (!noSep && (iPtr->appendUsed != 0)) {

1105 iPtr->appendUsed++;

1106 *dst = ' ';

1107 dst++;

1108 }

     iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);

1110 }

1111 \f

1112 /*

1113 *----------------------------------------------------------------------

1114 *

1115 * SetupAppendBuffer --

1116 *

1117 * This procedure makes sure that there is an append buffer

1118 * properly initialized for interp, and that it has at least

1119 * enough room to accommodate newSpace new bytes of information.

1120 *

1121 * Results:

1122 * None.

1123 *

1124 * Side effects:

1125 * None.

1126 *

1127 *----------------------------------------------------------------------

1128 */

1129

1130 static void

1131 SetupAppendBuffer(iPtr, newSpace)

1132 register Interp *iPtr; /* Interpreter whose result is being set up. */

1133 int newSpace; /* Make sure that at least this many bytes

1134 * of new information may be added. */

1135 {

1136 int totalSpace;

1137

1138 /*

1139 * Make the append buffer larger, if that's necessary, then

1140 * copy the current result into the append buffer and make the

1141 * append buffer the official Tcl result.

1142 */

1143

     if (iPtr->result != iPtr->appendResult) {

1145 /*

1146 * If an oversized buffer was used recently, then free it up

1147 * so we go back to a smaller buffer. This avoids tying up

1148 * memory forever after a large operation.

1149 */

1150

         if (iPtr->appendAvl > 500) {

1152 ckfree(iPtr->appendResult);

1153 iPtr->appendResult = NULL;

1154 iPtr->appendAvl = 0;

1155 }

         iPtr->appendUsed = strlen(iPtr->result);

1157 }

1158 totalSpace = newSpace + iPtr->appendUsed;

     if (totalSpace >= iPtr->appendAvl) {

1160 char *new;

1161

         if (totalSpace < 100) {

1163 totalSpace = 200;

1164 } else {

1165 totalSpace *= 2;

1166 }

         new = (char *) ckalloc((unsigned) totalSpace);

         strcpy(new, iPtr->result);

         if (iPtr->appendResult != NULL) {

1170 ckfree(iPtr->appendResult);

1171 }

1172 iPtr->appendResult = new;

1173 iPtr->appendAvl = totalSpace;

     } else if (iPtr->result != iPtr->appendResult) {

         strcpy(iPtr->appendResult, iPtr->result);

1176 }

1177 Tcl_FreeResult(iPtr);

1178 iPtr->result = iPtr->appendResult;

1179 }

1180 \f

1181 /*

1182 *----------------------------------------------------------------------

1183 *

1184 * Tcl_ResetResult --

1185 *

1186 * This procedure restores the result area for an interpreter

1187 * to its default initialized state, freeing up any memory that

1188 * may have been allocated for the result and clearing any

1189 * error information for the interpreter.

1190 *

1191 * Results:

1192 * None.

1193 *

1194 * Side effects:

1195 * None.

1196 *

1197 *----------------------------------------------------------------------

1198 */

1199

1200 void

1201 Tcl_ResetResult(interp)

1202 Tcl_Interp *interp; /* Interpreter for which to clear result. */

1203 {

     register Interp *iPtr = (Interp *) interp;

1205

1206 Tcl_FreeResult(iPtr);

1207 iPtr->result = iPtr->resultSpace;

     iPtr->resultSpace[0] = 0;

1209 iPtr->flags &=

1210 ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);

1211 }

1212 \f

1213 /*

1214 *----------------------------------------------------------------------

1215 *

1216 * Tcl_SetErrorCode --

1217 *

1218 * This procedure is called to record machine-readable information

1219 * about an error that is about to be returned.

1220 *

1221 * Results:

1222 * None.

1223 *

1224 * Side effects:

1225 * The errorCode global variable is modified to hold all of the

1226 * arguments to this procedure, in a list form with each argument

1227 * becoming one element of the list. A flag is set internally

1228 * to remember that errorCode has been set, so the variable doesn't

1229 * get set automatically when the error is returned.

1230 *

1231 *----------------------------------------------------------------------

1232 */

1233 void

1234 Tcl_SetErrorCode(Tcl_Interp *interp, ...)

1235 {

1236 va_list argList;

1237 char *string;

1238 int flags;

1239 Interp *iPtr;

1240

1241 /*

1242 * Scan through the arguments one at a time, appending them to

1243 * $errorCode as list elements.

1244 */

1245

1246 va_start(argList, interp);

1247 iPtr = (Interp *)interp;

1248 flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;

1249 while (1) {

         string = va_arg(argList, char *);

1251 if (string == NULL) {

1252 break;

1253 }

         (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",

                 (char *) NULL, string, flags);

1256 flags |= TCL_APPEND_VALUE;

1257 }

1258 va_end(argList);

1259 iPtr->flags |= ERROR_CODE_SET;

1260 }

1261 \f

1262 /*

1263 *----------------------------------------------------------------------

1264 *

1265 * TclGetListIndex --

1266 *

1267 * Parse a list index, which may be either an integer or the

1268 * value "end".

1269 *

1270 * Results:

1271 * The return value is either TCL_OK or TCL_ERROR. If it is

1272 * TCL_OK, then the index corresponding to string is left in

1273 * *indexPtr. If the return value is TCL_ERROR, then string

1274 * was bogus; an error message is returned in interp->result.

1275 * If a negative index is specified, it is rounded up to 0.

1276 * The index value may be larger than the size of the list

1277 * (this happens when "end" is specified).

1278 *

1279 * Side effects:

1280 * None.

1281 *

1282 *----------------------------------------------------------------------

1283 */

1284

1285 int

 TclGetListIndex(interp, string, indexPtr)

1287 Tcl_Interp *interp; /* Interpreter for error reporting. */

1288 char *string; /* String containing list index. */

1289 int *indexPtr; /* Where to store index. */

1290 {

     if (isdigit(*string) || (*string == '-')) {

         if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) {

1293 return TCL_ERROR;

1294 }

         if (*indexPtr < 0) {

1296 *indexPtr = 0;

1297 }

     } else if (strncmp(string, "end", strlen(string)) == 0) {

         *indexPtr = 1<<30;

1300 } else {

         Tcl_AppendResult(interp, "bad index \"", string,

                 "\": must be integer or \"end\"", (char *) NULL);

1303 return TCL_ERROR;

1304 }

1305 return TCL_OK;

1306 }

1307 \f

1308 /*

1309 *----------------------------------------------------------------------

1310 *

1311 * TclCompileRegexp --

1312 *

1313 * Compile a regular expression into a form suitable for fast

1314 * matching. This procedure retains a small cache of pre-compiled

1315 * regular expressions in the interpreter, in order to avoid

1316 * compilation costs as much as possible.

1317 *

1318 * Results:

1319 * The return value is a pointer to the compiled form of string,

1320 * suitable for passing to regexec. If an error occurred while

1321 * compiling the pattern, then NULL is returned and an error

1322 * message is left in interp->result.

1323 *

1324 * Side effects:

1325 * The cache of compiled regexp's in interp will be modified to

1326 * hold information for string, if such information isn't already

1327 * present in the cache.

1328 *

1329 *----------------------------------------------------------------------

1330 */

1331

1332 regexp *

1333 TclCompileRegexp(interp, string)

1334 Tcl_Interp *interp; /* For use in error reporting. */

1335 char *string; /* String for which to produce

1336 * compiled regular expression. */

1337 {

     register Interp *iPtr = (Interp *) interp;

1339 int i, length;

1340 regexp *result;

1341

1342 length = strlen(string);

     for (i = 0; i < NUM_REGEXPS; i++) {

         if ((length == iPtr->patLengths[i])

                 && (strcmp(string, iPtr->patterns[i]) == 0)) {

1346 /*

1347 * Move the matched pattern to the first slot in the

1348 * cache and shift the other patterns down one position.

1349 */

1350

             if (i != 0) {

1352 int j;

1353 char *cachedString;

1354

1355 cachedString = iPtr->patterns[i];

1356 result = iPtr->regexps[i];

                 for (j = i-1; j >= 0; j--) {

                     iPtr->patterns[j+1] = iPtr->patterns[j];

                     iPtr->patLengths[j+1] = iPtr->patLengths[j];

                     iPtr->regexps[j+1] = iPtr->regexps[j];

1361 }

                 iPtr->patterns[0] = cachedString;

                 iPtr->patLengths[0] = length;

                 iPtr->regexps[0] = result;

1365 }

             return iPtr->regexps[0];

1367 }

1368 }

1369

1370 /*

1371 * No match in the cache. Compile the string and add it to the

1372 * cache.

1373 */

1374

1375 tclRegexpError = NULL;

1376 result = regcomp(string);

1377 if (tclRegexpError != NULL) {

1378 Tcl_AppendResult(interp,

1379 "couldn't compile regular expression pattern: ",

1380 tclRegexpError, (char *) NULL);

1381 return NULL;

1382 }

     if (iPtr->patterns[NUM_REGEXPS-1] != NULL) {

         ckfree(iPtr->patterns[NUM_REGEXPS-1]);

         ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]);

1386 }

     for (i = NUM_REGEXPS - 2; i >= 0; i--) {

         iPtr->patterns[i+1] = iPtr->patterns[i];

         iPtr->patLengths[i+1] = iPtr->patLengths[i];

         iPtr->regexps[i+1] = iPtr->regexps[i];

1391 }

     iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1));

     strcpy(iPtr->patterns[0], string);

     iPtr->patLengths[0] = length;

     iPtr->regexps[0] = result;

1396 return result;

1397 }

1398 \f

1399 /*

1400 *----------------------------------------------------------------------

1401 *

1402 * regerror --

1403 *

1404 * This procedure is invoked by the Henry Spencer's regexp code

1405 * when an error occurs. It saves the error message so it can

1406 * be seen by the code that called Spencer's code.

1407 *

1408 * Results:

1409 * None.

1410 *

1411 * Side effects:

1412 * The value of "string" is saved in "tclRegexpError".

1413 *

1414 *----------------------------------------------------------------------

1415 */

1416

1417 void

1418 regerror(string)

1419 char *string; /* Error message. */

1420 {

1421 tclRegexpError = string;

1422 }