home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.0 / stk-3 / blt-for-STk-3.0 / blt-1.9 / src / bltWatch.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-07-01  |  26.5 KB  |  984 lines
  1. /*
  2.  * bltWatch.c --
  3.  *
  4.  *     This module implements watch procedure callbacks for Tcl
  5.  *    commands and procedures.
  6.  *
  7.  * Copyright 1994 by AT&T Bell Laboratories.
  8.  * Permission to use, copy, modify, and distribute this software
  9.  * and its documentation for any purpose and without fee is hereby
  10.  * granted, provided that the above copyright notice appear in all
  11.  * copies and that both that the copyright notice and warranty
  12.  * disclaimer appear in supporting documentation, and that the
  13.  * names of AT&T Bell Laboratories any of their entities not be used
  14.  * in advertising or publicity pertaining to distribution of the
  15.  * software without specific, written prior permission.
  16.  *
  17.  * AT&T disclaims all warranties with regard to this software, including
  18.  * all implied warranties of merchantability and fitness.  In no event
  19.  * shall AT&T be liable for any special, indirect or consequential
  20.  * damages or any damages whatsoever resulting from loss of use, data
  21.  * or profits, whether in an action of contract, negligence or other
  22.  * tortuous action, arising out of or in connection with the use or
  23.  * performance of this software.
  24.  *
  25.  * "blt_watch" command created by George Howlett.
  26.  */
  27.  
  28. #include "blt.h"
  29.  
  30. #ifndef WATCH_VERSION
  31. #define WATCH_VERSION         "1.0"
  32. #endif
  33.  
  34. #define UNKNOWN_RETURN_CODE    5
  35. static char *codeNames[] =
  36. {
  37.     "OK", "ERROR", "RETURN", "BREAK", "CONTINUE"
  38. };
  39.  
  40. #ifndef TK_VERSION
  41. /*
  42.  *----------------------------------------------------------------------
  43.  *
  44.  * The following was pulled from tkGet.c so that watches could
  45.  * be used with code which does not include the Tk library.
  46.  *
  47.  *----------------------------------------------------------------------
  48.  */
  49. typedef char *Tk_Uid;
  50.  
  51. /*
  52.  * The hash table below is used to keep track of all the Tk_Uids created
  53.  * so far.
  54.  */
  55.  
  56. static Tcl_HashTable uidTable;
  57. static int initialized = 0;
  58.  
  59. /*
  60.  *----------------------------------------------------------------------
  61.  *
  62.  * Tk_GetUid --
  63.  *
  64.  *    Given a string, this procedure returns a unique identifier
  65.  *    for the string.
  66.  *
  67.  * Results:
  68.  *    This procedure returns a Tk_Uid corresponding to the "string"
  69.  *    argument.  The Tk_Uid has a string value identical to string
  70.  *    (strcmp will return 0), but it's guaranteed that any other
  71.  *    calls to this procedure with a string equal to "string" will
  72.  *    return exactly the same result (i.e. can compare Tk_Uid
  73.  *    *values* directly, without having to call strcmp on what they
  74.  *    point to).
  75.  *
  76.  * Side effects:
  77.  *    New information may be entered into the identifier table.
  78.  *
  79.  *----------------------------------------------------------------------
  80.  */
  81.  
  82. Tk_Uid
  83. Tk_GetUid(string)
  84.     char *string;        /* String to convert. */
  85. {
  86.     int dummy;
  87.  
  88.     if (!initialized) {
  89.     Tcl_InitHashTable(&uidTable, TCL_STRING_KEYS);
  90.     initialized = 1;
  91.     }
  92.     return (Tk_Uid) Tcl_GetHashKey(&uidTable,
  93.     Tcl_CreateHashEntry(&uidTable, string, &dummy));
  94. }
  95.  
  96. #endif /* TK_VERSION */
  97.  
  98. #define WATCH_MAX_LEVEL    10000    /* Maximum depth of Tcl traces. */
  99.  
  100. enum WatchStates {
  101.     WATCH_STATE_DONT_CARE = -1,    /* Select watch regardless of state */
  102.     WATCH_STATE_IDLE = 0,    /*  */
  103.     WATCH_STATE_ACTIVE = 1
  104. };
  105.  
  106. typedef struct {
  107.     Tcl_Interp *interp;        /* Interpreter associated with the watch */
  108.     Tk_Uid nameId;        /* Watch identifier */
  109.  
  110.     /* User-configurable fields */
  111.     enum WatchStates state;    /* Current state of watch: either
  112.                  * WATCH_STATE_IDLE or WATCH_STATE_ACTIVE */
  113.     int maxLevel;        /* Maximum depth of tracing allowed */
  114.     char *preCmd;        /* Name of the procedure to be called
  115.                  * before the command is invoked (but
  116.                  * after substitutions). */
  117.     char *postCmd;        /* Name of the procedure to be called
  118.                  * after the command executes. */
  119.  
  120.  
  121.     Tcl_Trace trace;        /* Trace handler which activates "pre"
  122.                  * command procedures */
  123.     Tcl_AsyncHandler asyncHandle;    /* Async handler which triggers the
  124.                  * "post" command procedure (if one
  125.                  * exists) */
  126.     int active;            /* Indicates if a trace is currently
  127.                  * active.  This prevents recursive
  128.                  * tracing of the "pre" and "post"
  129.                  * procedures. */
  130.     int level;            /* Current level of traced command. */
  131.     char *cmdPtr;        /* Command string before
  132.                  * substitions. Points to a original
  133.                  * command buffer. */
  134.     char *args;            /* Tcl list of the command after
  135.                  * substitutions. List is malloc-ed by
  136.                  * Tcl_Merge. Must be freed in handler
  137.                  * procs */
  138. } Watch;
  139.  
  140. typedef struct {
  141.     Tk_Uid nameId;        /* Name identifier of the watch */
  142.     Tcl_Interp *interp;        /* Interpreter associated with the
  143.                  * watch */
  144. } WatchKey;
  145.  
  146. static Tcl_HashTable watchTable;
  147.  
  148. /*
  149.  *----------------------------------------------------------------------
  150.  *
  151.  * PreCmdProc --
  152.  *
  153.  *    Procedure callback for Tcl_Trace. Gets called before the
  154.  *     command is executed, but after substitutions have occurred.
  155.  *    If a watch procedure is active, it evals a Tcl command.
  156.  *    Activates the "precmd" callback, if one exists.
  157.  *
  158.  *    Stashes some information for the "pre" callback: command
  159.  *    string, substituted argument list, and current level.
  160.  *
  161.  *     Format of "pre" proc:
  162.  *
  163.  *     proc beforeCmd { level cmdStr argList } {
  164.  *
  165.  *     }
  166.  *
  167.  *
  168.  * Results:
  169.  *    None.
  170.  *
  171.  * Side Effects:
  172.  *    A Tcl_AsyncHandler may be triggered, if a "post" procedure is
  173.  *    defined.
  174.  *
  175.  *----------------------------------------------------------------------
  176.  */
  177. /*ARGSUSED*/
  178. static void
  179. PreCmdProc(clientData, interp, level, command, cmdProc, cmdClientData,
  180.     argc, argv)
  181.     ClientData clientData;    /* not used */
  182.     Tcl_Interp *interp;        /* not used */
  183.     int level;            /* Current level */
  184.     char *command;        /* Command before substitution */
  185.     int (*cmdProc) ();        /* not used */
  186.     ClientData cmdClientData;    /* not used */
  187.     int argc;
  188.     char **argv;        /* Command after parsing, but before
  189.                  * evaluation */
  190. {
  191.     Watch *watchPtr = (Watch *) clientData;
  192.  
  193.     if (((watchPtr->preCmd == NULL) && (watchPtr->postCmd == NULL)) ||
  194.     (watchPtr->active)) {
  195.     return;            /* Don't re-enter from Tcl_Eval below */
  196.     }
  197.     watchPtr->cmdPtr = command;
  198.     watchPtr->level = level;
  199.     /*
  200.      * There's no guarantee that the calls to PreCmdProc will match
  201.      * up with PostCmdProc.  So free up argument lists that are still
  202.      * hanging around before allocating a new one.
  203.      */
  204.     if (watchPtr->args != NULL) {
  205.     free((char *)watchPtr->args);
  206.     }
  207.     watchPtr->args = Tcl_Merge(argc, argv);
  208.  
  209.     if (watchPtr->preCmd != NULL) {
  210.     Tcl_DString buffer;
  211.     char string[200];
  212.     int status;
  213.  
  214.     /* Create the "pre" command procedure call */
  215.  
  216.     Tcl_DStringInit(&buffer);
  217.     Tcl_DStringAppendElement(&buffer, watchPtr->preCmd);
  218.     sprintf(string, "%d", watchPtr->level);
  219.     Tcl_DStringAppendElement(&buffer, string);
  220.     Tcl_DStringAppendElement(&buffer, watchPtr->cmdPtr);
  221.     Tcl_DStringAppendElement(&buffer, watchPtr->args);
  222.  
  223.     watchPtr->active = 1;
  224.     status = Tcl_Eval(interp, Tcl_DStringValue(&buffer));
  225.     watchPtr->active = 0;
  226.  
  227.     Tcl_DStringFree(&buffer);
  228.     if (status != TCL_OK) {
  229.         fprintf(stderr, "%s failed: %s\n", watchPtr->preCmd,
  230.         interp->result);
  231.     }
  232.     }
  233.     /* Set trigger for the "post" command procedure */
  234.     if (watchPtr->postCmd != NULL) {
  235.     Tcl_AsyncMark(watchPtr->asyncHandle);
  236.     }
  237. }
  238.  
  239. /*
  240.  *----------------------------------------------------------------------
  241.  *
  242.  * PostCmdProc --
  243.  *
  244.  *    Procedure callback for Tcl_AsyncHandler. Gets called after
  245.  *    the command has executed.  We test for a "post" command, but
  246.  *    you really can't get here, if one doen't exist.
  247.  *
  248.  *    Save the current contents of interp->result before calling
  249.  *    the "post" command, and restore it afterwards.
  250.  *
  251.  *     Format of "post" proc:
  252.  *
  253.  *     proc afterCmd { level cmdStr argList retCode results } {
  254.  *
  255.  *    }
  256.  *
  257.  * Results:
  258.  *    None.
  259.  *
  260.  * Side Effects:
  261.  *    Memory for argument list is released.
  262.  *
  263.  *----------------------------------------------------------------------
  264.  */
  265. /*ARGSUSED*/
  266. static int
  267. PostCmdProc(clientData, interp, code)
  268.     ClientData clientData;    /* not used */
  269.     Tcl_Interp *interp;        /* not used */
  270.     int code;            /* Completion code of command */
  271. {
  272.     Watch *watchPtr = (Watch *) clientData;
  273.  
  274.     if (watchPtr->active) {
  275.     return code;
  276.     }
  277.     if (watchPtr->postCmd != NULL) {
  278.     int status;
  279.     Tcl_DString buffer;
  280.     char string[200];
  281.     char *results;
  282.     char *retCode;
  283.     char *errorCode, *errorInfo;
  284.     errorInfo = errorCode = NULL;
  285.  
  286.     results = "NO INTERPRETER AVAILABLE";
  287.  
  288.     /*
  289.      * ----------------------------------------------------
  290.      *
  291.      * Save the state of the interpreter.
  292.      *
  293.      * ----------------------------------------------------
  294.      */
  295.     if (interp != NULL) {
  296.         errorInfo = Tcl_GetVar2(interp, "errorInfo", (char *)NULL,
  297.         TCL_GLOBAL_ONLY);
  298.         if (errorInfo != NULL) {
  299.         errorInfo = strdup(errorInfo);
  300.         }
  301.         errorCode = Tcl_GetVar2(interp, "errorCode", (char *)NULL,
  302.         TCL_GLOBAL_ONLY);
  303.         if (errorCode != NULL) {
  304.         errorCode = strdup(errorCode);
  305.         }
  306.         results = strdup(interp->result);
  307.     }
  308.     /* Create the "post" command procedure call */
  309.     Tcl_DStringInit(&buffer);
  310.     Tcl_DStringAppendElement(&buffer, watchPtr->postCmd);
  311.     sprintf(string, "%d", watchPtr->level);
  312.     Tcl_DStringAppendElement(&buffer, string);
  313.     Tcl_DStringAppendElement(&buffer, watchPtr->cmdPtr);
  314.     Tcl_DStringAppendElement(&buffer, watchPtr->args);
  315.     if (code < UNKNOWN_RETURN_CODE) {
  316.         retCode = codeNames[code];
  317.     } else {
  318.         sprintf(string, "%d", code);
  319.         retCode = string;
  320.     }
  321.     Tcl_DStringAppendElement(&buffer, retCode);
  322.     Tcl_DStringAppendElement(&buffer, results);
  323.  
  324.     watchPtr->active = 1;
  325.     status = Tcl_Eval(watchPtr->interp, Tcl_DStringValue(&buffer));
  326.     watchPtr->active = 0;
  327.  
  328.     Tcl_DStringFree(&buffer);
  329.     free((char *)watchPtr->args);
  330.     watchPtr->args = NULL;
  331.  
  332.     if (status != TCL_OK) {
  333.         fprintf(stderr, "%s failed: %s\n", watchPtr->postCmd,
  334.         watchPtr->interp->result);
  335.     }
  336.     /*
  337.      * ----------------------------------------------------
  338.      *
  339.      * Restore the state of the interpreter.
  340.      *
  341.      * ----------------------------------------------------
  342.      */
  343.     if (interp != NULL) {
  344.         if (errorInfo != NULL) {
  345.         Tcl_SetVar2(interp, "errorInfo", (char *)NULL, errorInfo,
  346.             TCL_GLOBAL_ONLY);
  347.         free((char *)errorInfo);
  348.         }
  349.         if (errorCode != NULL) {
  350.         Tcl_SetVar2(interp, "errorCode", (char *)NULL, errorCode,
  351.             TCL_GLOBAL_ONLY);
  352.         free((char *)errorCode);
  353.         }
  354.         Tcl_SetResult(interp, results, TCL_DYNAMIC);
  355.     }
  356.     }
  357.     return code;
  358. }
  359.  
  360. /*
  361.  *----------------------------------------------------------------------
  362.  *
  363.  * NewWatch --
  364.  *
  365.  *    Creates a new watch. Uses the nameId and interpreter
  366.  *    address to create a unique hash key.  The new watch is
  367.  *    registered into the "watchTable" hash table. Also creates a
  368.  *    Tcl_AsyncHandler for triggering "post" events.
  369.  *
  370.  * Results:
  371.  *    If memory for the watch could be allocated, a pointer to
  372.  *    the new watch is returned.  Otherwise NULL, and interp->result
  373.  *    points to an error message.
  374.  *
  375.  * Side Effects:
  376.  *    A new Tcl_AsyncHandler is created. A new hash table entry
  377.  *    is created. Memory the watch structure is allocated.
  378.  *
  379.  *----------------------------------------------------------------------
  380.  */
  381. static Watch *
  382. NewWatch(interp, nameId)
  383.     Tcl_Interp *interp;
  384.     Tk_Uid nameId;
  385. {
  386.     Watch *watchPtr;
  387.     WatchKey key;
  388.     Tcl_HashEntry *entryPtr;
  389.     int dummy;
  390.  
  391.     watchPtr = (Watch *) malloc(sizeof(Watch));
  392.     if (watchPtr == NULL) {
  393.     interp->result = "can't allocate watch structure";
  394.     return NULL;
  395.     }
  396.     watchPtr->state = WATCH_STATE_ACTIVE;
  397.     watchPtr->trace = (Tcl_Trace) 0;
  398.     watchPtr->args = NULL;
  399.     watchPtr->preCmd = NULL;
  400.     watchPtr->postCmd = NULL;
  401.     watchPtr->level = 0;
  402.     watchPtr->active = 0;
  403.     watchPtr->maxLevel = WATCH_MAX_LEVEL;
  404.     watchPtr->nameId = nameId;
  405.     watchPtr->interp = interp;
  406.     watchPtr->asyncHandle = Tcl_AsyncCreate(PostCmdProc, (ClientData)watchPtr);
  407.     key.interp = interp;
  408.     key.nameId = nameId;
  409.     entryPtr = Tcl_CreateHashEntry(&watchTable, (char *)&key, &dummy);
  410.     Tcl_SetHashValue(entryPtr, (ClientData)watchPtr);
  411.     return watchPtr;
  412. }
  413.  
  414. /*
  415.  *----------------------------------------------------------------------
  416.  *
  417.  * DestroyWatch --
  418.  *
  419.  *    Removes the watch. The resources used by the watch
  420.  *    are released.
  421.  *      1) If the watch is active, its trace is deleted.
  422.  *      2) Memory for command strings is free-ed.
  423.  *      3) Entry is removed from watch registry.
  424.  *      4) Async handler is deleted.
  425.  *      5) Memory for watch itself is released.
  426.  *
  427.  * Results:
  428.  *    None.
  429.  *
  430.  * Side Effects:
  431.  *    Everything associated with the watch is freed.
  432.  *
  433.  *----------------------------------------------------------------------
  434.  */
  435. static void
  436. DestroyWatch(watchPtr)
  437.     Watch *watchPtr;
  438. {
  439.     WatchKey key;
  440.     Tcl_HashEntry *entryPtr;
  441.  
  442.     Tcl_AsyncDelete(watchPtr->asyncHandle);
  443.     if (watchPtr->state == WATCH_STATE_ACTIVE) {
  444.     Tcl_DeleteTrace(watchPtr->interp, watchPtr->trace);
  445.     }
  446.     if (watchPtr->preCmd != NULL) {
  447.     free((char *)watchPtr->preCmd);
  448.     }
  449.     if (watchPtr->postCmd != NULL) {
  450.     free((char *)watchPtr->postCmd);
  451.     }
  452.     if (watchPtr->args != NULL) {
  453.     free((char *)watchPtr->args);
  454.     }
  455.     key.interp = watchPtr->interp;
  456.     key.nameId = watchPtr->nameId;
  457.     entryPtr = Tcl_FindHashEntry(&watchTable, (char *)&key);
  458.     Tcl_DeleteHashEntry(entryPtr);
  459.     free((char *)watchPtr);
  460. }
  461.  
  462. /*
  463.  *----------------------------------------------------------------------
  464.  *
  465.  * FindWatch --
  466.  *
  467.  *    Searches for the watch represented by the watch name and its
  468.  *    associated interpreter in its directory.
  469.  *
  470.  * Results:
  471.  *    If found, the pointer to the watch structure is returned,
  472.  *    otherwise NULL. If requested, interp-result will be filled
  473.  *    with an error message.
  474.  *
  475.  *----------------------------------------------------------------------
  476.  */
  477. static Watch *
  478. FindWatch(interp, nameId, flags)
  479.     Tcl_Interp *interp;
  480.     Tk_Uid nameId;
  481.     unsigned int flags;
  482. {
  483.     WatchKey key;
  484.     Tcl_HashEntry *entryPtr;
  485.  
  486.     key.interp = interp;
  487.     key.nameId = nameId;
  488.     entryPtr = Tcl_FindHashEntry(&watchTable, (char *)&key);
  489.     if (entryPtr == NULL) {
  490.     if (flags & TCL_LEAVE_ERR_MSG) {
  491.         Tcl_AppendResult(interp, "can't find any watch named \"", nameId,
  492.         "\"", (char *)NULL);
  493.     }
  494.     return NULL;
  495.     }
  496.     return (Watch *) Tcl_GetHashValue(entryPtr);
  497. }
  498.  
  499. /*
  500.  *----------------------------------------------------------------------
  501.  *
  502.  * ListWatches --
  503.  *
  504.  *    Creates a list of all watches in the interpreter.  The
  505.  *    list search may be restricted to selected states by
  506.  *    setting "state" to something other than WATCH_STATE_DONT_CARE.
  507.  *
  508.  * Results:
  509.  *    A standard Tcl result.  Interp->result will contain a list
  510.  *    of all watches matches the state criteria.
  511.  *
  512.  *----------------------------------------------------------------------
  513.  */
  514. static int
  515. ListWatches(interp, state)
  516.     Tcl_Interp *interp;
  517.     enum WatchStates state;    /* Active flag */
  518. {
  519.     Tcl_HashEntry *entryPtr;
  520.     Tcl_HashSearch cursor;
  521.     register Watch *watchPtr;
  522.  
  523.     for (entryPtr = Tcl_FirstHashEntry(&watchTable, &cursor);
  524.     entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&cursor)) {
  525.     watchPtr = (Watch *) Tcl_GetHashValue(entryPtr);
  526.     if (watchPtr->interp == interp) {
  527.         if ((state == WATCH_STATE_DONT_CARE) ||
  528.         (state == watchPtr->state)) {
  529.         Tcl_AppendElement(interp, (char *)watchPtr->nameId);
  530.         }
  531.     }
  532.     }
  533.     return TCL_OK;
  534. }
  535.  
  536. /*
  537.  *----------------------------------------------------------------------
  538.  *
  539.  * ConfigWatch --
  540.  *
  541.  *    Processes argument list of switches and values, setting
  542.  *    Watch fields.
  543.  *
  544.  * Results:
  545.  *    If found, the pointer to the watch structure is returned,
  546.  *    otherwise NULL. If requested, interp-result will be filled
  547.  *    with an error message.
  548.  *
  549.  *----------------------------------------------------------------------
  550.  */
  551. static int
  552. ConfigWatch(watchPtr, interp, argc, argv)
  553.     Watch *watchPtr;
  554.     Tcl_Interp *interp;
  555.     int argc;
  556.     char *argv[];
  557. {
  558.     register int i;
  559.     char *swtch;
  560.     int length;
  561.     char c;
  562.  
  563.     for (i = 0; i < argc; i++) {
  564.     length = strlen(argv[i]);
  565.     swtch = argv[i++];
  566.  
  567.     if (*swtch != '-') {
  568.         goto badSwitch;
  569.     }
  570.     c = swtch[1];
  571.     if (i == argc) {
  572.         Tcl_AppendResult(interp, "no argument for \"", swtch, "\"",
  573.         (char *)NULL);
  574.         return TCL_ERROR;
  575.     }
  576.     if ((c == 'p') && (length > 1) &&
  577.         (strncmp(swtch, "-precmd", length) == 0)) {
  578.         if (watchPtr->preCmd != NULL) {
  579.         free((char *)watchPtr->preCmd);
  580.         }
  581.         watchPtr->preCmd = (*argv[i] == '\0') ? NULL : strdup(argv[i]);
  582.     } else if ((c == 'p') && (length > 1) &&
  583.         (strncmp(swtch, "-postcmd", length) == 0)) {
  584.         if (watchPtr->postCmd != NULL) {
  585.         free((char *)watchPtr->postCmd);
  586.         }
  587.         watchPtr->postCmd = (*argv[i] == '\0') ? NULL : strdup(argv[i]);
  588.     } else if ((c == 'a') && (length > 1) &&
  589.         (strncmp(swtch, "-active", length) == 0)) {
  590.         int bool;
  591.  
  592.         if (Tcl_GetBoolean(interp, argv[i], &bool) != TCL_OK) {
  593.         return TCL_ERROR;
  594.         }
  595.         watchPtr->state = (bool) ? WATCH_STATE_ACTIVE : WATCH_STATE_IDLE;
  596.     } else if ((c == 'm') &&
  597.         (strncmp(swtch, "-maxlevel", length) == 0)) {
  598.         int newLevel;
  599.  
  600.         if (Tcl_GetInt(interp, argv[i], &newLevel) != TCL_OK) {
  601.         return TCL_ERROR;
  602.         }
  603.         watchPtr->maxLevel = newLevel;
  604.     } else {
  605.       badSwitch:
  606.         Tcl_AppendResult(interp, "bad switch \"", swtch, "\": ",
  607.         "should be -active, -maxlevel, -precmd or -postcmd",
  608.         (char *)NULL);
  609.         return TCL_ERROR;
  610.     }
  611.     }
  612.     /*
  613.      * If the watch's max depth changed or its state, reset the traces.
  614.      */
  615.     if (watchPtr->trace != (Tcl_Trace) 0) {
  616.     Tcl_DeleteTrace(interp, watchPtr->trace);
  617.     watchPtr->trace = (Tcl_Trace) 0;
  618.     }
  619.     if (watchPtr->state == WATCH_STATE_ACTIVE) {
  620.     watchPtr->trace = Tcl_CreateTrace(interp, watchPtr->maxLevel,
  621.         PreCmdProc, (ClientData)watchPtr);
  622.     }
  623.     return TCL_OK;
  624. }
  625.  
  626. /* Tcl interface routines */
  627. /*
  628.  *----------------------------------------------------------------------
  629.  *
  630.  * CreateWatch --
  631.  *
  632.  *    Creates a new watch and processes any extra switches.
  633.  *
  634.  * Results:
  635.  *    A standard Tcl result.
  636.  *
  637.  * Side Effects:
  638.  *    A new watch is created.
  639.  *
  640.  *----------------------------------------------------------------------
  641.  */
  642. /*ARGSUSED*/
  643. static int
  644. CreateWatch(clientData, interp, argc, argv)
  645.     ClientData clientData;    /* not used */
  646.     Tcl_Interp *interp;
  647.     int argc;
  648.     char **argv;
  649. {
  650.     register Watch *watchPtr;
  651.     Tk_Uid nameId;
  652.  
  653.     if (argc < 3) {
  654.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  655.         " create name ?switches?\"", (char *)NULL);
  656.     return TCL_ERROR;
  657.     }
  658.     nameId = Tk_GetUid(argv[2]);
  659.     watchPtr = FindWatch(interp, nameId, 0);
  660.     if (watchPtr != NULL) {
  661.     Tcl_AppendResult(interp, "a watch \"", argv[2], "\" already exists",
  662.         (char *)NULL);
  663.     return TCL_ERROR;
  664.     }
  665.     watchPtr = NewWatch(interp, nameId);
  666.     if (watchPtr == NULL) {
  667.     return TCL_ERROR;    /* Can't create new watch */
  668.     }
  669.     return (ConfigWatch(watchPtr, interp, argc - 3, argv + 3));
  670. }
  671.  
  672. /*
  673.  *----------------------------------------------------------------------
  674.  *
  675.  * DeleteWatch --
  676.  *
  677.  *    Deletes the watch.
  678.  *
  679.  * Results:
  680.  *    A standard Tcl result.
  681.  *
  682.  *----------------------------------------------------------------------
  683.  */
  684. /*ARGSUSED*/
  685. static int
  686. DeleteWatch(clientData, interp, argc, argv)
  687.     ClientData clientData;    /* not used */
  688.     Tcl_Interp *interp;
  689.     int argc;
  690.     char **argv;
  691. {
  692.     register Watch *watchPtr;
  693.     Tk_Uid nameId;
  694.  
  695.     if (argc != 3) {
  696.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  697.         " delete name\"", (char *)NULL);
  698.     return TCL_ERROR;
  699.     }
  700.     nameId = Tk_GetUid(argv[2]);
  701.     watchPtr = FindWatch(interp, nameId, TCL_LEAVE_ERR_MSG);
  702.     if (watchPtr == NULL) {
  703.     return TCL_ERROR;
  704.     }
  705.     DestroyWatch(watchPtr);
  706.     return TCL_OK;
  707. }
  708.  
  709. /*
  710.  *----------------------------------------------------------------------
  711.  *
  712.  * ActivateWatch --
  713.  *
  714.  *    Activate/deactivates the named watch.
  715.  *
  716.  * Results:
  717.  *    A standard Tcl result.
  718.  *
  719.  *----------------------------------------------------------------------
  720.  */
  721. /*ARGSUSED*/
  722. static int
  723. ActivateWatch(clientData, interp, argc, argv)
  724.     ClientData clientData;    /* not used */
  725.     Tcl_Interp *interp;
  726.     int argc;
  727.     char **argv;
  728. {
  729.     register Watch *watchPtr;
  730.     Tk_Uid nameId;
  731.     enum WatchStates state;
  732.  
  733.     if (argc != 3) {
  734.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  735.         " ", argv[1], "  name\"", (char *)NULL);
  736.     return TCL_ERROR;
  737.     }
  738.     state = (argv[1][0] == 'a') ? WATCH_STATE_ACTIVE : WATCH_STATE_IDLE;
  739.     nameId = Tk_GetUid(argv[2]);
  740.     watchPtr = FindWatch(interp, nameId, TCL_LEAVE_ERR_MSG);
  741.     if (watchPtr == NULL) {
  742.     return TCL_ERROR;
  743.     }
  744.     if (state != watchPtr->state) {
  745.     if (watchPtr->trace == (Tcl_Trace) 0) {
  746.         watchPtr->trace = Tcl_CreateTrace(interp, watchPtr->maxLevel,
  747.         PreCmdProc, (ClientData)watchPtr);
  748.     } else {
  749.         Tcl_DeleteTrace(interp, watchPtr->trace);
  750.         watchPtr->trace = (Tcl_Trace) 0;
  751.     }
  752.     watchPtr->state = state;
  753.     }
  754.     return TCL_OK;
  755. }
  756.  
  757. /*
  758.  *----------------------------------------------------------------------
  759.  *
  760.  * WatchNames --
  761.  *
  762.  *    Returns the names of all watches in the interpreter.
  763.  *
  764.  * Results:
  765.  *    A standard Tcl result.
  766.  *
  767.  *----------------------------------------------------------------------
  768.  */
  769. /*ARGSUSED*/
  770. static int
  771. WatchNames(clientData, interp, argc, argv)
  772.     ClientData clientData;    /* not used */
  773.     Tcl_Interp *interp;
  774.     int argc;
  775.     char **argv;
  776. {
  777.     enum WatchStates state;
  778.  
  779.     if ((argc < 2) && (argc > 3)) {
  780.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  781.         " names ?state?\"", (char *)NULL);
  782.     return TCL_ERROR;
  783.     }
  784.     state = WATCH_STATE_DONT_CARE;
  785.     if (argc == 3) {
  786.     char c;
  787.     c = argv[2][0];
  788.     if ((c == 'a') && (strcmp(argv[2], "active") == 0)) {
  789.         state = WATCH_STATE_ACTIVE;
  790.     } else if ((c == 'i') && (strcmp(argv[2], "idle") == 0)) {
  791.         state = WATCH_STATE_IDLE;
  792.     } else if ((c == 'i') && (strcmp(argv[2], "ignore") == 0)) {
  793.         state = WATCH_STATE_DONT_CARE;
  794.     } else {
  795.         Tcl_AppendResult(interp, "bad state \"", argv[2],
  796.         "\" should be active, idle, or ignore", (char *)NULL);
  797.         return TCL_ERROR;
  798.     }
  799.     }
  800.     return (ListWatches(interp, state));
  801. }
  802.  
  803. /*
  804.  *----------------------------------------------------------------------
  805.  *
  806.  * ConfigureWatch --
  807.  *
  808.  *    Convert the limits of the pixel values allowed into a list.
  809.  *
  810.  * Results:
  811.  *    The string representation of the limits is returned.
  812.  *
  813.  *----------------------------------------------------------------------
  814.  */
  815. /*ARGSUSED*/
  816. static int
  817. ConfigureWatch(clientData, interp, argc, argv)
  818.     ClientData clientData;    /* not used */
  819.     Tcl_Interp *interp;
  820.     int argc;
  821.     char **argv;
  822. {
  823.     register Watch *watchPtr;
  824.     Tk_Uid nameId;
  825.  
  826.     if (argc < 3) {
  827.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  828.         " ", argv[1], "  name ?options...?\"", (char *)NULL);
  829.     return TCL_ERROR;
  830.     }
  831.     nameId = Tk_GetUid(argv[2]);
  832.     watchPtr = FindWatch(interp, nameId, TCL_LEAVE_ERR_MSG);
  833.     if (watchPtr == NULL) {
  834.     return TCL_ERROR;
  835.     }
  836.     return (ConfigWatch(watchPtr, interp, argc - 3, argv + 3));
  837. }
  838.  
  839. /*
  840.  *----------------------------------------------------------------------
  841.  *
  842.  * WatchInfo --
  843.  *
  844.  *    Convert the limits of the pixel values allowed into a list.
  845.  *
  846.  * Results:
  847.  *    The string representation of the limits is returned.
  848.  *
  849.  *----------------------------------------------------------------------
  850.  */
  851. /*ARGSUSED*/
  852. static int
  853. WatchInfo(clientData, interp, argc, argv)
  854.     ClientData clientData;    /* not used */
  855.     Tcl_Interp *interp;
  856.     int argc;
  857.     char **argv;
  858. {
  859.     register Watch *watchPtr;
  860.     Tk_Uid nameId;
  861.     char string[200];
  862.  
  863.     if (argc < 3) {
  864.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  865.         " ", " info name\"", (char *)NULL);
  866.     return TCL_ERROR;
  867.     }
  868.     nameId = Tk_GetUid(argv[2]);
  869.     watchPtr = FindWatch(interp, nameId, TCL_LEAVE_ERR_MSG);
  870.     if (watchPtr == NULL) {
  871.     return TCL_ERROR;
  872.     }
  873.     if (watchPtr->preCmd != NULL) {
  874.     Tcl_AppendResult(interp, "-precmd ", watchPtr->preCmd, " ",
  875.         (char *)NULL);
  876.     }
  877.     if (watchPtr->postCmd != NULL) {
  878.     Tcl_AppendResult(interp, "-postcmd ", watchPtr->postCmd, " ",
  879.         (char *)NULL);
  880.     }
  881.     sprintf(string, "%d", watchPtr->maxLevel);
  882.     Tcl_AppendResult(interp, "-maxlevel ", string, " ", (char *)NULL);
  883.     Tcl_AppendResult(interp, "-active ",
  884.     (watchPtr->state == WATCH_STATE_ACTIVE)
  885.     ? "true" : "false", " ", (char *)NULL);
  886.     return TCL_OK;
  887. }
  888.  
  889. /*
  890.  *--------------------------------------------------------------
  891.  *
  892.  * WatchCmd --
  893.  *
  894.  *    This procedure is invoked to process the Tcl "blt_watch"
  895.  *    command. See the user documentation for details on what
  896.  *    it does.
  897.  *
  898.  * Results:
  899.  *    A standard Tcl result.
  900.  *
  901.  * Side effects:
  902.  *    See the user documentation.
  903.  *
  904.  *--------------------------------------------------------------
  905.  */
  906. /*ARGSUSED*/
  907. static int
  908. WatchCmd(clientData, interp, argc, argv)
  909.     ClientData clientData;    /* not used */
  910.     Tcl_Interp *interp;
  911.     int argc;
  912.     char **argv;
  913. {
  914.     int length;
  915.     char c;
  916.  
  917.     if (argc < 2) {
  918.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  919.         " option name ?switches?\"", (char *)NULL);
  920.     return TCL_ERROR;
  921.     }
  922.     length = strlen(argv[1]);
  923.     c = argv[1][0];
  924.     if ((c == 'a') && (strncmp(argv[1], "activate", length) == 0)) {
  925.     return (ActivateWatch(clientData, interp, argc, argv));
  926.     } else if ((c == 'd') && (length > 2) &&
  927.     (strncmp(argv[1], "deactivate", length) == 0)) {
  928.     return (ActivateWatch(clientData, interp, argc, argv));
  929.     } else if ((c == 'c') &&
  930.     (strncmp(argv[1], "configure", length) == 0)) {
  931.     return (ConfigureWatch(clientData, interp, argc, argv));
  932.     } else if ((c == 'd') && (length > 2) &&
  933.     (strncmp(argv[1], "delete", length) == 0)) {
  934.     return (DeleteWatch(clientData, interp, argc, argv));
  935.     } else if ((c == 'c') && (strncmp(argv[1], "create", length) == 0)) {
  936.     return (CreateWatch(clientData, interp, argc, argv));
  937.     } else if ((c == 'n') && (strncmp(argv[1], "names", length) == 0)) {
  938.     return (WatchNames(clientData, interp, argc, argv));
  939.     } else if ((c == 'i') && (strncmp(argv[1], "info", length) == 0)) {
  940.     return (WatchInfo(clientData, interp, argc, argv));
  941.     } else {
  942.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  943.         "\": should be activate, configure, create, deactivate, or delete",
  944.         (char *)NULL);
  945.     return TCL_ERROR;
  946.     }
  947. }
  948.  
  949. /* Public initialization routine */
  950. /*
  951.  *--------------------------------------------------------------
  952.  *
  953.  * Blt_WatchInit --
  954.  *
  955.  *    This procedure is invoked to initialize the Tcl command
  956.  *    "blt_watch".
  957.  *
  958.  * Results:
  959.  *    None.
  960.  *
  961.  * Side effects:
  962.  *    Creates the new command and adds a new entry into a
  963.  *    global    Tcl associative array.
  964.  *
  965.  *--------------------------------------------------------------
  966.  */
  967. int
  968. Blt_WatchInit(interp)
  969.     Tcl_Interp *interp;
  970. {
  971.     if (Blt_FindCmd(interp, "blt_watch", (ClientData *)NULL) == TCL_OK) {
  972.     Tcl_AppendResult(interp, "\"blt_watch\" command already exists",
  973.         (char *)NULL);
  974.     return TCL_ERROR;
  975.     }
  976.     Tcl_SetVar2(interp, "blt_versions", "blt_watch", WATCH_VERSION,
  977.     TCL_GLOBAL_ONLY);
  978.     Tcl_CreateCommand(interp, "blt_watch", WatchCmd, (ClientData)0,
  979.     (Tcl_CmdDeleteProc *)NULL);
  980.  
  981.     Tcl_InitHashTable(&watchTable, sizeof(WatchKey) / sizeof(int));
  982.     return TCL_OK;
  983. }
  984.