URL https://opencores.org/ocsvn/or1k_old/or1k_old/trunk
Subversion Repositories or1k_old

[/] [or1k_old/] [trunk/] [insight/] [tcl/] [mac/] [tclMacOSA.c] - Blame information for rev 1782

Details | Compare with Previous | View Log

/*
 * 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.
 *
 * RCS: @(#) $Id: tclMacOSA.c,v 1.1.1.1 2002-01-16 10:25:30 markom Exp $
 */
 
#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;
}
Browse

Tools

Subversion Repositories or1k_old

[/] [or1k_old/] [trunk/] [insight/] [tcl/] [mac/] [tclMacOSA.c] - Blame information for rev 1782

Line No.	Rev	Author	Line
1	578	markom	`/*`
2			`* tclMacOSA.c --`
3			`*`
4			`* This contains the initialization routines, and the implementation of`
5			`* the OSA and Component commands. These commands allow you to connect`
6			`* with the AppleScript or any other OSA component to compile and execute`
7			`* scripts.`
8			`*`
9			`* Copyright (c) 1996 Lucent Technologies and Jim Ingham`
10			`* Copyright (c) 1997 Sun Microsystems, Inc.`
11			`*`
12			`* See the file "License Terms" for information on usage and redistribution`
13			`* of this file, and for a DISCLAIMER OF ALL WARRANTIES.`
14			`*`
15			`* RCS: @(#) $Id: tclMacOSA.c,v 1.1.1.1 2002-01-16 10:25:30 markom Exp $`
16			`*/`
17
18			`#define MAC_TCL`
19
20			`#include <Aliases.h>`
21			`#include <string.h>`
22			`#include <AppleEvents.h>`
23			`#include <AppleScript.h>`
24			`#include <OSA.h>`
25			`#include <OSAGeneric.h>`
26			`#include <Script.h>`
27
28			`#include <FullPath.h>`
29			`#include <components.h>`
30
31			`#include <resources.h>`
32			`#include <FSpCompat.h>`
33			`/*`
34			`* The following two Includes are from the More Files package.`
35			`*/`
36			`#include <MoreFiles.h>`
37			`#include <FullPath.h>`
38
39			`#include "tcl.h"`
40			`#include "tclInt.h"`