/* -*-C++-*- * ################################################################### * TclAE - AppleEvent extension for Tcl * * FILE: "tclAEObjects.c" * created: 11/13/00 {10:30:29 PM} * last update: 2/3/04 {10:39:33 AM} * Author: Jonathan Guyer * E-mail: jguyer@his.com * mail: Alpha Cabal * POMODORO no seisan * www: http://www.his.com/jguyer/ * * ======================================================================== * Copyright © 2000 Jonathan Guyer * All rights reserved * ======================================================================== * Permission to use, copy, modify, and distribute this software and its * documentation for any purpose and without fee is hereby granted, * provided that the above copyright notice appear in all copies and that * both that the copyright notice and warranty disclaimer appear in * supporting documentation. * * Jonathan Guyer disclaims all warranties with regard to this software, * including all implied warranties of merchantability and fitness. In * no event shall Jonathan Guyer be liable for any special, indirect or * consequential damages or any damages whatsoever resulting from loss of * use, data or profits, whether in an action of contract, negligence or * other tortuous action, arising out of or in connection with the use or * performance of this software. * ======================================================================== * See header file for further information * ################################################################### */ #ifndef _TCL #include #endif #ifdef TCLAE_USE_FRAMEWORK_INCLUDES #include #else #include #endif #include #include "tclAEInt.h" #include "tclMacOSError.h" /* I don't claim that I understand why, by gInterp will retain different * values for different applications that invoke TclAE. This is fortunate * because the slugs at Apple were too lazy to provide a refcon field * in the object callbacks. */ static Tcl_Interp * gInterp; static AEDesc gErrorDesc; /* Hash table for storage of object accessors */ static Tcl_HashTable * tclAEObjectAccessorHashTable; static OSLAccessorUPP TclaeObjectAccessorUPP = NULL; static OSLCompareUPP TclaeCompareObjectsUPP = NULL; static OSLCountUPP TclaeCountObjectsUPP = NULL; static OSLDisposeTokenUPP TclaeDisposeTokenUPP = NULL; static OSLGetMarkTokenUPP TclaeGetMarkTokenUPP = NULL; static OSLMarkUPP TclaeMarkUPP = NULL; static OSLAdjustMarksUPP TclaeAdjustMarksUPP = NULL; static OSLGetErrDescUPP TclaeGetErrorDescUPP = NULL; typedef struct tclAEObjectAccessor { DescType desiredClass; DescType containerType; Tcl_Obj *accessorProc; Tcl_Interp *interp; } tclAEObjectAccessor; static Tcl_HashEntry* TclaeGetObjectAccessor(Tcl_Interp* interp, DescType desiredClass, DescType containerType, char* accessorProc); static pascal OSErr TclaeObjectAccessor(DescType desiredClass, const AEDesc *containerToken, DescType containerClass, DescType keyForm, const AEDesc *keyData, AEDesc *theToken, long theRefcon); static pascal OSErr TclaeCountObjects(DescType desiredClass, DescType containerClass, const AEDesc *theContainer, long *result); static pascal OSErr TclaeCompareObjects(DescType comparisonOperator, const AEDesc *theObject, const AEDesc *objectOrDescToCompare, Boolean *result); static pascal OSErr TclaeDisposeToken(AEDesc *unneededToken); static pascal OSErr TclaeGetErrorDesc(AEDescPtr *errDescPtr); static pascal OSErr TclaeGetMarkToken(const AEDesc *containerToken, DescType containerClass, AEDesc *result); static pascal OSErr TclaeMark(const AEDesc *theToken, const AEDesc *markToken, long markCount); static pascal OSErr TclaeAdjustMarks(long newStart, long newStop, const AEDesc *markToken); static OSErr TclaeRemoveObjectAccessor(DescType desiredClass, DescType containerType, Tcl_HashEntry * hashEntryPtr); /* * ------------------------------------------------------------------------- * * "Tclae_SetObjectCallbacksCmd" -- * * Tcl wrapper for ToolBox AESetObjectCallbacks call. * * Argument Default In/Out Description * ------------ ------- ------ --------------------------------------------- * clientData (unused) * interp In for results * objc In number of arguments * objv In argument objects * * Results: * ¥ * * Side effects: * ¥ * * --Version--Author------------------Changes------------------------------- * 1.0 jguyer@his.com original * ------------------------------------------------------------------------- */ int Tclae_SetObjectCallbacksCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { OSErr err; /* result from ToolBox calls */ // int result; /* result from Tcl calls */ Tcl_Obj * procObj; enum { kCompareProc = 1, kCountProc, kDisposeTokenProc, kGetMarkTokenProc, kMarkProc, kAdjustMarksProc, kTotalArguments }; if (objc != kTotalArguments) { Tcl_WrongNumArgs(interp, 1, objv, " "); return TCL_ERROR; } gInterp = interp; // All compare callbacks are relayed through TclaeCompareObjects() procObj = Tcl_SetVar2Ex(interp, "tclAE::_callbacks", "compareObjects", objv[kCompareProc], TCL_GLOBAL_ONLY); if (Tcl_GetCharLength(procObj) > 0) { if (!TclaeCompareObjectsUPP) { TclaeCompareObjectsUPP = NewOSLCompareUPP(TclaeCompareObjects); } } else { DisposeOSLCompareUPP(TclaeCompareObjectsUPP); } // All count callbacks are relayed through TclaeCountObjects() procObj = Tcl_SetVar2Ex(interp, "tclAE::_callbacks", "countObjects", objv[kCountProc], TCL_GLOBAL_ONLY); if (Tcl_GetCharLength(procObj) > 0) { if (!TclaeCountObjectsUPP) { TclaeCountObjectsUPP = NewOSLCountUPP(TclaeCountObjects); } } else { DisposeOSLCountUPP(TclaeCountObjectsUPP); } // All dispose token callbacks are relayed through TclaeDisposeToken() procObj = Tcl_SetVar2Ex(interp, "tclAE::_callbacks", "disposeToken", objv[kDisposeTokenProc], TCL_GLOBAL_ONLY); if (Tcl_GetCharLength(procObj) > 0) { if (!TclaeDisposeTokenUPP) { TclaeDisposeTokenUPP = NewOSLDisposeTokenUPP(TclaeDisposeToken); } } else { DisposeOSLDisposeTokenUPP(TclaeDisposeTokenUPP); } // All get mark token callbacks are relayed through TclaeGetMarkToken() procObj = Tcl_SetVar2Ex(interp, "tclAE::_callbacks", "getMarkToken", objv[kGetMarkTokenProc], TCL_GLOBAL_ONLY); if (Tcl_GetCharLength(procObj) > 0) { if (!TclaeGetMarkTokenUPP) { TclaeGetMarkTokenUPP = NewOSLGetMarkTokenUPP(TclaeGetMarkToken); } } else { DisposeOSLGetMarkTokenUPP(TclaeGetMarkTokenUPP); } // All mark callbacks are relayed through TclaeMark() procObj = Tcl_SetVar2Ex(interp, "tclAE::_callbacks", "mark", objv[kMarkProc], TCL_GLOBAL_ONLY); if (Tcl_GetCharLength(procObj) > 0) { if (!TclaeMarkUPP) { TclaeMarkUPP = NewOSLMarkUPP(TclaeMark); } } else { DisposeOSLMarkUPP(TclaeMarkUPP); } // All adjust marks callbacks are relayed through TclaeAdjustMarks() procObj = Tcl_SetVar2Ex(interp, "tclAE::_callbacks", "adjustMarks", objv[kAdjustMarksProc], TCL_GLOBAL_ONLY); if (Tcl_GetCharLength(procObj) > 0) { if (!TclaeAdjustMarksUPP) { TclaeAdjustMarksUPP = NewOSLAdjustMarksUPP(TclaeAdjustMarks); } } else { DisposeOSLAdjustMarksUPP(TclaeAdjustMarksUPP); } // All get error desc callbacks are handled by TclaeGetErrorDesc() if (!TclaeGetErrorDescUPP) { TclaeGetErrorDescUPP = NewOSLGetErrDescUPP(TclaeGetErrorDesc); } err = AESetObjectCallbacks(TclaeCompareObjectsUPP, TclaeCountObjectsUPP, TclaeDisposeTokenUPP, TclaeGetMarkTokenUPP, TclaeMarkUPP, TclaeAdjustMarksUPP, TclaeGetErrorDescUPP); if (err != noErr) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "Couldn't set object callbacks: ", Tcl_MacOSError(interp, err), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /* * ------------------------------------------------------------------------- * * "Tclae_ResolveCmd" -- * * * * Argument Default In/Out Description * ------------ ------- ------ --------------------------------------------- * clientData (unused) * interp In for results * objc In number of arguments * objv In argument objects * * Results: * ¥ * * Side effects: * ¥ * * --Version--Author------------------Changes------------------------------- * 1.0 jguyer@his.com original * ------------------------------------------------------------------------- */ int Tclae_ResolveCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { OSErr err; /* result from ToolBox calls */ int result; /* result from Tcl calls */ int j; /* object variable counter */ const AEDesc * objectSpecifier; /* object specifier record to be resolved */ AEDesc * theTokenPtr; /* to hold newly created Token */ short callbackFlags = kAEIDoMinimum; /* additional assistance app can provide AEM */ char * arg; /* for option arguments */ /* Scan optional flags */ for (j = 1; (j < objc) && ((arg = Tcl_GetString(objv[j]))[0] == '-') && (arg[1] != '-'); j++) { switch (arg[1]) { case 'm': callbackFlags |= kAEIDoMarking; break; case 'w': callbackFlags |= kAEIDoWhose; break; } } if (objc < (j + 1)) { Tcl_WrongNumArgs(interp, 1, objv, "?options? "); return TCL_ERROR; } /* objv[1] holds hash key for original descriptor */ result = Tclae_GetConstAEDescFromObj(interp, objv[j], &objectSpecifier, true); if (result != TCL_OK) { return TCL_ERROR; } /* allocate space for new AEDesc */ theTokenPtr = (AEDesc *) ckalloc(sizeof(AEDesc)); err = AEResolve(objectSpecifier, callbackFlags, theTokenPtr); if (err != noErr) { ckfree((char *) theTokenPtr); Tcl_ResetResult(interp); Tcl_AppendResult(interp, "Couldn't resolve object \"", Tcl_GetString(objv[1]), "\": ", Tcl_MacOSError(interp, err), (char *) NULL); return TCL_ERROR; } else { Tcl_SetObjResult(interp, Tclae_NewAEDescObj(theTokenPtr)); return TCL_OK; } } /* * ------------------------------------------------------------------------- * * "Tclae_CallObjectAccessorCmd" -- * * Tcl wrapper for ToolBox AECallObjectAccessor call. * * tclAE::callObjectAccessor * * Argument Default In/Out Description * ------------ ------- ------ --------------------------------------------- * clientData (unused) * interp In for results * objc In number of arguments * objv In argument objects * * Results: * Tcl result code * * Side effects: * result of interp is set to hash key for new token * ------------------------------------------------------------------------- */ int Tclae_CallObjectAccessorCmd(ClientData clientData, /* (unused) */ Tcl_Interp *interp, /* for results */ int objc, /* number of arguments */ Tcl_Obj *const objv[]) /* argument objects */ { OSErr err; /* result from ToolBox calls */ int result; /* result from Tcl calls */ const AEDesc * containerToken; /* the containing AEDesc */ const AEDesc * keyData; /* the AEDesc containing object */ AEDesc * tokenPtr = NULL; /* pointer to new token */ enum { kDesiredType = 1, kContainerToken, kContainerClass, kKeyForm, kKeyData, kTotalArguments }; if (objc != kTotalArguments) { Tcl_WrongNumArgs(interp, 1, objv, " "); return TCL_ERROR; } /* objv[kContainerToken] holds reference for the container */ result = Tclae_GetConstAEDescFromObj(interp, objv[kContainerToken], &containerToken, true); if (result != TCL_OK) { return TCL_ERROR; } /* objv[kKeyData] holds reference for the key data */ result = Tclae_GetConstAEDescFromObj(interp, objv[kKeyData], &keyData, true); if (result != TCL_OK) { return TCL_ERROR; } /* Allocate the coerced AEDesc */ tokenPtr = (AEDesc *) ckalloc(sizeof(AEDesc)); if (tokenPtr == NULL) { return TCL_ERROR; } err = AECallObjectAccessor(TclaeGetOSTypeFromObj(objv[kDesiredType]), containerToken, TclaeGetOSTypeFromObj(objv[kContainerClass]), TclaeGetOSTypeFromObj(objv[kKeyForm]), keyData, tokenPtr); if (err != noErr) { ckfree((char *)tokenPtr); Tcl_ResetResult(interp); Tcl_AppendResult(interp, "Couldn't call object accessor: ", Tcl_MacOSError(interp, err), (char *) NULL); return TCL_ERROR; } else { Tcl_SetObjResult(interp, Tclae_NewAEDescObj(tokenPtr)); return TCL_OK; } } /* * ------------------------------------------------------------------------- * * "Tclae_GetObjectAccessorCmd" -- * * Tcl wrapper for ToolBox AEGetObjectAccessorr call. * This returns the Tcl proc that has been installed as an object accessor. * * tclAE::getObjectAccessor * * Argument Default In/Out Description * ------------ ------- ------ --------------------------------------------- * clientData (unused) * interp In for results * objc In number of arguments * objv In argument objects * * Results: * Tcl result code * * Side effects: * result of interp is set to registered * or errAEAccessorNotFound if none * * --Version--Author------------------Changes------------------------------- * 1.0 jguyer@his.com original * ------------------------------------------------------------------------- */ int Tclae_GetObjectAccessorCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { DescType desiredClass; DescType containerType; Tcl_HashEntry * hashEntryPtr; /* for entry in coercion handler hash table */ OSErr err; OSLAccessorUPP accessor; long accessorRefcon; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, " "); return TCL_ERROR; } desiredClass = TclaeGetOSTypeFromObj(objv[1]); containerType = TclaeGetOSTypeFromObj(objv[2]); hashEntryPtr = TclaeGetObjectAccessor(interp, desiredClass, containerType, NULL); if (hashEntryPtr == NULL) { // Check if there's a non-Tcl coercion handler registered in // the application handler table. // If there is, return nothing. err = AEGetObjectAccessor(desiredClass, containerType, &accessor, &accessorRefcon, false); if (err == errAEAccessorNotFound) { // Check if there's a non-Tcl coercion handler registered in // the system handler table. // If there is, return nothing. err = AEGetObjectAccessor(desiredClass, containerType, &accessor, &accessorRefcon, true); } } else { tclAEObjectAccessor* accessorPtr = Tcl_GetHashValue(hashEntryPtr); // Ensure this accessor is actually registered with the AEM err = AEGetObjectAccessor(desiredClass, containerType, &accessor, &accessorRefcon, false); if ((err != noErr) || (accessor != (OSLAccessorUPP)TclaeObjectAccessorUPP) || (accessorRefcon != (long) accessorPtr)) { // Something is severely wrong. // The accessor in the accessor hash table is either not // registered with the AEM at all, or it is inconsistent // with what the AEM thinks it is. // Delete this coercion hash entry. TclaeRemoveObjectAccessor(desiredClass, containerType, hashEntryPtr); if (err == noErr) { // The AEM didn't report an error, but something was // wrong anyway. Report handler not found. err = errAEAccessorNotFound; } } else { // Return Tcl_Obj *accessorProcPtr = accessorPtr->accessorProc; // Keep interpreter from deleting it Tcl_IncrRefCount(accessorProcPtr); Tcl_SetObjResult(interp, accessorProcPtr); } } if (err != noErr) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "Couldn't find object accessor: ", Tcl_MacOSError(interp, err), (char *) NULL); return TCL_ERROR; } else { return TCL_OK; } } /* * ------------------------------------------------------------------------- * * "Tclae_InstallObjectAccessorCmd" -- * * Tcl wrapper for ToolBox AEInstallObjectAccessor call. * This allows Tcl procs to act as object accessors. * * tclAE::installObjectAccessor * * Argument Default In/Out Description * ------------ ------- ------ --------------------------------------------- * clientData (unused) * interp In for results * objc In number of arguments * objv In argument objects * * Results: * Tcl result code * * Side effects: * is registered and added to the object accessor hash * * --Version--Author------------------Changes------------------------------- * 1.0 jguyer@his.com original * ------------------------------------------------------------------------- */ int Tclae_InstallObjectAccessorCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { DescType desiredClass; DescType containerType; tclAEObjectAccessor * objectAccessorPtr; Tcl_HashEntry * hashEntryPtr; /* for entry in object accessor hash table */ OSErr err; int isNew; /* is hash already used (shouldn't be!) */ if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, " "); return TCL_ERROR; } // As far as the AEM is concerned, all registered accessors are handled by // TclaeObjectAccessor() if (!TclaeObjectAccessorUPP) { TclaeObjectAccessorUPP = NewOSLAccessorUPP(TclaeObjectAccessor); } desiredClass = TclaeGetOSTypeFromObj(objv[1]); containerType = TclaeGetOSTypeFromObj(objv[2]); hashEntryPtr = TclaeGetObjectAccessor(interp, desiredClass, containerType, NULL); if (hashEntryPtr == NULL) { // Not found. Create a new hash entry for this accessor objectAccessorPtr = (tclAEObjectAccessor *) ckalloc(sizeof(tclAEObjectAccessor)); objectAccessorPtr->desiredClass = desiredClass; objectAccessorPtr->containerType = containerType; // No need to check isNew because that's the only reason we're here hashEntryPtr = Tcl_CreateHashEntry(tclAEObjectAccessorHashTable, (char *) objectAccessorPtr, &isNew); if (isNew) { // Set hash entry to point at the accessor record Tcl_SetHashValue(hashEntryPtr, objectAccessorPtr); } } else { // Found. Get the existing handler from the hash entry. objectAccessorPtr = (tclAEObjectAccessor *) Tcl_GetHashValue(hashEntryPtr); } // Assign the Tcl proc which is to handle this accessor objectAccessorPtr->interp = interp; objectAccessorPtr->accessorProc = objv[3]; // Keep proc from being deleted by the interpreter Tcl_IncrRefCount(objv[3]); // Register this accessor with the AEM err = AEInstallObjectAccessor(desiredClass, containerType, TclaeObjectAccessorUPP, (long) objectAccessorPtr, false); if (err != noErr) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "Couldn't install object accessor: ", Tcl_MacOSError(interp, err), (char *) NULL); return TCL_ERROR; } else { return TCL_OK; } } /* * ------------------------------------------------------------------------- * * "Tclae_RemoveObjectAccessorCmd" -- * * Tcl wrapper for ToolBox AERemoveObjectAccessor call. * This removes a Tcl proc that has been installed as an object accessor. * * tclAE::removeObjectAccessor * * Argument Default In/Out Description * ------------ ------- ------ --------------------------------------------- * clientData (unused) * interp In for results * objc In number of arguments * objv In argument objects * * Results: * Tcl result code * * Side effects: * is deregistered and removed from the object accessor hash * * --Version--Author------------------Changes------------------------------- * 1.0 jguyer@his.com original * ------------------------------------------------------------------------- */ int Tclae_RemoveObjectAccessorCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { DescType desiredClass; DescType containerType; Tcl_HashEntry *hashEntryPtr; /* for entry in coercion handler hash table */ OSErr err; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, " "); return TCL_ERROR; } desiredClass = TclaeGetOSTypeFromObj(objv[1]); containerType = TclaeGetOSTypeFromObj(objv[2]); hashEntryPtr = TclaeGetObjectAccessor(interp, desiredClass, containerType, Tcl_GetString(objv[3])); if (hashEntryPtr == NULL) { err = errAEAccessorNotFound; } else { err = TclaeRemoveObjectAccessor(desiredClass, containerType, hashEntryPtr); } if (err != noErr) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "Couldn't remove coercion handler: ", Tcl_MacOSError(interp, err), (char *) NULL); return TCL_ERROR; } else { return TCL_OK; } } /* * ------------------------------------------------------------------------- * * "Tclae_DisposeTokenCmd" -- * * Tcl wrapper for ToolBox AEDisposeToken call * * tclAE::disposeToken * * Argument Default In/Out Description * ------------ ------- ------ --------------------------------------------- * clientData (unused) * interp In for results * objc In number of arguments * objv In argument objects * * Results: * Tcl result code * * Side effects: * Token is deleted * ------------------------------------------------------------------------- */ int Tclae_DisposeTokenCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { AEDesc * tokenPtr; int result; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, ""); return TCL_ERROR; } /* Obtain AEDesc pointer from reference and dispose of it */ result = Tclae_GetAEDescFromObj(interp, objv[1], &tokenPtr, true); if (result != TCL_OK) { return TCL_ERROR; } if (tokenPtr) { OSErr err; /* result from ToolBox calls */ err = AEDisposeToken(tokenPtr); /* !!! what if this wasn't ckalloc'ed? * shouldn't ever happen */ ckfree((char *)tokenPtr); if (err != noErr) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "Couldn't dispose of \"", Tcl_GetString(objv[1]), "\": ", Tcl_MacOSError(interp, err), (char *) NULL); return TCL_ERROR; } } else { /* * No such hash entry. * Throw a slightly bogus "descriptor not found" error */ Tcl_ResetResult(interp); Tcl_AppendResult(interp, "Couldn't dispose of \"", Tcl_GetString(objv[1]), "\": ", Tcl_MacOSError(interp, errAEDescNotFound), (char *) NULL); return TCL_ERROR; } return TCL_OK; } /* ×××× Object callbacks ×××× */ /* * ------------------------------------------------------------------------- * * "TclaeObjectAccessor" -- * * AEM callback routine for all coercions to be handled by Tcl procs * * Results: * MacOS error code * * Side effects: * ??? * * --Version--Author------------------Changes------------------------------- * 1.0 jguyer@his.com original * ------------------------------------------------------------------------- */ static pascal OSErr TclaeObjectAccessor(DescType desiredClass, const AEDesc * containerToken, DescType containerClass, DescType keyForm, const AEDesc * keyData, AEDesc * theToken, long theRefcon) { enum { kAccessorProc = 0, kDesiredClass, kContainerToken, kContainerClass, kKeyForm, kKeyData, kTheToken, kTotalArguments }; Tcl_Obj * objv[kTotalArguments]; Tcl_HashEntry * hashEntryPtr; tclAEObjectAccessor * accessorPtr; int result; Tcl_CmdInfo cmdInfo; // theRefcon holds the hash key for this object accessor hashEntryPtr = Tcl_FindHashEntry(tclAEObjectAccessorHashTable, (char *) theRefcon); if (hashEntryPtr == NULL) { // This really shouldn't happen return errAEAccessorNotFound; } accessorPtr = (tclAEObjectAccessor *) Tcl_GetHashValue(hashEntryPtr); // Apparent bug in Tcl_EvalObjv. // If is undefined in interp, we crash with // an unmapped memory exception, instead of getting an interpreter error // invalid command name "" result = Tcl_GetCommandInfo(accessorPtr->interp, Tcl_GetString(accessorPtr->accessorProc), &cmdInfo); if (!result) { Tcl_ResetResult(accessorPtr->interp); Tcl_AppendResult(accessorPtr->interp, "Couldn't find object accessor \"", Tcl_GetString(accessorPtr->accessorProc), "\": ", Tcl_MacOSError(accessorPtr->interp, errAEAccessorNotFound), (char *) NULL); return errAEAccessorNotFound; } // Build up Tcl object accessor command objv[kAccessorProc] = accessorPtr->accessorProc; // Ensure none of the command objects is disposed of by the interpreter Tcl_IncrRefCount(objv[kAccessorProc]); objv[kDesiredClass] = TclaeNewOSTypeObj(desiredClass); objv[kContainerToken] = Tclae_NewConstAEDescRefObj(containerToken); objv[kContainerClass] = TclaeNewOSTypeObj(containerClass); objv[kKeyForm] = TclaeNewOSTypeObj(keyForm); objv[kKeyData] = Tclae_NewConstAEDescRefObj(keyData); objv[kTheToken] = Tclae_NewAEDescObj(theToken); Tcl_IncrRefCount(objv[kTheToken]); // Execute the coercion handler command // [ ] result = Tcl_EvalObjv(accessorPtr->interp, kTotalArguments, objv, TCL_EVAL_GLOBAL); // Decrement, but don't delete, the handler command Tcl_DecrRefCount(objv[kAccessorProc]); // Delete the reference but not the actual AEDesc (that would be Badª) // Can't just decrement, as that will delete the non-const token TclaeDetachAEDescObj(objv[kTheToken]); Tcl_DecrRefCount(objv[kTheToken]); if (result != TCL_OK) { OSErr err = TclaeErrorCodeFromInterp(accessorPtr->interp); if (err != noErr) { return err; } else { return errAECoercionFail; } } else { return noErr; } } /* * ------------------------------------------------------------------------- * * "TclaeCountObjects" -- * * * * Argument Default In/Out Description * ------------ ------- ------ --------------------------------------------- * desiredClass In * containerClass In * theContainer In * countPtr Out * * Results: * * * Side effects: * * ------------------------------------------------------------------------- */ static pascal OSErr TclaeCountObjects(DescType desiredClass, DescType containerClass, const AEDesc *theContainer, long *countPtr) { enum { kCountProc = 0, kDesiredClass, kContainerClass, kContainer, kTotalArguments }; Tcl_Obj * objv[kTotalArguments]; OSErr err = noErr; int result; objv[kCountProc] = Tcl_GetVar2Ex(gInterp, "tclAE::_callbacks", "countObjects", TCL_GLOBAL_ONLY); if (!objv[kCountProc]) { return errAEEventNotHandled; } Tcl_IncrRefCount(objv[kCountProc]); objv[kDesiredClass] = TclaeNewOSTypeObj(desiredClass); objv[kContainerClass] = TclaeNewOSTypeObj(containerClass); objv[kContainer] = Tclae_NewConstAEDescRefObj(theContainer); // Execute the object count command // set count [ ] result = Tcl_EvalObjv(gInterp, kTotalArguments, objv, TCL_EVAL_GLOBAL); if (result != TCL_OK) { err = TclaeErrorCodeFromInterp(gInterp); if (err == noErr) { err = errAEEventNotHandled; } } else { result = Tcl_GetLongFromObj(gInterp, Tcl_GetObjResult(gInterp), countPtr); if (result != TCL_OK) { err = errAEEventNotHandled; } } return err; } /* * ------------------------------------------------------------------------- * * "TclaeCompareObjects" -- * * * * Argument Default In/Out Description * ------------ ------- ------ --------------------------------------------- * * Results: * * * Side effects: * * ------------------------------------------------------------------------- */ static pascal OSErr TclaeCompareObjects(DescType comparisonOperator, const AEDesc *theObject, const AEDesc *objectOrDescToCompare, Boolean *comparisonPtr) { enum { kCompareProc = 0, kComparisonOperator, kObject, kObjectOrDescToCompare, kTotalArguments }; Tcl_Obj * objv[kTotalArguments]; OSErr err = noErr; int result; objv[kCompareProc] = Tcl_GetVar2Ex(gInterp, "tclAE::_callbacks", "compareObjects", TCL_GLOBAL_ONLY); if (!objv[kCompareProc]) { return errAEEventNotHandled; } Tcl_IncrRefCount(objv[kCompareProc]); objv[kComparisonOperator] = TclaeNewOSTypeObj(comparisonOperator); objv[kObject] = Tclae_NewConstAEDescRefObj(theObject); objv[kObjectOrDescToCompare] = Tclae_NewConstAEDescRefObj(objectOrDescToCompare); // Execute the object comparison command // set comparison [ ] result = Tcl_EvalObjv(gInterp, kTotalArguments, objv, TCL_EVAL_GLOBAL); if (result != TCL_OK) { err = TclaeErrorCodeFromInterp(gInterp); if (err == noErr) { err = errAEEventNotHandled; } } else { int temp; result = Tcl_GetBooleanFromObj(gInterp, Tcl_GetObjResult(gInterp), &temp); *comparisonPtr = temp; if (result != TCL_OK) { err = errAEEventNotHandled; } } return err; } /* * ------------------------------------------------------------------------- * * "TclaeDisposeToken" -- * * * * Argument Default In/Out Description * ------------ ------- ------ --------------------------------------------- * * Results: * * * Side effects: * * ------------------------------------------------------------------------- */ static pascal OSErr TclaeDisposeToken(AEDesc *unneededToken) { enum { kDisposeProc = 0, kUnneededToken, kTotalArguments }; Tcl_Obj * objv[kTotalArguments]; OSErr err = noErr; int result; objv[kDisposeProc] = Tcl_GetVar2Ex(gInterp, "tclAE::_callbacks", "disposeToken", TCL_GLOBAL_ONLY); if (!objv[kDisposeProc]) { return errAEEventNotHandled; } Tcl_IncrRefCount(objv[kDisposeProc]); objv[kUnneededToken] = Tclae_NewAEDescRefObj(unneededToken); Tcl_IncrRefCount(objv[kUnneededToken]); // Execute the token disposal command // [ ] result = Tcl_EvalObjv(gInterp, kTotalArguments, objv, TCL_EVAL_GLOBAL); TclaeDetachAEDescObj(objv[kUnneededToken]); Tcl_DecrRefCount(objv[kUnneededToken]); if (result != TCL_OK) { err = TclaeErrorCodeFromInterp(gInterp); if (err == noErr) { err = errAEEventNotHandled; } } return err; } /* * ------------------------------------------------------------------------- * * "TclaeGetErrorDesc" -- * * * * Argument Default In/Out Description * ------------ ------- ------ --------------------------------------------- * * Results: * * * Side effects: * * ------------------------------------------------------------------------- */ static pascal OSErr TclaeGetErrorDesc(AEDescPtr *errDescPtr) { *errDescPtr = &gErrorDesc; return noErr; } /* * ------------------------------------------------------------------------- * * "TclaeGetMarkToken" -- * * * * Argument Default In/Out Description * ------------ ------- ------ --------------------------------------------- * * Results: * * * Side effects: * * ------------------------------------------------------------------------- */ static pascal OSErr TclaeGetMarkToken(const AEDesc *containerToken, DescType containerClass, AEDesc *resultDesc) { enum { kGetMarkTokenProc = 0, kContainerToken, kContainerClass, kResultDesc, kTotalArguments }; Tcl_Obj * objv[kTotalArguments]; OSErr err = noErr; int result; objv[kGetMarkTokenProc] = Tcl_GetVar2Ex(gInterp, "tclAE::_callbacks", "getMarkToken", TCL_GLOBAL_ONLY); if (!objv[kGetMarkTokenProc]) { return errAEEventNotHandled; } Tcl_IncrRefCount(objv[kGetMarkTokenProc]); objv[kContainerToken] = Tclae_NewConstAEDescRefObj(containerToken); objv[kContainerClass] = TclaeNewOSTypeObj(containerClass); objv[kResultDesc] = Tclae_NewAEDescRefObj(resultDesc); Tcl_IncrRefCount(objv[kResultDesc]); // Execute the get mark token command // [ ] result = Tcl_EvalObjv(gInterp, kTotalArguments, objv, TCL_EVAL_GLOBAL); TclaeDetachAEDescObj(objv[kResultDesc]); Tcl_DecrRefCount(objv[kResultDesc]); if (result != TCL_OK) { err = TclaeErrorCodeFromInterp(gInterp); if (err == noErr) { err = errAEEventNotHandled; } } return err; } /* * ------------------------------------------------------------------------- * * "TclaeMark" -- * * * * Argument Default In/Out Description * ------------ ------- ------ --------------------------------------------- * * Results: * * * Side effects: * * ------------------------------------------------------------------------- */ static pascal OSErr TclaeMark(const AEDesc *theToken, const AEDesc *markToken, long markCount) { enum { kMarkProc = 0, kTheToken, kMarkToken, kMarkCount, kTotalArguments }; Tcl_Obj * objv[kTotalArguments]; OSErr err = noErr; int result; objv[kMarkProc] = Tcl_GetVar2Ex(gInterp, "tclAE::_callbacks", "mark", TCL_GLOBAL_ONLY); if (!objv[kMarkProc]) { return errAEEventNotHandled; } Tcl_IncrRefCount(objv[kMarkProc]); objv[kTheToken] = Tclae_NewConstAEDescRefObj(theToken); objv[kMarkToken] = Tclae_NewConstAEDescRefObj(markToken); objv[kMarkCount] = Tcl_NewLongObj(markCount); // Execute the mark command // [ ] result = Tcl_EvalObjv(gInterp, kTotalArguments, objv, TCL_EVAL_GLOBAL); if (result != TCL_OK) { err = TclaeErrorCodeFromInterp(gInterp); if (err == noErr) { err = errAEEventNotHandled; } } return err; } /* * ------------------------------------------------------------------------- * * "TclaeAdjustMarks" -- * * * * Argument Default In/Out Description * ------------ ------- ------ --------------------------------------------- * * Results: * ¥ * * Side effects: * ¥ * ------------------------------------------------------------------------- */ static pascal OSErr TclaeAdjustMarks(long newStart, long newStop, const AEDesc *markToken) { enum { kAdjustMarksProc = 0, kNewStart, kNewStop, kMarkToken, kTotalArguments }; Tcl_Obj * objv[kTotalArguments]; OSErr err = noErr; int result; objv[kAdjustMarksProc] = Tcl_GetVar2Ex(gInterp, "tclAE::_callbacks", "adjustMarks", TCL_GLOBAL_ONLY); if (!objv[kAdjustMarksProc]) { return errAEEventNotHandled; } Tcl_IncrRefCount(objv[kAdjustMarksProc]); objv[kNewStart] = Tcl_NewLongObj(newStart); objv[kNewStop] = Tcl_NewLongObj(newStop); objv[kMarkToken] = Tclae_NewConstAEDescRefObj(markToken); // Execute the adjust marks command // [ ] result = Tcl_EvalObjv(gInterp, kTotalArguments, objv, TCL_EVAL_GLOBAL); if (result != TCL_OK) { err = TclaeErrorCodeFromInterp(gInterp); if (err == noErr) { err = errAEEventNotHandled; } } return err; } /* ×××× Internal routines ×××× */ /* * ------------------------------------------------------------------------- * * "TclaeGetObjectAccessor" -- * * Find specified entry in hash table for object accessors * If accessorProc is not NULL, it must match * * Results: * Tcl_HashEntry pointer (or NULL) for desired accessor * * Side effects: * None. * ------------------------------------------------------------------------- */ static Tcl_HashEntry* TclaeGetObjectAccessor(Tcl_Interp* interp, DescType desiredClass, DescType containerType, char* accessorProc) { Tcl_HashEntry *hashEntryPtr; /* for search of AEObjectAccessor */ Tcl_HashSearch search; /* hash list */ tclAEObjectAccessor *objectAccessorPtr; // Search through coercion handler hash table for this type pair for (hashEntryPtr = Tcl_FirstHashEntry(tclAEObjectAccessorHashTable, &search); hashEntryPtr != NULL; hashEntryPtr = Tcl_NextHashEntry(&search)) { objectAccessorPtr = Tcl_GetHashValue(hashEntryPtr); if ((objectAccessorPtr->desiredClass == desiredClass) && (objectAccessorPtr->containerType == containerType) && (objectAccessorPtr->interp == interp)) { if (accessorProc && (strcmp(accessorProc, Tcl_GetString(objectAccessorPtr->accessorProc)) != 0)) { // accessorProc doesn't match continue; } else { // found break; } } } return hashEntryPtr; } /* * ------------------------------------------------------------------------- * * "TclaeInitObjectAccessors" -- * * Initialize object accessors. * * Results: * None. * * Side effects: * Object accessors activated. * ------------------------------------------------------------------------- */ void TclaeInitObjectAccessors(Tcl_Interp *interp) { /* Store identifier for the global error descriptor */ Tcl_SetVar2Ex(interp, "tclAE::errorDesc", NULL, Tclae_NewAEDescRefObj(&gErrorDesc), TCL_GLOBAL_ONLY); /* Initialize the AE Handler hash table */ tclAEObjectAccessorHashTable = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); if (tclAEObjectAccessorHashTable) { Tcl_InitHashTable(tclAEObjectAccessorHashTable, TCL_ONE_WORD_KEYS); } else { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "Couldn't initialize object accessors", (char *) NULL); } } /* * ------------------------------------------------------------------------- * * "TclaeRemoveObjectAccessor" -- * * Remove entry from hash table for object accessors, and deregister * accessor with the AEM * * Results: * OS Error * * Side effects: * Specified accessor is removed * ------------------------------------------------------------------------- */ static OSErr TclaeRemoveObjectAccessor( DescType desiredClass, DescType containerType, Tcl_HashEntry * hashEntryPtr) { tclAEObjectAccessor* accessorPtr = Tcl_GetHashValue(hashEntryPtr); // Delete the object holding the accessor proc Tcl_DecrRefCount(accessorPtr->accessorProc); // Remove the coercion hash entry Tcl_DeleteHashEntry(hashEntryPtr); // Delete the coercion handler structure ckfree((char*) accessorPtr); // Deregister any accessor for this type-pair with the AEM return AERemoveObjectAccessor(desiredClass, containerType, TclaeObjectAccessorUPP, false); }