home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1993 #3 / NN_1993_3.iso / spool / comp / lang / tcl / 2480 < prev    next >
Encoding:
Text File  |  1993-01-27  |  7.9 KB  |  336 lines
  1. Newsgroups: comp.lang.tcl
  2. Path: sparky!uunet!enterpoop.mit.edu!ira.uka.de!gmd.de!eddy!olav
  3. From: olav@eddy.gmd.de (Olav Schettler)
  4. Subject: Re: interp module source
  5. Message-ID: <1993Jan27.090042.24378@gmd.de>
  6. Sender: news@gmd.de (USENET News)
  7. Nntp-Posting-Host: eddy
  8. Organization: GMD, Sankt Augustin, Germany
  9. X-Newsreader: Tin 1.1 PL5
  10. References: <1993Jan26.183003.6215@twg.com>
  11. Date: Wed, 27 Jan 1993 09:00:42 GMT
  12. Lines: 322
  13.  
  14. I have done a more simplistic version of an `interp'-command which
  15. just modifies main.c:
  16.  
  17. Have fun,
  18. --
  19.           Olav Schettler
  20.  
  21.              GMD-SET
  22.           P.O. Box 1316                  phone: +49 (2241) 14-2291
  23.       Schloss Birlinghoven               fax:   +49 (2241) 14-2242
  24. D-5205 Sankt Augustin 1, Germany         email: Olav@GMD.de
  25.  
  26.  
  27. /* 
  28.  * main.c --
  29.  *
  30.  *    A simple program to test the toolkit facilities.
  31.  *
  32.  * Copyright 1990-1992 Regents of the University of California.
  33.  * Permission to use, copy, modify, and distribute this
  34.  * software and its documentation for any purpose and without
  35.  * fee is hereby granted, provided that the above copyright
  36.  * notice appear in all copies.  The University of California
  37.  * makes no representations about the suitability of this
  38.  * software for any purpose.  It is provided "as is" without
  39.  * express or implied warranty.
  40.  *
  41.  * (C) by Olav Schettler (olav@gmd.de), Jan 25, 1993:
  42.  *  Derived from tk2.3: I have split off the stuff to create an interpreter
  43.  *  and use it to provide an additional command `interp' to create new
  44.  *  interpreters. These interpreters are just plain tcl-interpreter except
  45.  *  that they have their `exit'-command replaced by a more harmless version
  46.  *  Interpreters thus created can be manipulated in the usual way using
  47.  *  `send'-commands
  48.  *
  49.  * # From a desktop program where I use the interp-command:
  50.  * set types(group) {
  51.  *    group.bm
  52.  *    {
  53.  *     set group %s
  54.  *     set name %s
  55.  *     interp $name 
  56.  *     send $name "set group $group"
  57.  *     send $name "source tcl/desk.tcl"
  58.  *    }
  59.  * }
  60.  */
  61.  
  62. #ifndef lint
  63. static char rcsid[] = "$Header: /user6/ouster/wish/RCS/main.c,v 1.68 92/05/07 08:52:02 ouster Exp $ SPRITE (Berkeley)";
  64. #endif
  65.  
  66. #include "tkConfig.h"
  67. #include "tkInt.h"
  68.  
  69. /*
  70.  * Declarations for library procedures:
  71.  */
  72.  
  73. extern int isatty();
  74.  
  75. /*
  76.  * Command used to initialize wish:
  77.  */
  78.  
  79. char initCmd[] = "source $tk_library/wish.tcl";
  80.  
  81. Tk_TimerToken timeToken = 0;
  82. int idleHandler = 0;
  83. Tcl_CmdBuf buffer;
  84. int tty;
  85. extern void Tk_AddDragDropCmd _ANSI_ARGS_((Tcl_Interp *interp, Tk_Window tkwin));
  86. extern void init_interp _ANSI_ARGS_((Tcl_Interp *interp));
  87. extern int Tk_SquareCmd _ANSI_ARGS_((ClientData clientData,
  88.     Tcl_Interp *interp, int argc, char **argv));
  89.  
  90. /*
  91.  * Information for testing out command-line options:
  92.  */
  93.  
  94. char *fileName = NULL;
  95. char *name = NULL;
  96. char *display = NULL;
  97.  
  98. Tk_ArgvInfo argTable[] = {
  99.     {"-file", TK_ARGV_STRING, (char *) NULL, (char *) &fileName,
  100.     "File from which to read commands"},
  101.     {"-display", TK_ARGV_STRING, (char *) NULL, (char *) &display,
  102.     "Display to use"},
  103.     {"-name", TK_ARGV_STRING, (char *) NULL, (char *) &name,
  104.     "Name to use for application"},
  105.     {(char *) NULL, TK_ARGV_END, (char *) NULL, (char *) NULL,
  106.     (char *) NULL}
  107. };
  108.  
  109.     /* ARGSUSED */
  110. void
  111. StdinProc(clientData, mask)
  112.     ClientData clientData;
  113.     int mask;
  114. {
  115.     char line[200];
  116.     static int gotPartial = 0;
  117.     char *cmd;
  118.     int result;
  119.  
  120.     if (mask & TK_READABLE) {
  121.     if (fgets(line, 200, stdin) == NULL) {
  122.         if (!gotPartial) {
  123.         if (tty) {
  124.             Tcl_Eval((Tcl_Interp *) clientData, "destroy .", 0, (char **) NULL);
  125.             exit(0);
  126.         } else {
  127.             Tk_DeleteFileHandler(0);
  128.         }
  129.         return;
  130.         } else {
  131.         line[0] = 0;
  132.         }
  133.     }
  134.     cmd = Tcl_AssembleCmd(buffer, line);
  135.     if (cmd == NULL) {
  136.         gotPartial = 1;
  137.         return;
  138.     }
  139.     gotPartial = 0;
  140.     result = Tcl_RecordAndEval((Tcl_Interp *) clientData, cmd, 0);
  141.     if (((Tcl_Interp *) clientData)->result != 0) {
  142.         if ((result != TCL_OK) || (tty)) {
  143.         printf("%s\n", ((Tcl_Interp *) clientData)->result);
  144.         }
  145.     }
  146.     if (tty) {
  147.         printf("dish: ");
  148.         fflush(stdout);
  149.     }
  150.     }
  151. }
  152.  
  153.     /* ARGSUSED */
  154. void
  155. StructureProc(clientData, eventPtr)
  156.     ClientData clientData;    /* Information about window. */
  157.     XEvent *eventPtr;        /* Information about event. */
  158. {
  159.     if (eventPtr->type == DestroyNotify) {
  160.     (Tk_Window) clientData = NULL;
  161.     }
  162. }
  163.  
  164. /*
  165.  * Procedure to map initial window.  This is invoked as a do-when-idle
  166.  * handler.  Wait for all other when-idle handlers to be processed
  167.  * before mapping the window, so that the window's correct geometry
  168.  * has been determined.
  169.  */
  170.  
  171.     /* ARGSUSED */
  172. void
  173. DelayedMap(clientData)
  174.     ClientData clientData;
  175. {
  176.  
  177.     while (Tk_DoOneEvent(TK_IDLE_EVENTS) != 0) {
  178.     /* Empty loop body. */
  179.     }
  180.     if (clientData == NULL) {
  181.     return;
  182.     }
  183.     Tk_MapWindow((Tk_Window) clientData);
  184. }
  185.  
  186. Tcl_Interp *
  187. Tk_NewInterp (name, argc, argv)
  188. char *name;
  189. int argc;
  190. char **argv;
  191. {
  192.   Tk_Window w;            /* NULL means window has been deleted. */
  193.   Tcl_Interp *interp;
  194.   char *args;
  195.   char buf[20];
  196.   int result;
  197.   Tk_3DBorder border;
  198.   int InterpCmd();
  199.  
  200.   interp = Tcl_CreateInterp();
  201. #ifdef TCL_MEM_DEBUG
  202.   Tcl_InitMemory(interp);
  203. #endif
  204.   w = Tk_CreateMainWindow(interp, display, name);
  205.   if (w == NULL) {
  206.     return interp;
  207.   }
  208.   Tk_SetClass(w, "Tk");
  209.   Tk_CreateEventHandler(w, StructureNotifyMask, StructureProc,
  210.         (ClientData) w);
  211.   Tk_DoWhenIdle(DelayedMap, (ClientData) w);
  212.  
  213.   args = Tcl_Merge(argc-1, argv+1);
  214.   Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
  215.   ckfree(args);
  216.   sprintf(buf, "%d", argc-1);
  217.   Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY);
  218.  
  219.   Tk_GeometryRequest(w, 200, 200);
  220.   border = Tk_Get3DBorder(interp, w, None, "#4eee94");
  221.   if (border == NULL) {
  222.     Tcl_SetResult(interp, (char *) NULL, TCL_STATIC);
  223.     Tk_SetWindowBackground(w, WhitePixelOfScreen(Tk_Screen(w)));
  224.   } else {
  225.     Tk_SetBackgroundFromBorder(w, border);
  226.   }
  227.   XSetForeground(Tk_Display(w), DefaultGCOfScreen(Tk_Screen(w)),
  228.         BlackPixelOfScreen(Tk_Screen(w)));
  229.  
  230.   /*
  231.    * Add multiple interpreter support
  232.    */
  233.   Tcl_CreateCommand(interp, "interp", InterpCmd, (ClientData) NULL,
  234.     (Tcl_CmdDeleteProc *) NULL);
  235.  
  236.   result = Tcl_Eval(interp, initCmd, 0, (char **) NULL);
  237.  
  238.   return interp;
  239. }
  240.  
  241.     /* ARGSUSED */
  242. int
  243. ExitInterpCmd(dummy, interp, argc, argv)
  244.     ClientData *dummy;
  245.     Tcl_Interp *interp;
  246.     int argc;
  247.     char **argv;
  248. {
  249.     Tcl_Eval(interp, "destroy .", 0, (char **) NULL);
  250.     Tcl_DeleteInterp(interp);
  251.  
  252.     return TCL_OK;
  253. }
  254.  
  255.     /* ARGSUSED */
  256. int
  257. InterpCmd(dummy, interp, argc, argv)
  258.     ClientData dummy;
  259.     Tcl_Interp *interp;
  260.     int argc;
  261.     char **argv;
  262. {
  263.     Tcl_Interp *newInterp;
  264.     if (argc < 1) {
  265.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  266.         " name ?args ...?\"", (char *) NULL);
  267.     return TCL_ERROR;
  268.     }
  269.     newInterp = Tk_NewInterp(argv[1], argc-2, argv+2);
  270.     Tcl_CreateCommand(newInterp, "exit", ExitInterpCmd,
  271.        (ClientData) NULL,
  272.          (Tcl_CmdDeleteProc *) NULL);
  273.  
  274.     return TCL_OK;
  275. }
  276.  
  277. int
  278. main (argc, argv)
  279. int argc;
  280. char **argv;
  281. {
  282.   Tcl_Interp *interp;
  283.   char *p, *msg;
  284.   int result;
  285.   
  286.   if (Tk_ParseArgv(interp, (Tk_Window) NULL, &argc, argv, argTable, 0)
  287.         != TCL_OK) {
  288.     goto error;
  289.   }
  290.   if (name == NULL) {
  291.     if (fileName != NULL) {
  292.         p = fileName;
  293.     } else {
  294.         p = argv[0];
  295.     }
  296.     name = strrchr(p, '/');
  297.     if (name != NULL) {
  298.         name++;
  299.     } else {
  300.         name = p;
  301.     }
  302.   }
  303.   interp = Tk_NewInterp (name, argc, argv);
  304.   if (fileName != NULL) {
  305.     result = Tcl_VarEval(interp, "source ", fileName, (char *) NULL);
  306.     if (result != TCL_OK) {
  307.         goto error;
  308.     }
  309.     tty = 0;
  310.   } else {
  311.     tty = isatty(0);
  312.     Tk_CreateFileHandler(0, TK_READABLE, StdinProc, (ClientData) interp);
  313.     if (tty) {
  314.         printf("dish: ");
  315.     }
  316.   }
  317.   fflush(stdout);
  318.   buffer = Tcl_CreateCmdBuf();
  319.   (void) Tcl_Eval(interp, "update", 0, (char **) NULL);
  320.  
  321.   Tk_MainLoop();
  322.   Tcl_DeleteInterp(interp);
  323.   Tcl_DeleteCmdBuf(buffer);
  324.   exit (0);
  325.  
  326. error:
  327.   msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
  328.   if (msg == NULL) {
  329.     msg = interp->result;
  330.   }
  331.   fprintf(stderr, "%s\n", msg);
  332.   Tcl_Eval(interp, "destroy .", 0, (char **) NULL);
  333.   exit (-1);
  334. }
  335.  
  336.