summaryrefslogtreecommitdiffstats
path: root/mac/tclMacBOAMain.c
blob: ebec08231c006e1cd0a687d86a07e412a043f69a (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
/* 
 * tclMacBGMain.c --
 *
 *	Main program for Macintosh Background Only Application shells.
 *
 * Copyright (c) 1997 Sun Microsystems, Inc.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclMacBOAMain.c,v 1.2 1998/09/14 18:40:04 stanton Exp $
 */

#include "tcl.h"
#include "tclInt.h"
#include "tclMacInt.h"
#include <Resources.h>
#include <Notification.h>
#include <Strings.h>

/*
 * This variable is used to get out of the modal loop of the
 * notification manager.
 */

int NotificationIsDone = 0;

/*
 * The following code ensures that tclLink.c is linked whenever
 * Tcl is linked.  Without this code there's no reference to the
 * code in that file from anywhere in Tcl, so it may not be
 * linked into the application.
 */

EXTERN int Tcl_LinkVar();
int (*tclDummyLinkVarPtr)() = Tcl_LinkVar;

/*
 * Declarations for various library procedures and variables (don't want
 * to include tclPort.h here, because people might copy this file out of
 * the Tcl source directory to make their own modified versions).
 * Note:  "exit" should really be declared here, but there's no way to
 * declare it without causing conflicts with other definitions elsewher
 * on some systems, so it's better just to leave it out.
 */

extern int		isatty _ANSI_ARGS_((int fd));
extern char *		strcpy _ANSI_ARGS_((char *dst, CONST char *src));

static Tcl_Interp *interp;	/* Interpreter for application. */

#ifdef TCL_MEM_DEBUG
static char dumpFile[100];	/* Records where to dump memory allocation
				 * information. */
static int quitFlag = 0;	/* 1 means "checkmem" command was called,
				 * so the application should quit and dump
				 * memory allocation information. */
#endif

/*
 * Forward references for procedures defined later in this file:
 */

#ifdef TCL_MEM_DEBUG
static int		CheckmemCmd _ANSI_ARGS_((ClientData clientData,
			    Tcl_Interp *interp, int argc, char *argv[]));
#endif
void TclMacDoNotification(char *mssg);
void TclMacNotificationResponse(NMRecPtr nmRec); 
int Tcl_MacBGNotifyObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv);


/*
 *----------------------------------------------------------------------
 *
 * Tcl_Main --
 *
 *	Main program for tclsh and most other Tcl-based applications.
 *
 * Results:
 *	None. This procedure never returns (it exits the process when
 *	it's done.
 *
 * Side effects:
 *	This procedure initializes the Tk world and then starts
 *	interpreting commands;  almost anything could happen, depending
 *	on the script being interpreted.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_Main(argc, argv, appInitProc)
    int argc;			/* Number of arguments. */
    char **argv;		/* Array of argument strings. */
    Tcl_AppInitProc *appInitProc;
				/* Application-specific initialization
				 * procedure to call after most
				 * initialization but before starting to
				 * execute commands. */
{
    Tcl_Obj *prompt1NamePtr = NULL;
    Tcl_Obj *prompt2NamePtr = NULL;
    Tcl_Obj *commandPtr = NULL;
    char buffer[1000], *args, *fileName;
    int code, tty;
    int exitCode = 0;

    Tcl_FindExecutable(argv[0]);
    interp = Tcl_CreateInterp();
#ifdef TCL_MEM_DEBUG
    Tcl_InitMemory(interp);
    Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
	    (Tcl_CmdDeleteProc *) NULL);
#endif

    /*
     * Make command-line arguments available in the Tcl variables "argc"
     * and "argv".  If the first argument doesn't start with a "-" then
     * strip it off and use it as the name of a script file to process.
     */

    fileName = NULL;
    if ((argc > 1) && (argv[1][0] != '-')) {
	fileName = argv[1];
	argc--;
	argv++;
    }
    args = Tcl_Merge(argc-1, argv+1);
    Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
    ckfree(args);
    TclFormatInt(buffer, argc-1);
    Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY);
    Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0],
	    TCL_GLOBAL_ONLY);

    /*
     * Set the "tcl_interactive" variable.
     */

    tty = isatty(0);
    Tcl_SetVar(interp, "tcl_interactive",
	    ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY);
    
    /*
     * Invoke application-specific initialization.
     */

    if ((*appInitProc)(interp) != TCL_OK) {
	    Tcl_DString errStr;
	    Tcl_DStringInit(&errStr);
	    Tcl_DStringAppend(&errStr,
		    "application-specific initialization failed: \n", -1);
	    Tcl_DStringAppend(&errStr, interp->result, -1);
	    Tcl_DStringAppend(&errStr, "\n", 1);
	    TclMacDoNotification(Tcl_DStringValue(&errStr));
	    goto done;
    }

    /*
     * Install the BGNotify command:
     */
    
    if ( Tcl_CreateObjCommand(interp, "bgnotify", Tcl_MacBGNotifyObjCmd, NULL,
             (Tcl_CmdDeleteProc *) NULL) == NULL) {
        goto done;
    }
    
    /*
     * If a script file was specified then just source that file
     * and quit.  In this Mac BG Application version, we will try the
     * resource fork first, then the file system second...
     */

    if (fileName != NULL) {
        Str255 resName;
        Handle resource;
        
        strcpy((char *) resName + 1, fileName);
        resName[0] = strlen(fileName);
        resource = GetNamedResource('TEXT',resName);
        if (resource != NULL) {
            code = Tcl_MacEvalResource(interp, fileName, -1, NULL);
        } else {
            code = Tcl_EvalFile(interp, fileName);
        }
        
	if (code != TCL_OK) {
            Tcl_DString errStr;
            
            Tcl_DStringInit(&errStr);
            Tcl_DStringAppend(&errStr, " Error sourcing resource or file: ", -1);
            Tcl_DStringAppend(&errStr, fileName, -1);
            Tcl_DStringAppend(&errStr, "\n\nError was: ", -1);
            Tcl_DStringAppend(&errStr, interp->result, -1);
                        
            TclMacDoNotification(Tcl_DStringValue(&errStr));
                        
        }
	goto done;
    }


    /*
     * Rather than calling exit, invoke the "exit" command so that
     * users can replace "exit" with some other command to do additional
     * cleanup on exit.  The Tcl_Eval call should never return.
     */

    done:
    if (commandPtr != NULL) {
	Tcl_DecrRefCount(commandPtr);
    }
    if (prompt1NamePtr != NULL) {
	Tcl_DecrRefCount(prompt1NamePtr);
    }
    if (prompt2NamePtr != NULL) {
	Tcl_DecrRefCount(prompt2NamePtr);
    }
    sprintf(buffer, "exit %d", exitCode);
    Tcl_Eval(interp, buffer);
}

/*----------------------------------------------------------------------
 *
 * TclMacDoNotification --
 *
 *	This posts an error message using the Notification manager.
 *
 * Results:
 *	Post a Notification Manager dialog.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */
void 
TclMacDoNotification(mssg)
    char *mssg;
{
    NMRec errorNot;
    EventRecord *theEvent = NULL;
    OSErr err;
    char *ptr;
    
    errorNot.qType = nmType;
    errorNot.nmMark = 0;
    errorNot.nmIcon = 0;
    errorNot.nmSound = (Handle) -1;

    for ( ptr = mssg; *ptr != '\0'; ptr++) {
        if (*ptr == '\n') {
            *ptr = '\r';
        }
    }
        
    c2pstr(mssg);
    errorNot.nmStr = (StringPtr) mssg;

    errorNot.nmResp = NewNMProc(TclMacNotificationResponse);
    errorNot.nmRefCon = SetCurrentA5();
    
    NotificationIsDone = 0;
    
    /*
     * Cycle while waiting for the user to click on the
     * notification box.  Don't take any events off the event queue,
     * since we want Tcl to do this but we want to block till the notification
     * has been handled...
     */
    
    err = NMInstall(&errorNot);
    if (err == noErr) { 
        while (!NotificationIsDone) {
            WaitNextEvent(0, theEvent, 20, NULL);
        }
        NMRemove(&errorNot);
    }
    	
    p2cstr((unsigned char *) mssg);
}

void 
TclMacNotificationResponse(nmRec) 
    NMRecPtr nmRec;
{
    int curA5;
    
    curA5 = SetCurrentA5();
    SetA5(nmRec->nmRefCon);
    
    NotificationIsDone = 1;
    
    SetA5(curA5);
    
}

int 
Tcl_MacBGNotifyObjCmd(clientData, interp, objc, objv)
    ClientData clientData;
    Tcl_Interp *interp;
    int objc;
    Tcl_Obj **objv;	
{
    Tcl_Obj *resultPtr;
    
    resultPtr = Tcl_GetObjResult(interp);
    
    if ( objc != 2 ) {
        Tcl_WrongNumArgs(interp, 1, objv, "message");
        return TCL_ERROR;
    }
    
    TclMacDoNotification(Tcl_GetStringFromObj(objv[1], (int *) NULL));
    return TCL_OK;
           
}


/*
 *----------------------------------------------------------------------
 *
 * CheckmemCmd --
 *
 *	This is the command procedure for the "checkmem" command, which
 *	causes the application to exit after printing information about
 *	memory usage to the file passed to this command as its first
 *	argument.
 *
 * Results:
 *	Returns a standard Tcl completion code.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */
#ifdef TCL_MEM_DEBUG

	/* ARGSUSED */
static int
CheckmemCmd(clientData, interp, argc, argv)
    ClientData clientData;		/* Not used. */
    Tcl_Interp *interp;			/* Interpreter for evaluation. */
    int argc;				/* Number of arguments. */
    char *argv[];			/* String values of arguments. */
{
    extern char *tclMemDumpFileName;
    if (argc != 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" fileName\"", (char *) NULL);
	return TCL_ERROR;
    }
    strcpy(dumpFile, argv[1]);
    tclMemDumpFileName = dumpFile;
    quitFlag = 1;
    return TCL_OK;
}
#endif