home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / source / oodleutl.cpt / oodles-of-utils / mixin-madness / simple-view-mixins / rsrc-svm.lisp < prev    next >
Encoding:
Text File  |  1992-01-30  |  2.9 KB  |  77 lines
  1. (in-package :oou)
  2. (oou-provide :rsrc-svm)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; rsrc-svm.Lisp
  5. ;;
  6. ;; Copyright ⌐ 1992 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;
  11. ;; Dialog item mixin for handling resources.
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (oou-dependencies
  15.  :Resources-u)
  16.  
  17. (export '(rsrc-svm set-view-resource rsrc-get-fn rsrc-dispose-fn))
  18.  
  19. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20.  
  21. (defclass rsrc-svm ()
  22.   ((rsrc-type                :initarg :rsrc-type)
  23.    (rsrc-id                  :initarg :rsrc-id)
  24.    (rsrc-name                :initarg :rsrc-name)
  25.    (rsrc-handle              :initarg :rsrc-handle)
  26.    (detach-p                 :initarg :detach-p)
  27.    (dispose-rsrc-on-remove-p :initarg :dispose-rsrc-on-remove-p))
  28.   (:default-initargs    :dispose-rsrc-on-remove-p t :detach-p nil))
  29.  
  30. (defmethod install-view-in-window :after ((sv rsrc-svm) window)
  31.   (declare (ignore window))
  32.   (rsrc-handle-install sv))
  33.  
  34. (defmethod remove-view-from-window :after ((sv rsrc-svm))
  35.   (rsrc-handle-remove sv))
  36.  
  37. (defmethod rsrc-handle-install ((sv rsrc-svm))
  38.   (with-slots (rsrc-type rsrc-id rsrc-name rsrc-handle detach-p) sv
  39.     (cond ((slot-boundp sv 'rsrc-handle))
  40.           ((slot-boundp sv 'rsrc-id)
  41.            (setf rsrc-handle (rsrc-get-fn sv rsrc-type rsrc-id)))
  42.           ((slot-boundp sv 'rsrc-name)
  43.            (setf rsrc-handle (rsrc-get-fn sv rsrc-type rsrc-name))))
  44.     (when (and detach-p (slot-boundp sv 'rsrc-handle) (resource-handlep rsrc-handle))
  45.       (#_DetachResource rsrc-handle))))
  46.  
  47. (defmethod rsrc-handle-remove ((sv rsrc-svm))
  48.   (when (slot-boundp sv 'rsrc-handle)
  49.     (with-macptrs ((rsrc-handle (slot-value sv 'rsrc-handle)))
  50.       (slot-makunbound sv 'rsrc-handle)
  51.       (when (slot-value sv 'dispose-rsrc-on-remove-p)
  52.         (rsrc-dispose-fn sv rsrc-handle (resource-handlep rsrc-handle))))))
  53.  
  54. (defmethod set-view-resource ((sv rsrc-svm) &key rsrc-type rsrc-id rsrc-name rsrc-handle)
  55.   (when rsrc-type (setf (slot-value sv 'rsrc-type) rsrc-type))
  56.   (slot-makunbound sv 'rsrc-id)
  57.   (slot-makunbound sv 'rsrc-name)
  58.   (without-interrupts
  59.    (rsrc-handle-remove sv)
  60.    (cond (rsrc-handle (setf (slot-value sv 'rsrc-handle) rsrc-handle))
  61.          (rsrc-id     (setf (slot-value sv 'rsrc-id)     rsrc-id))
  62.          (rsrc-name   (setf (slot-value sv 'rsrc-name)   rsrc-name)))
  63.    (when (wptr sv) (rsrc-handle-install sv))))
  64.  
  65.  
  66. (defmethod rsrc-get-fn ((sv rsrc-svm) rsrc-type rsrc-id-or-name)
  67.   (get-resource rsrc-type rsrc-id-or-name))
  68.  
  69. (defmethod rsrc-dispose-fn ((sv rsrc-svm) rsrc-handle rsrc-handlep)
  70.   (if rsrc-handlep
  71.     (#_ReleaseResource rsrc-handle)
  72.     (#_DisposeHandle rsrc-handle)))
  73.  
  74. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  75. #|
  76.    examples can be found in graphic-rsrc-svm, PICT-svm, PICT-di, ICON-di, cicn-di
  77. |#