URL
https://opencores.org/ocsvn/or1k/or1k/trunk
Subversion Repositories or1k
[/] [or1k/] [trunk/] [insight/] [tcl/] [mac/] [tclMacBOAMain.c] - Rev 578
Go to most recent revision | Compare with Previous | Blame | View Log
/* * 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.1.1.1 2002-01-16 10:25:30 markom 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
Go to most recent revision | Compare with Previous | Blame | View Log