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