1 /*----------------------------------------------------------------------*/
2 /* tclmagic.c --- Creates the interpreter-wrapped version of magic. */
3 /* */
4 /* Written by Tim Edwards August 2002 */
5 /* */
6 /* Note that this file is tied to Tcl. The original version (from */
7 /* around April 2002) relied on SWIG, the only differences being */
8 /* as few %{ ... %} boundaries and the replacement of the */
9 /* Tclmagic_Init function header with "%init %{", and call the */
10 /* file "tclmagic.i". However, the rest of the associated wrapper */
11 /* code got so dependent on Tcl commands that there is no longer any */
12 /* point in using SWIG. */
13 /* */
14 /* When using SWIG, the Makefile requires: */
15 /* */
16 /* tclmagic.c: tclmagic.i */
17 /* swig -tcl8 -o tclmagic.c tclmagic.i */
18 /* */
19 /*----------------------------------------------------------------------*/
20
21 #include <stdio.h>
22 #include <stdlib.h>
23 #include <stdarg.h>
24 #include <unistd.h>
25 #include <signal.h>
26 #include <string.h>
27 #include <errno.h>
28
29 #include "tcltk/tclmagic.h"
30 #include "utils/main.h"
31 #include "utils/magic.h"
32 #include "utils/geometry.h"
33 #include "tiles/tile.h"
34 #include "utils/hash.h"
35 #include "utils/dqueue.h"
36 #include "database/database.h"
37 #include "windows/windows.h"
38 #include "commands/commands.h"
39 #include "utils/utils.h"
40 #include "textio/textio.h"
41 #include "textio/txcommands.h"
42 #include "utils/signals.h"
43 #include "graphics/graphics.h"
44 #include "utils/malloc.h"
45 #include "dbwind/dbwind.h"
46
47 /*
48 * String containing the version number of magic. Don't change the string
49 * here, nor its format. It is updated by the Makefile in this directory.
50 */
51
52 char *MagicVersion = MAGIC_VERSION;
53 char *MagicRevision = MAGIC_REVISION;
54 char *MagicCompileTime = MAGIC_DATE;
55
56 Tcl_Interp *magicinterp;
57 Tcl_Interp *consoleinterp;
58
59 HashTable txTclTagTable;
60
61 Tcl_ChannelType inChannel;
62
63 /* Forward declarations */
64
65 int TerminalInputProc(ClientData, char *, int, int *);
66 void TxFlushErr();
67 void TxFlushOut();
68 void RegisterTkCommands();
69
70 /*--------------------------------------------------------------*/
71 /* Verify if a command has a tag callback. */
72 /*--------------------------------------------------------------*/
73
74 int
TagVerify(keyword)75 TagVerify(keyword)
76 char *keyword;
77 {
78 char *croot, *postcmd;
79 HashEntry *entry;
80
81 /* Skip over namespace qualifier, if any */
82
83 croot = keyword;
84 if (!strncmp(croot, "::", 2)) croot += 2;
85 if (!strncmp(croot, "magic::", 7)) croot += 7;
86
87 entry = HashLookOnly(&txTclTagTable, croot);
88 postcmd = (entry) ? (char *)HashGetValue(entry) : NULL;
89 return (postcmd) ? TRUE : FALSE;
90 }
91
92 /*--------------------------------------------------------------*/
93 /* Find any tags associated with a command and execute them. */
94 /*--------------------------------------------------------------*/
95
96 static int
TagCallback(interp,tkpath,argc,argv)97 TagCallback(interp, tkpath, argc, argv)
98 Tcl_Interp *interp;
99 char *tkpath;
100 int argc; /* original command's number of arguments */
101 char *argv[]; /* original command's argument list */
102 {
103 int argidx, result = TCL_OK;
104 char *postcmd, *substcmd, *newcmd, *sptr, *sres;
105 char *croot;
106 HashEntry *entry;
107 Tcl_SavedResult state;
108 bool reset = FALSE;
109 int cmdnum;
110
111 /* No command, no action */
112
113 if (argc == 0) return TCL_OK;
114
115 /* Skip over namespace qualifier, if any */
116
117 croot = argv[0];
118 if (!strncmp(croot, "::", 2)) croot += 2;
119 if (!strncmp(croot, "magic::", 7)) croot += 7;
120
121 entry = HashLookOnly(&txTclTagTable, croot);
122 postcmd = (entry) ? (char *)HashGetValue(entry) : NULL;
123
124 if (postcmd)
125 {
126 /* The Tag callback should not increase the command number */
127 /* sequence, so save it now and restore it before returning. */
128 cmdnum = TxCommandNumber;
129
130 substcmd = (char *)mallocMagic(strlen(postcmd) + 1);
131 strcpy(substcmd, postcmd);
132 sptr = substcmd;
133
134 /*--------------------------------------------------------------*/
135 /* Parse "postcmd" for Tk-substitution escapes */
136 /* Allowed escapes are: */
137 /* %W substitute the tk path of the layout window */
138 /* %r substitute the previous Tcl result string */
139 /* %R substitute the previous Tcl result string and */
140 /* reset the Tcl result. */
141 /* %[0-5] substitute the argument to the original command */
142 /* %% substitute a single percent character */
143 /* %* (all others) no action: print as-is. */
144 /*--------------------------------------------------------------*/
145
146 while ((sptr = strchr(sptr, '%')) != NULL)
147 {
148 switch (*(sptr + 1))
149 {
150 case 'W':
151
152 /* In the case of the %W escape, first we see if a Tk */
153 /* path has been passed in the argument. If not, get */
154 /* the window path if there is only one window. */
155 /* Otherwise, the window is unknown so we substitute */
156 /* a null list "{}". */
157
158 if (tkpath == NULL)
159 {
160 MagWindow *w = NULL;
161 windCheckOnlyWindow(&w, DBWclientID);
162 if (w != NULL && !(w->w_flags & WIND_OFFSCREEN))
163 {
164 Tk_Window tkwind = (Tk_Window) w->w_grdata;
165 if (tkwind != NULL) tkpath = Tk_PathName(tkwind);
166 }
167 }
168 if (tkpath == NULL)
169 newcmd = (char *)mallocMagic(strlen(substcmd) + 2);
170 else
171 newcmd = (char *)mallocMagic(strlen(substcmd) + strlen(tkpath));
172
173 strcpy(newcmd, substcmd);
174
175 if (tkpath == NULL)
176 strcpy(newcmd + (int)(sptr - substcmd), "{}");
177 else
178 strcpy(newcmd + (int)(sptr - substcmd), tkpath);
179
180 strcat(newcmd, sptr + 2);
181 freeMagic(substcmd);
182 substcmd = newcmd;
183 sptr = substcmd;
184 break;
185
186 case 'R':
187 reset = TRUE;
188 case 'r':
189 sres = (char *)Tcl_GetStringResult(magicinterp);
190 newcmd = (char *)mallocMagic(strlen(substcmd)
191 + strlen(sres) + 1);
192 strcpy(newcmd, substcmd);
193 sprintf(newcmd + (int)(sptr - substcmd), "\"%s\"", sres);
194 strcat(newcmd, sptr + 2);
195 freeMagic(substcmd);
196 substcmd = newcmd;
197 sptr = substcmd;
198
199 break;
200
201 case '0': case '1': case '2': case '3': case '4': case '5':
202 argidx = (int)(*(sptr + 1) - '0');
203 if ((argidx >= 0) && (argidx < argc))
204 {
205 newcmd = (char *)mallocMagic(strlen(substcmd)
206 + strlen(argv[argidx]));
207 strcpy(newcmd, substcmd);
208 strcpy(newcmd + (int)(sptr - substcmd), argv[argidx]);
209 strcat(newcmd, sptr + 2);
210 freeMagic(substcmd);
211 substcmd = newcmd;
212 sptr = substcmd;
213 }
214 else if (argidx >= argc)
215 {
216 newcmd = (char *)mallocMagic(strlen(substcmd) + 1);
217 strcpy(newcmd, substcmd);
218 strcpy(newcmd + (int)(sptr - substcmd), sptr + 2);
219 freeMagic(substcmd);
220 substcmd = newcmd;
221 sptr = substcmd;
222 }
223 else sptr++;
224 break;
225
226 case '%':
227 newcmd = (char *)mallocMagic(strlen(substcmd) + 1);
228 strcpy(newcmd, substcmd);
229 strcpy(newcmd + (int)(sptr - substcmd), sptr + 1);
230 freeMagic(substcmd);
231 substcmd = newcmd;
232 sptr = substcmd;
233 break;
234
235 default:
236 break;
237 }
238 }
239
240 /* fprintf(stderr, "Substituted tag callback is \"%s\"\n", substcmd); */
241 /* fflush(stderr); */
242
243 Tcl_SaveResult(interp, &state);
244 result = Tcl_EvalEx(interp, substcmd, -1, 0);
245 if ((result == TCL_OK) && (reset == FALSE))
246 Tcl_RestoreResult(interp, &state);
247 else
248 Tcl_DiscardResult(&state);
249
250 freeMagic(substcmd);
251 TxCommandNumber = cmdnum; /* restore original value */
252 }
253 return result;
254 }
255
256 /*--------------------------------------------------------------*/
257 /* Add a command tag callback */
258 /*--------------------------------------------------------------*/
259
260 static int
AddCommandTag(ClientData clientData,Tcl_Interp * interp,int argc,char * argv[])261 AddCommandTag(ClientData clientData,
262 Tcl_Interp *interp, int argc, char *argv[])
263 {
264 HashEntry *entry;
265 char *hstring;
266
267 if (argc != 2 && argc != 3)
268 return TCL_ERROR;
269
270 entry = HashFind(&txTclTagTable, argv[1]);
271
272 if (entry == NULL) return TCL_ERROR;
273
274 hstring = (char *)HashGetValue(entry);
275
276 if (argc == 2)
277 {
278 Tcl_SetResult(magicinterp, hstring, NULL);
279 return TCL_OK;
280 }
281
282 if (hstring != NULL) freeMagic(hstring);
283
284 if (strlen(argv[2]) == 0)
285 {
286 HashSetValue(entry, NULL);
287 }
288 else
289 {
290 hstring = StrDup((char **)NULL, argv[2]);
291 HashSetValue(entry, hstring);
292 }
293 return TCL_OK;
294 }
295
296 /*--------------------------------------------------------------*/
297 /* Dispatch a command from Tcl */
298 /* See TxTclDispatch() in textio/txCommands.c */
299 /*--------------------------------------------------------------*/
300
301 static int
_tcl_dispatch(ClientData clientData,Tcl_Interp * interp,int argc,char * argv[])302 _tcl_dispatch(ClientData clientData,
303 Tcl_Interp *interp, int argc, char *argv[])
304 {
305 int wval;
306 int result, idx;
307 Tcl_Obj *objv0;
308 char *argv0, *tkwind;
309
310 /* Check command (argv[0]) against known conflicting */
311 /* command names. If the command is potentially a */
312 /* Tcl/Tk command, try it as such, first. If a Tcl */
313 /* error is returned, then try it as a magic */
314 /* command. Note that the other way (try the magic */
315 /* command first) would necessitate setting Tcl */
316 /* results for every magic command. Too much work. */
317
318 static char *conflicts[] =
319 {
320 "clockwise", "flush", "load", "label", "array", "grid", NULL
321 };
322 static char *resolutions[] =
323 {
324 "orig_clock", "tcl_flush", "tcl_load", "tcl_label", "tcl_array",
325 "tcl_grid", NULL
326 };
327
328 typedef enum
329 {
330 IDX_CLOCK, IDX_FLUSH, IDX_LOAD, IDX_LABEL, IDX_ARRAY,
331 IDX_GRID
332 } conflictCommand;
333
334 /* Skip any "::" namespace prefix before parsing */
335 argv0 = argv[0];
336 if (!strncmp(argv0, "::", 2)) argv0 += 2;
337
338 objv0 = Tcl_NewStringObj(argv0, strlen(argv0));
339 if (Tcl_GetIndexFromObj(interp, objv0, (CONST84 char **)conflicts,
340 "overloaded command", 0, &idx) == TCL_OK)
341 {
342 int i;
343 Tcl_Obj **objv = (Tcl_Obj **)Tcl_Alloc(argc * sizeof(Tcl_Obj *));
344
345 /* Create a Tcl_Obj array suitable for calling Tcl_EvalObjv. */
346 /* The first argument is changed from the magic command name to */
347 /* "tcl" + the command name. This assumes that all conflicting */
348 /* command names have been so renamed in the startup script! */
349
350 objv[0] = Tcl_NewStringObj(resolutions[idx], strlen(resolutions[idx]));
351 Tcl_IncrRefCount(objv[0]);
352
353 for (i = 1; i < argc; i++)
354 {
355 objv[i] = Tcl_NewStringObj(argv[i], strlen(argv[i]));
356 Tcl_IncrRefCount(objv[i]);
357 }
358
359 result = Tcl_EvalObjv(interp, argc, objv, 0);
360
361 for (i = 0; i < argc; i++)
362 Tcl_DecrRefCount(objv[i]);
363 Tcl_Free((char *)objv);
364
365 if (result == TCL_OK)
366 return result;
367
368 /* The rule is to execute Magic commands for any Tcl command */
369 /* with the same name that returns an error. However, this */
370 /* rule hangs magic when the "load" command is used on a shared */
371 /* object file that fails to load properly. So if the filename */
372 /* has an extension which is not ".mag", we will return the */
373 /* error. */
374
375 /* Updated 1/20/2015: Need to check for a '.' AFTER the last */
376 /* slash, so as to avoid problems with ./, ../, etc. */
377
378 if (idx == IDX_LOAD)
379 {
380 char *dotptr, *slashptr;
381 if (argc >= 2)
382 {
383 slashptr = strrchr(argv[1], '/');
384 if (slashptr == NULL)
385 slashptr = argv[1];
386 else
387 slashptr++;
388
389 if ((dotptr = strrchr(slashptr, '.')) != NULL)
390 if (strcmp(dotptr + 1, "mag"))
391 return result;
392 }
393 }
394 }
395 Tcl_ResetResult(interp);
396
397 if (TxInputRedirect == TX_INPUT_REDIRECTED)
398 TxInputRedirect = TX_INPUT_PENDING_RESET;
399
400 wval = TxTclDispatch(clientData, argc, argv, TRUE);
401
402 if (TxInputRedirect == TX_INPUT_PENDING_RESET)
403 TxInputRedirect = TX_INPUT_NORMAL;
404
405 /* If the command did not pass through _tk_dispatch, but the command was */
406 /* entered by key redirection from a window, then TxInputRedirect will be */
407 /* set to TX_INPUT_PROCESSING and the window ID will have been set by */
408 /* TxSetPoint(). Do our level best to find the Tk window name. */
409
410 if (TxInputRedirect == TX_INPUT_PROCESSING)
411 {
412 if (GrWindowNamePtr)
413 {
414 MagWindow *mw = WindSearchWid(TxGetPoint(NULL));
415 if (mw != NULL)
416 tkwind = (*GrWindowNamePtr)(mw);
417 else
418 tkwind = NULL;
419 }
420 else
421 tkwind = NULL;
422 }
423 else
424 tkwind = NULL;
425
426 // Pass back an error if TxTclDispatch failed
427 if (wval != 0) return TCL_ERROR;
428
429 return TagCallback(interp, tkwind, argc, argv);
430 }
431
432 /*--------------------------------------------------------------*/
433 /* Dispatch a window-related command. The first argument is */
434 /* the window to which the command should be directed, so we */
435 /* determine which window this is, set "TxCurCommand" values */
436 /* to point to the window, then dispatch the command. */
437 /*--------------------------------------------------------------*/
438
439 static int
_tk_dispatch(ClientData clientData,Tcl_Interp * interp,int argc,char * argv[])440 _tk_dispatch(ClientData clientData,
441 Tcl_Interp *interp, int argc, char *argv[])
442 {
443 int id;
444 char *tkpath;
445 char *arg0;
446 Point txp;
447
448 if (GrWindowIdPtr)
449 {
450 /* Key macros set the point from the graphics module code but */
451 /* set up the command to be dispatched via _tk_dispatch(). */
452 /* Therefore it is necessary to check if a point position */
453 /* has already been set for this command. If not, then the */
454 /* command was probably called from the command entry window, */
455 /* so we choose an arbitrary point which is somewhere in the */
456 /* window, so that command functions have a point of reference. */
457
458 id = (*GrWindowIdPtr)(argv[0]);
459
460 if (TxGetPoint(&txp) != id)
461 {
462 /* This is a point in the window, inside the */
463 /* scrollbars if they are managed by magic. */
464
465 txp.p_x = 20;
466 txp.p_y = 20;
467 }
468 TxSetPoint(txp.p_x, txp.p_y, id);
469 arg0 = argv[0];
470 argc--;
471 argv++;
472 }
473
474 TxTclDispatch(clientData, argc, argv, FALSE);
475
476 /* Get pathname of window and pass to TagCallback */
477 return TagCallback(interp, arg0, argc, argv);
478 }
479
480 /*--------------------------------------------------------------*/
481 /* Set up a window to use commands via _tk_dispatch */
482 /*--------------------------------------------------------------*/
483
484 void
MakeWindowCommand(char * wname,MagWindow * mw)485 MakeWindowCommand(char *wname, MagWindow *mw)
486 {
487 char *tclcmdstr;
488
489 Tcl_CreateCommand(magicinterp, wname, (Tcl_CmdProc *)_tk_dispatch,
490 (ClientData)mw, (Tcl_CmdDeleteProc *) NULL);
491
492 /* Force the window manager to use magic's "close" command to close */
493 /* down a window. */
494
495 tclcmdstr = (char *)mallocMagic(52 + 2 * strlen(wname));
496 sprintf(tclcmdstr, "wm protocol %s WM_DELETE_WINDOW "
497 "{magic::closewindow %s}", wname, wname);
498 Tcl_EvalEx(magicinterp, tclcmdstr, -1, 0);
499 freeMagic(tclcmdstr);
500 }
501
502 /*------------------------------------------------------*/
503 /* Main startup procedure */
504 /*------------------------------------------------------*/
505
506 static int
_magic_initialize(ClientData clientData,Tcl_Interp * interp,int argc,char * argv[])507 _magic_initialize(ClientData clientData,
508 Tcl_Interp *interp, int argc, char *argv[])
509 {
510 WindClient client;
511 int n, i;
512 char keyword[100];
513 char *kwptr = keyword + 7;
514 char **commandTable;
515 int result;
516
517 /* Is magic being executed in a slave interpreter? */
518
519 if ((consoleinterp = Tcl_GetMaster(interp)) == NULL)
520 consoleinterp = interp;
521
522 // Force tkcon to send output to terminal during initialization
523 else
524 {
525 RuntimeFlags |= (MAIN_TK_CONSOLE | MAIN_TK_PRINTF);
526 Tcl_Eval(consoleinterp, "rename ::puts ::unused_puts\n");
527 Tcl_Eval(consoleinterp, "rename ::tkcon_tcl_puts ::puts\n");
528 }
529
530 /* Did we start in the same interpreter as we initialized? */
531 if (magicinterp != interp)
532 {
533 TxError("Warning: Switching interpreters. Tcl-magic is not set up "
534 "to handle this.\n");
535 magicinterp = interp;
536 }
537
538 if (mainInitBeforeArgs(argc, argv) != 0) goto magicfatal;
539 if (mainDoArgs(argc, argv) != 0) goto magicfatal;
540
541 // Redirect output back to the console
542 if (TxTkConsole)
543 {
544 RuntimeFlags &= ~MAIN_TK_PRINTF;
545 Tcl_Eval(consoleinterp, "rename ::puts ::tkcon_tcl_puts\n");
546 Tcl_Eval(consoleinterp, "rename ::unused_puts ::puts\n");
547 }
548
549 /* Identify version and revision */
550
551 TxPrintf("\nMagic %s revision %s - Compiled on %s.\n", MagicVersion,
552 MagicRevision, MagicCompileTime);
553 TxPrintf("Starting magic under Tcl interpreter\n");
554 if (TxTkConsole)
555 TxPrintf("Using Tk console window\n");
556 else
557 TxPrintf("Using the terminal as the console.\n");
558 TxFlushOut();
559
560 if (mainInitAfterArgs() != 0) goto magicfatal;
561
562 /* Registration of commands is performed after calling the */
563 /* start function, not after initialization, as the command */
564 /* modularization requires magic initialization to get a */
565 /* valid DBWclientID, windClientID, etc. */
566
567 sprintf(keyword, "magic::");
568
569 /* Work through all the known clients, and register the */
570 /* commands of all of them. */
571
572 client = (WindClient)NULL;
573 while ((client = WindNextClient(client)) != NULL)
574 {
575 commandTable = WindGetCommandTable(client);
576 for (n = 0; commandTable[n] != NULL; n++)
577 {
578 sscanf(commandTable[n], "%s ", kwptr); /* get first word */
579 Tcl_CreateCommand(interp, keyword, (Tcl_CmdProc *)_tcl_dispatch,
580 (ClientData)NULL, (Tcl_CmdDeleteProc *) NULL);
581 }
582 }
583
584 /* Extra commands provided by the Tk graphics routines */
585 /* (See graphics/grTkCommon.c) */
586 /* (Unless "-dnull" option has been given) */
587
588 if (strcmp(MainDisplayType, "NULL"))
589 RegisterTkCommands(interp);
590
591 /* Set up the console so that its menu option File->Exit */
592 /* calls magic's exit routine first. This should not be */
593 /* done in console.tcl, or else it puts the console in a */
594 /* state where it is difficult to exit, if magic doesn't */
595 /* start up correctly. */
596
597 if (TxTkConsole)
598 {
599 Tcl_Eval(consoleinterp, "rename ::exit ::quit\n");
600 Tcl_Eval(consoleinterp, "proc ::exit args {slave eval quit}\n");
601 }
602
603 return TCL_OK;
604
605 magicfatal:
606 TxResetTerminal();
607 Tcl_SetResult(interp, "Magic initialization encountered a fatal error.", NULL);
608 return TCL_ERROR;
609 }
610
611 /*--------------------------------------------------------------*/
612
613 typedef struct FileState {
614 Tcl_Channel channel;
615 int fd;
616 int validMask;
617 } FileState;
618
619 /*--------------------------------------------------------------*/
620 /* "Wizard" command for manipulating run-time flags. */
621 /*--------------------------------------------------------------*/
622
623 static int
_magic_flags(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * CONST objv[])624 _magic_flags(ClientData clientData,
625 Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
626 {
627 int index, index2;
628 bool value;
629 static char *flagOptions[] = {"debug", "recover", "silent",
630 "window", "console", "printf", (char *)NULL};
631 static char *yesNo[] = {"off", "no", "false", "0", "on", "yes",
632 "true", "1", (char *)NULL};
633
634 if ((objc != 2) && (objc != 3)) {
635 Tcl_WrongNumArgs(interp, 1, objv, "flag ?value?");
636 return TCL_ERROR;
637 }
638 if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **)flagOptions,
639 "option", 0, &index) != TCL_OK) {
640 return TCL_ERROR;
641 }
642 if (objc == 2) {
643 switch (index) {
644 case 0:
645 value = (RuntimeFlags & MAIN_DEBUG) ? TRUE : FALSE;
646 break;
647 case 1:
648 value = (RuntimeFlags & MAIN_RECOVER) ? TRUE : FALSE;
649 break;
650 case 2:
651 value = (RuntimeFlags & MAIN_SILENT) ? TRUE : FALSE;
652 break;
653 case 3:
654 value = (RuntimeFlags & MAIN_MAKE_WINDOW) ? TRUE : FALSE;
655 break;
656 case 4:
657 value = (RuntimeFlags & MAIN_TK_CONSOLE) ? TRUE : FALSE;
658 break;
659 case 5:
660 value = (RuntimeFlags & MAIN_TK_PRINTF) ? TRUE : FALSE;
661 break;
662 }
663 Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value));
664 }
665 else {
666 if (Tcl_GetIndexFromObj(interp, objv[2], (CONST84 char **)yesNo,
667 "value", 0, &index2) != TCL_OK)
668 return TCL_ERROR;
669
670 value = (index2 > 3) ? TRUE : FALSE;
671 switch (index) {
672 case 0:
673 if (value == TRUE)
674 RuntimeFlags |= MAIN_DEBUG;
675 else
676 RuntimeFlags &= ~MAIN_DEBUG;
677 break;
678 case 1:
679 if (value == TRUE)
680 RuntimeFlags |= MAIN_RECOVER;
681 else
682 RuntimeFlags &= ~MAIN_RECOVER;
683 break;
684 case 2:
685 if (value == TRUE)
686 RuntimeFlags |= MAIN_SILENT;
687 else
688 RuntimeFlags &= ~MAIN_SILENT;
689 break;
690 case 3:
691 if (value == TRUE)
692 RuntimeFlags |= MAIN_MAKE_WINDOW;
693 else
694 RuntimeFlags &= ~MAIN_MAKE_WINDOW;
695 break;
696 case 4:
697 if (value == TRUE)
698 RuntimeFlags |= MAIN_TK_CONSOLE;
699 else
700 RuntimeFlags &= ~MAIN_TK_CONSOLE;
701 break;
702 case 5:
703 if (value == TRUE)
704 RuntimeFlags |= MAIN_TK_PRINTF;
705 else
706 RuntimeFlags &= ~MAIN_TK_PRINTF;
707 break;
708 }
709 }
710 return TCL_OK;
711 }
712
713 /*--------------------------------------------------------------*/
714 /* Post-initialization: read in the magic startup files and */
715 /* load any initial layout. Note that this is not done via */
716 /* script, but probably should be. */
717 /*--------------------------------------------------------------*/
718
719 static int
_magic_startup(ClientData clientData,Tcl_Interp * interp,int argc,char * argv[])720 _magic_startup(ClientData clientData,
721 Tcl_Interp *interp, int argc, char *argv[])
722 {
723 /* Execute contents of startup files and load any initial cell */
724
725 if (mainInitFinal() != 0)
726 {
727 /* We don't want mainInitFinal errors to return TCL_ERROR from */
728 /* magic::start; otherwise, the window won't come up. As long */
729 /* as we have successfully passed mainInitAfterArgs(), magic is */
730 /* fundamentally sound. */
731
732 Tcl_SetResult(interp,
733 "Magic encountered problems with the startup files.",
734 NULL);
735 }
736
737 TxResetTerminal();
738
739 if (TxTkConsole)
740 {
741 Tcl_EvalEx(consoleinterp, "tkcon set ::tkcon::OPT(showstatusbar) 1", -1, 0);
742 TxSetPrompt('%');
743 }
744 else
745 {
746 Tcl_Channel oldchannel;
747 Tcl_ChannelType *stdChannel;
748 FileState *fsPtr, *fsOrig;
749
750 /* Use the terminal. */
751 /* Replace the input proc for stdin with our own. */
752
753 oldchannel = Tcl_GetStdChannel(TCL_STDIN); // Get existing stdin
754 fsOrig = Tcl_GetChannelInstanceData(oldchannel);
755
756 /* Copy the structure from the old to the new channel */
757 stdChannel = (Tcl_ChannelType *)Tcl_GetChannelType(oldchannel);
758 memcpy(&inChannel, stdChannel, sizeof(Tcl_ChannelType));
759 inChannel.inputProc = TerminalInputProc;
760
761 fsPtr = (FileState *)Tcl_Alloc(sizeof(FileState));
762 fsPtr->validMask = fsOrig->validMask;
763 fsPtr->fd = fsOrig->fd;
764 fsPtr->channel = Tcl_CreateChannel(&inChannel, "stdin",
765 (ClientData)fsPtr, TCL_READABLE);
766
767 Tcl_SetStdChannel(fsPtr->channel, TCL_STDIN); // Apply new stdin
768 Tcl_RegisterChannel(NULL, fsPtr->channel);
769 }
770
771 return TCL_OK;
772 }
773
774 /*--------------------------------------------------------------*/
775 /* Tk version of TxDialog */
776 /*--------------------------------------------------------------*/
777
778 int
TxDialog(prompt,responses,defresp)779 TxDialog(prompt, responses, defresp)
780 char *prompt;
781 char *(responses[]);
782 int defresp;
783 {
784 Tcl_Obj *objPtr;
785 int code, result, pos;
786 char *evalstr, *newstr;
787
788 /* Ensure that use of TxPrintString doesn't overwrite the */
789 /* value of prompt my making a copy of it. */
790 /* 5/11/05---use Tcl_escape() to do the duplication; this */
791 /* ensures that cell names with special characters like '$' */
792 /* will be handled properly. */
793
794 newstr = Tcl_escape(prompt);
795 /* newstr = StrDup((char **)NULL, prompt); */
796 evalstr = TxPrintString("tk_dialog .dialog \"Dialog\""
797 " \"%s\" {} %d ", newstr, defresp);
798 /* freeMagic(newstr); */
799 Tcl_Free(newstr); /* Tcl_escape() uses Tcl_Alloc() */
800
801 for (pos = 0; responses[pos] != 0; pos++)
802 {
803 newstr = StrDup((char **)NULL, evalstr);
804 evalstr = TxPrintString("%s \"%s\" ", newstr,
805 responses[pos]);
806 freeMagic(newstr);
807 }
808
809 Tcl_EvalEx(magicinterp, evalstr, -1, 0);
810 objPtr = Tcl_GetObjResult(magicinterp);
811 result = Tcl_GetIntFromObj(magicinterp, objPtr, &code);
812
813 if (result == TCL_OK) return code;
814 else return -1;
815 }
816
817 /*--------------------------------------------------------------*/
818 /* TxUseMore and TxStopMore are dummy functions, although they */
819 /* could be used to set up a top-level window containing the */
820 /* result (redefine "puts" to write to the window). */
821 /*--------------------------------------------------------------*/
822
823 void
TxUseMore()824 TxUseMore()
825 {
826 }
827
828 /*--------------------------------------------------------------*/
829
830 void
TxStopMore()831 TxStopMore()
832 {
833 }
834
835 /*--------------------------------------------------------------*/
836 /* Set the prompt, if we are using the TkCon console */
837 /*--------------------------------------------------------------*/
838
839 extern char txPromptChar;
840
841 void
TxSetPrompt(ch)842 TxSetPrompt(ch)
843 char ch;
844 {
845 Tcl_SavedResult state;
846 char promptline[16];
847
848 if (TxTkConsole)
849 {
850 sprintf(promptline, "replaceprompt %c", ch);
851 Tcl_SaveResult(consoleinterp, &state);
852 Tcl_EvalEx(consoleinterp, promptline, 15, 0);
853 Tcl_RestoreResult(consoleinterp, &state);
854 }
855 }
856
857 /*--------------------------------------------------------------*/
858 /* Get a line from stdin (Tcl replacement for Tx function) */
859 /*--------------------------------------------------------------*/
860
861 char *
TxGetLinePfix(dest,maxChars,prefix)862 TxGetLinePfix(dest, maxChars, prefix)
863 char *dest;
864 int maxChars;
865 char *prefix;
866 {
867 Tcl_Obj *objPtr;
868 int charsStored, length;
869 char *string;
870
871 if (TxTkConsole)
872 {
873 /* Use dialog function (must be defined in magic.tcl!) */
874 if (prefix != NULL)
875 {
876 string = Tcl_Alloc(20 + strlen(prefix));
877 sprintf(string, "magic::dialog \"\" \"%s\"\n", prefix);
878 Tcl_EvalEx(magicinterp, string, -1, 0);
879 Tcl_Free(string);
880 }
881 else
882 Tcl_EvalEx(magicinterp, "magic::dialog", 13, 0);
883 }
884 else
885 {
886 if (prefix != NULL)
887 {
888 TxPrintf("%s", prefix);
889 TxFlushOut();
890 }
891 Tcl_EvalEx(magicinterp, "gets stdin", 10, 0);
892 }
893
894 objPtr = Tcl_GetObjResult(magicinterp);
895 string = Tcl_GetStringFromObj(objPtr, &length);
896
897 if (length > 0)
898 if (*(string + length - 1) == '\n')
899 length--;
900
901 if (length == 0)
902 return NULL;
903 else if (length >= maxChars)
904 length = (maxChars - 1);
905
906 strncpy(dest, string, length);
907 *(dest + length) = '\0';
908 return dest;
909 }
910
911 /*--------------------------------------------------------------*/
912 /* Parse a file. This is a skeleton version of the TxDispatch */
913 /* routine in textio/txCommands.c */
914 /*--------------------------------------------------------------*/
915
916 void
TxDispatch(f)917 TxDispatch(f)
918 FILE *f; /* Under Tcl, we never call this with NULL */
919 {
920 if (f == NULL)
921 {
922 TxError("Error: TxDispatch(NULL) was called\n");
923 }
924 while (!feof(f))
925 {
926 if (SigInterruptPending)
927 {
928 TxError("Read-in of file aborted.\n");
929 SigInterruptPending = FALSE;
930 return;
931 }
932 txGetFileCommand(f, NULL);
933 }
934 }
935
936 /*--------------------------------------------------------------*/
937 /* Send a command line which was collected by magic's TxEvent */
938 /* handler to the interpreter's event queue. */
939 /*--------------------------------------------------------------*/
940
941 void
TxParseString(str,q,event)942 TxParseString(str, q, event)
943 char *str;
944 caddr_t q; /* unused */
945 caddr_t event; /* always NULL (ignored) */
946 {
947 char *reply;
948
949 Tcl_EvalEx(magicinterp, str, -1, 0);
950
951 reply = (char *)Tcl_GetStringResult(magicinterp);
952
953 if (strlen(reply) > 0)
954 TxPrintf("%s: %s\n", str, reply);
955 }
956
957 /*--------------------------------------------------------------*/
958 /* Replacement for TxFlush(): use Tcl interpreter */
959 /* If we just call "flush", _tcl_dispatch gets called, and */
960 /* bad things will happen. */
961 /*--------------------------------------------------------------*/
962
963 void
TxFlushErr()964 TxFlushErr()
965 {
966 Tcl_SavedResult state;
967
968 Tcl_SaveResult(magicinterp, &state);
969 Tcl_EvalEx(magicinterp, "::tcl_flush stderr", 18, 0);
970 Tcl_RestoreResult(magicinterp, &state);
971 }
972
973 /*--------------------------------------------------------------*/
974
975 void
TxFlushOut()976 TxFlushOut()
977 {
978 Tcl_SavedResult state;
979
980 Tcl_SaveResult(magicinterp, &state);
981 Tcl_EvalEx(magicinterp, "::tcl_flush stdout", 18, 0);
982 Tcl_RestoreResult(magicinterp, &state);
983 }
984
985 /*--------------------------------------------------------------*/
986
987 void
TxFlush()988 TxFlush()
989 {
990 TxFlushOut();
991 TxFlushErr();
992 }
993
994 /*--------------------------------------------------------------*/
995 /* Tcl_printf() replaces vfprintf() for use by every Tx output */
996 /* function (namely, TxError() for stderr and TxPrintf() for */
997 /* stdout). It changes the result to a Tcl "puts" call, which */
998 /* can be changed inside Tcl, as, for example, by TkCon. */
999 /* */
1000 /* 6/17/04---Routine extended to escape double-dollar-sign '$$' */
1001 /* which is used by some tools when generating via cells. */
1002 /* */
1003 /* 12/23/16---Noted that using consoleinterp simply prevents */
1004 /* the output from being redirected to another window such as */
1005 /* the command entry window. Split off another bit TxTkOutput */
1006 /* from TxTkConsole and set it to zero by default. The */
1007 /* original behavior can be restored using the *flags wizard */
1008 /* command (*flags printf true). */
1009 /* */
1010 /* 11/24/21---Routing extended to excape any dollar sign that */
1011 /* does not represent a valid Tcl variable. */
1012 /*--------------------------------------------------------------*/
1013
1014 int
Tcl_printf(FILE * f,char * fmt,va_list args_in)1015 Tcl_printf(FILE *f, char *fmt, va_list args_in)
1016 {
1017 va_list args;
1018 static char outstr[128] = "puts -nonewline std";
1019 char *outptr, *bigstr = NULL, *finalstr = NULL;
1020 int i, nchars, result, escapes = 0, limit;
1021 Tcl_Interp *printinterp = (TxTkOutput) ? consoleinterp : magicinterp;
1022
1023 strcpy (outstr + 19, (f == stderr) ? "err \"" : "out \"");
1024
1025 va_copy(args, args_in);
1026 outptr = outstr;
1027 nchars = vsnprintf(outptr + 24, 102, fmt, args);
1028 va_end(args);
1029
1030 if (nchars >= 102)
1031 {
1032 va_copy(args, args_in);
1033 bigstr = Tcl_Alloc(nchars + 26);
1034 strncpy(bigstr, outptr, 24);
1035 outptr = bigstr;
1036 vsnprintf(outptr + 24, nchars + 2, fmt, args);
1037 va_end(args);
1038 }
1039 else if (nchars == -1) nchars = 126;
1040
1041 for (i = 24; *(outptr + i) != '\0'; i++)
1042 {
1043 if (*(outptr + i) == '\"' || *(outptr + i) == '[' ||
1044 *(outptr + i) == ']' || *(outptr + i) == '\\')
1045 escapes++;
1046 else if (*(outptr + i) == '$')
1047 escapes += 2;
1048 }
1049
1050 if (escapes > 0)
1051 {
1052 /* "+ 4" required to process "$$...$$"; haven't figured out why. */
1053 finalstr = Tcl_Alloc(nchars + escapes + 26 + 4);
1054 strncpy(finalstr, outptr, 24);
1055 escapes = 0;
1056 for (i = 24; *(outptr + i) != '\0'; i++)
1057 {
1058 if (*(outptr + i) == '\"' || *(outptr + i) == '[' ||
1059 *(outptr + i) == ']' || *(outptr + i) == '\\')
1060 {
1061 *(finalstr + i + escapes) = '\\';
1062 escapes++;
1063 }
1064 else if (*(outptr + i) == '$')
1065 {
1066 char *wsp;
1067
1068 /* Determine if what follows the '$' is a valid Tcl */
1069 /* variable name. If not, then escape the '$'. */
1070
1071 wsp = strchr(outptr + i + 1, ' ');
1072 if (wsp != NULL) *wsp = '\0';
1073 if (Tcl_GetVar(printinterp, outptr + i + 1, 0) == NULL)
1074 {
1075 *(finalstr + i + escapes) = '\\';
1076 escapes++;
1077 }
1078 if (wsp != NULL) *wsp = ' ';
1079 }
1080 *(finalstr + i + escapes) = *(outptr + i);
1081 }
1082 outptr = finalstr;
1083 }
1084
1085 *(outptr + 24 + nchars + escapes) = '\"';
1086 *(outptr + 25 + nchars + escapes) = '\0';
1087
1088 result = Tcl_EvalEx(printinterp, outptr, -1, 0);
1089
1090 if (bigstr != NULL) Tcl_Free(bigstr);
1091 if (finalstr != NULL) Tcl_Free(finalstr);
1092
1093 return result;
1094 }
1095
1096 /*--------------------------------------------------------------*/
1097 /* Tcl_escape() takes a string as input and produces a string */
1098 /* in which characters are escaped as necessary to make them */
1099 /* printable from Tcl. The new string is allocated by */
1100 /* Tcl_Alloc() which needs to be free'd with Tcl_Free(). */
1101 /* */
1102 /* 6/17/04---extended like Tcl_printf to escape double-dollar- */
1103 /* sign ('$$') in names. */
1104 /* 11/24/21---modified like Tcl_printf to escape any dollar */
1105 /* sign that does not precede a valid Tcl variable name. */
1106 /*--------------------------------------------------------------*/
1107
1108 char *
Tcl_escape(instring)1109 Tcl_escape(instring)
1110 char *instring;
1111 {
1112 char *newstr;
1113 int nchars = 0;
1114 int escapes = 0;
1115 int i;
1116 Tcl_Interp *printinterp = (TxTkOutput) ? consoleinterp : magicinterp;
1117
1118 for (i = 0; *(instring + i) != '\0'; i++)
1119 {
1120 nchars++;
1121 if (*(instring + i) == '\"' || *(instring + i) == '[' ||
1122 *(instring + i) == ']' || *(instring + i) == '$')
1123 escapes++;
1124 }
1125
1126 newstr = Tcl_Alloc(nchars + escapes + 1);
1127 escapes = 0;
1128 for (i = 0; *(instring + i) != '\0'; i++)
1129 {
1130 if (*(instring + i) == '\"' || *(instring + i) == '[' ||
1131 *(instring + i) == ']')
1132 {
1133 *(newstr + i + escapes) = '\\';
1134 escapes++;
1135 }
1136 else if (*(instring + i) == '$')
1137 {
1138 char *wsp;
1139
1140 /* If what follows '$' is a valid Tcl variable, don't escape it */
1141 wsp = strchr(instring + i + 1, ' ');
1142 if (wsp != NULL) *wsp = '\0';
1143 if (Tcl_GetVar(printinterp, instring + i + 1, 0) == NULL)
1144 {
1145 *(newstr + i + escapes) = '\\';
1146 escapes++;
1147 }
1148 if (wsp != NULL) *wsp = ' ';
1149 }
1150 *(newstr + i + escapes) = *(instring + i);
1151 }
1152 *(newstr + i + escapes) = '\0';
1153 return newstr;
1154 }
1155
1156 /*--------------------------------------------------------------*/
1157
1158 int
TerminalInputProc(instanceData,buf,toRead,errorCodePtr)1159 TerminalInputProc(instanceData, buf, toRead, errorCodePtr)
1160 ClientData instanceData;
1161 char *buf;
1162 int toRead;
1163 int *errorCodePtr;
1164 {
1165 FileState *fsPtr = (FileState *)instanceData;
1166 int bytesRead, i, tlen;
1167 char *locbuf;
1168
1169 *errorCodePtr = 0;
1170
1171 TxInputRedirect = TX_INPUT_NORMAL;
1172 if (TxBuffer != NULL) {
1173 tlen = strlen(TxBuffer);
1174 if (tlen < toRead) {
1175 strcpy(buf, TxBuffer);
1176 Tcl_Free(TxBuffer);
1177 TxBuffer = NULL;
1178 return tlen;
1179 }
1180 else {
1181 strncpy(buf, TxBuffer, toRead);
1182 locbuf = Tcl_Alloc(tlen - toRead + 1);
1183 strcpy(locbuf, TxBuffer + toRead);
1184 Tcl_Free(TxBuffer);
1185 TxBuffer = locbuf;
1186 return toRead;
1187 }
1188 }
1189
1190 while (1) {
1191 bytesRead = read(fsPtr->fd, buf, (size_t) toRead);
1192 if (bytesRead > -1)
1193 return bytesRead;
1194
1195 // Ignore interrupts, which may be generated by new
1196 // terminal windows (added by Tim, 9/30/2014)
1197
1198 if (errno != EINTR) break;
1199 }
1200 *errorCodePtr = errno;
1201
1202 return -1;
1203 }
1204
1205 /*--------------------------------------------------------------*/
1206
1207 int
Tclmagic_Init(interp)1208 Tclmagic_Init(interp)
1209 Tcl_Interp *interp;
1210 {
1211 const char *cadroot;
1212
1213 /* Sanity check! */
1214 if (interp == NULL) return TCL_ERROR;
1215
1216 /* Remember the interpreter */
1217 magicinterp = interp;
1218
1219 if (Tcl_InitStubs(interp, "8.5", 0) == NULL) return TCL_ERROR;
1220
1221 /* Initialization and Startup commands */
1222 Tcl_CreateCommand(interp, "magic::initialize", (Tcl_CmdProc *)_magic_initialize,
1223 (ClientData)NULL, (Tcl_CmdDeleteProc *) NULL);
1224 Tcl_CreateCommand(interp, "magic::startup", (Tcl_CmdProc *)_magic_startup,
1225 (ClientData)NULL, (Tcl_CmdDeleteProc *) NULL);
1226
1227 /* Initialize the command-tag callback feature */
1228
1229 HashInit(&txTclTagTable, 10, HT_STRINGKEYS);
1230 Tcl_CreateCommand(interp, "magic::tag", (Tcl_CmdProc *)AddCommandTag,
1231 (ClientData)NULL, (Tcl_CmdDeleteProc *) NULL);
1232
1233 /* Add "*flags" command for manipulating run-time flags */
1234 Tcl_CreateObjCommand(interp, "magic::*flags", (Tcl_ObjCmdProc *)_magic_flags,
1235 (ClientData)NULL, (Tcl_CmdDeleteProc *) NULL);
1236
1237 /* Add the magic TCL directory to the Tcl library search path */
1238
1239 Tcl_Eval(interp, "lappend auto_path " TCL_DIR );
1240
1241 /* Get $CAD_ROOT from a Tcl variable, if it exists, and if not, then */
1242 /* set CAD_ROOT from the environment variable of the same name, if */
1243 /* it exists, and finally fall back on the CAD_DIR set at compile */
1244 /* time. */
1245
1246 cadroot = Tcl_GetVar(interp, "CAD_ROOT", TCL_GLOBAL_ONLY);
1247 if (cadroot == NULL)
1248 {
1249 cadroot = (const char *)getenv("CAD_ROOT");
1250 if (cadroot == NULL) cadroot = CAD_DIR;
1251 Tcl_SetVar(interp, "CAD_ROOT", cadroot, TCL_GLOBAL_ONLY);
1252 }
1253
1254 Tcl_PkgProvide(interp, "Tclmagic", MAGIC_VERSION);
1255 return TCL_OK;
1256 }
1257
1258 /*--------------------------------------------------------------*/
1259 /* Define a "safe init" function for those platforms that */
1260 /* require it. */
1261 /*--------------------------------------------------------------*/
1262
1263 int
Tclmagic_SafeInit(interp)1264 Tclmagic_SafeInit(interp)
1265 Tcl_Interp *interp;
1266 {
1267 return Tclmagic_Init(interp);
1268 }
1269