sl@0: /* sl@0: * tclMacOSA.c -- sl@0: * sl@0: * This contains the initialization routines, and the implementation of sl@0: * the OSA and Component commands. These commands allow you to connect sl@0: * with the AppleScript or any other OSA component to compile and execute sl@0: * scripts. sl@0: * sl@0: * Copyright (c) 1996 Lucent Technologies and Jim Ingham sl@0: * Copyright (c) 1997 Sun Microsystems, Inc. sl@0: * sl@0: * See the file "License Terms" for information on usage and redistribution sl@0: * of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: * sl@0: * RCS: @(#) $Id: tclMacOSA.c,v 1.10 2002/10/09 11:54:30 das Exp $ sl@0: */ sl@0: sl@0: #define MAC_TCL sl@0: sl@0: #include sl@0: #include sl@0: #include sl@0: #include sl@0: #include sl@0: #include sl@0: #include sl@0: sl@0: #include sl@0: #include sl@0: sl@0: #include sl@0: #include sl@0: /* sl@0: * The following two Includes are from the More Files package. sl@0: */ sl@0: #include sl@0: #include sl@0: sl@0: #include "tcl.h" sl@0: #include "tclInt.h" sl@0: sl@0: /* sl@0: * I need this only for the call to FspGetFullPath, sl@0: * I'm really not poking my nose where it does not belong! sl@0: */ sl@0: #include "tclMacInt.h" sl@0: sl@0: /* sl@0: * Data structures used by the OSA code. sl@0: */ sl@0: typedef struct tclOSAScript { sl@0: OSAID scriptID; sl@0: OSType languageID; sl@0: long modeFlags; sl@0: } tclOSAScript; sl@0: sl@0: typedef struct tclOSAContext { sl@0: OSAID contextID; sl@0: } tclOSAContext; sl@0: sl@0: typedef struct tclOSAComponent { sl@0: char *theName; sl@0: ComponentInstance theComponent; /* The OSA Component represented */ sl@0: long componentFlags; sl@0: OSType languageID; sl@0: char *languageName; sl@0: Tcl_HashTable contextTable; /* Hash Table linking the context names & ID's */ sl@0: Tcl_HashTable scriptTable; sl@0: Tcl_Interp *theInterp; sl@0: OSAActiveUPP defActiveProc; sl@0: long defRefCon; sl@0: } tclOSAComponent; sl@0: sl@0: /* sl@0: * Prototypes for static procedures. sl@0: */ sl@0: sl@0: static pascal OSErr TclOSAActiveProc _ANSI_ARGS_((long refCon)); sl@0: static int TclOSACompileCmd _ANSI_ARGS_((Tcl_Interp *interp, sl@0: tclOSAComponent *OSAComponent, int argc, sl@0: CONST char **argv)); sl@0: static int tclOSADecompileCmd _ANSI_ARGS_((Tcl_Interp * Interp, sl@0: tclOSAComponent *OSAComponent, int argc, sl@0: CONST char **argv)); sl@0: static int tclOSADeleteCmd _ANSI_ARGS_((Tcl_Interp *interp, sl@0: tclOSAComponent *OSAComponent, int argc, sl@0: CONST char **argv)); sl@0: static int tclOSAExecuteCmd _ANSI_ARGS_((Tcl_Interp *interp, sl@0: tclOSAComponent *OSAComponent, int argc, sl@0: CONST char **argv)); sl@0: static int tclOSAInfoCmd _ANSI_ARGS_((Tcl_Interp *interp, sl@0: tclOSAComponent *OSAComponent, int argc, sl@0: CONST char **argv)); sl@0: static int tclOSALoadCmd _ANSI_ARGS_((Tcl_Interp *interp, sl@0: tclOSAComponent *OSAComponent, int argc, sl@0: CONST char **argv)); sl@0: static int tclOSARunCmd _ANSI_ARGS_((Tcl_Interp *interp, sl@0: tclOSAComponent *OSAComponent, int argc, sl@0: CONST char **argv)); sl@0: static int tclOSAStoreCmd _ANSI_ARGS_((Tcl_Interp *interp, sl@0: tclOSAComponent *OSAComponent, int argc, sl@0: CONST char **argv)); sl@0: static void GetRawDataFromDescriptor _ANSI_ARGS_((AEDesc *theDesc, sl@0: Ptr destPtr, Size destMaxSize, Size *actSize)); sl@0: static OSErr GetCStringFromDescriptor _ANSI_ARGS_(( sl@0: AEDesc *sourceDesc, char *resultStr, sl@0: Size resultMaxSize,Size *resultSize)); sl@0: static int Tcl_OSAComponentCmd _ANSI_ARGS_((ClientData clientData, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static void getSortedHashKeys _ANSI_ARGS_((Tcl_HashTable *theTable, sl@0: CONST char *pattern, Tcl_DString *theResult)); sl@0: static int ASCIICompareProc _ANSI_ARGS_((const void *first, sl@0: const void *second)); sl@0: static int Tcl_OSACmd _ANSI_ARGS_((ClientData clientData, sl@0: Tcl_Interp *interp, int argc, CONST char **argv)); sl@0: static void tclOSAClose _ANSI_ARGS_((ClientData clientData)); sl@0: /*static void tclOSACloseAll _ANSI_ARGS_((ClientData clientData));*/ sl@0: static tclOSAComponent *tclOSAMakeNewComponent _ANSI_ARGS_((Tcl_Interp *interp, sl@0: char *cmdName, char *languageName, sl@0: OSType scriptSubtype, long componentFlags)); sl@0: static int prepareScriptData _ANSI_ARGS_((int argc, CONST char **argv, sl@0: Tcl_DString *scrptData ,AEDesc *scrptDesc)); sl@0: static void tclOSAResultFromID _ANSI_ARGS_((Tcl_Interp *interp, sl@0: ComponentInstance theComponent, OSAID resultID)); sl@0: static void tclOSAASError _ANSI_ARGS_((Tcl_Interp * interp, sl@0: ComponentInstance theComponent, char *scriptSource)); sl@0: static int tclOSAGetContextID _ANSI_ARGS_((tclOSAComponent *theComponent, sl@0: CONST char *contextName, OSAID *theContext)); sl@0: static void tclOSAAddContext _ANSI_ARGS_((tclOSAComponent *theComponent, sl@0: char *contextName, const OSAID theContext)); sl@0: static int tclOSAMakeContext _ANSI_ARGS_((tclOSAComponent *theComponent, sl@0: CONST char *contextName, OSAID *theContext)); sl@0: static int tclOSADeleteContext _ANSI_ARGS_((tclOSAComponent *theComponent, sl@0: CONST char *contextName)); sl@0: static int tclOSALoad _ANSI_ARGS_((Tcl_Interp *interp, sl@0: tclOSAComponent *theComponent, CONST char *resourceName, sl@0: int resourceNumber, CONST char *fileName,OSAID *resultID)); sl@0: static int tclOSAStore _ANSI_ARGS_((Tcl_Interp *interp, sl@0: tclOSAComponent *theComponent, CONST char *resourceName, sl@0: int resourceNumber, CONST char *scriptName, CONST char *fileName)); sl@0: static int tclOSAAddScript _ANSI_ARGS_((tclOSAComponent *theComponent, sl@0: char *scriptName, long modeFlags, OSAID scriptID)); sl@0: static int tclOSAGetScriptID _ANSI_ARGS_((tclOSAComponent *theComponent, sl@0: CONST char *scriptName, OSAID *scriptID)); sl@0: static tclOSAScript * tclOSAGetScript _ANSI_ARGS_((tclOSAComponent *theComponent, sl@0: CONST char *scriptName)); sl@0: static int tclOSADeleteScript _ANSI_ARGS_((tclOSAComponent *theComponent, sl@0: CONST char *scriptName,char *errMsg)); sl@0: sl@0: /* sl@0: * "export" is a MetroWerks specific pragma. It flags the linker that sl@0: * any symbols that are defined when this pragma is on will be exported sl@0: * to shared libraries that link with this library. sl@0: */ sl@0: sl@0: sl@0: #pragma export on sl@0: int Tclapplescript_Init( Tcl_Interp *interp ); sl@0: #pragma export reset sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tclapplescript_Init -- sl@0: * sl@0: * Initializes the the OSA command which opens connections to sl@0: * OSA components, creates the AppleScript command, which opens an sl@0: * instance of the AppleScript component,and constructs the table of sl@0: * available languages. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side Effects: sl@0: * Opens one connection to the AppleScript component, if sl@0: * available. Also builds up a table of available OSA languages, sl@0: * and creates the OSA command. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: Tclapplescript_Init( sl@0: Tcl_Interp *interp) /* Tcl interpreter. */ sl@0: { sl@0: char *errMsg = NULL; sl@0: OSErr myErr = noErr; sl@0: Boolean gotAppleScript = false; sl@0: Boolean GotOneOSALanguage = false; sl@0: ComponentDescription compDescr = { sl@0: kOSAComponentType, sl@0: (OSType) 0, sl@0: (OSType) 0, sl@0: (long) 0, sl@0: (long) 0 sl@0: }, *foundComp; sl@0: Component curComponent = (Component) 0; sl@0: ComponentInstance curOpenComponent; sl@0: Tcl_HashTable *ComponentTable; sl@0: Tcl_HashTable *LanguagesTable; sl@0: Tcl_HashEntry *hashEntry; sl@0: int newPtr; sl@0: AEDesc componentName = { typeNull, NULL }; sl@0: char nameStr[32]; sl@0: Size nameLen; sl@0: long appleScriptFlags; sl@0: sl@0: /* sl@0: * Perform the required stubs magic... sl@0: */ sl@0: sl@0: if (!Tcl_InitStubs(interp, "8.2", 0)) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Here We Will Get The Available Osa Languages, Since They Can Only Be sl@0: * Registered At Startup... If You Dynamically Load Components, This sl@0: * Will Fail, But This Is Not A Common Thing To Do. sl@0: */ sl@0: sl@0: LanguagesTable = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); sl@0: sl@0: if (LanguagesTable == NULL) { sl@0: panic("Memory Error Allocating Languages Hash Table"); sl@0: } sl@0: sl@0: Tcl_SetAssocData(interp, "OSAScript_LangTable", NULL, LanguagesTable); sl@0: Tcl_InitHashTable(LanguagesTable, TCL_STRING_KEYS); sl@0: sl@0: sl@0: while ((curComponent = FindNextComponent(curComponent, &compDescr)) != 0) { sl@0: int nbytes = sizeof(ComponentDescription); sl@0: foundComp = (ComponentDescription *) sl@0: ckalloc(sizeof(ComponentDescription)); sl@0: myErr = GetComponentInfo(curComponent, foundComp, NULL, NULL, NULL); sl@0: if (foundComp->componentSubType == sl@0: kOSAGenericScriptingComponentSubtype) { sl@0: /* Skip the generic component */ sl@0: ckfree((char *) foundComp); sl@0: } else { sl@0: GotOneOSALanguage = true; sl@0: sl@0: /* sl@0: * This is gross: looks like I have to open the component just sl@0: * to get its name!!! GetComponentInfo is supposed to return sl@0: * the name, but AppleScript always returns an empty string. sl@0: */ sl@0: sl@0: curOpenComponent = OpenComponent(curComponent); sl@0: if (curOpenComponent == NULL) { sl@0: Tcl_AppendResult(interp,"Error opening component", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: myErr = OSAScriptingComponentName(curOpenComponent,&componentName); sl@0: if (myErr == noErr) { sl@0: myErr = GetCStringFromDescriptor(&componentName, sl@0: nameStr, 31, &nameLen); sl@0: AEDisposeDesc(&componentName); sl@0: } sl@0: CloseComponent(curOpenComponent); sl@0: sl@0: if (myErr == noErr) { sl@0: hashEntry = Tcl_CreateHashEntry(LanguagesTable, sl@0: nameStr, &newPtr); sl@0: Tcl_SetHashValue(hashEntry, (ClientData) foundComp); sl@0: } else { sl@0: Tcl_AppendResult(interp,"Error getting componentName.", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Make sure AppleScript is loaded, otherwise we will sl@0: * not bother to make the AppleScript command. sl@0: */ sl@0: if (foundComp->componentSubType == kAppleScriptSubtype) { sl@0: appleScriptFlags = foundComp->componentFlags; sl@0: gotAppleScript = true; sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Create the OSA command. sl@0: */ sl@0: sl@0: if (!GotOneOSALanguage) { sl@0: Tcl_AppendResult(interp,"Could not find any OSA languages", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Create the Component Assoc Data & put it in the interpreter. sl@0: */ sl@0: sl@0: ComponentTable = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); sl@0: sl@0: if (ComponentTable == NULL) { sl@0: panic("Memory Error Allocating Hash Table"); sl@0: } sl@0: sl@0: Tcl_SetAssocData(interp, "OSAScript_CompTable", NULL, ComponentTable); sl@0: sl@0: Tcl_InitHashTable(ComponentTable, TCL_STRING_KEYS); sl@0: sl@0: /* sl@0: * The OSA command is not currently supported. sl@0: Tcl_CreateCommand(interp, "OSA", Tcl_OSACmd, (ClientData) NULL, sl@0: (Tcl_CmdDeleteProc *) NULL); sl@0: */ sl@0: sl@0: /* sl@0: * Open up one AppleScript component, with a default context sl@0: * and tie it to the AppleScript command. sl@0: * If the user just wants single-threaded AppleScript execution sl@0: * this should be enough. sl@0: * sl@0: */ sl@0: sl@0: if (gotAppleScript) { sl@0: if (tclOSAMakeNewComponent(interp, "AppleScript", sl@0: "AppleScript English", kAppleScriptSubtype, sl@0: appleScriptFlags) == NULL ) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: return Tcl_PkgProvide(interp, "OSAConnect", "1.0"); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_OSACmd -- sl@0: * sl@0: * This is the command that provides the interface to the OSA sl@0: * component manager. The subcommands are: close: close a component, sl@0: * info: get info on components open, and open: get a new connection sl@0: * with the Scripting Component sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Depends on the subcommand, see the user documentation sl@0: * for more details. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: Tcl_OSACmd( sl@0: ClientData clientData, sl@0: Tcl_Interp *interp, sl@0: int argc, sl@0: CONST char **argv) sl@0: { sl@0: static unsigned short componentCmdIndex = 0; sl@0: char autoName[32]; sl@0: char c; sl@0: int length; sl@0: Tcl_HashTable *ComponentTable = NULL; sl@0: sl@0: sl@0: if (argc == 1) { sl@0: Tcl_AppendResult(interp, "Wrong # of arguments, should be \"", sl@0: argv[0], " option\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: c = *argv[1]; sl@0: length = strlen(argv[1]); sl@0: sl@0: /* sl@0: * Query out the Component Table, since most of these commands use it... sl@0: */ sl@0: sl@0: ComponentTable = (Tcl_HashTable *) Tcl_GetAssocData(interp, sl@0: "OSAScript_CompTable", (Tcl_InterpDeleteProc **) NULL); sl@0: sl@0: if (ComponentTable == NULL) { sl@0: Tcl_AppendResult(interp, "Error, could not get the Component Table", sl@0: " from the Associated data.", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (c == 'c' && strncmp(argv[1],"close",length) == 0) { sl@0: Tcl_HashEntry *hashEntry; sl@0: if (argc != 3) { sl@0: Tcl_AppendResult(interp, "Wrong # of arguments, should be \"", sl@0: argv[0], " ",argv[1], " componentName\"", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if ((hashEntry = Tcl_FindHashEntry(ComponentTable,argv[2])) == NULL) { sl@0: Tcl_AppendResult(interp, "Component \"", argv[2], "\" not found", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } else { sl@0: Tcl_DeleteCommand(interp,argv[2]); sl@0: return TCL_OK; sl@0: } sl@0: } else if (c == 'o' && strncmp(argv[1],"open",length) == 0) { sl@0: /* sl@0: * Default language is AppleScript. sl@0: */ sl@0: OSType scriptSubtype = kAppleScriptSubtype; sl@0: char *languageName = "AppleScript English"; sl@0: char *errMsg = NULL; sl@0: ComponentDescription *theCD; sl@0: sl@0: argv += 2; sl@0: argc -= 2; sl@0: sl@0: while (argc > 0 ) { sl@0: if (*argv[0] == '-') { sl@0: c = *(argv[0] + 1); sl@0: if (c == 'l' && strcmp(argv[0] + 1, "language") == 0) { sl@0: if (argc == 1) { sl@0: Tcl_AppendResult(interp, sl@0: "Error - no language provided for the -language switch", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } else { sl@0: Tcl_HashEntry *hashEntry; sl@0: Tcl_HashSearch search; sl@0: Boolean gotIt = false; sl@0: Tcl_HashTable *LanguagesTable; sl@0: sl@0: /* sl@0: * Look up the language in the languages table sl@0: * Do a simple strstr match, so AppleScript sl@0: * will match "AppleScript English"... sl@0: */ sl@0: sl@0: LanguagesTable = Tcl_GetAssocData(interp, sl@0: "OSAScript_LangTable", sl@0: (Tcl_InterpDeleteProc **) NULL); sl@0: sl@0: for (hashEntry = sl@0: Tcl_FirstHashEntry(LanguagesTable, &search); sl@0: hashEntry != NULL; sl@0: hashEntry = Tcl_NextHashEntry(&search)) { sl@0: languageName = Tcl_GetHashKey(LanguagesTable, sl@0: hashEntry); sl@0: if (strstr(languageName,argv[1]) != NULL) { sl@0: theCD = (ComponentDescription *) sl@0: Tcl_GetHashValue(hashEntry); sl@0: gotIt = true; sl@0: break; sl@0: } sl@0: } sl@0: if (!gotIt) { sl@0: Tcl_AppendResult(interp, sl@0: "Error, could not find the language \"", sl@0: argv[1], sl@0: "\" in the list of known languages.", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: } sl@0: argc -= 2; sl@0: argv += 2; sl@0: } else { sl@0: Tcl_AppendResult(interp, "Expected a flag, but got ", sl@0: argv[0], (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: sprintf(autoName, "OSAComponent%-d", componentCmdIndex++); sl@0: if (tclOSAMakeNewComponent(interp, autoName, languageName, sl@0: theCD->componentSubType, theCD->componentFlags) == NULL ) { sl@0: return TCL_ERROR; sl@0: } else { sl@0: Tcl_SetResult(interp,autoName,TCL_VOLATILE); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: } else if (c == 'i' && strncmp(argv[1],"info",length) == 0) { sl@0: if (argc == 2) { sl@0: Tcl_AppendResult(interp, "Wrong # of arguments, should be \"", sl@0: argv[0], " ", argv[1], " what\"", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: c = *argv[2]; sl@0: length = strlen(argv[2]); sl@0: sl@0: if (c == 'c' && strncmp(argv[2], "components", length) == 0) { sl@0: Tcl_DString theResult; sl@0: sl@0: Tcl_DStringInit(&theResult); sl@0: sl@0: if (argc == 3) { sl@0: getSortedHashKeys(ComponentTable,(char *) NULL, &theResult); sl@0: } else if (argc == 4) { sl@0: getSortedHashKeys(ComponentTable, argv[3], &theResult); sl@0: } else { sl@0: Tcl_AppendResult(interp, "Error: wrong # of arguments", sl@0: ", should be \"", argv[0], " ", argv[1], " ", sl@0: argv[2], " ?pattern?\".", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_DStringResult(interp, &theResult); sl@0: return TCL_OK; sl@0: } else if (c == 'l' && strncmp(argv[2],"languages",length) == 0) { sl@0: Tcl_DString theResult; sl@0: Tcl_HashTable *LanguagesTable; sl@0: sl@0: Tcl_DStringInit(&theResult); sl@0: LanguagesTable = Tcl_GetAssocData(interp, sl@0: "OSAScript_LangTable", (Tcl_InterpDeleteProc **) NULL); sl@0: sl@0: if (argc == 3) { sl@0: getSortedHashKeys(LanguagesTable, (char *) NULL, &theResult); sl@0: } else if (argc == 4) { sl@0: getSortedHashKeys(LanguagesTable, argv[3], &theResult); sl@0: } else { sl@0: Tcl_AppendResult(interp, "Error: wrong # of arguments", sl@0: ", should be \"", argv[0], " ", argv[1], " ", sl@0: argv[2], " ?pattern?\".", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_DStringResult(interp,&theResult); sl@0: return TCL_OK; sl@0: } else { sl@0: Tcl_AppendResult(interp, "Unknown option: ", argv[2], sl@0: " for OSA info, should be one of", sl@0: " \"components\" or \"languages\"", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } else { sl@0: Tcl_AppendResult(interp, "Unknown option: ", argv[1], sl@0: ", should be one of \"open\", \"close\" or \"info\".", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_OSAComponentCmd -- sl@0: * sl@0: * This is the command that provides the interface with an OSA sl@0: * component. The sub commands are: sl@0: * - compile ? -context context? scriptData sl@0: * compiles the script data, returns the ScriptID sl@0: * - decompile ? -context context? scriptData sl@0: * decompiles the script data, source code sl@0: * - execute ?-context context? scriptData sl@0: * compiles and runs script data sl@0: * - info what: get component info sl@0: * - load ?-flags values? fileName sl@0: * loads & compiles script data from fileName sl@0: * - run scriptId ?options? sl@0: * executes the compiled script sl@0: * sl@0: * Results: sl@0: * A standard Tcl result sl@0: * sl@0: * Side Effects: sl@0: * Depends on the subcommand, see the user documentation sl@0: * for more details. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: Tcl_OSAComponentCmd( sl@0: ClientData clientData, sl@0: Tcl_Interp *interp, sl@0: int argc, sl@0: CONST char **argv) sl@0: { sl@0: int length; sl@0: char c; sl@0: sl@0: tclOSAComponent *OSAComponent = (tclOSAComponent *) clientData; sl@0: sl@0: if (argc == 1) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", sl@0: argv[0], " option ?arg ...?\"", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: c = *argv[1]; sl@0: length = strlen(argv[1]); sl@0: if (c == 'c' && strncmp(argv[1], "compile", length) == 0) { sl@0: return TclOSACompileCmd(interp, OSAComponent, argc, argv); sl@0: } else if (c == 'l' && strncmp(argv[1], "load", length) == 0) { sl@0: return tclOSALoadCmd(interp, OSAComponent, argc, argv); sl@0: } else if (c == 'e' && strncmp(argv[1], "execute", length) == 0) { sl@0: return tclOSAExecuteCmd(interp, OSAComponent, argc, argv); sl@0: } else if (c == 'i' && strncmp(argv[1], "info", length) == 0) { sl@0: return tclOSAInfoCmd(interp, OSAComponent, argc, argv); sl@0: } else if (c == 'd' && strncmp(argv[1], "decompile", length) == 0) { sl@0: return tclOSADecompileCmd(interp, OSAComponent, argc, argv); sl@0: } else if (c == 'd' && strncmp(argv[1], "delete", length) == 0) { sl@0: return tclOSADeleteCmd(interp, OSAComponent, argc, argv); sl@0: } else if (c == 'r' && strncmp(argv[1], "run", length) == 0) { sl@0: return tclOSARunCmd(interp, OSAComponent, argc, argv); sl@0: } else if (c == 's' && strncmp(argv[1], "store", length) == 0) { sl@0: return tclOSAStoreCmd(interp, OSAComponent, argc, argv); sl@0: } else { sl@0: Tcl_AppendResult(interp,"bad option \"", argv[1], sl@0: "\": should be compile, decompile, delete, ", sl@0: "execute, info, load, run or store", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclOSACompileCmd -- sl@0: * sl@0: * This is the compile subcommand for the component command. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result sl@0: * sl@0: * Side Effects: sl@0: * Compiles the script data either into a script or a script sl@0: * context. Adds the script to the component's script or context sl@0: * table. Sets interp's result to the name of the new script or sl@0: * context. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TclOSACompileCmd( sl@0: Tcl_Interp *interp, sl@0: tclOSAComponent *OSAComponent, sl@0: int argc, sl@0: CONST char **argv) sl@0: { sl@0: int tclError = TCL_OK; sl@0: int augment = 1; sl@0: int makeContext = 0; sl@0: char c; sl@0: char autoName[16]; sl@0: char buffer[32]; sl@0: char *resultName; sl@0: Boolean makeNewContext = false; sl@0: Tcl_DString scrptData; sl@0: AEDesc scrptDesc = { typeNull, NULL }; sl@0: long modeFlags = kOSAModeCanInteract; sl@0: OSAID resultID = kOSANullScript; sl@0: OSAID contextID = kOSANullScript; sl@0: OSAID parentID = kOSANullScript; sl@0: OSAError osaErr = noErr; sl@0: sl@0: if (!(OSAComponent->componentFlags && kOSASupportsCompiling)) { sl@0: Tcl_AppendResult(interp, sl@0: "OSA component does not support compiling", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * This signals that we should make up a name, which is the sl@0: * default behavior: sl@0: */ sl@0: sl@0: autoName[0] = '\0'; sl@0: resultName = NULL; sl@0: sl@0: if (argc == 2) { sl@0: numArgs: sl@0: Tcl_AppendResult(interp, sl@0: "wrong # args: should be \"", argv[0], " ", argv[1], sl@0: " ?options? code\"",(char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: argv += 2; sl@0: argc -= 2; sl@0: sl@0: /* sl@0: * Do the argument parsing. sl@0: */ sl@0: sl@0: while (argc > 0) { sl@0: sl@0: if (*argv[0] == '-') { sl@0: c = *(argv[0] + 1); sl@0: sl@0: /* sl@0: * "--" is the only switch that has no value, stops processing sl@0: */ sl@0: sl@0: if (c == '-' && *(argv[0] + 2) == '\0') { sl@0: argv += 1; sl@0: argc--; sl@0: break; sl@0: } sl@0: sl@0: /* sl@0: * So we can check here a switch with no value. sl@0: */ sl@0: sl@0: if (argc == 1) { sl@0: Tcl_AppendResult(interp, sl@0: "no value given for switch: ", sl@0: argv[0], (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (c == 'c' && strcmp(argv[0] + 1, "context") == 0) { sl@0: if (Tcl_GetBoolean(interp, argv[1], &makeContext) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: } else if (c == 'a' && strcmp(argv[0] + 1, "augment") == 0) { sl@0: /* sl@0: * Augment the current context which implies making a context. sl@0: */ sl@0: sl@0: if (Tcl_GetBoolean(interp, argv[1], &augment) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: makeContext = 1; sl@0: } else if (c == 'n' && strcmp(argv[0] + 1, "name") == 0) { sl@0: strncpy(autoName, argv[1], 15); sl@0: autoName[15] = '\0'; sl@0: resultName = autoName; sl@0: } else if (c == 'p' && strcmp(argv[0] + 1,"parent") == 0) { sl@0: /* sl@0: * Since this implies we are compiling into a context, sl@0: * set makeContext here sl@0: */ sl@0: if (tclOSAGetContextID(OSAComponent, sl@0: argv[1], &parentID) != TCL_OK) { sl@0: Tcl_AppendResult(interp, "context not found \"", sl@0: argv[1], "\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: makeContext = 1; sl@0: } else { sl@0: Tcl_AppendResult(interp, "bad option \"", argv[0], sl@0: "\": should be -augment, -context, -name or -parent", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: argv += 2; sl@0: argc -= 2; sl@0: sl@0: } else { sl@0: break; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Make sure we have some data left... sl@0: */ sl@0: if (argc == 0) { sl@0: goto numArgs; sl@0: } sl@0: sl@0: /* sl@0: * Now if we are making a context, see if it is a new one... sl@0: * There are three options here: sl@0: * 1) There was no name provided, so we autoName it sl@0: * 2) There was a name, then check and see if it already exists sl@0: * a) If yes, then makeNewContext is false sl@0: * b) Otherwise we are making a new context sl@0: */ sl@0: sl@0: if (makeContext) { sl@0: modeFlags |= kOSAModeCompileIntoContext; sl@0: if (resultName == NULL) { sl@0: /* sl@0: * Auto name the new context. sl@0: */ sl@0: resultName = autoName; sl@0: resultID = kOSANullScript; sl@0: makeNewContext = true; sl@0: } else if (tclOSAGetContextID(OSAComponent, sl@0: resultName, &resultID) == TCL_OK) { sl@0: } else { sl@0: makeNewContext = true; sl@0: } sl@0: sl@0: /* sl@0: * Deal with the augment now... sl@0: */ sl@0: if (augment && !makeNewContext) { sl@0: modeFlags |= kOSAModeAugmentContext; sl@0: } sl@0: } else if (resultName == NULL) { sl@0: resultName = autoName; /* Auto name the script */ sl@0: } sl@0: sl@0: /* sl@0: * Ok, now we have the options, so we can compile the script data. sl@0: */ sl@0: sl@0: if (prepareScriptData(argc, argv, &scrptData, &scrptDesc) == TCL_ERROR) { sl@0: Tcl_DStringResult(interp, &scrptData); sl@0: AEDisposeDesc(&scrptDesc); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * If we want to use a parent context, we have to make the context sl@0: * by hand. Note, parentID is only specified when you make a new context. sl@0: */ sl@0: sl@0: if (parentID != kOSANullScript && makeNewContext) { sl@0: AEDesc contextDesc = { typeNull, NULL }; sl@0: sl@0: osaErr = OSAMakeContext(OSAComponent->theComponent, sl@0: &contextDesc, parentID, &resultID); sl@0: modeFlags |= kOSAModeAugmentContext; sl@0: } sl@0: sl@0: osaErr = OSACompile(OSAComponent->theComponent, &scrptDesc, sl@0: modeFlags, &resultID); sl@0: if (osaErr == noErr) { sl@0: sl@0: if (makeContext) { sl@0: /* sl@0: * For the compiled context to be active, you need to run sl@0: * the code that is in the context. sl@0: */ sl@0: OSAID activateID; sl@0: sl@0: osaErr = OSAExecute(OSAComponent->theComponent, resultID, sl@0: resultID, kOSAModeCanInteract, &activateID); sl@0: OSADispose(OSAComponent->theComponent, activateID); sl@0: sl@0: if (osaErr == noErr) { sl@0: if (makeNewContext) { sl@0: /* sl@0: * If we have compiled into a context, sl@0: * this is added to the context table sl@0: */ sl@0: sl@0: tclOSAAddContext(OSAComponent, resultName, resultID); sl@0: } sl@0: sl@0: Tcl_SetResult(interp, resultName, TCL_VOLATILE); sl@0: tclError = TCL_OK; sl@0: } sl@0: } else { sl@0: /* sl@0: * For a script, we return the script name. sl@0: */ sl@0: tclOSAAddScript(OSAComponent, resultName, modeFlags, resultID); sl@0: Tcl_SetResult(interp, resultName, TCL_VOLATILE); sl@0: tclError = TCL_OK; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * This catches the error either from the original compile, sl@0: * or from the execute in case makeContext == true sl@0: */ sl@0: sl@0: if (osaErr == errOSAScriptError) { sl@0: OSADispose(OSAComponent->theComponent, resultID); sl@0: tclOSAASError(interp, OSAComponent->theComponent, sl@0: Tcl_DStringValue(&scrptData)); sl@0: tclError = TCL_ERROR; sl@0: } else if (osaErr != noErr) { sl@0: sprintf(buffer, "Error #%-6ld compiling script", osaErr); sl@0: Tcl_AppendResult(interp, buffer, (char *) NULL); sl@0: tclError = TCL_ERROR; sl@0: } sl@0: sl@0: Tcl_DStringFree(&scrptData); sl@0: AEDisposeDesc(&scrptDesc); sl@0: sl@0: return tclError; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * tclOSADecompileCmd -- sl@0: * sl@0: * This implements the Decompile subcommand of the component command sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side Effects: sl@0: * Decompiles the script, and sets interp's result to the sl@0: * decompiled script data. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: tclOSADecompileCmd( sl@0: Tcl_Interp * interp, sl@0: tclOSAComponent *OSAComponent, sl@0: int argc, sl@0: CONST char **argv) sl@0: { sl@0: AEDesc resultingSourceData = { typeChar, NULL }; sl@0: OSAID scriptID; sl@0: Boolean isContext; sl@0: long result; sl@0: OSErr sysErr = noErr; sl@0: sl@0: if (argc == 2) { sl@0: Tcl_AppendResult(interp, "Wrong # of arguments, should be \"", sl@0: argv[0], " ",argv[1], " scriptName \"", (char *) NULL ); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (!(OSAComponent->componentFlags && kOSASupportsGetSource)) { sl@0: Tcl_AppendResult(interp, sl@0: "Error, this component does not support get source", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (tclOSAGetScriptID(OSAComponent, argv[2], &scriptID) == TCL_OK) { sl@0: isContext = false; sl@0: } else if (tclOSAGetContextID(OSAComponent, argv[2], &scriptID) sl@0: == TCL_OK ) { sl@0: isContext = true; sl@0: } else { sl@0: Tcl_AppendResult(interp, "Could not find script \"", sl@0: argv[2], "\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: OSAGetScriptInfo(OSAComponent->theComponent, scriptID, sl@0: kOSACanGetSource, &result); sl@0: sl@0: sysErr = OSAGetSource(OSAComponent->theComponent, sl@0: scriptID, typeChar, &resultingSourceData); sl@0: sl@0: if (sysErr == noErr) { sl@0: Tcl_DString theResult; sl@0: Tcl_DStringInit(&theResult); sl@0: sl@0: Tcl_DStringAppend(&theResult, *resultingSourceData.dataHandle, sl@0: GetHandleSize(resultingSourceData.dataHandle)); sl@0: Tcl_DStringResult(interp, &theResult); sl@0: AEDisposeDesc(&resultingSourceData); sl@0: return TCL_OK; sl@0: } else { sl@0: Tcl_AppendResult(interp, "Error getting source data", (char *) NULL); sl@0: AEDisposeDesc(&resultingSourceData); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * tclOSADeleteCmd -- sl@0: * sl@0: * This implements the Delete subcommand of the Component command. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side Effects: sl@0: * Deletes a script from the script list of the given component. sl@0: * Removes all references to the script, and frees the memory sl@0: * associated with it. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: tclOSADeleteCmd( sl@0: Tcl_Interp *interp, sl@0: tclOSAComponent *OSAComponent, sl@0: int argc, sl@0: CONST char **argv) sl@0: { sl@0: char c,*errMsg = NULL; sl@0: int length; sl@0: sl@0: if (argc < 4) { sl@0: Tcl_AppendResult(interp, "Wrong # of arguments, should be \"", sl@0: argv[0], " ", argv[1], " what scriptName", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: c = *argv[2]; sl@0: length = strlen(argv[2]); sl@0: if (c == 'c' && strncmp(argv[2], "context", length) == 0) { sl@0: if (strcmp(argv[3], "global") == 0) { sl@0: Tcl_AppendResult(interp, "You cannot delete the global context", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } else if (tclOSADeleteContext(OSAComponent, argv[3]) != TCL_OK) { sl@0: Tcl_AppendResult(interp, "Error deleting script \"", argv[2], sl@0: "\": ", errMsg, (char *) NULL); sl@0: ckfree(errMsg); sl@0: return TCL_ERROR; sl@0: } sl@0: } else if (c == 's' && strncmp(argv[2], "script", length) == 0) { sl@0: if (tclOSADeleteScript(OSAComponent, argv[3], errMsg) != TCL_OK) { sl@0: Tcl_AppendResult(interp, "Error deleting script \"", argv[3], sl@0: "\": ", errMsg, (char *) NULL); sl@0: ckfree(errMsg); sl@0: return TCL_ERROR; sl@0: } sl@0: } else { sl@0: Tcl_AppendResult(interp,"Unknown value ", argv[2], sl@0: " should be one of ", sl@0: "\"context\" or \"script\".", sl@0: (char *) NULL ); sl@0: return TCL_ERROR; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * tclOSAExecuteCmd -- sl@0: * sl@0: * This implements the execute subcommand of the component command. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Executes the given script data, and sets interp's result to sl@0: * the OSA component's return value. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: tclOSAExecuteCmd( sl@0: Tcl_Interp *interp, sl@0: tclOSAComponent *OSAComponent, sl@0: int argc, sl@0: CONST char **argv) sl@0: { sl@0: int tclError = TCL_OK, resID = 128; sl@0: char c,buffer[32], sl@0: *contextName = NULL,*scriptName = NULL, *resName = NULL; sl@0: Boolean makeNewContext = false,makeContext = false; sl@0: AEDesc scrptDesc = { typeNull, NULL }; sl@0: long modeFlags = kOSAModeCanInteract; sl@0: OSAID resultID = kOSANullScript, sl@0: contextID = kOSANullScript, sl@0: parentID = kOSANullScript; sl@0: Tcl_DString scrptData; sl@0: OSAError osaErr = noErr; sl@0: OSErr sysErr = noErr; sl@0: sl@0: if (argc == 2) { sl@0: Tcl_AppendResult(interp, sl@0: "Error, no script data for \"", argv[0], sl@0: " run\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: argv += 2; sl@0: argc -= 2; sl@0: sl@0: /* sl@0: * Set the context to the global context by default. sl@0: * Then parse the argument list for switches sl@0: */ sl@0: tclOSAGetContextID(OSAComponent, "global", &contextID); sl@0: sl@0: while (argc > 0) { sl@0: sl@0: if (*argv[0] == '-') { sl@0: c = *(argv[0] + 1); sl@0: sl@0: /* sl@0: * "--" is the only switch that has no value. sl@0: */ sl@0: sl@0: if (c == '-' && *(argv[0] + 2) == '\0') { sl@0: argv += 1; sl@0: argc--; sl@0: break; sl@0: } sl@0: sl@0: /* sl@0: * So we can check here for a switch with no value. sl@0: */ sl@0: sl@0: if (argc == 1) { sl@0: Tcl_AppendResult(interp, sl@0: "Error, no value given for switch ", sl@0: argv[0], (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (c == 'c' && strcmp(argv[0] + 1, "context") == 0) { sl@0: if (tclOSAGetContextID(OSAComponent, sl@0: argv[1], &contextID) == TCL_OK) { sl@0: } else { sl@0: Tcl_AppendResult(interp, "Script context \"", sl@0: argv[1], "\" not found", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } else { sl@0: Tcl_AppendResult(interp, "Error, invalid switch ", argv[0], sl@0: " should be \"-context\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: argv += 2; sl@0: argc -= 2; sl@0: } else { sl@0: break; sl@0: } sl@0: } sl@0: sl@0: if (argc == 0) { sl@0: Tcl_AppendResult(interp, "Error, no script data", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (prepareScriptData(argc, argv, &scrptData, &scrptDesc) == TCL_ERROR) { sl@0: Tcl_DStringResult(interp, &scrptData); sl@0: AEDisposeDesc(&scrptDesc); sl@0: return TCL_ERROR; sl@0: } sl@0: /* sl@0: * Now try to compile and run, but check to make sure the sl@0: * component supports the one shot deal sl@0: */ sl@0: if (OSAComponent->componentFlags && kOSASupportsConvenience) { sl@0: osaErr = OSACompileExecute(OSAComponent->theComponent, sl@0: &scrptDesc, contextID, modeFlags, &resultID); sl@0: } else { sl@0: /* sl@0: * If not, we have to do this ourselves sl@0: */ sl@0: if (OSAComponent->componentFlags && kOSASupportsCompiling) { sl@0: OSAID compiledID = kOSANullScript; sl@0: osaErr = OSACompile(OSAComponent->theComponent, &scrptDesc, sl@0: modeFlags, &compiledID); sl@0: if (osaErr == noErr) { sl@0: osaErr = OSAExecute(OSAComponent->theComponent, compiledID, sl@0: contextID, modeFlags, &resultID); sl@0: } sl@0: OSADispose(OSAComponent->theComponent, compiledID); sl@0: } else { sl@0: /* sl@0: * The scripting component had better be able to load text data... sl@0: */ sl@0: OSAID loadedID = kOSANullScript; sl@0: sl@0: scrptDesc.descriptorType = OSAComponent->languageID; sl@0: osaErr = OSALoad(OSAComponent->theComponent, &scrptDesc, sl@0: modeFlags, &loadedID); sl@0: if (osaErr == noErr) { sl@0: OSAExecute(OSAComponent->theComponent, loadedID, sl@0: contextID, modeFlags, &resultID); sl@0: } sl@0: OSADispose(OSAComponent->theComponent, loadedID); sl@0: } sl@0: } sl@0: if (osaErr == errOSAScriptError) { sl@0: tclOSAASError(interp, OSAComponent->theComponent, sl@0: Tcl_DStringValue(&scrptData)); sl@0: tclError = TCL_ERROR; sl@0: } else if (osaErr != noErr) { sl@0: sprintf(buffer, "Error #%-6ld compiling script", osaErr); sl@0: Tcl_AppendResult(interp, buffer, (char *) NULL); sl@0: tclError = TCL_ERROR; sl@0: } else { sl@0: tclOSAResultFromID(interp, OSAComponent->theComponent, resultID); sl@0: osaErr = OSADispose(OSAComponent->theComponent, resultID); sl@0: tclError = TCL_OK; sl@0: } sl@0: sl@0: Tcl_DStringFree(&scrptData); sl@0: AEDisposeDesc(&scrptDesc); sl@0: sl@0: return tclError; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * tclOSAInfoCmd -- sl@0: * sl@0: * This implements the Info subcommand of the component command sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Info on scripts and contexts. See the user documentation for details. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: static int sl@0: tclOSAInfoCmd( sl@0: Tcl_Interp *interp, sl@0: tclOSAComponent *OSAComponent, sl@0: int argc, sl@0: CONST char **argv) sl@0: { sl@0: char c; sl@0: int length; sl@0: Tcl_DString theResult; sl@0: sl@0: if (argc == 2) { sl@0: Tcl_AppendResult(interp, "Wrong # of arguments, should be \"", sl@0: argv[0], " ", argv[1], " what \"", (char *) NULL ); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: c = *argv[2]; sl@0: length = strlen(argv[2]); sl@0: if (c == 's' && strncmp(argv[2], "scripts", length) == 0) { sl@0: Tcl_DStringInit(&theResult); sl@0: if (argc == 3) { sl@0: getSortedHashKeys(&OSAComponent->scriptTable, (char *) NULL, sl@0: &theResult); sl@0: } else if (argc == 4) { sl@0: getSortedHashKeys(&OSAComponent->scriptTable, argv[3], &theResult); sl@0: } else { sl@0: Tcl_AppendResult(interp, "Error: wrong # of arguments,", sl@0: " should be \"", argv[0], " ", argv[1], " ", sl@0: argv[2], " ?pattern?", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_DStringResult(interp, &theResult); sl@0: return TCL_OK; sl@0: } else if (c == 'c' && strncmp(argv[2], "contexts", length) == 0) { sl@0: Tcl_DStringInit(&theResult); sl@0: if (argc == 3) { sl@0: getSortedHashKeys(&OSAComponent->contextTable, (char *) NULL, sl@0: &theResult); sl@0: } else if (argc == 4) { sl@0: getSortedHashKeys(&OSAComponent->contextTable, sl@0: argv[3], &theResult); sl@0: } else { sl@0: Tcl_AppendResult(interp, "Error: wrong # of arguments for ,", sl@0: " should be \"", argv[0], " ", argv[1], " ", sl@0: argv[2], " ?pattern?", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: Tcl_DStringResult(interp, &theResult); sl@0: return TCL_OK; sl@0: } else if (c == 'l' && strncmp(argv[2], "language", length) == 0) { sl@0: Tcl_SetResult(interp, OSAComponent->languageName, TCL_STATIC); sl@0: return TCL_OK; sl@0: } else { sl@0: Tcl_AppendResult(interp, "Unknown argument \"", argv[2], sl@0: "\" for \"", argv[0], " info \", should be one of ", sl@0: "\"scripts\" \"language\", or \"contexts\"", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * tclOSALoadCmd -- sl@0: * sl@0: * This is the load subcommand for the Component Command sl@0: * sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Loads script data from the given file, creates a new context sl@0: * for it, and sets interp's result to the name of the new context. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: tclOSALoadCmd( sl@0: Tcl_Interp *interp, sl@0: tclOSAComponent *OSAComponent, sl@0: int argc, sl@0: CONST char **argv) sl@0: { sl@0: int tclError = TCL_OK, resID = 128; sl@0: char c, autoName[24], sl@0: *contextName = NULL, *scriptName = NULL; sl@0: CONST char *resName = NULL; sl@0: Boolean makeNewContext = false, makeContext = false; sl@0: AEDesc scrptDesc = { typeNull, NULL }; sl@0: long modeFlags = kOSAModeCanInteract; sl@0: OSAID resultID = kOSANullScript, sl@0: contextID = kOSANullScript, sl@0: parentID = kOSANullScript; sl@0: OSAError osaErr = noErr; sl@0: OSErr sysErr = noErr; sl@0: long scptInfo; sl@0: sl@0: autoName[0] = '\0'; sl@0: scriptName = autoName; sl@0: contextName = autoName; sl@0: sl@0: if (argc == 2) { sl@0: Tcl_AppendResult(interp, sl@0: "Error, no data for \"", argv[0], " ", argv[1], sl@0: "\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: argv += 2; sl@0: argc -= 2; sl@0: sl@0: /* sl@0: * Do the argument parsing. sl@0: */ sl@0: sl@0: while (argc > 0) { sl@0: sl@0: if (*argv[0] == '-') { sl@0: c = *(argv[0] + 1); sl@0: sl@0: /* sl@0: * "--" is the only switch that has no value. sl@0: */ sl@0: sl@0: if (c == '-' && *(argv[0] + 2) == '\0') { sl@0: argv += 1; sl@0: argc--; sl@0: break; sl@0: } sl@0: sl@0: /* sl@0: * So we can check here a switch with no value. sl@0: */ sl@0: sl@0: if (argc == 1) { sl@0: Tcl_AppendResult(interp, "Error, no value given for switch ", sl@0: argv[0], (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (c == 'r' && strcmp(argv[0] + 1, "rsrcname") == 0) { sl@0: resName = argv[1]; sl@0: } else if (c == 'r' && strcmp(argv[0] + 1, "rsrcid") == 0) { sl@0: if (Tcl_GetInt(interp, argv[1], &resID) != TCL_OK) { sl@0: Tcl_AppendResult(interp, sl@0: "Error getting resource ID", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } else { sl@0: Tcl_AppendResult(interp, "Error, invalid switch ", argv[0], sl@0: " should be \"--\", \"-rsrcname\" or \"-rsrcid\"", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: argv += 2; sl@0: argc -= 2; sl@0: } else { sl@0: break; sl@0: } sl@0: } sl@0: /* sl@0: * Ok, now we have the options, so we can load the resource, sl@0: */ sl@0: if (argc == 0) { sl@0: Tcl_AppendResult(interp, "Error, no filename given", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (tclOSALoad(interp, OSAComponent, resName, resID, sl@0: argv[0], &resultID) != TCL_OK) { sl@0: Tcl_AppendResult(interp, "Error in load command", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Now find out whether we have a script, or a script context. sl@0: */ sl@0: sl@0: OSAGetScriptInfo(OSAComponent->theComponent, resultID, sl@0: kOSAScriptIsTypeScriptContext, &scptInfo); sl@0: sl@0: if (scptInfo) { sl@0: autoName[0] = '\0'; sl@0: tclOSAAddContext(OSAComponent, autoName, resultID); sl@0: sl@0: Tcl_SetResult(interp, autoName, TCL_VOLATILE); sl@0: } else { sl@0: /* sl@0: * For a script, we return the script name sl@0: */ sl@0: autoName[0] = '\0'; sl@0: tclOSAAddScript(OSAComponent, autoName, kOSAModeCanInteract, resultID); sl@0: Tcl_SetResult(interp, autoName, TCL_VOLATILE); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * tclOSARunCmd -- sl@0: * sl@0: * This implements the run subcommand of the component command sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Runs the given compiled script, and returns the OSA sl@0: * component's result. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: tclOSARunCmd( sl@0: Tcl_Interp *interp, sl@0: tclOSAComponent *OSAComponent, sl@0: int argc, sl@0: CONST char **argv) sl@0: { sl@0: int tclError = TCL_OK, sl@0: resID = 128; sl@0: char c, *contextName = NULL, sl@0: *scriptName = NULL, sl@0: *resName = NULL; sl@0: AEDesc scrptDesc = { typeNull, NULL }; sl@0: long modeFlags = kOSAModeCanInteract; sl@0: OSAID resultID = kOSANullScript, sl@0: contextID = kOSANullScript, sl@0: parentID = kOSANullScript; sl@0: OSAError osaErr = noErr; sl@0: OSErr sysErr = noErr; sl@0: CONST char *componentName = argv[0]; sl@0: OSAID scriptID; sl@0: sl@0: if (argc == 2) { sl@0: Tcl_AppendResult(interp, "Wrong # of arguments, should be \"", sl@0: argv[0], " ", argv[1], " scriptName", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Set the context to the global context for this component, sl@0: * as a default sl@0: */ sl@0: if (tclOSAGetContextID(OSAComponent, "global", &contextID) != TCL_OK) { sl@0: Tcl_AppendResult(interp, sl@0: "Could not find the global context for component ", sl@0: OSAComponent->theName, (char *) NULL ); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Now parse the argument list for switches sl@0: */ sl@0: argv += 2; sl@0: argc -= 2; sl@0: sl@0: while (argc > 0) { sl@0: if (*argv[0] == '-') { sl@0: c = *(argv[0] + 1); sl@0: /* sl@0: * "--" is the only switch that has no value sl@0: */ sl@0: if (c == '-' && *(argv[0] + 2) == '\0') { sl@0: argv += 1; sl@0: argc--; sl@0: break; sl@0: } sl@0: sl@0: /* sl@0: * So we can check here for a switch with no value. sl@0: */ sl@0: if (argc == 1) { sl@0: Tcl_AppendResult(interp, "Error, no value given for switch ", sl@0: argv[0], (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (c == 'c' && strcmp(argv[0] + 1, "context") == 0) { sl@0: if (argc == 1) { sl@0: Tcl_AppendResult(interp, sl@0: "Error - no context provided for the -context switch", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } else if (tclOSAGetContextID(OSAComponent, sl@0: argv[1], &contextID) == TCL_OK) { sl@0: } else { sl@0: Tcl_AppendResult(interp, "Script context \"", argv[1], sl@0: "\" not found", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } else { sl@0: Tcl_AppendResult(interp, "Error, invalid switch ", argv[0], sl@0: " for ", componentName, sl@0: " should be \"-context\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: argv += 2; sl@0: argc -= 2; sl@0: } else { sl@0: break; sl@0: } sl@0: } sl@0: sl@0: if (tclOSAGetScriptID(OSAComponent, argv[0], &scriptID) != TCL_OK) { sl@0: if (tclOSAGetContextID(OSAComponent, argv[0], &scriptID) != TCL_OK) { sl@0: Tcl_AppendResult(interp, "Could not find script \"", sl@0: argv[2], "\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: sysErr = OSAExecute(OSAComponent->theComponent, sl@0: scriptID, contextID, modeFlags, &resultID); sl@0: sl@0: if (sysErr == errOSAScriptError) { sl@0: tclOSAASError(interp, OSAComponent->theComponent, (char *) NULL); sl@0: tclError = TCL_ERROR; sl@0: } else if (sysErr != noErr) { sl@0: char buffer[32]; sl@0: sprintf(buffer, "Error #%6.6d encountered in run", sysErr); sl@0: Tcl_SetResult(interp, buffer, TCL_VOLATILE); sl@0: tclError = TCL_ERROR; sl@0: } else { sl@0: tclOSAResultFromID(interp, OSAComponent->theComponent, resultID ); sl@0: } sl@0: OSADispose(OSAComponent->theComponent, resultID); sl@0: sl@0: return tclError; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * tclOSAStoreCmd -- sl@0: * sl@0: * This implements the store subcommand of the component command sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Runs the given compiled script, and returns the OSA sl@0: * component's result. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: tclOSAStoreCmd( sl@0: Tcl_Interp *interp, sl@0: tclOSAComponent *OSAComponent, sl@0: int argc, sl@0: CONST char **argv) sl@0: { sl@0: int tclError = TCL_OK, resID = 128; sl@0: char c, *contextName = NULL, *scriptName = NULL; sl@0: CONST char *resName = NULL; sl@0: Boolean makeNewContext = false, makeContext = false; sl@0: AEDesc scrptDesc = { typeNull, NULL }; sl@0: long modeFlags = kOSAModeCanInteract; sl@0: OSAID resultID = kOSANullScript, sl@0: contextID = kOSANullScript, sl@0: parentID = kOSANullScript; sl@0: OSAError osaErr = noErr; sl@0: OSErr sysErr = noErr; sl@0: sl@0: if (argc == 2) { sl@0: Tcl_AppendResult(interp, "Error, no data for \"", argv[0], sl@0: " ",argv[1], "\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: argv += 2; sl@0: argc -= 2; sl@0: sl@0: /* sl@0: * Do the argument parsing sl@0: */ sl@0: sl@0: while (argc > 0) { sl@0: if (*argv[0] == '-') { sl@0: c = *(argv[0] + 1); sl@0: sl@0: /* sl@0: * "--" is the only switch that has no value sl@0: */ sl@0: if (c == '-' && *(argv[0] + 2) == '\0') { sl@0: argv += 1; sl@0: argc--; sl@0: break; sl@0: } sl@0: sl@0: /* sl@0: * So we can check here a switch with no value. sl@0: */ sl@0: if (argc == 1) { sl@0: Tcl_AppendResult(interp, sl@0: "Error, no value given for switch ", sl@0: argv[0], (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (c == 'r' && strcmp(argv[0] + 1, "rsrcname") == 0) { sl@0: resName = argv[1]; sl@0: } else if (c == 'r' && strcmp(argv[0] + 1, "rsrcid") == 0) { sl@0: if (Tcl_GetInt(interp, argv[1], &resID) != TCL_OK) { sl@0: Tcl_AppendResult(interp, sl@0: "Error getting resource ID", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } else { sl@0: Tcl_AppendResult(interp, "Error, invalid switch ", argv[0], sl@0: " should be \"--\", \"-rsrcname\" or \"-rsrcid\"", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: argv += 2; sl@0: argc -= 2; sl@0: } else { sl@0: break; sl@0: } sl@0: } sl@0: /* sl@0: * Ok, now we have the options, so we can load the resource, sl@0: */ sl@0: if (argc != 2) { sl@0: Tcl_AppendResult(interp, "Error, wrong # of arguments, should be ", sl@0: argv[0], " ", argv[1], "?option flag? scriptName fileName", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (tclOSAStore(interp, OSAComponent, resName, resID, sl@0: argv[0], argv[1]) != TCL_OK) { sl@0: Tcl_AppendResult(interp, "Error in load command", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } else { sl@0: Tcl_ResetResult(interp); sl@0: tclError = TCL_OK; sl@0: } sl@0: sl@0: return tclError; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * tclOSAMakeNewComponent -- sl@0: * sl@0: * Makes a command cmdName to represent a new connection to the sl@0: * OSA component with componentSubType scriptSubtype. sl@0: * sl@0: * Results: sl@0: * Returns the tclOSAComponent structure for the connection. sl@0: * sl@0: * Side Effects: sl@0: * Adds a new element to the component table. If there is an sl@0: * error, then the result of the Tcl interpreter interp is set sl@0: * to an appropriate error message. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: tclOSAComponent * sl@0: tclOSAMakeNewComponent( sl@0: Tcl_Interp *interp, sl@0: char *cmdName, sl@0: char *languageName, sl@0: OSType scriptSubtype, sl@0: long componentFlags) sl@0: { sl@0: char buffer[32]; sl@0: AEDesc resultingName = {typeNull, NULL}; sl@0: AEDesc nullDesc = {typeNull, NULL }; sl@0: OSAID globalContext; sl@0: char global[] = "global"; sl@0: int nbytes; sl@0: ComponentDescription requestedComponent = { sl@0: kOSAComponentType, sl@0: (OSType) 0, sl@0: (OSType) 0, sl@0: (long int) 0, sl@0: (long int) 0 sl@0: }; sl@0: Tcl_HashTable *ComponentTable; sl@0: Component foundComponent = NULL; sl@0: OSAActiveUPP myActiveProcUPP; sl@0: sl@0: tclOSAComponent *newComponent; sl@0: Tcl_HashEntry *hashEntry; sl@0: int newPtr; sl@0: sl@0: requestedComponent.componentSubType = scriptSubtype; sl@0: nbytes = sizeof(tclOSAComponent); sl@0: newComponent = (tclOSAComponent *) ckalloc(sizeof(tclOSAComponent)); sl@0: if (newComponent == NULL) { sl@0: goto CleanUp; sl@0: } sl@0: sl@0: foundComponent = FindNextComponent(0, &requestedComponent); sl@0: if (foundComponent == 0) { sl@0: Tcl_AppendResult(interp, sl@0: "Could not find component of requested type", (char *) NULL); sl@0: goto CleanUp; sl@0: } sl@0: sl@0: newComponent->theComponent = OpenComponent(foundComponent); sl@0: sl@0: if (newComponent->theComponent == NULL) { sl@0: Tcl_AppendResult(interp, sl@0: "Could not open component of the requested type", sl@0: (char *) NULL); sl@0: goto CleanUp; sl@0: } sl@0: sl@0: newComponent->languageName = (char *) ckalloc(strlen(languageName) + 1); sl@0: strcpy(newComponent->languageName,languageName); sl@0: sl@0: newComponent->componentFlags = componentFlags; sl@0: sl@0: newComponent->theInterp = interp; sl@0: sl@0: Tcl_InitHashTable(&newComponent->contextTable, TCL_STRING_KEYS); sl@0: Tcl_InitHashTable(&newComponent->scriptTable, TCL_STRING_KEYS); sl@0: sl@0: if (tclOSAMakeContext(newComponent, global, &globalContext) != TCL_OK) { sl@0: sprintf(buffer, "%-6.6ld", globalContext); sl@0: Tcl_AppendResult(interp, "Error ", buffer, " making ", global, sl@0: " context.", (char *) NULL); sl@0: goto CleanUp; sl@0: } sl@0: sl@0: newComponent->languageID = scriptSubtype; sl@0: sl@0: newComponent->theName = (char *) ckalloc(strlen(cmdName) + 1 ); sl@0: strcpy(newComponent->theName, cmdName); sl@0: sl@0: Tcl_CreateCommand(interp, newComponent->theName, Tcl_OSAComponentCmd, sl@0: (ClientData) newComponent, tclOSAClose); sl@0: sl@0: /* sl@0: * Register the new component with the component table sl@0: */ sl@0: sl@0: ComponentTable = (Tcl_HashTable *) Tcl_GetAssocData(interp, sl@0: "OSAScript_CompTable", (Tcl_InterpDeleteProc **) NULL); sl@0: sl@0: if (ComponentTable == NULL) { sl@0: Tcl_AppendResult(interp, "Error, could not get the Component Table", sl@0: " from the Associated data.", (char *) NULL); sl@0: return (tclOSAComponent *) NULL; sl@0: } sl@0: sl@0: hashEntry = Tcl_CreateHashEntry(ComponentTable, sl@0: newComponent->theName, &newPtr); sl@0: Tcl_SetHashValue(hashEntry, (ClientData) newComponent); sl@0: sl@0: /* sl@0: * Set the active proc to call Tcl_DoOneEvent() while idle sl@0: */ sl@0: if (OSAGetActiveProc(newComponent->theComponent, sl@0: &newComponent->defActiveProc, &newComponent->defRefCon) != noErr ) { sl@0: /* TODO -- clean up here... */ sl@0: } sl@0: sl@0: myActiveProcUPP = NewOSAActiveUPP(TclOSAActiveProc); sl@0: OSASetActiveProc(newComponent->theComponent, sl@0: myActiveProcUPP, (long) newComponent); sl@0: return newComponent; sl@0: sl@0: CleanUp: sl@0: sl@0: ckfree((char *) newComponent); sl@0: return (tclOSAComponent *) NULL; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * tclOSAClose -- sl@0: * sl@0: * This procedure closes the connection to an OSA component, and sl@0: * deletes all the script and context data associated with it. sl@0: * It is the command deletion callback for the component's command. sl@0: * sl@0: * Results: sl@0: * None sl@0: * sl@0: * Side effects: sl@0: * Closes the connection, and releases all the script data. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: tclOSAClose( sl@0: ClientData clientData) sl@0: { sl@0: tclOSAComponent *theComponent = (tclOSAComponent *) clientData; sl@0: Tcl_HashEntry *hashEntry; sl@0: Tcl_HashSearch search; sl@0: tclOSAScript *theScript; sl@0: Tcl_HashTable *ComponentTable; sl@0: sl@0: /* sl@0: * Delete the context and script tables sl@0: * the memory for the language name, and sl@0: * the hash entry. sl@0: */ sl@0: sl@0: for (hashEntry = Tcl_FirstHashEntry(&theComponent->scriptTable, &search); sl@0: hashEntry != NULL; sl@0: hashEntry = Tcl_NextHashEntry(&search)) { sl@0: sl@0: theScript = (tclOSAScript *) Tcl_GetHashValue(hashEntry); sl@0: OSADispose(theComponent->theComponent, theScript->scriptID); sl@0: ckfree((char *) theScript); sl@0: Tcl_DeleteHashEntry(hashEntry); sl@0: } sl@0: sl@0: for (hashEntry = Tcl_FirstHashEntry(&theComponent->contextTable, &search); sl@0: hashEntry != NULL; sl@0: hashEntry = Tcl_NextHashEntry(&search)) { sl@0: sl@0: Tcl_DeleteHashEntry(hashEntry); sl@0: } sl@0: sl@0: ckfree(theComponent->languageName); sl@0: ckfree(theComponent->theName); sl@0: sl@0: /* sl@0: * Finally close the component sl@0: */ sl@0: sl@0: CloseComponent(theComponent->theComponent); sl@0: sl@0: ComponentTable = (Tcl_HashTable *) sl@0: Tcl_GetAssocData(theComponent->theInterp, sl@0: "OSAScript_CompTable", (Tcl_InterpDeleteProc **) NULL); sl@0: sl@0: if (ComponentTable == NULL) { sl@0: panic("Error, could not get the Component Table from the Associated data."); sl@0: } sl@0: sl@0: hashEntry = Tcl_FindHashEntry(ComponentTable, theComponent->theName); sl@0: if (hashEntry != NULL) { sl@0: Tcl_DeleteHashEntry(hashEntry); sl@0: } sl@0: sl@0: ckfree((char *) theComponent); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * tclOSAGetContextID -- sl@0: * sl@0: * This returns the context ID, given the component name. sl@0: * sl@0: * Results: sl@0: * A context ID sl@0: * sl@0: * Side effects: sl@0: * None sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: tclOSAGetContextID( sl@0: tclOSAComponent *theComponent, sl@0: CONST char *contextName, sl@0: OSAID *theContext) sl@0: { sl@0: Tcl_HashEntry *hashEntry; sl@0: tclOSAContext *contextStruct; sl@0: sl@0: if ((hashEntry = Tcl_FindHashEntry(&theComponent->contextTable, sl@0: contextName)) == NULL ) { sl@0: return TCL_ERROR; sl@0: } else { sl@0: contextStruct = (tclOSAContext *) Tcl_GetHashValue(hashEntry); sl@0: *theContext = contextStruct->contextID; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * tclOSAAddContext -- sl@0: * sl@0: * This adds the context ID, with the name contextName. If the sl@0: * name is passed in as a NULL string, space is malloc'ed for the sl@0: * string and a new name is made up, if the string is empty, you sl@0: * must have allocated enough space ( 24 characters is fine) for sl@0: * the name, which is made up and passed out. sl@0: * sl@0: * Results: sl@0: * Nothing sl@0: * sl@0: * Side effects: sl@0: * Adds the script context to the component's context table. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: tclOSAAddContext( sl@0: tclOSAComponent *theComponent, sl@0: char *contextName, sl@0: const OSAID theContext) sl@0: { sl@0: static unsigned short contextIndex = 0; sl@0: tclOSAContext *contextStruct; sl@0: Tcl_HashEntry *hashEntry; sl@0: int newPtr; sl@0: sl@0: if (contextName == NULL) { sl@0: contextName = ckalloc(16 + TCL_INTEGER_SPACE); sl@0: sprintf(contextName, "OSAContext%d", contextIndex++); sl@0: } else if (*contextName == '\0') { sl@0: sprintf(contextName, "OSAContext%d", contextIndex++); sl@0: } sl@0: sl@0: hashEntry = Tcl_CreateHashEntry(&theComponent->contextTable, sl@0: contextName, &newPtr); sl@0: sl@0: contextStruct = (tclOSAContext *) ckalloc(sizeof(tclOSAContext)); sl@0: contextStruct->contextID = theContext; sl@0: Tcl_SetHashValue(hashEntry,(ClientData) contextStruct); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * tclOSADeleteContext -- sl@0: * sl@0: * This deletes the context struct, with the name contextName. sl@0: * sl@0: * Results: sl@0: * A normal Tcl result sl@0: * sl@0: * Side effects: sl@0: * Removes the script context to the component's context table, sl@0: * and deletes the data associated with it. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: tclOSADeleteContext( sl@0: tclOSAComponent *theComponent, sl@0: CONST char *contextName) sl@0: { sl@0: Tcl_HashEntry *hashEntry; sl@0: tclOSAContext *contextStruct; sl@0: sl@0: hashEntry = Tcl_FindHashEntry(&theComponent->contextTable, contextName); sl@0: if (hashEntry == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: /* sl@0: * Dispose of the script context data sl@0: */ sl@0: contextStruct = (tclOSAContext *) Tcl_GetHashValue(hashEntry); sl@0: OSADispose(theComponent->theComponent,contextStruct->contextID); sl@0: /* sl@0: * Then the hash entry sl@0: */ sl@0: ckfree((char *) contextStruct); sl@0: Tcl_DeleteHashEntry(hashEntry); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * tclOSAMakeContext -- sl@0: * sl@0: * This makes the context with name contextName, and returns the ID. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result sl@0: * sl@0: * Side effects: sl@0: * Makes a new context, adds it to the context table, and returns sl@0: * the new contextID in the variable theContext. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: tclOSAMakeContext( sl@0: tclOSAComponent *theComponent, sl@0: CONST char *contextName, sl@0: OSAID *theContext) sl@0: { sl@0: AEDesc contextNameDesc = {typeNull, NULL}; sl@0: OSAError osaErr = noErr; sl@0: sl@0: AECreateDesc(typeChar, contextName, strlen(contextName), &contextNameDesc); sl@0: osaErr = OSAMakeContext(theComponent->theComponent, &contextNameDesc, sl@0: kOSANullScript, theContext); sl@0: sl@0: AEDisposeDesc(&contextNameDesc); sl@0: sl@0: if (osaErr == noErr) { sl@0: char name[24]; sl@0: strncpy(name, contextName, 23); sl@0: name[23] = '\0'; sl@0: tclOSAAddContext(theComponent, name, *theContext); sl@0: } else { sl@0: *theContext = (OSAID) osaErr; sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * tclOSAStore -- sl@0: * sl@0: * This stores a script resource from the file named in fileName. sl@0: * sl@0: * Most of this routine is caged from the Tcl Source, from the sl@0: * Tcl_MacSourceCmd routine. This is good, since it ensures this sl@0: * follows the same convention for looking up files as Tcl. sl@0: * sl@0: * Returns sl@0: * A standard Tcl result. sl@0: * sl@0: * Side Effects: sl@0: * The given script data is stored in the file fileName. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: tclOSAStore( sl@0: Tcl_Interp *interp, sl@0: tclOSAComponent *theComponent, sl@0: CONST char *resourceName, sl@0: int resourceNumber, sl@0: CONST char *scriptName, sl@0: CONST char *fileName) sl@0: { sl@0: Handle resHandle; sl@0: Str255 rezName; sl@0: int result = TCL_OK; sl@0: short saveRef, fileRef = -1; sl@0: char idStr[16 + TCL_INTEGER_SPACE]; sl@0: FSSpec fileSpec; sl@0: Tcl_DString ds, buffer; sl@0: CONST char *nativeName; sl@0: OSErr myErr = noErr; sl@0: OSAID scriptID; sl@0: Size scriptSize; sl@0: AEDesc scriptData; sl@0: sl@0: /* sl@0: * First extract the script data sl@0: */ sl@0: sl@0: if (tclOSAGetScriptID(theComponent, scriptName, &scriptID) != TCL_OK ) { sl@0: if (tclOSAGetContextID(theComponent, scriptName, &scriptID) sl@0: != TCL_OK) { sl@0: Tcl_AppendResult(interp, "Error getting script ", sl@0: scriptName, (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: myErr = OSAStore(theComponent->theComponent, scriptID, sl@0: typeOSAGenericStorage, kOSAModeNull, &scriptData); sl@0: if (myErr != noErr) { sl@0: sprintf(idStr, "%d", myErr); sl@0: Tcl_AppendResult(interp, "Error #", idStr, sl@0: " storing script ", scriptName, (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * Now try to open the output file sl@0: */ sl@0: sl@0: saveRef = CurResFile(); sl@0: sl@0: if (fileName != NULL) { sl@0: OSErr err; sl@0: sl@0: if (Tcl_TranslateFileName(interp, fileName, &buffer) == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: nativeName = Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&buffer), sl@0: Tcl_DStringLength(&buffer), &ds); sl@0: err = FSpLocationFromPath(strlen(nativeName), nativeName, &fileSpec); sl@0: sl@0: Tcl_DStringFree(&ds); sl@0: Tcl_DStringFree(&buffer); sl@0: if ((err != noErr) && (err != fnfErr)) { sl@0: Tcl_AppendResult(interp, sl@0: "Error getting a location for the file: \"", sl@0: fileName, "\".", NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: FSpCreateResFileCompatTcl(&fileSpec, sl@0: 'WiSH', 'osas', smSystemScript); sl@0: myErr = ResError(); sl@0: sl@0: if ((myErr != noErr) && (myErr != dupFNErr)) { sl@0: sprintf(idStr, "%d", myErr); sl@0: Tcl_AppendResult(interp, "Error #", idStr, sl@0: " creating new resource file ", fileName, (char *) NULL); sl@0: result = TCL_ERROR; sl@0: goto rezEvalCleanUp; sl@0: } sl@0: sl@0: fileRef = FSpOpenResFileCompatTcl(&fileSpec, fsRdWrPerm); sl@0: if (fileRef == -1) { sl@0: Tcl_AppendResult(interp, "Error reading the file: \"", sl@0: fileName, "\".", NULL); sl@0: result = TCL_ERROR; sl@0: goto rezEvalCleanUp; sl@0: } sl@0: UseResFile(fileRef); sl@0: } else { sl@0: /* sl@0: * The default behavior will search through all open resource files. sl@0: * This may not be the behavior you desire. If you want the behavior sl@0: * of this call to *only* search the application resource fork, you sl@0: * must call UseResFile at this point to set it to the application sl@0: * file. This means you must have already obtained the application's sl@0: * fileRef when the application started up. sl@0: */ sl@0: } sl@0: sl@0: /* sl@0: * Load the resource by name sl@0: */ sl@0: if (resourceName != NULL) { sl@0: strcpy((char *) rezName + 1, resourceName); sl@0: rezName[0] = strlen(resourceName); sl@0: resHandle = Get1NamedResource('scpt', rezName); sl@0: myErr = ResError(); sl@0: if (resHandle == NULL) { sl@0: /* sl@0: * These signify either the resource or the resource sl@0: * type were not found sl@0: */ sl@0: if (myErr == resNotFound || myErr == noErr) { sl@0: short uniqueID; sl@0: while ((uniqueID = Unique1ID('scpt') ) < 128) {} sl@0: AddResource(scriptData.dataHandle, 'scpt', uniqueID, rezName); sl@0: WriteResource(resHandle); sl@0: result = TCL_OK; sl@0: goto rezEvalCleanUp; sl@0: } else { sl@0: /* sl@0: * This means there was some other error, for now sl@0: * I just bag out. sl@0: */ sl@0: sprintf(idStr, "%d", myErr); sl@0: Tcl_AppendResult(interp, "Error #", idStr, sl@0: " opening scpt resource named ", resourceName, sl@0: " in file ", fileName, (char *) NULL); sl@0: result = TCL_ERROR; sl@0: goto rezEvalCleanUp; sl@0: } sl@0: } sl@0: /* sl@0: * Or ID sl@0: */ sl@0: } else { sl@0: resHandle = Get1Resource('scpt', resourceNumber); sl@0: rezName[0] = 0; sl@0: rezName[1] = '\0'; sl@0: myErr = ResError(); sl@0: if (resHandle == NULL) { sl@0: /* sl@0: * These signify either the resource or the resource sl@0: * type were not found sl@0: */ sl@0: if (myErr == resNotFound || myErr == noErr) { sl@0: AddResource(scriptData.dataHandle, 'scpt', sl@0: resourceNumber, rezName); sl@0: WriteResource(resHandle); sl@0: result = TCL_OK; sl@0: goto rezEvalCleanUp; sl@0: } else { sl@0: /* sl@0: * This means there was some other error, for now sl@0: * I just bag out */ sl@0: sprintf(idStr, "%d", myErr); sl@0: Tcl_AppendResult(interp, "Error #", idStr, sl@0: " opening scpt resource named ", resourceName, sl@0: " in file ", fileName,(char *) NULL); sl@0: result = TCL_ERROR; sl@0: goto rezEvalCleanUp; sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * We get to here if the resource exists sl@0: * we just copy into it... sl@0: */ sl@0: sl@0: scriptSize = GetHandleSize(scriptData.dataHandle); sl@0: SetHandleSize(resHandle, scriptSize); sl@0: HLock(scriptData.dataHandle); sl@0: HLock(resHandle); sl@0: BlockMove(*scriptData.dataHandle, *resHandle,scriptSize); sl@0: HUnlock(scriptData.dataHandle); sl@0: HUnlock(resHandle); sl@0: ChangedResource(resHandle); sl@0: WriteResource(resHandle); sl@0: result = TCL_OK; sl@0: goto rezEvalCleanUp; sl@0: sl@0: rezEvalError: sl@0: sprintf(idStr, "ID=%d", resourceNumber); sl@0: Tcl_AppendResult(interp, "The resource \"", sl@0: (resourceName != NULL ? resourceName : idStr), sl@0: "\" could not be loaded from ", sl@0: (fileName != NULL ? fileName : "application"), sl@0: ".", NULL); sl@0: sl@0: rezEvalCleanUp: sl@0: if (fileRef != -1) { sl@0: CloseResFile(fileRef); sl@0: } sl@0: sl@0: UseResFile(saveRef); sl@0: sl@0: return result; sl@0: } sl@0: sl@0: /*---------------------------------------------------------------------- sl@0: * sl@0: * tclOSALoad -- sl@0: * sl@0: * This loads a script resource from the file named in fileName. sl@0: * Most of this routine is caged from the Tcl Source, from the sl@0: * Tcl_MacSourceCmd routine. This is good, since it ensures this sl@0: * follows the same convention for looking up files as Tcl. sl@0: * sl@0: * Returns sl@0: * A standard Tcl result. sl@0: * sl@0: * Side Effects: sl@0: * A new script element is created from the data in the file. sl@0: * The script ID is passed out in the variable resultID. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: tclOSALoad( sl@0: Tcl_Interp *interp, sl@0: tclOSAComponent *theComponent, sl@0: CONST char *resourceName, sl@0: int resourceNumber, sl@0: CONST char *fileName, sl@0: OSAID *resultID) sl@0: { sl@0: Handle sourceData; sl@0: Str255 rezName; sl@0: int result = TCL_OK; sl@0: short saveRef, fileRef = -1; sl@0: char idStr[16 + TCL_INTEGER_SPACE]; sl@0: FSSpec fileSpec; sl@0: Tcl_DString ds, buffer; sl@0: CONST char *nativeName; sl@0: sl@0: saveRef = CurResFile(); sl@0: sl@0: if (fileName != NULL) { sl@0: OSErr err; sl@0: sl@0: if (Tcl_TranslateFileName(interp, fileName, &buffer) == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: nativeName = Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&buffer), sl@0: Tcl_DStringLength(&buffer), &ds); sl@0: err = FSpLocationFromPath(strlen(nativeName), nativeName, &fileSpec); sl@0: Tcl_DStringFree(&ds); sl@0: Tcl_DStringFree(&buffer); sl@0: if (err != noErr) { sl@0: Tcl_AppendResult(interp, "Error finding the file: \"", sl@0: fileName, "\".", NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: fileRef = FSpOpenResFileCompatTcl(&fileSpec, fsRdPerm); sl@0: if (fileRef == -1) { sl@0: Tcl_AppendResult(interp, "Error reading the file: \"", sl@0: fileName, "\".", NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: UseResFile(fileRef); sl@0: } else { sl@0: /* sl@0: * The default behavior will search through all open resource files. sl@0: * This may not be the behavior you desire. If you want the behavior sl@0: * of this call to *only* search the application resource fork, you sl@0: * must call UseResFile at this point to set it to the application sl@0: * file. This means you must have already obtained the application's sl@0: * fileRef when the application started up. sl@0: */ sl@0: } sl@0: sl@0: /* sl@0: * Load the resource by name or ID sl@0: */ sl@0: if (resourceName != NULL) { sl@0: strcpy((char *) rezName + 1, resourceName); sl@0: rezName[0] = strlen(resourceName); sl@0: sourceData = GetNamedResource('scpt', rezName); sl@0: } else { sl@0: sourceData = GetResource('scpt', (short) resourceNumber); sl@0: } sl@0: sl@0: if (sourceData == NULL) { sl@0: result = TCL_ERROR; sl@0: } else { sl@0: AEDesc scriptDesc; sl@0: OSAError osaErr; sl@0: sl@0: scriptDesc.descriptorType = typeOSAGenericStorage; sl@0: scriptDesc.dataHandle = sourceData; sl@0: sl@0: osaErr = OSALoad(theComponent->theComponent, &scriptDesc, sl@0: kOSAModeNull, resultID); sl@0: sl@0: ReleaseResource(sourceData); sl@0: sl@0: if (osaErr != noErr) { sl@0: result = TCL_ERROR; sl@0: goto rezEvalError; sl@0: } sl@0: sl@0: goto rezEvalCleanUp; sl@0: } sl@0: sl@0: rezEvalError: sl@0: sprintf(idStr, "ID=%d", resourceNumber); sl@0: Tcl_AppendResult(interp, "The resource \"", sl@0: (resourceName != NULL ? resourceName : idStr), sl@0: "\" could not be loaded from ", sl@0: (fileName != NULL ? fileName : "application"), sl@0: ".", NULL); sl@0: sl@0: rezEvalCleanUp: sl@0: if (fileRef != -1) { sl@0: CloseResFile(fileRef); sl@0: } sl@0: sl@0: UseResFile(saveRef); sl@0: sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * tclOSAGetScriptID -- sl@0: * sl@0: * This returns the context ID, gibven the component name. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result sl@0: * sl@0: * Side effects: sl@0: * Passes out the script ID in the variable scriptID. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: tclOSAGetScriptID( sl@0: tclOSAComponent *theComponent, sl@0: CONST char *scriptName, sl@0: OSAID *scriptID) sl@0: { sl@0: tclOSAScript *theScript; sl@0: sl@0: theScript = tclOSAGetScript(theComponent, scriptName); sl@0: if (theScript == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: *scriptID = theScript->scriptID; sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * tclOSAAddScript -- sl@0: * sl@0: * This adds a script to theComponent's script table, with the sl@0: * given name & ID. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result sl@0: * sl@0: * Side effects: sl@0: * Adds an element to the component's script table. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: tclOSAAddScript( sl@0: tclOSAComponent *theComponent, sl@0: char *scriptName, sl@0: long modeFlags, sl@0: OSAID scriptID) sl@0: { sl@0: Tcl_HashEntry *hashEntry; sl@0: int newPtr; sl@0: static int scriptIndex = 0; sl@0: tclOSAScript *theScript; sl@0: sl@0: if (*scriptName == '\0') { sl@0: sprintf(scriptName, "OSAScript%d", scriptIndex++); sl@0: } sl@0: sl@0: hashEntry = Tcl_CreateHashEntry(&theComponent->scriptTable, sl@0: scriptName, &newPtr); sl@0: if (newPtr == 0) { sl@0: theScript = (tclOSAScript *) Tcl_GetHashValue(hashEntry); sl@0: OSADispose(theComponent->theComponent, theScript->scriptID); sl@0: } else { sl@0: theScript = (tclOSAScript *) ckalloc(sizeof(tclOSAScript)); sl@0: if (theScript == NULL) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: sl@0: theScript->scriptID = scriptID; sl@0: theScript->languageID = theComponent->languageID; sl@0: theScript->modeFlags = modeFlags; sl@0: sl@0: Tcl_SetHashValue(hashEntry,(ClientData) theScript); sl@0: sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * tclOSAGetScriptID -- sl@0: * sl@0: * This returns the script structure, given the component and script name. sl@0: * sl@0: * Results: sl@0: * A pointer to the script structure. sl@0: * sl@0: * Side effects: sl@0: * None sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static tclOSAScript * sl@0: tclOSAGetScript( sl@0: tclOSAComponent *theComponent, sl@0: CONST char *scriptName) sl@0: { sl@0: Tcl_HashEntry *hashEntry; sl@0: sl@0: hashEntry = Tcl_FindHashEntry(&theComponent->scriptTable, scriptName); sl@0: if (hashEntry == NULL) { sl@0: return NULL; sl@0: } sl@0: sl@0: return (tclOSAScript *) Tcl_GetHashValue(hashEntry); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * tclOSADeleteScript -- sl@0: * sl@0: * This deletes the script given by scriptName. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result sl@0: * sl@0: * Side effects: sl@0: * Deletes the script from the script table, and frees up the sl@0: * resources associated with it. If there is an error, then sl@0: * space for the error message is malloc'ed, and passed out in sl@0: * the variable errMsg. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: tclOSADeleteScript( sl@0: tclOSAComponent *theComponent, sl@0: CONST char *scriptName, sl@0: char *errMsg) sl@0: { sl@0: Tcl_HashEntry *hashEntry; sl@0: tclOSAScript *scriptPtr; sl@0: sl@0: hashEntry = Tcl_FindHashEntry(&theComponent->scriptTable, scriptName); sl@0: if (hashEntry == NULL) { sl@0: errMsg = ckalloc(17); sl@0: strcpy(errMsg,"Script not found"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: scriptPtr = (tclOSAScript *) Tcl_GetHashValue(hashEntry); sl@0: OSADispose(theComponent->theComponent, scriptPtr->scriptID); sl@0: ckfree((char *) scriptPtr); sl@0: Tcl_DeleteHashEntry(hashEntry); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclOSAActiveProc -- sl@0: * sl@0: * This is passed to each component. It is run periodically sl@0: * during script compilation and script execution. It in turn sl@0: * calls Tcl_DoOneEvent to process the event queue. We also call sl@0: * the default Active proc which will let the user cancel the script sl@0: * by hitting Command-. sl@0: * sl@0: * Results: sl@0: * A standard MacOS system error sl@0: * sl@0: * Side effects: sl@0: * Any Tcl code may run while calling Tcl_DoOneEvent. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static pascal OSErr sl@0: TclOSAActiveProc( sl@0: long refCon) sl@0: { sl@0: tclOSAComponent *theComponent = (tclOSAComponent *) refCon; sl@0: sl@0: Tcl_DoOneEvent(TCL_DONT_WAIT); sl@0: InvokeOSAActiveUPP(theComponent->defRefCon, theComponent->defActiveProc); sl@0: sl@0: return noErr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * ASCIICompareProc -- sl@0: * sl@0: * Trivial ascii compare for use with qsort. sl@0: * sl@0: * Results: sl@0: * strcmp of the two input strings sl@0: * sl@0: * Side effects: sl@0: * None sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: static int sl@0: ASCIICompareProc(const void *first,const void *second) sl@0: { sl@0: int order; sl@0: sl@0: char *firstString = *((char **) first); sl@0: char *secondString = *((char **) second); sl@0: sl@0: order = strcmp(firstString, secondString); sl@0: sl@0: return order; sl@0: } sl@0: sl@0: #define REALLOC_INCR 30 sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * getSortedHashKeys -- sl@0: * sl@0: * returns an alphabetically sorted list of the keys of the hash sl@0: * theTable which match the string "pattern" in the DString sl@0: * theResult. pattern == NULL matches all. sl@0: * sl@0: * Results: sl@0: * None sl@0: * sl@0: * Side effects: sl@0: * ReInitializes the DString theResult, then copies the names of sl@0: * the matching keys into the string as list elements. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: getSortedHashKeys( sl@0: Tcl_HashTable *theTable, sl@0: CONST char *pattern, sl@0: Tcl_DString *theResult) sl@0: { sl@0: Tcl_HashSearch search; sl@0: Tcl_HashEntry *hPtr; sl@0: Boolean compare = true; sl@0: char *keyPtr; sl@0: static char **resultArgv = NULL; sl@0: static int totSize = 0; sl@0: int totElem = 0, i; sl@0: sl@0: if (pattern == NULL || *pattern == '\0' || sl@0: (*pattern == '*' && *(pattern + 1) == '\0')) { sl@0: compare = false; sl@0: } sl@0: sl@0: for (hPtr = Tcl_FirstHashEntry(theTable,&search), totElem = 0; sl@0: hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { sl@0: sl@0: keyPtr = (char *) Tcl_GetHashKey(theTable, hPtr); sl@0: if (!compare || Tcl_StringMatch(keyPtr, pattern)) { sl@0: totElem++; sl@0: if (totElem >= totSize) { sl@0: totSize += REALLOC_INCR; sl@0: resultArgv = (char **) ckrealloc((char *) resultArgv, sl@0: totSize * sizeof(char *)); sl@0: } sl@0: resultArgv[totElem - 1] = keyPtr; sl@0: } sl@0: } sl@0: sl@0: Tcl_DStringInit(theResult); sl@0: if (totElem == 1) { sl@0: Tcl_DStringAppendElement(theResult, resultArgv[0]); sl@0: } else if (totElem > 1) { sl@0: qsort((VOID *) resultArgv, (size_t) totElem, sizeof (char *), sl@0: ASCIICompareProc); sl@0: sl@0: for (i = 0; i < totElem; i++) { sl@0: Tcl_DStringAppendElement(theResult, resultArgv[i]); sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * prepareScriptData -- sl@0: * sl@0: * Massages the input data in the argv array, concating the sl@0: * elements, with a " " between each, and replacing \n with \r, sl@0: * and \\n with " ". Puts the result in the the DString scrptData, sl@0: * and copies the result to the AEdesc scrptDesc. sl@0: * sl@0: * Results: sl@0: * Standard Tcl result sl@0: * sl@0: * Side effects: sl@0: * Creates a new Handle (with AECreateDesc) for the script data. sl@0: * Stores the script in scrptData, or the error message if there sl@0: * is an error creating the descriptor. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: prepareScriptData( sl@0: int argc, sl@0: CONST char **argv, sl@0: Tcl_DString *scrptData, sl@0: AEDesc *scrptDesc) sl@0: { sl@0: char * ptr; sl@0: int i; sl@0: char buffer[7]; sl@0: OSErr sysErr = noErr; sl@0: Tcl_DString encodedText; sl@0: sl@0: Tcl_DStringInit(scrptData); sl@0: sl@0: for (i = 0; i < argc; i++) { sl@0: Tcl_DStringAppend(scrptData, argv[i], -1); sl@0: Tcl_DStringAppend(scrptData, " ", 1); sl@0: } sl@0: sl@0: /* sl@0: * First replace the \n's with \r's in the script argument sl@0: * Also replace "\\n" with " ". sl@0: */ sl@0: sl@0: for (ptr = scrptData->string; *ptr != '\0'; ptr++) { sl@0: if (*ptr == '\n') { sl@0: *ptr = '\r'; sl@0: } else if (*ptr == '\\') { sl@0: if (*(ptr + 1) == '\n') { sl@0: *ptr = ' '; sl@0: *(ptr + 1) = ' '; sl@0: } sl@0: } sl@0: } sl@0: sl@0: Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(scrptData), sl@0: Tcl_DStringLength(scrptData), &encodedText); sl@0: sysErr = AECreateDesc(typeChar, Tcl_DStringValue(&encodedText), sl@0: Tcl_DStringLength(&encodedText), scrptDesc); sl@0: Tcl_DStringFree(&encodedText); sl@0: sl@0: if (sysErr != noErr) { sl@0: sprintf(buffer, "%6d", sysErr); sl@0: Tcl_DStringFree(scrptData); sl@0: Tcl_DStringAppend(scrptData, "Error #", 7); sl@0: Tcl_DStringAppend(scrptData, buffer, -1); sl@0: Tcl_DStringAppend(scrptData, " creating Script Data Descriptor.", 33); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * tclOSAResultFromID -- sl@0: * sl@0: * Gets a human readable version of the result from the script ID sl@0: * and returns it in the result of the interpreter interp sl@0: * sl@0: * Results: sl@0: * None sl@0: * sl@0: * Side effects: sl@0: * Sets the result of interp to the human readable version of resultID. sl@0: * sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: tclOSAResultFromID( sl@0: Tcl_Interp *interp, sl@0: ComponentInstance theComponent, sl@0: OSAID resultID ) sl@0: { sl@0: OSErr myErr = noErr; sl@0: AEDesc resultDesc; sl@0: Tcl_DString resultStr; sl@0: sl@0: Tcl_DStringInit(&resultStr); sl@0: sl@0: myErr = OSADisplay(theComponent, resultID, typeChar, sl@0: kOSAModeNull, &resultDesc); sl@0: Tcl_DStringAppend(&resultStr, (char *) *resultDesc.dataHandle, sl@0: GetHandleSize(resultDesc.dataHandle)); sl@0: Tcl_DStringResult(interp,&resultStr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * tclOSAASError -- sl@0: * sl@0: * Gets the error message from the AppleScript component, and adds sl@0: * it to interp's result. If the script data is known, will point sl@0: * out the offending bit of code. This MUST BE A NULL TERMINATED sl@0: * C-STRING, not a typeChar. sl@0: * sl@0: * Results: sl@0: * None sl@0: * sl@0: * Side effects: sl@0: * Sets the result of interp to error, plus the relevant portion sl@0: * of the script. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: tclOSAASError( sl@0: Tcl_Interp * interp, sl@0: ComponentInstance theComponent, sl@0: char *scriptData ) sl@0: { sl@0: OSErr myErr = noErr; sl@0: AEDesc errResult,errLimits; sl@0: Tcl_DString errStr; sl@0: DescType returnType; sl@0: Size returnSize; sl@0: short srcStart,srcEnd; sl@0: char buffer[16]; sl@0: sl@0: Tcl_DStringInit(&errStr); sl@0: Tcl_DStringAppend(&errStr, "An AppleScript error was encountered.\n", -1); sl@0: sl@0: OSAScriptError(theComponent, kOSAErrorNumber, sl@0: typeShortInteger, &errResult); sl@0: sl@0: sprintf(buffer, "Error #%-6.6d\n", (short int) **errResult.dataHandle); sl@0: sl@0: AEDisposeDesc(&errResult); sl@0: sl@0: Tcl_DStringAppend(&errStr,buffer, 15); sl@0: sl@0: OSAScriptError(theComponent, kOSAErrorMessage, typeChar, &errResult); sl@0: Tcl_DStringAppend(&errStr, (char *) *errResult.dataHandle, sl@0: GetHandleSize(errResult.dataHandle)); sl@0: AEDisposeDesc(&errResult); sl@0: sl@0: if (scriptData != NULL) { sl@0: int lowerB, upperB; sl@0: sl@0: myErr = OSAScriptError(theComponent, kOSAErrorRange, sl@0: typeOSAErrorRange, &errResult); sl@0: sl@0: myErr = AECoerceDesc(&errResult, typeAERecord, &errLimits); sl@0: myErr = AEGetKeyPtr(&errLimits, keyOSASourceStart, sl@0: typeShortInteger, &returnType, &srcStart, sl@0: sizeof(short int), &returnSize); sl@0: myErr = AEGetKeyPtr(&errLimits, keyOSASourceEnd, typeShortInteger, sl@0: &returnType, &srcEnd, sizeof(short int), &returnSize); sl@0: AEDisposeDesc(&errResult); sl@0: AEDisposeDesc(&errLimits); sl@0: sl@0: Tcl_DStringAppend(&errStr, "\nThe offending bit of code was:\n\t", -1); sl@0: /* sl@0: * Get the full line on which the error occured: sl@0: */ sl@0: for (lowerB = srcStart; lowerB > 0; lowerB--) { sl@0: if (*(scriptData + lowerB ) == '\r') { sl@0: lowerB++; sl@0: break; sl@0: } sl@0: } sl@0: sl@0: for (upperB = srcEnd; *(scriptData + upperB) != '\0'; upperB++) { sl@0: if (*(scriptData + upperB) == '\r') { sl@0: break; sl@0: } sl@0: } sl@0: sl@0: Tcl_DStringAppend(&errStr, scriptData+lowerB, srcStart - lowerB); sl@0: Tcl_DStringAppend(&errStr, "_", 1); sl@0: Tcl_DStringAppend(&errStr, scriptData+srcStart, upperB - srcStart); sl@0: } sl@0: sl@0: Tcl_DStringResult(interp,&errStr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * GetRawDataFromDescriptor -- sl@0: * sl@0: * Get the data from a descriptor. sl@0: * sl@0: * Results: sl@0: * None sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: GetRawDataFromDescriptor( sl@0: AEDesc *theDesc, sl@0: Ptr destPtr, sl@0: Size destMaxSize, sl@0: Size *actSize) sl@0: { sl@0: Size copySize; sl@0: sl@0: if (theDesc->dataHandle) { sl@0: HLock((Handle)theDesc->dataHandle); sl@0: *actSize = GetHandleSize((Handle)theDesc->dataHandle); sl@0: copySize = *actSize < destMaxSize ? *actSize : destMaxSize; sl@0: BlockMove(*theDesc->dataHandle, destPtr, copySize); sl@0: HUnlock((Handle)theDesc->dataHandle); sl@0: } else { sl@0: *actSize = 0; sl@0: } sl@0: sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * GetRawDataFromDescriptor -- sl@0: * sl@0: * Get the data from a descriptor. Assume it's a C string. sl@0: * sl@0: * Results: sl@0: * None sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static OSErr sl@0: GetCStringFromDescriptor( sl@0: AEDesc *sourceDesc, sl@0: char *resultStr, sl@0: Size resultMaxSize, sl@0: Size *resultSize) sl@0: { sl@0: OSErr err; sl@0: AEDesc resultDesc; sl@0: sl@0: resultDesc.dataHandle = nil; sl@0: sl@0: err = AECoerceDesc(sourceDesc, typeChar, &resultDesc); sl@0: sl@0: if (!err) { sl@0: GetRawDataFromDescriptor(&resultDesc, (Ptr) resultStr, sl@0: resultMaxSize - 1, resultSize); sl@0: resultStr[*resultSize] = 0; sl@0: } else { sl@0: err = errAECoercionFail; sl@0: } sl@0: sl@0: if (resultDesc.dataHandle) { sl@0: AEDisposeDesc(&resultDesc); sl@0: } sl@0: sl@0: return err; sl@0: }