home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume25 / tcl / part28 < prev    next >
Encoding:
Text File  |  1991-11-15  |  38.4 KB  |  1,480 lines

  1. Newsgroups: comp.sources.misc
  2. From: karl@sugar.neosoft.com (Karl Lehenbauer)
  3. Subject:  v25i096:  tcl - tool command language, version 6.1, Part28/33
  4. Message-ID: <1991Nov15.225840.21930@sparky.imd.sterling.com>
  5. X-Md4-Signature: edb34012633cbc906ba12f47383b7290
  6. Date: Fri, 15 Nov 1991 22:58:40 GMT
  7. Approved: kent@sparky.imd.sterling.com
  8.  
  9. Submitted-by: karl@sugar.neosoft.com (Karl Lehenbauer)
  10. Posting-number: Volume 25, Issue 96
  11. Archive-name: tcl/part28
  12. Environment: UNIX
  13.  
  14. #! /bin/sh
  15. # This is a shell archive.  Remove anything before this line, then unpack
  16. # it by saving it into a file and typing "sh file".  To overwrite existing
  17. # files, type "sh file -c".  You can also feed this as standard input via
  18. # unshar, or by typing "sh <file", e.g..  If this archive is complete, you
  19. # will see the following message at the end:
  20. #        "End of archive 28 (of 33)."
  21. # Contents:  tcl6.1/tclCmdMZ.c
  22. # Wrapped by karl@one on Tue Nov 12 19:44:31 1991
  23. PATH=/bin:/usr/bin:/usr/ucb ; export PATH
  24. if test -f 'tcl6.1/tclCmdMZ.c' -a "${1}" != "-c" ; then 
  25.   echo shar: Will not clobber existing file \"'tcl6.1/tclCmdMZ.c'\"
  26. else
  27. echo shar: Extracting \"'tcl6.1/tclCmdMZ.c'\" \(35722 characters\)
  28. sed "s/^X//" >'tcl6.1/tclCmdMZ.c' <<'END_OF_FILE'
  29. X/* 
  30. X * tclCmdMZ.c --
  31. X *
  32. X *    This file contains the top-level command routines for most of
  33. X *    the Tcl built-in commands whose names begin with the letters
  34. X *    M to Z.  It contains only commands in the generic core (i.e.
  35. X *    those that don't depend much upon UNIX facilities).
  36. X *
  37. X * Copyright 1987-1991 Regents of the University of California
  38. X * Permission to use, copy, modify, and distribute this
  39. X * software and its documentation for any purpose and without
  40. X * fee is hereby granted, provided that the above copyright
  41. X * notice appear in all copies.  The University of California
  42. X * makes no representations about the suitability of this
  43. X * software for any purpose.  It is provided "as is" without
  44. X * express or implied warranty.
  45. X */
  46. X
  47. X#ifndef lint
  48. Xstatic char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclCmdMZ.c,v 1.12 91/10/27 16:17:07 ouster Exp $ SPRITE (Berkeley)";
  49. X#endif
  50. X
  51. X#include "tclInt.h"
  52. X
  53. X/*
  54. X * Structure used to hold information about variable traces:
  55. X */
  56. X
  57. Xtypedef struct {
  58. X    int flags;            /* Operations for which Tcl command is
  59. X                 * to be invoked. */
  60. X    int length;            /* Number of non-NULL chars. in command. */
  61. X    char command[4];        /* Space for Tcl command to invoke.  Actual
  62. X                 * size will be as large as necessary to
  63. X                 * hold command.  This field must be the
  64. X                 * last in the structure, so that it can
  65. X                 * be larger than 4 bytes. */
  66. X} TraceVarInfo;
  67. X
  68. X/*
  69. X * Forward declarations for procedures defined in this file:
  70. X */
  71. X
  72. Xstatic char *        TraceVarProc _ANSI_ARGS_((ClientData clientData,
  73. X                Tcl_Interp *interp, char *name1, char *name2,
  74. X                int flags));
  75. X
  76. X/*
  77. X *----------------------------------------------------------------------
  78. X *
  79. X * Tcl_RegexpCmd --
  80. X *
  81. X *    This procedure is invoked to process the "regexp" Tcl command.
  82. X *    See the user documentation for details on what it does.
  83. X *
  84. X * Results:
  85. X *    A standard Tcl result.
  86. X *
  87. X * Side effects:
  88. X *    See the user documentation.
  89. X *
  90. X *----------------------------------------------------------------------
  91. X */
  92. X
  93. X    /* ARGSUSED */
  94. Xint
  95. XTcl_RegexpCmd(dummy, interp, argc, argv)
  96. X    ClientData dummy;            /* Not used. */
  97. X    Tcl_Interp *interp;            /* Current interpreter. */
  98. X    int argc;                /* Number of arguments. */
  99. X    char **argv;            /* Argument strings. */
  100. X{
  101. X    int noCase = 0;
  102. X    int indices = 0;
  103. X    regexp *regexpPtr;
  104. X    char **argPtr, *string;
  105. X    int match, i;
  106. X
  107. X    if (argc < 3) {
  108. X    wrongNumArgs:
  109. X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  110. X        " ?-nocase? exp string ?matchVar? ?subMatchVar ",
  111. X        "subMatchVar ...?\"", (char *) NULL);
  112. X    return TCL_ERROR;
  113. X    }
  114. X    argPtr = argv+1;
  115. X    argc--;
  116. X    while ((argc > 0) && (argPtr[0][0] == '-')) {
  117. X    if (strcmp(argPtr[0], "-indices") == 0) {
  118. X        argPtr++;
  119. X        argc--;
  120. X        indices = 1;
  121. X    } else if (strcmp(argPtr[0], "-nocase") == 0) {
  122. X        argPtr++;
  123. X        argc--;
  124. X        noCase = 1;
  125. X    } else {
  126. X        break;
  127. X    }
  128. X    }
  129. X    if (argc < 2) {
  130. X    goto wrongNumArgs;
  131. X    }
  132. X    regexpPtr = TclCompileRegexp(interp, argPtr[0]);
  133. X    if (regexpPtr == NULL) {
  134. X    return TCL_ERROR;
  135. X    }
  136. X
  137. X    /*
  138. X     * Convert the string to lower case, if desired, and perform
  139. X     * the match.
  140. X     */
  141. X
  142. X    if (noCase) {
  143. X    register char *dst, *src;
  144. X
  145. X    string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
  146. X    for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
  147. X        if (isupper(*src)) {
  148. X        *dst = tolower(*src);
  149. X        } else {
  150. X        *dst = *src;
  151. X        }
  152. X    }
  153. X    *dst = 0;
  154. X    } else {
  155. X    string = argPtr[1];
  156. X    }
  157. X    tclRegexpError = NULL;
  158. X    match = regexec(regexpPtr, string);
  159. X    if (string != argPtr[1]) {
  160. X    ckfree(string);
  161. X    }
  162. X    if (tclRegexpError != NULL) {
  163. X    Tcl_AppendResult(interp, "error while matching pattern: ",
  164. X        tclRegexpError, (char *) NULL);
  165. X    return TCL_ERROR;
  166. X    }
  167. X    if (!match) {
  168. X    interp->result = "0";
  169. X    return TCL_OK;
  170. X    }
  171. X
  172. X    /*
  173. X     * If additional variable names have been specified, return
  174. X     * index information in those variables.
  175. X     */
  176. X
  177. X    argc -= 2;
  178. X    if (argc > NSUBEXP) {
  179. X    interp->result = "too many substring variables";
  180. X    return TCL_ERROR;
  181. X    }
  182. X    for (i = 0; i < argc; i++) {
  183. X    char *result, info[50];
  184. X
  185. X    if (regexpPtr->startp[i] == NULL) {
  186. X        if (indices) {
  187. X        result = Tcl_SetVar(interp, argPtr[i+2], "-1 -1", 0);
  188. X        } else {
  189. X        result = Tcl_SetVar(interp, argPtr[i+2], "", 0);
  190. X        }
  191. X    } else {
  192. X        if (indices) {
  193. X        sprintf(info, "%d %d", regexpPtr->startp[i] - string,
  194. X            regexpPtr->endp[i] - string - 1);
  195. X        result = Tcl_SetVar(interp, argPtr[i+2], info, 0);
  196. X        } else {
  197. X        char savedChar, *first, *last;
  198. X
  199. X        first = argPtr[1] + (regexpPtr->startp[i] - string);
  200. X        last = argPtr[1] + (regexpPtr->endp[i] - string);
  201. X        savedChar = *last;
  202. X        *last = 0;
  203. X        result = Tcl_SetVar(interp, argPtr[i+2], first, 0);
  204. X        *last = savedChar;
  205. X        }
  206. X    }
  207. X    if (result == NULL) {
  208. X        Tcl_AppendResult(interp, "couldn't set variable \"",
  209. X            argPtr[i+2], "\"", (char *) NULL);
  210. X        return TCL_ERROR;
  211. X    }
  212. X    }
  213. X    interp->result = "1";
  214. X    return TCL_OK;
  215. X}
  216. X
  217. X/*
  218. X *----------------------------------------------------------------------
  219. X *
  220. X * Tcl_RegsubCmd --
  221. X *
  222. X *    This procedure is invoked to process the "regsub" Tcl command.
  223. X *    See the user documentation for details on what it does.
  224. X *
  225. X * Results:
  226. X *    A standard Tcl result.
  227. X *
  228. X * Side effects:
  229. X *    See the user documentation.
  230. X *
  231. X *----------------------------------------------------------------------
  232. X */
  233. X
  234. X    /* ARGSUSED */
  235. Xint
  236. XTcl_RegsubCmd(dummy, interp, argc, argv)
  237. X    ClientData dummy;            /* Not used. */
  238. X    Tcl_Interp *interp;            /* Current interpreter. */
  239. X    int argc;                /* Number of arguments. */
  240. X    char **argv;            /* Argument strings. */
  241. X{
  242. X    int noCase = 0, all = 0;
  243. X    regexp *regexpPtr;
  244. X    char *string, *p, *firstChar, *newValue, **argPtr;
  245. X    int match, result, flags;
  246. X    register char *src, c;
  247. X
  248. X    if (argc < 5) {
  249. X    wrongNumArgs:
  250. X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  251. X        " ?-nocase? ?-all? exp string subSpec varName\"", (char *) NULL);
  252. X    return TCL_ERROR;
  253. X    }
  254. X    argPtr = argv+1;
  255. X    argc--;
  256. X    while (argPtr[0][0] == '-') {
  257. X    if (strcmp(argPtr[0], "-nocase") == 0) {
  258. X        argPtr++;
  259. X        argc--;
  260. X        noCase = 1;
  261. X    } else if (strcmp(argPtr[0], "-all") == 0) {
  262. X        argPtr++;
  263. X        argc--;
  264. X        all = 1;
  265. X    } else {
  266. X        break;
  267. X    }
  268. X    }
  269. X    if (argc != 4) {
  270. X    goto wrongNumArgs;
  271. X    }
  272. X    regexpPtr = TclCompileRegexp(interp, argPtr[0]);
  273. X    if (regexpPtr == NULL) {
  274. X    return TCL_ERROR;
  275. X    }
  276. X
  277. X    /*
  278. X     * Convert the string to lower case, if desired.
  279. X     */
  280. X
  281. X    if (noCase) {
  282. X    register char *dst;
  283. X
  284. X    string = (char *) ckalloc((unsigned) (strlen(argPtr[1]) + 1));
  285. X    for (src = argPtr[1], dst = string; *src != 0; src++, dst++) {
  286. X        if (isupper(*src)) {
  287. X        *dst = tolower(*src);
  288. X        } else {
  289. X        *dst = *src;
  290. X        }
  291. X    }
  292. X    *dst = 0;
  293. X    } else {
  294. X    string = argPtr[1];
  295. X    }
  296. X
  297. X    /*
  298. X     * The following loop is to handle multiple matches within the
  299. X     * same source string;  each iteration handles one match and its
  300. X     * corresponding substitution.  If "-all" hasn't been specified
  301. X     * then the loop body only gets executed once.
  302. X     */
  303. X
  304. X    flags = 0;
  305. X    for (p = string; *p != 0; ) {
  306. X    tclRegexpError = NULL;
  307. X    match = regexec(regexpPtr, p);
  308. X    if (tclRegexpError != NULL) {
  309. X        Tcl_AppendResult(interp, "error while matching pattern: ",
  310. X            tclRegexpError, (char *) NULL);
  311. X        result = TCL_ERROR;
  312. X        goto done;
  313. X    }
  314. X    if (!match) {
  315. X        break;
  316. X    }
  317. X
  318. X    /*
  319. X     * Copy the portion of the source string before the match to the
  320. X     * result variable.
  321. X     */
  322. X    
  323. X    src = argPtr[1] + (regexpPtr->startp[0] - string);
  324. X    c = *src;
  325. X    *src = 0;
  326. X    newValue = Tcl_SetVar(interp, argPtr[3], argPtr[1] + (p - string),
  327. X        flags);
  328. X    *src = c;
  329. X    flags = TCL_APPEND_VALUE;
  330. X    if (newValue == NULL) {
  331. X        cantSet:
  332. X        Tcl_AppendResult(interp, "couldn't set variable \"",
  333. X            argPtr[3], "\"", (char *) NULL);
  334. X        result = TCL_ERROR;
  335. X        goto done;
  336. X    }
  337. X    
  338. X    /*
  339. X     * Append the subSpec argument to the variable, making appropriate
  340. X     * substitutions.  This code is a bit hairy because of the backslash
  341. X     * conventions and because the code saves up ranges of characters in
  342. X     * subSpec to reduce the number of calls to Tcl_SetVar.
  343. X     */
  344. X    
  345. X    for (src = firstChar = argPtr[2], c = *src; c != 0; src++, c = *src) {
  346. X        int index;
  347. X    
  348. X        if (c == '&') {
  349. X        index = 0;
  350. X        } else if (c == '\\') {
  351. X        c = src[1];
  352. X        if ((c >= '0') && (c <= '9')) {
  353. X            index = c - '0';
  354. X        } else if ((c == '\\') || (c == '&')) {
  355. X            *src = c;
  356. X            src[1] = 0;
  357. X            newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
  358. X                TCL_APPEND_VALUE);
  359. X            *src = '\\';
  360. X            src[1] = c;
  361. X            if (newValue == NULL) {
  362. X            goto cantSet;
  363. X            }
  364. X            firstChar = src+2;
  365. X            src++;
  366. X            continue;
  367. X        } else {
  368. X            continue;
  369. X        }
  370. X        } else {
  371. X        continue;
  372. X        }
  373. X        if (firstChar != src) {
  374. X        c = *src;
  375. X        *src = 0;
  376. X        newValue = Tcl_SetVar(interp, argPtr[3], firstChar,
  377. X            TCL_APPEND_VALUE);
  378. X        *src = c;
  379. X        if (newValue == NULL) {
  380. X            goto cantSet;
  381. X        }
  382. X        }
  383. X        if ((index < NSUBEXP) && (regexpPtr->startp[index] != NULL)
  384. X            && (regexpPtr->endp[index] != NULL)) {
  385. X        char *first, *last, saved;
  386. X    
  387. X        first = argPtr[1] + (regexpPtr->startp[index] - string);
  388. X        last = argPtr[1] + (regexpPtr->endp[index] - string);
  389. X        saved = *last;
  390. X        *last = 0;
  391. X        newValue = Tcl_SetVar(interp, argPtr[3], first,
  392. X            TCL_APPEND_VALUE);
  393. X        *last = saved;
  394. X        if (newValue == NULL) {
  395. X            goto cantSet;
  396. X        }
  397. X        }
  398. X        if (*src == '\\') {
  399. X        src++;
  400. X        }
  401. X        firstChar = src+1;
  402. X    }
  403. X    if (firstChar != src) {
  404. X        if (Tcl_SetVar(interp, argPtr[3], firstChar,
  405. X            TCL_APPEND_VALUE) == NULL) {
  406. X        goto cantSet;
  407. X        }
  408. X    }
  409. X    p = regexpPtr->endp[0];
  410. X    if (!all) {
  411. X        break;
  412. X    }
  413. X    }
  414. X
  415. X    /*
  416. X     * If there were no matches at all, then return a "0" result.
  417. X     */
  418. X
  419. X    if (p == string) {
  420. X    interp->result = "0";
  421. X    result = TCL_OK;
  422. X    goto done;
  423. X    }
  424. X
  425. X    /*
  426. X     * Copy the portion of the source string after the last match to the
  427. X     * result variable.
  428. X     */
  429. X
  430. X    if (*p != 0) {
  431. X    if (Tcl_SetVar(interp, argPtr[3], p, TCL_APPEND_VALUE) == NULL) {
  432. X        goto cantSet;
  433. X    }
  434. X    }
  435. X    interp->result = "1";
  436. X    result = TCL_OK;
  437. X
  438. X    done:
  439. X    if (string != argPtr[1]) {
  440. X    ckfree(string);
  441. X    }
  442. X    return result;
  443. X}
  444. X
  445. X/*
  446. X *----------------------------------------------------------------------
  447. X *
  448. X * Tcl_RenameCmd --
  449. X *
  450. X *    This procedure is invoked to process the "rename" Tcl command.
  451. X *    See the user documentation for details on what it does.
  452. X *
  453. X * Results:
  454. X *    A standard Tcl result.
  455. X *
  456. X * Side effects:
  457. X *    See the user documentation.
  458. X *
  459. X *----------------------------------------------------------------------
  460. X */
  461. X
  462. X    /* ARGSUSED */
  463. Xint
  464. XTcl_RenameCmd(dummy, interp, argc, argv)
  465. X    ClientData dummy;            /* Not used. */
  466. X    Tcl_Interp *interp;            /* Current interpreter. */
  467. X    int argc;                /* Number of arguments. */
  468. X    char **argv;            /* Argument strings. */
  469. X{
  470. X    register Command *cmdPtr;
  471. X    Interp *iPtr = (Interp *) interp;
  472. X    Tcl_HashEntry *hPtr;
  473. X    int new;
  474. X
  475. X    if (argc != 3) {
  476. X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  477. X        " oldName newName\"", (char *) NULL);
  478. X    return TCL_ERROR;
  479. X    }
  480. X    if (argv[2][0] == '\0') {
  481. X    if (Tcl_DeleteCommand(interp, argv[1]) != 0) {
  482. X        Tcl_AppendResult(interp, "can't delete \"", argv[1],
  483. X            "\": command doesn't exist", (char *) NULL);
  484. X        return TCL_ERROR;
  485. X    }
  486. X    return TCL_OK;
  487. X    }
  488. X    hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[2]);
  489. X    if (hPtr != NULL) {
  490. X    Tcl_AppendResult(interp, "can't rename to \"", argv[2],
  491. X        "\": command already exists", (char *) NULL);
  492. X    return TCL_ERROR;
  493. X    }
  494. X    hPtr = Tcl_FindHashEntry(&iPtr->commandTable, argv[1]);
  495. X    if (hPtr == NULL) {
  496. X    Tcl_AppendResult(interp, "can't rename \"", argv[1],
  497. X        "\":  command doesn't exist", (char *) NULL);
  498. X    return TCL_ERROR;
  499. X    }
  500. X    cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  501. X    Tcl_DeleteHashEntry(hPtr);
  502. X    hPtr = Tcl_CreateHashEntry(&iPtr->commandTable, argv[2], &new);
  503. X    Tcl_SetHashValue(hPtr, cmdPtr);
  504. X    return TCL_OK;
  505. X}
  506. X
  507. X/*
  508. X *----------------------------------------------------------------------
  509. X *
  510. X * Tcl_ReturnCmd --
  511. X *
  512. X *    This procedure is invoked to process the "return" Tcl command.
  513. X *    See the user documentation for details on what it does.
  514. X *
  515. X * Results:
  516. X *    A standard Tcl result.
  517. X *
  518. X * Side effects:
  519. X *    See the user documentation.
  520. X *
  521. X *----------------------------------------------------------------------
  522. X */
  523. X
  524. X    /* ARGSUSED */
  525. Xint
  526. XTcl_ReturnCmd(dummy, interp, argc, argv)
  527. X    ClientData dummy;            /* Not used. */
  528. X    Tcl_Interp *interp;            /* Current interpreter. */
  529. X    int argc;                /* Number of arguments. */
  530. X    char **argv;            /* Argument strings. */
  531. X{
  532. X    if (argc > 2) {
  533. X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  534. X        " ?value?\"", (char *) NULL);
  535. X    return TCL_ERROR;
  536. X    }
  537. X    if (argc == 2) {
  538. X    Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
  539. X    }
  540. X    return TCL_RETURN;
  541. X}
  542. X
  543. X/*
  544. X *----------------------------------------------------------------------
  545. X *
  546. X * Tcl_ScanCmd --
  547. X *
  548. X *    This procedure is invoked to process the "scan" Tcl command.
  549. X *    See the user documentation for details on what it does.
  550. X *
  551. X * Results:
  552. X *    A standard Tcl result.
  553. X *
  554. X * Side effects:
  555. X *    See the user documentation.
  556. X *
  557. X *----------------------------------------------------------------------
  558. X */
  559. X
  560. X    /* ARGSUSED */
  561. Xint
  562. XTcl_ScanCmd(dummy, interp, argc, argv)
  563. X    ClientData dummy;            /* Not used. */
  564. X    Tcl_Interp *interp;            /* Current interpreter. */
  565. X    int argc;                /* Number of arguments. */
  566. X    char **argv;            /* Argument strings. */
  567. X{
  568. X    int arg1Length;            /* Number of bytes in argument to be
  569. X                     * scanned.  This gives an upper limit
  570. X                     * on string field sizes. */
  571. X#   define MAX_FIELDS 20
  572. X    typedef struct {
  573. X    char fmt;            /* Format for field. */
  574. X    int size;            /* How many bytes to allow for
  575. X                     * field. */
  576. X    char *location;            /* Where field will be stored. */
  577. X    } Field;
  578. X    Field fields[MAX_FIELDS];        /* Info about all the fields in the
  579. X                     * format string. */
  580. X    register Field *curField;
  581. X    int numFields = 0;            /* Number of fields actually
  582. X                     * specified. */
  583. X    int suppress;            /* Current field is assignment-
  584. X                     * suppressed. */
  585. X    int totalSize = 0;            /* Number of bytes needed to store
  586. X                     * all results combined. */
  587. X    char *results;            /* Where scanned output goes.  */
  588. X    int numScanned;            /* sscanf's result. */
  589. X    register char *fmt;
  590. X    int i, widthSpecified;
  591. X
  592. X    if (argc < 3) {
  593. X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  594. X        " string format ?varName varName ...?\"", (char *) NULL);
  595. X    return TCL_ERROR;
  596. X    }
  597. X
  598. X    /*
  599. X     * This procedure operates in four stages:
  600. X     * 1. Scan the format string, collecting information about each field.
  601. X     * 2. Allocate an array to hold all of the scanned fields.
  602. X     * 3. Call sscanf to do all the dirty work, and have it store the
  603. X     *    parsed fields in the array.
  604. X     * 4. Pick off the fields from the array and assign them to variables.
  605. X     */
  606. X
  607. X    arg1Length = (strlen(argv[1]) + 4) & ~03;
  608. X    for (fmt = argv[2]; *fmt != 0; fmt++) {
  609. X    if (*fmt != '%') {
  610. X        continue;
  611. X    }
  612. X    fmt++;
  613. X    if (*fmt == '*') {
  614. X        suppress = 1;
  615. X        fmt++;
  616. X    } else {
  617. X        suppress = 0;
  618. X    }
  619. X    widthSpecified = 0;
  620. X    while (isdigit(*fmt)) {
  621. X        widthSpecified = 1;
  622. X        fmt++;
  623. X    }
  624. X    if (suppress) {
  625. X        continue;
  626. X    }
  627. X    if (numFields == MAX_FIELDS) {
  628. X        interp->result = "too many fields to scan";
  629. X        return TCL_ERROR;
  630. X    }
  631. X    curField = &fields[numFields];
  632. X    numFields++;
  633. X    switch (*fmt) {
  634. X        case 'D':
  635. X        case 'O':
  636. X        case 'X':
  637. X        case 'd':
  638. X        case 'o':
  639. X        case 'x':
  640. X        curField->fmt = 'd';
  641. X        curField->size = sizeof(int);
  642. X        break;
  643. X
  644. X        case 's':
  645. X        curField->fmt = 's';
  646. X        curField->size = arg1Length;
  647. X        break;
  648. X
  649. X        case 'c':
  650. X                if (widthSpecified) {
  651. X                    interp->result = 
  652. X                         "field width may not be specified in %c conversion";
  653. X                    return TCL_ERROR;
  654. X                }
  655. X        curField->fmt = 'c';
  656. X        curField->size = sizeof(int);
  657. X        break;
  658. X
  659. X        case 'E':
  660. X        case 'F':
  661. X        curField->fmt = 'F';
  662. X        curField->size = sizeof(double);
  663. X        break;
  664. X
  665. X        case 'e':
  666. X        case 'f':
  667. X        curField->fmt = 'f';
  668. X        curField->size = sizeof(float);
  669. X        break;
  670. X
  671. X        case '[':
  672. X        curField->fmt = 's';
  673. X        curField->size = arg1Length;
  674. X        do {
  675. X            fmt++;
  676. X        } while (*fmt != ']');
  677. X        break;
  678. X
  679. X        default:
  680. X        sprintf(interp->result, "bad scan conversion character \"%c\"",
  681. X            *fmt);
  682. X        return TCL_ERROR;
  683. X    }
  684. X    totalSize += curField->size;
  685. X    }
  686. X
  687. X    if (numFields != (argc-3)) {
  688. X    interp->result =
  689. X        "different numbers of variable names and field specifiers";
  690. X    return TCL_ERROR;
  691. X    }
  692. X
  693. X    /*
  694. X     * Step 2:
  695. X     */
  696. X
  697. X    results = (char *) ckalloc((unsigned) totalSize);
  698. X    for (i = 0, totalSize = 0, curField = fields;
  699. X        i < numFields; i++, curField++) {
  700. X    curField->location = results + totalSize;
  701. X    totalSize += curField->size;
  702. X    }
  703. X
  704. X    /*
  705. X     * Step 3:
  706. X     */
  707. X
  708. X    numScanned = sscanf(argv[1], argv[2],
  709. X        fields[0].location, fields[1].location, fields[2].location,
  710. X        fields[3].location, fields[4].location, fields[5].location,
  711. X        fields[6].location, fields[7].location, fields[8].location,
  712. X        fields[9].location, fields[10].location, fields[11].location,
  713. X        fields[12].location, fields[13].location, fields[14].location,
  714. X        fields[15].location, fields[16].location, fields[17].location,
  715. X        fields[18].location, fields[19].location);
  716. X
  717. X    /*
  718. X     * Step 4:
  719. X     */
  720. X
  721. X    if (numScanned < numFields) {
  722. X    numFields = numScanned;
  723. X    }
  724. X    for (i = 0, curField = fields; i < numFields; i++, curField++) {
  725. X    switch (curField->fmt) {
  726. X        char string[120];
  727. X
  728. X        case 'd':
  729. X        sprintf(string, "%d", *((int *) curField->location));
  730. X        if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  731. X            storeError:
  732. X            Tcl_AppendResult(interp,
  733. X                "couldn't set variable \"", argv[i+3], "\"",
  734. X                (char *) NULL);
  735. X            ckfree((char *) results);
  736. X            return TCL_ERROR;
  737. X        }
  738. X        break;
  739. X
  740. X        case 'c':
  741. X        sprintf(string, "%d", *((char *) curField->location) & 0xff);
  742. X        if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  743. X            goto storeError;
  744. X        }
  745. X        break;
  746. X
  747. X        case 's':
  748. X        if (Tcl_SetVar(interp, argv[i+3], curField->location, 0)
  749. X            == NULL) {
  750. X            goto storeError;
  751. X        }
  752. X        break;
  753. X
  754. X        case 'F':
  755. X        sprintf(string, "%g", *((double *) curField->location));
  756. X        if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  757. X            goto storeError;
  758. X        }
  759. X        break;
  760. X
  761. X        case 'f':
  762. X        sprintf(string, "%g", *((float *) curField->location));
  763. X        if (Tcl_SetVar(interp, argv[i+3], string, 0) == NULL) {
  764. X            goto storeError;
  765. X        }
  766. X        break;
  767. X    }
  768. X    }
  769. X    ckfree(results);
  770. X    sprintf(interp->result, "%d", numScanned);
  771. X    return TCL_OK;
  772. X}
  773. X
  774. X/*
  775. X *----------------------------------------------------------------------
  776. X *
  777. X * Tcl_SplitCmd --
  778. X *
  779. X *    This procedure is invoked to process the "split" Tcl command.
  780. X *    See the user documentation for details on what it does.
  781. X *
  782. X * Results:
  783. X *    A standard Tcl result.
  784. X *
  785. X * Side effects:
  786. X *    See the user documentation.
  787. X *
  788. X *----------------------------------------------------------------------
  789. X */
  790. X
  791. X    /* ARGSUSED */
  792. Xint
  793. XTcl_SplitCmd(dummy, interp, argc, argv)
  794. X    ClientData dummy;            /* Not used. */
  795. X    Tcl_Interp *interp;            /* Current interpreter. */
  796. X    int argc;                /* Number of arguments. */
  797. X    char **argv;            /* Argument strings. */
  798. X{
  799. X    char *splitChars;
  800. X    register char *p, *p2;
  801. X    char *elementStart;
  802. X
  803. X    if (argc == 2) {
  804. X    splitChars = " \n\t\r";
  805. X    } else if (argc == 3) {
  806. X    splitChars = argv[2];
  807. X    } else {
  808. X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  809. X        " string ?splitChars?\"", (char *) NULL);
  810. X    return TCL_ERROR;
  811. X    }
  812. X
  813. X    /*
  814. X     * Handle the special case of splitting on every character.
  815. X     */
  816. X
  817. X    if (*splitChars == 0) {
  818. X    char string[2];
  819. X    string[1] = 0;
  820. X    for (p = argv[1]; *p != 0; p++) {
  821. X        string[0] = *p;
  822. X        Tcl_AppendElement(interp, string, 0);
  823. X    }
  824. X    return TCL_OK;
  825. X    }
  826. X
  827. X    /*
  828. X     * Normal case: split on any of a given set of characters.
  829. X     * Discard instances of the split characters.
  830. X     */
  831. X
  832. X    for (p = elementStart = argv[1]; *p != 0; p++) {
  833. X    char c = *p;
  834. X    for (p2 = splitChars; *p2 != 0; p2++) {
  835. X        if (*p2 == c) {
  836. X        *p = 0;
  837. X        Tcl_AppendElement(interp, elementStart, 0);
  838. X        *p = c;
  839. X        elementStart = p+1;
  840. X        break;
  841. X        }
  842. X    }
  843. X    }
  844. X    if (p != argv[1]) {
  845. X    Tcl_AppendElement(interp, elementStart, 0);
  846. X    }
  847. X    return TCL_OK;
  848. X}
  849. X
  850. X/*
  851. X *----------------------------------------------------------------------
  852. X *
  853. X * Tcl_StringCmd --
  854. X *
  855. X *    This procedure is invoked to process the "string" Tcl command.
  856. X *    See the user documentation for details on what it does.
  857. X *
  858. X * Results:
  859. X *    A standard Tcl result.
  860. X *
  861. X * Side effects:
  862. X *    See the user documentation.
  863. X *
  864. X *----------------------------------------------------------------------
  865. X */
  866. X
  867. X    /* ARGSUSED */
  868. Xint
  869. XTcl_StringCmd(dummy, interp, argc, argv)
  870. X    ClientData dummy;            /* Not used. */
  871. X    Tcl_Interp *interp;            /* Current interpreter. */
  872. X    int argc;                /* Number of arguments. */
  873. X    char **argv;            /* Argument strings. */
  874. X{
  875. X    int length;
  876. X    register char *p, c;
  877. X    int match;
  878. X    int first;
  879. X    int left = 0, right = 0;
  880. X
  881. X    if (argc < 2) {
  882. X    Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  883. X        " option arg ?arg ...?\"", (char *) NULL);
  884. X    return TCL_ERROR;
  885. X    }
  886. X    c = argv[1][0];
  887. X    length = strlen(argv[1]);
  888. X    if ((c == 'c') && (strncmp(argv[1], "compare", length) == 0)) {
  889. X    if (argc != 4) {
  890. X        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  891. X            " compare string1 string2\"", (char *) NULL);
  892. X        return TCL_ERROR;
  893. X    }
  894. X    match = strcmp(argv[2], argv[3]);
  895. X    if (match > 0) {
  896. X        interp->result = "1";
  897. X    } else if (match < 0) {
  898. X        interp->result = "-1";
  899. X    } else {
  900. X        interp->result = "0";
  901. X    }
  902. X    return TCL_OK;
  903. X    } else if ((c == 'f') && (strncmp(argv[1], "first", length) == 0)) {
  904. X    if (argc != 4) {
  905. X        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  906. X            " first string1 string2\"", (char *) NULL);
  907. X        return TCL_ERROR;
  908. X    }
  909. X    first = 1;
  910. X
  911. X    firstLast:
  912. X    match = -1;
  913. X    c = *argv[2];
  914. X    length = strlen(argv[2]);
  915. X    for (p = argv[3]; *p != 0; p++) {
  916. X        if (*p != c) {
  917. X        continue;
  918. X        }
  919. X        if (strncmp(argv[2], p, length) == 0) {
  920. X        match = p-argv[3];
  921. X        if (first) {
  922. X            break;
  923. X        }
  924. X        }
  925. X    }
  926. X    sprintf(interp->result, "%d", match);
  927. X    return TCL_OK;
  928. X    } else if ((c == 'i') && (strncmp(argv[1], "index", length) == 0)) {
  929. X    int index;
  930. X
  931. X    if (argc != 4) {
  932. X        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  933. X            " index string charIndex\"", (char *) NULL);
  934. X        return TCL_ERROR;
  935. X    }
  936. X    if (Tcl_GetInt(interp, argv[3], &index) != TCL_OK) {
  937. X        return TCL_ERROR;
  938. X    }
  939. X    if ((index >= 0) && (index < strlen(argv[2]))) {
  940. X        interp->result[0] = argv[2][index];
  941. X        interp->result[1] = 0;
  942. X    }
  943. X    return TCL_OK;
  944. X    } else if ((c == 'l') && (strncmp(argv[1], "last", length) == 0)
  945. X        && (length >= 2)) {
  946. X    if (argc != 4) {
  947. X        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  948. X            " last string1 string2\"", (char *) NULL);
  949. X        return TCL_ERROR;
  950. X    }
  951. X    first = 0;
  952. X    goto firstLast;
  953. X    } else if ((c == 'l') && (strncmp(argv[1], "length", length) == 0)
  954. X        && (length >= 2)) {
  955. X    if (argc != 3) {
  956. X        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  957. X            " length string\"", (char *) NULL);
  958. X        return TCL_ERROR;
  959. X    }
  960. X    sprintf(interp->result, "%d", strlen(argv[2]));
  961. X    return TCL_OK;
  962. X    } else if ((c == 'm') && (strncmp(argv[1], "match", length) == 0)) {
  963. X    if (argc != 4) {
  964. X        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  965. X            " match pattern string\"", (char *) NULL);
  966. X        return TCL_ERROR;
  967. X    }
  968. X    if (Tcl_StringMatch(argv[3], argv[2]) != 0) {
  969. X        interp->result = "1";
  970. X    } else {
  971. X        interp->result = "0";
  972. X    }
  973. X    return TCL_OK;
  974. X    } else if ((c == 'r') && (strncmp(argv[1], "range", length) == 0)) {
  975. X    int first, last, stringLength;
  976. X
  977. X    if (argc != 5) {
  978. X        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  979. X            " range string first last\"", (char *) NULL);
  980. X        return TCL_ERROR;
  981. X    }
  982. X    stringLength = strlen(argv[2]);
  983. X    if (Tcl_GetInt(interp, argv[3], &first) != TCL_OK) {
  984. X        return TCL_ERROR;
  985. X    }
  986. X    if ((*argv[4] == 'e')
  987. X        && (strncmp(argv[4], "end", strlen(argv[4])) == 0)) {
  988. X        last = stringLength-1;
  989. X    } else {
  990. X        if (Tcl_GetInt(interp, argv[4], &last) != TCL_OK) {
  991. X        Tcl_ResetResult(interp);
  992. X        Tcl_AppendResult(interp,
  993. X            "expected integer or \"end\" but got \"",
  994. X            argv[4], "\"", (char *) NULL);
  995. X        return TCL_ERROR;
  996. X        }
  997. X    }
  998. X    if (first < 0) {
  999. X        first = 0;
  1000. X    }
  1001. X    if (last >= stringLength) {
  1002. X        last = stringLength-1;
  1003. X    }
  1004. X    if (last >= first) {
  1005. X        char saved, *p;
  1006. X
  1007. X        p = argv[2] + last + 1;
  1008. X        saved = *p;
  1009. X        *p = 0;
  1010. X        Tcl_SetResult(interp, argv[2] + first, TCL_VOLATILE);
  1011. X        *p = saved;
  1012. X    }
  1013. X    return TCL_OK;
  1014. X    } else if ((c == 't') && (strncmp(argv[1], "tolower", length) == 0)
  1015. X        && (length >= 3)) {
  1016. X    register char *p;
  1017. X
  1018. X    if (argc != 3) {
  1019. X        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1020. X            " tolower string\"", (char *) NULL);
  1021. X        return TCL_ERROR;
  1022. X    }
  1023. X    Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
  1024. X    for (p = interp->result; *p != 0; p++) {
  1025. X        if (isupper(*p)) {
  1026. X        *p = tolower(*p);
  1027. X        }
  1028. X    }
  1029. X    return TCL_OK;
  1030. X    } else if ((c == 't') && (strncmp(argv[1], "toupper", length) == 0)
  1031. X        && (length >= 3)) {
  1032. X    register char *p;
  1033. X
  1034. X    if (argc != 3) {
  1035. X        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1036. X            " toupper string\"", (char *) NULL);
  1037. X        return TCL_ERROR;
  1038. X    }
  1039. X    Tcl_SetResult(interp, argv[2], TCL_VOLATILE);
  1040. X    for (p = interp->result; *p != 0; p++) {
  1041. X        if (islower(*p)) {
  1042. X        *p = toupper(*p);
  1043. X        }
  1044. X    }
  1045. X    return TCL_OK;
  1046. X    } else if ((c == 't') && (strncmp(argv[1], "trim", length) == 0)
  1047. X        && (length == 4)) {
  1048. X    char *trimChars;
  1049. X    register char *p, *checkPtr;
  1050. X
  1051. X    left = right = 1;
  1052. X
  1053. X    trim:
  1054. X    if (argc == 4) {
  1055. X        trimChars = argv[3];
  1056. X    } else if (argc == 3) {
  1057. X        trimChars = " \t\n\r";
  1058. X    } else {
  1059. X        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1060. X            " ", argv[1], " string ?chars?\"", (char *) NULL);
  1061. X        return TCL_ERROR;
  1062. X    }
  1063. X    p = argv[2];
  1064. X    if (left) {
  1065. X        for (c = *p; c != 0; p++, c = *p) {
  1066. X        for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
  1067. X            if (*checkPtr == 0) {
  1068. X            goto doneLeft;
  1069. X            }
  1070. X        }
  1071. X        }
  1072. X    }
  1073. X    doneLeft:
  1074. X    Tcl_SetResult(interp, p, TCL_VOLATILE);
  1075. X    if (right) {
  1076. X        char *donePtr;
  1077. X
  1078. X        p = interp->result + strlen(interp->result) - 1;
  1079. X        donePtr = &interp->result[-1];
  1080. X        for (c = *p; p != donePtr; p--, c = *p) {
  1081. X        for (checkPtr = trimChars; *checkPtr != c; checkPtr++) {
  1082. X            if (*checkPtr == 0) {
  1083. X            goto doneRight;
  1084. X            }
  1085. X        }
  1086. X        }
  1087. X        doneRight:
  1088. X        p[1] = 0;
  1089. X    }
  1090. X    return TCL_OK;
  1091. X    } else if ((c == 't') && (strncmp(argv[1], "trimleft", length) == 0)
  1092. X        && (length > 4)) {
  1093. X    left = 1;
  1094. X    argv[1] = "trimleft";
  1095. X    goto trim;
  1096. X    } else if ((c == 't') && (strncmp(argv[1], "trimright", length) == 0)
  1097. X        && (length > 4)) {
  1098. X    right = 1;
  1099. X    argv[1] = "trimright";
  1100. X    goto trim;
  1101. X    } else {
  1102. X    Tcl_AppendResult(interp, "bad option \"", argv[1],
  1103. X        "\": should be compare, first, index, last, length, match, ",
  1104. X        "range, tolower, toupper, trim, trimleft, or trimright",
  1105. X        (char *) NULL);
  1106. X    return TCL_ERROR;
  1107. X    }
  1108. X}
  1109. X
  1110. X/*
  1111. X *----------------------------------------------------------------------
  1112. X *
  1113. X * Tcl_TraceCmd --
  1114. X *
  1115. X *    This procedure is invoked to process the "trace" Tcl command.
  1116. X *    See the user documentation for details on what it does.
  1117. X *
  1118. X * Results:
  1119. X *    A standard Tcl result.
  1120. X *
  1121. X * Side effects:
  1122. X *    See the user documentation.
  1123. X *
  1124. X *----------------------------------------------------------------------
  1125. X */
  1126. X
  1127. X    /* ARGSUSED */
  1128. Xint
  1129. XTcl_TraceCmd(dummy, interp, argc, argv)
  1130. X    ClientData dummy;            /* Not used. */
  1131. X    Tcl_Interp *interp;            /* Current interpreter. */
  1132. X    int argc;                /* Number of arguments. */
  1133. X    char **argv;            /* Argument strings. */
  1134. X{
  1135. X    char c;
  1136. X    int length;
  1137. X
  1138. X    if (argc < 2) {
  1139. X    Tcl_AppendResult(interp, "too few args: should be \"",
  1140. X        argv[0], " option [arg arg ...]\"", (char *) NULL);
  1141. X    return TCL_ERROR;
  1142. X    }
  1143. X    c = argv[1][1];
  1144. X    length = strlen(argv[1]);
  1145. X    if ((c == 'a') && (strncmp(argv[1], "variable", length) == 0)
  1146. X        && (length >= 2)) {
  1147. X    char *p;
  1148. X    int flags, length;
  1149. X    TraceVarInfo *tvarPtr;
  1150. X
  1151. X    if (argc != 5) {
  1152. X        Tcl_AppendResult(interp, "wrong # args: should be \"",
  1153. X            argv[0], " variable name ops command\"", (char *) NULL);
  1154. X        return TCL_ERROR;
  1155. X    }
  1156. X
  1157. X    flags = 0;
  1158. X    for (p = argv[3] ; *p != 0; p++) {
  1159. X        if (*p == 'r') {
  1160. X        flags |= TCL_TRACE_READS;
  1161. X        } else if (*p == 'w') {
  1162. X        flags |= TCL_TRACE_WRITES;
  1163. X        } else if (*p == 'u') {
  1164. X        flags |= TCL_TRACE_UNSETS;
  1165. X        } else {
  1166. X        goto badOps;
  1167. X        }
  1168. X    }
  1169. X    if (flags == 0) {
  1170. X        goto badOps;
  1171. X    }
  1172. X
  1173. X    length = strlen(argv[4]);
  1174. X    tvarPtr = (TraceVarInfo *) ckalloc((unsigned)
  1175. X        (sizeof(TraceVarInfo) - sizeof(tvarPtr->command) + length + 1));
  1176. X    tvarPtr->flags = flags;
  1177. X    tvarPtr->length = length;
  1178. X    flags |= TCL_TRACE_UNSETS;
  1179. X    strcpy(tvarPtr->command, argv[4]);
  1180. X    if (Tcl_TraceVar(interp, argv[2], flags, TraceVarProc,
  1181. X        (ClientData) tvarPtr) != TCL_OK) {
  1182. X        ckfree((char *) tvarPtr);
  1183. X        return TCL_ERROR;
  1184. X    }
  1185. X    } else if ((c == 'd') && (strncmp(argv[1], "vdelete", length)
  1186. X        && (length >= 2)) == 0) {
  1187. X    char *p;
  1188. X    int flags, length;
  1189. X    TraceVarInfo *tvarPtr;
  1190. X    ClientData clientData;
  1191. X
  1192. X    if (argc != 5) {
  1193. X        Tcl_AppendResult(interp, "wrong # args: should be \"",
  1194. X            argv[0], " vdelete name ops command\"", (char *) NULL);
  1195. X        return TCL_ERROR;
  1196. X    }
  1197. X
  1198. X    flags = 0;
  1199. X    for (p = argv[3] ; *p != 0; p++) {
  1200. X        if (*p == 'r') {
  1201. X        flags |= TCL_TRACE_READS;
  1202. X        } else if (*p == 'w') {
  1203. X        flags |= TCL_TRACE_WRITES;
  1204. X        } else if (*p == 'u') {
  1205. X        flags |= TCL_TRACE_UNSETS;
  1206. X        } else {
  1207. X        goto badOps;
  1208. X        }
  1209. X    }
  1210. X    if (flags == 0) {
  1211. X        goto badOps;
  1212. X    }
  1213. X
  1214. X    /*
  1215. X     * Search through all of our traces on this variable to
  1216. X     * see if there's one with the given command.  If so, then
  1217. X     * delete the first one that matches.
  1218. X     */
  1219. X
  1220. X    length = strlen(argv[4]);
  1221. X    clientData = 0;
  1222. X    while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
  1223. X        TraceVarProc, clientData)) != 0) {
  1224. X        tvarPtr = (TraceVarInfo *) clientData;
  1225. X        if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
  1226. X            && (strncmp(argv[4], tvarPtr->command, length) == 0)) {
  1227. X        Tcl_UntraceVar(interp, argv[2], flags | TCL_TRACE_UNSETS,
  1228. X            TraceVarProc, clientData);
  1229. X        ckfree((char *) tvarPtr);
  1230. X        break;
  1231. X        }
  1232. X    }
  1233. X    } else if ((c == 'i') && (strncmp(argv[1], "vinfo", length) == 0)
  1234. X        && (length >= 2)) {
  1235. X    ClientData clientData;
  1236. X    char ops[4], *p;
  1237. X    char *prefix = "{";
  1238. X
  1239. X    if (argc != 3) {
  1240. X        Tcl_AppendResult(interp, "wrong # args: should be \"",
  1241. X            argv[0], " vinfo name\"", (char *) NULL);
  1242. X        return TCL_ERROR;
  1243. X    }
  1244. X    clientData = 0;
  1245. X    while ((clientData = Tcl_VarTraceInfo(interp, argv[2], 0,
  1246. X        TraceVarProc, clientData)) != 0) {
  1247. X        TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
  1248. X        p = ops;
  1249. X        if (tvarPtr->flags & TCL_TRACE_READS) {
  1250. X        *p = 'r';
  1251. X        p++;
  1252. X        }
  1253. X        if (tvarPtr->flags & TCL_TRACE_WRITES) {
  1254. X        *p = 'w';
  1255. X        p++;
  1256. X        }
  1257. X        if (tvarPtr->flags & TCL_TRACE_UNSETS) {
  1258. X        *p = 'u';
  1259. X        p++;
  1260. X        }
  1261. X        *p = '\0';
  1262. X        Tcl_AppendResult(interp, prefix, (char *) NULL);
  1263. X        Tcl_AppendElement(interp, ops, 1);
  1264. X        Tcl_AppendElement(interp, tvarPtr->command, 0);
  1265. X        Tcl_AppendResult(interp, "}", (char *) NULL);
  1266. X        tvarPtr->command[tvarPtr->length] = ' ';
  1267. X        prefix = " {";
  1268. X    }
  1269. X    } else {
  1270. X    Tcl_AppendResult(interp, "bad option \"", argv[1],
  1271. X        "\": should be variable, vdelete, or vinfo",
  1272. X        (char *) NULL);
  1273. X    return TCL_ERROR;
  1274. X    }
  1275. X    return TCL_OK;
  1276. X
  1277. X    badOps:
  1278. X    Tcl_AppendResult(interp, "bad operations \"", argv[3],
  1279. X        "\": should be one or more of rwu", (char *) NULL);
  1280. X    return TCL_ERROR;
  1281. X}
  1282. X
  1283. X/*
  1284. X *----------------------------------------------------------------------
  1285. X *
  1286. X * TraceVarProc --
  1287. X *
  1288. X *    This procedure is called to handle variable accesses that have
  1289. X *    been traced using the "trace" command.
  1290. X *
  1291. X * Results:
  1292. X *    Normally returns NULL.  If the trace command returns an error,
  1293. X *    then this procedure returns an error string.
  1294. X *
  1295. X * Side effects:
  1296. X *    Depends on the command associated with the trace.
  1297. X *
  1298. X *----------------------------------------------------------------------
  1299. X */
  1300. X
  1301. X    /* ARGSUSED */
  1302. Xstatic char *
  1303. XTraceVarProc(clientData, interp, name1, name2, flags)
  1304. X    ClientData clientData;    /* Information about the variable trace. */
  1305. X    Tcl_Interp *interp;        /* Interpreter containing variable. */
  1306. X    char *name1;        /* Name of variable or array. */
  1307. X    char *name2;        /* Name of element within array;  NULL means
  1308. X                 * scalar variable is being referenced. */
  1309. X    int flags;            /* OR-ed bits giving operation and other
  1310. X                 * information. */
  1311. X{
  1312. X    TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
  1313. X    char *result;
  1314. X    int code, cmdLength, flags1, flags2;
  1315. X    Interp dummy;
  1316. X#define STATIC_SIZE 199
  1317. X    char staticSpace[STATIC_SIZE+1];
  1318. X    char *cmdPtr, *p;
  1319. X
  1320. X    result = NULL;
  1321. X    if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
  1322. X
  1323. X    /*
  1324. X     * Generate a command to execute by appending list elements
  1325. X     * for the two variable names and the operation.  The five
  1326. X     * extra characters are for three space, the opcode character,
  1327. X     * and the terminating null.
  1328. X     */
  1329. X
  1330. X    if (name2 == NULL) {
  1331. X        name2 = "";
  1332. X    }
  1333. X    cmdLength = tvarPtr->length + Tcl_ScanElement(name1, &flags1) +
  1334. X        Tcl_ScanElement(name2, &flags2) + 5;
  1335. X    if (cmdLength < STATIC_SIZE) {
  1336. X        cmdPtr = staticSpace;
  1337. X    } else {
  1338. X        cmdPtr = (char *) ckalloc((unsigned) cmdLength);
  1339. X    }
  1340. X    p = cmdPtr;
  1341. X    strcpy(p, tvarPtr->command);
  1342. X    p += tvarPtr->length;
  1343. X    *p = ' ';
  1344. X    p++;
  1345. X    p += Tcl_ConvertElement(name1, p, flags1);
  1346. X    *p = ' ';
  1347. X    p++;
  1348. X    p += Tcl_ConvertElement(name2, p, flags2);
  1349. X    *p = ' ';
  1350. X    if (flags & TCL_TRACE_READS) {
  1351. X        p[1] = 'r';
  1352. X    } else if (flags & TCL_TRACE_WRITES) {
  1353. X        p[1] = 'w';
  1354. X    } else if (flags & TCL_TRACE_UNSETS) {
  1355. X        p[1] = 'u';
  1356. X    }
  1357. X    p[2] = '\0';
  1358. X
  1359. X    /*
  1360. X     * Execute the command.  Be careful to save and restore the
  1361. X     * result from the interpreter used for the command.
  1362. X     */
  1363. X
  1364. X    dummy.freeProc = interp->freeProc;
  1365. X    if (interp->freeProc == 0) {
  1366. X        Tcl_SetResult((Tcl_Interp *) &dummy, interp->result, TCL_VOLATILE);
  1367. X    } else {
  1368. X        dummy.result = interp->result;
  1369. X    }
  1370. X    code = Tcl_Eval(interp, cmdPtr, 0, (char **) NULL);
  1371. X    if (cmdPtr != staticSpace) {
  1372. X        ckfree(cmdPtr);
  1373. X    }
  1374. X    if (code != TCL_OK) {
  1375. X        result = "access disallowed by trace command";
  1376. X        Tcl_ResetResult(interp);        /* Must clear error state. */
  1377. X    }
  1378. X    Tcl_FreeResult(interp);
  1379. X    interp->result = dummy.result;
  1380. X    interp->freeProc = dummy.freeProc;
  1381. X    }
  1382. X    if (flags & TCL_TRACE_DESTROYED) {
  1383. X    ckfree((char *) tvarPtr);
  1384. X    }
  1385. X    return result;
  1386. X}
  1387. X
  1388. X/*
  1389. X *----------------------------------------------------------------------
  1390. X *
  1391. X * Tcl_WhileCmd --
  1392. X *
  1393. X *    This procedure is invoked to process the "while" Tcl command.
  1394. X *    See the user documentation for details on what it does.
  1395. X *
  1396. X * Results:
  1397. X *    A standard Tcl result.
  1398. X *
  1399. X * Side effects:
  1400. X *    See the user documentation.
  1401. X *
  1402. X *----------------------------------------------------------------------
  1403. X */
  1404. X
  1405. X    /* ARGSUSED */
  1406. Xint
  1407. XTcl_WhileCmd(dummy, interp, argc, argv)
  1408. X    ClientData dummy;            /* Not used. */
  1409. X    Tcl_Interp *interp;            /* Current interpreter. */
  1410. X    int argc;                /* Number of arguments. */
  1411. X    char **argv;            /* Argument strings. */
  1412. X{
  1413. X    int result, value;
  1414. X
  1415. X    if (argc != 3) {
  1416. X    Tcl_AppendResult(interp, "wrong # args: should be \"",
  1417. X        argv[0], " test command\"", (char *) NULL);
  1418. X    return TCL_ERROR;
  1419. X    }
  1420. X
  1421. X    while (1) {
  1422. X    result = Tcl_ExprBoolean(interp, argv[1], &value);
  1423. X    if (result != TCL_OK) {
  1424. X        return result;
  1425. X    }
  1426. X    if (!value) {
  1427. X        break;
  1428. X    }
  1429. X    result = Tcl_Eval(interp, argv[2], 0, (char **) NULL);
  1430. X    if (result == TCL_CONTINUE) {
  1431. X        result = TCL_OK;
  1432. X    } else if (result != TCL_OK) {
  1433. X        if (result == TCL_ERROR) {
  1434. X        char msg[60];
  1435. X        sprintf(msg, "\n    (\"while\" body line %d)",
  1436. X            interp->errorLine);
  1437. X        Tcl_AddErrorInfo(interp, msg);
  1438. X        }
  1439. X        break;
  1440. X    }
  1441. X    }
  1442. X    if (result == TCL_BREAK) {
  1443. X    result = TCL_OK;
  1444. X    }
  1445. X    if (result == TCL_OK) {
  1446. X    Tcl_ResetResult(interp);
  1447. X    }
  1448. X    return result;
  1449. X}
  1450. END_OF_FILE
  1451. if test 35722 -ne `wc -c <'tcl6.1/tclCmdMZ.c'`; then
  1452.     echo shar: \"'tcl6.1/tclCmdMZ.c'\" unpacked with wrong size!
  1453. fi
  1454. # end of 'tcl6.1/tclCmdMZ.c'
  1455. fi
  1456. echo shar: End of archive 28 \(of 33\).
  1457. cp /dev/null ark28isdone
  1458. MISSING=""
  1459. for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 ; do
  1460.     if test ! -f ark${I}isdone ; then
  1461.     MISSING="${MISSING} ${I}"
  1462.     fi
  1463. done
  1464. if test "${MISSING}" = "" ; then
  1465.     echo You have unpacked all 33 archives.
  1466.     rm -f ark[1-9]isdone ark[1-9][0-9]isdone
  1467. else
  1468.     echo You still need to unpack the following archives:
  1469.     echo "        " ${MISSING}
  1470. fi
  1471. ##  End of shell archive.
  1472. exit 0
  1473.  
  1474. exit 0 # Just in case...
  1475. -- 
  1476. Kent Landfield                   INTERNET: kent@sparky.IMD.Sterling.COM
  1477. Sterling Software, IMD           UUCP:     uunet!sparky!kent
  1478. Phone:    (402) 291-8300         FAX:      (402) 291-4362
  1479. Please send comp.sources.misc-related mail to kent@uunet.uu.net.
  1480.