OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tcl/] [mac/] [tclMacBOAMain.c] - Blame information for rev 1774

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom
/*
2
 * tclMacBGMain.c --
3
 *
4
 *      Main program for Macintosh Background Only Application shells.
5
 *
6
 * Copyright (c) 1997 Sun Microsystems, Inc.
7
 *
8
 * See the file "license.terms" for information on usage and redistribution
9
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
10
 *
11
 * RCS: @(#) $Id: tclMacBOAMain.c,v 1.1.1.1 2002-01-16 10:25:30 markom Exp $
12
 */
13
 
14
#include "tcl.h"
15
#include "tclInt.h"
16
#include "tclMacInt.h"
17
#include <Resources.h>
18
#include <Notification.h>
19
#include <Strings.h>
20
 
21
/*
22
 * This variable is used to get out of the modal loop of the
23
 * notification manager.
24
 */
25
 
26
int NotificationIsDone = 0;
27
 
28
/*
29
 * The following code ensures that tclLink.c is linked whenever
30
 * Tcl is linked.  Without this code there's no reference to the
31
 * code in that file from anywhere in Tcl, so it may not be
32
 * linked into the application.
33
 */
34
 
35
EXTERN int Tcl_LinkVar();
36
int (*tclDummyLinkVarPtr)() = Tcl_LinkVar;
37
 
38
/*
39
 * Declarations for various library procedures and variables (don't want
40
 * to include tclPort.h here, because people might copy this file out of
41
 * the Tcl source directory to make their own modified versions).
42
 * Note:  "exit" should really be declared here, but there's no way to
43
 * declare it without causing conflicts with other definitions elsewher
44
 * on some systems, so it's better just to leave it out.
45
 */
46
 
47
extern int              isatty _ANSI_ARGS_((int fd));
48
extern char *           strcpy _ANSI_ARGS_((char *dst, CONST char *src));
49
 
50
static Tcl_Interp *interp;      /* Interpreter for application. */
51
 
52
#ifdef TCL_MEM_DEBUG
53
static char dumpFile[100];      /* Records where to dump memory allocation
54
                                 * information. */
55
static int quitFlag = 0; /* 1 means "checkmem" command was called,
56
                                 * so the application should quit and dump
57
                                 * memory allocation information. */
58
#endif
59
 
60
/*
61
 * Forward references for procedures defined later in this file:
62
 */
63
 
64
#ifdef TCL_MEM_DEBUG
65
static int              CheckmemCmd _ANSI_ARGS_((ClientData clientData,
66
                            Tcl_Interp *interp, int argc, char *argv[]));
67
#endif
68
void TclMacDoNotification(char *mssg);
69
void TclMacNotificationResponse(NMRecPtr nmRec);
70
int Tcl_MacBGNotifyObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv);
71
 
72
 
73
/*
74
 *----------------------------------------------------------------------
75
 *
76
 * Tcl_Main --
77
 *
78
 *      Main program for tclsh and most other Tcl-based applications.
79
 *
80
 * Results:
81
 *      None. This procedure never returns (it exits the process when
82
 *      it's done.
83
 *
84
 * Side effects:
85
 *      This procedure initializes the Tk world and then starts
86
 *      interpreting commands;  almost anything could happen, depending
87
 *      on the script being interpreted.
88
 *
89
 *----------------------------------------------------------------------
90
 */
91
 
92
void
93
Tcl_Main(argc, argv, appInitProc)
94
    int argc;                   /* Number of arguments. */
95
    char **argv;                /* Array of argument strings. */
96
    Tcl_AppInitProc *appInitProc;
97
                                /* Application-specific initialization
98
                                 * procedure to call after most
99
                                 * initialization but before starting to
100
                                 * execute commands. */
101
{
102
    Tcl_Obj *prompt1NamePtr = NULL;
103
    Tcl_Obj *prompt2NamePtr = NULL;
104
    Tcl_Obj *commandPtr = NULL;
105
    char buffer[1000], *args, *fileName;
106
    int code, tty;
107
    int exitCode = 0;
108
 
109
    Tcl_FindExecutable(argv[0]);
110
    interp = Tcl_CreateInterp();
111
#ifdef TCL_MEM_DEBUG
112
    Tcl_InitMemory(interp);
113
    Tcl_CreateCommand(interp, "checkmem", CheckmemCmd, (ClientData) 0,
114
            (Tcl_CmdDeleteProc *) NULL);
115
#endif
116
 
117
    /*
118
     * Make command-line arguments available in the Tcl variables "argc"
119
     * and "argv".  If the first argument doesn't start with a "-" then
120
     * strip it off and use it as the name of a script file to process.
121
     */
122
 
123
    fileName = NULL;
124
    if ((argc > 1) && (argv[1][0] != '-')) {
125
        fileName = argv[1];
126
        argc--;
127
        argv++;
128
    }
129
    args = Tcl_Merge(argc-1, argv+1);
130
    Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
131
    ckfree(args);
132
    TclFormatInt(buffer, argc-1);
133
    Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY);
134
    Tcl_SetVar(interp, "argv0", (fileName != NULL) ? fileName : argv[0],
135
            TCL_GLOBAL_ONLY);
136
 
137
    /*
138
     * Set the "tcl_interactive" variable.
139
     */
140
 
141
    tty = isatty(0);
142
    Tcl_SetVar(interp, "tcl_interactive",
143
            ((fileName == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY);
144
 
145
    /*
146
     * Invoke application-specific initialization.
147
     */
148
 
149
    if ((*appInitProc)(interp) != TCL_OK) {
150
            Tcl_DString errStr;
151
            Tcl_DStringInit(&errStr);
152
            Tcl_DStringAppend(&errStr,
153
                    "application-specific initialization failed: \n", -1);
154
            Tcl_DStringAppend(&errStr, interp->result, -1);
155
            Tcl_DStringAppend(&errStr, "\n", 1);
156
            TclMacDoNotification(Tcl_DStringValue(&errStr));
157
            goto done;
158
    }
159
 
160
    /*
161
     * Install the BGNotify command:
162
     */
163
 
164
    if ( Tcl_CreateObjCommand(interp, "bgnotify", Tcl_MacBGNotifyObjCmd, NULL,
165
             (Tcl_CmdDeleteProc *) NULL) == NULL) {
166
        goto done;
167
    }
168
 
169
    /*
170
     * If a script file was specified then just source that file
171
     * and quit.  In this Mac BG Application version, we will try the
172
     * resource fork first, then the file system second...
173
     */
174
 
175
    if (fileName != NULL) {
176
        Str255 resName;
177
        Handle resource;
178
 
179
        strcpy((char *) resName + 1, fileName);
180
        resName[0] = strlen(fileName);
181
        resource = GetNamedResource('TEXT',resName);
182
        if (resource != NULL) {
183
            code = Tcl_MacEvalResource(interp, fileName, -1, NULL);
184
        } else {
185
            code = Tcl_EvalFile(interp, fileName);
186
        }
187
 
188
        if (code != TCL_OK) {
189
            Tcl_DString errStr;
190
 
191
            Tcl_DStringInit(&errStr);
192
            Tcl_DStringAppend(&errStr, " Error sourcing resource or file: ", -1);
193
            Tcl_DStringAppend(&errStr, fileName, -1);
194
            Tcl_DStringAppend(&errStr, "\n\nError was: ", -1);
195
            Tcl_DStringAppend(&errStr, interp->result, -1);
196
 
197
            TclMacDoNotification(Tcl_DStringValue(&errStr));
198
 
199
        }
200
        goto done;
201
    }
202
 
203
 
204
    /*
205
     * Rather than calling exit, invoke the "exit" command so that
206
     * users can replace "exit" with some other command to do additional
207
     * cleanup on exit.  The Tcl_Eval call should never return.
208
     */
209
 
210
    done:
211
    if (commandPtr != NULL) {
212
        Tcl_DecrRefCount(commandPtr);
213
    }
214
    if (prompt1NamePtr != NULL) {
215
        Tcl_DecrRefCount(prompt1NamePtr);
216
    }
217
    if (prompt2NamePtr != NULL) {
218
        Tcl_DecrRefCount(prompt2NamePtr);
219
    }
220
    sprintf(buffer, "exit %d", exitCode);
221
    Tcl_Eval(interp, buffer);
222
}
223
 
224
/*----------------------------------------------------------------------
225
 *
226
 * TclMacDoNotification --
227
 *
228
 *      This posts an error message using the Notification manager.
229
 *
230
 * Results:
231
 *      Post a Notification Manager dialog.
232
 *
233
 * Side effects:
234
 *      None.
235
 *
236
 *----------------------------------------------------------------------
237
 */
238
void
239
TclMacDoNotification(mssg)
240
    char *mssg;
241
{
242
    NMRec errorNot;
243
    EventRecord *theEvent = NULL;
244
    OSErr err;
245
    char *ptr;
246
 
247
    errorNot.qType = nmType;
248
    errorNot.nmMark = 0;
249
    errorNot.nmIcon = 0;
250
    errorNot.nmSound = (Handle) -1;
251
 
252
    for ( ptr = mssg; *ptr != '\0'; ptr++) {
253
        if (*ptr == '\n') {
254
            *ptr = '\r';
255
        }
256
    }
257
 
258
    c2pstr(mssg);
259
    errorNot.nmStr = (StringPtr) mssg;
260
 
261
    errorNot.nmResp = NewNMProc(TclMacNotificationResponse);
262
    errorNot.nmRefCon = SetCurrentA5();
263
 
264
    NotificationIsDone = 0;
265
 
266
    /*
267
     * Cycle while waiting for the user to click on the
268
     * notification box.  Don't take any events off the event queue,
269
     * since we want Tcl to do this but we want to block till the notification
270
     * has been handled...
271
     */
272
 
273
    err = NMInstall(&errorNot);
274
    if (err == noErr) {
275
        while (!NotificationIsDone) {
276
            WaitNextEvent(0, theEvent, 20, NULL);
277
        }
278
        NMRemove(&errorNot);
279
    }
280
 
281
    p2cstr((unsigned char *) mssg);
282
}
283
 
284
void
285
TclMacNotificationResponse(nmRec)
286
    NMRecPtr nmRec;
287
{
288
    int curA5;
289
 
290
    curA5 = SetCurrentA5();
291
    SetA5(nmRec->nmRefCon);
292
 
293
    NotificationIsDone = 1;
294
 
295
    SetA5(curA5);
296
 
297
}
298
 
299
int
300
Tcl_MacBGNotifyObjCmd(clientData, interp, objc, objv)
301
    ClientData clientData;
302
    Tcl_Interp *interp;
303
    int objc;
304
    Tcl_Obj **objv;
305
{
306
    Tcl_Obj *resultPtr;
307
 
308
    resultPtr = Tcl_GetObjResult(interp);
309
 
310
    if ( objc != 2 ) {
311
        Tcl_WrongNumArgs(interp, 1, objv, "message");
312
        return TCL_ERROR;
313
    }
314
 
315
    TclMacDoNotification(Tcl_GetStringFromObj(objv[1], (int *) NULL));
316
    return TCL_OK;
317
 
318
}
319
 
320
 
321
/*
322
 *----------------------------------------------------------------------
323
 *
324
 * CheckmemCmd --
325
 *
326
 *      This is the command procedure for the "checkmem" command, which
327
 *      causes the application to exit after printing information about
328
 *      memory usage to the file passed to this command as its first
329
 *      argument.
330
 *
331
 * Results:
332
 *      Returns a standard Tcl completion code.
333
 *
334
 * Side effects:
335
 *      None.
336
 *
337
 *----------------------------------------------------------------------
338
 */
339
#ifdef TCL_MEM_DEBUG
340
 
341
        /* ARGSUSED */
342
static int
343
CheckmemCmd(clientData, interp, argc, argv)
344
    ClientData clientData;              /* Not used. */
345
    Tcl_Interp *interp;                 /* Interpreter for evaluation. */
346
    int argc;                           /* Number of arguments. */
347
    char *argv[];                       /* String values of arguments. */
348
{
349
    extern char *tclMemDumpFileName;
350
    if (argc != 2) {
351
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
352
                " fileName\"", (char *) NULL);
353
        return TCL_ERROR;
354
    }
355
    strcpy(dumpFile, argv[1]);
356
    tclMemDumpFileName = dumpFile;
357
    quitFlag = 1;
358
    return TCL_OK;
359
}
360
#endif

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.