/[ascend]/trunk/tcltk98/generic/interface/tkConsole.c
ViewVC logotype

Contents of /trunk/tcltk98/generic/interface/tkConsole.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 428 - (show annotations) (download) (as text)
Tue Apr 4 06:41:25 2006 UTC (16 years, 1 month ago) by johnpye
File MIME type: text/x-csrc
File size: 17126 byte(s)
Much progress on the MinGW build of the Tcl/Tk interface. Builds and links now,
just having some problems getting the DLLs for Tcl/Tk to resolve at runtime.
1 /*
2 * tkConsole.c --
3 *
4 * This file implements a Tcl console for systems that may not
5 * otherwise have access to a console. It uses the Text widget
6 * and provides special access via a console command.
7 *
8 * Copyright (c) 1995-1996 Sun Microsystems, Inc.
9 *
10 * See the file "TclTk.license.terms" for information on usage and
11 * redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12 *
13 * SCCS: @(#) tkConsole.c 1.51 97/04/25 16:52:39
14 */
15
16 #include <tcl.h>
17 #include <utilities/ascConfig.h>
18 #include "tkConsole.h"
19
20 #ifdef ASC_USE_TK_CONSOLE
21
22 #ifndef __WIN32__
23 # include <tkInt.h>
24 #else
25 # include <X11/Xlib.h>
26 # include <tkIntXlibDecls.h>
27 # include <tk.h>
28 #endif
29
30 /*
31 * A data structure of the following type holds information for each console
32 * which a handler (i.e. a Tcl command) has been defined for a particular
33 * top-level window.
34 */
35
36 typedef struct ConsoleInfo {
37 Tcl_Interp *consoleInterp; /* Interpreter for the console. */
38 Tcl_Interp *interp; /* Interpreter to send console commands. */
39 } ConsoleInfo;
40
41 static Tcl_Interp *gStdoutInterp = NULL;
42
43 /*
44 * Forward declarations for procedures defined later in this file:
45 */
46
47 static int ConsoleCmd _ANSI_ARGS_((ClientData clientData,
48 Tcl_Interp *interp, int argc, char **argv));
49 static void ConsoleDeleteProc _ANSI_ARGS_((ClientData clientData));
50 static void ConsoleEventProc _ANSI_ARGS_((ClientData clientData,
51 XEvent *eventPtr));
52 static int InterpreterCmd _ANSI_ARGS_((ClientData clientData,
53 Tcl_Interp *interp, int argc, char **argv));
54
55 static int ConsoleInput _ANSI_ARGS_((ClientData instanceData,
56 char *buf, int toRead, int *errorCode));
57 static int ConsoleOutput _ANSI_ARGS_((ClientData instanceData,
58 char *buf, int toWrite, int *errorCode));
59 static int ConsoleClose _ANSI_ARGS_((ClientData instanceData,
60 Tcl_Interp *interp));
61 static void ConsoleWatch _ANSI_ARGS_((ClientData instanceData,
62 int mask));
63 static int ConsoleHandle _ANSI_ARGS_((ClientData instanceData,
64 int direction, ClientData *handlePtr));
65 static void TkConsolePrint _ANSI_ARGS_((Tcl_Interp *interp,
66 int devId, char *buffer, long size));
67 /*
68 * This structure describes the channel type structure for file based IO:
69 */
70
71 static Tcl_ChannelType consoleChannelType = {
72 "console", /* Type name. */
73 NULL, /* Always non-blocking.*/
74 ConsoleClose, /* Close proc. */
75 ConsoleInput, /* Input proc. */
76 ConsoleOutput, /* Output proc. */
77 NULL, /* Seek proc. */
78 NULL, /* Set option proc. */
79 NULL, /* Get option proc. */
80 ConsoleWatch, /* Watch for events on console. */
81 ConsoleHandle, /* Get a handle from the device. */
82 };
83
84 /*
85 *----------------------------------------------------------------------
86 *
87 * TkConsoleCreate --
88 *
89 * Create the console channels and install them as the standard
90 * channels. All I/O will be discarded until TkConsoleInit is
91 * called to attach the console to a text widget.
92 *
93 * Results:
94 * None.
95 *
96 * Side effects:
97 * Creates the console channel and installs it as the standard
98 * channels.
99 *
100 *----------------------------------------------------------------------
101 */
102
103 void
104 TkConsoleCreate()
105 {
106 Tcl_Channel consoleChannel;
107
108 consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console0",
109 (ClientData) TCL_STDIN, TCL_READABLE);
110 if (consoleChannel != NULL) {
111 Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf");
112 Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none");
113 }
114 Tcl_SetStdChannel(consoleChannel, TCL_STDIN);
115 consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console1",
116 (ClientData) TCL_STDOUT, TCL_WRITABLE);
117 if (consoleChannel != NULL) {
118 Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf");
119 Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none");
120 }
121 Tcl_SetStdChannel(consoleChannel, TCL_STDOUT);
122 consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console2",
123 (ClientData) TCL_STDERR, TCL_WRITABLE);
124 if (consoleChannel != NULL) {
125 Tcl_SetChannelOption(NULL, consoleChannel, "-translation", "lf");
126 Tcl_SetChannelOption(NULL, consoleChannel, "-buffering", "none");
127 }
128 Tcl_SetStdChannel(consoleChannel, TCL_STDERR);
129 }
130
131 /*
132 *----------------------------------------------------------------------
133 *
134 * TkConsoleInit --
135 *
136 * Initialize the console. This code actually creates a new
137 * application and associated interpreter. This effectivly hides
138 * the implementation from the main application.
139 *
140 * Results:
141 * None.
142 *
143 * Side effects:
144 * A new console it created.
145 *
146 *----------------------------------------------------------------------
147 */
148
149 int
150 TkConsoleInit(interp)
151 Tcl_Interp *interp; /* Interpreter to use for prompting. */
152 {
153 Tcl_Interp *consoleInterp;
154 ConsoleInfo *info;
155 Tk_Window mainWindow = Tk_MainWindow(interp);
156 #ifdef MAC_TCL
157 static char initCmd[] = "source -rsrc {Console}";
158 #else
159 static char initCmd[] = "source $tk_library/console.tcl";
160 #endif
161
162 consoleInterp = Tcl_CreateInterp();
163 if (consoleInterp == NULL) {
164 goto error;
165 }
166
167 /*
168 * Initialized Tcl and Tk.
169 */
170
171 if (Tcl_Init(consoleInterp) != TCL_OK) {
172 goto error;
173 }
174 if (Tk_Init(consoleInterp) != TCL_OK) {
175 goto error;
176 }
177 gStdoutInterp = interp;
178
179 /*
180 * Add console commands to the interp
181 */
182 info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo));
183 info->interp = interp;
184 info->consoleInterp = consoleInterp;
185 Tcl_CreateCommand(interp, "console", ConsoleCmd, (ClientData) info,
186 (Tcl_CmdDeleteProc *) ConsoleDeleteProc);
187 Tcl_CreateCommand(consoleInterp, "consoleinterp", InterpreterCmd,
188 (ClientData) info, (Tcl_CmdDeleteProc *) NULL);
189
190 Tk_CreateEventHandler(mainWindow, StructureNotifyMask, ConsoleEventProc,
191 (ClientData) info);
192
193 Tcl_Preserve((ClientData) consoleInterp);
194 if (Tcl_Eval(consoleInterp, initCmd) == TCL_ERROR) {
195 /* goto error; -- no problem for now... */
196 printf("Eval error: %s", consoleInterp->result);
197 }
198 Tcl_Release((ClientData) consoleInterp);
199 return TCL_OK;
200
201 error:
202 if (consoleInterp != NULL) {
203 Tcl_DeleteInterp(consoleInterp);
204 }
205 return TCL_ERROR;
206 }
207
208 /*
209 *----------------------------------------------------------------------
210 *
211 * ConsoleOutput--
212 *
213 * Writes the given output on the IO channel. Returns count of how
214 * many characters were actually written, and an error indication.
215 *
216 * Results:
217 * A count of how many characters were written is returned and an
218 * error indication is returned in an output argument.
219 *
220 * Side effects:
221 * Writes output on the actual channel.
222 *
223 *----------------------------------------------------------------------
224 */
225
226 static int
227 ConsoleOutput(instanceData, buf, toWrite, errorCode)
228 ClientData instanceData; /* Indicates which device to use. */
229 char *buf; /* The data buffer. */
230 int toWrite; /* How many bytes to write? */
231 int *errorCode; /* Where to store error code. */
232 {
233 *errorCode = 0;
234 Tcl_SetErrno(0);
235
236 if (gStdoutInterp != NULL) {
237 TkConsolePrint(gStdoutInterp, (int) instanceData, buf, toWrite);
238 }
239
240 return toWrite;
241 }
242
243 /*
244 *----------------------------------------------------------------------
245 *
246 * ConsoleInput --
247 *
248 * Read input from the console. Not currently implemented.
249 *
250 * Results:
251 * Always returns EOF.
252 *
253 * Side effects:
254 * None.
255 *
256 *----------------------------------------------------------------------
257 */
258
259 /* ARGSUSED */
260 static int
261 ConsoleInput(instanceData, buf, bufSize, errorCode)
262 ClientData instanceData; /* Unused. */
263 char *buf; /* Where to store data read. */
264 int bufSize; /* How much space is available
265 * in the buffer? */
266 int *errorCode; /* Where to store error code. */
267 {
268 return 0; /* Always return EOF. */
269 }
270
271 /*
272 *----------------------------------------------------------------------
273 *
274 * ConsoleClose --
275 *
276 * Closes the IO channel.
277 *
278 * Results:
279 * Always returns 0 (success).
280 *
281 * Side effects:
282 * Frees the dummy file associated with the channel.
283 *
284 *----------------------------------------------------------------------
285 */
286
287 /* ARGSUSED */
288 static int
289 ConsoleClose(instanceData, interp)
290 ClientData instanceData; /* Unused. */
291 Tcl_Interp *interp; /* Unused. */
292 {
293 return 0;
294 }
295
296 /*
297 *----------------------------------------------------------------------
298 *
299 * ConsoleWatch --
300 *
301 * Called by the notifier to set up the console device so that
302 * events will be noticed. Since there are no events on the
303 * console, this routine just returns without doing anything.
304 *
305 * Results:
306 * None.
307 *
308 * Side effects:
309 * None.
310 *
311 *----------------------------------------------------------------------
312 */
313
314 /* ARGSUSED */
315 static void
316 ConsoleWatch(instanceData, mask)
317 ClientData instanceData; /* Device ID for the channel. */
318 int mask; /* OR-ed combination of
319 * TCL_READABLE, TCL_WRITABLE and
320 * TCL_EXCEPTION, for the events
321 * we are interested in. */
322 {
323 }
324
325 /*
326 *----------------------------------------------------------------------
327 *
328 * ConsoleHandle --
329 *
330 * Invoked by the generic IO layer to get a handle from a channel.
331 * Because console channels are not devices, this function always
332 * fails.
333 *
334 * Results:
335 * Always returns TCL_ERROR.
336 *
337 * Side effects:
338 * None.
339 *
340 *----------------------------------------------------------------------
341 */
342
343 /* ARGSUSED */
344 static int
345 ConsoleHandle(instanceData, direction, handlePtr)
346 ClientData instanceData; /* Device ID for the channel. */
347 int direction; /* TCL_READABLE or TCL_WRITABLE to indicate
348 * which direction of the channel is being
349 * requested. */
350 ClientData *handlePtr; /* Where to store handle */
351 {
352 return TCL_ERROR;
353 }
354
355 /*
356 *----------------------------------------------------------------------
357 *
358 * ConsoleCmd --
359 *
360 * The console command implements a Tcl interface to the various console
361 * options.
362 *
363 * Results:
364 * None.
365 *
366 * Side effects:
367 * None.
368 *
369 *----------------------------------------------------------------------
370 */
371
372 static int
373 ConsoleCmd(clientData, interp, argc, argv)
374 ClientData clientData; /* Not used. */
375 Tcl_Interp *interp; /* Current interpreter. */
376 int argc; /* Number of arguments. */
377 CONST84 char **argv; /* Argument strings. */
378 {
379 ConsoleInfo *info = (ConsoleInfo *) clientData;
380 char c;
381 int length;
382 int result;
383 Tcl_Interp *consoleInterp;
384
385 if (argc < 2) {
386 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
387 " option ?arg arg ...?\"", (char *) NULL);
388 return TCL_ERROR;
389 }
390
391 c = argv[1][0];
392 length = strlen(argv[1]);
393 result = TCL_OK;
394 consoleInterp = info->consoleInterp;
395 Tcl_Preserve((ClientData) consoleInterp);
396 if ((c == 't') && (strncmp(argv[1], "title", length)) == 0) {
397 Tcl_DString dString;
398
399 Tcl_DStringInit(&dString);
400 Tcl_DStringAppend(&dString, "wm title . ", -1);
401 if (argc == 3) {
402 Tcl_DStringAppendElement(&dString, argv[2]);
403 }
404 Tcl_Eval(consoleInterp, Tcl_DStringValue(&dString));
405 Tcl_DStringFree(&dString);
406 } else if ((c == 'h') && (strncmp(argv[1], "hide", length)) == 0) {
407 Tcl_Eval(info->consoleInterp, "wm withdraw .");
408 } else if ((c == 's') && (strncmp(argv[1], "show", length)) == 0) {
409 Tcl_Eval(info->consoleInterp, "wm deiconify .");
410 } else if ((c == 'e') && (strncmp(argv[1], "eval", length)) == 0) {
411 if (argc == 3) {
412 Tcl_Eval(info->consoleInterp, argv[2]);
413 } else {
414 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
415 " eval command\"", (char *) NULL);
416 return TCL_ERROR;
417 }
418 } else {
419 Tcl_AppendResult(interp, "bad option \"", argv[1],
420 "\": should be hide, show, or title",
421 (char *) NULL);
422 result = TCL_ERROR;
423 }
424 Tcl_Release((ClientData) consoleInterp);
425 return result;
426 }
427
428 /*
429 *----------------------------------------------------------------------
430 *
431 * InterpreterCmd --
432 *
433 * This command allows the console interp to communicate with the
434 * main interpreter.
435 *
436 * Results:
437 * None.
438 *
439 * Side effects:
440 * None.
441 *
442 *----------------------------------------------------------------------
443 */
444
445 static int
446 InterpreterCmd(clientData, interp, argc, argv)
447 ClientData clientData; /* Not used. */
448 Tcl_Interp *interp; /* Current interpreter. */
449 int argc; /* Number of arguments. */
450 CONST84 char **argv; /* Argument strings. */
451 {
452 ConsoleInfo *info = (ConsoleInfo *) clientData;
453 char c;
454 int length;
455 int result;
456 Tcl_Interp *otherInterp;
457
458 if (argc < 2) {
459 Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
460 " option ?arg arg ...?\"", (char *) NULL);
461 return TCL_ERROR;
462 }
463
464 c = argv[1][0];
465 length = strlen(argv[1]);
466 otherInterp = info->interp;
467 Tcl_Preserve((ClientData) otherInterp);
468 if ((c == 'e') && (strncmp(argv[1], "eval", length)) == 0) {
469 result = Tcl_GlobalEval(otherInterp, argv[2]);
470 Tcl_AppendResult(interp, otherInterp->result, (char *) NULL);
471 } else if ((c == 'r') && (strncmp(argv[1], "record", length)) == 0) {
472 Tcl_RecordAndEval(otherInterp, argv[2], TCL_EVAL_GLOBAL);
473 result = TCL_OK;
474 Tcl_AppendResult(interp, otherInterp->result, (char *) NULL);
475 } else {
476 Tcl_AppendResult(interp, "bad option \"", argv[1],
477 "\": should be eval or record",
478 (char *) NULL);
479 result = TCL_ERROR;
480 }
481 Tcl_Release((ClientData) otherInterp);
482 return result;
483 }
484
485 /*
486 *----------------------------------------------------------------------
487 *
488 * ConsoleDeleteProc --
489 *
490 * If the console command is deleted we destroy the console window
491 * and all associated data structures.
492 *
493 * Results:
494 * None.
495 *
496 * Side effects:
497 * A new console it created.
498 *
499 *----------------------------------------------------------------------
500 */
501
502 void
503 ConsoleDeleteProc(clientData)
504 ClientData clientData;
505 {
506 ConsoleInfo *info = (ConsoleInfo *) clientData;
507
508 Tcl_DeleteInterp(info->consoleInterp);
509 info->consoleInterp = NULL;
510 }
511
512 /*
513 *----------------------------------------------------------------------
514 *
515 * ConsoleEventProc --
516 *
517 * This event procedure is registered on the main window of the
518 * slave interpreter. If the user or a running script causes the
519 * main window to be destroyed, then we need to inform the console
520 * interpreter by invoking "tkConsoleExit".
521 *
522 * Results:
523 * None.
524 *
525 * Side effects:
526 * Invokes the "tkConsoleExit" procedure in the console interp.
527 *
528 *----------------------------------------------------------------------
529 */
530
531 static void
532 ConsoleEventProc(clientData, eventPtr)
533 ClientData clientData;
534 XEvent *eventPtr;
535 {
536 ConsoleInfo *info = (ConsoleInfo *) clientData;
537 Tcl_Interp *consoleInterp;
538
539 if (eventPtr->type == DestroyNotify) {
540 consoleInterp = info->consoleInterp;
541
542 /*
543 * It is possible that the console interpreter itself has
544 * already been deleted. In that case the consoleInterp
545 * field will be set to NULL. If the interpreter is already
546 * gone, we do not have to do any work here.
547 */
548
549 if (consoleInterp == (Tcl_Interp *) NULL) {
550 return;
551 }
552 Tcl_Preserve((ClientData) consoleInterp);
553 Tcl_Eval(consoleInterp, "tkConsoleExit");
554 Tcl_Release((ClientData) consoleInterp);
555 }
556 }
557
558 /*
559 *----------------------------------------------------------------------
560 *
561 * TkConsolePrint --
562 *
563 * Prints to the give text to the console. Given the main interp
564 * this functions find the appropiate console interp and forwards
565 * the text to be added to that console.
566 *
567 * Results:
568 * None.
569 *
570 * Side effects:
571 * None.
572 *
573 *----------------------------------------------------------------------
574 */
575
576 void
577 TkConsolePrint(interp, devId, buffer, size)
578 Tcl_Interp *interp; /* Main interpreter. */
579 int devId; /* TCL_STDOUT for stdout, TCL_STDERR for
580 * stderr. */
581 char *buffer; /* Text buffer. */
582 long size; /* Size of text buffer. */
583 {
584 Tcl_DString command, output;
585 Tcl_CmdInfo cmdInfo;
586 char *cmd;
587 ConsoleInfo *info;
588 Tcl_Interp *consoleInterp;
589 int result;
590
591 if (interp == NULL) {
592 return;
593 }
594
595 if (devId == TCL_STDERR) {
596 cmd = "tkConsoleOutput stderr ";
597 } else {
598 cmd = "tkConsoleOutput stdout ";
599 }
600
601 result = Tcl_GetCommandInfo(interp, "console", &cmdInfo);
602 if (result == 0) {
603 return;
604 }
605 info = (ConsoleInfo *) cmdInfo.clientData;
606
607 Tcl_DStringInit(&output);
608 Tcl_DStringAppend(&output, buffer, size);
609
610 Tcl_DStringInit(&command);
611 Tcl_DStringAppend(&command, cmd, strlen(cmd));
612 Tcl_DStringAppendElement(&command, output.string);
613
614 consoleInterp = info->consoleInterp;
615 Tcl_Preserve((ClientData) consoleInterp);
616 Tcl_Eval(consoleInterp, command.string);
617 Tcl_Release((ClientData) consoleInterp);
618
619 Tcl_DStringFree(&command);
620 Tcl_DStringFree(&output);
621 }
622
623 #endif /* ASC_USE_TK_CONSOLE */

john.pye@anu.edu.au
ViewVC Help
Powered by ViewVC 1.1.22