git.zerfleddert.de Git - micropolis/blob

1 /*

2 * tclCmdMZ.c --

3 *

4 * This file contains the top-level command routines for most of

5 * the Tcl built-in commands whose names begin with the letters

6 * M to Z. It contains only commands in the generic core (i.e.

7 * those that don't depend much upon UNIX facilities).

8 *

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

11 * software and its documentation for any purpose and without

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

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

14 * makes no representations about the suitability of this

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

16 * express or implied warranty.

17 */

19 #ifndef lint

20 static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdMZ.c,v 1.13 92/04/23 11:07:54 ouster Exp $ SPRITE (Berkeley)";

21 #endif

23 #include "tclint.h"

25 /*

26 * Structure used to hold information about variable traces:

27 */

29 typedef struct {

30 int flags; /* Operations for which Tcl command is

31 * to be invoked. */

32 int length; /* Number of non-NULL chars. in command. */

     char command[4];            /* Space for Tcl command to invoke.  Actual

34 * size will be as large as necessary to

35 * hold command. This field must be the

36 * last in the structure, so that it can

37 * be larger than 4 bytes. */

38 } TraceVarInfo;

40 /*

41 * Forward declarations for procedures defined in this file:

42 */

 static char *           TraceVarProc _ANSI_ARGS_((ClientData clientData,

                             Tcl_Interp *interp, char *name1, char *name2,

46 int flags));

47 \f

48 /*

49 *----------------------------------------------------------------------

50 *

51 * Tcl_RegexpCmd --

52 *

53 * This procedure is invoked to process the "regexp" Tcl command.

54 * See the user documentation for details on what it does.

55 *

56 * Results:

57 * A standard Tcl result.

58 *

59 * Side effects:

60 * See the user documentation.

61 *

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

63 */

65 /* ARGSUSED */

66 int

 Tcl_RegexpCmd(dummy, interp, argc, argv)

68 ClientData dummy; /* Not used. */

69 Tcl_Interp *interp; /* Current interpreter. */

70 int argc; /* Number of arguments. */

71 char **argv; /* Argument strings. */

72 {

73 int noCase = 0;

74 int indices = 0;

75 regexp *regexpPtr;

76 char **argPtr, *string;

77 int match, i;

     if (argc < 3) {

80 wrongNumArgs:

         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

82 " ?-nocase? exp string ?matchVar? ?subMatchVar ",

                 "subMatchVar ...?\"", (char *) NULL);

84 return TCL_ERROR;

85 }

86 argPtr = argv+1;

87 argc--;

     while ((argc > 0) && (argPtr[0][0] == '-')) {

         if (strcmp(argPtr[0], "-indices") == 0) {

90 argPtr++;

91 argc--;

92 indices = 1;

         } else if (strcmp(argPtr[0], "-nocase") == 0) {

94 argPtr++;

95 argc--;

96 noCase = 1;

97 } else {

98 break;

99 }

100 }

     if (argc < 2) {

102 goto wrongNumArgs;

103 }

     regexpPtr = TclCompileRegexp(interp, argPtr[0]);

105 if (regexpPtr == NULL) {

106 return TCL_ERROR;

107 }

108

109 /*

110 * Convert the string to lower case, if desired, and perform

111 * the match.

112 */

113

114 if (noCase) {

         register char *dst, *src;

116

         string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));

         for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {

             if (isupper(*src)) {

                 *dst = tolower(*src);

121 } else {

122 *dst = *src;

123 }

124 }

125 *dst = 0;

126 } else {

127 string = argPtr[1];

128 }

129 tclRegexpError = NULL;

     match = regexec(regexpPtr, string);

     if (string != argPtr[1]) {

132 ckfree(string);

133 }

134 if (tclRegexpError != NULL) {

         Tcl_AppendResult(interp, "error while matching pattern: ",

136 tclRegexpError, (char *) NULL);

137 return TCL_ERROR;

138 }

139 if (!match) {

140 interp->result = "0";

141 return TCL_OK;

142 }

143

144 /*

145 * If additional variable names have been specified, return

146 * index information in those variables.

147 */

148

149 argc -= 2;

150 if (argc > NSUBEXP) {

151 interp->result = "too many substring variables";

152 return TCL_ERROR;

153 }

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

         char *result, info[50];

156

         if (regexpPtr->startp[i] == NULL) {

158 if (indices) {

                 result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0);

160 } else {

                 result = Tcl_SetVar(interp, argPtr[i+2], "", 0);

162 }

163 } else {

164 if (indices) {

                 sprintf(info, "%d %d", regexpPtr->startp[i] - string,

                         regexpPtr->endp[i] - string - 1);

                 result = Tcl_SetVar(interp, argPtr[i+2], info, 0);

168 } else {

169 char savedChar, *first, *last;

170

                 first = argPtr[1] + (regexpPtr->startp[i] - string);

                 last = argPtr[1] + (regexpPtr->endp[i] - string);

173 savedChar = *last;

174 *last = 0;

                 result = Tcl_SetVar(interp, argPtr[i+2], first, 0);

176 *last = savedChar;

177 }

178 }

179 if (result == NULL) {

             Tcl_AppendResult(interp, "couldn't set variable \"",

                     argPtr[i+2], "\"", (char *) NULL);

182 return TCL_ERROR;

183 }

184 }

185 interp->result = "1";

186 return TCL_OK;

187 }

188 \f

189 /*

190 *----------------------------------------------------------------------

191 *

192 * Tcl_RegsubCmd --

193 *

194 * This procedure is invoked to process the "regsub" Tcl command.

195 * See the user documentation for details on what it does.

196 *

197 * Results:

198 * A standard Tcl result.

199 *

200 * Side effects:

201 * See the user documentation.

202 *

203 *----------------------------------------------------------------------

204 */

205

206 /* ARGSUSED */

207 int

 Tcl_RegsubCmd(dummy, interp, argc, argv)

209 ClientData dummy; /* Not used. */

210 Tcl_Interp *interp; /* Current interpreter. */

211 int argc; /* Number of arguments. */

212 char **argv; /* Argument strings. */

213 {

     int noCase = 0, all = 0;

215 regexp *regexpPtr;

     char *string, *p, *firstChar, *newValue, **argPtr;

217 int match, result, flags;

     register char *src, c;

219

     if (argc < 5) {

221 wrongNumArgs:

         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

                 " ?-nocase? ?-all? exp string subSpec varName\"", (char *) NULL);

224 return TCL_ERROR;

225 }

226 argPtr = argv+1;

227 argc--;

     while (argPtr[0][0] == '-') {

         if (strcmp(argPtr[0], "-nocase") == 0) {

230 argPtr++;

231 argc--;

232 noCase = 1;

         } else if (strcmp(argPtr[0], "-all") == 0) {

234 argPtr++;

235 argc--;

236 all = 1;

237 } else {

238 break;

239 }

240 }

     if (argc != 4) {

242 goto wrongNumArgs;

243 }

     regexpPtr = TclCompileRegexp(interp, argPtr[0]);

245 if (regexpPtr == NULL) {

246 return TCL_ERROR;

247 }

248

249 /*

250 * Convert the string to lower case, if desired.

251 */

252

253 if (noCase) {

254 register char *dst;

255

         string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));

         for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {

             if (isupper(*src)) {

                 *dst = tolower(*src);

260 } else {

261 *dst = *src;

262 }

263 }

264 *dst = 0;

265 } else {

266 string = argPtr[1];

267 }

268

269 /*

270 * The following loop is to handle multiple matches within the

271 * same source string; each iteration handles one match and its

272 * corresponding substitution. If "-all" hasn't been specified

273 * then the loop body only gets executed once.

274 */

275

276 flags = 0;

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

278 tclRegexpError = NULL;

         match = regexec(regexpPtr, p);

280 if (tclRegexpError != NULL) {

             Tcl_AppendResult(interp, "error while matching pattern: ",

282 tclRegexpError, (char *) NULL);

283 result = TCL_ERROR;

284 goto done;

285 }

286 if (!match) {

287 break;

288 }

289

290 /*

291 * Copy the portion of the source string before the match to the

292 * result variable.

293 */

294

         src = argPtr[1] + (regexpPtr->startp[0] - string);

296 c = *src;

297 *src = 0;

         newValue = Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string),

299 flags);

300 *src = c;

301 flags = TCL_APPEND_VALUE;

302 if (newValue == NULL) {

303 cantSet:

             Tcl_AppendResult(interp, "couldn't set variable \"",

                     argPtr[3], "\"", (char *) NULL);

306 result = TCL_ERROR;

307 goto done;

308 }

309

310 /*

311 * Append the subSpec argument to the variable, making appropriate

312 * substitutions. This code is a bit hairy because of the backslash

313 * conventions and because the code saves up ranges of characters in

314 * subSpec to reduce the number of calls to Tcl_SetVar.

315 */

316

         for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) {

318 int index;

319

             if (c == '&') {

321 index = 0;

             } else if (c == '\\') {

323 c = src[1];

                 if ((c >= '0') && (c <= '9')) {

325 index = c - '0';

                 } else if ((c == '\\') || (c == '&')) {

327 *src = c;

                     src[1] = 0;

                     newValue = Tcl_SetVar(interp, argPtr[3], firstChar,

330 TCL_APPEND_VALUE);

                     *src = '\\';

332 src[1] = c;

333 if (newValue == NULL) {

334 goto cantSet;

335 }

336 firstChar = src+2;

337 src++;

338 continue;

339 } else {

340 continue;

341 }

342 } else {

343 continue;

344 }

345 if (firstChar != src) {

346 c = *src;

347 *src = 0;

                 newValue = Tcl_SetVar(interp, argPtr[3], firstChar,

349 TCL_APPEND_VALUE);

350 *src = c;

351 if (newValue == NULL) {

352 goto cantSet;

353 }

354 }

             if ((index < NSUBEXP) && (regexpPtr->startp[index] != NULL)

                     && (regexpPtr->endp[index] != NULL)) {

                 char *first, *last, saved;

358

                 first = argPtr[1] + (regexpPtr->startp[index] - string);

                 last = argPtr[1] + (regexpPtr->endp[index] - string);

361 saved = *last;

362 *last = 0;

                 newValue = Tcl_SetVar(interp, argPtr[3], first,

364 TCL_APPEND_VALUE);

365 *last = saved;

366 if (newValue == NULL) {

367 goto cantSet;

368 }

369 }

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

371 src++;

372 }

373 firstChar = src+1;

374 }

375 if (firstChar != src) {

             if (Tcl_SetVar(interp, argPtr[3], firstChar,

377 TCL_APPEND_VALUE) == NULL) {

378 goto cantSet;

379 }

380 }

         p = regexpPtr->endp[0];

382 if (!all) {

383 break;

384 }

385 }

386

387 /*

388 * If there were no matches at all, then return a "0" result.

389 */

390

391 if (p == string) {

392 interp->result = "0";

393 result = TCL_OK;

394 goto done;

395 }

396

397 /*

398 * Copy the portion of the source string after the last match to the

399 * result variable.

400 */

401

     if (*p != 0) {

         if (Tcl_SetVar(interp, argPtr[3], p, TCL_APPEND_VALUE) == NULL) {

404 goto cantSet;

405 }

406 }

407 interp->result = "1";

408 result = TCL_OK;

409

410 done:

     if (string != argPtr[1]) {

412 ckfree(string);

413 }

414 return result;

415 }

416 \f

417 /*

418 *----------------------------------------------------------------------

419 *

420 * Tcl_RenameCmd --

421 *

422 * This procedure is invoked to process the "rename" Tcl command.

423 * See the user documentation for details on what it does.

424 *

425 * Results:

426 * A standard Tcl result.

427 *

428 * Side effects:

429 * See the user documentation.

430 *

431 *----------------------------------------------------------------------

432 */

433

434 /* ARGSUSED */

435 int

 Tcl_RenameCmd(dummy, interp, argc, argv)

437 ClientData dummy; /* Not used. */

438 Tcl_Interp *interp; /* Current interpreter. */

439 int argc; /* Number of arguments. */

440 char **argv; /* Argument strings. */

441 {

442 register Command *cmdPtr;

443 Interp *iPtr = (Interp *) interp;

444 Tcl_HashEntry *hPtr;

445 int new;

446

     if (argc != 3) {

         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

                 " oldName newName\"", (char *) NULL);

450 return TCL_ERROR;

451 }

     if (argv[2][0] == '\0') {

         if (Tcl_DeleteCommand(interp, argv[1]) != 0) {

             Tcl_AppendResult(interp, "can't delete \"", argv[1],

                     "\": command doesn't exist", (char *) NULL);

456 return TCL_ERROR;

457 }

458 return TCL_OK;

459 }

     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[2]);

461 if (hPtr != NULL) {

         Tcl_AppendResult(interp, "can't rename to \"", argv[2],

                 "\": command already exists", (char *) NULL);

464 return TCL_ERROR;

465 }

     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[1]);

467 if (hPtr == NULL) {

         Tcl_AppendResult(interp, "can't rename \"", argv[1],

                 "\":  command doesn't exist", (char *) NULL);

470 return TCL_ERROR;

471 }

     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);

473 Tcl_DeleteHashEntry(hPtr);

     hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, argv[2], &new);

475 Tcl_SetHashValue(hPtr, cmdPtr);

476 return TCL_OK;

477 }

478 \f

479 /*

480 *----------------------------------------------------------------------

481 *

482 * Tcl_ReturnCmd --

483 *

484 * This procedure is invoked to process the "return" Tcl command.

485 * See the user documentation for details on what it does.

486 *

487 * Results:

488 * A standard Tcl result.

489 *

490 * Side effects:

491 * See the user documentation.

492 *

493 *----------------------------------------------------------------------

494 */

495

496 /* ARGSUSED */

497 int

 Tcl_ReturnCmd(dummy, interp, argc, argv)

499 ClientData dummy; /* Not used. */

500 Tcl_Interp *interp; /* Current interpreter. */

501 int argc; /* Number of arguments. */

502 char **argv; /* Argument strings. */

503 {

     if (argc > 2) {

         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

                 " ?value?\"", (char *) NULL);

507 return TCL_ERROR;

508 }

     if (argc == 2) {

         Tcl_SetResult(interp, argv[1], TCL_VOLATILE);

511 }

512 return TCL_RETURN;

513 }

514 \f

515 /*

516 *----------------------------------------------------------------------

517 *

518 * Tcl_ScanCmd --

519 *

520 * This procedure is invoked to process the "scan" Tcl command.

521 * See the user documentation for details on what it does.

522 *

523 * Results:

524 * A standard Tcl result.

525 *

526 * Side effects:

527 * See the user documentation.

528 *

529 *----------------------------------------------------------------------

530 */

531

532 /* ARGSUSED */

533 int

 Tcl_ScanCmd(dummy, interp, argc, argv)

535 ClientData dummy; /* Not used. */

536 Tcl_Interp *interp; /* Current interpreter. */

537 int argc; /* Number of arguments. */

538 char **argv; /* Argument strings. */

539 {

540 int arg1Length; /* Number of bytes in argument to be

541 * scanned. This gives an upper limit

542 * on string field sizes. */

543 # define MAX_FIELDS 20

544 typedef struct {

545 char fmt; /* Format for field. */

546 int size; /* How many bytes to allow for

547 * field. */

548 char *location; /* Where field will be stored. */

549 } Field;

550 Field fields[MAX_FIELDS]; /* Info about all the fields in the

551 * format string. */

552 register Field *curField;

     int numFields = 0;                  /* Number of fields actually

554 * specified. */

555 int suppress; /* Current field is assignment-

556 * suppressed. */

     int totalSize = 0;                  /* Number of bytes needed to store

558 * all results combined. */

559 char *results; /* Where scanned output goes. */

560 int numScanned; /* sscanf's result. */

561 register char *fmt;

562 int i, widthSpecified;

563

     if (argc < 3) {

         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

                 " string format ?varName varName ...?\"", (char *) NULL);

567 return TCL_ERROR;

568 }

569

570 /*

571 * This procedure operates in four stages:

572 * 1. Scan the format string, collecting information about each field.

573 * 2. Allocate an array to hold all of the scanned fields.

574 * 3. Call sscanf to do all the dirty work, and have it store the

575 * parsed fields in the array.

576 * 4. Pick off the fields from the array and assign them to variables.

577 */

578

     arg1Length = (strlen(argv[1]) + 4) & ~03;

     for (fmt = argv[2]; *fmt != 0; fmt++) {

         if (*fmt != '%') {

582 continue;

583 }

584 fmt++;

         if (*fmt == '*') {

586 suppress = 1;

587 fmt++;

588 } else {

589 suppress = 0;

590 }

591 widthSpecified = 0;

         while (isdigit(*fmt)) {

593 widthSpecified = 1;

594 fmt++;

595 }

596 if (suppress) {

597 continue;

598 }

599 if (numFields == MAX_FIELDS) {

600 interp->result = "too many fields to scan";

601 return TCL_ERROR;

602 }

603 curField = &fields[numFields];

604 numFields++;

605 switch (*fmt) {

606 case 'D':

607 case 'O':

608 case 'X':

609 case 'd':

610 case 'o':

611 case 'x':

612 curField->fmt = 'd';

                 curField->size = sizeof(int);

614 break;

615

616 case 's':

617 curField->fmt = 's';

618 curField->size = arg1Length;

619 break;

620

621 case 'c':

622 if (widthSpecified) {

623 interp->result =

624 "field width may not be specified in %c conversion";

625 return TCL_ERROR;

626 }

627 curField->fmt = 'c';

                 curField->size = sizeof(int);

629 break;

630

631 case 'E':

632 case 'F':

633 curField->fmt = 'F';

                 curField->size = sizeof(double);

635 break;

636

637 case 'e':

638 case 'f':

639 curField->fmt = 'f';

                 curField->size = sizeof(float);

641 break;

642

643 case '[':

644 curField->fmt = 's';

645 curField->size = arg1Length;

646 do {

647 fmt++;

                 } while (*fmt != ']');

649 break;

650

651 default:

                 sprintf(interp->result, "bad scan conversion character \"%c\"",

653 *fmt);

654 return TCL_ERROR;

655 }

656 totalSize += curField->size;

657 }

658

     if (numFields != (argc-3)) {

660 interp->result =

661 "different numbers of variable names and field specifiers";

662 return TCL_ERROR;

663 }

664

665 /*

666 * Step 2:

667 */

668

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

     for (i = 0, totalSize = 0, curField = fields;

671 i < numFields; i++, curField++) {

672 curField->location = results + totalSize;

673 totalSize += curField->size;

674 }

675

676 /*

677 * Step 3:

678 */

679

     numScanned = sscanf(argv[1], argv[2],

             fields[0].location, fields[1].location, fields[2].location,

             fields[3].location, fields[4].location, fields[5].location,

             fields[6].location, fields[7].location, fields[8].location,

             fields[9].location, fields[10].location, fields[11].location,

             fields[12].location, fields[13].location, fields[14].location,

             fields[15].location, fields[16].location, fields[17].location,

             fields[18].location, fields[19].location);

688

689 /*

690 * Step 4:

691 */

692

693 if (numScanned < numFields) {

694 numFields = numScanned;

695 }

     for (i = 0, curField = fields; i < numFields; i++, curField++) {

697 switch (curField->fmt) {

698 char string[120];

699

700 case 'd':

                 sprintf(string, "%d", *((int *) curField->location));

                 if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {

703 storeError:

704 Tcl_AppendResult(interp,

                             "couldn't set variable \"", argv[i+3], "\"",

706 (char *) NULL);

                     ckfree((char *) results);

708 return TCL_ERROR;

709 }

710 break;

711

712 case 'c':

                 sprintf(string, "%d", *((char *) curField->location) & 0xff);

                 if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {

715 goto storeError;

716 }

717 break;

718

719 case 's':

                 if (Tcl_SetVar(interp, argv[i+3], curField->location, 0)

721 == NULL) {

722 goto storeError;

723 }

724 break;

725

726 case 'F':

                 sprintf(string, "%g", *((double *) curField->location));

                 if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {

729 goto storeError;

730 }

731 break;

732

733 case 'f':

                 sprintf(string, "%g", *((float *) curField->location));

                 if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {

736 goto storeError;

737 }

738 break;

739 }

740 }

741 ckfree(results);

     sprintf(interp->result, "%d", numScanned);

743 return TCL_OK;

744 }

745 \f

746 /*

747 *----------------------------------------------------------------------

748 *

749 * Tcl_SplitCmd --

750 *

751 * This procedure is invoked to process the "split" Tcl command.

752 * See the user documentation for details on what it does.

753 *

754 * Results:

755 * A standard Tcl result.

756 *

757 * Side effects:

758 * See the user documentation.

759 *

760 *----------------------------------------------------------------------

761 */

762

763 /* ARGSUSED */

764 int

 Tcl_SplitCmd(dummy, interp, argc, argv)

766 ClientData dummy; /* Not used. */

767 Tcl_Interp *interp; /* Current interpreter. */

768 int argc; /* Number of arguments. */

769 char **argv; /* Argument strings. */

770 {

771 char *splitChars;

     register char *p, *p2;

773 char *elementStart;

774

     if (argc == 2) {

         splitChars = " \n\t\r";

     } else if (argc == 3) {

778 splitChars = argv[2];

779 } else {

         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

                 " string ?splitChars?\"", (char *) NULL);

782 return TCL_ERROR;

783 }

784

785 /*

786 * Handle the special case of splitting on every character.

787 */

788

     if (*splitChars == 0) {

790 char string[2];

         string[1] = 0;

         for (p = argv[1]; *p != 0; p++) {

793 string[0] = *p;

             Tcl_AppendElement(interp, string, 0);

795 }

796 return TCL_OK;

797 }

798

799 /*

800 * Normal case: split on any of a given set of characters.

801 * Discard instances of the split characters.

802 */

803

     for (p = elementStart = argv[1]; *p != 0; p++) {

805 char c = *p;

         for (p2 = splitChars; *p2 != 0; p2++) {

807 if (*p2 == c) {

808 *p = 0;

                 Tcl_AppendElement(interp, elementStart, 0);

810 *p = c;

811 elementStart = p+1;

812 break;

813 }

814 }

815 }

     if (p != argv[1]) {

         Tcl_AppendElement(interp, elementStart, 0);

818 }

819 return TCL_OK;

820 }

821 \f

822 /*

823 *----------------------------------------------------------------------

824 *

825 * Tcl_StringCmd --

826 *

827 * This procedure is invoked to process the "string" Tcl command.

828 * See the user documentation for details on what it does.

829 *

830 * Results:

831 * A standard Tcl result.

832 *

833 * Side effects:

834 * See the user documentation.

835 *

836 *----------------------------------------------------------------------

837 */

838

839 /* ARGSUSED */

840 int

 Tcl_StringCmd(dummy, interp, argc, argv)

842 ClientData dummy; /* Not used. */

843 Tcl_Interp *interp; /* Current interpreter. */

844 int argc; /* Number of arguments. */

845 char **argv; /* Argument strings. */

846 {

847 int length;

     register char *p, c;

849 int match;

850 int first;

     int left = 0, right = 0;

852

     if (argc < 2) {

         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

                 " option arg ?arg ...?\"", (char *) NULL);

856 return TCL_ERROR;

857 }

     c = argv[1][0];

     length = strlen(argv[1]);

     if ((c == 'c') && (strncmp(argv[1], "compare", length) == 0)) {

         if (argc != 4) {

             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

                     " compare string1 string2\"", (char *) NULL);

864 return TCL_ERROR;

865 }

         match = strcmp(argv[2], argv[3]);

         if (match > 0) {

868 interp->result = "1";

         } else if (match < 0) {

870 interp->result = "-1";

871 } else {

872 interp->result = "0";

873 }

874 return TCL_OK;

     } else if ((c == 'f') && (strncmp(argv[1], "first", length) == 0)) {

         if (argc != 4) {

             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

                     " first string1 string2\"", (char *) NULL);

879 return TCL_ERROR;

880 }

881 first = 1;

882

883 firstLast:

884 match = -1;

885 c = *argv[2];

         length = strlen(argv[2]);

         for (p = argv[3]; *p != 0; p++) {

888 if (*p != c) {

889 continue;

890 }

             if (strncmp(argv[2], p, length) == 0) {

                 match = p-argv[3];

893 if (first) {

894 break;

895 }

896 }

897 }

         sprintf(interp->result, "%d", match);

899 return TCL_OK;

     } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0)) {

901 int index;

902

         if (argc != 4) {

             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

                     " index string charIndex\"", (char *) NULL);

906 return TCL_ERROR;

907 }

         if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) {

909 return TCL_ERROR;

910 }

         if ((index >= 0) && (index < strlen(argv[2]))) {

             interp->result[0] = argv[2][index];

             interp->result[1] = 0;

914 }

915 return TCL_OK;

     } else if ((c == 'l') && (strncmp(argv[1], "last", length) == 0)

917 && (length >= 2)) {

         if (argc != 4) {

             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

                     " last string1 string2\"", (char *) NULL);

921 return TCL_ERROR;

922 }

923 first = 0;

924 goto firstLast;

     } else if ((c == 'l') && (strncmp(argv[1], "length", length) == 0)

926 && (length >= 2)) {

         if (argc != 3) {

             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

                     " length string\"", (char *) NULL);

930 return TCL_ERROR;

931 }

         sprintf(interp->result, "%d", strlen(argv[2]));

933 return TCL_OK;

     } else if ((c == 'm') && (strncmp(argv[1], "match", length) == 0)) {

         if (argc != 4) {

             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

                     " match pattern string\"", (char *) NULL);

938 return TCL_ERROR;

939 }

         if (Tcl_StringMatch(argv[3], argv[2]) != 0) {

941 interp->result = "1";

942 } else {

943 interp->result = "0";

944 }

945 return TCL_OK;

     } else if ((c == 'r') && (strncmp(argv[1], "range", length) == 0)) {

947 int first, last, stringLength;

948

         if (argc != 5) {

             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

                     " range string first last\"", (char *) NULL);

952 return TCL_ERROR;

953 }

         stringLength = strlen(argv[2]);

         if (Tcl_GetInt(interp, argv[3], &first) != TCL_OK) {

956 return TCL_ERROR;

957 }

         if ((*argv[4] == 'e')

                 && (strncmp(argv[4], "end", strlen(argv[4])) == 0)) {

960 last = stringLength-1;

961 } else {

             if (Tcl_GetInt(interp, argv[4], &last) != TCL_OK) {

963 Tcl_ResetResult(interp);

964 Tcl_AppendResult(interp,

                         "expected integer or \"end\" but got \"",

                         argv[4], "\"", (char *) NULL);

967 return TCL_ERROR;

968 }

969 }

         if (first < 0) {

971 first = 0;

972 }

973 if (last >= stringLength) {

974 last = stringLength-1;

975 }

976 if (last >= first) {

977 char saved, *p;

978

             p = argv[2] + last + 1;

980 saved = *p;

981 *p = 0;

             Tcl_SetResult(interp, argv[2] + first, TCL_VOLATILE);

983 *p = saved;

984 }

985 return TCL_OK;

     } else if ((c == 't') && (strncmp(argv[1], "tolower", length) == 0)

987 && (length >= 3)) {

988 register char *p;

989

         if (argc != 3) {

             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

                     " tolower string\"", (char *) NULL);

993 return TCL_ERROR;

994 }

         Tcl_SetResult(interp, argv[2], TCL_VOLATILE);

         for (p = interp->result; *p != 0; p++) {

             if (isupper(*p)) {

                 *p = tolower(*p);

999 }

1000 }

1001 return TCL_OK;

     } else if ((c == 't') && (strncmp(argv[1], "toupper", length) == 0)

1003 && (length >= 3)) {

1004 register char *p;

1005

         if (argc != 3) {

             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

                     " toupper string\"", (char *) NULL);

1009 return TCL_ERROR;

1010 }

         Tcl_SetResult(interp, argv[2], TCL_VOLATILE);

         for (p = interp->result; *p != 0; p++) {

             if (islower(*p)) {

                 *p = toupper(*p);

1015 }

1016 }

1017 return TCL_OK;

     } else if ((c == 't') && (strncmp(argv[1], "trim", length) == 0)

1019 && (length == 4)) {

1020 char *trimChars;

         register char *p, *checkPtr;

1022

1023 left = right = 1;

1024

1025 trim:

         if (argc == 4) {

1027 trimChars = argv[3];

         } else if (argc == 3) {

             trimChars = " \t\n\r";

1030 } else {

             Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],

                     " ", argv[1], " string ?chars?\"", (char *) NULL);

1033 return TCL_ERROR;

1034 }

1035 p = argv[2];

1036 if (left) {

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

                 for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {

                     if (*checkPtr == 0) {

1040 goto doneLeft;

1041 }

1042 }

1043 }

1044 }

1045 doneLeft:

         Tcl_SetResult(interp, p, TCL_VOLATILE);

1047 if (right) {

1048 char *donePtr;

1049

             p = interp->result + strlen(interp->result) - 1;

             donePtr = &interp->result[-1];

             for (c = *p; p != donePtr; p--, c = *p) {

                 for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {

                     if (*checkPtr == 0) {

1055 goto doneRight;

1056 }

1057 }

1058 }

1059 doneRight:

             p[1] = 0;

1061 }

1062 return TCL_OK;

     } else if ((c == 't') && (strncmp(argv[1], "trimleft", length) == 0)

1064 && (length > 4)) {

1065 left = 1;

         argv[1] = "trimleft";

1067 goto trim;

     } else if ((c == 't') && (strncmp(argv[1], "trimright", length) == 0)

1069 && (length > 4)) {

1070 right = 1;

         argv[1] = "trimright";

1072 goto trim;

1073 } else {

         Tcl_AppendResult(interp, "bad option \"", argv[1],

1075 "\": should be compare, first, index, last, length, match, ",

1076 "range, tolower, toupper, trim, trimleft, or trimright",

1077 (char *) NULL);

1078 return TCL_ERROR;

1079 }

1080 }

1081 \f

1082 /*

1083 *----------------------------------------------------------------------

1084 *

1085 * Tcl_TraceCmd --

1086 *

1087 * This procedure is invoked to process the "trace" Tcl command.

1088 * See the user documentation for details on what it does.

1089 *

1090 * Results:

1091 * A standard Tcl result.

1092 *

1093 * Side effects:

1094 * See the user documentation.

1095 *

1096 *----------------------------------------------------------------------

1097 */

1098

1099 /* ARGSUSED */

1100 int

 Tcl_TraceCmd(dummy, interp, argc, argv)

1102 ClientData dummy; /* Not used. */

1103 Tcl_Interp *interp; /* Current interpreter. */

1104 int argc; /* Number of arguments. */

1105 char **argv; /* Argument strings. */

1106 {

1107 char c;

1108 int length;

1109

     if (argc < 2) {

         Tcl_AppendResult(interp, "too few args: should be \"",

                 argv[0], " option [arg arg ...]\"", (char *) NULL);

1113 return TCL_ERROR;

1114 }

     c = argv[1][1];

     length = strlen(argv[1]);

     if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0)

1118 && (length >= 2)) {

1119 char *p;

1120 int flags, length;

1121 TraceVarInfo *tvarPtr;

1122

         if (argc != 5) {

             Tcl_AppendResult(interp, "wrong # args: should be \"",

                     argv[0], " variable name ops command\"", (char *) NULL);

1126 return TCL_ERROR;

1127 }

1128

1129 flags = 0;

         for (p = argv[3] ; *p != 0; p++) {

             if (*p == 'r') {

1132 flags |= TCL_TRACE_READS;

             } else if (*p == 'w') {

1134 flags |= TCL_TRACE_WRITES;

             } else if (*p == 'u') {

1136 flags |= TCL_TRACE_UNSETS;

1137 } else {

1138 goto badOps;

1139 }

1140 }

         if (flags == 0) {

1142 goto badOps;

1143 }

1144

         length = strlen(argv[4]);

         tvarPtr = (TraceVarInfo *) ckalloc((unsigned)

                 (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1));

1148 tvarPtr->flags = flags;

1149 tvarPtr->length = length;

1150 flags |= TCL_TRACE_UNSETS;

         strcpy(tvarPtr->command, argv[4]);

         if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc,

1153 (ClientData) tvarPtr) != TCL_OK) {

             ckfree((char *) tvarPtr);

1155 return TCL_ERROR;

1156 }

     } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length)

             && (length >= 2)) == 0) {

1159 char *p;

1160 int flags, length;

1161 TraceVarInfo *tvarPtr;

1162 ClientData clientData;

1163

         if (argc != 5) {

             Tcl_AppendResult(interp, "wrong # args: should be \"",

                     argv[0], " vdelete name ops command\"", (char *) NULL);

1167 return TCL_ERROR;

1168 }

1169

1170 flags = 0;

         for (p = argv[3] ; *p != 0; p++) {

             if (*p == 'r') {

1173 flags |= TCL_TRACE_READS;

             } else if (*p == 'w') {

1175 flags |= TCL_TRACE_WRITES;

             } else if (*p == 'u') {

1177 flags |= TCL_TRACE_UNSETS;

1178 } else {

1179 goto badOps;

1180 }

1181 }

         if (flags == 0) {

1183 goto badOps;

1184 }

1185

1186 /*

1187 * Search through all of our traces on this variable to

1188 * see if there's one with the given command. If so, then

1189 * delete the first one that matches.

1190 */

1191

         length = strlen(argv[4]);

1193 clientData = 0;

         while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,

1195 TraceVarProc, clientData)) != 0) {

1196 tvarPtr = (TraceVarInfo *) clientData;

             if ((tvarPtr->length == length) && (tvarPtr->flags == flags)

                     && (strncmp(argv[4], tvarPtr->command, length) == 0)) {

                 Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS,

1200 TraceVarProc, clientData);

                 ckfree((char *) tvarPtr);

1202 break;

1203 }

1204 }

     } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0)

1206 && (length >= 2)) {

1207 ClientData clientData;

         char ops[4], *p;

         char *prefix = "{";

1210

         if (argc != 3) {

             Tcl_AppendResult(interp, "wrong # args: should be \"",

                     argv[0], " vinfo name\"", (char *) NULL);

1214 return TCL_ERROR;

1215 }

1216 clientData = 0;

         while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,

1218 TraceVarProc, clientData)) != 0) {

1219 TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;

1220 p = ops;

             if (tvarPtr->flags & TCL_TRACE_READS) {

1222 *p = 'r';

1223 p++;

1224 }

             if (tvarPtr->flags & TCL_TRACE_WRITES) {

1226 *p = 'w';

1227 p++;

1228 }

             if (tvarPtr->flags & TCL_TRACE_UNSETS) {

1230 *p = 'u';

1231 p++;

1232 }

1233 *p = '\0';

             Tcl_AppendResult(interp, prefix, (char *) NULL);

             Tcl_AppendElement(interp, ops, 1);

             Tcl_AppendElement(interp, tvarPtr->command, 0);

             Tcl_AppendResult(interp, "}", (char *) NULL);

1238 prefix = " {";

1239 }

1240 } else {

         Tcl_AppendResult(interp, "bad option \"", argv[1],

1242 "\": should be variable, vdelete, or vinfo",

1243 (char *) NULL);

1244 return TCL_ERROR;

1245 }

1246 return TCL_OK;

1247

1248 badOps:

     Tcl_AppendResult(interp, "bad operations \"", argv[3],

             "\": should be one or more of rwu", (char *) NULL);

1251 return TCL_ERROR;

1252 }

1253 \f

1254 /*

1255 *----------------------------------------------------------------------

1256 *

1257 * TraceVarProc --

1258 *

1259 * This procedure is called to handle variable accesses that have

1260 * been traced using the "trace" command.

1261 *

1262 * Results:

1263 * Normally returns NULL. If the trace command returns an error,

1264 * then this procedure returns an error string.

1265 *

1266 * Side effects:

1267 * Depends on the command associated with the trace.

1268 *

1269 *----------------------------------------------------------------------

1270 */

1271

1272 /* ARGSUSED */

1273 static char *

 TraceVarProc(clientData, interp, name1, name2, flags)

1275 ClientData clientData; /* Information about the variable trace. */

1276 Tcl_Interp *interp; /* Interpreter containing variable. */

1277 char *name1; /* Name of variable or array. */

1278 char *name2; /* Name of element within array; NULL means

1279 * scalar variable is being referenced. */

1280 int flags; /* OR-ed bits giving operation and other

1281 * information. */

1282 {

1283 TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;

1284 char *result;

     int code, cmdLength, flags1, flags2;

1286 Interp dummy;

1287 #define STATIC_SIZE 199

     char staticSpace[STATIC_SIZE+1];

1289 char *cmdPtr, *p;

1290

1291 result = NULL;

     if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {

1293

1294 /*

1295 * Generate a command to execute by appending list elements

1296 * for the two variable names and the operation. The five

1297 * extra characters are for three space, the opcode character,

1298 * and the terminating null.

1299 */

1300

1301 if (name2 == NULL) {

1302 name2 = "";

1303 }

         cmdLength = tvarPtr->length + Tcl_ScanElement(name1, &flags1) +

                 Tcl_ScanElement(name2, &flags2) + 5;

1306 if (cmdLength < STATIC_SIZE) {

1307 cmdPtr = staticSpace;

1308 } else {

             cmdPtr = (char *) ckalloc((unsigned) cmdLength);

1310 }

1311 p = cmdPtr;

         strcpy(p, tvarPtr->command);

1313 p += tvarPtr->length;

1314 *p = ' ';

1315 p++;

         p += Tcl_ConvertElement(name1, p, flags1);

1317 *p = ' ';

1318 p++;

         p += Tcl_ConvertElement(name2, p, flags2);

1320 *p = ' ';

1321 if (flags & TCL_TRACE_READS) {

             p[1] = 'r';

         } else if (flags & TCL_TRACE_WRITES) {

             p[1] = 'w';

         } else if (flags & TCL_TRACE_UNSETS) {

             p[1] = 'u';

1327 }

         p[2] = '\0';

1329

1330 /*

1331 * Execute the command. Be careful to save and restore the

1332 * result from the interpreter used for the command.

1333 */

1334

1335 dummy.freeProc = interp->freeProc;

         if (interp->freeProc == 0) {

             Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, TCL_VOLATILE);

1338 } else {

1339 dummy.result = interp->result;

1340 }

         code = Tcl_Eval(interp, cmdPtr, 0, (char **) NULL);

1342 if (cmdPtr != staticSpace) {

1343 ckfree(cmdPtr);

1344 }

1345 if (code != TCL_OK) {

1346 result = "access disallowed by trace command";

1347 Tcl_ResetResult(interp); /* Must clear error state. */

1348 }

1349 Tcl_FreeResult(interp);

1350 interp->result = dummy.result;

1351 interp->freeProc = dummy.freeProc;

1352 }

1353 if (flags & TCL_TRACE_DESTROYED) {

         ckfree((char *) tvarPtr);

1355 }

1356 return result;

1357 }

1358 \f

1359 /*

1360 *----------------------------------------------------------------------

1361 *

1362 * Tcl_WhileCmd --

1363 *

1364 * This procedure is invoked to process the "while" Tcl command.

1365 * See the user documentation for details on what it does.

1366 *

1367 * Results:

1368 * A standard Tcl result.

1369 *

1370 * Side effects:

1371 * See the user documentation.

1372 *

1373 *----------------------------------------------------------------------

1374 */

1375

1376 /* ARGSUSED */

1377 int

 Tcl_WhileCmd(dummy, interp, argc, argv)

1379 ClientData dummy; /* Not used. */

1380 Tcl_Interp *interp; /* Current interpreter. */

1381 int argc; /* Number of arguments. */

1382 char **argv; /* Argument strings. */

1383 {

1384 int result, value;

1385

     if (argc != 3) {

         Tcl_AppendResult(interp, "wrong # args: should be \"",

                 argv[0], " test command\"", (char *) NULL);

1389 return TCL_ERROR;

1390 }

1391

1392 while (1) {

         result = Tcl_ExprBoolean(interp, argv[1], &value);

1394 if (result != TCL_OK) {

1395 return result;

1396 }

1397 if (!value) {

1398 break;

1399 }

         result = Tcl_Eval(interp, argv[2], 0, (char **) NULL);

1401 if (result == TCL_CONTINUE) {

1402 result = TCL_OK;

         } else if (result != TCL_OK) {

1404 if (result == TCL_ERROR) {

1405 char msg[60];

                 sprintf(msg, "\n    (\"while\" body line %d)",

1407 interp->errorLine);

1408 Tcl_AddErrorInfo(interp, msg);

1409 }

1410 break;

1411 }

1412 }

1413 if (result == TCL_BREAK) {

1414 result = TCL_OK;

1415 }

1416 if (result == TCL_OK) {

1417 Tcl_ResetResult(interp);

1418 }

1419 return result;

1420 }