summaryrefslogtreecommitdiffstats
path: root/mac/tclMacResource.c
diff options
context:
space:
mode:
Diffstat (limited to 'mac/tclMacResource.c')
-rw-r--r--mac/tclMacResource.c2165
1 files changed, 2165 insertions, 0 deletions
diff --git a/mac/tclMacResource.c b/mac/tclMacResource.c
new file mode 100644
index 0000000..db06571
--- /dev/null
+++ b/mac/tclMacResource.c
@@ -0,0 +1,2165 @@
+/*
+ * tclMacResource.c --
+ *
+ * This file contains several commands that manipulate or use
+ * Macintosh resources. Included are extensions to the "source"
+ * command, the mac specific "beep" and "resource" commands, and
+ * administration for open resource file references.
+ *
+ * Copyright (c) 1996-1997 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclMacResource.c 1.35 97/11/24 15:03:58
+ */
+
+#include <Errors.h>
+#include <FSpCompat.h>
+#include <Processes.h>
+#include <Resources.h>
+#include <Sound.h>
+#include <Strings.h>
+#include <Traps.h>
+#include <LowMem.h>
+
+#include "FullPath.h"
+#include "tcl.h"
+#include "tclInt.h"
+#include "tclMac.h"
+#include "tclMacInt.h"
+#include "tclMacPort.h"
+
+/*
+ * This flag tells the RegisterResource function to insert the
+ * resource into the tail of the resource fork list. Needed only
+ * Resource_Init.
+ */
+
+#define TCL_RESOURCE_INSERT_TAIL 1
+/*
+ * 2 is taken by TCL_RESOURCE_DONT_CLOSE
+ * which is the only public flag to TclMacRegisterResourceFork.
+ */
+
+#define TCL_RESOURCE_CHECK_IF_OPEN 4
+
+/*
+ * Pass this in the mode parameter of SetSoundVolume to determine
+ * which volume to set.
+ */
+
+enum WhichVolume {
+ SYS_BEEP_VOLUME, /* This sets the volume for SysBeep calls */
+ DEFAULT_SND_VOLUME, /* This one for SndPlay calls */
+ RESET_VOLUME /* And this undoes the last call to SetSoundVolume */
+};
+
+/*
+ * Hash table to track open resource files.
+ */
+
+typedef struct OpenResourceFork {
+ short fileRef;
+ int flags;
+} OpenResourceFork;
+
+
+
+static Tcl_HashTable nameTable; /* Id to process number mapping. */
+static Tcl_HashTable resourceTable; /* Process number to id mapping. */
+static Tcl_Obj *resourceForkList; /* Ordered list of resource forks */
+static int appResourceIndex; /* This is the index of the application*
+ * in the list of resource forks */
+static int newId = 0; /* Id source. */
+static int initialized = 0; /* 0 means static structures haven't
+ * been initialized yet. */
+static int osTypeInit = 0; /* 0 means Tcl object of osType hasn't
+ * been initialized yet. */
+/*
+ * Prototypes for procedures defined later in this file:
+ */
+
+static void DupOSTypeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
+ Tcl_Obj *copyPtr));
+static void ResourceInit _ANSI_ARGS_((void));
+static void BuildResourceForkList _ANSI_ARGS_((void));
+static int SetOSTypeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
+static void UpdateStringOfOSType _ANSI_ARGS_((Tcl_Obj *objPtr));
+static OpenResourceFork* GetRsrcRefFromObj _ANSI_ARGS_((Tcl_Obj *objPtr,
+ int okayOnReadOnly, const char *operation,
+ Tcl_Obj *resultPtr));
+
+static void SetSoundVolume(int volume, enum WhichVolume mode);
+
+/*
+ * The structures below defines the Tcl object type defined in this file by
+ * means of procedures that can be invoked by generic object code.
+ */
+
+static Tcl_ObjType osType = {
+ "ostype", /* name */
+ (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
+ DupOSTypeInternalRep, /* dupIntRepProc */
+ UpdateStringOfOSType, /* updateStringProc */
+ SetOSTypeFromAny /* setFromAnyProc */
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ResourceObjCmd --
+ *
+ * This procedure is invoked to process the "resource" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ResourceObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument values. */
+{
+ Tcl_Obj *resultPtr, *objPtr;
+ int index, result;
+ long fileRef, rsrcId;
+ FSSpec fileSpec;
+ Tcl_DString buffer;
+ char *nativeName;
+ char *stringPtr;
+ char errbuf[16];
+ OpenResourceFork *resourceRef;
+ Handle resource = NULL;
+ OSErr err;
+ int count, i, limitSearch = false, length;
+ short id, saveRef, resInfo;
+ Str255 theName;
+ OSType rezType;
+ int gotInt, releaseIt = 0, force;
+ char *resourceId = NULL;
+ long size;
+ char macPermision;
+ int mode;
+
+ static char *switches[] = {"close", "delete" ,"files", "list",
+ "open", "read", "types", "write", (char *) NULL
+ };
+
+ enum {
+ RESOURCE_CLOSE, RESOURCE_DELETE, RESOURCE_FILES, RESOURCE_LIST,
+ RESOURCE_OPEN, RESOURCE_READ, RESOURCE_TYPES, RESOURCE_WRITE
+ };
+
+ static char *writeSwitches[] = {
+ "-id", "-name", "-file", "-force", (char *) NULL
+ };
+
+ enum {
+ RESOURCE_WRITE_ID, RESOURCE_WRITE_NAME,
+ RESOURCE_WRITE_FILE, RESOURCE_FORCE
+ };
+
+ static char *deleteSwitches[] = {"-id", "-name", "-file", (char *) NULL};
+
+ enum {RESOURCE_DELETE_ID, RESOURCE_DELETE_NAME, RESOURCE_DELETE_FILE};
+
+ resultPtr = Tcl_GetObjResult(interp);
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetIndexFromObj(interp, objv[1], switches, "option", 0, &index)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (!initialized) {
+ ResourceInit();
+ }
+ result = TCL_OK;
+
+ switch (index) {
+ case RESOURCE_CLOSE:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "resourceRef");
+ return TCL_ERROR;
+ }
+ stringPtr = Tcl_GetStringFromObj(objv[2], &length);
+ fileRef = TclMacUnRegisterResourceFork(stringPtr, resultPtr);
+
+ if (fileRef >= 0) {
+ CloseResFile((short) fileRef);
+ return TCL_OK;
+ } else {
+ return TCL_ERROR;
+ }
+ case RESOURCE_DELETE:
+ if (!((objc >= 3) && (objc <= 9) && ((objc % 2) == 1))) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-id resourceId? ?-name resourceName? ?-file \
+resourceRef? resourceType");
+ return TCL_ERROR;
+ }
+
+ i = 2;
+ fileRef = -1;
+ gotInt = false;
+ resourceId = NULL;
+ limitSearch = false;
+
+ while (i < (objc - 2)) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], deleteSwitches,
+ "option", 0, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch (index) {
+ case RESOURCE_DELETE_ID:
+ if (Tcl_GetLongFromObj(interp, objv[i+1], &rsrcId)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ gotInt = true;
+ break;
+ case RESOURCE_DELETE_NAME:
+ resourceId = Tcl_GetStringFromObj(objv[i+1], &length);
+ if (length > 255) {
+ Tcl_AppendStringsToObj(resultPtr,"-name argument ",
+ "too long, must be < 255 characters",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ strcpy((char *) theName, resourceId);
+ resourceId = (char *) theName;
+ c2pstr(resourceId);
+ break;
+ case RESOURCE_DELETE_FILE:
+ resourceRef = GetRsrcRefFromObj(objv[i+1], 0,
+ "delete from", resultPtr);
+ if (resourceRef == NULL) {
+ return TCL_ERROR;
+ }
+ limitSearch = true;
+ break;
+ }
+ i += 2;
+ }
+
+ if ((resourceId == NULL) && !gotInt) {
+ Tcl_AppendStringsToObj(resultPtr,"you must specify either ",
+ "\"-id\" or \"-name\" or both ",
+ "to \"resource delete\"",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetOSTypeFromObj(interp, objv[i], &rezType) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (limitSearch) {
+ saveRef = CurResFile();
+ UseResFile((short) resourceRef->fileRef);
+ }
+
+ SetResLoad(false);
+
+ if (gotInt == true) {
+ if (limitSearch) {
+ resource = Get1Resource(rezType, rsrcId);
+ } else {
+ resource = GetResource(rezType, rsrcId);
+ }
+ err = ResError();
+
+ if (err == resNotFound || resource == NULL) {
+ Tcl_AppendStringsToObj(resultPtr, "resource not found",
+ (char *) NULL);
+ result = TCL_ERROR;
+ goto deleteDone;
+ } else if (err != noErr) {
+ char buffer[16];
+
+ sprintf(buffer, "%12d", err);
+ Tcl_AppendStringsToObj(resultPtr, "resource error #",
+ buffer, "occured while trying to find resource",
+ (char *) NULL);
+ result = TCL_ERROR;
+ goto deleteDone;
+ }
+ }
+
+ if (resourceId != NULL) {
+ Handle tmpResource;
+ if (limitSearch) {
+ tmpResource = Get1NamedResource(rezType,
+ (StringPtr) resourceId);
+ } else {
+ tmpResource = GetNamedResource(rezType,
+ (StringPtr) resourceId);
+ }
+ err = ResError();
+
+ if (err == resNotFound || tmpResource == NULL) {
+ Tcl_AppendStringsToObj(resultPtr, "resource not found",
+ (char *) NULL);
+ result = TCL_ERROR;
+ goto deleteDone;
+ } else if (err != noErr) {
+ char buffer[16];
+
+ sprintf(buffer, "%12d", err);
+ Tcl_AppendStringsToObj(resultPtr, "resource error #",
+ buffer, "occured while trying to find resource",
+ (char *) NULL);
+ result = TCL_ERROR;
+ goto deleteDone;
+ }
+
+ if (gotInt) {
+ if (resource != tmpResource) {
+ Tcl_AppendStringsToObj(resultPtr,
+ "\"-id\" and \"-name\" ",
+ "values do not point to the same resource",
+ (char *) NULL);
+ result = TCL_ERROR;
+ goto deleteDone;
+ }
+ } else {
+ resource = tmpResource;
+ }
+ }
+
+ resInfo = GetResAttrs(resource);
+
+ if ((resInfo & resProtected) == resProtected) {
+ Tcl_AppendStringsToObj(resultPtr, "resource ",
+ "cannot be deleted: it is protected.",
+ (char *) NULL);
+ result = TCL_ERROR;
+ goto deleteDone;
+ } else if ((resInfo & resSysHeap) == resSysHeap) {
+ Tcl_AppendStringsToObj(resultPtr, "resource",
+ "cannot be deleted: it is in the system heap.",
+ (char *) NULL);
+ result = TCL_ERROR;
+ goto deleteDone;
+ }
+
+ /*
+ * Find the resource file, if it was not specified,
+ * so we can flush the changes now. Perhaps this is
+ * a little paranoid, but better safe than sorry.
+ */
+
+ RemoveResource(resource);
+
+ if (!limitSearch) {
+ UpdateResFile(HomeResFile(resource));
+ } else {
+ UpdateResFile(resourceRef->fileRef);
+ }
+
+
+ deleteDone:
+
+ SetResLoad(true);
+ if (limitSearch) {
+ UseResFile(saveRef);
+ }
+ return result;
+
+ case RESOURCE_FILES:
+ if ((objc < 2) || (objc > 3)) {
+ Tcl_SetStringObj(resultPtr,
+ "wrong # args: should be \"resource files \
+?resourceId?\"", -1);
+ return TCL_ERROR;
+ }
+
+ if (objc == 2) {
+ stringPtr = Tcl_GetStringFromObj(resourceForkList, &length);
+ Tcl_SetStringObj(resultPtr, stringPtr, length);
+ } else {
+ FCBPBRec fileRec;
+ Handle pathHandle;
+ short pathLength;
+ Str255 fileName;
+
+ if (strcmp(Tcl_GetStringFromObj(objv[2], NULL), "ROM Map")
+ == 0) {
+ Tcl_SetStringObj(resultPtr,"no file path for ROM Map", -1);
+ return TCL_ERROR;
+ }
+
+ resourceRef = GetRsrcRefFromObj(objv[2], 1, "files", resultPtr);
+ if (resourceRef == NULL) {
+ return TCL_ERROR;
+ }
+
+ fileRec.ioCompletion = NULL;
+ fileRec.ioFCBIndx = 0;
+ fileRec.ioNamePtr = fileName;
+ fileRec.ioVRefNum = 0;
+ fileRec.ioRefNum = resourceRef->fileRef;
+ err = PBGetFCBInfo(&fileRec, false);
+ if (err != noErr) {
+ Tcl_SetStringObj(resultPtr,
+ "could not get FCB for resource file", -1);
+ return TCL_ERROR;
+ }
+
+ err = GetFullPath(fileRec.ioFCBVRefNum, fileRec.ioFCBParID,
+ fileRec.ioNamePtr, &pathLength, &pathHandle);
+ if ( err != noErr) {
+ Tcl_SetStringObj(resultPtr,
+ "could not get file path from token", -1);
+ return TCL_ERROR;
+ }
+
+ HLock(pathHandle);
+ Tcl_SetStringObj(resultPtr,*pathHandle,pathLength);
+ HUnlock(pathHandle);
+ DisposeHandle(pathHandle);
+ }
+ return TCL_OK;
+ case RESOURCE_LIST:
+ if (!((objc == 3) || (objc == 4))) {
+ Tcl_WrongNumArgs(interp, 2, objv, "resourceType ?resourceRef?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetOSTypeFromObj(interp, objv[2], &rezType) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (objc == 4) {
+ resourceRef = GetRsrcRefFromObj(objv[3], 1,
+ "list", resultPtr);
+ if (resourceRef == NULL) {
+ return TCL_ERROR;
+ }
+
+ saveRef = CurResFile();
+ UseResFile((short) resourceRef->fileRef);
+ limitSearch = true;
+ }
+
+ Tcl_ResetResult(interp);
+ if (limitSearch) {
+ count = Count1Resources(rezType);
+ } else {
+ count = CountResources(rezType);
+ }
+ SetResLoad(false);
+ for (i = 1; i <= count; i++) {
+ if (limitSearch) {
+ resource = Get1IndResource(rezType, i);
+ } else {
+ resource = GetIndResource(rezType, i);
+ }
+ if (resource != NULL) {
+ GetResInfo(resource, &id, (ResType *) &rezType, theName);
+ if (theName[0] != 0) {
+ objPtr = Tcl_NewStringObj((char *) theName + 1,
+ theName[0]);
+ } else {
+ objPtr = Tcl_NewIntObj(id);
+ }
+ ReleaseResource(resource);
+ result = Tcl_ListObjAppendElement(interp, resultPtr,
+ objPtr);
+ if (result != TCL_OK) {
+ Tcl_DecrRefCount(objPtr);
+ break;
+ }
+ }
+ }
+ SetResLoad(true);
+
+ if (limitSearch) {
+ UseResFile(saveRef);
+ }
+
+ return TCL_OK;
+ case RESOURCE_OPEN:
+ if (!((objc == 3) || (objc == 4))) {
+ Tcl_WrongNumArgs(interp, 2, objv, "fileName ?permissions?");
+ return TCL_ERROR;
+ }
+ stringPtr = Tcl_GetStringFromObj(objv[2], &length);
+ nativeName = Tcl_TranslateFileName(interp, stringPtr, &buffer);
+ if (nativeName == NULL) {
+ return TCL_ERROR;
+ }
+ err = FSpLocationFromPath(strlen(nativeName), nativeName,
+ &fileSpec) ;
+ Tcl_DStringFree(&buffer);
+ if (!((err == noErr) || (err == fnfErr))) {
+ Tcl_AppendStringsToObj(resultPtr,
+ "invalid path", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get permissions for the file. We really only understand
+ * read-only and shared-read-write. If no permissions are
+ * given we default to read only.
+ */
+
+ if (objc == 4) {
+ stringPtr = Tcl_GetStringFromObj(objv[3], &length);
+ mode = TclGetOpenMode(interp, stringPtr, &index);
+ if (mode == -1) {
+ /* TODO: TclGetOpenMode doesn't work with Obj commands. */
+ return TCL_ERROR;
+ }
+ switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
+ case O_RDONLY:
+ macPermision = fsRdPerm;
+ break;
+ case O_WRONLY:
+ case O_RDWR:
+ macPermision = fsRdWrShPerm;
+ break;
+ default:
+ panic("Tcl_ResourceObjCmd: invalid mode value");
+ break;
+ }
+ } else {
+ macPermision = fsRdPerm;
+ }
+
+ /*
+ * Don't load in any of the resources in the file, this could
+ * cause problems if you open a file that has CODE resources...
+ */
+
+ SetResLoad(false);
+ fileRef = (long) FSpOpenResFileCompat(&fileSpec, macPermision);
+ SetResLoad(true);
+
+ if (fileRef == -1) {
+ err = ResError();
+ if (((err == fnfErr) || (err == eofErr)) &&
+ (macPermision == fsRdWrShPerm)) {
+ /*
+ * No resource fork existed for this file. Since we are
+ * opening it for writing we will create the resource fork
+ * now.
+ */
+
+ HCreateResFile(fileSpec.vRefNum, fileSpec.parID,
+ fileSpec.name);
+ fileRef = (long) FSpOpenResFileCompat(&fileSpec,
+ macPermision);
+ if (fileRef == -1) {
+ goto openError;
+ }
+ } else if (err == fnfErr) {
+ Tcl_AppendStringsToObj(resultPtr,
+ "file does not exist", (char *) NULL);
+ return TCL_ERROR;
+ } else if (err == eofErr) {
+ Tcl_AppendStringsToObj(resultPtr,
+ "file does not contain resource fork", (char *) NULL);
+ return TCL_ERROR;
+ } else {
+ openError:
+ Tcl_AppendStringsToObj(resultPtr,
+ "error opening resource file", (char *) NULL);
+ return TCL_ERROR;
+ }
+ }
+
+ /*
+ * The FspOpenResFile function does not set the ResFileAttrs.
+ * Even if you open the file read only, the mapReadOnly
+ * attribute is not set. This means we can't detect writes to a
+ * read only resource fork until the write fails, which is bogus.
+ * So set it here...
+ */
+
+ if (macPermision == fsRdPerm) {
+ SetResFileAttrs(fileRef, mapReadOnly);
+ }
+
+ Tcl_SetStringObj(resultPtr, "", 0);
+ if (TclMacRegisterResourceFork(fileRef, resultPtr,
+ TCL_RESOURCE_CHECK_IF_OPEN) != TCL_OK) {
+ CloseResFile(fileRef);
+ return TCL_ERROR;
+ }
+
+ return TCL_OK;
+ case RESOURCE_READ:
+ if (!((objc == 4) || (objc == 5))) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "resourceType resourceId ?resourceRef?");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetOSTypeFromObj(interp, objv[2], &rezType) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetLongFromObj((Tcl_Interp *) NULL, objv[3], &rsrcId)
+ != TCL_OK) {
+ resourceId = Tcl_GetStringFromObj(objv[3], &length);
+ }
+
+ if (objc == 5) {
+ stringPtr = Tcl_GetStringFromObj(objv[4], &length);
+ } else {
+ stringPtr = NULL;
+ }
+
+ resource = Tcl_MacFindResource(interp, rezType, resourceId,
+ rsrcId, stringPtr, &releaseIt);
+
+ if (resource != NULL) {
+ size = GetResourceSizeOnDisk(resource);
+ Tcl_SetStringObj(resultPtr, *resource, size);
+
+ /*
+ * Don't release the resource unless WE loaded it...
+ */
+
+ if (releaseIt) {
+ ReleaseResource(resource);
+ }
+ return TCL_OK;
+ } else {
+ Tcl_AppendStringsToObj(resultPtr, "could not load resource",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+ case RESOURCE_TYPES:
+ if (!((objc == 2) || (objc == 3))) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?resourceRef?");
+ return TCL_ERROR;
+ }
+
+ if (objc == 3) {
+ resourceRef = GetRsrcRefFromObj(objv[2], 1,
+ "get types of", resultPtr);
+ if (resourceRef == NULL) {
+ return TCL_ERROR;
+ }
+
+ saveRef = CurResFile();
+ UseResFile((short) resourceRef->fileRef);
+ limitSearch = true;
+ }
+
+ if (limitSearch) {
+ count = Count1Types();
+ } else {
+ count = CountTypes();
+ }
+ for (i = 1; i <= count; i++) {
+ if (limitSearch) {
+ Get1IndType((ResType *) &rezType, i);
+ } else {
+ GetIndType((ResType *) &rezType, i);
+ }
+ objPtr = Tcl_NewOSTypeObj(rezType);
+ result = Tcl_ListObjAppendElement(interp, resultPtr, objPtr);
+ if (result != TCL_OK) {
+ Tcl_DecrRefCount(objPtr);
+ break;
+ }
+ }
+
+ if (limitSearch) {
+ UseResFile(saveRef);
+ }
+
+ return result;
+ case RESOURCE_WRITE:
+ if ((objc < 4) || (objc > 11)) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-id resourceId? ?-name resourceName? ?-file resourceRef?\
+ ?-force? resourceType data");
+ return TCL_ERROR;
+ }
+
+ i = 2;
+ gotInt = false;
+ resourceId = NULL;
+ limitSearch = false;
+ force = 0;
+
+ while (i < (objc - 2)) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], writeSwitches,
+ "switch", 0, &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch (index) {
+ case RESOURCE_WRITE_ID:
+ if (Tcl_GetLongFromObj(interp, objv[i+1], &rsrcId)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ gotInt = true;
+ i += 2;
+ break;
+ case RESOURCE_WRITE_NAME:
+ resourceId = Tcl_GetStringFromObj(objv[i+1], &length);
+ strcpy((char *) theName, resourceId);
+ resourceId = (char *) theName;
+ c2pstr(resourceId);
+ i += 2;
+ break;
+ case RESOURCE_WRITE_FILE:
+ resourceRef = GetRsrcRefFromObj(objv[i+1], 0,
+ "write to", resultPtr);
+ if (resourceRef == NULL) {
+ return TCL_ERROR;
+ }
+ limitSearch = true;
+ i += 2;
+ break;
+ case RESOURCE_FORCE:
+ force = 1;
+ i += 1;
+ break;
+ }
+ }
+ if (Tcl_GetOSTypeFromObj(interp, objv[i], &rezType) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ stringPtr = Tcl_GetStringFromObj(objv[i+1], &length);
+
+ if (gotInt == false) {
+ rsrcId = UniqueID(rezType);
+ }
+ if (resourceId == NULL) {
+ resourceId = (char *) "\p";
+ }
+ if (limitSearch) {
+ saveRef = CurResFile();
+ UseResFile((short) resourceRef->fileRef);
+ }
+
+ /*
+ * If we are adding the resource by number, then we must make sure
+ * there is not already a resource of that number. We are not going
+ * load it here, since we want to detect whether we loaded it or
+ * not. Remember that releasing some resources in particular menu
+ * related ones, can be fatal.
+ */
+
+ if (gotInt == true) {
+ SetResLoad(false);
+ resource = Get1Resource(rezType,rsrcId);
+ SetResLoad(true);
+ }
+
+ if (resource == NULL) {
+ /*
+ * We get into this branch either if there was not already a
+ * resource of this type & id, or the id was not specified.
+ */
+
+ resource = NewHandle(length);
+ if (resource == NULL) {
+ resource = NewHandleSys(length);
+ if (resource == NULL) {
+ panic("could not allocate memory to write resource");
+ }
+ }
+ HLock(resource);
+ memcpy(*resource, stringPtr, length);
+ HUnlock(resource);
+ AddResource(resource, rezType, (short) rsrcId,
+ (StringPtr) resourceId);
+ releaseIt = 1;
+ } else {
+ /*
+ * We got here because there was a resource of this type
+ * & ID in the file.
+ */
+
+ if (*resource == NULL) {
+ releaseIt = 1;
+ } else {
+ releaseIt = 0;
+ }
+
+ if (!force) {
+ /*
+ *We only overwrite extant resources
+ * when the -force flag has been set.
+ */
+
+ sprintf(errbuf,"%d", rsrcId);
+
+ Tcl_AppendStringsToObj(resultPtr, "the resource ",
+ errbuf, " already exists, use \"-force\"",
+ " to overwrite it.", (char *) NULL);
+
+ result = TCL_ERROR;
+ goto writeDone;
+ } else if (GetResAttrs(resource) & resProtected) {
+ /*
+ *
+ * Next, check to see if it is protected...
+ */
+
+ sprintf(errbuf,"%d", rsrcId);
+ Tcl_AppendStringsToObj(resultPtr,
+ "could not write resource id ",
+ errbuf, " of type ",
+ Tcl_GetStringFromObj(objv[i],&length),
+ ", it was protected.",(char *) NULL);
+ result = TCL_ERROR;
+ goto writeDone;
+ } else {
+ /*
+ * Be careful, the resource might already be in memory
+ * if something else loaded it.
+ */
+
+ if (*resource == 0) {
+ LoadResource(resource);
+ err = ResError();
+ if (err != noErr) {
+ sprintf(errbuf,"%d", rsrcId);
+ Tcl_AppendStringsToObj(resultPtr,
+ "error loading resource ",
+ errbuf, " of type ",
+ Tcl_GetStringFromObj(objv[i],&length),
+ " to overwrite it", (char *) NULL);
+ goto writeDone;
+ }
+ }
+
+ SetHandleSize(resource, length);
+ if ( MemError() != noErr ) {
+ panic("could not allocate memory to write resource");
+ }
+
+ HLock(resource);
+ memcpy(*resource, stringPtr, length);
+ HUnlock(resource);
+
+ ChangedResource(resource);
+
+ /*
+ * We also may have changed the name...
+ */
+
+ SetResInfo(resource, rsrcId, (StringPtr) resourceId);
+ }
+ }
+
+ err = ResError();
+ if (err != noErr) {
+ Tcl_AppendStringsToObj(resultPtr,
+ "error adding resource to resource map",
+ (char *) NULL);
+ result = TCL_ERROR;
+ goto writeDone;
+ }
+
+ WriteResource(resource);
+ err = ResError();
+ if (err != noErr) {
+ Tcl_AppendStringsToObj(resultPtr,
+ "error writing resource to disk",
+ (char *) NULL);
+ result = TCL_ERROR;
+ }
+
+ writeDone:
+
+ if (releaseIt) {
+ ReleaseResource(resource);
+ err = ResError();
+ if (err != noErr) {
+ Tcl_AppendStringsToObj(resultPtr,
+ "error releasing resource",
+ (char *) NULL);
+ result = TCL_ERROR;
+ }
+ }
+
+ if (limitSearch) {
+ UseResFile(saveRef);
+ }
+
+ return result;
+ default:
+ panic("Tcl_GetIndexFromObject returned unrecognized option");
+ return TCL_ERROR; /* Should never be reached. */
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_MacSourceObjCmd --
+ *
+ * This procedure is invoked to process the "source" Tcl command.
+ * See the user documentation for details on what it does. In
+ * addition, it supports sourceing from the resource fork of
+ * type 'TEXT'.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_MacSourceObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
+{
+ char *errNum = "wrong # args: ";
+ char *errBad = "bad argument: ";
+ char *errStr;
+ char *fileName = NULL, *rsrcName = NULL;
+ long rsrcID = -1;
+ char *string;
+ int length;
+
+ if (objc < 2 || objc > 4) {
+ errStr = errNum;
+ goto sourceFmtErr;
+ }
+
+ if (objc == 2) {
+ string = TclGetStringFromObj(objv[1], &length);
+ return Tcl_EvalFile(interp, string);
+ }
+
+ /*
+ * The following code supports a few older forms of this command
+ * for backward compatability.
+ */
+ string = TclGetStringFromObj(objv[1], &length);
+ if (!strcmp(string, "-rsrc") || !strcmp(string, "-rsrcname")) {
+ rsrcName = TclGetStringFromObj(objv[2], &length);
+ } else if (!strcmp(string, "-rsrcid")) {
+ if (Tcl_GetLongFromObj(interp, objv[2], &rsrcID) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ } else {
+ errStr = errBad;
+ goto sourceFmtErr;
+ }
+
+ if (objc == 4) {
+ fileName = TclGetStringFromObj(objv[3], &length);
+ }
+ return Tcl_MacEvalResource(interp, rsrcName, rsrcID, fileName);
+
+ sourceFmtErr:
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), errStr, "should be \"",
+ Tcl_GetStringFromObj(objv[0], (int *) NULL),
+ " fileName\" or \"",
+ Tcl_GetStringFromObj(objv[0], (int *) NULL),
+ " -rsrc name ?fileName?\" or \"",
+ Tcl_GetStringFromObj(objv[0], (int *) NULL),
+ " -rsrcid id ?fileName?\"", (char *) NULL);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_BeepObjCmd --
+ *
+ * This procedure makes the beep sound.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Makes a beep.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_BeepObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument values. */
+{
+ Tcl_Obj *resultPtr, *objPtr;
+ Handle sound;
+ Str255 sndName;
+ int volume = -1, length;
+ char * sndArg = NULL;
+
+ resultPtr = Tcl_GetObjResult(interp);
+ if (objc == 1) {
+ SysBeep(1);
+ return TCL_OK;
+ } else if (objc == 2) {
+ if (!strcmp(Tcl_GetStringFromObj(objv[1], &length), "-list")) {
+ int count, i;
+ short id;
+ Str255 theName;
+ ResType rezType;
+
+ count = CountResources('snd ');
+ for (i = 1; i <= count; i++) {
+ sound = GetIndResource('snd ', i);
+ if (sound != NULL) {
+ GetResInfo(sound, &id, &rezType, theName);
+ if (theName[0] == 0) {
+ continue;
+ }
+ objPtr = Tcl_NewStringObj((char *) theName + 1,
+ theName[0]);
+ Tcl_ListObjAppendElement(interp, resultPtr, objPtr);
+ }
+ }
+ return TCL_OK;
+ } else {
+ sndArg = Tcl_GetStringFromObj(objv[1], &length);
+ }
+ } else if (objc == 3) {
+ if (!strcmp(Tcl_GetStringFromObj(objv[1], &length), "-volume")) {
+ Tcl_GetIntFromObj(interp, objv[2], &volume);
+ } else {
+ goto beepUsage;
+ }
+ } else if (objc == 4) {
+ if (!strcmp(Tcl_GetStringFromObj(objv[1], &length), "-volume")) {
+ Tcl_GetIntFromObj(interp, objv[2], &volume);
+ sndArg = Tcl_GetStringFromObj(objv[3], &length);
+ } else {
+ goto beepUsage;
+ }
+ } else {
+ goto beepUsage;
+ }
+
+ /*
+ * Play the sound
+ */
+ if (sndArg == NULL) {
+ /*
+ * Set Volume for SysBeep
+ */
+
+ if (volume >= 0) {
+ SetSoundVolume(volume, SYS_BEEP_VOLUME);
+ }
+ SysBeep(1);
+
+ /*
+ * Reset Volume
+ */
+
+ if (volume >= 0) {
+ SetSoundVolume(0, RESET_VOLUME);
+ }
+ } else {
+ strcpy((char *) sndName + 1, sndArg);
+ sndName[0] = length;
+ sound = GetNamedResource('snd ', sndName);
+ if (sound != NULL) {
+ /*
+ * Set Volume for Default Output device
+ */
+
+ if (volume >= 0) {
+ SetSoundVolume(volume, DEFAULT_SND_VOLUME);
+ }
+
+ SndPlay(NULL, (SndListHandle) sound, false);
+
+ /*
+ * Reset Volume
+ */
+
+ if (volume >= 0) {
+ SetSoundVolume(0, RESET_VOLUME);
+ }
+ } else {
+ Tcl_AppendStringsToObj(resultPtr, " \"", sndArg,
+ "\" is not a valid sound. (Try ",
+ Tcl_GetStringFromObj(objv[0], (int *) NULL),
+ " -list)", NULL);
+ return TCL_ERROR;
+ }
+ }
+
+ return TCL_OK;
+
+ beepUsage:
+ Tcl_WrongNumArgs(interp, 1, objv, "[-volume num] [-list | sndName]?");
+ return TCL_ERROR;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * SetSoundVolume --
+ *
+ * Set the volume for either the SysBeep or the SndPlay call depending
+ * on the value of mode (SYS_BEEP_VOLUME or DEFAULT_SND_VOLUME
+ * respectively.
+ *
+ * It also stores the last channel set, and the old value of its
+ * VOLUME. If you call SetSoundVolume with a mode of RESET_VOLUME,
+ * it will undo the last setting. The volume parameter is
+ * ignored in this case.
+ *
+ * Side Effects:
+ * Sets the System Volume
+ *
+ * Results:
+ * None
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+void
+SetSoundVolume(
+ int volume, /* This is the new volume */
+ enum WhichVolume mode) /* This flag says which volume to
+ * set: SysBeep, SndPlay, or instructs us
+ * to reset the volume */
+{
+ static int hasSM3 = -1;
+ static enum WhichVolume oldMode;
+ static long oldVolume = -1;
+
+ /*
+ * The volume setting calls only work if we have SoundManager
+ * 3.0 or higher. So we check that here.
+ */
+
+ if (hasSM3 == -1) {
+ if (GetToolboxTrapAddress(_SoundDispatch)
+ != GetToolboxTrapAddress(_Unimplemented)) {
+ NumVersion SMVers = SndSoundManagerVersion();
+ if (SMVers.majorRev > 2) {
+ hasSM3 = 1;
+ } else {
+ hasSM3 = 0;
+ }
+ } else {
+ /*
+ * If the SoundDispatch trap is not present, then
+ * we don't have the SoundManager at all.
+ */
+
+ hasSM3 = 0;
+ }
+ }
+
+ /*
+ * If we don't have Sound Manager 3.0, we can't set the sound volume.
+ * We will just ignore the request rather than raising an error.
+ */
+
+ if (!hasSM3) {
+ return;
+ }
+
+ switch (mode) {
+ case SYS_BEEP_VOLUME:
+ GetSysBeepVolume(&oldVolume);
+ SetSysBeepVolume(volume);
+ oldMode = SYS_BEEP_VOLUME;
+ break;
+ case DEFAULT_SND_VOLUME:
+ GetDefaultOutputVolume(&oldVolume);
+ SetDefaultOutputVolume(volume);
+ oldMode = DEFAULT_SND_VOLUME;
+ break;
+ case RESET_VOLUME:
+ /*
+ * If oldVolume is -1 someone has made a programming error
+ * and called reset before setting the volume. This is benign
+ * however, so we will just exit.
+ */
+
+ if (oldVolume != -1) {
+ if (oldMode == SYS_BEEP_VOLUME) {
+ SetSysBeepVolume(oldVolume);
+ } else if (oldMode == DEFAULT_SND_VOLUME) {
+ SetDefaultOutputVolume(oldVolume);
+ }
+ }
+ oldVolume = -1;
+ }
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * Tcl_MacEvalResource --
+ *
+ * Used to extend the source command. Sources Tcl code from a Text
+ * resource. Currently only sources the resouce by name file ID may be
+ * supported at a later date.
+ *
+ * Side Effects:
+ * Depends on the Tcl code in the resource.
+ *
+ * Results:
+ * Returns a Tcl result.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+int
+Tcl_MacEvalResource(
+ Tcl_Interp *interp, /* Interpreter in which to process file. */
+ char *resourceName, /* Name of TEXT resource to source,
+ NULL if number should be used. */
+ int resourceNumber, /* Resource id of source. */
+ char *fileName) /* Name of file to process.
+ NULL if application resource. */
+{
+ Handle sourceText;
+ Str255 rezName;
+ char msg[200];
+ int result;
+ short saveRef, fileRef = -1;
+ char idStr[64];
+ FSSpec fileSpec;
+ Tcl_DString buffer;
+ char *nativeName;
+
+ saveRef = CurResFile();
+
+ if (fileName != NULL) {
+ OSErr err;
+
+ nativeName = Tcl_TranslateFileName(interp, fileName, &buffer);
+ if (nativeName == NULL) {
+ return TCL_ERROR;
+ }
+ err = FSpLocationFromPath(strlen(nativeName), nativeName, &fileSpec);
+ Tcl_DStringFree(&buffer);
+ if (err != noErr) {
+ Tcl_AppendResult(interp, "Error finding the file: \"",
+ fileName, "\".", NULL);
+ return TCL_ERROR;
+ }
+
+ fileRef = FSpOpenResFileCompat(&fileSpec, fsRdPerm);
+ if (fileRef == -1) {
+ Tcl_AppendResult(interp, "Error reading the file: \"",
+ fileName, "\".", NULL);
+ return TCL_ERROR;
+ }
+
+ UseResFile(fileRef);
+ } else {
+ /*
+ * The default behavior will search through all open resource files.
+ * This may not be the behavior you desire. If you want the behavior
+ * of this call to *only* search the application resource fork, you
+ * must call UseResFile at this point to set it to the application
+ * file. This means you must have already obtained the application's
+ * fileRef when the application started up.
+ */
+ }
+
+ /*
+ * Load the resource by name or ID
+ */
+ if (resourceName != NULL) {
+ strcpy((char *) rezName + 1, resourceName);
+ rezName[0] = strlen(resourceName);
+ sourceText = GetNamedResource('TEXT', rezName);
+ } else {
+ sourceText = GetResource('TEXT', (short) resourceNumber);
+ }
+
+ if (sourceText == NULL) {
+ result = TCL_ERROR;
+ } else {
+ char *sourceStr = NULL;
+
+ HLock(sourceText);
+ sourceStr = Tcl_MacConvertTextResource(sourceText);
+ HUnlock(sourceText);
+ ReleaseResource(sourceText);
+
+ /*
+ * We now evaluate the Tcl source
+ */
+ result = Tcl_Eval(interp, sourceStr);
+ ckfree(sourceStr);
+ if (result == TCL_RETURN) {
+ result = TCL_OK;
+ } else if (result == TCL_ERROR) {
+ sprintf(msg, "\n (rsrc \"%.150s\" line %d)", resourceName,
+ interp->errorLine);
+ Tcl_AddErrorInfo(interp, msg);
+ }
+
+ 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;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * Tcl_MacConvertTextResource --
+ *
+ * Converts a TEXT resource into a Tcl suitable string.
+ *
+ * Side Effects:
+ * Mallocs the returned memory, converts '\r' to '\n', and appends a NULL.
+ *
+ * Results:
+ * A new malloced string.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+char *
+Tcl_MacConvertTextResource(
+ Handle resource) /* Handle to TEXT resource. */
+{
+ int i, size;
+ char *resultStr;
+
+ size = GetResourceSizeOnDisk(resource);
+
+ resultStr = ckalloc(size + 1);
+
+ for (i=0; i<size; i++) {
+ if ((*resource)[i] == '\r') {
+ resultStr[i] = '\n';
+ } else {
+ resultStr[i] = (*resource)[i];
+ }
+ }
+
+ resultStr[size] = '\0';
+
+ return resultStr;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * Tcl_MacFindResource --
+ *
+ * Higher level interface for loading resources.
+ *
+ * Side Effects:
+ * Attempts to load a resource.
+ *
+ * Results:
+ * A handle on success.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+Handle
+Tcl_MacFindResource(
+ Tcl_Interp *interp, /* Interpreter in which to process file. */
+ long resourceType, /* Type of resource to load. */
+ char *resourceName, /* Name of resource to find,
+ * NULL if number should be used. */
+ int resourceNumber, /* Resource id of source. */
+ char *resFileRef, /* Registered resource file reference,
+ * NULL if searching all open resource files. */
+ int *releaseIt) /* Should we release this resource when done. */
+{
+ Tcl_HashEntry *nameHashPtr;
+ OpenResourceFork *resourceRef;
+ int limitSearch = false;
+ short saveRef;
+ Handle resource;
+
+ if (resFileRef != NULL) {
+ nameHashPtr = Tcl_FindHashEntry(&nameTable, resFileRef);
+ if (nameHashPtr == NULL) {
+ Tcl_AppendResult(interp, "invalid resource file reference \"",
+ resFileRef, "\"", (char *) NULL);
+ return NULL;
+ }
+ resourceRef = (OpenResourceFork *) Tcl_GetHashValue(nameHashPtr);
+ saveRef = CurResFile();
+ UseResFile((short) resourceRef->fileRef);
+ limitSearch = true;
+ }
+
+ /*
+ * Some system resources (for example system resources) should not
+ * be released. So we set autoload to false, and try to get the resource.
+ * If the Master Pointer of the returned handle is null, then resource was
+ * not in memory, and it is safe to release it. Otherwise, it is not.
+ */
+
+ SetResLoad(false);
+
+ if (resourceName == NULL) {
+ if (limitSearch) {
+ resource = Get1Resource(resourceType, resourceNumber);
+ } else {
+ resource = GetResource(resourceType, resourceNumber);
+ }
+ } else {
+ c2pstr(resourceName);
+ if (limitSearch) {
+ resource = Get1NamedResource(resourceType,
+ (StringPtr) resourceName);
+ } else {
+ resource = GetNamedResource(resourceType,
+ (StringPtr) resourceName);
+ }
+ p2cstr((StringPtr) resourceName);
+ }
+
+ if (*resource == NULL) {
+ *releaseIt = 1;
+ LoadResource(resource);
+ } else {
+ *releaseIt = 0;
+ }
+
+ SetResLoad(true);
+
+
+ if (limitSearch) {
+ UseResFile(saveRef);
+ }
+
+ return resource;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ResourceInit --
+ *
+ * Initialize the structures used for resource management.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Read the code.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ResourceInit()
+{
+
+ initialized = 1;
+ Tcl_InitHashTable(&nameTable, TCL_STRING_KEYS);
+ Tcl_InitHashTable(&resourceTable, TCL_ONE_WORD_KEYS);
+ resourceForkList = Tcl_NewObj();
+ Tcl_IncrRefCount(resourceForkList);
+
+ BuildResourceForkList();
+
+}
+/***/
+
+/*Tcl_RegisterObjType(typePtr) */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_NewOSTypeObj --
+ *
+ * This procedure is used to create a new resource name type object.
+ *
+ * Results:
+ * The newly created object is returned. This object will have a NULL
+ * string representation. The returned object has ref count 0.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+Tcl_NewOSTypeObj(
+ OSType newOSType) /* Int used to initialize the new object. */
+{
+ register Tcl_Obj *objPtr;
+
+ if (!osTypeInit) {
+ osTypeInit = 1;
+ Tcl_RegisterObjType(&osType);
+ }
+
+ objPtr = Tcl_NewObj();
+ objPtr->bytes = NULL;
+ objPtr->internalRep.longValue = newOSType;
+ objPtr->typePtr = &osType;
+ return objPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_SetOSTypeObj --
+ *
+ * Modify an object to be a resource type and to have the
+ * specified long value.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object's old string rep, if any, is freed. Also, any old
+ * internal rep is freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_SetOSTypeObj(
+ Tcl_Obj *objPtr, /* Object whose internal rep to init. */
+ OSType newOSType) /* Integer used to set object's value. */
+{
+ register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
+
+ if (!osTypeInit) {
+ osTypeInit = 1;
+ Tcl_RegisterObjType(&osType);
+ }
+
+ Tcl_InvalidateStringRep(objPtr);
+ if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
+ oldTypePtr->freeIntRepProc(objPtr);
+ }
+
+ objPtr->internalRep.longValue = newOSType;
+ objPtr->typePtr = &osType;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetOSTypeFromObj --
+ *
+ * Attempt to return an int from the Tcl object "objPtr". If the object
+ * is not already an int, an attempt will be made to convert it to one.
+ *
+ * Results:
+ * The return value is a standard Tcl object result. If an error occurs
+ * during conversion, an error message is left in interp->objResult
+ * unless "interp" is NULL.
+ *
+ * Side effects:
+ * If the object is not already an int, the conversion will free
+ * any old internal representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_GetOSTypeFromObj(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr, /* The object from which to get a int. */
+ OSType *osTypePtr) /* Place to store resulting int. */
+{
+ register int result;
+
+ if (!osTypeInit) {
+ osTypeInit = 1;
+ Tcl_RegisterObjType(&osType);
+ }
+
+ if (objPtr->typePtr == &osType) {
+ *osTypePtr = objPtr->internalRep.longValue;
+ return TCL_OK;
+ }
+
+ result = SetOSTypeFromAny(interp, objPtr);
+ if (result == TCL_OK) {
+ *osTypePtr = objPtr->internalRep.longValue;
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupOSTypeInternalRep --
+ *
+ * Initialize the internal representation of an int Tcl_Obj to a
+ * copy of the internal representation of an existing int object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * "copyPtr"s internal rep is set to the integer corresponding to
+ * "srcPtr"s internal rep.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupOSTypeInternalRep(
+ Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
+ Tcl_Obj *copyPtr) /* Object with internal rep to set. */
+{
+ copyPtr->internalRep.longValue = srcPtr->internalRep.longValue;
+ copyPtr->typePtr = &osType;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetOSTypeFromAny --
+ *
+ * Attempt to generate an integer internal form for the Tcl object
+ * "objPtr".
+ *
+ * Results:
+ * The return value is a standard object Tcl result. If an error occurs
+ * during conversion, an error message is left in interp->objResult
+ * unless "interp" is NULL.
+ *
+ * Side effects:
+ * If no error occurs, an int is stored as "objPtr"s internal
+ * representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetOSTypeFromAny(
+ Tcl_Interp *interp, /* Used for error reporting if not NULL. */
+ Tcl_Obj *objPtr) /* The object to convert. */
+{
+ Tcl_ObjType *oldTypePtr = objPtr->typePtr;
+ char *string;
+ int length;
+ long newOSType;
+
+ /*
+ * Get the string representation. Make it up-to-date if necessary.
+ */
+
+ string = TclGetStringFromObj(objPtr, &length);
+
+ if (length != 4) {
+ if (interp != NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "expected Macintosh OS type but got \"", string, "\"",
+ (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ newOSType = *((long *) string);
+
+ /*
+ * The conversion to resource type succeeded. Free the old internalRep
+ * before setting the new one.
+ */
+
+ if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
+ oldTypePtr->freeIntRepProc(objPtr);
+ }
+
+ objPtr->internalRep.longValue = newOSType;
+ objPtr->typePtr = &osType;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateStringOfOSType --
+ *
+ * Update the string representation for an resource type object.
+ * Note: This procedure does not free an existing old string rep
+ * so storage will be lost if this has not already been done.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object's string is set to a valid string that results from
+ * the int-to-string conversion.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UpdateStringOfOSType(
+ register Tcl_Obj *objPtr) /* Int object whose string rep to update. */
+{
+ objPtr->bytes = ckalloc(5);
+ sprintf(objPtr->bytes, "%-4.4s", &(objPtr->internalRep.longValue));
+ objPtr->length = 4;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetRsrcRefFromObj --
+ *
+ * Given a String object containing a resource file token, return
+ * the OpenResourceFork structure that it represents, or NULL if
+ * the token cannot be found. If okayOnReadOnly is false, it will
+ * also check whether the token corresponds to a read-only file,
+ * and return NULL if it is.
+ *
+ * Results:
+ * A pointer to an OpenResourceFork structure, or NULL.
+ *
+ * Side effects:
+ * An error message may be left in resultPtr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static OpenResourceFork *
+GetRsrcRefFromObj(
+ register Tcl_Obj *objPtr, /* String obj containing file token */
+ int okayOnReadOnly, /* Whether this operation is okay for a *
+ * read only file. */
+ const char *operation, /* String containing the operation we *
+ * were trying to perform, used for errors */
+ Tcl_Obj *resultPtr) /* Tcl_Obj to contain error message */
+{
+ char *stringPtr;
+ Tcl_HashEntry *nameHashPtr;
+ OpenResourceFork *resourceRef;
+ int length;
+ OSErr err;
+
+ stringPtr = Tcl_GetStringFromObj(objPtr, &length);
+ nameHashPtr = Tcl_FindHashEntry(&nameTable, stringPtr);
+ if (nameHashPtr == NULL) {
+ Tcl_AppendStringsToObj(resultPtr,
+ "invalid resource file reference \"",
+ stringPtr, "\"", (char *) NULL);
+ return NULL;
+ }
+
+ resourceRef = (OpenResourceFork *) Tcl_GetHashValue(nameHashPtr);
+
+ if (!okayOnReadOnly) {
+ err = GetResFileAttrs((short) resourceRef->fileRef);
+ if (err & mapReadOnly) {
+ Tcl_AppendStringsToObj(resultPtr, "cannot ", operation,
+ " resource file \"",
+ stringPtr, "\", it was opened read only",
+ (char *) NULL);
+ return NULL;
+ }
+ }
+ return resourceRef;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclMacRegisterResourceFork --
+ *
+ * Register an open resource fork in the table of open resources
+ * managed by the procedures in this file. If the resource file
+ * is already registered with the table, then no new token is made.
+ *
+ * The bahavior is controlled by the value of tokenPtr, and of the
+ * flags variable. For tokenPtr, the possibilities are:
+ * - NULL: The new token is auto-generated, but not returned.
+ * - The string value of tokenPtr is the empty string: Then
+ * the new token is auto-generated, and returned in tokenPtr
+ * - tokenPtr has a value: The string value will be used for the token,
+ * unless it is already in use, in which case a new token will
+ * be generated, and returned in tokenPtr.
+ *
+ * For the flags variable: it can be one of:
+ * - TCL_RESOURCE__INSERT_TAIL: The element is inserted at the
+ * end of the list of open resources. Used only in Resource_Init.
+ * - TCL_RESOURCE_DONT_CLOSE: The resource close command will not close
+ * this resource.
+ * - TCL_RESOURCE_CHECK_IF_OPEN: This will check to see if this file's
+ * resource fork is already opened by this Tcl shell, and return
+ * an error without registering the resource fork.
+ *
+ * Results:
+ * Standard Tcl Result
+ *
+ * Side effects:
+ * An entry is added to the resource name table.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclMacRegisterResourceFork(
+ short fileRef, /* File ref for an open resource fork. */
+ Tcl_Obj *tokenPtr, /* A Tcl Object to which to write the *
+ * new token */
+ int flags) /* 1 means insert at the head of the resource
+ * fork list, 0 means at the tail */
+
+{
+ Tcl_HashEntry *resourceHashPtr;
+ Tcl_HashEntry *nameHashPtr;
+ OpenResourceFork *resourceRef;
+ int new;
+ char *resourceId = NULL;
+
+ if (!initialized) {
+ ResourceInit();
+ }
+
+ /*
+ * If we were asked to, check that this file has not been opened
+ * already.
+ */
+
+ if (flags & TCL_RESOURCE_CHECK_IF_OPEN) {
+ Tcl_HashSearch search;
+ short oldFileRef;
+ FCBPBRec newFileRec, oldFileRec;
+ OSErr err;
+
+ oldFileRec.ioCompletion = NULL;
+ oldFileRec.ioFCBIndx = 0;
+ oldFileRec.ioNamePtr = NULL;
+
+ newFileRec.ioCompletion = NULL;
+ newFileRec.ioFCBIndx = 0;
+ newFileRec.ioNamePtr = NULL;
+ newFileRec.ioVRefNum = 0;
+ newFileRec.ioRefNum = fileRef;
+ err = PBGetFCBInfo(&newFileRec, false);
+
+
+ resourceHashPtr = Tcl_FirstHashEntry(&resourceTable, &search);
+ while (resourceHashPtr != NULL) {
+
+ oldFileRef = (short) Tcl_GetHashKey(&resourceTable,
+ resourceHashPtr);
+
+
+ oldFileRec.ioVRefNum = 0;
+ oldFileRec.ioRefNum = oldFileRef;
+ err = PBGetFCBInfo(&oldFileRec, false);
+
+ /*
+ * err might not be noErr either because the file has closed
+ * out from under us somehow, which is bad but we're not going
+ * to fix it here, OR because it is the ROM MAP, which has a
+ * fileRef, but can't be gotten to by PBGetFCBInfo.
+ */
+
+ if ((oldFileRef == fileRef) ||
+ ((err == noErr)
+ && (newFileRec.ioFCBVRefNum == oldFileRec.ioFCBVRefNum)
+ && (newFileRec.ioFCBFlNm == oldFileRec.ioFCBFlNm))) {
+
+ resourceId = (char *) Tcl_GetHashValue(resourceHashPtr);
+ Tcl_SetStringObj(tokenPtr, resourceId, -1);
+ return TCL_OK;
+ }
+
+ resourceHashPtr = Tcl_NextHashEntry(&search);
+ }
+
+
+ }
+
+ resourceHashPtr = Tcl_CreateHashEntry(&resourceTable,
+ (char *) fileRef, &new);
+ if (!new) {
+ if (tokenPtr != NULL) {
+ resourceId = (char *) Tcl_GetHashValue(resourceHashPtr);
+ Tcl_SetStringObj(tokenPtr, resourceId, -1);
+ }
+ return TCL_OK;
+ }
+
+
+ /*
+ * If we were passed in a result pointer which is not an empty
+ * string, attempt to use that as the key. If the key already
+ * exists, silently fall back on resource%d...
+ */
+
+ if (tokenPtr != NULL) {
+ char *tokenVal;
+ int length;
+ tokenVal = (char *) Tcl_GetStringFromObj(tokenPtr, &length);
+ if (length > 0) {
+ nameHashPtr = Tcl_FindHashEntry(&nameTable, tokenVal);
+ if (nameHashPtr == NULL) {
+ resourceId = ckalloc(length + 1);
+ memcpy(resourceId, tokenVal, length);
+ resourceId[length] = '\0';
+ }
+ }
+ }
+
+ if (resourceId == NULL) {
+ resourceId = (char *) ckalloc(15);
+ sprintf(resourceId, "resource%d", newId);
+ }
+
+ Tcl_SetHashValue(resourceHashPtr, resourceId);
+ newId++;
+
+ nameHashPtr = Tcl_CreateHashEntry(&nameTable, resourceId, &new);
+ if (!new) {
+ panic("resource id has repeated itself");
+ }
+
+ resourceRef = (OpenResourceFork *) ckalloc(sizeof(OpenResourceFork));
+ resourceRef->fileRef = fileRef;
+ resourceRef->flags = flags;
+
+ Tcl_SetHashValue(nameHashPtr, (ClientData) resourceRef);
+ if (tokenPtr != NULL) {
+ Tcl_SetStringObj(tokenPtr, resourceId, -1);
+ }
+
+ if (flags & TCL_RESOURCE_INSERT_TAIL) {
+ Tcl_ListObjAppendElement(NULL, resourceForkList, tokenPtr);
+ } else {
+ Tcl_ListObjReplace(NULL, resourceForkList, 0, 0, 1, &tokenPtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclMacUnRegisterResourceFork --
+ *
+ * Removes the entry for an open resource fork from the table of
+ * open resources managed by the procedures in this file.
+ * If resultPtr is not NULL, it will be used for error reporting.
+ *
+ * Results:
+ * The fileRef for this token, or -1 if an error occured.
+ *
+ * Side effects:
+ * An entry is removed from the resource name table.
+ *
+ *----------------------------------------------------------------------
+ */
+
+short
+TclMacUnRegisterResourceFork(
+ char *tokenPtr,
+ Tcl_Obj *resultPtr)
+
+{
+ Tcl_HashEntry *resourceHashPtr;
+ Tcl_HashEntry *nameHashPtr;
+ OpenResourceFork *resourceRef;
+ char *resourceId = NULL;
+ short fileRef;
+ char *bytes;
+ int i, match, index, listLen, length, elemLen;
+ Tcl_Obj **elemPtrs;
+
+
+ nameHashPtr = Tcl_FindHashEntry(&nameTable, tokenPtr);
+ if (nameHashPtr == NULL) {
+ if (resultPtr != NULL) {
+ Tcl_AppendStringsToObj(resultPtr,
+ "invalid resource file reference \"",
+ tokenPtr, "\"", (char *) NULL);
+ }
+ return -1;
+ }
+
+ resourceRef = (OpenResourceFork *) Tcl_GetHashValue(nameHashPtr);
+ fileRef = resourceRef->fileRef;
+
+ if ( resourceRef->flags & TCL_RESOURCE_DONT_CLOSE ) {
+ if (resultPtr != NULL) {
+ Tcl_AppendStringsToObj(resultPtr,
+ "can't close \"", tokenPtr, "\" resource file",
+ (char *) NULL);
+ }
+ return -1;
+ }
+
+ Tcl_DeleteHashEntry(nameHashPtr);
+ ckfree((char *) resourceRef);
+
+
+ /*
+ * Now remove the resource from the resourceForkList object
+ */
+
+ Tcl_ListObjGetElements(NULL, resourceForkList, &listLen, &elemPtrs);
+
+
+ index = -1;
+ length = strlen(tokenPtr);
+
+ for (i = 0; i < listLen; i++) {
+ match = 0;
+ bytes = Tcl_GetStringFromObj(elemPtrs[i], &elemLen);
+ if (length == elemLen) {
+ match = (memcmp(bytes, tokenPtr,
+ (size_t) length) == 0);
+ }
+ if (match) {
+ index = i;
+ break;
+ }
+ }
+ if (!match) {
+ panic("the resource Fork List is out of synch!");
+ }
+
+ Tcl_ListObjReplace(NULL, resourceForkList, index, 1, 0, NULL);
+
+ resourceHashPtr = Tcl_FindHashEntry(&resourceTable, (char *) fileRef);
+
+ if (resourceHashPtr == NULL) {
+ panic("Resource & Name tables are out of synch in resource command.");
+ }
+ ckfree(Tcl_GetHashValue(resourceHashPtr));
+ Tcl_DeleteHashEntry(resourceHashPtr);
+
+ return fileRef;
+
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * BuildResourceForkList --
+ *
+ * Traverses the list of open resource forks, and builds the
+ * list of resources forks. Also creates a resource token for any that
+ * are opened but not registered with our resource system.
+ * This is based on code from Apple DTS.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The list of resource forks is updated.
+ * The resource name table may be augmented.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+BuildResourceForkList()
+{
+ Handle currentMapHandle, mSysMapHandle;
+ Ptr tempPtr;
+ FCBPBRec fileRec;
+ char fileName[256];
+ char appName[62];
+ Tcl_Obj *nameObj;
+ OSErr err;
+ ProcessSerialNumber psn;
+ ProcessInfoRec info;
+ FSSpec fileSpec;
+
+ /*
+ * Get the application name, so we can substitute
+ * the token "application" for the application's resource.
+ */
+
+ GetCurrentProcess(&psn);
+ info.processInfoLength = sizeof(ProcessInfoRec);
+ info.processName = (StringPtr) &appName;
+ info.processAppSpec = &fileSpec;
+ GetProcessInformation(&psn, &info);
+ p2cstr((StringPtr) appName);
+
+
+ fileRec.ioCompletion = NULL;
+ fileRec.ioVRefNum = 0;
+ fileRec.ioFCBIndx = 0;
+ fileRec.ioNamePtr = (StringPtr) &fileName;
+
+
+ currentMapHandle = LMGetTopMapHndl();
+ mSysMapHandle = LMGetSysMapHndl();
+
+ while (1) {
+ /*
+ * Now do the ones opened after the application.
+ */
+
+ nameObj = Tcl_NewObj();
+
+ tempPtr = *currentMapHandle;
+
+ fileRec.ioRefNum = *((short *) (tempPtr + 20));
+ err = PBGetFCBInfo(&fileRec, false);
+
+ if (err != noErr) {
+ /*
+ * The ROM resource map does not correspond to an opened file...
+ */
+ Tcl_SetStringObj(nameObj, "ROM Map", -1);
+ } else {
+ p2cstr((StringPtr) fileName);
+ if (strcmp(fileName,(char *) appName) == 0) {
+ Tcl_SetStringObj(nameObj, "application", -1);
+ } else {
+ Tcl_SetStringObj(nameObj, fileName, -1);
+ }
+ c2pstr(fileName);
+ }
+
+ TclMacRegisterResourceFork(fileRec.ioRefNum, nameObj,
+ TCL_RESOURCE_DONT_CLOSE | TCL_RESOURCE_INSERT_TAIL);
+
+ if (currentMapHandle == mSysMapHandle) {
+ break;
+ }
+
+ currentMapHandle = *((Handle *) (tempPtr + 16));
+ }
+}