开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
tclMacResource.c
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：62k
源码类别：

通讯编程

开发平台：

Visual C++

tclMacResource.c：源码内容
  1. /*
  2.  * tclMacResource.c --
  3.  *
  4.  * This file contains several commands that manipulate or use
  5.  * Macintosh resources.  Included are extensions to the "source"
  6.  * command, the mac specific "beep" and "resource" commands, and
  7.  * administration for open resource file references.
  8.  *
  9.  * Copyright (c) 1996-1997 Sun Microsystems, Inc.
  10.  *
  11.  * See the file "license.terms" for information on usage and redistribution
  12.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13.  *
  14.  * RCS: @(#) $Id: tclMacResource.c,v 1.14.2.1 2003/10/01 14:34:16 das Exp $
  15.  */
  17. #include <Errors.h>
  18. #include <FSpCompat.h>
  19. #include <Processes.h>
  20. #include <Resources.h>
  21. #include <Sound.h>
  22. #include <Strings.h>
  23. #include <Traps.h>
  24. #include <LowMem.h>
  26. #include "FullPath.h"
  27. #include "tcl.h"
  28. #include "tclInt.h"
  29. #include "tclMac.h"
  30. #include "tclMacInt.h"
  31. #include "tclMacPort.h"
  33. /*
  34.  * This flag tells the RegisterResource function to insert the
  35.  * resource into the tail of the resource fork list.  Needed only
  36.  * Resource_Init.
  37.  */
  38.  
  39. #define TCL_RESOURCE_INSERT_TAIL 1
  40. /*
  41.  * 2 is taken by TCL_RESOURCE_DONT_CLOSE
  42.  * which is the only public flag to TclMacRegisterResourceFork.
  43.  */
  44.  
  45. #define TCL_RESOURCE_CHECK_IF_OPEN 4
  47. /*
  48.  * Pass this in the mode parameter of SetSoundVolume to determine
  49.  * which volume to set.
  50.  */
  52. enum WhichVolume {
  53.     SYS_BEEP_VOLUME,    /* This sets the volume for SysBeep calls */ 
  54.     DEFAULT_SND_VOLUME, /* This one for SndPlay calls */
  55.     RESET_VOLUME        /* And this undoes the last call to SetSoundVolume */
  56. };
  57.  
  58. /*
  59.  * Hash table to track open resource files.
  60.  */
  62. typedef struct OpenResourceFork {
  63.     short fileRef;
  64.     int   flags;
  65. } OpenResourceFork;
  69. static Tcl_HashTable nameTable; /* Id to process number mapping. */
  70. static Tcl_HashTable resourceTable; /* Process number to id mapping. */
  71. static Tcl_Obj *resourceForkList;       /* Ordered list of resource forks */
  72. static int appResourceIndex;            /* This is the index of the application*
  73.  * in the list of resource forks */
  74. static int newId = 0; /* Id source. */
  75. static int initialized = 0; /* 0 means static structures haven't 
  76.  * been initialized yet. */
  77. static int osTypeInit = 0; /* 0 means Tcl object of osType hasn't 
  78.  * been initialized yet. */
  79. /*
  80.  * Prototypes for procedures defined later in this file:
  81.  */
  83. static void DupOSTypeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
  84.     Tcl_Obj *copyPtr));
  85. static void ResourceInit _ANSI_ARGS_((void));
  86. static void             BuildResourceForkList _ANSI_ARGS_((void));
  87. static int SetOSTypeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
  88.     Tcl_Obj *objPtr));
  89. static void UpdateStringOfOSType _ANSI_ARGS_((Tcl_Obj *objPtr));
  90. static OpenResourceFork* GetRsrcRefFromObj _ANSI_ARGS_((Tcl_Obj *objPtr,
  91.                 int okayOnReadOnly, const char *operation,
  92.                         Tcl_Obj *resultPtr));
  94. static void  SetSoundVolume(int volume, enum WhichVolume mode);
  96. /*
  97.  * The structures below defines the Tcl object type defined in this file by
  98.  * means of procedures that can be invoked by generic object code.
  99.  */
  101. static Tcl_ObjType osType = {
  102.     "ostype", /* name */
  103.     (Tcl_FreeInternalRepProc *) NULL,   /* freeIntRepProc */
  104.     DupOSTypeInternalRep,         /* dupIntRepProc */
  105.     UpdateStringOfOSType, /* updateStringProc */
  106.     SetOSTypeFromAny /* setFromAnyProc */
  107. };
  109. /*
  110.  *----------------------------------------------------------------------
  111.  *
  112.  * Tcl_ResourceObjCmd --
  113.  *
  114.  * This procedure is invoked to process the "resource" Tcl command.
  115.  * See the user documentation for details on what it does.
  116.  *
  117.  * Results:
  118.  * A standard Tcl result.
  119.  *
  120.  * Side effects:
  121.  * See the user documentation.
  122.  *
  123.  *----------------------------------------------------------------------
  124.  */
  126. int
  127. Tcl_ResourceObjCmd(
  128.     ClientData clientData, /* Not used. */
  129.     Tcl_Interp *interp, /* Current interpreter. */
  130.     int objc, /* Number of arguments. */
  131.     Tcl_Obj *CONST objv[]) /* Argument values. */
  132. {
  133.     Tcl_Obj *resultPtr, *objPtr;
  134.     int index, result;
  135.     long fileRef, rsrcId;
  136.     FSSpec fileSpec;
  137.     char *stringPtr;
  138.     char errbuf[16];
  139.     OpenResourceFork *resourceRef;
  140.     Handle resource = NULL;
  141.     OSErr err;
  142.     int count, i, limitSearch = false, length;
  143.     short id, saveRef, resInfo;
  144.     Str255 theName;
  145.     OSType rezType;
  146.     int gotInt, releaseIt = 0, force;
  147.     char *resourceId = NULL;
  148.     long size;
  149.     char macPermision;
  150.     int mode;
  152.     static CONST char *switches[] = {"close", "delete" ,"files", "list", 
  153.             "open", "read", "types", "write", (char *) NULL
  154.     };
  155.         
  156.     enum {
  157.             RESOURCE_CLOSE, RESOURCE_DELETE, RESOURCE_FILES, RESOURCE_LIST, 
  158.             RESOURCE_OPEN, RESOURCE_READ, RESOURCE_TYPES, RESOURCE_WRITE
  159.     };
  160.               
  161.     static CONST char *writeSwitches[] = {
  162.             "-id", "-name", "-file", "-force", (char *) NULL
  163.     };
  164.             
  165.     enum {
  166.             RESOURCE_WRITE_ID, RESOURCE_WRITE_NAME, 
  167.             RESOURCE_WRITE_FILE, RESOURCE_FORCE
  168.     };
  169.             
  170.     static CONST char *deleteSwitches[] = {"-id", "-name", "-file", (char *) NULL};
  171.              
  172.     enum {RESOURCE_DELETE_ID, RESOURCE_DELETE_NAME, RESOURCE_DELETE_FILE};
  174.     resultPtr = Tcl_GetObjResult(interp);
  175.     
  176.     if (objc < 2) {
  177. Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
  178. return TCL_ERROR;
  179.     }
  181.     if (Tcl_GetIndexFromObj(interp, objv[1], switches, "option", 0, &index)
  182.     != TCL_OK) {
  183. return TCL_ERROR;
  184.     }
  185.     if (!initialized) {
  186. ResourceInit();
  187.     }
  188.     result = TCL_OK;
  190.     switch (index) {
  191. case RESOURCE_CLOSE:
  192.     if (objc != 3) {
  193. Tcl_WrongNumArgs(interp, 2, objv, "resourceRef");
  194. return TCL_ERROR;
  195.     }
  196.     stringPtr = Tcl_GetStringFromObj(objv[2], &length);
  197.     fileRef = TclMacUnRegisterResourceFork(stringPtr, resultPtr);
  198.     
  199.     if (fileRef >= 0) {
  200.         CloseResFile((short) fileRef);
  201.         return TCL_OK;
  202.     } else {
  203.         return TCL_ERROR;
  204.     }
  205. case RESOURCE_DELETE:
  206.     if (!((objc >= 3) && (objc <= 9) && ((objc % 2) == 1))) {
  207. Tcl_WrongNumArgs(interp, 2, objv, 
  208.     "?-id resourceId? ?-name resourceName? ?-file 
  209. resourceRef? resourceType");
  210. return TCL_ERROR;
  211.     }
  212.     
  213.     i = 2;
  214.     fileRef = -1;
  215.     gotInt = false;
  216.     resourceId = NULL;
  217.     limitSearch = false;
  219.     while (i < (objc - 2)) {
  220. if (Tcl_GetIndexFromObj(interp, objv[i], deleteSwitches,
  221. "option", 0, &index) != TCL_OK) {
  222.     return TCL_ERROR;
  223. }
  225. switch (index) {
  226.     case RESOURCE_DELETE_ID:
  227. if (Tcl_GetLongFromObj(interp, objv[i+1], &rsrcId)
  228. != TCL_OK) {
  229.     return TCL_ERROR;
  230. }
  231. gotInt = true;
  232. break;
  233.     case RESOURCE_DELETE_NAME:
  234. resourceId = Tcl_GetStringFromObj(objv[i+1], &length);
  235. if (length > 255) {
  236.     Tcl_AppendStringsToObj(resultPtr,"-name argument ",
  237.             "too long, must be < 255 characters",
  238.             (char *) NULL);
  239.     return TCL_ERROR;
  240. }
  241. strcpy((char *) theName, resourceId);
  242. resourceId = (char *) theName;
  243. c2pstr(resourceId);
  244. break;
  245.     case RESOURCE_DELETE_FILE:
  246.         resourceRef = GetRsrcRefFromObj(objv[i+1], 0, 
  247.                 "delete from", resultPtr);
  248.         if (resourceRef == NULL) {
  249.             return TCL_ERROR;
  250.         }
  251. limitSearch = true;
  252. break;
  253. }
  254. i += 2;
  255.     }
  256.     
  257.     if ((resourceId == NULL) && !gotInt) {
  258. Tcl_AppendStringsToObj(resultPtr,"you must specify either ",
  259.         ""-id" or "-name" or both ",
  260.         "to "resource delete"",
  261.         (char *) NULL);
  262.         return TCL_ERROR;
  263.             }
  265.     if (Tcl_GetOSTypeFromObj(interp, objv[i], &rezType) != TCL_OK) {
  266. return TCL_ERROR;
  267.     }
  269.     if (limitSearch) {
  270. saveRef = CurResFile();
  271. UseResFile((short) resourceRef->fileRef);
  272.     }
  273.     
  274.     SetResLoad(false);
  275.     
  276.     if (gotInt == true) {
  277.         if (limitSearch) {
  278.     resource = Get1Resource(rezType, rsrcId);
  279. } else {
  280.     resource = GetResource(rezType, rsrcId);
  281. }
  282.                 err = ResError();
  283.             
  284.                 if (err == resNotFound || resource == NULL) {
  285.             Tcl_AppendStringsToObj(resultPtr, "resource not found",
  286.                 (char *) NULL);
  287.             result = TCL_ERROR;
  288.             goto deleteDone;               
  289.                 } else if (err != noErr) {
  290.                     char buffer[16];
  291.                 
  292.                     sprintf(buffer, "%12d", err);
  293.             Tcl_AppendStringsToObj(resultPtr, "resource error #",
  294.                     buffer, "occured while trying to find resource",
  295.                     (char *) NULL);
  296.             result = TCL_ERROR;
  297.             goto deleteDone;               
  298.         }
  299.     } 
  300.     
  301.     if (resourceId != NULL) {
  302.         Handle tmpResource;
  303.         if (limitSearch) {
  304.             tmpResource = Get1NamedResource(rezType,
  305.     (StringPtr) resourceId);
  306.         } else {
  307.             tmpResource = GetNamedResource(rezType,
  308.     (StringPtr) resourceId);
  309.         }
  310.                 err = ResError();
  311.             
  312.                 if (err == resNotFound || tmpResource == NULL) {
  313.             Tcl_AppendStringsToObj(resultPtr, "resource not found",
  314.                 (char *) NULL);
  315.             result = TCL_ERROR;
  316.             goto deleteDone;               
  317.                 } else if (err != noErr) {
  318.                     char buffer[16];
  319.                 
  320.                     sprintf(buffer, "%12d", err);
  321.             Tcl_AppendStringsToObj(resultPtr, "resource error #",
  322.                     buffer, "occured while trying to find resource",
  323.                     (char *) NULL);
  324.             result = TCL_ERROR;
  325.             goto deleteDone;               
  326.         }
  327.         
  328.         if (gotInt) { 
  329.             if (resource != tmpResource) {
  330.                 Tcl_AppendStringsToObj(resultPtr,
  331. ""-id" and "-name" ",
  332.                         "values do not point to the same resource",
  333.                         (char *) NULL);
  334.                 result = TCL_ERROR;
  335.                 goto deleteDone;
  336.             }
  337.         } else {
  338.             resource = tmpResource;
  339.         }
  340.     }
  341.         
  342.             resInfo = GetResAttrs(resource);
  343.     
  344.     if ((resInfo & resProtected) == resProtected) {
  345.         Tcl_AppendStringsToObj(resultPtr, "resource ",
  346.                 "cannot be deleted: it is protected.",
  347.                 (char *) NULL);
  348.         result = TCL_ERROR;
  349.         goto deleteDone;               
  350.     } else if ((resInfo & resSysHeap) == resSysHeap) {   
  351.         Tcl_AppendStringsToObj(resultPtr, "resource",
  352.                 "cannot be deleted: it is in the system heap.",
  353.                 (char *) NULL);
  354.         result = TCL_ERROR;
  355.         goto deleteDone;               
  356.     }
  357.     
  358.     /*
  359.      * Find the resource file, if it was not specified,
  360.      * so we can flush the changes now.  Perhaps this is
  361.      * a little paranoid, but better safe than sorry.
  362.      */
  363.      
  364.     RemoveResource(resource);
  365.     
  366.     if (!limitSearch) {
  367.         UpdateResFile(HomeResFile(resource));
  368.     } else {
  369.         UpdateResFile(resourceRef->fileRef);
  370.     }
  371.     
  372.     
  373.     deleteDone:
  374.     
  375.             SetResLoad(true);
  376.     if (limitSearch) {
  377.                  UseResFile(saveRef);                        
  378.     }
  379.     return result;
  380.     
  381. case RESOURCE_FILES:
  382.     if ((objc < 2) || (objc > 3)) {
  383. Tcl_SetStringObj(resultPtr,
  384.         "wrong # args: should be "resource files 
  385. ?resourceId?"", -1);
  386. return TCL_ERROR;
  387.     }
  388.     
  389.     if (objc == 2) {
  390.         stringPtr = Tcl_GetStringFromObj(resourceForkList, &length);
  391.         Tcl_SetStringObj(resultPtr, stringPtr, length);
  392.     } else {
  393.                 FCBPBRec fileRec;
  394.                 Handle pathHandle;
  395.                 short pathLength;
  396.                 Str255 fileName;
  397.                 Tcl_DString dstr;
  398.         
  399.         if (strcmp(Tcl_GetString(objv[2]), "ROM Map") == 0) {
  400.             Tcl_SetStringObj(resultPtr,"no file path for ROM Map", -1);
  401.             return TCL_ERROR;
  402.         }
  403.         
  404.         resourceRef = GetRsrcRefFromObj(objv[2], 1, "files", resultPtr);
  405.         if (resourceRef == NULL) {
  406.             return TCL_ERROR;
  407.         }
  409.                 fileRec.ioCompletion = NULL;
  410.                 fileRec.ioFCBIndx = 0;
  411.                 fileRec.ioNamePtr = fileName;
  412.                 fileRec.ioVRefNum = 0;
  413.                 fileRec.ioRefNum = resourceRef->fileRef;
  414.                 err = PBGetFCBInfo(&fileRec, false);
  415.                 if (err != noErr) {
  416.                     Tcl_SetStringObj(resultPtr,
  417.                             "could not get FCB for resource file", -1);
  418.                     return TCL_ERROR;
  419.                 }
  420.                 
  421.                 err = GetFullPath(fileRec.ioFCBVRefNum, fileRec.ioFCBParID,
  422.                         fileRec.ioNamePtr, &pathLength, &pathHandle);
  423.                 if ( err != noErr) {
  424.                     Tcl_SetStringObj(resultPtr,
  425.                             "could not get file path from token", -1);
  426.                     return TCL_ERROR;
  427.                 }
  428.                 
  429.                 HLock(pathHandle);
  430.                 Tcl_ExternalToUtfDString(NULL, *pathHandle, pathLength, &dstr);
  431.                 
  432.                 Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr));
  433.                 HUnlock(pathHandle);
  434.                 DisposeHandle(pathHandle);
  435.                 Tcl_DStringFree(&dstr);
  436.             }                         
  437.     return TCL_OK;
  438. case RESOURCE_LIST:
  439.     if (!((objc == 3) || (objc == 4))) {
  440. Tcl_WrongNumArgs(interp, 2, objv, "resourceType ?resourceRef?");
  441. return TCL_ERROR;
  442.     }
  443.     if (Tcl_GetOSTypeFromObj(interp, objv[2], &rezType) != TCL_OK) {
  444. return TCL_ERROR;
  445.     }
  447.     if (objc == 4) {
  448.         resourceRef = GetRsrcRefFromObj(objv[3], 1, 
  449.                 "list", resultPtr);
  450. if (resourceRef == NULL) {
  451.     return TCL_ERROR;
  452. }
  454. saveRef = CurResFile();
  455. UseResFile((short) resourceRef->fileRef);
  456. limitSearch = true;
  457.     }
  459.     Tcl_ResetResult(interp);
  460.     if (limitSearch) {
  461. count = Count1Resources(rezType);
  462.     } else {
  463. count = CountResources(rezType);
  464.     }
  465.     SetResLoad(false);
  466.     for (i = 1; i <= count; i++) {
  467. if (limitSearch) {
  468.     resource = Get1IndResource(rezType, i);
  469. } else {
  470.     resource = GetIndResource(rezType, i);
  471. }
  472. if (resource != NULL) {
  473.     GetResInfo(resource, &id, (ResType *) &rezType, theName);
  474.     if (theName[0] != 0) {
  475.         
  476. objPtr = Tcl_NewStringObj((char *) theName + 1,
  477. theName[0]);
  478.     } else {
  479. objPtr = Tcl_NewIntObj(id);
  480.     }
  481.     ReleaseResource(resource);
  482.     result = Tcl_ListObjAppendElement(interp, resultPtr,
  483.     objPtr);
  484.     if (result != TCL_OK) {
  485. Tcl_DecrRefCount(objPtr);
  486. break;
  487.     }
  488. }
  489.     }
  490.     SetResLoad(true);
  492.     if (limitSearch) {
  493. UseResFile(saveRef);
  494.     }
  496.     return TCL_OK;
  497. case RESOURCE_OPEN: {
  498.     Tcl_DString ds, buffer;
  499.     CONST char *str, *native;
  500.     int length;
  501.     
  502.     if (!((objc == 3) || (objc == 4))) {
  503. Tcl_WrongNumArgs(interp, 2, objv, "fileName ?permissions?");
  504. return TCL_ERROR;
  505.     }
  506.     str = Tcl_GetStringFromObj(objv[2], &length);
  507.     if (Tcl_TranslateFileName(interp, str, &buffer) == NULL) {
  508.         return TCL_ERROR;
  509.     }
  510.     native = Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&buffer),
  511.          Tcl_DStringLength(&buffer), &ds);
  512.     err = FSpLocationFromPath(Tcl_DStringLength(&ds), native, &fileSpec);
  513.     Tcl_DStringFree(&ds);
  514.     Tcl_DStringFree(&buffer);
  516.     if (!((err == noErr) || (err == fnfErr))) {
  517. Tcl_AppendStringsToObj(resultPtr, "invalid path", (char *) NULL);
  518. return TCL_ERROR;
  519.     }
  521.     /*
  522.      * Get permissions for the file.  We really only understand
  523.      * read-only and shared-read-write.  If no permissions are 
  524.      * given we default to read only.
  525.      */
  526.     
  527.     if (objc == 4) {
  528. stringPtr = Tcl_GetStringFromObj(objv[3], &length);
  529. mode = TclGetOpenMode(interp, stringPtr, &index);
  530. if (mode == -1) {
  531.     /* TODO: TclGetOpenMode doesn't work with Obj commands. */
  532.     return TCL_ERROR;
  533. }
  534. switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
  535.     case O_RDONLY:
  536. macPermision = fsRdPerm;
  537.     break;
  538.     case O_WRONLY:
  539.     case O_RDWR:
  540. macPermision = fsRdWrShPerm;
  541. break;
  542.     default:
  543. panic("Tcl_ResourceObjCmd: invalid mode value");
  544.     break;
  545. }
  546.     } else {
  547. macPermision = fsRdPerm;
  548.     }
  549.     
  550.     /*
  551.      * Don't load in any of the resources in the file, this could 
  552.      * cause problems if you open a file that has CODE resources...
  553.      */
  554.      
  555.     SetResLoad(false); 
  556.     fileRef = (long) FSpOpenResFileCompat(&fileSpec, macPermision);
  557.     SetResLoad(true);
  558.     
  559.     if (fileRef == -1) {
  560.      err = ResError();
  561. if (((err == fnfErr) || (err == eofErr)) &&
  562. (macPermision == fsRdWrShPerm)) {
  563.     /*
  564.      * No resource fork existed for this file.  Since we are
  565.      * opening it for writing we will create the resource fork
  566.      * now.
  567.      */
  568.      
  569.     HCreateResFile(fileSpec.vRefNum, fileSpec.parID,
  570.     fileSpec.name);
  571.     fileRef = (long) FSpOpenResFileCompat(&fileSpec,
  572.     macPermision);
  573.     if (fileRef == -1) {
  574. goto openError;
  575.     }
  576. } else if (err == fnfErr) {
  577.     Tcl_AppendStringsToObj(resultPtr,
  578. "file does not exist", (char *) NULL);
  579.     return TCL_ERROR;
  580. } else if (err == eofErr) {
  581.     Tcl_AppendStringsToObj(resultPtr,
  582. "file does not contain resource fork", (char *) NULL);
  583.     return TCL_ERROR;
  584. } else {
  585.     openError:
  586.     Tcl_AppendStringsToObj(resultPtr,
  587. "error opening resource file", (char *) NULL);
  588.     return TCL_ERROR;
  589. }
  590.     }
  591.          
  592.             /*
  593.              * The FspOpenResFile function does not set the ResFileAttrs.
  594.              * Even if you open the file read only, the mapReadOnly
  595.              * attribute is not set.  This means we can't detect writes to a 
  596.              * read only resource fork until the write fails, which is bogus.  
  597.              * So set it here...
  598.              */
  599.             
  600.             if (macPermision == fsRdPerm) {
  601.                 SetResFileAttrs(fileRef, mapReadOnly);
  602.             }
  603.             
  604.             Tcl_SetStringObj(resultPtr, "", 0);
  605.             if (TclMacRegisterResourceFork(fileRef, resultPtr, 
  606.                     TCL_RESOURCE_CHECK_IF_OPEN) != TCL_OK) {
  607.                 CloseResFile(fileRef);
  608. return TCL_ERROR;
  609.             }
  610.     return TCL_OK;
  611. }
  612. case RESOURCE_READ:
  613.     if (!((objc == 4) || (objc == 5))) {
  614. Tcl_WrongNumArgs(interp, 2, objv,
  615. "resourceType resourceId ?resourceRef?");
  616. return TCL_ERROR;
  617.     }
  619.     if (Tcl_GetOSTypeFromObj(interp, objv[2], &rezType) != TCL_OK) {
  620. return TCL_ERROR;
  621.     }
  622.     
  623.     if (Tcl_GetLongFromObj((Tcl_Interp *) NULL, objv[3], &rsrcId)
  624.     != TCL_OK) {
  625. resourceId = Tcl_GetStringFromObj(objv[3], &length);
  626.             }
  628.     if (objc == 5) {
  629. stringPtr = Tcl_GetStringFromObj(objv[4], &length);
  630.     } else {
  631. stringPtr = NULL;
  632.     }
  634.     resource = Tcl_MacFindResource(interp, rezType, resourceId,
  635. rsrcId, stringPtr, &releaseIt);
  636.     
  637.     if (resource != NULL) {
  638. size = GetResourceSizeOnDisk(resource);
  639. Tcl_SetByteArrayObj(resultPtr, (unsigned char *) *resource, size);
  641. /*
  642.  * Don't release the resource unless WE loaded it...
  643.  */
  644.  
  645. if (releaseIt) {
  646.     ReleaseResource(resource);
  647. }
  648. return TCL_OK;
  649.     } else {
  650. Tcl_AppendStringsToObj(resultPtr, "could not load resource",
  651.     (char *) NULL);
  652. return TCL_ERROR;
  653.     }
  654. case RESOURCE_TYPES:
  655.     if (!((objc == 2) || (objc == 3))) {
  656. Tcl_WrongNumArgs(interp, 2, objv, "?resourceRef?");
  657. return TCL_ERROR;
  658.     }
  660.     if (objc == 3) {
  661.         resourceRef = GetRsrcRefFromObj(objv[2], 1, 
  662.                 "get types of", resultPtr);
  663. if (resourceRef == NULL) {
  664.     return TCL_ERROR;
  665. }
  667. saveRef = CurResFile();
  668. UseResFile((short) resourceRef->fileRef);
  669. limitSearch = true;
  670.     }
  672.     if (limitSearch) {
  673. count = Count1Types();
  674.     } else {
  675. count = CountTypes();
  676.     }
  677.     for (i = 1; i <= count; i++) {
  678. if (limitSearch) {
  679.     Get1IndType((ResType *) &rezType, i);
  680. } else {
  681.     GetIndType((ResType *) &rezType, i);
  682. }
  683. objPtr = Tcl_NewOSTypeObj(rezType);
  684. result = Tcl_ListObjAppendElement(interp, resultPtr, objPtr);
  685. if (result != TCL_OK) {
  686.     Tcl_DecrRefCount(objPtr);
  687.     break;
  688. }
  689.     }
  691.     if (limitSearch) {
  692. UseResFile(saveRef);
  693.     }
  695.     return result;
  696. case RESOURCE_WRITE:
  697.     if ((objc < 4) || (objc > 11)) {
  698. Tcl_WrongNumArgs(interp, 2, objv, 
  699. "?-id resourceId? ?-name resourceName? ?-file resourceRef?
  700.  ?-force? resourceType data");
  701. return TCL_ERROR;
  702.     }
  703.     
  704.     i = 2;
  705.     gotInt = false;
  706.     resourceId = NULL;
  707.     limitSearch = false;
  708.     force = 0;
  710.     while (i < (objc - 2)) {
  711. if (Tcl_GetIndexFromObj(interp, objv[i], writeSwitches,
  712. "switch", 0, &index) != TCL_OK) {
  713.     return TCL_ERROR;
  714. }
  716. switch (index) {
  717.     case RESOURCE_WRITE_ID:
  718. if (Tcl_GetLongFromObj(interp, objv[i+1], &rsrcId)
  719. != TCL_OK) {
  720.     return TCL_ERROR;
  721. }
  722. gotInt = true;
  723.         i += 2;
  724. break;
  725.     case RESOURCE_WRITE_NAME:
  726. resourceId = Tcl_GetStringFromObj(objv[i+1], &length);
  727. strcpy((char *) theName, resourceId);
  728. resourceId = (char *) theName;
  729. c2pstr(resourceId);
  730.         i += 2;
  731. break;
  732.     case RESOURCE_WRITE_FILE:
  733.                 resourceRef = GetRsrcRefFromObj(objv[i+1], 0, 
  734.                         "write to", resultPtr);
  735.                         if (resourceRef == NULL) {
  736.                             return TCL_ERROR;
  737.         }
  738. limitSearch = true;
  739.         i += 2;
  740. break;
  741.     case RESOURCE_FORCE:
  742.         force = 1;
  743.         i += 1;
  744.         break;
  745. }
  746.     }
  747.     if (Tcl_GetOSTypeFromObj(interp, objv[i], &rezType) != TCL_OK) {
  748. return TCL_ERROR;
  749.     }
  750.     stringPtr = (char *) Tcl_GetByteArrayFromObj(objv[i+1], &length);
  752.     if (gotInt == false) {
  753. rsrcId = UniqueID(rezType);
  754.     }
  755.     if (resourceId == NULL) {
  756. resourceId = (char *) "p";
  757.     }
  758.     if (limitSearch) {
  759. saveRef = CurResFile();
  760. UseResFile((short) resourceRef->fileRef);
  761.     }
  762.     
  763.     /*
  764.      * If we are adding the resource by number, then we must make sure
  765.      * there is not already a resource of that number.  We are not going
  766.      * load it here, since we want to detect whether we loaded it or
  767.      * not.  Remember that releasing some resources in particular menu
  768.      * related ones, can be fatal.
  769.      */
  770.      
  771.     if (gotInt == true) {
  772.         SetResLoad(false);
  773.         resource = Get1Resource(rezType,rsrcId);
  774.         SetResLoad(true);
  775.     }     
  776.          
  777.     if (resource == NULL) {
  778.         /*
  779.          * We get into this branch either if there was not already a
  780.          * resource of this type & id, or the id was not specified.
  781.          */
  782.          
  783.         resource = NewHandle(length);
  784.         if (resource == NULL) {
  785.             resource = NewHandleSys(length);
  786.             if (resource == NULL) {
  787.                 panic("could not allocate memory to write resource");
  788.             }
  789.         }
  790.         HLock(resource);
  791.         memcpy(*resource, stringPtr, length);
  792.         HUnlock(resource);
  793.         AddResource(resource, rezType, (short) rsrcId,
  794.     (StringPtr) resourceId);
  795. releaseIt = 1;
  796.             } else {
  797.                 /* 
  798.                  * We got here because there was a resource of this type 
  799.                  * & ID in the file. 
  800.                  */ 
  801.                 
  802.                 if (*resource == NULL) {
  803.                     releaseIt = 1;
  804.                 } else {
  805.                     releaseIt = 0;
  806.                 }
  807.                
  808.                 if (!force) {
  809.                     /*
  810.                      *We only overwrite extant resources
  811.                      * when the -force flag has been set.
  812.                      */
  813.                      
  814.                     sprintf(errbuf,"%d", rsrcId);
  815.                   
  816.                     Tcl_AppendStringsToObj(resultPtr, "the resource ",
  817.                           errbuf, " already exists, use "-force"",
  818.                           " to overwrite it.", (char *) NULL);
  819.                     
  820.                     result = TCL_ERROR;
  821.                     goto writeDone;
  822.                 } else if (GetResAttrs(resource) & resProtected) {
  823.                     /*  
  824.                      *  
  825.                      * Next, check to see if it is protected...
  826.                      */
  827.                  
  828.                     sprintf(errbuf,"%d", rsrcId);
  829.                     Tcl_AppendStringsToObj(resultPtr,
  830.     "could not write resource id ",
  831.                             errbuf, " of type ",
  832.                             Tcl_GetStringFromObj(objv[i],&length),
  833.                             ", it was protected.",(char *) NULL);
  834.                     result = TCL_ERROR;
  835.                     goto writeDone;
  836.                 } else {
  837.                     /*
  838.                      * Be careful, the resource might already be in memory
  839.                      * if something else loaded it.
  840.                      */
  841.                      
  842.                     if (*resource == 0) {
  843.                      LoadResource(resource);
  844.                      err = ResError();
  845.                      if (err != noErr) {
  846.                             sprintf(errbuf,"%d", rsrcId);
  847.                             Tcl_AppendStringsToObj(resultPtr,
  848.     "error loading resource ",
  849.                                     errbuf, " of type ",
  850.                                     Tcl_GetStringFromObj(objv[i],&length),
  851.                                     " to overwrite it", (char *) NULL);
  852.                             goto writeDone;
  853.                      }
  854.                     }
  855.                      
  856.                     SetHandleSize(resource, length);
  857.                     if ( MemError() != noErr ) {
  858.                         panic("could not allocate memory to write resource");
  859.                     }
  861.                     HLock(resource);
  862.             memcpy(*resource, stringPtr, length);
  863.             HUnlock(resource);
  864.            
  865.                     ChangedResource(resource);
  866.                 
  867.                     /*
  868.                      * We also may have changed the name...
  869.                      */ 
  870.                  
  871.                     SetResInfo(resource, rsrcId, (StringPtr) resourceId);
  872.                 }
  873.             }
  874.             
  875.     err = ResError();
  876.     if (err != noErr) {
  877. Tcl_AppendStringsToObj(resultPtr,
  878. "error adding resource to resource map",
  879.         (char *) NULL);
  880. result = TCL_ERROR;
  881. goto writeDone;
  882.     }
  883.     
  884.     WriteResource(resource);
  885.     err = ResError();
  886.     if (err != noErr) {
  887. Tcl_AppendStringsToObj(resultPtr,
  888. "error writing resource to disk",
  889.         (char *) NULL);
  890. result = TCL_ERROR;
  891.     }
  892.     
  893.     writeDone:
  894.     
  895.     if (releaseIt) {
  896.         ReleaseResource(resource);
  897.         err = ResError();
  898.         if (err != noErr) {
  899.     Tcl_AppendStringsToObj(resultPtr,
  900.     "error releasing resource",
  901.             (char *) NULL);
  902.     result = TCL_ERROR;
  903.         }
  904.     }
  905.     
  906.     if (limitSearch) {
  907. UseResFile(saveRef);
  908.     }
  910.     return result;
  911. default:
  912.     panic("Tcl_GetIndexFromObj returned unrecognized option");
  913.     return TCL_ERROR; /* Should never be reached. */
  914.     }
  915. }
  917. /*
  918.  *----------------------------------------------------------------------
  919.  *
  920.  * Tcl_MacSourceObjCmd --
  921.  *
  922.  * This procedure is invoked to process the "source" Tcl command.
  923.  * See the user documentation for details on what it does.  In 
  924.  * addition, it supports sourceing from the resource fork of
  925.  * type 'TEXT'.
  926.  *
  927.  * Results:
  928.  * A standard Tcl result.
  929.  *
  930.  * Side effects:
  931.  * See the user documentation.
  932.  *
  933.  *----------------------------------------------------------------------
  934.  */
  936. int
  937. Tcl_MacSourceObjCmd(
  938.     ClientData dummy, /* Not used. */
  939.     Tcl_Interp *interp, /* Current interpreter. */
  940.     int objc, /* Number of arguments. */
  941.     Tcl_Obj *CONST objv[]) /* Argument objects. */
  942. {
  943.     char *errNum = "wrong # args: ";
  944.     char *errBad = "bad argument: ";
  945.     char *errStr;
  946.     char *fileName = NULL, *rsrcName = NULL;
  947.     long rsrcID = -1;
  948.     char *string;
  949.     int length;
  951.     if (objc < 2 || objc > 4)  {
  952.      errStr = errNum;
  953.      goto sourceFmtErr;
  954.     }
  955.     
  956.     if (objc == 2)  {
  957. return Tcl_FSEvalFile(interp, objv[1]);
  958.     }
  959.     
  960.     /*
  961.      * The following code supports a few older forms of this command
  962.      * for backward compatability.
  963.      */
  964.     string = Tcl_GetStringFromObj(objv[1], &length);
  965.     if (!strcmp(string, "-rsrc") || !strcmp(string, "-rsrcname")) {
  966. rsrcName = Tcl_GetStringFromObj(objv[2], &length);
  967.     } else if (!strcmp(string, "-rsrcid")) {
  968. if (Tcl_GetLongFromObj(interp, objv[2], &rsrcID) != TCL_OK) {
  969.     return TCL_ERROR;
  970. }
  971.     } else {
  972.      errStr = errBad;
  973.      goto sourceFmtErr;
  974.     }
  975.     
  976.     if (objc == 4) {
  977. fileName = Tcl_GetStringFromObj(objv[3], &length);
  978.     }
  979.     return Tcl_MacEvalResource(interp, rsrcName, rsrcID, fileName);
  981.     sourceFmtErr:
  982.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), errStr, "should be "",
  983. Tcl_GetString(objv[0]), " fileName" or "",
  984. Tcl_GetString(objv[0]), " -rsrc name ?fileName?" or "", 
  985. Tcl_GetString(objv[0]), " -rsrcid id ?fileName?"",
  986. (char *) NULL);
  987.     return TCL_ERROR;
  988. }
  990. /*
  991.  *----------------------------------------------------------------------
  992.  *
  993.  * Tcl_BeepObjCmd --
  994.  *
  995.  * This procedure makes the beep sound.
  996.  *
  997.  * Results:
  998.  * A standard Tcl result.
  999.  *
  1000.  * Side effects:
  1001.  * Makes a beep.
  1002.  *
  1003.  *----------------------------------------------------------------------
  1004.  */
  1006. int
  1007. Tcl_BeepObjCmd(
  1008.     ClientData dummy, /* Not used. */
  1009.     Tcl_Interp *interp, /* Current interpreter. */
  1010.     int objc, /* Number of arguments. */
  1011.     Tcl_Obj *CONST objv[]) /* Argument values. */
  1012. {
  1013.     Tcl_Obj *resultPtr, *objPtr;
  1014.     Handle sound;
  1015.     Str255 sndName;
  1016.     int volume = -1, length;
  1017.     char * sndArg = NULL;
  1019.     resultPtr = Tcl_GetObjResult(interp);
  1020.     if (objc == 1) {
  1021. SysBeep(1);
  1022. return TCL_OK;
  1023.     } else if (objc == 2) {
  1024. if (!strcmp(Tcl_GetStringFromObj(objv[1], &length), "-list")) {
  1025.     int count, i;
  1026.     short id;
  1027.     Str255 theName;
  1028.     ResType rezType;
  1030.     count = CountResources('snd ');
  1031.     for (i = 1; i <= count; i++) {
  1032. sound = GetIndResource('snd ', i);
  1033. if (sound != NULL) {
  1034.     GetResInfo(sound, &id, &rezType, theName);
  1035.     if (theName[0] == 0) {
  1036. continue;
  1037.     }
  1038.     objPtr = Tcl_NewStringObj((char *) theName + 1,
  1039.     theName[0]);
  1040.     Tcl_ListObjAppendElement(interp, resultPtr, objPtr);
  1041. }
  1042.     }
  1043.     return TCL_OK;
  1044. } else {
  1045.     sndArg = Tcl_GetStringFromObj(objv[1], &length);
  1046. }
  1047.     } else if (objc == 3) {
  1048. if (!strcmp(Tcl_GetStringFromObj(objv[1], &length), "-volume")) {
  1049.     Tcl_GetIntFromObj(interp, objv[2], &volume);
  1050. } else {
  1051.     goto beepUsage;
  1052. }
  1053.     } else if (objc == 4) {
  1054. if (!strcmp(Tcl_GetStringFromObj(objv[1], &length), "-volume")) {
  1055.     Tcl_GetIntFromObj(interp, objv[2], &volume);
  1056.     sndArg = Tcl_GetStringFromObj(objv[3], &length);
  1057. } else {
  1058.     goto beepUsage;
  1059. }
  1060.     } else {
  1061. goto beepUsage;
  1062.     }
  1064.     /*
  1065.      * Play the sound
  1066.      */
  1067.     if (sndArg == NULL) {
  1068. /*
  1069.          * Set Volume for SysBeep
  1070.          */
  1072. if (volume >= 0) {
  1073.     SetSoundVolume(volume, SYS_BEEP_VOLUME);
  1074. }
  1075. SysBeep(1);
  1077. /*
  1078.          * Reset Volume
  1079.          */
  1081. if (volume >= 0) {
  1082.     SetSoundVolume(0, RESET_VOLUME);
  1083. }
  1084.     } else {
  1085. strcpy((char *) sndName + 1, sndArg);
  1086. sndName[0] = length;
  1087. sound = GetNamedResource('snd ', sndName);
  1088. if (sound != NULL) {
  1089.     /*
  1090.              * Set Volume for Default Output device
  1091.              */
  1093.     if (volume >= 0) {
  1094. SetSoundVolume(volume, DEFAULT_SND_VOLUME);
  1095.     }
  1097.     SndPlay(NULL, (SndListHandle) sound, false);
  1099.     /*
  1100.              * Reset Volume
  1101.              */
  1103.     if (volume >= 0) {
  1104. SetSoundVolume(0, RESET_VOLUME);
  1105.     }
  1106. } else {
  1107.     Tcl_AppendStringsToObj(resultPtr, " "", sndArg, 
  1108.     "" is not a valid sound.  (Try ",
  1109.     Tcl_GetString(objv[0]), " -list)", NULL);
  1110.     return TCL_ERROR;
  1111. }
  1112.     }
  1114.     return TCL_OK;
  1116.     beepUsage:
  1117.     Tcl_WrongNumArgs(interp, 1, objv, "[-volume num] [-list | sndName]?");
  1118.     return TCL_ERROR;
  1119. }
  1121. /*
  1122.  *-----------------------------------------------------------------------------
  1123.  *
  1124.  * SetSoundVolume --
  1125.  *
  1126.  * Set the volume for either the SysBeep or the SndPlay call depending
  1127.  * on the value of mode (SYS_BEEP_VOLUME or DEFAULT_SND_VOLUME
  1128.  *      respectively.
  1129.  *
  1130.  *      It also stores the last channel set, and the old value of its 
  1131.  * VOLUME.  If you call SetSoundVolume with a mode of RESET_VOLUME, 
  1132.  * it will undo the last setting.  The volume parameter is
  1133.  *      ignored in this case.
  1134.  *
  1135.  * Side Effects:
  1136.  * Sets the System Volume
  1137.  *
  1138.  * Results:
  1139.  *      None
  1140.  *
  1141.  *-----------------------------------------------------------------------------
  1142.  */
  1144. void
  1145. SetSoundVolume(
  1146.     int volume,              /* This is the new volume */
  1147.     enum WhichVolume mode)   /* This flag says which volume to
  1148.       * set: SysBeep, SndPlay, or instructs us
  1149.       * to reset the volume */
  1150. {
  1151.     static int hasSM3 = -1;
  1152.     static enum WhichVolume oldMode;
  1153.     static long oldVolume = -1;
  1155.     /*
  1156.      * The volume setting calls only work if we have SoundManager
  1157.      * 3.0 or higher.  So we check that here.
  1158.      */
  1159.     
  1160.     if (hasSM3 == -1) {
  1161.      if (GetToolboxTrapAddress(_SoundDispatch) 
  1162. != GetToolboxTrapAddress(_Unimplemented)) {
  1163.     NumVersion SMVers = SndSoundManagerVersion();
  1164.     if (SMVers.majorRev > 2) {
  1165.      hasSM3 = 1;
  1166.     } else {
  1167. hasSM3 = 0;
  1168.     }
  1169. } else {
  1170.     /*
  1171.      * If the SoundDispatch trap is not present, then
  1172.      * we don't have the SoundManager at all.
  1173.      */
  1174.     
  1175.     hasSM3 = 0;
  1176. }
  1177.     }
  1178.     
  1179.     /*
  1180.      * If we don't have Sound Manager 3.0, we can't set the sound volume.
  1181.      * We will just ignore the request rather than raising an error.
  1182.      */
  1183.     
  1184.     if (!hasSM3) {
  1185.      return;
  1186.     }
  1187.     
  1188.     switch (mode) {
  1189.      case SYS_BEEP_VOLUME:
  1190.     GetSysBeepVolume(&oldVolume);
  1191.     SetSysBeepVolume(volume);
  1192.     oldMode = SYS_BEEP_VOLUME;
  1193.     break;
  1194. case DEFAULT_SND_VOLUME:
  1195.     GetDefaultOutputVolume(&oldVolume);
  1196.     SetDefaultOutputVolume(volume);
  1197.     oldMode = DEFAULT_SND_VOLUME;
  1198.     break;
  1199. case RESET_VOLUME:
  1200.     /*
  1201.      * If oldVolume is -1 someone has made a programming error
  1202.      * and called reset before setting the volume.  This is benign
  1203.      * however, so we will just exit.
  1204.      */
  1205.   
  1206.     if (oldVolume != -1) {
  1207.         if (oldMode == SYS_BEEP_VOLUME) {
  1208.          SetSysBeepVolume(oldVolume);
  1209.         } else if (oldMode == DEFAULT_SND_VOLUME) {
  1210.     SetDefaultOutputVolume(oldVolume);
  1211.         }
  1212.     }
  1213.     oldVolume = -1;
  1214.     }
  1215. }
  1217. /*
  1218.  *-----------------------------------------------------------------------------
  1219.  *
  1220.  * Tcl_MacEvalResource --
  1221.  *
  1222.  * Used to extend the source command.  Sources Tcl code from a Text
  1223.  * resource.  Currently only sources the resouce by name file ID may be
  1224.  * supported at a later date.
  1225.  *
  1226.  * Side Effects:
  1227.  * Depends on the Tcl code in the resource.
  1228.  *
  1229.  * Results:
  1230.  *      Returns a Tcl result.
  1231.  *
  1232.  *-----------------------------------------------------------------------------
  1233.  */
  1235. int
  1236. Tcl_MacEvalResource(
  1237.     Tcl_Interp *interp, /* Interpreter in which to process file. */
  1238.     CONST char *resourceName, /* Name of TEXT resource to source,
  1239.    NULL if number should be used. */
  1240.     int resourceNumber, /* Resource id of source. */
  1241.     CONST char *fileName) /* Name of file to process.
  1242.    NULL if application resource. */
  1243. {
  1244.     Handle sourceText;
  1245.     Str255 rezName;
  1246.     char msg[200];
  1247.     int result, iOpenedResFile = false;
  1248.     short saveRef, fileRef = -1;
  1249.     char idStr[64];
  1250.     FSSpec fileSpec;
  1251.     Tcl_DString ds, buffer;
  1252.     CONST char *nativeName;
  1254.     saveRef = CurResFile();
  1256.     if (fileName != NULL) {
  1257. OSErr err;
  1259. if (Tcl_TranslateFileName(interp, fileName, &buffer) == NULL) {
  1260.     return TCL_ERROR;
  1261. }
  1262. nativeName = Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&buffer), 
  1263.          Tcl_DStringLength(&buffer), &ds);
  1264. err = FSpLocationFromPath(strlen(nativeName), nativeName,
  1265.                 &fileSpec);
  1266. Tcl_DStringFree(&ds);
  1267. Tcl_DStringFree(&buffer);
  1268. if (err != noErr) {
  1269.     Tcl_AppendResult(interp, "Error finding the file: "", 
  1270. fileName, "".", NULL);
  1271.     return TCL_ERROR;
  1272. }
  1274. fileRef = FSpOpenResFileCompat(&fileSpec, fsRdPerm);
  1275. if (fileRef == -1) {
  1276.     Tcl_AppendResult(interp, "Error reading the file: "", 
  1277. fileName, "".", NULL);
  1278.     return TCL_ERROR;
  1279. }
  1281. UseResFile(fileRef);
  1282. iOpenedResFile = true;
  1283.     } else {
  1284. /*
  1285.  * The default behavior will search through all open resource files.
  1286.  * This may not be the behavior you desire.  If you want the behavior
  1287.  * of this call to *only* search the application resource fork, you
  1288.  * must call UseResFile at this point to set it to the application
  1289.  * file.  This means you must have already obtained the application's 
  1290.  * fileRef when the application started up.
  1291.  */
  1292.     }
  1294.     /*
  1295.      * Load the resource by name or ID
  1296.      */
  1297.     if (resourceName != NULL) {
  1298. Tcl_DString ds;
  1299. Tcl_UtfToExternalDString(NULL, resourceName, -1, &ds);
  1300. strcpy((char *) rezName + 1, Tcl_DStringValue(&ds));
  1301. rezName[0] = (unsigned) Tcl_DStringLength(&ds);
  1302. sourceText = GetNamedResource('TEXT', rezName);
  1303. Tcl_DStringFree(&ds);
  1304.     } else {
  1305. sourceText = GetResource('TEXT', (short) resourceNumber);
  1306.     }
  1308.     if (sourceText == NULL) {
  1309. result = TCL_ERROR;
  1310.     } else {
  1311. char *sourceStr = NULL;
  1313. HLock(sourceText);
  1314. sourceStr = Tcl_MacConvertTextResource(sourceText);
  1315. HUnlock(sourceText);
  1316. ReleaseResource(sourceText);
  1318. /*
  1319.  * We now evaluate the Tcl source
  1320.  */
  1321. result = Tcl_Eval(interp, sourceStr);
  1322. ckfree(sourceStr);
  1323. if (result == TCL_RETURN) {
  1324.     result = TCL_OK;
  1325. } else if (result == TCL_ERROR) {
  1326.     sprintf(msg, "n    (rsrc "%.150s" line %d)",
  1327.                     resourceName,
  1328.     interp->errorLine);
  1329.     Tcl_AddErrorInfo(interp, msg);
  1330. }
  1332. goto rezEvalCleanUp;
  1333.     }
  1335.     rezEvalError:
  1336.     sprintf(idStr, "ID=%d", resourceNumber);
  1337.     Tcl_AppendResult(interp, "The resource "",
  1338.     (resourceName != NULL ? resourceName : idStr),
  1339.     "" could not be loaded from ",
  1340.     (fileName != NULL ? fileName : "application"),
  1341.     ".", NULL);
  1343.     rezEvalCleanUp:
  1345.     /* 
  1346.      * TRICKY POINT: The code that you are sourcing here could load a
  1347.      * shared library.  This will go AHEAD of the resource we stored away
  1348.      * in saveRef on the resource path.  
  1349.      * If you restore the saveRef in this case, you will never be able
  1350.      * to get to the resources in the shared library, since you are now
  1351.      * pointing too far down on the resource list.  
  1352.      * So, we only reset the current resource file if WE opened a resource
  1353.      * explicitly, and then only if the CurResFile is still the 
  1354.      * one we opened... 
  1355.      */
  1356.      
  1357.     if (iOpenedResFile && (CurResFile() == fileRef)) {
  1358.         UseResFile(saveRef);
  1359.     }
  1361.     if (fileRef != -1) {
  1362. CloseResFile(fileRef);
  1363.     }
  1365.     return result;
  1366. }
  1368. /*
  1369.  *-----------------------------------------------------------------------------
  1370.  *
  1371.  * Tcl_MacConvertTextResource --
  1372.  *
  1373.  * Converts a TEXT resource into a Tcl suitable string.
  1374.  *
  1375.  * Side Effects:
  1376.  * Mallocs the returned memory, converts 'r' to 'n', and appends a NULL.
  1377.  *
  1378.  * Results:
  1379.  *      A new malloced string.
  1380.  *
  1381.  *-----------------------------------------------------------------------------
  1382.  */
  1384. char *
  1385. Tcl_MacConvertTextResource(
  1386.     Handle resource) /* Handle to TEXT resource. */
  1387. {
  1388.     int i, size;
  1389.     char *resultStr;
  1390.     Tcl_DString dstr;
  1392.     size = GetResourceSizeOnDisk(resource);
  1393.     
  1394.     Tcl_ExternalToUtfDString(NULL, *resource, size, &dstr);
  1396.     size = Tcl_DStringLength(&dstr) + 1;
  1397.     resultStr = (char *) ckalloc((unsigned) size);
  1398.     
  1399.     memcpy((VOID *) resultStr, (VOID *) Tcl_DStringValue(&dstr), (size_t) size);
  1400.     
  1401.     Tcl_DStringFree(&dstr);
  1402.     
  1403.     for (i=0; i<size; i++) {
  1404. if (resultStr[i] == 'r') {
  1405.     resultStr[i] = 'n';
  1406. }
  1407.     }
  1409.     return resultStr;
  1410. }
  1412. /*
  1413.  *-----------------------------------------------------------------------------
  1414.  *
  1415.  * Tcl_MacFindResource --
  1416.  *
  1417.  * Higher level interface for loading resources.
  1418.  *
  1419.  * Side Effects:
  1420.  * Attempts to load a resource.
  1421.  *
  1422.  * Results:
  1423.  *      A handle on success.
  1424.  *
  1425.  *-----------------------------------------------------------------------------
  1426.  */
  1428. Handle
  1429. Tcl_MacFindResource(
  1430.     Tcl_Interp *interp, /* Interpreter in which to process file. */
  1431.     long resourceType, /* Type of resource to load. */
  1432.     CONST char *resourceName, /* Name of resource to find,
  1433.  * NULL if number should be used. */
  1434.     int resourceNumber, /* Resource id of source. */
  1435.     CONST char *resFileRef, /* Registered resource file reference,
  1436.  * NULL if searching all open resource files. */
  1437.     int *releaseIt)         /* Should we release this resource when done. */
  1438. {
  1439.     Tcl_HashEntry *nameHashPtr;
  1440.     OpenResourceFork *resourceRef;
  1441.     int limitSearch = false;
  1442.     short saveRef;
  1443.     Handle resource;
  1445.     if (resFileRef != NULL) {
  1446. nameHashPtr = Tcl_FindHashEntry(&nameTable, resFileRef);
  1447. if (nameHashPtr == NULL) {
  1448.     Tcl_AppendResult(interp, "invalid resource file reference "",
  1449.      resFileRef, """, (char *) NULL);
  1450.     return NULL;
  1451. }
  1452. resourceRef = (OpenResourceFork *) Tcl_GetHashValue(nameHashPtr);
  1453. saveRef = CurResFile();
  1454. UseResFile((short) resourceRef->fileRef);
  1455. limitSearch = true;
  1456.     }
  1458.     /* 
  1459.      * Some system resources (for example system resources) should not 
  1460.      * be released.  So we set autoload to false, and try to get the resource.
  1461.      * If the Master Pointer of the returned handle is null, then resource was 
  1462.      * not in memory, and it is safe to release it.  Otherwise, it is not.
  1463.      */
  1464.     
  1465.     SetResLoad(false);
  1466.  
  1467.     if (resourceName == NULL) {
  1468. if (limitSearch) {
  1469.     resource = Get1Resource(resourceType, resourceNumber);
  1470. } else {
  1471.     resource = GetResource(resourceType, resourceNumber);
  1472. }
  1473.     } else {
  1474.      Str255 rezName;
  1475. Tcl_DString ds;
  1476. Tcl_UtfToExternalDString(NULL, resourceName, -1, &ds);
  1477. strcpy((char *) rezName + 1, Tcl_DStringValue(&ds));
  1478. rezName[0] = (unsigned) Tcl_DStringLength(&ds);
  1479. if (limitSearch) {
  1480.     resource = Get1NamedResource(resourceType,
  1481.     rezName);
  1482. } else {
  1483.     resource = GetNamedResource(resourceType,
  1484.     rezName);
  1485. }
  1486. Tcl_DStringFree(&ds);
  1487.     }
  1488.     
  1489.     if (resource != NULL && *resource == NULL) {
  1490.      *releaseIt = 1;
  1491.      LoadResource(resource);
  1492.     } else {
  1493.      *releaseIt = 0;
  1494.     }
  1495.     
  1496.     SetResLoad(true);
  1497.     
  1499.     if (limitSearch) {
  1500. UseResFile(saveRef);
  1501.     }
  1503.     return resource;
  1504. }
  1506. /*
  1507.  *----------------------------------------------------------------------
  1508.  *
  1509.  * ResourceInit --
  1510.  *
  1511.  * Initialize the structures used for resource management.
  1512.  *
  1513.  * Results:
  1514.  * None.
  1515.  *
  1516.  * Side effects:
  1517.  * Read the code.
  1518.  *
  1519.  *----------------------------------------------------------------------
  1520.  */
  1522. static void
  1523. ResourceInit()
  1524. {
  1526.     initialized = 1;
  1527.     Tcl_InitHashTable(&nameTable, TCL_STRING_KEYS);
  1528.     Tcl_InitHashTable(&resourceTable, TCL_ONE_WORD_KEYS);
  1529.     resourceForkList = Tcl_NewObj();
  1530.     Tcl_IncrRefCount(resourceForkList);
  1532.     BuildResourceForkList();
  1533.     
  1534. }
  1535. /***/
  1537. /*Tcl_RegisterObjType(typePtr) */
  1539. /*
  1540.  *----------------------------------------------------------------------
  1541.  *
  1542.  * Tcl_NewOSTypeObj --
  1543.  *
  1544.  * This procedure is used to create a new resource name type object.
  1545.  *
  1546.  * Results:
  1547.  * The newly created object is returned. This object will have a NULL
  1548.  * string representation. The returned object has ref count 0.
  1549.  *
  1550.  * Side effects:
  1551.  * None.
  1552.  *
  1553.  *----------------------------------------------------------------------
  1554.  */
  1556. Tcl_Obj *
  1557. Tcl_NewOSTypeObj(
  1558.     OSType newOSType) /* Int used to initialize the new object. */
  1559. {
  1560.     register Tcl_Obj *objPtr;
  1562.     if (!osTypeInit) {
  1563. osTypeInit = 1;
  1564. Tcl_RegisterObjType(&osType);
  1565.     }
  1567.     objPtr = Tcl_NewObj();
  1568.     objPtr->bytes = NULL;
  1569.     objPtr->internalRep.longValue = newOSType;
  1570.     objPtr->typePtr = &osType;
  1571.     return objPtr;
  1572. }
  1574. /*
  1575.  *----------------------------------------------------------------------
  1576.  *
  1577.  * Tcl_SetOSTypeObj --
  1578.  *
  1579.  * Modify an object to be a resource type and to have the 
  1580.  * specified long value.
  1581.  *
  1582.  * Results:
  1583.  * None.
  1584.  *
  1585.  * Side effects:
  1586.  * The object's old string rep, if any, is freed. Also, any old
  1587.  * internal rep is freed. 
  1588.  *
  1589.  *----------------------------------------------------------------------
  1590.  */
  1592. void
  1593. Tcl_SetOSTypeObj(
  1594.     Tcl_Obj *objPtr, /* Object whose internal rep to init. */
  1595.     OSType newOSType) /* Integer used to set object's value. */
  1596. {
  1597.     register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
  1599.     if (!osTypeInit) {
  1600. osTypeInit = 1;
  1601. Tcl_RegisterObjType(&osType);
  1602.     }
  1604.     if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
  1605. oldTypePtr->freeIntRepProc(objPtr);
  1606.     }
  1607.     
  1608.     objPtr->internalRep.longValue = newOSType;
  1609.     objPtr->typePtr = &osType;
  1611.     Tcl_InvalidateStringRep(objPtr);
  1612. }
  1614. /*
  1615.  *----------------------------------------------------------------------
  1616.  *
  1617.  * Tcl_GetOSTypeFromObj --
  1618.  *
  1619.  * Attempt to return an int from the Tcl object "objPtr". If the object
  1620.  * is not already an int, an attempt will be made to convert it to one.
  1621.  *
  1622.  * Results:
  1623.  * The return value is a standard Tcl object result. If an error occurs
  1624.  * during conversion, an error message is left in interp->objResult
  1625.  * unless "interp" is NULL.
  1626.  *
  1627.  * Side effects:
  1628.  * If the object is not already an int, the conversion will free
  1629.  * any old internal representation.
  1630.  *
  1631.  *----------------------------------------------------------------------
  1632.  */
  1634. int
  1635. Tcl_GetOSTypeFromObj(
  1636.     Tcl_Interp *interp,  /* Used for error reporting if not NULL. */
  1637.     Tcl_Obj *objPtr, /* The object from which to get a int. */
  1638.     OSType *osTypePtr) /* Place to store resulting int. */
  1639. {
  1640.     register int result;
  1641.     
  1642.     if (!osTypeInit) {
  1643. osTypeInit = 1;
  1644. Tcl_RegisterObjType(&osType);
  1645.     }
  1647.     if (objPtr->typePtr == &osType) {
  1648. *osTypePtr = objPtr->internalRep.longValue;
  1649. return TCL_OK;
  1650.     }
  1652.     result = SetOSTypeFromAny(interp, objPtr);
  1653.     if (result == TCL_OK) {
  1654. *osTypePtr = objPtr->internalRep.longValue;
  1655.     }
  1656.     return result;
  1657. }
  1659. /*
  1660.  *----------------------------------------------------------------------
  1661.  *
  1662.  * DupOSTypeInternalRep --
  1663.  *
  1664.  * Initialize the internal representation of an int Tcl_Obj to a
  1665.  * copy of the internal representation of an existing int object. 
  1666.  *
  1667.  * Results:
  1668.  * None.
  1669.  *
  1670.  * Side effects:
  1671.  * "copyPtr"s internal rep is set to the integer corresponding to
  1672.  * "srcPtr"s internal rep.
  1673.  *
  1674.  *----------------------------------------------------------------------
  1675.  */
  1677. static void
  1678. DupOSTypeInternalRep(
  1679.     Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
  1680.     Tcl_Obj *copyPtr) /* Object with internal rep to set. */
  1681. {
  1682.     copyPtr->internalRep.longValue = srcPtr->internalRep.longValue;
  1683.     copyPtr->typePtr = &osType;
  1684. }
  1686. /*
  1687.  *----------------------------------------------------------------------
  1688.  *
  1689.  * SetOSTypeFromAny --
  1690.  *
  1691.  * Attempt to generate an integer internal form for the Tcl object
  1692.  * "objPtr".
  1693.  *
  1694.  * Results:
  1695.  * The return value is a standard object Tcl result. If an error occurs
  1696.  * during conversion, an error message is left in interp->objResult
  1697.  * unless "interp" is NULL.
  1698.  *
  1699.  * Side effects:
  1700.  * If no error occurs, an int is stored as "objPtr"s internal
  1701.  * representation. 
  1702.  *
  1703.  *----------------------------------------------------------------------
  1704.  */
  1706. static int
  1707. SetOSTypeFromAny(
  1708.     Tcl_Interp *interp, /* Used for error reporting if not NULL. */
  1709.     Tcl_Obj *objPtr) /* The object to convert. */
  1710. {
  1711.     Tcl_ObjType *oldTypePtr = objPtr->typePtr;
  1712.     char *string;
  1713.     int length;
  1714.     long newOSType;
  1716.     /*
  1717.      * Get the string representation. Make it up-to-date if necessary.
  1718.      */
  1720.     string = Tcl_GetStringFromObj(objPtr, &length);
  1722.     if (length != 4) {
  1723. if (interp != NULL) {
  1724.     Tcl_ResetResult(interp);
  1725.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
  1726.     "expected Macintosh OS type but got "", string, """,
  1727.     (char *) NULL);
  1728. }
  1729. return TCL_ERROR;
  1730.     }
  1731.     newOSType =  *((long *) string);
  1732.     
  1733.     /*
  1734.      * The conversion to resource type succeeded. Free the old internalRep 
  1735.      * before setting the new one.
  1736.      */
  1738.     if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
  1739. oldTypePtr->freeIntRepProc(objPtr);
  1740.     }
  1741.     
  1742.     objPtr->internalRep.longValue = newOSType;
  1743.     objPtr->typePtr = &osType;
  1744.     return TCL_OK;
  1745. }
  1747. /*
  1748.  *----------------------------------------------------------------------
  1749.  *
  1750.  * UpdateStringOfOSType --
  1751.  *
  1752.  * Update the string representation for an resource type object.
  1753.  * Note: This procedure does not free an existing old string rep
  1754.  * so storage will be lost if this has not already been done. 
  1755.  *
  1756.  * Results:
  1757.  * None.
  1758.  *
  1759.  * Side effects:
  1760.  * The object's string is set to a valid string that results from
  1761.  * the int-to-string conversion.
  1762.  *
  1763.  *----------------------------------------------------------------------
  1764.  */
  1766. static void
  1767. UpdateStringOfOSType(
  1768.     register Tcl_Obj *objPtr) /* Int object whose string rep to update. */
  1769. {
  1770.     objPtr->bytes = ckalloc(5);
  1771.     sprintf(objPtr->bytes, "%-4.4s", &(objPtr->internalRep.longValue));
  1772.     objPtr->length = 4;
  1773. }
  1775. /*
  1776.  *----------------------------------------------------------------------
  1777.  *
  1778.  * GetRsrcRefFromObj --
  1779.  *
  1780.  * Given a String object containing a resource file token, return
  1781.  * the OpenResourceFork structure that it represents, or NULL if 
  1782.  * the token cannot be found.  If okayOnReadOnly is false, it will 
  1783.  *      also check whether the token corresponds to a read-only file, 
  1784.  *      and return NULL if it is.
  1785.  *
  1786.  * Results:
  1787.  * A pointer to an OpenResourceFork structure, or NULL.
  1788.  *
  1789.  * Side effects:
  1790.  * An error message may be left in resultPtr.
  1791.  *
  1792.  *----------------------------------------------------------------------
  1793.  */
  1795. static OpenResourceFork *
  1796. GetRsrcRefFromObj(
  1797.     register Tcl_Obj *objPtr, /* String obj containing file token     */
  1798.     int okayOnReadOnly,         /* Whether this operation is okay for a *
  1799.                                  * read only file.                      */
  1800.     const char *operation,      /* String containing the operation we   *
  1801.                                  * were trying to perform, used for errors */
  1802.     Tcl_Obj *resultPtr)         /* Tcl_Obj to contain error message     */
  1803. {
  1804.     char *stringPtr;
  1805.     Tcl_HashEntry *nameHashPtr;
  1806.     OpenResourceFork *resourceRef;
  1807.     int length;
  1808.     OSErr err;
  1809.     
  1810.     stringPtr = Tcl_GetStringFromObj(objPtr, &length);
  1811.     nameHashPtr = Tcl_FindHashEntry(&nameTable, stringPtr);
  1812.     if (nameHashPtr == NULL) {
  1813.         Tcl_AppendStringsToObj(resultPtr,
  1814.         "invalid resource file reference "",
  1815.         stringPtr, """, (char *) NULL);
  1816.         return NULL;
  1817.     }
  1819.     resourceRef = (OpenResourceFork *) Tcl_GetHashValue(nameHashPtr);
  1820.     
  1821.     if (!okayOnReadOnly) {
  1822.         err = GetResFileAttrs((short) resourceRef->fileRef);
  1823.         if (err & mapReadOnly) {
  1824.             Tcl_AppendStringsToObj(resultPtr, "cannot ", operation, 
  1825.                     " resource file "",
  1826.                     stringPtr, "", it was opened read only",
  1827.                     (char *) NULL);
  1828.             return NULL;
  1829.         }
  1830.     }
  1831.     return resourceRef;
  1832. }
  1834. /*
  1835.  *----------------------------------------------------------------------
  1836.  *
  1837.  * TclMacRegisterResourceFork --
  1838.  *
  1839.  * Register an open resource fork in the table of open resources 
  1840.  * managed by the procedures in this file.  If the resource file
  1841.  *      is already registered with the table, then no new token is made.
  1842.  *
  1843.  *      The behavior is controlled by the value of tokenPtr, and of the 
  1844.  * flags variable.  For tokenPtr, the possibilities are:
  1845.  *   - NULL: The new token is auto-generated, but not returned.
  1846.  *        - The string value of tokenPtr is the empty string: Then
  1847.  * the new token is auto-generated, and returned in tokenPtr
  1848.  *   - tokenPtr has a value: The string value will be used for the token,
  1849.  * unless it is already in use, in which case a new token will
  1850.  * be generated, and returned in tokenPtr.
  1851.  *
  1852.  *      For the flags variable:  it can be one of:
  1853.  *   - TCL_RESOURCE__INSERT_TAIL: The element is inserted at the
  1854.  *              end of the list of open resources.  Used only in Resource_Init.
  1855.  *   - TCL_RESOURCE_DONT_CLOSE: The resource close command will not close
  1856.  *         this resource.
  1857.  *   - TCL_RESOURCE_CHECK_IF_OPEN: This will check to see if this file's
  1858.  *         resource fork is already opened by this Tcl shell, and return 
  1859.  *         an error without registering the resource fork.
  1860.  *
  1861.  * Results:
  1862.  * Standard Tcl Result
  1863.  *
  1864.  * Side effects:
  1865.  * An entry may be added to the resource name table.
  1866.  *
  1867.  *----------------------------------------------------------------------
  1868.  */
  1870. int
  1871. TclMacRegisterResourceFork(
  1872.     short fileRef,         /* File ref for an open resource fork. */
  1873.     Tcl_Obj *tokenPtr, /* A Tcl Object to which to write the  *
  1874.  * new token */
  1875.     int flags)       /* 1 means insert at the head of the resource
  1876.                                  * fork list, 0 means at the tail */
  1878. {
  1879.     Tcl_HashEntry *resourceHashPtr;
  1880.     Tcl_HashEntry *nameHashPtr;
  1881.     OpenResourceFork *resourceRef;
  1882.     int new;
  1883.     char *resourceId = NULL;
  1884.    
  1885.     if (!initialized) {
  1886.         ResourceInit();
  1887.     }
  1888.     
  1889.     /*
  1890.      * If we were asked to, check that this file has not been opened
  1891.      * already with a different permission.  It it has, then return an error.
  1892.      */
  1893.      
  1894.     new = 1;
  1895.     
  1896.     if (flags & TCL_RESOURCE_CHECK_IF_OPEN) {
  1897.         Tcl_HashSearch search;
  1898.         short oldFileRef, filePermissionFlag;
  1899.         FCBPBRec newFileRec, oldFileRec;
  1900.         OSErr err;
  1901.         
  1902.         oldFileRec.ioCompletion = NULL;
  1903.         oldFileRec.ioFCBIndx = 0;
  1904.         oldFileRec.ioNamePtr = NULL;
  1905.         
  1906.         newFileRec.ioCompletion = NULL;
  1907.         newFileRec.ioFCBIndx = 0;
  1908.         newFileRec.ioNamePtr = NULL;
  1909.         newFileRec.ioVRefNum = 0;
  1910.         newFileRec.ioRefNum = fileRef;
  1911.         err = PBGetFCBInfo(&newFileRec, false);
  1912.         filePermissionFlag = ( newFileRec.ioFCBFlags >> 12 ) & 0x1;
  1913.             
  1914.         
  1915.         resourceHashPtr = Tcl_FirstHashEntry(&resourceTable, &search);
  1916.         while (resourceHashPtr != NULL) {
  1917.             oldFileRef = (short) Tcl_GetHashKey(&resourceTable,
  1918.                     resourceHashPtr);
  1919.             if (oldFileRef == fileRef) {
  1920.                 new = 0;
  1921.                 break;
  1922.             }
  1923.             oldFileRec.ioVRefNum = 0;
  1924.             oldFileRec.ioRefNum = oldFileRef;
  1925.             err = PBGetFCBInfo(&oldFileRec, false);
  1926.             
  1927.             /*
  1928.              * err might not be noErr either because the file has closed 
  1929.              * out from under us somehow, which is bad but we're not going
  1930.              * to fix it here, OR because it is the ROM MAP, which has a 
  1931.              * fileRef, but can't be gotten to by PBGetFCBInfo.
  1932.              */
  1933.             if ((err == noErr) 
  1934.                     && (newFileRec.ioFCBVRefNum == oldFileRec.ioFCBVRefNum)
  1935.                     && (newFileRec.ioFCBFlNm == oldFileRec.ioFCBFlNm)) {
  1936.                 /*
  1937.  * In MacOS 8.1 it seems like we get different file refs even
  1938.                  * though we pass the same file & permissions.  This is not
  1939.                  * what Inside Mac says should happen, but it does, so if it
  1940.                  * does, then close the new res file and return the original
  1941.                  * one...
  1942.  */
  1943.                  
  1944.                 if (filePermissionFlag == ((oldFileRec.ioFCBFlags >> 12) & 0x1)) {
  1945.                     CloseResFile(fileRef);
  1946.                     new = 0;
  1947.                     break;
  1948.                 } else {
  1949.                     if (tokenPtr != NULL) {
  1950.                         Tcl_SetStringObj(tokenPtr, "Resource already open with different permissions.", -1);
  1951.                     }   
  1952.                     return TCL_ERROR;
  1953.                 }
  1954.             }
  1955.             resourceHashPtr = Tcl_NextHashEntry(&search);
  1956.         }
  1957.     }
  1958.        
  1959.     
  1960.     /*
  1961.      * If the file has already been opened with these same permissions, then it
  1962.      * will be in our list and we will have set new to 0 above.
  1963.      * So we will just return the token (if tokenPtr is non-null)
  1964.      */
  1965.      
  1966.     if (new) {
  1967.         resourceHashPtr = Tcl_CreateHashEntry(&resourceTable,
  1968. (char *) fileRef, &new);
  1969.     }
  1970.     
  1971.     if (!new) {
  1972.         if (tokenPtr != NULL) {   
  1973.             resourceId = (char *) Tcl_GetHashValue(resourceHashPtr);
  1974.     Tcl_SetStringObj(tokenPtr, resourceId, -1);
  1975.         }
  1976.         return TCL_OK;
  1977.     }        
  1979.     /*
  1980.      * If we were passed in a result pointer which is not an empty
  1981.      * string, attempt to use that as the key.  If the key already
  1982.      * exists, silently fall back on resource%d...
  1983.      */
  1984.      
  1985.     if (tokenPtr != NULL) {
  1986.         char *tokenVal;
  1987.         int length;
  1988.         tokenVal = Tcl_GetStringFromObj(tokenPtr, &length);
  1989.         if (length > 0) {
  1990.             nameHashPtr = Tcl_FindHashEntry(&nameTable, tokenVal);
  1991.             if (nameHashPtr == NULL) {
  1992.                 resourceId = ckalloc(length + 1);
  1993.                 memcpy(resourceId, tokenVal, length);
  1994.                 resourceId[length] = '';
  1995.             }
  1996.         }
  1997.     }
  1998.     
  1999.     if (resourceId == NULL) {
  2000.         resourceId = (char *) ckalloc(15);
  2001.         sprintf(resourceId, "resource%d", newId);
  2002.     }
  2003.     
  2004.     Tcl_SetHashValue(resourceHashPtr, resourceId);
  2005.     newId++;
  2007.     nameHashPtr = Tcl_CreateHashEntry(&nameTable, resourceId, &new);
  2008.     if (!new) {
  2009. panic("resource id has repeated itself");
  2010.     }
  2011.     
  2012.     resourceRef = (OpenResourceFork *) ckalloc(sizeof(OpenResourceFork));
  2013.     resourceRef->fileRef = fileRef;
  2014.     resourceRef->flags = flags;
  2015.     
  2016.     Tcl_SetHashValue(nameHashPtr, (ClientData) resourceRef);
  2017.     if (tokenPtr != NULL) {
  2018.         Tcl_SetStringObj(tokenPtr, resourceId, -1);
  2019.     }
  2020.     
  2021.     if (flags & TCL_RESOURCE_INSERT_TAIL) {
  2022.         Tcl_ListObjAppendElement(NULL, resourceForkList, tokenPtr);
  2023.     } else {
  2024.         Tcl_ListObjReplace(NULL, resourceForkList, 0, 0, 1, &tokenPtr);
  2025.     }
  2026.     return TCL_OK;
  2027. }
  2029. /*
  2030.  *----------------------------------------------------------------------
  2031.  *
  2032.  * TclMacUnRegisterResourceFork --
  2033.  *
  2034.  * Removes the entry for an open resource fork from the table of 
  2035.  * open resources managed by the procedures in this file.
  2036.  *      If resultPtr is not NULL, it will be used for error reporting.
  2037.  *
  2038.  * Results:
  2039.  * The fileRef for this token, or -1 if an error occured.
  2040.  *
  2041.  * Side effects:
  2042.  * An entry is removed from the resource name table.
  2043.  *
  2044.  *----------------------------------------------------------------------
  2045.  */
  2047. short
  2048. TclMacUnRegisterResourceFork(
  2049.     char *tokenPtr,
  2050.     Tcl_Obj *resultPtr)
  2052. {
  2053.     Tcl_HashEntry *resourceHashPtr;
  2054.     Tcl_HashEntry *nameHashPtr;
  2055.     OpenResourceFork *resourceRef;
  2056.     char *resourceId = NULL;
  2057.     short fileRef;
  2058.     char *bytes;
  2059.     int i, match, index, listLen, length, elemLen;
  2060.     Tcl_Obj **elemPtrs;
  2061.     
  2062.      
  2063.     nameHashPtr = Tcl_FindHashEntry(&nameTable, tokenPtr);
  2064.     if (nameHashPtr == NULL) {
  2065.         if (resultPtr != NULL) {
  2066.     Tcl_AppendStringsToObj(resultPtr,
  2067.     "invalid resource file reference "",
  2068.     tokenPtr, """, (char *) NULL);
  2069.         }
  2070. return -1;
  2071.     }
  2072.     
  2073.     resourceRef = (OpenResourceFork *) Tcl_GetHashValue(nameHashPtr);
  2074.     fileRef = resourceRef->fileRef;
  2075.         
  2076.     if ( resourceRef->flags & TCL_RESOURCE_DONT_CLOSE ) {
  2077.         if (resultPtr != NULL) {
  2078.     Tcl_AppendStringsToObj(resultPtr,
  2079.     "can't close "", tokenPtr, "" resource file", 
  2080.     (char *) NULL);
  2081. }
  2082. return -1;
  2083.     }            
  2085.     Tcl_DeleteHashEntry(nameHashPtr);
  2086.     ckfree((char *) resourceRef);
  2087.     
  2088.     
  2089.     /* 
  2090.      * Now remove the resource from the resourceForkList object 
  2091.      */
  2092.      
  2093.     Tcl_ListObjGetElements(NULL, resourceForkList, &listLen, &elemPtrs);
  2094.     
  2095.  
  2096.     index = -1;
  2097.     length = strlen(tokenPtr);
  2098.     
  2099.     for (i = 0; i < listLen; i++) {
  2100. match = 0;
  2101. bytes = Tcl_GetStringFromObj(elemPtrs[i], &elemLen);
  2102. if (length == elemLen) {
  2103. match = (memcmp(bytes, tokenPtr,
  2104. (size_t) length) == 0);
  2105. }
  2106. if (match) {
  2107.     index = i;
  2108.     break;
  2109. }
  2110.     }
  2111.     if (!match) {
  2112.         panic("the resource Fork List is out of synch!");
  2113.     }
  2114.     
  2115.     Tcl_ListObjReplace(NULL, resourceForkList, index, 1, 0, NULL);
  2116.     
  2117.     resourceHashPtr = Tcl_FindHashEntry(&resourceTable, (char *) fileRef);
  2118.     
  2119.     if (resourceHashPtr == NULL) {
  2120. panic("Resource & Name tables are out of synch in resource command.");
  2121.     }
  2122.     ckfree(Tcl_GetHashValue(resourceHashPtr));
  2123.     Tcl_DeleteHashEntry(resourceHashPtr);
  2124.     
  2125.     return fileRef;
  2127. }
  2130. /*
  2131.  *----------------------------------------------------------------------
  2132.  *
  2133.  * BuildResourceForkList --
  2134.  *
  2135.  * Traverses the list of open resource forks, and builds the 
  2136.  * list of resources forks.  Also creates a resource token for any that 
  2137.  *      are opened but not registered with our resource system.
  2138.  *      This is based on code from Apple DTS.
  2139.  *
  2140.  * Results:
  2141.  * None.
  2142.  *
  2143.  * Side effects:
  2144.  *      The list of resource forks is updated.
  2145.  * The resource name table may be augmented.
  2146.  *
  2147.  *----------------------------------------------------------------------
  2148.  */
  2150. void
  2151. BuildResourceForkList()
  2152. {
  2153.     Handle currentMapHandle, mSysMapHandle;  
  2154.     Ptr tempPtr;
  2155.     FCBPBRec fileRec;
  2156.     char fileName[256];
  2157.     char appName[62];
  2158.     Tcl_Obj *nameObj;
  2159.     OSErr err;
  2160.     ProcessSerialNumber psn;
  2161.     ProcessInfoRec info;
  2162.     FSSpec fileSpec;
  2163.         
  2164.     /* 
  2165.      * Get the application name, so we can substitute
  2166.      * the token "application" for the application's resource.
  2167.      */ 
  2168.      
  2169.     GetCurrentProcess(&psn);
  2170.     info.processInfoLength = sizeof(ProcessInfoRec);
  2171.     info.processName = (StringPtr) &appName;
  2172.     info.processAppSpec = &fileSpec;
  2173.     GetProcessInformation(&psn, &info);
  2174.     p2cstr((StringPtr) appName);
  2176.     
  2177.     fileRec.ioCompletion = NULL;
  2178.     fileRec.ioVRefNum = 0;
  2179.     fileRec.ioFCBIndx = 0;
  2180.     fileRec.ioNamePtr = (StringPtr) &fileName;
  2181.     
  2182.     
  2183.     currentMapHandle = LMGetTopMapHndl();
  2184.     mSysMapHandle = LMGetSysMapHndl();
  2185.     
  2186.     while (1) {
  2187.         /* 
  2188.          * Now do the ones opened after the application.
  2189.          */
  2190.        
  2191.         nameObj = Tcl_NewObj();
  2192.         
  2193.         tempPtr = *currentMapHandle;
  2195.         fileRec.ioRefNum = *((short *) (tempPtr + 20));
  2196.         err = PBGetFCBInfo(&fileRec, false);
  2197.         
  2198.         if (err != noErr) {
  2199.             /*
  2200.              * The ROM resource map does not correspond to an opened file...
  2201.              */
  2202.              Tcl_SetStringObj(nameObj, "ROM Map", -1);
  2203.         } else {
  2204.             p2cstr((StringPtr) fileName);
  2205.             if (strcmp(fileName,appName) == 0) {
  2206.                 Tcl_SetStringObj(nameObj, "application", -1);
  2207.             } else {
  2208.                 Tcl_SetStringObj(nameObj, fileName, -1);
  2209.             }
  2210.             c2pstr(fileName);
  2211.         }
  2212.         
  2213.         TclMacRegisterResourceFork(fileRec.ioRefNum, nameObj, 
  2214.             TCL_RESOURCE_DONT_CLOSE | TCL_RESOURCE_INSERT_TAIL);
  2215.        
  2216.         if (currentMapHandle == mSysMapHandle) {
  2217.             break;
  2218.         }
  2219.         
  2220.         currentMapHandle = *((Handle *) (tempPtr + 16));
  2221.     }
  2222. }