os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/mac/tclMacResource.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/mac/tclMacResource.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,2222 @@
1.4 +/*
1.5 + * tclMacResource.c --
1.6 + *
1.7 + * This file contains several commands that manipulate or use
1.8 + * Macintosh resources. Included are extensions to the "source"
1.9 + * command, the mac specific "beep" and "resource" commands, and
1.10 + * administration for open resource file references.
1.11 + *
1.12 + * Copyright (c) 1996-1997 Sun Microsystems, Inc.
1.13 + *
1.14 + * See the file "license.terms" for information on usage and redistribution
1.15 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.16 + *
1.17 + * RCS: @(#) $Id: tclMacResource.c,v 1.14.2.1 2003/10/01 14:34:16 das Exp $
1.18 + */
1.19 +
1.20 +#include <Errors.h>
1.21 +#include <FSpCompat.h>
1.22 +#include <Processes.h>
1.23 +#include <Resources.h>
1.24 +#include <Sound.h>
1.25 +#include <Strings.h>
1.26 +#include <Traps.h>
1.27 +#include <LowMem.h>
1.28 +
1.29 +#include "FullPath.h"
1.30 +#include "tcl.h"
1.31 +#include "tclInt.h"
1.32 +#include "tclMac.h"
1.33 +#include "tclMacInt.h"
1.34 +#include "tclMacPort.h"
1.35 +
1.36 +/*
1.37 + * This flag tells the RegisterResource function to insert the
1.38 + * resource into the tail of the resource fork list. Needed only
1.39 + * Resource_Init.
1.40 + */
1.41 +
1.42 +#define TCL_RESOURCE_INSERT_TAIL 1
1.43 +/*
1.44 + * 2 is taken by TCL_RESOURCE_DONT_CLOSE
1.45 + * which is the only public flag to TclMacRegisterResourceFork.
1.46 + */
1.47 +
1.48 +#define TCL_RESOURCE_CHECK_IF_OPEN 4
1.49 +
1.50 +/*
1.51 + * Pass this in the mode parameter of SetSoundVolume to determine
1.52 + * which volume to set.
1.53 + */
1.54 +
1.55 +enum WhichVolume {
1.56 + SYS_BEEP_VOLUME, /* This sets the volume for SysBeep calls */
1.57 + DEFAULT_SND_VOLUME, /* This one for SndPlay calls */
1.58 + RESET_VOLUME /* And this undoes the last call to SetSoundVolume */
1.59 +};
1.60 +
1.61 +/*
1.62 + * Hash table to track open resource files.
1.63 + */
1.64 +
1.65 +typedef struct OpenResourceFork {
1.66 + short fileRef;
1.67 + int flags;
1.68 +} OpenResourceFork;
1.69 +
1.70 +
1.71 +
1.72 +static Tcl_HashTable nameTable; /* Id to process number mapping. */
1.73 +static Tcl_HashTable resourceTable; /* Process number to id mapping. */
1.74 +static Tcl_Obj *resourceForkList; /* Ordered list of resource forks */
1.75 +static int appResourceIndex; /* This is the index of the application*
1.76 + * in the list of resource forks */
1.77 +static int newId = 0; /* Id source. */
1.78 +static int initialized = 0; /* 0 means static structures haven't
1.79 + * been initialized yet. */
1.80 +static int osTypeInit = 0; /* 0 means Tcl object of osType hasn't
1.81 + * been initialized yet. */
1.82 +/*
1.83 + * Prototypes for procedures defined later in this file:
1.84 + */
1.85 +
1.86 +static void DupOSTypeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
1.87 + Tcl_Obj *copyPtr));
1.88 +static void ResourceInit _ANSI_ARGS_((void));
1.89 +static void BuildResourceForkList _ANSI_ARGS_((void));
1.90 +static int SetOSTypeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
1.91 + Tcl_Obj *objPtr));
1.92 +static void UpdateStringOfOSType _ANSI_ARGS_((Tcl_Obj *objPtr));
1.93 +static OpenResourceFork* GetRsrcRefFromObj _ANSI_ARGS_((Tcl_Obj *objPtr,
1.94 + int okayOnReadOnly, const char *operation,
1.95 + Tcl_Obj *resultPtr));
1.96 +
1.97 +static void SetSoundVolume(int volume, enum WhichVolume mode);
1.98 +
1.99 +/*
1.100 + * The structures below defines the Tcl object type defined in this file by
1.101 + * means of procedures that can be invoked by generic object code.
1.102 + */
1.103 +
1.104 +static Tcl_ObjType osType = {
1.105 + "ostype", /* name */
1.106 + (Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
1.107 + DupOSTypeInternalRep, /* dupIntRepProc */
1.108 + UpdateStringOfOSType, /* updateStringProc */
1.109 + SetOSTypeFromAny /* setFromAnyProc */
1.110 +};
1.111 +
1.112 +/*
1.113 + *----------------------------------------------------------------------
1.114 + *
1.115 + * Tcl_ResourceObjCmd --
1.116 + *
1.117 + * This procedure is invoked to process the "resource" Tcl command.
1.118 + * See the user documentation for details on what it does.
1.119 + *
1.120 + * Results:
1.121 + * A standard Tcl result.
1.122 + *
1.123 + * Side effects:
1.124 + * See the user documentation.
1.125 + *
1.126 + *----------------------------------------------------------------------
1.127 + */
1.128 +
1.129 +int
1.130 +Tcl_ResourceObjCmd(
1.131 + ClientData clientData, /* Not used. */
1.132 + Tcl_Interp *interp, /* Current interpreter. */
1.133 + int objc, /* Number of arguments. */
1.134 + Tcl_Obj *CONST objv[]) /* Argument values. */
1.135 +{
1.136 + Tcl_Obj *resultPtr, *objPtr;
1.137 + int index, result;
1.138 + long fileRef, rsrcId;
1.139 + FSSpec fileSpec;
1.140 + char *stringPtr;
1.141 + char errbuf[16];
1.142 + OpenResourceFork *resourceRef;
1.143 + Handle resource = NULL;
1.144 + OSErr err;
1.145 + int count, i, limitSearch = false, length;
1.146 + short id, saveRef, resInfo;
1.147 + Str255 theName;
1.148 + OSType rezType;
1.149 + int gotInt, releaseIt = 0, force;
1.150 + char *resourceId = NULL;
1.151 + long size;
1.152 + char macPermision;
1.153 + int mode;
1.154 +
1.155 + static CONST char *switches[] = {"close", "delete" ,"files", "list",
1.156 + "open", "read", "types", "write", (char *) NULL
1.157 + };
1.158 +
1.159 + enum {
1.160 + RESOURCE_CLOSE, RESOURCE_DELETE, RESOURCE_FILES, RESOURCE_LIST,
1.161 + RESOURCE_OPEN, RESOURCE_READ, RESOURCE_TYPES, RESOURCE_WRITE
1.162 + };
1.163 +
1.164 + static CONST char *writeSwitches[] = {
1.165 + "-id", "-name", "-file", "-force", (char *) NULL
1.166 + };
1.167 +
1.168 + enum {
1.169 + RESOURCE_WRITE_ID, RESOURCE_WRITE_NAME,
1.170 + RESOURCE_WRITE_FILE, RESOURCE_FORCE
1.171 + };
1.172 +
1.173 + static CONST char *deleteSwitches[] = {"-id", "-name", "-file", (char *) NULL};
1.174 +
1.175 + enum {RESOURCE_DELETE_ID, RESOURCE_DELETE_NAME, RESOURCE_DELETE_FILE};
1.176 +
1.177 + resultPtr = Tcl_GetObjResult(interp);
1.178 +
1.179 + if (objc < 2) {
1.180 + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
1.181 + return TCL_ERROR;
1.182 + }
1.183 +
1.184 + if (Tcl_GetIndexFromObj(interp, objv[1], switches, "option", 0, &index)
1.185 + != TCL_OK) {
1.186 + return TCL_ERROR;
1.187 + }
1.188 + if (!initialized) {
1.189 + ResourceInit();
1.190 + }
1.191 + result = TCL_OK;
1.192 +
1.193 + switch (index) {
1.194 + case RESOURCE_CLOSE:
1.195 + if (objc != 3) {
1.196 + Tcl_WrongNumArgs(interp, 2, objv, "resourceRef");
1.197 + return TCL_ERROR;
1.198 + }
1.199 + stringPtr = Tcl_GetStringFromObj(objv[2], &length);
1.200 + fileRef = TclMacUnRegisterResourceFork(stringPtr, resultPtr);
1.201 +
1.202 + if (fileRef >= 0) {
1.203 + CloseResFile((short) fileRef);
1.204 + return TCL_OK;
1.205 + } else {
1.206 + return TCL_ERROR;
1.207 + }
1.208 + case RESOURCE_DELETE:
1.209 + if (!((objc >= 3) && (objc <= 9) && ((objc % 2) == 1))) {
1.210 + Tcl_WrongNumArgs(interp, 2, objv,
1.211 + "?-id resourceId? ?-name resourceName? ?-file \
1.212 +resourceRef? resourceType");
1.213 + return TCL_ERROR;
1.214 + }
1.215 +
1.216 + i = 2;
1.217 + fileRef = -1;
1.218 + gotInt = false;
1.219 + resourceId = NULL;
1.220 + limitSearch = false;
1.221 +
1.222 + while (i < (objc - 2)) {
1.223 + if (Tcl_GetIndexFromObj(interp, objv[i], deleteSwitches,
1.224 + "option", 0, &index) != TCL_OK) {
1.225 + return TCL_ERROR;
1.226 + }
1.227 +
1.228 + switch (index) {
1.229 + case RESOURCE_DELETE_ID:
1.230 + if (Tcl_GetLongFromObj(interp, objv[i+1], &rsrcId)
1.231 + != TCL_OK) {
1.232 + return TCL_ERROR;
1.233 + }
1.234 + gotInt = true;
1.235 + break;
1.236 + case RESOURCE_DELETE_NAME:
1.237 + resourceId = Tcl_GetStringFromObj(objv[i+1], &length);
1.238 + if (length > 255) {
1.239 + Tcl_AppendStringsToObj(resultPtr,"-name argument ",
1.240 + "too long, must be < 255 characters",
1.241 + (char *) NULL);
1.242 + return TCL_ERROR;
1.243 + }
1.244 + strcpy((char *) theName, resourceId);
1.245 + resourceId = (char *) theName;
1.246 + c2pstr(resourceId);
1.247 + break;
1.248 + case RESOURCE_DELETE_FILE:
1.249 + resourceRef = GetRsrcRefFromObj(objv[i+1], 0,
1.250 + "delete from", resultPtr);
1.251 + if (resourceRef == NULL) {
1.252 + return TCL_ERROR;
1.253 + }
1.254 + limitSearch = true;
1.255 + break;
1.256 + }
1.257 + i += 2;
1.258 + }
1.259 +
1.260 + if ((resourceId == NULL) && !gotInt) {
1.261 + Tcl_AppendStringsToObj(resultPtr,"you must specify either ",
1.262 + "\"-id\" or \"-name\" or both ",
1.263 + "to \"resource delete\"",
1.264 + (char *) NULL);
1.265 + return TCL_ERROR;
1.266 + }
1.267 +
1.268 + if (Tcl_GetOSTypeFromObj(interp, objv[i], &rezType) != TCL_OK) {
1.269 + return TCL_ERROR;
1.270 + }
1.271 +
1.272 + if (limitSearch) {
1.273 + saveRef = CurResFile();
1.274 + UseResFile((short) resourceRef->fileRef);
1.275 + }
1.276 +
1.277 + SetResLoad(false);
1.278 +
1.279 + if (gotInt == true) {
1.280 + if (limitSearch) {
1.281 + resource = Get1Resource(rezType, rsrcId);
1.282 + } else {
1.283 + resource = GetResource(rezType, rsrcId);
1.284 + }
1.285 + err = ResError();
1.286 +
1.287 + if (err == resNotFound || resource == NULL) {
1.288 + Tcl_AppendStringsToObj(resultPtr, "resource not found",
1.289 + (char *) NULL);
1.290 + result = TCL_ERROR;
1.291 + goto deleteDone;
1.292 + } else if (err != noErr) {
1.293 + char buffer[16];
1.294 +
1.295 + sprintf(buffer, "%12d", err);
1.296 + Tcl_AppendStringsToObj(resultPtr, "resource error #",
1.297 + buffer, "occured while trying to find resource",
1.298 + (char *) NULL);
1.299 + result = TCL_ERROR;
1.300 + goto deleteDone;
1.301 + }
1.302 + }
1.303 +
1.304 + if (resourceId != NULL) {
1.305 + Handle tmpResource;
1.306 + if (limitSearch) {
1.307 + tmpResource = Get1NamedResource(rezType,
1.308 + (StringPtr) resourceId);
1.309 + } else {
1.310 + tmpResource = GetNamedResource(rezType,
1.311 + (StringPtr) resourceId);
1.312 + }
1.313 + err = ResError();
1.314 +
1.315 + if (err == resNotFound || tmpResource == NULL) {
1.316 + Tcl_AppendStringsToObj(resultPtr, "resource not found",
1.317 + (char *) NULL);
1.318 + result = TCL_ERROR;
1.319 + goto deleteDone;
1.320 + } else if (err != noErr) {
1.321 + char buffer[16];
1.322 +
1.323 + sprintf(buffer, "%12d", err);
1.324 + Tcl_AppendStringsToObj(resultPtr, "resource error #",
1.325 + buffer, "occured while trying to find resource",
1.326 + (char *) NULL);
1.327 + result = TCL_ERROR;
1.328 + goto deleteDone;
1.329 + }
1.330 +
1.331 + if (gotInt) {
1.332 + if (resource != tmpResource) {
1.333 + Tcl_AppendStringsToObj(resultPtr,
1.334 + "\"-id\" and \"-name\" ",
1.335 + "values do not point to the same resource",
1.336 + (char *) NULL);
1.337 + result = TCL_ERROR;
1.338 + goto deleteDone;
1.339 + }
1.340 + } else {
1.341 + resource = tmpResource;
1.342 + }
1.343 + }
1.344 +
1.345 + resInfo = GetResAttrs(resource);
1.346 +
1.347 + if ((resInfo & resProtected) == resProtected) {
1.348 + Tcl_AppendStringsToObj(resultPtr, "resource ",
1.349 + "cannot be deleted: it is protected.",
1.350 + (char *) NULL);
1.351 + result = TCL_ERROR;
1.352 + goto deleteDone;
1.353 + } else if ((resInfo & resSysHeap) == resSysHeap) {
1.354 + Tcl_AppendStringsToObj(resultPtr, "resource",
1.355 + "cannot be deleted: it is in the system heap.",
1.356 + (char *) NULL);
1.357 + result = TCL_ERROR;
1.358 + goto deleteDone;
1.359 + }
1.360 +
1.361 + /*
1.362 + * Find the resource file, if it was not specified,
1.363 + * so we can flush the changes now. Perhaps this is
1.364 + * a little paranoid, but better safe than sorry.
1.365 + */
1.366 +
1.367 + RemoveResource(resource);
1.368 +
1.369 + if (!limitSearch) {
1.370 + UpdateResFile(HomeResFile(resource));
1.371 + } else {
1.372 + UpdateResFile(resourceRef->fileRef);
1.373 + }
1.374 +
1.375 +
1.376 + deleteDone:
1.377 +
1.378 + SetResLoad(true);
1.379 + if (limitSearch) {
1.380 + UseResFile(saveRef);
1.381 + }
1.382 + return result;
1.383 +
1.384 + case RESOURCE_FILES:
1.385 + if ((objc < 2) || (objc > 3)) {
1.386 + Tcl_SetStringObj(resultPtr,
1.387 + "wrong # args: should be \"resource files \
1.388 +?resourceId?\"", -1);
1.389 + return TCL_ERROR;
1.390 + }
1.391 +
1.392 + if (objc == 2) {
1.393 + stringPtr = Tcl_GetStringFromObj(resourceForkList, &length);
1.394 + Tcl_SetStringObj(resultPtr, stringPtr, length);
1.395 + } else {
1.396 + FCBPBRec fileRec;
1.397 + Handle pathHandle;
1.398 + short pathLength;
1.399 + Str255 fileName;
1.400 + Tcl_DString dstr;
1.401 +
1.402 + if (strcmp(Tcl_GetString(objv[2]), "ROM Map") == 0) {
1.403 + Tcl_SetStringObj(resultPtr,"no file path for ROM Map", -1);
1.404 + return TCL_ERROR;
1.405 + }
1.406 +
1.407 + resourceRef = GetRsrcRefFromObj(objv[2], 1, "files", resultPtr);
1.408 + if (resourceRef == NULL) {
1.409 + return TCL_ERROR;
1.410 + }
1.411 +
1.412 + fileRec.ioCompletion = NULL;
1.413 + fileRec.ioFCBIndx = 0;
1.414 + fileRec.ioNamePtr = fileName;
1.415 + fileRec.ioVRefNum = 0;
1.416 + fileRec.ioRefNum = resourceRef->fileRef;
1.417 + err = PBGetFCBInfo(&fileRec, false);
1.418 + if (err != noErr) {
1.419 + Tcl_SetStringObj(resultPtr,
1.420 + "could not get FCB for resource file", -1);
1.421 + return TCL_ERROR;
1.422 + }
1.423 +
1.424 + err = GetFullPath(fileRec.ioFCBVRefNum, fileRec.ioFCBParID,
1.425 + fileRec.ioNamePtr, &pathLength, &pathHandle);
1.426 + if ( err != noErr) {
1.427 + Tcl_SetStringObj(resultPtr,
1.428 + "could not get file path from token", -1);
1.429 + return TCL_ERROR;
1.430 + }
1.431 +
1.432 + HLock(pathHandle);
1.433 + Tcl_ExternalToUtfDString(NULL, *pathHandle, pathLength, &dstr);
1.434 +
1.435 + Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr));
1.436 + HUnlock(pathHandle);
1.437 + DisposeHandle(pathHandle);
1.438 + Tcl_DStringFree(&dstr);
1.439 + }
1.440 + return TCL_OK;
1.441 + case RESOURCE_LIST:
1.442 + if (!((objc == 3) || (objc == 4))) {
1.443 + Tcl_WrongNumArgs(interp, 2, objv, "resourceType ?resourceRef?");
1.444 + return TCL_ERROR;
1.445 + }
1.446 + if (Tcl_GetOSTypeFromObj(interp, objv[2], &rezType) != TCL_OK) {
1.447 + return TCL_ERROR;
1.448 + }
1.449 +
1.450 + if (objc == 4) {
1.451 + resourceRef = GetRsrcRefFromObj(objv[3], 1,
1.452 + "list", resultPtr);
1.453 + if (resourceRef == NULL) {
1.454 + return TCL_ERROR;
1.455 + }
1.456 +
1.457 + saveRef = CurResFile();
1.458 + UseResFile((short) resourceRef->fileRef);
1.459 + limitSearch = true;
1.460 + }
1.461 +
1.462 + Tcl_ResetResult(interp);
1.463 + if (limitSearch) {
1.464 + count = Count1Resources(rezType);
1.465 + } else {
1.466 + count = CountResources(rezType);
1.467 + }
1.468 + SetResLoad(false);
1.469 + for (i = 1; i <= count; i++) {
1.470 + if (limitSearch) {
1.471 + resource = Get1IndResource(rezType, i);
1.472 + } else {
1.473 + resource = GetIndResource(rezType, i);
1.474 + }
1.475 + if (resource != NULL) {
1.476 + GetResInfo(resource, &id, (ResType *) &rezType, theName);
1.477 + if (theName[0] != 0) {
1.478 +
1.479 + objPtr = Tcl_NewStringObj((char *) theName + 1,
1.480 + theName[0]);
1.481 + } else {
1.482 + objPtr = Tcl_NewIntObj(id);
1.483 + }
1.484 + ReleaseResource(resource);
1.485 + result = Tcl_ListObjAppendElement(interp, resultPtr,
1.486 + objPtr);
1.487 + if (result != TCL_OK) {
1.488 + Tcl_DecrRefCount(objPtr);
1.489 + break;
1.490 + }
1.491 + }
1.492 + }
1.493 + SetResLoad(true);
1.494 +
1.495 + if (limitSearch) {
1.496 + UseResFile(saveRef);
1.497 + }
1.498 +
1.499 + return TCL_OK;
1.500 + case RESOURCE_OPEN: {
1.501 + Tcl_DString ds, buffer;
1.502 + CONST char *str, *native;
1.503 + int length;
1.504 +
1.505 + if (!((objc == 3) || (objc == 4))) {
1.506 + Tcl_WrongNumArgs(interp, 2, objv, "fileName ?permissions?");
1.507 + return TCL_ERROR;
1.508 + }
1.509 + str = Tcl_GetStringFromObj(objv[2], &length);
1.510 + if (Tcl_TranslateFileName(interp, str, &buffer) == NULL) {
1.511 + return TCL_ERROR;
1.512 + }
1.513 + native = Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&buffer),
1.514 + Tcl_DStringLength(&buffer), &ds);
1.515 + err = FSpLocationFromPath(Tcl_DStringLength(&ds), native, &fileSpec);
1.516 + Tcl_DStringFree(&ds);
1.517 + Tcl_DStringFree(&buffer);
1.518 +
1.519 + if (!((err == noErr) || (err == fnfErr))) {
1.520 + Tcl_AppendStringsToObj(resultPtr, "invalid path", (char *) NULL);
1.521 + return TCL_ERROR;
1.522 + }
1.523 +
1.524 + /*
1.525 + * Get permissions for the file. We really only understand
1.526 + * read-only and shared-read-write. If no permissions are
1.527 + * given we default to read only.
1.528 + */
1.529 +
1.530 + if (objc == 4) {
1.531 + stringPtr = Tcl_GetStringFromObj(objv[3], &length);
1.532 + mode = TclGetOpenMode(interp, stringPtr, &index);
1.533 + if (mode == -1) {
1.534 + /* TODO: TclGetOpenMode doesn't work with Obj commands. */
1.535 + return TCL_ERROR;
1.536 + }
1.537 + switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
1.538 + case O_RDONLY:
1.539 + macPermision = fsRdPerm;
1.540 + break;
1.541 + case O_WRONLY:
1.542 + case O_RDWR:
1.543 + macPermision = fsRdWrShPerm;
1.544 + break;
1.545 + default:
1.546 + panic("Tcl_ResourceObjCmd: invalid mode value");
1.547 + break;
1.548 + }
1.549 + } else {
1.550 + macPermision = fsRdPerm;
1.551 + }
1.552 +
1.553 + /*
1.554 + * Don't load in any of the resources in the file, this could
1.555 + * cause problems if you open a file that has CODE resources...
1.556 + */
1.557 +
1.558 + SetResLoad(false);
1.559 + fileRef = (long) FSpOpenResFileCompat(&fileSpec, macPermision);
1.560 + SetResLoad(true);
1.561 +
1.562 + if (fileRef == -1) {
1.563 + err = ResError();
1.564 + if (((err == fnfErr) || (err == eofErr)) &&
1.565 + (macPermision == fsRdWrShPerm)) {
1.566 + /*
1.567 + * No resource fork existed for this file. Since we are
1.568 + * opening it for writing we will create the resource fork
1.569 + * now.
1.570 + */
1.571 +
1.572 + HCreateResFile(fileSpec.vRefNum, fileSpec.parID,
1.573 + fileSpec.name);
1.574 + fileRef = (long) FSpOpenResFileCompat(&fileSpec,
1.575 + macPermision);
1.576 + if (fileRef == -1) {
1.577 + goto openError;
1.578 + }
1.579 + } else if (err == fnfErr) {
1.580 + Tcl_AppendStringsToObj(resultPtr,
1.581 + "file does not exist", (char *) NULL);
1.582 + return TCL_ERROR;
1.583 + } else if (err == eofErr) {
1.584 + Tcl_AppendStringsToObj(resultPtr,
1.585 + "file does not contain resource fork", (char *) NULL);
1.586 + return TCL_ERROR;
1.587 + } else {
1.588 + openError:
1.589 + Tcl_AppendStringsToObj(resultPtr,
1.590 + "error opening resource file", (char *) NULL);
1.591 + return TCL_ERROR;
1.592 + }
1.593 + }
1.594 +
1.595 + /*
1.596 + * The FspOpenResFile function does not set the ResFileAttrs.
1.597 + * Even if you open the file read only, the mapReadOnly
1.598 + * attribute is not set. This means we can't detect writes to a
1.599 + * read only resource fork until the write fails, which is bogus.
1.600 + * So set it here...
1.601 + */
1.602 +
1.603 + if (macPermision == fsRdPerm) {
1.604 + SetResFileAttrs(fileRef, mapReadOnly);
1.605 + }
1.606 +
1.607 + Tcl_SetStringObj(resultPtr, "", 0);
1.608 + if (TclMacRegisterResourceFork(fileRef, resultPtr,
1.609 + TCL_RESOURCE_CHECK_IF_OPEN) != TCL_OK) {
1.610 + CloseResFile(fileRef);
1.611 + return TCL_ERROR;
1.612 + }
1.613 + return TCL_OK;
1.614 + }
1.615 + case RESOURCE_READ:
1.616 + if (!((objc == 4) || (objc == 5))) {
1.617 + Tcl_WrongNumArgs(interp, 2, objv,
1.618 + "resourceType resourceId ?resourceRef?");
1.619 + return TCL_ERROR;
1.620 + }
1.621 +
1.622 + if (Tcl_GetOSTypeFromObj(interp, objv[2], &rezType) != TCL_OK) {
1.623 + return TCL_ERROR;
1.624 + }
1.625 +
1.626 + if (Tcl_GetLongFromObj((Tcl_Interp *) NULL, objv[3], &rsrcId)
1.627 + != TCL_OK) {
1.628 + resourceId = Tcl_GetStringFromObj(objv[3], &length);
1.629 + }
1.630 +
1.631 + if (objc == 5) {
1.632 + stringPtr = Tcl_GetStringFromObj(objv[4], &length);
1.633 + } else {
1.634 + stringPtr = NULL;
1.635 + }
1.636 +
1.637 + resource = Tcl_MacFindResource(interp, rezType, resourceId,
1.638 + rsrcId, stringPtr, &releaseIt);
1.639 +
1.640 + if (resource != NULL) {
1.641 + size = GetResourceSizeOnDisk(resource);
1.642 + Tcl_SetByteArrayObj(resultPtr, (unsigned char *) *resource, size);
1.643 +
1.644 + /*
1.645 + * Don't release the resource unless WE loaded it...
1.646 + */
1.647 +
1.648 + if (releaseIt) {
1.649 + ReleaseResource(resource);
1.650 + }
1.651 + return TCL_OK;
1.652 + } else {
1.653 + Tcl_AppendStringsToObj(resultPtr, "could not load resource",
1.654 + (char *) NULL);
1.655 + return TCL_ERROR;
1.656 + }
1.657 + case RESOURCE_TYPES:
1.658 + if (!((objc == 2) || (objc == 3))) {
1.659 + Tcl_WrongNumArgs(interp, 2, objv, "?resourceRef?");
1.660 + return TCL_ERROR;
1.661 + }
1.662 +
1.663 + if (objc == 3) {
1.664 + resourceRef = GetRsrcRefFromObj(objv[2], 1,
1.665 + "get types of", resultPtr);
1.666 + if (resourceRef == NULL) {
1.667 + return TCL_ERROR;
1.668 + }
1.669 +
1.670 + saveRef = CurResFile();
1.671 + UseResFile((short) resourceRef->fileRef);
1.672 + limitSearch = true;
1.673 + }
1.674 +
1.675 + if (limitSearch) {
1.676 + count = Count1Types();
1.677 + } else {
1.678 + count = CountTypes();
1.679 + }
1.680 + for (i = 1; i <= count; i++) {
1.681 + if (limitSearch) {
1.682 + Get1IndType((ResType *) &rezType, i);
1.683 + } else {
1.684 + GetIndType((ResType *) &rezType, i);
1.685 + }
1.686 + objPtr = Tcl_NewOSTypeObj(rezType);
1.687 + result = Tcl_ListObjAppendElement(interp, resultPtr, objPtr);
1.688 + if (result != TCL_OK) {
1.689 + Tcl_DecrRefCount(objPtr);
1.690 + break;
1.691 + }
1.692 + }
1.693 +
1.694 + if (limitSearch) {
1.695 + UseResFile(saveRef);
1.696 + }
1.697 +
1.698 + return result;
1.699 + case RESOURCE_WRITE:
1.700 + if ((objc < 4) || (objc > 11)) {
1.701 + Tcl_WrongNumArgs(interp, 2, objv,
1.702 + "?-id resourceId? ?-name resourceName? ?-file resourceRef?\
1.703 + ?-force? resourceType data");
1.704 + return TCL_ERROR;
1.705 + }
1.706 +
1.707 + i = 2;
1.708 + gotInt = false;
1.709 + resourceId = NULL;
1.710 + limitSearch = false;
1.711 + force = 0;
1.712 +
1.713 + while (i < (objc - 2)) {
1.714 + if (Tcl_GetIndexFromObj(interp, objv[i], writeSwitches,
1.715 + "switch", 0, &index) != TCL_OK) {
1.716 + return TCL_ERROR;
1.717 + }
1.718 +
1.719 + switch (index) {
1.720 + case RESOURCE_WRITE_ID:
1.721 + if (Tcl_GetLongFromObj(interp, objv[i+1], &rsrcId)
1.722 + != TCL_OK) {
1.723 + return TCL_ERROR;
1.724 + }
1.725 + gotInt = true;
1.726 + i += 2;
1.727 + break;
1.728 + case RESOURCE_WRITE_NAME:
1.729 + resourceId = Tcl_GetStringFromObj(objv[i+1], &length);
1.730 + strcpy((char *) theName, resourceId);
1.731 + resourceId = (char *) theName;
1.732 + c2pstr(resourceId);
1.733 + i += 2;
1.734 + break;
1.735 + case RESOURCE_WRITE_FILE:
1.736 + resourceRef = GetRsrcRefFromObj(objv[i+1], 0,
1.737 + "write to", resultPtr);
1.738 + if (resourceRef == NULL) {
1.739 + return TCL_ERROR;
1.740 + }
1.741 + limitSearch = true;
1.742 + i += 2;
1.743 + break;
1.744 + case RESOURCE_FORCE:
1.745 + force = 1;
1.746 + i += 1;
1.747 + break;
1.748 + }
1.749 + }
1.750 + if (Tcl_GetOSTypeFromObj(interp, objv[i], &rezType) != TCL_OK) {
1.751 + return TCL_ERROR;
1.752 + }
1.753 + stringPtr = (char *) Tcl_GetByteArrayFromObj(objv[i+1], &length);
1.754 +
1.755 + if (gotInt == false) {
1.756 + rsrcId = UniqueID(rezType);
1.757 + }
1.758 + if (resourceId == NULL) {
1.759 + resourceId = (char *) "\p";
1.760 + }
1.761 + if (limitSearch) {
1.762 + saveRef = CurResFile();
1.763 + UseResFile((short) resourceRef->fileRef);
1.764 + }
1.765 +
1.766 + /*
1.767 + * If we are adding the resource by number, then we must make sure
1.768 + * there is not already a resource of that number. We are not going
1.769 + * load it here, since we want to detect whether we loaded it or
1.770 + * not. Remember that releasing some resources in particular menu
1.771 + * related ones, can be fatal.
1.772 + */
1.773 +
1.774 + if (gotInt == true) {
1.775 + SetResLoad(false);
1.776 + resource = Get1Resource(rezType,rsrcId);
1.777 + SetResLoad(true);
1.778 + }
1.779 +
1.780 + if (resource == NULL) {
1.781 + /*
1.782 + * We get into this branch either if there was not already a
1.783 + * resource of this type & id, or the id was not specified.
1.784 + */
1.785 +
1.786 + resource = NewHandle(length);
1.787 + if (resource == NULL) {
1.788 + resource = NewHandleSys(length);
1.789 + if (resource == NULL) {
1.790 + panic("could not allocate memory to write resource");
1.791 + }
1.792 + }
1.793 + HLock(resource);
1.794 + memcpy(*resource, stringPtr, length);
1.795 + HUnlock(resource);
1.796 + AddResource(resource, rezType, (short) rsrcId,
1.797 + (StringPtr) resourceId);
1.798 + releaseIt = 1;
1.799 + } else {
1.800 + /*
1.801 + * We got here because there was a resource of this type
1.802 + * & ID in the file.
1.803 + */
1.804 +
1.805 + if (*resource == NULL) {
1.806 + releaseIt = 1;
1.807 + } else {
1.808 + releaseIt = 0;
1.809 + }
1.810 +
1.811 + if (!force) {
1.812 + /*
1.813 + *We only overwrite extant resources
1.814 + * when the -force flag has been set.
1.815 + */
1.816 +
1.817 + sprintf(errbuf,"%d", rsrcId);
1.818 +
1.819 + Tcl_AppendStringsToObj(resultPtr, "the resource ",
1.820 + errbuf, " already exists, use \"-force\"",
1.821 + " to overwrite it.", (char *) NULL);
1.822 +
1.823 + result = TCL_ERROR;
1.824 + goto writeDone;
1.825 + } else if (GetResAttrs(resource) & resProtected) {
1.826 + /*
1.827 + *
1.828 + * Next, check to see if it is protected...
1.829 + */
1.830 +
1.831 + sprintf(errbuf,"%d", rsrcId);
1.832 + Tcl_AppendStringsToObj(resultPtr,
1.833 + "could not write resource id ",
1.834 + errbuf, " of type ",
1.835 + Tcl_GetStringFromObj(objv[i],&length),
1.836 + ", it was protected.",(char *) NULL);
1.837 + result = TCL_ERROR;
1.838 + goto writeDone;
1.839 + } else {
1.840 + /*
1.841 + * Be careful, the resource might already be in memory
1.842 + * if something else loaded it.
1.843 + */
1.844 +
1.845 + if (*resource == 0) {
1.846 + LoadResource(resource);
1.847 + err = ResError();
1.848 + if (err != noErr) {
1.849 + sprintf(errbuf,"%d", rsrcId);
1.850 + Tcl_AppendStringsToObj(resultPtr,
1.851 + "error loading resource ",
1.852 + errbuf, " of type ",
1.853 + Tcl_GetStringFromObj(objv[i],&length),
1.854 + " to overwrite it", (char *) NULL);
1.855 + goto writeDone;
1.856 + }
1.857 + }
1.858 +
1.859 + SetHandleSize(resource, length);
1.860 + if ( MemError() != noErr ) {
1.861 + panic("could not allocate memory to write resource");
1.862 + }
1.863 +
1.864 + HLock(resource);
1.865 + memcpy(*resource, stringPtr, length);
1.866 + HUnlock(resource);
1.867 +
1.868 + ChangedResource(resource);
1.869 +
1.870 + /*
1.871 + * We also may have changed the name...
1.872 + */
1.873 +
1.874 + SetResInfo(resource, rsrcId, (StringPtr) resourceId);
1.875 + }
1.876 + }
1.877 +
1.878 + err = ResError();
1.879 + if (err != noErr) {
1.880 + Tcl_AppendStringsToObj(resultPtr,
1.881 + "error adding resource to resource map",
1.882 + (char *) NULL);
1.883 + result = TCL_ERROR;
1.884 + goto writeDone;
1.885 + }
1.886 +
1.887 + WriteResource(resource);
1.888 + err = ResError();
1.889 + if (err != noErr) {
1.890 + Tcl_AppendStringsToObj(resultPtr,
1.891 + "error writing resource to disk",
1.892 + (char *) NULL);
1.893 + result = TCL_ERROR;
1.894 + }
1.895 +
1.896 + writeDone:
1.897 +
1.898 + if (releaseIt) {
1.899 + ReleaseResource(resource);
1.900 + err = ResError();
1.901 + if (err != noErr) {
1.902 + Tcl_AppendStringsToObj(resultPtr,
1.903 + "error releasing resource",
1.904 + (char *) NULL);
1.905 + result = TCL_ERROR;
1.906 + }
1.907 + }
1.908 +
1.909 + if (limitSearch) {
1.910 + UseResFile(saveRef);
1.911 + }
1.912 +
1.913 + return result;
1.914 + default:
1.915 + panic("Tcl_GetIndexFromObj returned unrecognized option");
1.916 + return TCL_ERROR; /* Should never be reached. */
1.917 + }
1.918 +}
1.919 +
1.920 +/*
1.921 + *----------------------------------------------------------------------
1.922 + *
1.923 + * Tcl_MacSourceObjCmd --
1.924 + *
1.925 + * This procedure is invoked to process the "source" Tcl command.
1.926 + * See the user documentation for details on what it does. In
1.927 + * addition, it supports sourceing from the resource fork of
1.928 + * type 'TEXT'.
1.929 + *
1.930 + * Results:
1.931 + * A standard Tcl result.
1.932 + *
1.933 + * Side effects:
1.934 + * See the user documentation.
1.935 + *
1.936 + *----------------------------------------------------------------------
1.937 + */
1.938 +
1.939 +int
1.940 +Tcl_MacSourceObjCmd(
1.941 + ClientData dummy, /* Not used. */
1.942 + Tcl_Interp *interp, /* Current interpreter. */
1.943 + int objc, /* Number of arguments. */
1.944 + Tcl_Obj *CONST objv[]) /* Argument objects. */
1.945 +{
1.946 + char *errNum = "wrong # args: ";
1.947 + char *errBad = "bad argument: ";
1.948 + char *errStr;
1.949 + char *fileName = NULL, *rsrcName = NULL;
1.950 + long rsrcID = -1;
1.951 + char *string;
1.952 + int length;
1.953 +
1.954 + if (objc < 2 || objc > 4) {
1.955 + errStr = errNum;
1.956 + goto sourceFmtErr;
1.957 + }
1.958 +
1.959 + if (objc == 2) {
1.960 + return Tcl_FSEvalFile(interp, objv[1]);
1.961 + }
1.962 +
1.963 + /*
1.964 + * The following code supports a few older forms of this command
1.965 + * for backward compatability.
1.966 + */
1.967 + string = Tcl_GetStringFromObj(objv[1], &length);
1.968 + if (!strcmp(string, "-rsrc") || !strcmp(string, "-rsrcname")) {
1.969 + rsrcName = Tcl_GetStringFromObj(objv[2], &length);
1.970 + } else if (!strcmp(string, "-rsrcid")) {
1.971 + if (Tcl_GetLongFromObj(interp, objv[2], &rsrcID) != TCL_OK) {
1.972 + return TCL_ERROR;
1.973 + }
1.974 + } else {
1.975 + errStr = errBad;
1.976 + goto sourceFmtErr;
1.977 + }
1.978 +
1.979 + if (objc == 4) {
1.980 + fileName = Tcl_GetStringFromObj(objv[3], &length);
1.981 + }
1.982 + return Tcl_MacEvalResource(interp, rsrcName, rsrcID, fileName);
1.983 +
1.984 + sourceFmtErr:
1.985 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), errStr, "should be \"",
1.986 + Tcl_GetString(objv[0]), " fileName\" or \"",
1.987 + Tcl_GetString(objv[0]), " -rsrc name ?fileName?\" or \"",
1.988 + Tcl_GetString(objv[0]), " -rsrcid id ?fileName?\"",
1.989 + (char *) NULL);
1.990 + return TCL_ERROR;
1.991 +}
1.992 +
1.993 +/*
1.994 + *----------------------------------------------------------------------
1.995 + *
1.996 + * Tcl_BeepObjCmd --
1.997 + *
1.998 + * This procedure makes the beep sound.
1.999 + *
1.1000 + * Results:
1.1001 + * A standard Tcl result.
1.1002 + *
1.1003 + * Side effects:
1.1004 + * Makes a beep.
1.1005 + *
1.1006 + *----------------------------------------------------------------------
1.1007 + */
1.1008 +
1.1009 +int
1.1010 +Tcl_BeepObjCmd(
1.1011 + ClientData dummy, /* Not used. */
1.1012 + Tcl_Interp *interp, /* Current interpreter. */
1.1013 + int objc, /* Number of arguments. */
1.1014 + Tcl_Obj *CONST objv[]) /* Argument values. */
1.1015 +{
1.1016 + Tcl_Obj *resultPtr, *objPtr;
1.1017 + Handle sound;
1.1018 + Str255 sndName;
1.1019 + int volume = -1, length;
1.1020 + char * sndArg = NULL;
1.1021 +
1.1022 + resultPtr = Tcl_GetObjResult(interp);
1.1023 + if (objc == 1) {
1.1024 + SysBeep(1);
1.1025 + return TCL_OK;
1.1026 + } else if (objc == 2) {
1.1027 + if (!strcmp(Tcl_GetStringFromObj(objv[1], &length), "-list")) {
1.1028 + int count, i;
1.1029 + short id;
1.1030 + Str255 theName;
1.1031 + ResType rezType;
1.1032 +
1.1033 + count = CountResources('snd ');
1.1034 + for (i = 1; i <= count; i++) {
1.1035 + sound = GetIndResource('snd ', i);
1.1036 + if (sound != NULL) {
1.1037 + GetResInfo(sound, &id, &rezType, theName);
1.1038 + if (theName[0] == 0) {
1.1039 + continue;
1.1040 + }
1.1041 + objPtr = Tcl_NewStringObj((char *) theName + 1,
1.1042 + theName[0]);
1.1043 + Tcl_ListObjAppendElement(interp, resultPtr, objPtr);
1.1044 + }
1.1045 + }
1.1046 + return TCL_OK;
1.1047 + } else {
1.1048 + sndArg = Tcl_GetStringFromObj(objv[1], &length);
1.1049 + }
1.1050 + } else if (objc == 3) {
1.1051 + if (!strcmp(Tcl_GetStringFromObj(objv[1], &length), "-volume")) {
1.1052 + Tcl_GetIntFromObj(interp, objv[2], &volume);
1.1053 + } else {
1.1054 + goto beepUsage;
1.1055 + }
1.1056 + } else if (objc == 4) {
1.1057 + if (!strcmp(Tcl_GetStringFromObj(objv[1], &length), "-volume")) {
1.1058 + Tcl_GetIntFromObj(interp, objv[2], &volume);
1.1059 + sndArg = Tcl_GetStringFromObj(objv[3], &length);
1.1060 + } else {
1.1061 + goto beepUsage;
1.1062 + }
1.1063 + } else {
1.1064 + goto beepUsage;
1.1065 + }
1.1066 +
1.1067 + /*
1.1068 + * Play the sound
1.1069 + */
1.1070 + if (sndArg == NULL) {
1.1071 + /*
1.1072 + * Set Volume for SysBeep
1.1073 + */
1.1074 +
1.1075 + if (volume >= 0) {
1.1076 + SetSoundVolume(volume, SYS_BEEP_VOLUME);
1.1077 + }
1.1078 + SysBeep(1);
1.1079 +
1.1080 + /*
1.1081 + * Reset Volume
1.1082 + */
1.1083 +
1.1084 + if (volume >= 0) {
1.1085 + SetSoundVolume(0, RESET_VOLUME);
1.1086 + }
1.1087 + } else {
1.1088 + strcpy((char *) sndName + 1, sndArg);
1.1089 + sndName[0] = length;
1.1090 + sound = GetNamedResource('snd ', sndName);
1.1091 + if (sound != NULL) {
1.1092 + /*
1.1093 + * Set Volume for Default Output device
1.1094 + */
1.1095 +
1.1096 + if (volume >= 0) {
1.1097 + SetSoundVolume(volume, DEFAULT_SND_VOLUME);
1.1098 + }
1.1099 +
1.1100 + SndPlay(NULL, (SndListHandle) sound, false);
1.1101 +
1.1102 + /*
1.1103 + * Reset Volume
1.1104 + */
1.1105 +
1.1106 + if (volume >= 0) {
1.1107 + SetSoundVolume(0, RESET_VOLUME);
1.1108 + }
1.1109 + } else {
1.1110 + Tcl_AppendStringsToObj(resultPtr, " \"", sndArg,
1.1111 + "\" is not a valid sound. (Try ",
1.1112 + Tcl_GetString(objv[0]), " -list)", NULL);
1.1113 + return TCL_ERROR;
1.1114 + }
1.1115 + }
1.1116 +
1.1117 + return TCL_OK;
1.1118 +
1.1119 + beepUsage:
1.1120 + Tcl_WrongNumArgs(interp, 1, objv, "[-volume num] [-list | sndName]?");
1.1121 + return TCL_ERROR;
1.1122 +}
1.1123 +
1.1124 +/*
1.1125 + *-----------------------------------------------------------------------------
1.1126 + *
1.1127 + * SetSoundVolume --
1.1128 + *
1.1129 + * Set the volume for either the SysBeep or the SndPlay call depending
1.1130 + * on the value of mode (SYS_BEEP_VOLUME or DEFAULT_SND_VOLUME
1.1131 + * respectively.
1.1132 + *
1.1133 + * It also stores the last channel set, and the old value of its
1.1134 + * VOLUME. If you call SetSoundVolume with a mode of RESET_VOLUME,
1.1135 + * it will undo the last setting. The volume parameter is
1.1136 + * ignored in this case.
1.1137 + *
1.1138 + * Side Effects:
1.1139 + * Sets the System Volume
1.1140 + *
1.1141 + * Results:
1.1142 + * None
1.1143 + *
1.1144 + *-----------------------------------------------------------------------------
1.1145 + */
1.1146 +
1.1147 +void
1.1148 +SetSoundVolume(
1.1149 + int volume, /* This is the new volume */
1.1150 + enum WhichVolume mode) /* This flag says which volume to
1.1151 + * set: SysBeep, SndPlay, or instructs us
1.1152 + * to reset the volume */
1.1153 +{
1.1154 + static int hasSM3 = -1;
1.1155 + static enum WhichVolume oldMode;
1.1156 + static long oldVolume = -1;
1.1157 +
1.1158 + /*
1.1159 + * The volume setting calls only work if we have SoundManager
1.1160 + * 3.0 or higher. So we check that here.
1.1161 + */
1.1162 +
1.1163 + if (hasSM3 == -1) {
1.1164 + if (GetToolboxTrapAddress(_SoundDispatch)
1.1165 + != GetToolboxTrapAddress(_Unimplemented)) {
1.1166 + NumVersion SMVers = SndSoundManagerVersion();
1.1167 + if (SMVers.majorRev > 2) {
1.1168 + hasSM3 = 1;
1.1169 + } else {
1.1170 + hasSM3 = 0;
1.1171 + }
1.1172 + } else {
1.1173 + /*
1.1174 + * If the SoundDispatch trap is not present, then
1.1175 + * we don't have the SoundManager at all.
1.1176 + */
1.1177 +
1.1178 + hasSM3 = 0;
1.1179 + }
1.1180 + }
1.1181 +
1.1182 + /*
1.1183 + * If we don't have Sound Manager 3.0, we can't set the sound volume.
1.1184 + * We will just ignore the request rather than raising an error.
1.1185 + */
1.1186 +
1.1187 + if (!hasSM3) {
1.1188 + return;
1.1189 + }
1.1190 +
1.1191 + switch (mode) {
1.1192 + case SYS_BEEP_VOLUME:
1.1193 + GetSysBeepVolume(&oldVolume);
1.1194 + SetSysBeepVolume(volume);
1.1195 + oldMode = SYS_BEEP_VOLUME;
1.1196 + break;
1.1197 + case DEFAULT_SND_VOLUME:
1.1198 + GetDefaultOutputVolume(&oldVolume);
1.1199 + SetDefaultOutputVolume(volume);
1.1200 + oldMode = DEFAULT_SND_VOLUME;
1.1201 + break;
1.1202 + case RESET_VOLUME:
1.1203 + /*
1.1204 + * If oldVolume is -1 someone has made a programming error
1.1205 + * and called reset before setting the volume. This is benign
1.1206 + * however, so we will just exit.
1.1207 + */
1.1208 +
1.1209 + if (oldVolume != -1) {
1.1210 + if (oldMode == SYS_BEEP_VOLUME) {
1.1211 + SetSysBeepVolume(oldVolume);
1.1212 + } else if (oldMode == DEFAULT_SND_VOLUME) {
1.1213 + SetDefaultOutputVolume(oldVolume);
1.1214 + }
1.1215 + }
1.1216 + oldVolume = -1;
1.1217 + }
1.1218 +}
1.1219 +
1.1220 +/*
1.1221 + *-----------------------------------------------------------------------------
1.1222 + *
1.1223 + * Tcl_MacEvalResource --
1.1224 + *
1.1225 + * Used to extend the source command. Sources Tcl code from a Text
1.1226 + * resource. Currently only sources the resouce by name file ID may be
1.1227 + * supported at a later date.
1.1228 + *
1.1229 + * Side Effects:
1.1230 + * Depends on the Tcl code in the resource.
1.1231 + *
1.1232 + * Results:
1.1233 + * Returns a Tcl result.
1.1234 + *
1.1235 + *-----------------------------------------------------------------------------
1.1236 + */
1.1237 +
1.1238 +int
1.1239 +Tcl_MacEvalResource(
1.1240 + Tcl_Interp *interp, /* Interpreter in which to process file. */
1.1241 + CONST char *resourceName, /* Name of TEXT resource to source,
1.1242 + NULL if number should be used. */
1.1243 + int resourceNumber, /* Resource id of source. */
1.1244 + CONST char *fileName) /* Name of file to process.
1.1245 + NULL if application resource. */
1.1246 +{
1.1247 + Handle sourceText;
1.1248 + Str255 rezName;
1.1249 + char msg[200];
1.1250 + int result, iOpenedResFile = false;
1.1251 + short saveRef, fileRef = -1;
1.1252 + char idStr[64];
1.1253 + FSSpec fileSpec;
1.1254 + Tcl_DString ds, buffer;
1.1255 + CONST char *nativeName;
1.1256 +
1.1257 + saveRef = CurResFile();
1.1258 +
1.1259 + if (fileName != NULL) {
1.1260 + OSErr err;
1.1261 +
1.1262 + if (Tcl_TranslateFileName(interp, fileName, &buffer) == NULL) {
1.1263 + return TCL_ERROR;
1.1264 + }
1.1265 + nativeName = Tcl_UtfToExternalDString(NULL, Tcl_DStringValue(&buffer),
1.1266 + Tcl_DStringLength(&buffer), &ds);
1.1267 + err = FSpLocationFromPath(strlen(nativeName), nativeName,
1.1268 + &fileSpec);
1.1269 + Tcl_DStringFree(&ds);
1.1270 + Tcl_DStringFree(&buffer);
1.1271 + if (err != noErr) {
1.1272 + Tcl_AppendResult(interp, "Error finding the file: \"",
1.1273 + fileName, "\".", NULL);
1.1274 + return TCL_ERROR;
1.1275 + }
1.1276 +
1.1277 + fileRef = FSpOpenResFileCompat(&fileSpec, fsRdPerm);
1.1278 + if (fileRef == -1) {
1.1279 + Tcl_AppendResult(interp, "Error reading the file: \"",
1.1280 + fileName, "\".", NULL);
1.1281 + return TCL_ERROR;
1.1282 + }
1.1283 +
1.1284 + UseResFile(fileRef);
1.1285 + iOpenedResFile = true;
1.1286 + } else {
1.1287 + /*
1.1288 + * The default behavior will search through all open resource files.
1.1289 + * This may not be the behavior you desire. If you want the behavior
1.1290 + * of this call to *only* search the application resource fork, you
1.1291 + * must call UseResFile at this point to set it to the application
1.1292 + * file. This means you must have already obtained the application's
1.1293 + * fileRef when the application started up.
1.1294 + */
1.1295 + }
1.1296 +
1.1297 + /*
1.1298 + * Load the resource by name or ID
1.1299 + */
1.1300 + if (resourceName != NULL) {
1.1301 + Tcl_DString ds;
1.1302 + Tcl_UtfToExternalDString(NULL, resourceName, -1, &ds);
1.1303 + strcpy((char *) rezName + 1, Tcl_DStringValue(&ds));
1.1304 + rezName[0] = (unsigned) Tcl_DStringLength(&ds);
1.1305 + sourceText = GetNamedResource('TEXT', rezName);
1.1306 + Tcl_DStringFree(&ds);
1.1307 + } else {
1.1308 + sourceText = GetResource('TEXT', (short) resourceNumber);
1.1309 + }
1.1310 +
1.1311 + if (sourceText == NULL) {
1.1312 + result = TCL_ERROR;
1.1313 + } else {
1.1314 + char *sourceStr = NULL;
1.1315 +
1.1316 + HLock(sourceText);
1.1317 + sourceStr = Tcl_MacConvertTextResource(sourceText);
1.1318 + HUnlock(sourceText);
1.1319 + ReleaseResource(sourceText);
1.1320 +
1.1321 + /*
1.1322 + * We now evaluate the Tcl source
1.1323 + */
1.1324 + result = Tcl_Eval(interp, sourceStr);
1.1325 + ckfree(sourceStr);
1.1326 + if (result == TCL_RETURN) {
1.1327 + result = TCL_OK;
1.1328 + } else if (result == TCL_ERROR) {
1.1329 + sprintf(msg, "\n (rsrc \"%.150s\" line %d)",
1.1330 + resourceName,
1.1331 + interp->errorLine);
1.1332 + Tcl_AddErrorInfo(interp, msg);
1.1333 + }
1.1334 +
1.1335 + goto rezEvalCleanUp;
1.1336 + }
1.1337 +
1.1338 + rezEvalError:
1.1339 + sprintf(idStr, "ID=%d", resourceNumber);
1.1340 + Tcl_AppendResult(interp, "The resource \"",
1.1341 + (resourceName != NULL ? resourceName : idStr),
1.1342 + "\" could not be loaded from ",
1.1343 + (fileName != NULL ? fileName : "application"),
1.1344 + ".", NULL);
1.1345 +
1.1346 + rezEvalCleanUp:
1.1347 +
1.1348 + /*
1.1349 + * TRICKY POINT: The code that you are sourcing here could load a
1.1350 + * shared library. This will go AHEAD of the resource we stored away
1.1351 + * in saveRef on the resource path.
1.1352 + * If you restore the saveRef in this case, you will never be able
1.1353 + * to get to the resources in the shared library, since you are now
1.1354 + * pointing too far down on the resource list.
1.1355 + * So, we only reset the current resource file if WE opened a resource
1.1356 + * explicitly, and then only if the CurResFile is still the
1.1357 + * one we opened...
1.1358 + */
1.1359 +
1.1360 + if (iOpenedResFile && (CurResFile() == fileRef)) {
1.1361 + UseResFile(saveRef);
1.1362 + }
1.1363 +
1.1364 + if (fileRef != -1) {
1.1365 + CloseResFile(fileRef);
1.1366 + }
1.1367 +
1.1368 + return result;
1.1369 +}
1.1370 +
1.1371 +/*
1.1372 + *-----------------------------------------------------------------------------
1.1373 + *
1.1374 + * Tcl_MacConvertTextResource --
1.1375 + *
1.1376 + * Converts a TEXT resource into a Tcl suitable string.
1.1377 + *
1.1378 + * Side Effects:
1.1379 + * Mallocs the returned memory, converts '\r' to '\n', and appends a NULL.
1.1380 + *
1.1381 + * Results:
1.1382 + * A new malloced string.
1.1383 + *
1.1384 + *-----------------------------------------------------------------------------
1.1385 + */
1.1386 +
1.1387 +char *
1.1388 +Tcl_MacConvertTextResource(
1.1389 + Handle resource) /* Handle to TEXT resource. */
1.1390 +{
1.1391 + int i, size;
1.1392 + char *resultStr;
1.1393 + Tcl_DString dstr;
1.1394 +
1.1395 + size = GetResourceSizeOnDisk(resource);
1.1396 +
1.1397 + Tcl_ExternalToUtfDString(NULL, *resource, size, &dstr);
1.1398 +
1.1399 + size = Tcl_DStringLength(&dstr) + 1;
1.1400 + resultStr = (char *) ckalloc((unsigned) size);
1.1401 +
1.1402 + memcpy((VOID *) resultStr, (VOID *) Tcl_DStringValue(&dstr), (size_t) size);
1.1403 +
1.1404 + Tcl_DStringFree(&dstr);
1.1405 +
1.1406 + for (i=0; i<size; i++) {
1.1407 + if (resultStr[i] == '\r') {
1.1408 + resultStr[i] = '\n';
1.1409 + }
1.1410 + }
1.1411 +
1.1412 + return resultStr;
1.1413 +}
1.1414 +
1.1415 +/*
1.1416 + *-----------------------------------------------------------------------------
1.1417 + *
1.1418 + * Tcl_MacFindResource --
1.1419 + *
1.1420 + * Higher level interface for loading resources.
1.1421 + *
1.1422 + * Side Effects:
1.1423 + * Attempts to load a resource.
1.1424 + *
1.1425 + * Results:
1.1426 + * A handle on success.
1.1427 + *
1.1428 + *-----------------------------------------------------------------------------
1.1429 + */
1.1430 +
1.1431 +Handle
1.1432 +Tcl_MacFindResource(
1.1433 + Tcl_Interp *interp, /* Interpreter in which to process file. */
1.1434 + long resourceType, /* Type of resource to load. */
1.1435 + CONST char *resourceName, /* Name of resource to find,
1.1436 + * NULL if number should be used. */
1.1437 + int resourceNumber, /* Resource id of source. */
1.1438 + CONST char *resFileRef, /* Registered resource file reference,
1.1439 + * NULL if searching all open resource files. */
1.1440 + int *releaseIt) /* Should we release this resource when done. */
1.1441 +{
1.1442 + Tcl_HashEntry *nameHashPtr;
1.1443 + OpenResourceFork *resourceRef;
1.1444 + int limitSearch = false;
1.1445 + short saveRef;
1.1446 + Handle resource;
1.1447 +
1.1448 + if (resFileRef != NULL) {
1.1449 + nameHashPtr = Tcl_FindHashEntry(&nameTable, resFileRef);
1.1450 + if (nameHashPtr == NULL) {
1.1451 + Tcl_AppendResult(interp, "invalid resource file reference \"",
1.1452 + resFileRef, "\"", (char *) NULL);
1.1453 + return NULL;
1.1454 + }
1.1455 + resourceRef = (OpenResourceFork *) Tcl_GetHashValue(nameHashPtr);
1.1456 + saveRef = CurResFile();
1.1457 + UseResFile((short) resourceRef->fileRef);
1.1458 + limitSearch = true;
1.1459 + }
1.1460 +
1.1461 + /*
1.1462 + * Some system resources (for example system resources) should not
1.1463 + * be released. So we set autoload to false, and try to get the resource.
1.1464 + * If the Master Pointer of the returned handle is null, then resource was
1.1465 + * not in memory, and it is safe to release it. Otherwise, it is not.
1.1466 + */
1.1467 +
1.1468 + SetResLoad(false);
1.1469 +
1.1470 + if (resourceName == NULL) {
1.1471 + if (limitSearch) {
1.1472 + resource = Get1Resource(resourceType, resourceNumber);
1.1473 + } else {
1.1474 + resource = GetResource(resourceType, resourceNumber);
1.1475 + }
1.1476 + } else {
1.1477 + Str255 rezName;
1.1478 + Tcl_DString ds;
1.1479 + Tcl_UtfToExternalDString(NULL, resourceName, -1, &ds);
1.1480 + strcpy((char *) rezName + 1, Tcl_DStringValue(&ds));
1.1481 + rezName[0] = (unsigned) Tcl_DStringLength(&ds);
1.1482 + if (limitSearch) {
1.1483 + resource = Get1NamedResource(resourceType,
1.1484 + rezName);
1.1485 + } else {
1.1486 + resource = GetNamedResource(resourceType,
1.1487 + rezName);
1.1488 + }
1.1489 + Tcl_DStringFree(&ds);
1.1490 + }
1.1491 +
1.1492 + if (resource != NULL && *resource == NULL) {
1.1493 + *releaseIt = 1;
1.1494 + LoadResource(resource);
1.1495 + } else {
1.1496 + *releaseIt = 0;
1.1497 + }
1.1498 +
1.1499 + SetResLoad(true);
1.1500 +
1.1501 +
1.1502 + if (limitSearch) {
1.1503 + UseResFile(saveRef);
1.1504 + }
1.1505 +
1.1506 + return resource;
1.1507 +}
1.1508 +
1.1509 +/*
1.1510 + *----------------------------------------------------------------------
1.1511 + *
1.1512 + * ResourceInit --
1.1513 + *
1.1514 + * Initialize the structures used for resource management.
1.1515 + *
1.1516 + * Results:
1.1517 + * None.
1.1518 + *
1.1519 + * Side effects:
1.1520 + * Read the code.
1.1521 + *
1.1522 + *----------------------------------------------------------------------
1.1523 + */
1.1524 +
1.1525 +static void
1.1526 +ResourceInit()
1.1527 +{
1.1528 +
1.1529 + initialized = 1;
1.1530 + Tcl_InitHashTable(&nameTable, TCL_STRING_KEYS);
1.1531 + Tcl_InitHashTable(&resourceTable, TCL_ONE_WORD_KEYS);
1.1532 + resourceForkList = Tcl_NewObj();
1.1533 + Tcl_IncrRefCount(resourceForkList);
1.1534 +
1.1535 + BuildResourceForkList();
1.1536 +
1.1537 +}
1.1538 +/***/
1.1539 +
1.1540 +/*Tcl_RegisterObjType(typePtr) */
1.1541 +
1.1542 +/*
1.1543 + *----------------------------------------------------------------------
1.1544 + *
1.1545 + * Tcl_NewOSTypeObj --
1.1546 + *
1.1547 + * This procedure is used to create a new resource name type object.
1.1548 + *
1.1549 + * Results:
1.1550 + * The newly created object is returned. This object will have a NULL
1.1551 + * string representation. The returned object has ref count 0.
1.1552 + *
1.1553 + * Side effects:
1.1554 + * None.
1.1555 + *
1.1556 + *----------------------------------------------------------------------
1.1557 + */
1.1558 +
1.1559 +Tcl_Obj *
1.1560 +Tcl_NewOSTypeObj(
1.1561 + OSType newOSType) /* Int used to initialize the new object. */
1.1562 +{
1.1563 + register Tcl_Obj *objPtr;
1.1564 +
1.1565 + if (!osTypeInit) {
1.1566 + osTypeInit = 1;
1.1567 + Tcl_RegisterObjType(&osType);
1.1568 + }
1.1569 +
1.1570 + objPtr = Tcl_NewObj();
1.1571 + objPtr->bytes = NULL;
1.1572 + objPtr->internalRep.longValue = newOSType;
1.1573 + objPtr->typePtr = &osType;
1.1574 + return objPtr;
1.1575 +}
1.1576 +
1.1577 +/*
1.1578 + *----------------------------------------------------------------------
1.1579 + *
1.1580 + * Tcl_SetOSTypeObj --
1.1581 + *
1.1582 + * Modify an object to be a resource type and to have the
1.1583 + * specified long value.
1.1584 + *
1.1585 + * Results:
1.1586 + * None.
1.1587 + *
1.1588 + * Side effects:
1.1589 + * The object's old string rep, if any, is freed. Also, any old
1.1590 + * internal rep is freed.
1.1591 + *
1.1592 + *----------------------------------------------------------------------
1.1593 + */
1.1594 +
1.1595 +void
1.1596 +Tcl_SetOSTypeObj(
1.1597 + Tcl_Obj *objPtr, /* Object whose internal rep to init. */
1.1598 + OSType newOSType) /* Integer used to set object's value. */
1.1599 +{
1.1600 + register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
1.1601 +
1.1602 + if (!osTypeInit) {
1.1603 + osTypeInit = 1;
1.1604 + Tcl_RegisterObjType(&osType);
1.1605 + }
1.1606 +
1.1607 + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
1.1608 + oldTypePtr->freeIntRepProc(objPtr);
1.1609 + }
1.1610 +
1.1611 + objPtr->internalRep.longValue = newOSType;
1.1612 + objPtr->typePtr = &osType;
1.1613 +
1.1614 + Tcl_InvalidateStringRep(objPtr);
1.1615 +}
1.1616 +
1.1617 +/*
1.1618 + *----------------------------------------------------------------------
1.1619 + *
1.1620 + * Tcl_GetOSTypeFromObj --
1.1621 + *
1.1622 + * Attempt to return an int from the Tcl object "objPtr". If the object
1.1623 + * is not already an int, an attempt will be made to convert it to one.
1.1624 + *
1.1625 + * Results:
1.1626 + * The return value is a standard Tcl object result. If an error occurs
1.1627 + * during conversion, an error message is left in interp->objResult
1.1628 + * unless "interp" is NULL.
1.1629 + *
1.1630 + * Side effects:
1.1631 + * If the object is not already an int, the conversion will free
1.1632 + * any old internal representation.
1.1633 + *
1.1634 + *----------------------------------------------------------------------
1.1635 + */
1.1636 +
1.1637 +int
1.1638 +Tcl_GetOSTypeFromObj(
1.1639 + Tcl_Interp *interp, /* Used for error reporting if not NULL. */
1.1640 + Tcl_Obj *objPtr, /* The object from which to get a int. */
1.1641 + OSType *osTypePtr) /* Place to store resulting int. */
1.1642 +{
1.1643 + register int result;
1.1644 +
1.1645 + if (!osTypeInit) {
1.1646 + osTypeInit = 1;
1.1647 + Tcl_RegisterObjType(&osType);
1.1648 + }
1.1649 +
1.1650 + if (objPtr->typePtr == &osType) {
1.1651 + *osTypePtr = objPtr->internalRep.longValue;
1.1652 + return TCL_OK;
1.1653 + }
1.1654 +
1.1655 + result = SetOSTypeFromAny(interp, objPtr);
1.1656 + if (result == TCL_OK) {
1.1657 + *osTypePtr = objPtr->internalRep.longValue;
1.1658 + }
1.1659 + return result;
1.1660 +}
1.1661 +
1.1662 +/*
1.1663 + *----------------------------------------------------------------------
1.1664 + *
1.1665 + * DupOSTypeInternalRep --
1.1666 + *
1.1667 + * Initialize the internal representation of an int Tcl_Obj to a
1.1668 + * copy of the internal representation of an existing int object.
1.1669 + *
1.1670 + * Results:
1.1671 + * None.
1.1672 + *
1.1673 + * Side effects:
1.1674 + * "copyPtr"s internal rep is set to the integer corresponding to
1.1675 + * "srcPtr"s internal rep.
1.1676 + *
1.1677 + *----------------------------------------------------------------------
1.1678 + */
1.1679 +
1.1680 +static void
1.1681 +DupOSTypeInternalRep(
1.1682 + Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
1.1683 + Tcl_Obj *copyPtr) /* Object with internal rep to set. */
1.1684 +{
1.1685 + copyPtr->internalRep.longValue = srcPtr->internalRep.longValue;
1.1686 + copyPtr->typePtr = &osType;
1.1687 +}
1.1688 +
1.1689 +/*
1.1690 + *----------------------------------------------------------------------
1.1691 + *
1.1692 + * SetOSTypeFromAny --
1.1693 + *
1.1694 + * Attempt to generate an integer internal form for the Tcl object
1.1695 + * "objPtr".
1.1696 + *
1.1697 + * Results:
1.1698 + * The return value is a standard object Tcl result. If an error occurs
1.1699 + * during conversion, an error message is left in interp->objResult
1.1700 + * unless "interp" is NULL.
1.1701 + *
1.1702 + * Side effects:
1.1703 + * If no error occurs, an int is stored as "objPtr"s internal
1.1704 + * representation.
1.1705 + *
1.1706 + *----------------------------------------------------------------------
1.1707 + */
1.1708 +
1.1709 +static int
1.1710 +SetOSTypeFromAny(
1.1711 + Tcl_Interp *interp, /* Used for error reporting if not NULL. */
1.1712 + Tcl_Obj *objPtr) /* The object to convert. */
1.1713 +{
1.1714 + Tcl_ObjType *oldTypePtr = objPtr->typePtr;
1.1715 + char *string;
1.1716 + int length;
1.1717 + long newOSType;
1.1718 +
1.1719 + /*
1.1720 + * Get the string representation. Make it up-to-date if necessary.
1.1721 + */
1.1722 +
1.1723 + string = Tcl_GetStringFromObj(objPtr, &length);
1.1724 +
1.1725 + if (length != 4) {
1.1726 + if (interp != NULL) {
1.1727 + Tcl_ResetResult(interp);
1.1728 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1729 + "expected Macintosh OS type but got \"", string, "\"",
1.1730 + (char *) NULL);
1.1731 + }
1.1732 + return TCL_ERROR;
1.1733 + }
1.1734 + newOSType = *((long *) string);
1.1735 +
1.1736 + /*
1.1737 + * The conversion to resource type succeeded. Free the old internalRep
1.1738 + * before setting the new one.
1.1739 + */
1.1740 +
1.1741 + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
1.1742 + oldTypePtr->freeIntRepProc(objPtr);
1.1743 + }
1.1744 +
1.1745 + objPtr->internalRep.longValue = newOSType;
1.1746 + objPtr->typePtr = &osType;
1.1747 + return TCL_OK;
1.1748 +}
1.1749 +
1.1750 +/*
1.1751 + *----------------------------------------------------------------------
1.1752 + *
1.1753 + * UpdateStringOfOSType --
1.1754 + *
1.1755 + * Update the string representation for an resource type object.
1.1756 + * Note: This procedure does not free an existing old string rep
1.1757 + * so storage will be lost if this has not already been done.
1.1758 + *
1.1759 + * Results:
1.1760 + * None.
1.1761 + *
1.1762 + * Side effects:
1.1763 + * The object's string is set to a valid string that results from
1.1764 + * the int-to-string conversion.
1.1765 + *
1.1766 + *----------------------------------------------------------------------
1.1767 + */
1.1768 +
1.1769 +static void
1.1770 +UpdateStringOfOSType(
1.1771 + register Tcl_Obj *objPtr) /* Int object whose string rep to update. */
1.1772 +{
1.1773 + objPtr->bytes = ckalloc(5);
1.1774 + sprintf(objPtr->bytes, "%-4.4s", &(objPtr->internalRep.longValue));
1.1775 + objPtr->length = 4;
1.1776 +}
1.1777 +
1.1778 +/*
1.1779 + *----------------------------------------------------------------------
1.1780 + *
1.1781 + * GetRsrcRefFromObj --
1.1782 + *
1.1783 + * Given a String object containing a resource file token, return
1.1784 + * the OpenResourceFork structure that it represents, or NULL if
1.1785 + * the token cannot be found. If okayOnReadOnly is false, it will
1.1786 + * also check whether the token corresponds to a read-only file,
1.1787 + * and return NULL if it is.
1.1788 + *
1.1789 + * Results:
1.1790 + * A pointer to an OpenResourceFork structure, or NULL.
1.1791 + *
1.1792 + * Side effects:
1.1793 + * An error message may be left in resultPtr.
1.1794 + *
1.1795 + *----------------------------------------------------------------------
1.1796 + */
1.1797 +
1.1798 +static OpenResourceFork *
1.1799 +GetRsrcRefFromObj(
1.1800 + register Tcl_Obj *objPtr, /* String obj containing file token */
1.1801 + int okayOnReadOnly, /* Whether this operation is okay for a *
1.1802 + * read only file. */
1.1803 + const char *operation, /* String containing the operation we *
1.1804 + * were trying to perform, used for errors */
1.1805 + Tcl_Obj *resultPtr) /* Tcl_Obj to contain error message */
1.1806 +{
1.1807 + char *stringPtr;
1.1808 + Tcl_HashEntry *nameHashPtr;
1.1809 + OpenResourceFork *resourceRef;
1.1810 + int length;
1.1811 + OSErr err;
1.1812 +
1.1813 + stringPtr = Tcl_GetStringFromObj(objPtr, &length);
1.1814 + nameHashPtr = Tcl_FindHashEntry(&nameTable, stringPtr);
1.1815 + if (nameHashPtr == NULL) {
1.1816 + Tcl_AppendStringsToObj(resultPtr,
1.1817 + "invalid resource file reference \"",
1.1818 + stringPtr, "\"", (char *) NULL);
1.1819 + return NULL;
1.1820 + }
1.1821 +
1.1822 + resourceRef = (OpenResourceFork *) Tcl_GetHashValue(nameHashPtr);
1.1823 +
1.1824 + if (!okayOnReadOnly) {
1.1825 + err = GetResFileAttrs((short) resourceRef->fileRef);
1.1826 + if (err & mapReadOnly) {
1.1827 + Tcl_AppendStringsToObj(resultPtr, "cannot ", operation,
1.1828 + " resource file \"",
1.1829 + stringPtr, "\", it was opened read only",
1.1830 + (char *) NULL);
1.1831 + return NULL;
1.1832 + }
1.1833 + }
1.1834 + return resourceRef;
1.1835 +}
1.1836 +
1.1837 +/*
1.1838 + *----------------------------------------------------------------------
1.1839 + *
1.1840 + * TclMacRegisterResourceFork --
1.1841 + *
1.1842 + * Register an open resource fork in the table of open resources
1.1843 + * managed by the procedures in this file. If the resource file
1.1844 + * is already registered with the table, then no new token is made.
1.1845 + *
1.1846 + * The behavior is controlled by the value of tokenPtr, and of the
1.1847 + * flags variable. For tokenPtr, the possibilities are:
1.1848 + * - NULL: The new token is auto-generated, but not returned.
1.1849 + * - The string value of tokenPtr is the empty string: Then
1.1850 + * the new token is auto-generated, and returned in tokenPtr
1.1851 + * - tokenPtr has a value: The string value will be used for the token,
1.1852 + * unless it is already in use, in which case a new token will
1.1853 + * be generated, and returned in tokenPtr.
1.1854 + *
1.1855 + * For the flags variable: it can be one of:
1.1856 + * - TCL_RESOURCE__INSERT_TAIL: The element is inserted at the
1.1857 + * end of the list of open resources. Used only in Resource_Init.
1.1858 + * - TCL_RESOURCE_DONT_CLOSE: The resource close command will not close
1.1859 + * this resource.
1.1860 + * - TCL_RESOURCE_CHECK_IF_OPEN: This will check to see if this file's
1.1861 + * resource fork is already opened by this Tcl shell, and return
1.1862 + * an error without registering the resource fork.
1.1863 + *
1.1864 + * Results:
1.1865 + * Standard Tcl Result
1.1866 + *
1.1867 + * Side effects:
1.1868 + * An entry may be added to the resource name table.
1.1869 + *
1.1870 + *----------------------------------------------------------------------
1.1871 + */
1.1872 +
1.1873 +int
1.1874 +TclMacRegisterResourceFork(
1.1875 + short fileRef, /* File ref for an open resource fork. */
1.1876 + Tcl_Obj *tokenPtr, /* A Tcl Object to which to write the *
1.1877 + * new token */
1.1878 + int flags) /* 1 means insert at the head of the resource
1.1879 + * fork list, 0 means at the tail */
1.1880 +
1.1881 +{
1.1882 + Tcl_HashEntry *resourceHashPtr;
1.1883 + Tcl_HashEntry *nameHashPtr;
1.1884 + OpenResourceFork *resourceRef;
1.1885 + int new;
1.1886 + char *resourceId = NULL;
1.1887 +
1.1888 + if (!initialized) {
1.1889 + ResourceInit();
1.1890 + }
1.1891 +
1.1892 + /*
1.1893 + * If we were asked to, check that this file has not been opened
1.1894 + * already with a different permission. It it has, then return an error.
1.1895 + */
1.1896 +
1.1897 + new = 1;
1.1898 +
1.1899 + if (flags & TCL_RESOURCE_CHECK_IF_OPEN) {
1.1900 + Tcl_HashSearch search;
1.1901 + short oldFileRef, filePermissionFlag;
1.1902 + FCBPBRec newFileRec, oldFileRec;
1.1903 + OSErr err;
1.1904 +
1.1905 + oldFileRec.ioCompletion = NULL;
1.1906 + oldFileRec.ioFCBIndx = 0;
1.1907 + oldFileRec.ioNamePtr = NULL;
1.1908 +
1.1909 + newFileRec.ioCompletion = NULL;
1.1910 + newFileRec.ioFCBIndx = 0;
1.1911 + newFileRec.ioNamePtr = NULL;
1.1912 + newFileRec.ioVRefNum = 0;
1.1913 + newFileRec.ioRefNum = fileRef;
1.1914 + err = PBGetFCBInfo(&newFileRec, false);
1.1915 + filePermissionFlag = ( newFileRec.ioFCBFlags >> 12 ) & 0x1;
1.1916 +
1.1917 +
1.1918 + resourceHashPtr = Tcl_FirstHashEntry(&resourceTable, &search);
1.1919 + while (resourceHashPtr != NULL) {
1.1920 + oldFileRef = (short) Tcl_GetHashKey(&resourceTable,
1.1921 + resourceHashPtr);
1.1922 + if (oldFileRef == fileRef) {
1.1923 + new = 0;
1.1924 + break;
1.1925 + }
1.1926 + oldFileRec.ioVRefNum = 0;
1.1927 + oldFileRec.ioRefNum = oldFileRef;
1.1928 + err = PBGetFCBInfo(&oldFileRec, false);
1.1929 +
1.1930 + /*
1.1931 + * err might not be noErr either because the file has closed
1.1932 + * out from under us somehow, which is bad but we're not going
1.1933 + * to fix it here, OR because it is the ROM MAP, which has a
1.1934 + * fileRef, but can't be gotten to by PBGetFCBInfo.
1.1935 + */
1.1936 + if ((err == noErr)
1.1937 + && (newFileRec.ioFCBVRefNum == oldFileRec.ioFCBVRefNum)
1.1938 + && (newFileRec.ioFCBFlNm == oldFileRec.ioFCBFlNm)) {
1.1939 + /*
1.1940 + * In MacOS 8.1 it seems like we get different file refs even
1.1941 + * though we pass the same file & permissions. This is not
1.1942 + * what Inside Mac says should happen, but it does, so if it
1.1943 + * does, then close the new res file and return the original
1.1944 + * one...
1.1945 + */
1.1946 +
1.1947 + if (filePermissionFlag == ((oldFileRec.ioFCBFlags >> 12) & 0x1)) {
1.1948 + CloseResFile(fileRef);
1.1949 + new = 0;
1.1950 + break;
1.1951 + } else {
1.1952 + if (tokenPtr != NULL) {
1.1953 + Tcl_SetStringObj(tokenPtr, "Resource already open with different permissions.", -1);
1.1954 + }
1.1955 + return TCL_ERROR;
1.1956 + }
1.1957 + }
1.1958 + resourceHashPtr = Tcl_NextHashEntry(&search);
1.1959 + }
1.1960 + }
1.1961 +
1.1962 +
1.1963 + /*
1.1964 + * If the file has already been opened with these same permissions, then it
1.1965 + * will be in our list and we will have set new to 0 above.
1.1966 + * So we will just return the token (if tokenPtr is non-null)
1.1967 + */
1.1968 +
1.1969 + if (new) {
1.1970 + resourceHashPtr = Tcl_CreateHashEntry(&resourceTable,
1.1971 + (char *) fileRef, &new);
1.1972 + }
1.1973 +
1.1974 + if (!new) {
1.1975 + if (tokenPtr != NULL) {
1.1976 + resourceId = (char *) Tcl_GetHashValue(resourceHashPtr);
1.1977 + Tcl_SetStringObj(tokenPtr, resourceId, -1);
1.1978 + }
1.1979 + return TCL_OK;
1.1980 + }
1.1981 +
1.1982 + /*
1.1983 + * If we were passed in a result pointer which is not an empty
1.1984 + * string, attempt to use that as the key. If the key already
1.1985 + * exists, silently fall back on resource%d...
1.1986 + */
1.1987 +
1.1988 + if (tokenPtr != NULL) {
1.1989 + char *tokenVal;
1.1990 + int length;
1.1991 + tokenVal = Tcl_GetStringFromObj(tokenPtr, &length);
1.1992 + if (length > 0) {
1.1993 + nameHashPtr = Tcl_FindHashEntry(&nameTable, tokenVal);
1.1994 + if (nameHashPtr == NULL) {
1.1995 + resourceId = ckalloc(length + 1);
1.1996 + memcpy(resourceId, tokenVal, length);
1.1997 + resourceId[length] = '\0';
1.1998 + }
1.1999 + }
1.2000 + }
1.2001 +
1.2002 + if (resourceId == NULL) {
1.2003 + resourceId = (char *) ckalloc(15);
1.2004 + sprintf(resourceId, "resource%d", newId);
1.2005 + }
1.2006 +
1.2007 + Tcl_SetHashValue(resourceHashPtr, resourceId);
1.2008 + newId++;
1.2009 +
1.2010 + nameHashPtr = Tcl_CreateHashEntry(&nameTable, resourceId, &new);
1.2011 + if (!new) {
1.2012 + panic("resource id has repeated itself");
1.2013 + }
1.2014 +
1.2015 + resourceRef = (OpenResourceFork *) ckalloc(sizeof(OpenResourceFork));
1.2016 + resourceRef->fileRef = fileRef;
1.2017 + resourceRef->flags = flags;
1.2018 +
1.2019 + Tcl_SetHashValue(nameHashPtr, (ClientData) resourceRef);
1.2020 + if (tokenPtr != NULL) {
1.2021 + Tcl_SetStringObj(tokenPtr, resourceId, -1);
1.2022 + }
1.2023 +
1.2024 + if (flags & TCL_RESOURCE_INSERT_TAIL) {
1.2025 + Tcl_ListObjAppendElement(NULL, resourceForkList, tokenPtr);
1.2026 + } else {
1.2027 + Tcl_ListObjReplace(NULL, resourceForkList, 0, 0, 1, &tokenPtr);
1.2028 + }
1.2029 + return TCL_OK;
1.2030 +}
1.2031 +
1.2032 +/*
1.2033 + *----------------------------------------------------------------------
1.2034 + *
1.2035 + * TclMacUnRegisterResourceFork --
1.2036 + *
1.2037 + * Removes the entry for an open resource fork from the table of
1.2038 + * open resources managed by the procedures in this file.
1.2039 + * If resultPtr is not NULL, it will be used for error reporting.
1.2040 + *
1.2041 + * Results:
1.2042 + * The fileRef for this token, or -1 if an error occured.
1.2043 + *
1.2044 + * Side effects:
1.2045 + * An entry is removed from the resource name table.
1.2046 + *
1.2047 + *----------------------------------------------------------------------
1.2048 + */
1.2049 +
1.2050 +short
1.2051 +TclMacUnRegisterResourceFork(
1.2052 + char *tokenPtr,
1.2053 + Tcl_Obj *resultPtr)
1.2054 +
1.2055 +{
1.2056 + Tcl_HashEntry *resourceHashPtr;
1.2057 + Tcl_HashEntry *nameHashPtr;
1.2058 + OpenResourceFork *resourceRef;
1.2059 + char *resourceId = NULL;
1.2060 + short fileRef;
1.2061 + char *bytes;
1.2062 + int i, match, index, listLen, length, elemLen;
1.2063 + Tcl_Obj **elemPtrs;
1.2064 +
1.2065 +
1.2066 + nameHashPtr = Tcl_FindHashEntry(&nameTable, tokenPtr);
1.2067 + if (nameHashPtr == NULL) {
1.2068 + if (resultPtr != NULL) {
1.2069 + Tcl_AppendStringsToObj(resultPtr,
1.2070 + "invalid resource file reference \"",
1.2071 + tokenPtr, "\"", (char *) NULL);
1.2072 + }
1.2073 + return -1;
1.2074 + }
1.2075 +
1.2076 + resourceRef = (OpenResourceFork *) Tcl_GetHashValue(nameHashPtr);
1.2077 + fileRef = resourceRef->fileRef;
1.2078 +
1.2079 + if ( resourceRef->flags & TCL_RESOURCE_DONT_CLOSE ) {
1.2080 + if (resultPtr != NULL) {
1.2081 + Tcl_AppendStringsToObj(resultPtr,
1.2082 + "can't close \"", tokenPtr, "\" resource file",
1.2083 + (char *) NULL);
1.2084 + }
1.2085 + return -1;
1.2086 + }
1.2087 +
1.2088 + Tcl_DeleteHashEntry(nameHashPtr);
1.2089 + ckfree((char *) resourceRef);
1.2090 +
1.2091 +
1.2092 + /*
1.2093 + * Now remove the resource from the resourceForkList object
1.2094 + */
1.2095 +
1.2096 + Tcl_ListObjGetElements(NULL, resourceForkList, &listLen, &elemPtrs);
1.2097 +
1.2098 +
1.2099 + index = -1;
1.2100 + length = strlen(tokenPtr);
1.2101 +
1.2102 + for (i = 0; i < listLen; i++) {
1.2103 + match = 0;
1.2104 + bytes = Tcl_GetStringFromObj(elemPtrs[i], &elemLen);
1.2105 + if (length == elemLen) {
1.2106 + match = (memcmp(bytes, tokenPtr,
1.2107 + (size_t) length) == 0);
1.2108 + }
1.2109 + if (match) {
1.2110 + index = i;
1.2111 + break;
1.2112 + }
1.2113 + }
1.2114 + if (!match) {
1.2115 + panic("the resource Fork List is out of synch!");
1.2116 + }
1.2117 +
1.2118 + Tcl_ListObjReplace(NULL, resourceForkList, index, 1, 0, NULL);
1.2119 +
1.2120 + resourceHashPtr = Tcl_FindHashEntry(&resourceTable, (char *) fileRef);
1.2121 +
1.2122 + if (resourceHashPtr == NULL) {
1.2123 + panic("Resource & Name tables are out of synch in resource command.");
1.2124 + }
1.2125 + ckfree(Tcl_GetHashValue(resourceHashPtr));
1.2126 + Tcl_DeleteHashEntry(resourceHashPtr);
1.2127 +
1.2128 + return fileRef;
1.2129 +
1.2130 +}
1.2131 +
1.2132 +
1.2133 +/*
1.2134 + *----------------------------------------------------------------------
1.2135 + *
1.2136 + * BuildResourceForkList --
1.2137 + *
1.2138 + * Traverses the list of open resource forks, and builds the
1.2139 + * list of resources forks. Also creates a resource token for any that
1.2140 + * are opened but not registered with our resource system.
1.2141 + * This is based on code from Apple DTS.
1.2142 + *
1.2143 + * Results:
1.2144 + * None.
1.2145 + *
1.2146 + * Side effects:
1.2147 + * The list of resource forks is updated.
1.2148 + * The resource name table may be augmented.
1.2149 + *
1.2150 + *----------------------------------------------------------------------
1.2151 + */
1.2152 +
1.2153 +void
1.2154 +BuildResourceForkList()
1.2155 +{
1.2156 + Handle currentMapHandle, mSysMapHandle;
1.2157 + Ptr tempPtr;
1.2158 + FCBPBRec fileRec;
1.2159 + char fileName[256];
1.2160 + char appName[62];
1.2161 + Tcl_Obj *nameObj;
1.2162 + OSErr err;
1.2163 + ProcessSerialNumber psn;
1.2164 + ProcessInfoRec info;
1.2165 + FSSpec fileSpec;
1.2166 +
1.2167 + /*
1.2168 + * Get the application name, so we can substitute
1.2169 + * the token "application" for the application's resource.
1.2170 + */
1.2171 +
1.2172 + GetCurrentProcess(&psn);
1.2173 + info.processInfoLength = sizeof(ProcessInfoRec);
1.2174 + info.processName = (StringPtr) &appName;
1.2175 + info.processAppSpec = &fileSpec;
1.2176 + GetProcessInformation(&psn, &info);
1.2177 + p2cstr((StringPtr) appName);
1.2178 +
1.2179 +
1.2180 + fileRec.ioCompletion = NULL;
1.2181 + fileRec.ioVRefNum = 0;
1.2182 + fileRec.ioFCBIndx = 0;
1.2183 + fileRec.ioNamePtr = (StringPtr) &fileName;
1.2184 +
1.2185 +
1.2186 + currentMapHandle = LMGetTopMapHndl();
1.2187 + mSysMapHandle = LMGetSysMapHndl();
1.2188 +
1.2189 + while (1) {
1.2190 + /*
1.2191 + * Now do the ones opened after the application.
1.2192 + */
1.2193 +
1.2194 + nameObj = Tcl_NewObj();
1.2195 +
1.2196 + tempPtr = *currentMapHandle;
1.2197 +
1.2198 + fileRec.ioRefNum = *((short *) (tempPtr + 20));
1.2199 + err = PBGetFCBInfo(&fileRec, false);
1.2200 +
1.2201 + if (err != noErr) {
1.2202 + /*
1.2203 + * The ROM resource map does not correspond to an opened file...
1.2204 + */
1.2205 + Tcl_SetStringObj(nameObj, "ROM Map", -1);
1.2206 + } else {
1.2207 + p2cstr((StringPtr) fileName);
1.2208 + if (strcmp(fileName,appName) == 0) {
1.2209 + Tcl_SetStringObj(nameObj, "application", -1);
1.2210 + } else {
1.2211 + Tcl_SetStringObj(nameObj, fileName, -1);
1.2212 + }
1.2213 + c2pstr(fileName);
1.2214 + }
1.2215 +
1.2216 + TclMacRegisterResourceFork(fileRec.ioRefNum, nameObj,
1.2217 + TCL_RESOURCE_DONT_CLOSE | TCL_RESOURCE_INSERT_TAIL);
1.2218 +
1.2219 + if (currentMapHandle == mSysMapHandle) {
1.2220 + break;
1.2221 + }
1.2222 +
1.2223 + currentMapHandle = *((Handle *) (tempPtr + 16));
1.2224 + }
1.2225 +}