← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to gcl-tk/tkMain.c

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
gcl-tk/tkMain.c
 
1
/* 
 
2
 * main.c --
 
3
 *
 
4
 *      This file contains the main program for "wish", a windowing
 
5
 *      shell based on Tk and Tcl.  It also provides a template that
 
6
 *      can be used as the basis for main programs for other Tk
 
7
 *      applications.
 
8
 *
 
9
 * Copyright (c) 1990-1993 The Regents of the University of California.
 
10
 * All rights reserved.
 
11
 *
 
12
 * Permission is hereby granted, without written agreement and without
 
13
 * license or royalty fees, to use, copy, modify, and distribute this
 
14
 * software and its documentation for any purpose, provided that the
 
15
 * above copyright notice and the following two paragraphs appear in
 
16
 * all copies of this software.
 
17
 * 
 
18
 * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
 
19
 * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
 
20
 * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
 
21
 * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
22
 *
 
23
 * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
 
24
 * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
 
25
 * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
 
26
 * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
 
27
 * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
 
28
 */
 
29
 
 
30
/*  #ifndef lint */
 
31
/*  static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkMain.c,v 1.99 93/11/11 09:35:24 ouster Exp $ SPRITE (Berkeley)"; */
 
32
/*  #endif */
 
33
 
 
34
#include <string.h>
 
35
#include <stdio.h>
 
36
#include <stdlib.h>
 
37
#include <tcl.h>
 
38
#include <tk.h>
 
39
 
 
40
 
 
41
 
 
42
#if (TK_MINOR_VERSION==0 && TK_MAJOR_VERSION==4)
 
43
#define TkCreateMainWindow Tk_CreateMainWindow
 
44
#endif
 
45
 
 
46
 
 
47
/*-------------------------------------------------------------------*/
 
48
#include <unistd.h>
 
49
#include <sys/types.h>
 
50
#include <signal.h>
 
51
#include <errno.h>
 
52
 
 
53
#include "guis.h"
 
54
struct connection_state *dsfd;
 
55
/*-------------------------------------------------------------------*/
 
56
 
 
57
/*
 
58
 * Declarations for various library procedures and variables (don't want
 
59
 * to include tkInt.h or tkConfig.h here, because people might copy this
 
60
 * file out of the Tk source directory to make their own modified versions).
 
61
 */
 
62
 
 
63
/* extern void          exit _ANSI_ARGS_((int status)); */
 
64
extern int              isatty _ANSI_ARGS_((int fd));
 
65
/*
 
66
extern int              read _ANSI_ARGS_((int fd, char *buf, size_t size));
 
67
*/
 
68
extern char *           strrchr _ANSI_ARGS_((CONST char *string, int c));
 
69
 
 
70
/*
 
71
 * Global variables used by the main program:
 
72
 */
 
73
 
 
74
/* static Tk_Window mainWindow;    The main window for the application.  If
 
75
                                 * NULL then the application no longer
 
76
                                 * exists. */
 
77
static Tcl_Interp *interp;      /* Interpreter for this application. */
 
78
char *tcl_RcFileName;           /* Name of a user-specific startup script
 
79
                                 * to source if the application is being run
 
80
                                 * interactively (e.g. "~/.wishrc").  Set
 
81
                                 * by Tcl_AppInit.  NULL means don't source
 
82
                                 * anything ever. */
 
83
static Tcl_DString command;     /* Used to assemble lines of terminal input
 
84
                                 * into Tcl commands. */
 
85
static int tty;                 /* Non-zero means standard input is a
 
86
                                 * terminal-like device.  Zero means it's
 
87
                                 * a file. */
 
88
static char errorExitCmd[] = "exit 1";
 
89
 
 
90
/*
 
91
 * Command-line options:
 
92
 */
 
93
 
 
94
static int synchronize = 0;
 
95
static char *fileName = NULL;
 
96
static char *name = NULL;
 
97
static char *display = NULL;
 
98
static char *geometry = NULL;
 
99
int debug = 0;
 
100
 
 
101
static void guiCreateCommand _ANSI_ARGS_((int idLispObject, int iSlot , char *arglist));
 
102
 
 
103
void
 
104
dfprintf(FILE *fp,char *s,...) {
 
105
 
 
106
  va_list args;
 
107
 
 
108
  if (debug) {
 
109
    va_start(args,s);
 
110
    fprintf(fp,"\nguis:");
 
111
    vfprintf(fp,s,args);
 
112
    fflush(fp);
 
113
    va_end(args);
 
114
  }
 
115
}
 
116
 
 
117
#define CMD_SIZE 4000
 
118
#define SIGNAL_ERROR TCL_signal_error
 
119
 
 
120
static void
 
121
TCL_signal_error(x)
 
122
     char *x;
 
123
{char buf[300] ;
 
124
 sprintf("error %s",x);
 
125
 Tcl_Eval(interp,buf);
 
126
 dfprintf(stderr,x);
 
127
}
 
128
 
 
129
 
 
130
 
 
131
static Tk_ArgvInfo argTable[] = {
 
132
    {"-file", TK_ARGV_STRING, (char *) NULL, (char *) &fileName,
 
133
        "File from which to read commands"},
 
134
    {"-geometry", TK_ARGV_STRING, (char *) NULL, (char *) &geometry,
 
135
        "Initial geometry for window"},
 
136
    {"-display", TK_ARGV_STRING, (char *) NULL, (char *) &display,
 
137
        "Display to use"},
 
138
    {"-name", TK_ARGV_STRING, (char *) NULL, (char *) &name,
 
139
        "Name to use for application"},
 
140
    {"-sync", TK_ARGV_CONSTANT, (char *) 1, (char *) &synchronize,
 
141
        "Use synchronous mode for display server"},
 
142
    {(char *) NULL, TK_ARGV_END, (char *) NULL, (char *) NULL,
 
143
        (char *) NULL}
 
144
};
 
145
 
 
146
/*
 
147
 * Declaration for Tcl command procedure to create demo widget.  This
 
148
 * procedure is only invoked if SQUARE_DEMO is defined.
 
149
 */
 
150
 
 
151
extern int SquareCmd _ANSI_ARGS_((ClientData clientData,
 
152
        Tcl_Interp *interp, int argc, char *argv[]));
 
153
 
 
154
/*
 
155
 * Forward declarations for procedures defined later in this file:
 
156
 */
 
157
 
 
158
static void             StdinProc _ANSI_ARGS_((ClientData clientData,
 
159
                            int mask));
 
160
 
 
161
/*
 
162
 *----------------------------------------------------------------------
 
163
 *
 
164
 * main --
 
165
 *
 
166
 *      Main program for Wish.
 
167
 *
 
168
 * Results:
 
169
 *      None. This procedure never returns (it exits the process when
 
170
 *      it's done
 
171
 *
 
172
 * Side effects:
 
173
 *      This procedure initializes the wish world and then starts
 
174
 *      interpreting commands;  almost anything could happen, depending
 
175
 *      on the script being interpreted.
 
176
 *
 
177
 *----------------------------------------------------------------------
 
178
 */
 
179
/*
 
180
int
 
181
main(argc, argv)
 
182
*/
 
183
 
 
184
/* FIXME, should come in from tk header or not be called */
 
185
EXTERN Tk_Window        TkCreateMainWindow _ANSI_ARGS_((Tcl_Interp * interp, 
 
186
                                char * screenName, char * baseName));
 
187
 
 
188
void
 
189
TkX_Wish (argc, argv)
 
190
    int argc;                           /* Number of arguments. */
 
191
    char **argv;                        /* Array of argument strings. */
 
192
{
 
193
    char *args, *p;
 
194
    const char *msg;
 
195
    char buf[20];
 
196
    int code;
 
197
 
 
198
    interp = Tcl_CreateInterp();
 
199
#ifdef TCL_MEM_DEBUG
 
200
    Tcl_InitMemory(interp);
 
201
#endif
 
202
 
 
203
    /*
 
204
     * Parse command-line arguments.
 
205
     */
 
206
 
 
207
    if (Tk_ParseArgv(interp, (Tk_Window) NULL, &argc, (const char **)argv, argTable, 0)
 
208
            != TCL_OK) {
 
209
        fprintf(stderr, "%s\n", interp->result);
 
210
        exit(1);
 
211
    }
 
212
    if (name == NULL) {
 
213
        if (fileName != NULL) {
 
214
            p = fileName;
 
215
        } else {
 
216
            p = argv[0];
 
217
        }
 
218
        name = strrchr(p, '/');
 
219
        if (name != NULL) {
 
220
            name++;
 
221
        } else {
 
222
            name = p;
 
223
        }
 
224
    }
 
225
 
 
226
    /*
 
227
     * If a display was specified, put it into the DISPLAY
 
228
     * environment variable so that it will be available for
 
229
     * any sub-processes created by us.
 
230
     */
 
231
 
 
232
    if (display != NULL) {
 
233
        Tcl_SetVar2(interp, "env", "DISPLAY", display, TCL_GLOBAL_ONLY);
 
234
    }
 
235
 
 
236
    /*
 
237
     * Initialize the Tk application.
 
238
     */
 
239
 
 
240
/*     mainWindow = TkCreateMainWindow(interp, display, name/\*  , "Tk" *\/);  */
 
241
/*     if (mainWindow == NULL) { */
 
242
/*      fprintf(stderr, "%s\n", interp->result); */
 
243
/*      exit(1); */
 
244
/*     } */
 
245
/* #ifndef __MINGW32__     */
 
246
/*     if (synchronize) { */
 
247
/*      XSynchronize(Tk_Display(mainWindow), True); */
 
248
/*     } */
 
249
/* #endif     */
 
250
/*     Tk_GeometryRequest(mainWindow, 200, 200); */
 
251
/*     Tk_UnmapWindow(mainWindow); */
 
252
 
 
253
    /*
 
254
     * Make command-line arguments available in the Tcl variables "argc"
 
255
     * and "argv".  Also set the "geometry" variable from the geometry
 
256
     * specified on the command line.
 
257
     */
 
258
 
 
259
    args = Tcl_Merge(argc-1, (const char **)argv+1);
 
260
    Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
 
261
    ckfree(args);
 
262
    sprintf(buf, "%d", argc-1);
 
263
    Tcl_SetVar(interp, "argc", buf, TCL_GLOBAL_ONLY);
 
264
    Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0],
 
265
            TCL_GLOBAL_ONLY);
 
266
    if (geometry != NULL) {
 
267
        Tcl_SetVar(interp, "geometry", geometry, TCL_GLOBAL_ONLY);
 
268
    }
 
269
 
 
270
    /*
 
271
     * Set the "tcl_interactive" variable.
 
272
     */
 
273
 
 
274
    tty = isatty(dsfd->fd);
 
275
    Tcl_SetVar(interp, "tcl_interactive",
 
276
            ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY);
 
277
 
 
278
    /*
 
279
     * Add a few application-specific commands to the application's
 
280
     * interpreter.
 
281
     */
 
282
 
 
283
/* #ifdef SQUARE_DEMO */
 
284
/*     Tcl_CreateCommand(interp, "square", SquareCmd, (ClientData) mainWindow, */
 
285
/*          (void (*)()) NULL); */
 
286
/* #endif */
 
287
 
 
288
    /*
 
289
     * Invoke application-specific initialization.
 
290
     */
 
291
 
 
292
    if (Tcl_AppInit(interp) != TCL_OK) {
 
293
        fprintf(stderr, "Tcl_AppInit failed: %s\n", interp->result);
 
294
    }
 
295
 
 
296
    /*
 
297
     * Set the geometry of the main window, if requested.
 
298
     */
 
299
 
 
300
    if (geometry != NULL) {
 
301
        code = Tcl_VarEval(interp, "wm geometry . ", geometry, (char *) NULL);
 
302
        if (code != TCL_OK) {
 
303
            fprintf(stderr, "%s\n", interp->result);
 
304
        }
 
305
    }
 
306
 
 
307
    /*
 
308
     * Invoke the script specified on the command line, if any.
 
309
     */
 
310
 
 
311
    if (fileName != NULL) {
 
312
        code = Tcl_VarEval(interp, "source ", fileName, (char *) NULL);
 
313
        if (code != TCL_OK) {
 
314
            goto error;
 
315
        }
 
316
        tty = 0;
 
317
    } else {
 
318
        /*
 
319
         * Commands will come from standard input, so set up an event
 
320
         * handler for standard input.  If the input device is aEvaluate the
 
321
         * .rc file, if one has been specified, set up an event handler
 
322
         * for standard input, and print a prompt if the input
 
323
         * device is a terminal.
 
324
         */
 
325
 
 
326
        if (tcl_RcFileName != NULL) {
 
327
            Tcl_DString buffer;
 
328
            char *fullName;
 
329
            FILE *f;
 
330
    
 
331
            fullName = Tcl_TildeSubst(interp, tcl_RcFileName, &buffer);
 
332
            if (fullName == NULL) {
 
333
                fprintf(stderr, "%s\n", interp->result);
 
334
            } else {
 
335
                f = fopen(fullName, "r");
 
336
                if (f != NULL) {
 
337
                    code = Tcl_EvalFile(interp, fullName);
 
338
                    if (code != TCL_OK) {
 
339
                        fprintf(stderr, "%s\n", interp->result);
 
340
                    }
 
341
                    fclose(f);
 
342
                }
 
343
            }
 
344
            Tcl_DStringFree(&buffer);
 
345
        }
 
346
 
 
347
        dfprintf(stderr, "guis : Creating file handler for %d\n", dsfd->fd);
 
348
#ifndef __MINGW32__     
 
349
        Tk_CreateFileHandler(dsfd->fd, TK_READABLE, StdinProc, (ClientData) 0);
 
350
#endif        
 
351
    }
 
352
    fflush(stdout);
 
353
    Tcl_DStringInit(&command);
 
354
 
 
355
    /*
 
356
     * Loop infinitely, waiting for commands to execute.  When there
 
357
     * are no windows left, Tk_MainLoop returns and we exit.
 
358
     */
 
359
 
 
360
    Tk_MainLoop();
 
361
 
 
362
    /*
 
363
     * Don't exit directly, but rather invoke the Tcl "exit" command.
 
364
     * This gives the application the opportunity to redefine "exit"
 
365
     * to do additional cleanup.
 
366
     */
 
367
 
 
368
    Tcl_Eval(interp, "exit");
 
369
    exit(1);
 
370
 
 
371
error:
 
372
    msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
 
373
    if (msg == NULL) {
 
374
        msg = interp->result;
 
375
    }
 
376
    dfprintf(stderr, "%s\n", msg);
 
377
    Tcl_Eval(interp, errorExitCmd);
 
378
    return;                     /* Needed only to prevent compiler warnings. */
 
379
}
 
380
 
 
381
static char *being_set_by_lisp;
 
382
 
 
383
static char *
 
384
tell_lisp_var_changed(
 
385
                clientData,
 
386
               interp,
 
387
               name1,
 
388
               name2,
 
389
                flags)
 
390
 
 
391
          ClientData clientData;
 
392
               Tcl_Interp *interp;
 
393
               char *name1;
 
394
               char *name2;
 
395
               int flags;     
 
396
     
 
397
{
 
398
 
 
399
  if (being_set_by_lisp == 0)
 
400
    { const char *val = Tcl_GetVar2(interp,name1,name2, TCL_GLOBAL_ONLY);
 
401
      char buf[3];
 
402
      STORE_3BYTES(buf,(long) clientData);
 
403
      if(sock_write_str2(dsfd,   m_set_lisp_loc, buf, 3 ,
 
404
                                 val, strlen(val))
 
405
                 < 0)
 
406
                {               /* what do we want to do if the write failed */}
 
407
#ifndef __MINGW32__           
 
408
    if (parent > 0)  kill(parent, SIGUSR1);
 
409
#endif      
 
410
    }
 
411
  else
 
412
  /* avoid going back to lisp if it is lisp that is doing the setting! */
 
413
    if (strcmp(being_set_by_lisp,name1))
 
414
      { fprintf(stderr,"recursive setting of vars %s??",name1);}
 
415
  /* normal */
 
416
  return 0;
 
417
}
 
418
 
 
419
 
 
420
/*
 
421
 *----------------------------------------------------------------------
 
422
 *
 
423
 * StdinProc --
 
424
 *
 
425
 *      This procedure is invoked by the event dispatcher whenever
 
426
 *      standard input becomes readable.  It grabs the next line of
 
427
 *      input characters, adds them to a command being assembled, and
 
428
 *      executes the command if it's complete.
 
429
 *
 
430
 * Results:
 
431
 *      None.
 
432
 *
 
433
 * Side effects:
 
434
 *      Could be almost arbitrary, depending on the command that's
 
435
 *      typed.
 
436
 *
 
437
 *----------------------------------------------------------------------
 
438
 */
 
439
 
 
440
    /* ARGSUSED */
 
441
static void
 
442
StdinProc(clientData, mask)
 
443
     ClientData clientData;             /* Not used. */
 
444
     int mask;                          /* Not used. */
 
445
{
 
446
  int fNotDone;
 
447
  char *cmd;
 
448
  int code, count;
 
449
  struct message_header *msg;
 
450
  char buf[0x4000];
 
451
  msg = (struct message_header *) buf;
 
452
 
 
453
  /*
 
454
   * Disable the stdin file handler while evaluating the command;
 
455
   * otherwise if the command re-enters the event loop we might
 
456
   * process commands from stdin before the current command is
 
457
   * finished.  Among other things, this will trash the text of the
 
458
   * command being evaluated.
 
459
   */
 
460
  dfprintf(stderr, "\nguis : Disabling file handler for %d\n", dsfd->fd);
 
461
 
 
462
/*  Tk_CreateFileHandler(dsfd->fd, 0, StdinProc, (ClientData) 0); */
 
463
 
 
464
  do
 
465
    { 
 
466
 
 
467
      msg = guiParseMsg1(dsfd,buf,sizeof(buf));
 
468
 
 
469
      if (msg == NULL)
 
470
        {
 
471
          /*dfprintf(stderr, "Yoo !!! Empty command\n"); */
 
472
          if (debug)perror("zero message");
 
473
#ifndef __MINGW32__          
 
474
          Tk_CreateFileHandler(dsfd->fd, TK_READABLE, StdinProc, (ClientData) 0);
 
475
#endif          
 
476
          return;
 
477
        }
 
478
 
 
479
      /* Need to switch to table lookup */
 
480
      switch (msg->type){
 
481
      case m_create_command:
 
482
          {
 
483
            int iSlot;
 
484
            GET_3BYTES(msg->body,iSlot);
 
485
            guiCreateCommand(0, iSlot, &(msg->body[3]));
 
486
          }
 
487
          break;
 
488
        case  m_tcl_command :
 
489
        case m_tcl_command_wait_response:
 
490
          count = strlen(msg->body);
 
491
          cmd = Tcl_DStringAppend(&command, msg->body, count);
 
492
 
 
493
          code = Tcl_RecordAndEval(interp, cmd, 0);
 
494
 
 
495
          if (msg->type == m_tcl_command_wait_response
 
496
              || code)
 
497
            {
 
498
              unsigned char buf[4];
 
499
              unsigned char *p = buf;
 
500
              /*header */
 
501
              *p++ = (code ? '1' : '0');
 
502
              bcopy(msg->msg_id,p,3);
 
503
              /* end header */
 
504
              if(sock_write_str2(dsfd, m_reply, buf, 4 ,
 
505
                                 interp->result, strlen(interp->result))
 
506
                 < 0)
 
507
                {               /* what do we want to do if the write failed */}
 
508
              
 
509
              if (msg->type == m_tcl_command_wait_response)
 
510
                { /* parent is waiting so dong signal */ ;}
 
511
#ifndef __MINGW32__              
 
512
              else
 
513
                if (parent> 0)kill(parent, SIGUSR1);
 
514
#endif              
 
515
            }
 
516
 
 
517
          Tcl_DStringFree(&command);
 
518
          break;
 
519
        case m_tcl_clear_connection:
 
520
          /* we are stuck... */
 
521
          {
 
522
            Tcl_DStringInit(&command);
 
523
            Tcl_DStringFree(&command);
 
524
            fSclear_connection(dsfd->fd);
 
525
          }
 
526
          break;
 
527
        case m_tcl_set_text_variable:
 
528
          { int n = strlen(msg->body);
 
529
            if(being_set_by_lisp) fprintf(stderr,"recursive set?");
 
530
            /* avoid a trace on this set!! */
 
531
            
 
532
            being_set_by_lisp = msg->body;
 
533
            Tcl_SetVar2(interp,msg->body,0,msg->body+n+1,
 
534
                        TCL_GLOBAL_ONLY);
 
535
            being_set_by_lisp = 0;
 
536
             }
 
537
          break;
 
538
 
 
539
        case m_tcl_link_text_variable:
 
540
          {long i;
 
541
           GET_3BYTES(msg->body,i);
 
542
           Tcl_TraceVar2(interp,msg->body+3 ,0,
 
543
                           TCL_TRACE_WRITES
 
544
                           | TCL_TRACE_UNSETS
 
545
                           | TCL_GLOBAL_ONLY
 
546
                           , tell_lisp_var_changed, (ClientData) i);
 
547
         }
 
548
           break;
 
549
 
 
550
        case m_tcl_unlink_text_variable:
 
551
          {long i;
 
552
           GET_3BYTES(msg->body,i);
 
553
           Tcl_UntraceVar2(interp,msg->body+3 ,0,
 
554
                           TCL_TRACE_WRITES
 
555
                           | TCL_TRACE_UNSETS
 
556
                           | TCL_GLOBAL_ONLY
 
557
                           , tell_lisp_var_changed, (ClientData) i);
 
558
         }
 
559
          break;
 
560
 
 
561
        default :
 
562
          dfprintf(stderr, "Error !!! Unknown command %d\n"
 
563
                   , msg->type);
 
564
        }
 
565
      fNotDone = fix(fScheck_dsfd_for_input(dsfd,0));
 
566
      
 
567
      if (fNotDone > 0)
 
568
        {
 
569
          dfprintf(stderr, "\nguis : in StdinProc, not done, executed %s"
 
570
                  ,  msg->body);
 
571
 
 
572
        }
 
573
    } while (fNotDone > 0);
 
574
 
 
575
 
 
576
  /* Tk_CreateFileHandler(dsfd->fd, TK_READABLE, StdinProc, (ClientData) 0); */
 
577
  if ((void *)msg != (void *) buf)
 
578
    free ((void *) msg);
 
579
}
 
580
 
 
581
/* ----------------------------------------------------------------- */
 
582
typedef struct _ClientDataLispObject {
 
583
  int id;
 
584
  int iSlot;
 
585
  char *arglist;
 
586
} ClientDataLispObject;
 
587
 
 
588
static int
 
589
TclGenericCommandProcedure( clientData,
 
590
                           pinterp,
 
591
                            argc, argv)
 
592
     ClientData clientData;
 
593
     Tcl_Interp *pinterp;
 
594
     int argc;
 
595
     char *argv[];
 
596
{
 
597
  char szCmd[CMD_SIZE];
 
598
  ClientDataLispObject *pcdlo = (ClientDataLispObject *)clientData;
 
599
  int cb=0;
 
600
  char *q = szCmd;
 
601
  char *p = pcdlo->arglist;
 
602
 
 
603
  STORE_3BYTES(q,(pcdlo->iSlot));
 
604
  q += 3;
 
605
  if (p == 0)
 
606
    { char *arg = (argc > 1 ? argv[1] : "");
 
607
      int m = strlen(arg);
 
608
      if (m > CMD_SIZE -50)
 
609
        SIGNAL_ERROR("too big command");
 
610
      bcopy(arg,q,m);
 
611
      q += m ;}
 
612
  else
 
613
    { int i,n;
 
614
      *q++ = '(';
 
615
      n = strlen(p);
 
616
      for (i=1; i< argc; i++)
 
617
        { if (i < n && p[i]=='s')   { *q++ = '"';}
 
618
          strcpy(q,argv[i]);
 
619
          q+= strlen(argv[i]);
 
620
          if (i < n && p[i]=='s')   { *q++ = '"';}
 
621
        }
 
622
      *q++ = ')';
 
623
    }
 
624
  *q = 0;
 
625
     
 
626
  dfprintf(stderr, "TclGenericCommandProcedure : %s\n"
 
627
          , szCmd
 
628
          );
 
629
 
 
630
  if (sock_write_str2(dsfd,m_call, "",0, szCmd, q-szCmd) == -1)
 
631
    {
 
632
      dfprintf(stderr,
 
633
      "Error\t(TclGenericCommandProcedure) !!!\n\tFailed to write [%s] to socket %d (%d) cb=%d\n"
 
634
              , szCmd, dsfd->fd, errno, cb);
 
635
 
 
636
    }
 
637
#ifndef __MINGW32__  
 
638
  if (parent > 0)kill(parent, SIGUSR1);
 
639
#endif  
 
640
  return TCL_OK;
 
641
}
 
642
 
 
643
 
 
644
 
 
645
static void
 
646
guiCreateCommand( idLispObject,  iSlot , arglist)
 
647
     int idLispObject; int iSlot ; char *arglist;
 
648
{
 
649
  char szNameCmdProc[2000],*c;
 
650
  ClientDataLispObject *pcdlo;
 
651
 
 
652
  sprintf(szNameCmdProc, "callback_%d",iSlot);
 
653
 
 
654
  pcdlo = (ClientDataLispObject *)malloc(sizeof(ClientDataLispObject));
 
655
  pcdlo->id = idLispObject;
 
656
  pcdlo->iSlot = iSlot;
 
657
  if (arglist[0] == 0)
 
658
    { pcdlo->arglist = 0;}
 
659
  else
 
660
  {c= malloc(strlen(arglist)+1);
 
661
   strcpy(c,arglist);
 
662
   pcdlo->arglist = c;}
 
663
  Tcl_CreateCommand(interp
 
664
                    , szNameCmdProc, TclGenericCommandProcedure
 
665
                    , (ClientData *)pcdlo, free);
 
666
  dfprintf(stderr, "TCL creating callback : %s\n", szNameCmdProc);
 
667
 
 
668
/*  guiBindCallback(szNameCmdProc, szTclObject, szModifier,arglist); */
 
669
}
 
670
 
 
671
/*
 
672
int
 
673
guiBindCallback(char *szNameCmdProc, char *szTclObject, char *szModifier,char* arglist)
 
674
{
 
675
  int code;
 
676
  char szCmd[2000];
 
677
 
 
678
  sprintf(szCmd, "bind %s %s {%s %s}"
 
679
          , szTclObject
 
680
          , szModifier
 
681
          , szNameCmdProc
 
682
          , (arglist ? arglist : "")
 
683
          );
 
684
  dfprintf(stderr, "TCL BIND : %s\n", szCmd);
 
685
 
 
686
  code = Tcl_Eval(interp, szCmd);
 
687
  if (code != TCL_OK)
 
688
    {
 
689
      dfprintf(stderr, "TCL Error int bind : %s\n", interp->result);
 
690
 
 
691
    }
 
692
  return code;
 
693
}
 
694
*/
 
695
/* static void */
 
696
/* guiDeleteCallback(szCallback) */
 
697
/*      char *szCallback; */
 
698
/* { */
 
699
/*   dfprintf(stderr, "Tcl Deleting command : %s\n", szCallback); */
 
700
 
 
701
/*   Tcl_DeleteCommand(interp, szCallback); */
 
702
/* } */
 
703
 
 
704
/*  */
 
705