home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / source / oodleutl.cpt / oodles-of-utils / brutal-utils / Resources-u.lisp < prev    next >
Encoding:
Text File  |  1992-07-08  |  9.3 KB  |  239 lines
  1. (in-package :oou)
  2. (oou-provide :Resources-u)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; Resources-u.Lisp
  5. ;;
  6. ;; Copyright ⌐ 1992 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;
  11. ;; Utilities for working with resources 
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (oou-dependencies :traps-u)
  15.  
  16. (export '(with-res-file with-purgeable-resource without-res-load
  17.           get-resource get-resource-id get-resource-name
  18.           release-resource resource-handlep resource-purgeablep
  19.           open-res-file close-res-file opened-res-file-p 
  20.           ))
  21.  
  22. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23. ;;; defrecords & macros
  24.  
  25. (eval-when (:compile-toplevel :load-toplevel :execute)
  26.   
  27.   (defrecord (ResourceHeader :handle)
  28.     (dataOffset longint)
  29.     (mapOffset longint)
  30.     (dataLength longint)
  31.     (mapLength longint))
  32.   
  33.   (defrecord (ResourceMap :handle)
  34.     (header ResourceHeader)
  35.     (nextMapH handle)
  36.     (refnum integer)
  37.     (fileAttributes integer)
  38.     (typeListOffset integer)
  39.     (nameListOffset integer))
  40.   
  41.  
  42.   (defmacro with-res-file-refNum ((refNum
  43.                                    &key
  44.                                    (close-when-done-p nil)
  45.                                    (write-changes-p nil))
  46.                                   &body body)
  47.     (let ((new-refNum (gensym))
  48.           (old-refNum (gensym)))
  49.       `(let ((,new-refNum)
  50.              (,old-refNum (require-trap #_CurResFile)))
  51.          (declare (dynamic-extent ,old-refNum ,new-refNum) 
  52.                   (fixnum ,old-refNum ,new-refNum))
  53.          (unwind-protect
  54.            (progn
  55.              ;must protect evaluation of refNum in case it alters
  56.              ;the current res file (like a call to open-res-file)
  57.              (setf ,new-refNum ,refNum) 
  58.              (require-trap #_UseResFile ,new-refNum)
  59.              ,@body)
  60.            (when ,new-refNum
  61.              (when ,write-changes-p (require-trap #_UpdateResFile ,new-refNum))
  62.              (when ,close-when-done-p (require-trap #_CloseResFile ,new-refNum)))
  63.            (require-trap #_UseResFile ,old-refNum)))))
  64.  
  65.   (defmacro with-res-file ((pathname
  66.                             &key
  67.                             (if-does-not-exist :error)
  68.                             (if-no-rsrc-fork :error)
  69.                             (if-not-open :close-when-done)
  70.                             (if-open :leave-open)
  71.                             (write-changes-p nil))
  72.                            &body body)
  73.     (let ((close-flag (gensym)))
  74.       `(let ((,close-flag (ecase (if (opened-res-file-p ,pathname) ,if-open ,if-not-open)
  75.                             (:close-when-done t)
  76.                             (:leave-open nil))))
  77.          (declare (dynamic-extent ,close-flag))
  78.          (with-res-file-refNum ((open-res-file ,pathname
  79.                                                :if-does-not-exist ,if-does-not-exist
  80.                                                :if-no-rsrc-fork ,if-no-rsrc-fork)
  81.                                 :close-when-done-p ,close-flag
  82.                                 :write-changes-p ,write-changes-p)
  83.            ,@body))))
  84.   
  85.   (defmacro without-res-load (&body body)
  86.     `(unwind-protect
  87.        (progn
  88.          (require-trap #_SetResLoad nil)
  89.          ,@body)
  90.        (require-trap #_SetResLoad t)))
  91.   
  92.   (defmacro with-purgeable-resource ((rsrc-handle &key (changed-p nil)) &body body)
  93.     (let ((hState (gensym))
  94.           (rsrc_h (gensym)))
  95.       `(let ((,rsrc_h ,rsrc-handle)
  96.              (,hState nil))
  97.          (declare (dynamic-extent ,hState ,rsrc_h)
  98.                   (fixnum ,hState))
  99.          (unwind-protect
  100.            (progn
  101.              (without-interrupts
  102.               (require-trap #_LoadResource ,rsrc_h)
  103.               (require-trap #_HNoPurge ,rsrc_h)
  104.               (setf ,hState (require-trap #_HGetState ,rsrc_h)))
  105.              ,@body)
  106.            (when ,changed-p (require-trap #_ChangedResource ,rsrc_h))
  107.            (require-trap #_HSetState ,rsrc_h ,hState)))))
  108.   
  109.   )
  110.  
  111. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  112. ;;; individual resources
  113.  
  114. (defun get-resource (rsrc-type rsrc-id-or-name &key (errorp t))
  115.   (without-interrupts
  116.    (let ((rsrc_h (etypecase rsrc-id-or-name
  117.                    (fixnum (#_GetResource rsrc-type rsrc-id-or-name))
  118.                    (string (with-pstrs ((name_p rsrc-id-or-name))
  119.                              (#_GetNamedResource rsrc-type name_p))))))
  120.      (when (and errorp (%null-ptr-p rsrc_h))
  121.        (error "Failed to load resource ~s of type ~s (ResError = ~a)."
  122.               rsrc-id-or-name rsrc-type (#_ResError)))
  123.      rsrc_h)))
  124.  
  125. (defun release-resource (rsrc-handle)
  126.   (if (resource-handlep rsrc-handle)
  127.     (#_ReleaseResource rsrc-handle)
  128.     (error "~s is not a resource handle" rsrc-handle)))
  129.  
  130. (defun get-resource-id (rsrc-type rsrc-name &key (errorp t))
  131.   (with-returned-pstrs ((name_p rsrc-name))
  132.     (rlet ((id_p :integer)
  133.            (type_p :OSType))
  134.       (with-macptrs ((rsrc_h (without-res-load (#_GetNamedResource rsrc-type name_p))))
  135.         (without-interrupts
  136.          (#_GetResInfo rsrc_h id_p type_p name_p)
  137.          (when (and errorp (not (zerop (#_ResError))))
  138.            (error "resource ~s of type ~s not found." rsrc-name rsrc-type))))
  139.       (%get-signed-word id_p))))
  140.  
  141. (defun get-resource-name (rsrc-type rsrc-id &key (errorp t))
  142.   (with-returned-pstrs ((name_p ""))
  143.     (rlet ((id_p :integer)
  144.            (type_p :OSType))
  145.       (with-macptrs ((rsrc_h (without-res-load (#_GetResource rsrc-type rsrc-id))))
  146.         (without-interrupts
  147.          (#_GetResInfo rsrc_h id_p type_p name_p)
  148.          (when (and errorp (not (zerop (#_ResError))))
  149.            (error "resource ~s of type ~s not found." rsrc-id rsrc-type))))
  150.       (%get-string name_p))))
  151.  
  152. (defun resource-handlep (handle)
  153.   (logbitp 5 (#_HGetState handle)))
  154.  
  155. (defun resource-purgeablep (rsrc-handle)
  156.   (logtest #$resPurgeable (#_GetResAttrs rsrc-handle)))
  157.  
  158. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  159. ;;; resource files
  160.  
  161. (defun opened-res-file-p (pathname)
  162. ;;Determines if the resource fork of the specified resource file is open
  163.   (with-pstrs ((fileName (mac-namestring pathname)))
  164.     (rlet ((pb :HParamBlockRec
  165.                :ioNamePtr fileName
  166.                :ioVRefNum 0
  167.                :ioFDirIndex 0
  168.                :ioDirID 0))
  169.       (trap-nz-echeck (#_PBHGetFInfo pb))
  170.       (logbitp 2 (pref pb :HParamBlockRec.ioFlAttrib)))))
  171.  
  172. (defun open-res-file (pathname &key (if-does-not-exist :error) (if-no-rsrc-fork :error))
  173. ;;Opens the resource fork of the the specified file and returns the refNum
  174.   (with-pstrs ((fn (mac-namestring pathname)))
  175.     (unless (probe-file pathname)
  176.       (when if-does-not-exist
  177.         (ecase if-does-not-exist
  178.           (:create (#_CreateResFile fn) (open-res-file pathname))
  179.           (:error (error "~s does not exist" pathname)))))
  180.     (let ((refNum (#_OpenResFile fn)))
  181.       (if (plusp refNum)
  182.         refNum
  183.         (when if-no-rsrc-fork
  184.           (ecase if-no-rsrc-fork
  185.             (:create (#_CreateResFile fn) (open-res-file pathname))
  186.             (:error (error "~s has no resource fork" pathname))))))))
  187.  
  188. (defun close-res-file (refNum-or-pathname)
  189.   (let ((refNum (etypecase refNum-or-pathname
  190.                   (string (when (opened-res-file-p refNum-or-pathname)
  191.                             (open-res-file refNum-or-pathname)))
  192.                   (pathname (when (opened-res-file-p refNum-or-pathname)
  193.                               (open-res-file refNum-or-pathname)))
  194.                   (fixnum refNum-or-pathname))))
  195.     (when refnum
  196.       (without-interrupts
  197.        (#_CloseResFile refNum)
  198.        (zerop (#_ResError))))))
  199.  
  200.  
  201.  
  202.  
  203.  
  204. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  205. ;;; resource maps (linked list of resource files)
  206.  
  207.  
  208. (defun opened-rsrc-file-refNums (&key (start-mapH (%get-ptr (%int-to-ptr #.#$TopMapHndl)))
  209.                                       (end-mapH (%get-ptr (%int-to-ptr #.#$SysMapHndl))))
  210. ;;Returns the refNums of the open resource files.
  211. ;;end-mapH specifies the endpoint (non-inclusive) for the search of the
  212. ;;resource map linked list. Typically, you want to search till the system
  213. ;;resource file (the default). Use (%null-ptr) for the complete list
  214.   (unless (eql start-mapH end-mapH)
  215.     (cons (href start-mapH :ResourceMap.refnum)
  216.           (opened-rsrc-file-refnums :start-mapH (href start-mapH :ResourceMap.nextMapH)
  217.                                     :end-mapH end-mapH))))
  218.  
  219. (defun opened-MCL-rsrc-file-refNums (&optional include-MCL-p)
  220. ;;Returns the refNums of open resource files that were opened since MCL
  221. ;;booted. include-MCL-p determines if MCL's refNum is on the list
  222.   (let ((refNums (opened-rsrc-file-refNums)))
  223.     (if include-MCL-p refNums (rest refNums))))
  224.  
  225. (defun opened-MCL-rsrc-file-names (&optional include-MCL-p)
  226. ;;Returns the names of open resource files that were opened since MCL
  227. ;;booted. include-MCL-p determines if MCL's name is on the list."
  228.   (with-returned-pstrs ((fn ""))
  229.     (rlet ((pb :FCBPBRec
  230.                :ioNamePtr fn
  231.                :ioVRefNum 0
  232.                :ioFCBIndx 0))
  233.       (flet ((fRefNum-to-fn (fRefNum)
  234.                (pset pb :FCBPBRec.ioRefNum fRefNum)
  235.                (trap-nz-echeck (#_PBGetFCBInfo pb))
  236.                (%get-string fn)))
  237.         (declare (dynamic-extent #'fRefNum-to-fn))
  238.         (mapcar #'fRefNum-to-fn (opened-MCL-rsrc-file-refNums include-MCL-p))))))
  239.