/*
* 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.10 2002/10/09 11:54:30 das 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,
CONST char **argv));
static int tclOSADecompileCmd _ANSI_ARGS_((Tcl_Interp * Interp,
tclOSAComponent *OSAComponent, int argc,
CONST char **argv));
static int tclOSADeleteCmd _ANSI_ARGS_((Tcl_Interp *interp,
tclOSAComponent *OSAComponent, int argc,
CONST char **argv));
static int tclOSAExecuteCmd _ANSI_ARGS_((Tcl_Interp *interp,
tclOSAComponent *OSAComponent, int argc,
CONST char **argv));
static int tclOSAInfoCmd _ANSI_ARGS_((Tcl_Interp *interp,
tclOSAComponent *OSAComponent, int argc,
CONST char **argv));
static int tclOSALoadCmd _ANSI_ARGS_((Tcl_Interp *interp,
tclOSAComponent *OSAComponent, int argc,
CONST char **argv));
static int tclOSARunCmd _ANSI_ARGS_((Tcl_Interp *interp,
tclOSAComponent *OSAComponent, int argc,
CONST char **argv));
static int tclOSAStoreCmd _ANSI_ARGS_((Tcl_Interp *interp,
tclOSAComponent *OSAComponent, int argc,
CONST 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, CONST char **argv));
static void getSortedHashKeys _ANSI_ARGS_((Tcl_HashTable *theTable,
CONST 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, CONST 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, CONST 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,
CONST char *contextName, OSAID *theContext));
static void tclOSAAddContext _ANSI_ARGS_((tclOSAComponent *theComponent,
char *contextName, const OSAID theContext));
static int tclOSAMakeContext _ANSI_ARGS_((tclOSAComponent *theComponent,
CONST char *contextName, OSAID *theContext));
static int tclOSADeleteContext _ANSI_ARGS_((tclOSAComponent *theComponent,
CONST char *contextName));
static int tclOSALoad _ANSI_ARGS_((Tcl_Interp *interp,
tclOSAComponent *theComponent, CONST char *resourceName,
int resourceNumber, CONST char *fileName,OSAID *resultID));
static int tclOSAStore _ANSI_ARGS_((Tcl_Interp *interp,
tclOSAComponent *theComponent, CONST char *resourceName,
int resourceNumber, CONST char *scriptName, CONST char *fileName));
static int tclOSAAddScript _ANSI_ARGS_((tclOSAComponent *theComponent,
char *scriptName, long modeFlags, OSAID scriptID));
static int tclOSAGetScriptID _ANSI_ARGS_((tclOSAComponent *theComponent,
CONST char *scriptName, OSAID *scriptID));
static tclOSAScript * tclOSAGetScript _ANSI_ARGS_((tclOSAComponent *theComponent,
CONST char *scriptName));
static int tclOSADeleteScript _ANSI_ARGS_((tclOSAComponent *theComponent,
CONST 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;
/*
* Perform the required stubs magic...
*/
if (!Tcl_InitStubs(interp, "8.2", 0)) {
return TCL_ERROR;
}
/*
* 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,
CONST 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,
CONST 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,
CONST 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) {
strncpy(autoName, argv[1], 15);
autoName[15] = '\0';
resultName = autoName;
} 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) {
} else {
makeNewContext = true;
}
/*
* Deal with the augment now...
*/
if (augment && !makeNewContext) {
modeFlags |= kOSAModeAugmentContext;
}
} else if (resultName == NULL) {
resultName = autoName; /* Auto name the script */
}
/*
* 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 #%-6ld 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,
CONST 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,
CONST 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,
CONST 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 #%-6ld 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,
CONST 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,
CONST char **argv)
{
int tclError = TCL_OK, resID = 128;
char c, autoName[24],
*contextName = NULL, *scriptName = NULL;
CONST char *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,
CONST 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;
CONST 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,
CONST char **argv)
{
int tclError = TCL_OK, resID = 128;
char c, *contextName = NULL, *scriptName = NULL;
CONST char *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.6ld", 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 = NewOSAActiveUPP(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,
CONST 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(16 + TCL_INTEGER_SPACE);
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,
CONST 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,
CONST 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) {
char name[24];
strncpy(name, contextName, 23);
name[23] = '\0';
tclOSAAddContext(theComponent, name, *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,
CONST char *resourceName,
int resourceNumber,
CONST char *scriptName,
CONST char *fileName)
{
Handle resHandle;
Str255 rezName;
int result = TCL_OK;
short saveRef, fileRef = -1;
char idStr[16 + TCL_INTEGER_SPACE];
FSSpec fileSpec;
Tcl_DString ds, buffer;
CONST 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;
if (Tcl_TranslateFileName(interp, fileName, &buffer) == NULL) {
return TCL_ERROR;
}
nativeName = Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&buffer),
Tcl_DStringLength(&buffer), &ds);
err = FSpLocationFromPath(strlen(nativeName), nativeName, &fileSpec);
Tcl_DStringFree(&ds);
Tcl_DStringFree(&buffer);
if ((err != noErr) && (err != fnfErr)) {
Tcl_AppendResult(interp,
"Error getting a location for the file: \"",
fileName, "\".", NULL);
return TCL_ERROR;
}
FSpCreateResFileCompatTcl(&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 = FSpOpenResFileCompatTcl(&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,
CONST char *resourceName,
int resourceNumber,
CONST char *fileName,
OSAID *resultID)
{
Handle sourceData;
Str255 rezName;
int result = TCL_OK;
short saveRef, fileRef = -1;
char idStr[16 + TCL_INTEGER_SPACE];
FSSpec fileSpec;
Tcl_DString ds, buffer;
CONST char *nativeName;
saveRef = CurResFile();
if (fileName != NULL) {
OSErr err;
if (Tcl_TranslateFileName(interp, fileName, &buffer) == NULL) {
return TCL_ERROR;
}
nativeName = Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&buffer),
Tcl_DStringLength(&buffer), &ds);
err = FSpLocationFromPath(strlen(nativeName), nativeName, &fileSpec);
Tcl_DStringFree(&ds);
Tcl_DStringFree(&buffer);
if (err != noErr) {
Tcl_AppendResult(interp, "Error finding the file: \"",
fileName, "\".", NULL);
return TCL_ERROR;
}
fileRef = FSpOpenResFileCompatTcl(&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,
CONST 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,
CONST 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,
CONST 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);
InvokeOSAActiveUPP(theComponent->defRefCon, theComponent->defActiveProc);
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,
CONST 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,
CONST char **argv,
Tcl_DString *scrptData,
AEDesc *scrptDesc)
{
char * ptr;
int i;
char buffer[7];
OSErr sysErr = noErr;
Tcl_DString encodedText;
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) = ' ';
}
}
}
Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(scrptData),
Tcl_DStringLength(scrptData), &encodedText);
sysErr = AECreateDesc(typeChar, Tcl_DStringValue(&encodedText),
Tcl_DStringLength(&encodedText), scrptDesc);
Tcl_DStringFree(&encodedText);
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;
}
syntax highlighted by Code2HTML, v. 0.9.1