#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>
#include <MoreFiles.h>
#include <FullPath.h>
#include "tcl.h"
#include "tclInt.h"
#include "tclMacInt.h"
typedef struct tclOSAScript {
OSAID scriptID;
OSType languageID;
long modeFlags;
} tclOSAScript;
typedef struct tclOSAContext {
OSAID contextID;
} tclOSAContext;
typedef struct tclOSAComponent {
char *theName;
ComponentInstance theComponent;
long componentFlags;
OSType languageID;
char *languageName;
Tcl_HashTable contextTable;
Tcl_HashTable scriptTable;
Tcl_Interp *theInterp;
OSAActiveUPP defActiveProc;
long defRefCon;
} tclOSAComponent;
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));
#pragma export on
int Tclapplescript_Init( Tcl_Interp *interp );
#pragma export reset
int
Tclapplescript_Init(
Tcl_Interp *interp)
{
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;
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) {
ckfree((char *) foundComp);
} else {
GotOneOSALanguage = true;
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;
}
if (foundComp->componentSubType == kAppleScriptSubtype) {
appleScriptFlags = foundComp->componentFlags;
gotAppleScript = true;
}
}
}
if (!GotOneOSALanguage) {
Tcl_AppendResult(interp,"Could not find any OSA languages",
(char *) NULL);
return TCL_ERROR;
}
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);
if (gotAppleScript) {
if (tclOSAMakeNewComponent(interp, "AppleScript",
"AppleScript English", kAppleScriptSubtype,
appleScriptFlags) == NULL ) {
return TCL_ERROR;
}
}
return Tcl_PkgProvide(interp, "OSAConnect", "1.0");
}
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]);
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) {
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;
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;
}
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;
}
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;
}
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;
while (argc > 0) {
if (*argv[0] == '-') {
c = *(argv[0] + 1);
if (c == '-' && *(argv[0] + 2) == '\0') {
argv += 1;
argc--;
break;
}
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) {
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) {
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;
}
}
if (argc == 0) {
goto numArgs;
}
if (makeContext) {
modeFlags |= kOSAModeCompileIntoContext;
if (resultName == NULL) {
resultName = autoName;
resultID = kOSANullScript;
makeNewContext = true;
} else if (tclOSAGetContextID(OSAComponent,
resultName, &resultID) == TCL_OK) {
makeNewContext = false;
} else {
makeNewContext = true;
resultID = kOSANullScript;
}
if (augment && !makeNewContext) {
modeFlags |= kOSAModeAugmentContext;
}
}
if (prepareScriptData(argc, argv, &scrptData, &scrptDesc) == TCL_ERROR) {
Tcl_DStringResult(interp, &scrptData);
AEDisposeDesc(&scrptDesc);
return TCL_ERROR;
}
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) {
OSAID activateID;
osaErr = OSAExecute(OSAComponent->theComponent, resultID,
resultID, kOSAModeCanInteract, &activateID);
OSADispose(OSAComponent->theComponent, activateID);
if (osaErr == noErr) {
if (makeNewContext) {
tclOSAAddContext(OSAComponent, resultName, resultID);
}
Tcl_SetResult(interp, resultName, TCL_VOLATILE);
tclError = TCL_OK;
}
} else {
tclOSAAddScript(OSAComponent, resultName, modeFlags, resultID);
Tcl_SetResult(interp, resultName, TCL_VOLATILE);
tclError = TCL_OK;
}
}
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;
}
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;
}
}
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;
}
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;
tclOSAGetContextID(OSAComponent, "global", &contextID);
while (argc > 0) {
if (*argv[0] == '-') {
c = *(argv[0] + 1);
if (c == '-' && *(argv[0] + 2) == '\0') {
argv += 1;
argc--;
break;
}
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;
}
if (OSAComponent->componentFlags && kOSASupportsConvenience) {
osaErr = OSACompileExecute(OSAComponent->theComponent,
&scrptDesc, contextID, modeFlags, &resultID);
} else {
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 {
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;
}
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;
}
}
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;
while (argc > 0) {
if (*argv[0] == '-') {
c = *(argv[0] + 1);
if (c == '-' && *(argv[0] + 2) == '\0') {
argv += 1;
argc--;
break;
}
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;
}
}
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;
}
OSAGetScriptInfo(OSAComponent->theComponent, resultID,
kOSAScriptIsTypeScriptContext, &scptInfo);
if (scptInfo) {
autoName[0] = '\0';
tclOSAAddContext(OSAComponent, autoName, resultID);
Tcl_SetResult(interp, autoName, TCL_VOLATILE);
} else {
autoName[0] = '\0';
tclOSAAddScript(OSAComponent, autoName, kOSAModeCanInteract, resultID);
Tcl_SetResult(interp, autoName, TCL_VOLATILE);
}
return TCL_OK;
}
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;
}
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;
}
argv += 2;
argc -= 2;
while (argc > 0) {
if (*argv[0] == '-') {
c = *(argv[0] + 1);
if (c == '-' && *(argv[0] + 2) == '\0') {
argv += 1;
argc--;
break;
}
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;
}
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;
while (argc > 0) {
if (*argv[0] == '-') {
c = *(argv[0] + 1);
if (c == '-' && *(argv[0] + 2) == '\0') {
argv += 1;
argc--;
break;
}
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;
}
}
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;
}
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);
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);
if (OSAGetActiveProc(newComponent->theComponent,
&newComponent->defActiveProc, &newComponent->defRefCon) != noErr ) {
}
myActiveProcUPP = NewOSAActiveProc(TclOSAActiveProc);
OSASetActiveProc(newComponent->theComponent,
myActiveProcUPP, (long) newComponent);
return newComponent;
CleanUp:
ckfree((char *) newComponent);
return (tclOSAComponent *) NULL;
}
void
tclOSAClose(
ClientData clientData)
{
tclOSAComponent *theComponent = (tclOSAComponent *) clientData;
Tcl_HashEntry *hashEntry;
Tcl_HashSearch search;
tclOSAScript *theScript;
Tcl_HashTable *ComponentTable;
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);
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);
}
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;
}
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);
}
static int
tclOSADeleteContext(
tclOSAComponent *theComponent,
char *contextName)
{
Tcl_HashEntry *hashEntry;
tclOSAContext *contextStruct;
hashEntry = Tcl_FindHashEntry(&theComponent->contextTable, contextName);
if (hashEntry == NULL) {
return TCL_ERROR;
}
contextStruct = (tclOSAContext *) Tcl_GetHashValue(hashEntry);
OSADispose(theComponent->theComponent,contextStruct->contextID);
ckfree((char *) contextStruct);
Tcl_DeleteHashEntry(hashEntry);
return TCL_OK;
}
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;
}
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;
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;
}
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 {
}
if (resourceName != NULL) {
strcpy((char *) rezName + 1, resourceName);
rezName[0] = strlen(resourceName);
resHandle = Get1NamedResource('scpt', rezName);
myErr = ResError();
if (resHandle == NULL) {
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 {
sprintf(idStr, "%d", myErr);
Tcl_AppendResult(interp, "Error #", idStr,
" opening scpt resource named ", resourceName,
" in file ", fileName, (char *) NULL);
result = TCL_ERROR;
goto rezEvalCleanUp;
}
}
} else {
resHandle = Get1Resource('scpt', resourceNumber);
rezName[0] = 0;
rezName[1] = '\0';
myErr = ResError();
if (resHandle == NULL) {
if (myErr == resNotFound || myErr == noErr) {
AddResource(scriptData.dataHandle, 'scpt',
resourceNumber, rezName);
WriteResource(resHandle);
result = TCL_OK;
goto rezEvalCleanUp;
} else {
sprintf(idStr, "%d", myErr);
Tcl_AppendResult(interp, "Error #", idStr,
" opening scpt resource named ", resourceName,
" in file ", fileName,(char *) NULL);
result = TCL_ERROR;
goto rezEvalCleanUp;
}
}
}
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;
}
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 {
}
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;
}
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;
}
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;
}
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);
}
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;
}
static pascal OSErr
TclOSAActiveProc(
long refCon)
{
tclOSAComponent *theComponent = (tclOSAComponent *) refCon;
Tcl_DoOneEvent(TCL_DONT_WAIT);
CallOSAActiveProc(theComponent->defActiveProc, theComponent->defRefCon);
return noErr;
}
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
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]);
}
}
}
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);
}
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;
}
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);
}
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);
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);
}
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;
}
}
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;
}