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