« back to all changes in this revision
Viewing changes to generic/tkConsole.c
- browse files at revision 7
- compare with another revision
- download diff
- download tarball
- view history from revision 7
- Committer: Bazaar Package Importer
- Author(s): Matthias Klose
- Date: 2007-01-05 15:56:45 UTC
- mfrom: (1.1.4 upstream)
- Revision ID: james.westby@ubuntu.com-20070105155645-8srmlwqo7m1q86qi
Tags: 8.4.14-0ubuntu1
New upstream version.
- files added:
- library/msgs/pt.msg
- files modified:
- ChangeLog
added
removed
generic/tkConsole.c
10
10
* See the file "license.terms" for information on usage and redistribution
11
11
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12
12
*
13
* RCS: @(#) $Id: tkConsole.c,v 1.18.2.2 2005/06/23 22:07:13 das Exp $
13
* RCS: @(#) $Id: tkConsole.c,v 1.18.2.6 2006/09/25 17:28:20 andreas_kupries Exp $
14
*
14
15
*/
15
16
16
17
#include "tk.h"
17
#include <string.h>
18
19
#include "tkInt.h"
20
18
21
19
/*
22
* A data structure of the following type holds information for each console
23
* which a handler (i.e. a Tcl command) has been defined for a particular
24
* top-level window.
20
* Each console is associated with an instance of the ConsoleInfo struct.
21
* It keeps track of what interp holds the Tk application that displays
22
* the console, and what interp is controlled by the interactions in that
23
* console. A refCount permits the struct to be shared as instance data
24
* by commands and by channels.
25
25
*/
26
26
27
27
typedef struct ConsoleInfo {
28
Tcl_Interp *consoleInterp; /* Interpreter for the console. */
29
Tcl_Interp *interp; /* Interpreter to send console commands. */
28
Tcl_Interp *consoleInterp; /* Interpreter displaying the console. */
29
Tcl_Interp *interp; /* Interpreter controlled by console. */
30
int refCount;
30
31
} ConsoleInfo;
31
32
32
33
/*
33
* Each interpreter with a console attached stores a reference to the
34
* interpreter's ConsoleInfo in the interpreter's AssocData store. The
35
* alternative is to look the values up by examining the "console"
36
* command and that is fragile. [Bug 1016385]
34
* Each console channel holds an instance of the ChannelData struct as
35
* its instance data. It contains ConsoleInfo, so the channel can work
36
* with the appropriate console window, and a type value to distinguish
37
* the stdout channel from the stderr channel.
37
38
*/
38
39
39
#define TK_CONSOLE_INFO_KEY "tk::ConsoleInfo"
40
41
typedef struct ThreadSpecificData {
42
Tcl_Interp *gStdoutInterp;
43
} ThreadSpecificData;
44
static Tcl_ThreadDataKey dataKey;
45
static int consoleInitialized = 0;
40
typedef struct ChannelData {
41
ConsoleInfo *info;
42
int type; /* TCL_STDOUT or TCL_STDERR */
43
} ChannelData;
46
44
47
45
/*
48
* The Mutex below is used to lock access to the consoleIntialized flag
49
*/
50
51
TCL_DECLARE_MUTEX(consoleMutex)
52
53
/*
54
* Forward declarations for procedures defined later in this file:
55
*
56
* The first three will be used in the tk app shells...
57
*/
58
59
static int ConsoleCmd _ANSI_ARGS_((ClientData clientData,
60
Tcl_Interp *interp, int argc, CONST char **argv));
46
* Prototypes for local procedures defined in this file:
47
*/
48
49
static int ConsoleClose _ANSI_ARGS_((ClientData instanceData,
50
Tcl_Interp *interp));
61
51
static void ConsoleDeleteProc _ANSI_ARGS_((ClientData clientData));
62
52
static void ConsoleEventProc _ANSI_ARGS_((ClientData clientData,
63
53
XEvent *eventPtr));
64
static int InterpreterCmd _ANSI_ARGS_((ClientData clientData,
65
Tcl_Interp *interp, int argc, CONST char **argv));
66
54
static int ConsoleHandle _ANSI_ARGS_((ClientData instandeData,
55
int direction, ClientData *handlePtr));
67
56
static int ConsoleInput _ANSI_ARGS_((ClientData instanceData,
68
57
char *buf, int toRead, int *errorCode));
58
static int ConsoleObjCmd _ANSI_ARGS_((ClientData clientData,
59
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
69
60
static int ConsoleOutput _ANSI_ARGS_((ClientData instanceData,
70
61
CONST char *buf, int toWrite, int *errorCode));
71
static int ConsoleClose _ANSI_ARGS_((ClientData instanceData,
72
Tcl_Interp *interp));
73
62
static void ConsoleWatch _ANSI_ARGS_((ClientData instanceData,
74
63
int mask));
75
static int ConsoleHandle _ANSI_ARGS_((ClientData instanceData,
76
int direction, ClientData *handlePtr));
64
static void DeleteConsoleInterp _ANSI_ARGS_((ClientData clientData));
65
static void InterpDeleteProc _ANSI_ARGS_((ClientData clientData,
66
Tcl_Interp *interp));
67
static int InterpreterObjCmd _ANSI_ARGS_((ClientData clientData,
68
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
77
69
78
70
/*
79
71
* This structure describes the channel type structure for file based IO:
81
73
82
74
static Tcl_ChannelType consoleChannelType = {
83
75
"console", /* Type name. */
84
NULL, /* Always non-blocking.*/
76
TCL_CHANNEL_VERSION_4, /* v4 channel */
85
77
ConsoleClose, /* Close proc. */
86
78
ConsoleInput, /* Input proc. */
87
79
ConsoleOutput, /* Output proc. */
90
82
NULL, /* Get option proc. */
91
83
ConsoleWatch, /* Watch for events on console. */
92
84
ConsoleHandle, /* Get a handle from the device. */
85
NULL, /* close2proc. */
86
NULL, /* Always non-blocking.*/
87
NULL, /* flush proc. */
88
NULL, /* handler proc. */
89
NULL, /* wide seek proc */
90
NULL, /* thread action proc */
93
91
};
94
92
95
93
215
213
* Tk_InitConsoleChannels --
216
214
*
217
215
* Create the console channels and install them as the standard
218
* channels. All I/O will be discarded until TkConsoleInit is
219
* called to attach the console to a text widget.
216
* channels. All I/O will be discarded until Tk_CreateConsoleWindow
217
* is called to attach the console to a text widget.
220
218
*
221
219
* Results:
222
220
* None.
232
230
Tk_InitConsoleChannels(interp)
233
231
Tcl_Interp *interp;
234
232
{
233
static Tcl_ThreadDataKey consoleInitKey;
234
int *consoleInitPtr, doIn, doOut, doErr;
235
ConsoleInfo *info;
235
236
Tcl_Channel consoleChannel;
236
237
237
238
/*
243
244
return;
244
245
}
245
246
246
Tcl_MutexLock(&consoleMutex);
247
if (!consoleInitialized) {
248
249
consoleInitialized = 1;
250
251
/*
252
* check for STDIN, otherwise create it
253
*
254
* Don't do this check on the Mac, because it is hard to prevent
255
* callbacks from the SIOUX layer from opening stdout & stdin, but
256
* we don't want to use the SIOUX console. Since the console is not
257
* actually created till something is written to the channel, it is
258
* okay to just ignore it here.
259
*
260
* This is still a bit of a hack, however, and should be cleaned up
261
* when we have a better abstraction for the console.
262
*/
263
264
if (ShouldUseConsoleChannel(TCL_STDIN)) {
265
consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console0",
266
(ClientData) TCL_STDIN, TCL_READABLE);
267
if (consoleChannel != NULL) {
268
Tcl_SetChannelOption(NULL, consoleChannel,
269
"-translation", "lf");
270
Tcl_SetChannelOption(NULL, consoleChannel,
271
"-buffering", "none");
272
Tcl_SetChannelOption(NULL, consoleChannel,
273
"-encoding", "utf-8");
274
}
275
Tcl_SetStdChannel(consoleChannel, TCL_STDIN);
276
}
277
278
/*
279
* check for STDOUT, otherwise create it
280
*/
281
282
if (ShouldUseConsoleChannel(TCL_STDOUT)) {
283
consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console1",
284
(ClientData) TCL_STDOUT, TCL_WRITABLE);
285
if (consoleChannel != NULL) {
286
Tcl_SetChannelOption(NULL, consoleChannel,
287
"-translation", "lf");
288
Tcl_SetChannelOption(NULL, consoleChannel,
289
"-buffering", "none");
290
Tcl_SetChannelOption(NULL, consoleChannel,
291
"-encoding", "utf-8");
292
}
293
Tcl_SetStdChannel(consoleChannel, TCL_STDOUT);
294
}
295
296
/*
297
* check for STDERR, otherwise create it
298
*/
299
300
if (ShouldUseConsoleChannel(TCL_STDERR)) {
301
consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console2",
302
(ClientData) TCL_STDERR, TCL_WRITABLE);
303
if (consoleChannel != NULL) {
304
Tcl_SetChannelOption(NULL, consoleChannel,
305
"-translation", "lf");
306
Tcl_SetChannelOption(NULL, consoleChannel,
307
"-buffering", "none");
308
Tcl_SetChannelOption(NULL, consoleChannel,
309
"-encoding", "utf-8");
310
}
311
Tcl_SetStdChannel(consoleChannel, TCL_STDERR);
312
}
313
}
314
Tcl_MutexUnlock(&consoleMutex);
247
consoleInitPtr = Tcl_GetThreadData(&consoleInitKey, (int)sizeof(int));
248
if (*consoleInitPtr) {
249
/* We've already initialized console channels in this thread. */
250
return;
251
}
252
*consoleInitPtr = 1;
253
254
doIn = ShouldUseConsoleChannel(TCL_STDIN);
255
doOut = ShouldUseConsoleChannel(TCL_STDOUT);
256
doErr = ShouldUseConsoleChannel(TCL_STDERR);
257
258
if (!(doIn || doOut || doErr)) {
259
/*
260
* No std channels should be tied to the console;
261
* Thus, no need to create the console
262
*/
263
return;
264
}
265
266
/*
267
* At least one std channel wants to be tied to the console,
268
* so create the interp for it to live in.
269
*/
270
271
info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo));
272
info->consoleInterp = NULL;
273
info->interp = NULL;
274
info->refCount = 0;
275
276
if (doIn) {
277
ChannelData *data = (ChannelData *) ckalloc(sizeof(ChannelData));
278
data->info = info;
279
data->info->refCount++;
280
data->type = TCL_STDIN;
281
consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console0",
282
(ClientData) data, TCL_READABLE);
283
if (consoleChannel != NULL) {
284
Tcl_SetChannelOption(NULL, consoleChannel,
285
"-translation", "lf");
286
Tcl_SetChannelOption(NULL, consoleChannel,
287
"-buffering", "none");
288
Tcl_SetChannelOption(NULL, consoleChannel,
289
"-encoding", "utf-8");
290
}
291
Tcl_SetStdChannel(consoleChannel, TCL_STDIN);
292
Tcl_RegisterChannel(NULL, consoleChannel);
293
}
294
295
if (doOut) {
296
ChannelData *data = (ChannelData *) ckalloc(sizeof(ChannelData));
297
data->info = info;
298
data->info->refCount++;
299
data->type = TCL_STDOUT;
300
consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console1",
301
(ClientData) data, TCL_WRITABLE);
302
if (consoleChannel != NULL) {
303
Tcl_SetChannelOption(NULL, consoleChannel,
304
"-translation", "lf");
305
Tcl_SetChannelOption(NULL, consoleChannel,
306
"-buffering", "none");
307
Tcl_SetChannelOption(NULL, consoleChannel,
308
"-encoding", "utf-8");
309
}
310
Tcl_SetStdChannel(consoleChannel, TCL_STDOUT);
311
Tcl_RegisterChannel(NULL, consoleChannel);
312
}
313
314
if (doErr) {
315
ChannelData *data = (ChannelData *) ckalloc(sizeof(ChannelData));
316
data->info = info;
317
data->info->refCount++;
318
data->type = TCL_STDERR;
319
consoleChannel = Tcl_CreateChannel(&consoleChannelType, "console2",
320
(ClientData) data, TCL_WRITABLE);
321
if (consoleChannel != NULL) {
322
Tcl_SetChannelOption(NULL, consoleChannel,
323
"-translation", "lf");
324
Tcl_SetChannelOption(NULL, consoleChannel,
325
"-buffering", "none");
326
Tcl_SetChannelOption(NULL, consoleChannel,
327
"-encoding", "utf-8");
328
}
329
Tcl_SetStdChannel(consoleChannel, TCL_STDERR);
330
Tcl_RegisterChannel(NULL, consoleChannel);
331
}
315
332
}
316
333
317
334
/*
336
353
Tk_CreateConsoleWindow(interp)
337
354
Tcl_Interp *interp; /* Interpreter to use for prompting. */
338
355
{
339
Tcl_Interp *consoleInterp;
356
Tcl_Channel chan;
340
357
ConsoleInfo *info;
341
Tk_Window mainWindow = Tk_MainWindow(interp);
342
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
343
Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
358
Tk_Window mainWindow;
359
Tcl_Command token;
360
int result = TCL_OK;
361
int haveConsoleChannel = 1;
362
344
363
#ifdef MAC_TCL
345
364
static const char *initCmd = "if {[catch {source $tk_library:console.tcl}]} {source -rsrc console}";
346
365
#else
347
366
static const char *initCmd = "source $tk_library/console.tcl";
348
367
#endif
349
368
350
consoleInterp = Tcl_CreateInterp();
351
if (consoleInterp == NULL) {
352
goto error;
353
}
354
355
/*
356
* Initialized Tcl and Tk.
357
*/
358
369
/* Init an interp with Tcl and Tk */
370
Tcl_Interp *consoleInterp = Tcl_CreateInterp();
359
371
if (Tcl_Init(consoleInterp) != TCL_OK) {
360
goto error;
372
goto error;
361
373
}
362
374
if (Tk_Init(consoleInterp) != TCL_OK) {
363
375
goto error;
364
376
}
365
tsdPtr->gStdoutInterp = interp;
377
378
/*
379
* Fetch the instance data from whatever std channel is a
380
* console channel. If none, create fresh instance data.
381
*/
382
383
if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDIN))
384
== &consoleChannelType) {
385
} else if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDOUT))
386
== &consoleChannelType) {
387
} else if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDERR))
388
== &consoleChannelType) {
389
} else {
390
haveConsoleChannel = 0;
391
}
392
393
if (haveConsoleChannel) {
394
ChannelData *data = (ChannelData *)Tcl_GetChannelInstanceData(chan);
395
info = data->info;
396
if (info->consoleInterp) {
397
/* New ConsoleInfo for a new console window */
398
info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo));
399
info->refCount = 0;
400
401
/* Update any console channels to make use of the new console */
402
if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDIN))
403
== &consoleChannelType) {
404
data = (ChannelData *)Tcl_GetChannelInstanceData(chan);
405
data->info->refCount--;
406
data->info = info;
407
data->info->refCount++;
408
}
409
if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDOUT))
410
== &consoleChannelType) {
411
data = (ChannelData *)Tcl_GetChannelInstanceData(chan);
412
data->info->refCount--;
413
data->info = info;
414
data->info->refCount++;
415
}
416
if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDERR))
417
== &consoleChannelType) {
418
data = (ChannelData *)Tcl_GetChannelInstanceData(chan);
419
data->info->refCount--;
420
data->info = info;
421
data->info->refCount++;
422
}
423
}
424
} else {
425
info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo));
426
info->refCount = 0;
427
}
428
429
info->consoleInterp = consoleInterp;
430
info->interp = interp;
431
432
Tcl_CallWhenDeleted(consoleInterp, InterpDeleteProc, (ClientData) info);
433
info->refCount++;
434
Tcl_CreateThreadExitHandler(DeleteConsoleInterp,
435
(ClientData) consoleInterp);
366
436
367
437
/*
368
438
* Add console commands to the interp
369
439
*/
370
info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo));
371
info->interp = interp;
372
info->consoleInterp = consoleInterp;
373
Tcl_CreateCommand(interp, "console", ConsoleCmd, (ClientData) info,
374
(Tcl_CmdDeleteProc *) ConsoleDeleteProc);
375
Tcl_CreateCommand(consoleInterp, "consoleinterp", InterpreterCmd,
376
(ClientData) info, (Tcl_CmdDeleteProc *) NULL);
377
Tcl_SetAssocData(interp, TK_CONSOLE_INFO_KEY, NULL, (ClientData) info);
378
379
Tk_CreateEventHandler(mainWindow, StructureNotifyMask, ConsoleEventProc,
380
(ClientData) info);
440
441
token = Tcl_CreateObjCommand(interp, "console", ConsoleObjCmd,
442
(ClientData) info, ConsoleDeleteProc);
443
info->refCount++;
444
445
/*
446
* We don't have to count the ref held by the [consoleinterp] command
447
* in the consoleInterp. The ref held by the consoleInterp delete
448
* handler takes care of us.
449
*/
450
Tcl_CreateObjCommand(consoleInterp, "consoleinterp", InterpreterObjCmd,
451
(ClientData) info, NULL);
452
453
mainWindow = Tk_MainWindow(interp);
454
if (mainWindow) {
455
Tk_CreateEventHandler(mainWindow, StructureNotifyMask,
456
ConsoleEventProc, (ClientData) info);
457
info->refCount++;
458
}
381
459
382
460
Tcl_Preserve((ClientData) consoleInterp);
383
if (Tcl_Eval(consoleInterp, initCmd) == TCL_ERROR) {
384
/* goto error; -- no problem for now... */
385
printf("Eval error: %s", consoleInterp->result);
461
result = Tcl_GlobalEval(consoleInterp, initCmd);
462
if (result == TCL_ERROR) {
463
Tcl_Obj *objPtr = Tcl_GetVar2Ex(consoleInterp, "errorCode", NULL,
464
TCL_GLOBAL_ONLY);
465
Tcl_ResetResult(interp);
466
if (objPtr) {
467
Tcl_SetObjErrorCode(interp, objPtr);
468
}
469
470
objPtr = Tcl_GetVar2Ex(consoleInterp, "errorInfo", NULL,
471
TCL_GLOBAL_ONLY);
472
if (objPtr) {
473
int numBytes;
474
CONST char *message = Tcl_GetStringFromObj(objPtr, &numBytes);
475
Tcl_AddObjErrorInfo(interp, message, numBytes);
476
}
477
Tcl_SetObjResult(interp, Tcl_GetObjResult(consoleInterp));
386
478
}
387
479
Tcl_Release((ClientData) consoleInterp);
480
if (result == TCL_ERROR) {
481
Tcl_DeleteCommandFromToken(interp, token);
482
mainWindow = Tk_MainWindow(interp);
483
if (mainWindow) {
484
Tk_DeleteEventHandler(mainWindow, StructureNotifyMask,
485
ConsoleEventProc, (ClientData) info);
486
if (--info->refCount <= 0) {
487
ckfree((char *) info);
488
}
489
}
490
goto error;
491
}
388
492
return TCL_OK;
389
493
390
494
error:
391
if (consoleInterp != NULL) {
392
Tcl_DeleteInterp(consoleInterp);
495
Tcl_AddErrorInfo(interp, "\n (creating console window)");
496
if (!Tcl_InterpDeleted(consoleInterp)) {
497
Tcl_DeleteInterp(consoleInterp);
393
498
}
394
499
return TCL_ERROR;
395
500
}
419
524
int toWrite; /* How many bytes to write? */
420
525
int *errorCode; /* Where to store error code. */
421
526
{
422
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
423
Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
527
ChannelData *data = (ChannelData *)instanceData;
528
ConsoleInfo *info = data->info;
424
529
425
530
*errorCode = 0;
426
531
Tcl_SetErrno(0);
427
532
428
if (tsdPtr->gStdoutInterp != NULL) {
429
TkConsolePrint(tsdPtr->gStdoutInterp, (int) instanceData, buf,
430
toWrite);
533
if (info) {
534
Tcl_Interp *consoleInterp = info->consoleInterp;
535
536
if (consoleInterp && !Tcl_InterpDeleted(consoleInterp)) {
537
Tcl_Obj *cmd = Tcl_NewStringObj("tk::ConsoleOutput", -1);
538
if (data->type == TCL_STDERR) {
539
Tcl_ListObjAppendElement(NULL, cmd,
540
Tcl_NewStringObj("stderr", -1));
541
} else {
542
Tcl_ListObjAppendElement(NULL, cmd,
543
Tcl_NewStringObj("stdout", -1));
544
}
545
Tcl_ListObjAppendElement(NULL, cmd, Tcl_NewStringObj(buf, toWrite));
546
Tcl_IncrRefCount(cmd);
547
Tcl_GlobalEvalObj(consoleInterp, cmd);
548
Tcl_DecrRefCount(cmd);
549
}
431
550
}
432
433
551
return toWrite;
434
552
}
435
553
483
601
ClientData instanceData; /* Unused. */
484
602
Tcl_Interp *interp; /* Unused. */
485
603
{
486
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
487
Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
488
tsdPtr->gStdoutInterp = NULL;
604
ChannelData *data = (ChannelData *)instanceData;
605
ConsoleInfo *info = data->info;
606
607
if (info) {
608
if (--info->refCount <= 0) {
609
/* Assuming the Tcl_Interp * fields must already be NULL */
610
ckfree((char *) info);
611
}
612
}
613
ckfree((char *) data);
489
614
return 0;
490
615
}
491
616
551
676
/*
552
677
*----------------------------------------------------------------------
553
678
*
554
* ConsoleCmd --
679
* ConsoleObjCmd --
555
680
*
556
681
* The console command implements a Tcl interface to the various console
557
682
* options.
558
683
*
559
684
* Results:
560
* None.
685
* A standard Tcl result.
561
686
*
562
687
* Side effects:
563
* None.
688
* See the user documentation.
564
689
*
565
690
*----------------------------------------------------------------------
566
691
*/
567
692
568
693
static int
569
ConsoleCmd(clientData, interp, argc, argv)
570
ClientData clientData; /* Not used. */
571
Tcl_Interp *interp; /* Current interpreter. */
572
int argc; /* Number of arguments. */
573
CONST char **argv; /* Argument strings. */
694
ConsoleObjCmd(clientData, interp, objc, objv)
695
ClientData clientData; /* Access to the console interp */
696
Tcl_Interp *interp; /* Current interpreter */
697
int objc; /* Number of arguments */
698
Tcl_Obj *CONST objv[]; /* Argument objects */
574
699
{
700
int index, result;
701
static CONST char *options[] = {"eval", "hide", "show", "title", NULL};
702
enum option {CON_EVAL, CON_HIDE, CON_SHOW, CON_TITLE};
703
Tcl_Obj *cmd = NULL;
575
704
ConsoleInfo *info = (ConsoleInfo *) clientData;
576
char c;
577
size_t length;
578
int result;
579
Tcl_Interp *consoleInterp;
580
581
if (argc < 2) {
582
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
583
" option ?arg arg ...?\"", (char *) NULL);
584
return TCL_ERROR;
585
}
586
587
c = argv[1][0];
588
length = strlen(argv[1]);
589
result = TCL_OK;
590
consoleInterp = info->consoleInterp;
591
Tcl_Preserve((ClientData) consoleInterp);
592
593
if ((c == 't') && (strncmp(argv[1], "title", length)) == 0) {
594
Tcl_DString dString;
595
596
Tcl_DStringInit(&dString);
597
Tcl_DStringAppend(&dString, "wm title . ", -1);
598
if (argc == 3) {
599
Tcl_DStringAppendElement(&dString, argv[2]);
600
}
601
Tcl_Eval(consoleInterp, Tcl_DStringValue(&dString));
602
Tcl_DStringFree(&dString);
603
} else if ((c == 'h') && (strncmp(argv[1], "hide", length)) == 0) {
604
Tcl_Eval(consoleInterp, "wm withdraw .");
605
} else if ((c == 's') && (strncmp(argv[1], "show", length)) == 0) {
606
Tcl_Eval(consoleInterp, "wm deiconify .");
607
} else if ((c == 'e') && (strncmp(argv[1], "eval", length)) == 0) {
608
if (argc == 3) {
609
result = Tcl_Eval(consoleInterp, argv[2]);
610
Tcl_AppendResult(interp, Tcl_GetStringResult(consoleInterp),
611
(char *) NULL);
612
} else {
613
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
614
" eval command\"", (char *) NULL);
615
result = TCL_ERROR;
616
}
705
Tcl_Interp *consoleInterp = info->consoleInterp;
706
707
if (objc < 2) {
708
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg?");
709
return TCL_ERROR;
710
}
711
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index)
712
!= TCL_OK) {
713
return TCL_ERROR;
714
}
715
716
switch ((enum option) index) {
717
case CON_EVAL:
718
if (objc != 3) {
719
Tcl_WrongNumArgs(interp, 2, objv, "script");
720
return TCL_ERROR;
721
}
722
cmd = objv[2];
723
break;
724
case CON_HIDE:
725
if (objc != 2) {
726
Tcl_WrongNumArgs(interp, 2, objv, NULL);
727
return TCL_ERROR;
728
}
729
cmd = Tcl_NewStringObj("wm withdraw .", -1);
730
break;
731
case CON_SHOW:
732
if (objc != 2) {
733
Tcl_WrongNumArgs(interp, 2, objv, NULL);
734
return TCL_ERROR;
735
}
736
cmd = Tcl_NewStringObj("wm deiconify .", -1);
737
break;
738
case CON_TITLE:
739
if (objc > 3) {
740
Tcl_WrongNumArgs(interp, 2, objv, "?title?");
741
return TCL_ERROR;
742
}
743
cmd = Tcl_NewStringObj("wm title .", -1);
744
if (objc == 3) {
745
Tcl_ListObjAppendElement(NULL, cmd, objv[2]);
746
}
747
break;
748
}
749
750
Tcl_IncrRefCount(cmd);
751
if (consoleInterp && !Tcl_InterpDeleted(consoleInterp)) {
752
Tcl_Preserve((ClientData) consoleInterp);
753
result = Tcl_GlobalEvalObj(consoleInterp, cmd);
754
if (result == TCL_ERROR) {
755
Tcl_Obj *objPtr = Tcl_GetVar2Ex(consoleInterp, "errorCode",
756
NULL, TCL_GLOBAL_ONLY);
757
Tcl_ResetResult(interp);
758
if (objPtr) {
759
Tcl_SetObjErrorCode(interp, objPtr);
760
}
761
762
objPtr = Tcl_GetVar2Ex(consoleInterp, "errorInfo",
763
NULL, TCL_GLOBAL_ONLY);
764
if (objPtr) {
765
int numBytes;
766
CONST char *message = Tcl_GetStringFromObj(objPtr, &numBytes);
767
Tcl_AddObjErrorInfo(interp, message, numBytes);
768
}
769
}
770
Tcl_SetObjResult(interp, Tcl_GetObjResult(consoleInterp));
771
Tcl_Release((ClientData) consoleInterp);
617
772
} else {
618
Tcl_AppendResult(interp, "bad option \"", argv[1],
619
"\": should be hide, show, or title",
620
(char *) NULL);
621
result = TCL_ERROR;
773
Tcl_AppendResult(interp, "no active console interp", NULL);
774
result = TCL_ERROR;
622
775
}
623
Tcl_Release((ClientData) consoleInterp);
776
Tcl_DecrRefCount(cmd);
624
777
return result;
625
778
}
626
779
627
780
/*
628
781
*----------------------------------------------------------------------
629
782
*
630
* InterpreterCmd --
783
* InterpreterObjCmd --
631
784
*
632
785
* This command allows the console interp to communicate with the
633
786
* main interpreter.
634
787
*
635
788
* Results:
636
* None.
637
*
638
* Side effects:
639
* None.
789
* A standard Tcl result.
640
790
*
641
791
*----------------------------------------------------------------------
642
792
*/
643
793
644
794
static int
645
InterpreterCmd(clientData, interp, argc, argv)
646
ClientData clientData; /* Not used. */
647
Tcl_Interp *interp; /* Current interpreter. */
648
int argc; /* Number of arguments. */
649
CONST char **argv; /* Argument strings. */
795
InterpreterObjCmd(clientData, interp, objc, objv)
796
ClientData clientData; /* Not used */
797
Tcl_Interp *interp; /* Current interpreter */
798
int objc; /* Number of arguments */
799
Tcl_Obj *CONST objv[]; /* Argument objects */
650
800
{
801
int index, result = TCL_OK;
802
static CONST char *options[] = {"eval", "record", NULL};
803
enum option {OTHER_EVAL, OTHER_RECORD};
651
804
ConsoleInfo *info = (ConsoleInfo *) clientData;
652
char c;
653
size_t length;
654
int result;
655
Tcl_Interp *consoleInterp;
656
Tcl_Interp *otherInterp;
657
658
if (argc < 2) {
659
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
660
" option ?arg arg ...?\"", (char *) NULL);
661
return TCL_ERROR;
662
}
663
664
c = argv[1][0];
665
length = strlen(argv[1]);
666
consoleInterp = info->consoleInterp;
667
Tcl_Preserve((ClientData) consoleInterp);
668
otherInterp = info->interp;
805
Tcl_Interp *otherInterp = info->interp;
806
807
if (objc < 2) {
808
Tcl_WrongNumArgs(interp, 1, objv, "option arg");
809
return TCL_ERROR;
810
}
811
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index)
812
!= TCL_OK) {
813
return TCL_ERROR;
814
}
815
816
if (objc != 3) {
817
Tcl_WrongNumArgs(interp, 2, objv, "script");
818
return TCL_ERROR;
819
}
820
821
if ((otherInterp == NULL) || Tcl_InterpDeleted(otherInterp)) {
822
Tcl_AppendResult(interp, "no active master interp", NULL);
823
return TCL_ERROR;
824
}
825
669
826
Tcl_Preserve((ClientData) otherInterp);
670
if ((c == 'e') && (strncmp(argv[1], "eval", length)) == 0) {
671
result = Tcl_GlobalEval(otherInterp, argv[2]);
672
Tcl_AppendResult(interp, otherInterp->result, (char *) NULL);
673
} else if ((c == 'r') && (strncmp(argv[1], "record", length)) == 0) {
674
Tcl_RecordAndEval(otherInterp, argv[2], TCL_EVAL_GLOBAL);
675
result = TCL_OK;
676
Tcl_ResetResult(interp);
677
Tcl_AppendResult(interp, otherInterp->result, (char *) NULL);
678
} else {
679
Tcl_AppendResult(interp, "bad option \"", argv[1],
680
"\": should be eval or record",
681
(char *) NULL);
682
result = TCL_ERROR;
827
switch ((enum option) index) {
828
case OTHER_EVAL:
829
result = Tcl_GlobalEvalObj(otherInterp, objv[2]);
830
/*
831
* TODO: Should exceptions be filtered here?
832
*/
833
if (result == TCL_ERROR) {
834
Tcl_Obj *objPtr = Tcl_GetVar2Ex(otherInterp, "errorCode",
835
NULL, TCL_GLOBAL_ONLY);
836
Tcl_ResetResult(interp);
837
if (objPtr) {
838
Tcl_SetObjErrorCode(interp, objPtr);
839
}
840
841
objPtr = Tcl_GetVar2Ex(otherInterp, "errorInfo",
842
NULL, TCL_GLOBAL_ONLY);
843
if (objPtr) {
844
int numBytes;
845
CONST char *message = Tcl_GetStringFromObj(objPtr, &numBytes);
846
Tcl_AddObjErrorInfo(interp, message, numBytes);
847
}
848
}
849
Tcl_SetObjResult(interp, Tcl_GetObjResult(otherInterp));
850
break;
851
case OTHER_RECORD:
852
Tcl_RecordAndEvalObj(otherInterp, objv[2], TCL_EVAL_GLOBAL);
853
/*
854
* By not setting result, we discard any exceptions or errors here
855
* and always return TCL_OK. All the caller wants is the
856
* interp result to display, whether that's result or error message.
857
*/
858
Tcl_SetObjResult(interp, Tcl_GetObjResult(otherInterp));
859
break;
683
860
}
684
861
Tcl_Release((ClientData) otherInterp);
685
Tcl_Release((ClientData) consoleInterp);
686
862
return result;
687
863
}
688
864
689
865
/*
690
866
*----------------------------------------------------------------------
691
867
*
868
* DeleteConsoleInterp --
869
*
870
* Thread exit handler to destroy a console interp when the
871
* thread it lives in gets torn down.
872
*
873
*----------------------------------------------------------------------
874
*/
875
876
static void
877
DeleteConsoleInterp(clientData)
878
ClientData clientData;
879
{
880
Tcl_Interp *interp = (Tcl_Interp *)clientData;
881
Tcl_DeleteInterp(interp);
882
}
883
884
/*
885
*----------------------------------------------------------------------
886
*
887
* InterpDeleteProc --
888
*
889
* React when the interp in which the console is displayed is deleted
890
* for any reason.
891
*
892
* Results:
893
* None.
894
*/
895
896
static void
897
InterpDeleteProc(clientData, interp)
898
ClientData clientData;
899
Tcl_Interp *interp;
900
{
901
ConsoleInfo *info = (ConsoleInfo *) clientData;
902
903
if(info->consoleInterp == interp) {
904
Tcl_DeleteThreadExitHandler(DeleteConsoleInterp,
905
(ClientData) info-> consoleInterp);
906
info->consoleInterp = NULL;
907
}
908
if (--info->refCount <= 0) {
909
ckfree((char *) info);
910
}
911
}
912
913
/*
914
*----------------------------------------------------------------------
915
*
692
916
* ConsoleDeleteProc --
693
917
*
694
* If the console command is deleted we destroy the console window
695
* and all associated data structures.
696
*
918
* If the console command is deleted we destroy the console window and
919
* all associated data structures.
920
697
921
* Results:
698
922
* None.
699
923
*
700
924
* Side effects:
701
* A new console it created.
925
* A new console is created.
702
926
*
703
927
*----------------------------------------------------------------------
704
928
*/
705
929
706
930
static void
707
ConsoleDeleteProc(clientData)
931
ConsoleDeleteProc(clientData)
708
932
ClientData clientData;
709
933
{
710
934
ConsoleInfo *info = (ConsoleInfo *) clientData;
711
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
712
Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
713
714
/*
715
* Also need to null this out to prevent any further use.
716
*
717
* Fix [Bug #756840]
718
*/
719
if (tsdPtr != NULL) {
720
tsdPtr->gStdoutInterp = NULL;
721
}
722
723
Tcl_DeleteInterp(info->consoleInterp);
724
info->consoleInterp = NULL;
935
936
if (info->consoleInterp) {
937
Tcl_DeleteInterp(info->consoleInterp);
938
}
939
if (--info->refCount <= 0) {
940
ckfree((char *) info);
941
}
725
942
}
726
943
727
944
/*
729
946
*
730
947
* ConsoleEventProc --
731
948
*
732
* This event procedure is registered on the main window of the
733
* slave interpreter. If the user or a running script causes the
734
* main window to be destroyed, then we need to inform the console
735
* interpreter by invoking "::tk::ConsoleExit".
736
*
949
* This event function is registered on the main window of the slave
950
* interpreter. If the user or a running script causes the main window to
951
* be destroyed, then we need to inform the console interpreter by
952
* invoking "::tk::ConsoleExit".
737
953
* Results:
738
954
* None.
739
955
*
740
956
* Side effects:
741
* Invokes the "::tk::ConsoleExit" procedure in the console interp.
957
* Invokes the "::tk::ConsoleExit" command in the console interp.
742
958
*
743
959
*----------------------------------------------------------------------
744
960
*/
748
964
ClientData clientData;
749
965
XEvent *eventPtr;
750
966
{
751
ConsoleInfo *info = (ConsoleInfo *) clientData;
752
Tcl_Interp *consoleInterp;
753
754
967
if (eventPtr->type == DestroyNotify) {
755
756
consoleInterp = info->consoleInterp;
757
758
/*
759
* It is possible that the console interpreter itself has
760
* already been deleted. In that case the consoleInterp
761
* field will be set to NULL. If the interpreter is already
762
* gone, we do not have to do any work here.
763
*/
764
765
if (consoleInterp == (Tcl_Interp *) NULL) {
766
return;
767
} else {
768
Tcl_Preserve((ClientData) consoleInterp);
769
Tcl_Eval(consoleInterp, "::tk::ConsoleExit");
770
Tcl_Release((ClientData) consoleInterp);
771
}
772
}
773
}
774
775
/*
776
*----------------------------------------------------------------------
777
*
778
* TkConsolePrint --
779
*
780
* Prints to the give text to the console. Given the main interp
781
* this functions find the appropiate console interp and forwards
782
* the text to be added to that console.
783
*
784
* Results:
785
* None.
786
*
787
* Side effects:
788
* None.
789
*
790
*----------------------------------------------------------------------
791
*/
792
793
void
794
TkConsolePrint(interp, devId, buffer, size)
795
Tcl_Interp *interp; /* Main interpreter. */
796
int devId; /* TCL_STDOUT for stdout, TCL_STDERR for
797
* stderr. */
798
CONST char *buffer; /* Text buffer. */
799
long size; /* Size of text buffer. */
800
{
801
Tcl_DString command, output;
802
ConsoleInfo *info;
803
Tcl_Interp *consoleInterp;
804
805
if (interp == NULL) {
806
return;
807
}
808
809
info = (ConsoleInfo *) Tcl_GetAssocData(interp, TK_CONSOLE_INFO_KEY, NULL);
810
if (info == NULL || info->consoleInterp == NULL) {
811
return;
812
}
813
814
Tcl_DStringInit(&command);
815
if (devId == TCL_STDERR) {
816
Tcl_DStringAppend(&command, "::tk::ConsoleOutput stderr ", -1);
817
} else {
818
Tcl_DStringAppend(&command, "::tk::ConsoleOutput stdout ", -1);
819
}
820
821
Tcl_DStringInit(&output);
822
Tcl_DStringAppend(&output, buffer, size);
823
Tcl_DStringAppendElement(&command, Tcl_DStringValue(&output));
824
Tcl_DStringFree(&output);
825
826
consoleInterp = info->consoleInterp;
827
Tcl_Preserve((ClientData) consoleInterp);
828
Tcl_Eval(consoleInterp, Tcl_DStringValue(&command));
829
Tcl_Release((ClientData) consoleInterp);
830
831
Tcl_DStringFree(&command);
968
ConsoleInfo *info = (ConsoleInfo *) clientData;
969
Tcl_Interp *consoleInterp = info->consoleInterp;
970
971
if (consoleInterp && !Tcl_InterpDeleted(consoleInterp)) {
972
Tcl_GlobalEval(consoleInterp, "tk::ConsoleExit");
973
}
974
975
if (--info->refCount <= 0) {
976
ckfree((char *) info);
977
}
978
}
832
979
}
Loggerhead is a web-based interface for Breezy
Version: 2.0.1