Some correction and moving around.
[com-informatimago:com-informatimago.git] / common-lisp / apple-file / apple-file.lisp
1 ;;;; -*- mode:lisp;coding:utf-8 -*-
2 ;;;;**************************************************************************
3 ;;;;FILE:               apple-file.lisp
4 ;;;;LANGUAGE:           Common-Lisp
5 ;;;;SYSTEM:             Common-Lisp
6 ;;;;USER-INTERFACE:     NONE
7 ;;;;DESCRIPTION
8 ;;;;    
9 ;;;;    Implements a codecs for AppleSingle and AppleDouble file formats.
10 ;;;;    http://kaiser-edv.de/documents/AppleSingle_AppleDouble.pdf
11 ;;;;    
12 ;;;;AUTHORS
13 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
14 ;;;;MODIFICATIONS
15 ;;;;    2013-05-08 <PJB> Created.
16 ;;;;BUGS
17 ;;;;LEGAL
18 ;;;;    AGPL3
19 ;;;;    
20 ;;;;    Copyright Pascal J. Bourguignon 2013 - 2013
21 ;;;;    
22 ;;;;    This program is free software: you can redistribute it and/or modify
23 ;;;;    it under the terms of the GNU Affero General Public License as published by
24 ;;;;    the Free Software Foundation, either version 3 of the License, or
25 ;;;;    (at your option) any later version.
26 ;;;;    
27 ;;;;    This program is distributed in the hope that it will be useful,
28 ;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
29 ;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
30 ;;;;    GNU Affero General Public License for more details.
31 ;;;;    
32 ;;;;    You should have received a copy of the GNU Affero General Public License
33 ;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
34 ;;;;**************************************************************************
35
36
37 (defpackage "COM.INFORMATIMAGO.COMMON-LISP.APPLE-FILE.APPLE-FILE"
38   (:use "COMMON-LISP"
39         "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY"
40         "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.INDEX-SET")
41   (:shadowing-import-from "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.INDEX-SET"
42                           "INCLUDE""MERGE""UNION""INTERSECTION")
43
44   (:export
45    "APPLE-FILE-REAL-NAME"
46    "APPLE-FILE-COMMENT"
47    "APPLE-FILE-ICON-B&W"
48    "APPLE-FILE-ICON-COLOR"
49    "APPLE-FILE-CREATION-DATE"
50    "APPLE-FILE-MODIFICATION-DATE"
51    "APPLE-FILE-BACKUP-DATE"
52    "APPLE-FILE-ACCESS-DATE"
53    "APPLE-FILE-FINDER-CREATOR"
54    "APPLE-FILE-FINDER-TYPE"
55    "APPLE-FILE-FINDER-LOCATION"
56    "APPLE-FILE-FINDER-ICON-ID"
57    "APPLE-FILE-FINDER-FOLDER"
58    "APPLE-FILE-FINDER-PUT-AWAY-FOLDER"
59    "APPLE-FILE-MACINTOSH-PROTECTED"
60    "APPLE-FILE-MACINTOSH-LOCKED"
61    "APPLE-FILE-PRODOS-ACCESS"
62    "APPLE-FILE-PRODOS-TYPE"
63    "APPLE-FILE-PRODOS-AUXILIARY-TYPE"
64    "APPLE-FILE-MSDOS-ATTRIBUTES"
65    "APPLE-FILE-AFP-BACKUP-NEEDED"
66    "APPLE-FILE-AFP-SYSTEM"
67    "APPLE-FILE-AFP-MULTI-USER"
68    "APPLE-FILE-AFP-INVISIBLE"
69    "APPLE-FILE-AFP-DIRECTORY-ID"))
70   
71 (in-package "COM.INFORMATIMAGO.COMMON-LISP.APPLE-FILE.APPLE-FILE")
72
73
74
75 (deftype octet () '(unsigned-byte 8))
76 (defun equal-type (a b) (and (subtypep a b) (subtypep b a)))
77
78
79 ;;----------------------------------------------------------------------
80 ;; Apple Single & Apple Double File Format
81 ;;----------------------------------------------------------------------
82
83 (defconstant +apple-format-version+       #x00020000)
84 (defconstant +apple-single-magic-number+  #x00051600)
85 (defconstant +apple-double-magic-number+  #x00051607)
86
87
88 (defenum predefined-entry-id
89   (data-fork-id 1)
90   resource-fork-id
91   real-name
92   comment
93   icon-b&w
94   icon-color
95   (file-dates-info 8)
96   finder-info
97   macintosh-file-info
98   prodos-file-info
99   msdos-file-info
100   short-name
101   afp-file-info
102   directory-id)
103
104 (defparameter *symbolic-entry-ids* #(nil
105                                      :data-fork-id 
106                                      :resource-fork-id
107                                      :real-name
108                                      :comment
109                                      :icon-b&w
110                                      :icon-color
111                                      nil
112                                      :file-dates-info 
113                                      :finder-info
114                                      :macintosh-file-info
115                                      :prodos-file-info
116                                      :msdos-file-info
117                                      :short-name
118                                      :afp-file-info
119                                      :directory-id))
120
121 (defun symbolicate-entry-id (entry-id)
122   (when (<= 0 entry-id (1- (length *symbolic-entry-ids*)))
123     (aref *symbolic-entry-ids* entry-id)))
124
125
126
127
128 (defclass apple-file ()
129   ((kind        :initform :apple-single
130                 :initarg  :kind
131                 :accessor header-kind
132                 :reader   apple-file-header-kind
133                 :type     (member :apple-single :apple-double :apple-triple))
134    (magic       :initform 0
135                 :initarg  :magic
136                 :accessor header-magic
137                 :reader   apple-file-header-magic)
138    (version     :initform 0
139                 :initarg  :version
140                 :accessor header-version
141                 :reader   apple-file-header-version)
142    (entries     :initform '()
143                 :initarg  :entries
144                 :accessor header-entries
145                 :reader   apple-file-header-entries)
146    (info-stream :initform nil
147                 :initarg  :info-stream
148                 :accessor header-info-stream
149                 :reader   apple-file-info-stream)
150    (direction   :initform :input
151                 :initarg  :direction
152                 :reader   apple-file-direction)))
153
154
155 (defstruct entry
156   kind
157   id
158   offset
159   length
160   decoded)
161
162 (defstruct (file-dates-info
163              (:conc-name file-))
164   creation-date
165   modification-date
166   backup-date
167   access-date)
168
169 (defstruct finder-info
170   type
171   creator
172   flags 
173   location.y
174   location.x
175   folder 
176   icon-id 
177   script 
178   xflags 
179   comment-id
180   put-away-folder)
181
182 (defstruct (macintosh-file-info
183              (:conc-name file-))
184   protected
185   locked)
186
187 (defstruct (prodos-file-info
188              (:conc-name file-))
189   access
190   type
191   auxiliary-type)
192
193 (defstruct (msdos-file-info
194              (:conc-name file-))
195   msdos-attributes)
196
197 (defstruct (afp-file-info
198              (:conc-name file-))
199   backup-needed
200   system
201   multi-user
202   invisible)
203
204 (defun get-ubyte (bytes offset)
205   (aref bytes offset))
206
207 (defun get-ushort (bytes offset)
208   (let ((hi (aref bytes offset))
209         (lo (aref bytes (1+ offset))))
210     (+ (ash hi 8) lo)))
211
212 (defun get-u3bytes (bytes offset)
213   (let ((hi (aref bytes offset))
214         (mi (aref bytes (+ 1 offset)))
215         (lo (aref bytes (+ 2 offset))))
216     (+ (ash (+ (ash hi 8) mi) 8) lo)))
217
218 (defun get-ulong (bytes offset)
219   (let ((hi (get-ushort bytes offset))
220         (lo (get-ushort bytes (+ offset 2))))
221     (+ (ash hi 16) lo)))
222
223 (defun get-byte (bytes offset)
224   (let ((ubyte (get-ubyte bytes offset)))
225     (if (< ubyte #x80)
226       ubyte
227       (- ubyte #x100))))
228
229 (defun get-short (bytes offset)
230   (let ((ushort (get-ushort bytes offset)))
231     (if (< ushort #x8000)
232       ushort
233       (- ushort #x10000))))
234
235 (defun get-long (bytes offset)
236   (let ((ulong (get-ulong bytes offset)))
237     (if (< ulong #x80000000)
238       ulong
239       (- ulong #x100000000))))
240
241 (defun read-ushort (stream)
242   (let ((hi (read-byte stream))
243         (lo (read-byte stream)))
244     (+ (ash hi 8) lo)))
245
246 (defun read-ulong (stream)
247   (let ((hi (read-ushort stream))
248         (lo (read-ushort stream)))
249     (+ (ash hi 16) lo)))
250
251
252 (defgeneric decode-entry-data (kind data))
253
254
255
256 (defun check-ranges (header)
257   (let ((file-set  (make-instance 'index-set))
258         (entry-set (make-instance 'index-set)))
259     (dolist (entry (header-entries header))
260       (assign-empty entry-set)
261       (include entry-set  (make-range :start (entry-offset entry)
262                                       :count (entry-length entry)))
263       (if (emptyp (intersection 'index-set file-set entry-set))
264         (merge file-set entry-set)
265         (report-collision header entry)))))
266
267 (defun report-collision (header  entry)
268   ;; TODO:
269   (error "Some entries collide in ~S." header))
270
271
272 (defun read-header (stream kind)
273   (check-type stream file-stream)
274   (assert (equal-type 'octet (stream-element-type stream)))
275   (let ((magic (read-ulong stream))
276         (expected-magic (ecase kind
277                           (:apple-single +apple-single-magic-number+)
278                           (:apple-double +apple-double-magic-number+))))
279     (assert (= magic expected-magic))
280     (let ((version (read-ulong stream)))
281       (assert (= version +apple-format-version+)))
282     (loop :repeat 16 :do (read-byte stream))
283     (let* ((entry-count (read-ushort stream))
284            (header (make-instance 'apple-file
285                      :kind kind
286                      :magic magic
287                      :version +apple-format-version+
288                      :entries (loop
289                                 :repeat entry-count
290                                 :collect (let* ((entry-id (read-ulong stream))
291                                                 (offset   (read-ulong stream))
292                                                 (length   (read-ulong stream))
293                                                 (kind     (symbolicate-entry-id entry-id))
294                                                 (entry    (make-entry
295                                                            :kind kind
296                                                            :id entry-id
297                                                            :offset offset
298                                                            :length length)))
299                                            entry))
300                      :info-stream stream)))
301       (dolist (entry (header-entries header))
302         (when (entry-kind entry)
303           (setf (entry-decoded entry)
304                 (decode-entry-data (entry-kind entry) (read-entry-data stream entry)))))
305       header)))
306
307
308 (defun read-entry-data (stream entry)
309   (file-position stream (entry-offset entry))
310   (let ((data (make-array (entry-length entry) :element-type 'octet)))
311     (let ((read-size (read-sequence data stream)))
312       (assert (= (entry-length entry) read-size)
313               () "entry-length=~A read-size=~A"
314               (entry-length entry) read-size)
315       data)))
316
317
318
319 (defmethod decode-entry-data ((kind (eql :data-fork-id)) data)
320   data)
321
322 (defmethod decode-entry-data ((kind (eql :resource-fork-id)) data)
323   (warn "TBD decode-entry-data :resource-fork-id")
324   data)
325
326 (defmethod decode-entry-data ((kind (eql :real-name)) data)
327   (map 'string (function code-char) data))
328
329 (defmethod decode-entry-data ((kind (eql :short-name)) data)
330   (map 'string (function code-char) data))
331
332 (defmethod decode-entry-data ((kind (eql :comment)) data)
333   (map 'string (function code-char) data))
334
335 (defmethod decode-entry-data ((kind (eql :icon-b&w)) data)
336   data)
337
338 (defmethod decode-entry-data ((kind (eql :icon-color)) data)
339   data)
340
341
342
343 (defun to-lisp-date (macdate)
344   (+ macdate (load-time-value (encode-universal-time 0 0 0 1 1 2000 0))))
345
346 (defun to-mac-date (universal-time)
347   (- universal-time (load-time-value (encode-universal-time 0 0 0 1 1 2000 0))))
348
349
350 (defmethod decode-entry-data ((kind (eql :file-dates-info)) data)
351   (make-file-dates-info
352    :creation-date     (to-lisp-date (get-long data  0))
353    :modification-date (to-lisp-date (get-long data  4))
354    :backup-date       (to-lisp-date (get-long data  8))
355    :access-date       (to-lisp-date (get-long data 12))))
356
357
358 (defun decode-fdflag (word)
359   (append (loop :for (key flag) :in '((:is-alias 15)
360                                       (:is-invisible 14)
361                                       (:has-bundle 13)
362                                       (:name-locked 12)
363                                       (:is-stationery 11)
364                                       (:has-custom-icon 10)
365                                       (:has-been-inited 8)
366                                       (:has-no-inits 7)
367                                       (:is-shared 6))
368             :when (logbitp flag word) :collect key
369             :when (logbitp flag word) :collect t)
370           (list :label (case (ldb (byte 3 1) word)
371                          (0 nil)
372                          (1 :red)
373                          (2 :orange)
374                          (3 :yellow)
375                          (4 :green)
376                          (5 :blue)
377                          (6 :violet)
378                          (7 :gray)))))
379
380
381 (defmethod decode-entry-data ((kind (eql :finder-info)) data)
382   (let ((fdtype       (get-ulong  data  0))
383         (fdcreator    (get-ulong  data  4))
384         (fdflags      (decode-fdflag (get-ushort data  8)))
385         (fdlocation.y (get-short  data 10))
386         (fdlocation.x (get-short  data 12))
387         (fdfolder     (get-short  data 14))
388         (fdiconid     (get-short  data 16))
389         (fdscript     (get-byte   data 24))
390         (fdxflags     (get-byte   data 25))
391         (fdcomment    (get-short  data 26))
392         (fdputaway    (get-long   data 28)))
393     (make-finder-info
394      :type fdtype
395      :creator fdcreator
396      :flags fdflags
397      :location.y fdlocation.y
398      :location.x fdlocation.x
399      :folder fdfolder
400      :icon-id fdiconid
401      :script fdscript
402      :xflags fdxflags
403      :comment-id fdcomment
404      :put-away-folder fdputaway)))
405
406 (defmethod decode-entry-data ((kind (eql :macintosh-file-info)) data)
407   (let ((flag (get-ulong data 0)))
408     (make-macintosh-file-info
409      :protected (logbitp 1 flag)
410      :locked (logbitp 0 flag))))
411
412 (defmethod decode-entry-data ((kind (eql :prodos-file-info)) data)
413   (make-prodos-file-info
414    :access (get-ushort data 0)
415    :type (get-ushort data 2)
416    :auxiliary-type (get-ulong data 4)))
417
418 (defmethod decode-entry-data ((kind (eql :msdos-file-info)) data)
419   (make-msdos-file-info
420    :msdos-attributes (get-ushort data 0)))
421
422 (defmethod decode-entry-data ((kind (eql :afp-file-info)) data)
423   (let ((flag (get-ulong data 0)))
424     (make-afp-file-info
425      :backup-needed (logbitp 6 flag)
426      :system (logbitp 2 flag)
427      :multi-user (logbitp 1 flag)
428      :invisible (logbitp 0 flag))))
429
430 (defmethod decode-entry-data ((kind (eql :directory-id)) data)
431   (get-ulong data 0))
432
433
434
435 ;;----------------------------------------------------------------------
436 ;; Resources
437 ;;----------------------------------------------------------------------
438
439 (defenum system-resource-type-id
440   DRVR-id
441   WDEF-id
442   MDEF-id
443   CDEF-id
444   PDEF-id
445   PACK-id
446   reserved-6-id
447   reserved-7-id)
448
449 (defun make-owned-system-resource-id (resource-type-id owner-id sub-id)
450   (dpb sub-id (byte 5 0)
451        (dpb owner-id (byte 6 5)
452             (dpb resource-type-id (byte 3 11)
453                  #xc000))))
454
455 (defun owned-system-resource-id-p     (id) (= (ldb (byte 2 14) id) 3))
456 (defun owned-system-resource-type-id  (id) (ldb (byte 3 11) id))
457 (defun owned-system-resource-owner-id (id) (ldb (byte 6  5) id))
458 (defun owned-system-resource-sub-id   (id) (ldb (byte 5  0) id))
459
460 ;; (owned-system-resource-id-p #xd182)
461 ;; (owned-system-resource-sub-id #xd182)
462 ;; (owned-system-resource-owner-id #xd182)
463 ;; (owned-system-resource-type-id #xd182)
464
465
466 (defenum resource-attributes
467   (res-sys-heap 64)
468   (res-purgeable 32)
469   (res-locked 16)
470   (res-protected 8)
471   (res-preload 4)
472   (res-changed 2))
473
474 (defun decode-resource-attributes (attributes)
475   (loop
476     :for key :in '(:changed :preload :protected :locked :purgeable :system-heap)
477     :for bit = 2 :then (* 2 bit)
478     :unless (zerop (logand bit attributes))
479     :collect key))
480
481 ;; header 16 byte
482 ;; resreved 112 bytes
483 ;; application data 128 bytes
484 ;; resource data
485 ;; resource map
486
487
488 (defstruct resource-header
489   data-offset
490   map-offset
491   data-length
492   map-length
493   resource)
494
495 (defun resource-header (resource-data)
496   (make-resource-header
497    :resource resource-data
498    :data-offset (get-ulong resource-data 0)
499    :map-offset (get-ulong resource-data 4)
500    :data-length (get-ulong resource-data 8)
501    :map-length (get-ulong resource-data 12)))
502
503 (defun resource-application-data (resource-header)
504   (subseq (resource-header-resource resource-header) 128 256))
505
506 ;; (defun resource-list (resource-header)
507 ;;   (let* ((start    (resource-header-data-offset resource-header))
508 ;;          (end      (+ start (resource-header-data-length resource-header)))
509 ;;          (resource (resource-header-resource resource-header)))
510 ;;     (loop
511 ;;       :while (< start end)
512 ;;       :for resource-length = (get-ulong resource start)
513 ;;       :collect (subseq resource (+ 4 start) (+ 4 start resource-length)))))
514
515 (defstruct resource-map
516   file-attributes
517   type-list-offset ; offsets from start of resource-header
518   name-list-offset)
519
520 (defstruct resource
521   type
522   id
523   name
524   attributes
525   data)
526
527 (defun get-resource-name (resource name-list-offset offset)
528   (when (/= -1 offset)
529     (loop
530       :with len = (aref resource (+ name-list-offset offset))
531       :with name = (make-array len :element-type 'character)
532       :for i :below len
533       :for ch = (code-char (aref resource (+ name-list-offset offset i 1)))
534       :do (setf (aref name i) ch)
535       :finally (return name))))
536
537 (defun get-resource-data (resource start)
538   (let ((len (get-ulong resource start)))
539     (subseq resource (+ start 4)  (+ start 4 len))))
540
541 (defun resources (resource-header)
542   (assert (<= 28 (resource-header-map-length resource-header)))
543   (let* ((start            (resource-header-map-offset resource-header))
544          (end              (+ start (resource-header-map-length resource-header)))
545          (resource         (resource-header-resource resource-header))
546          ;; (file-attributes  (get-ushort resource (+ start 22)))
547          (type-list-offset (+ start (get-short resource (+ start 24))))
548          (name-list-offset (+ start (get-short resource (+ start 26))))
549          (data-offset      (resource-header-data-offset resource-header)))
550     (loop
551       :repeat (1+ (get-ushort resource type-list-offset))
552       :for type-offset :from (+ type-list-offset 2) :by 8
553       :while (< type-offset end)
554       :collect (let ((resource-type   (get-ulong resource type-offset))
555                      (resource-count  (1+ (get-ushort resource (+ type-offset 4))))
556                      (resource-offset (+ type-list-offset (get-short resource (+ type-offset 6)))))
557                  (loop
558                    :repeat resource-count
559                    :for reference-offset :from resource-offset :by 12
560                    :collect (make-resource
561                              :type resource-type
562                              :id (get-ushort resource reference-offset)
563                              :name (get-resource-name resource name-list-offset
564                                                       (get-short resource (+ reference-offset 2)))
565                              :attributes (decode-resource-attributes (aref resource (+ reference-offset 4)))
566                              :data (get-resource-data resource (+ data-offset (get-u3bytes resource (+ reference-offset 5))))))))))
567
568
569
570 ;; (defvar resource-file #(0 0 1 0 0 0 1 0 0 0 0 0 0 0 0 30 84 104 105 115 32 114 101 115 111 117 114 99 101 32 102 111 114 107 32 105 110 116 101 110 116 105 111 110 97 108 108 121 32 108 101 102 116 32 98 108 97 110 107 32 32 32 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 1 0 0 0 0 0 0 0 0 30 0 0 0 0 0 0 0 0 0 28 0 30 255 255))
571 ;; (resource-header resource-file)
572 ;; (resource-list (resource-header resource-file))
573 ;; (resources (resource-header resource-file))
574 ;; (resources (resource-header (header-) resource-file))
575
576 ;; (let ((resources (resources (resource-header (entry-decoded
577 ;;                                               (find :resource-fork-id
578 ;;                                                     (header-entries (with-open-file (stream (first (directory  #P"/home/pjb/works/patchwork/examples/B/._*.*"))
579 ;;                                                                                             :element-type 'octet)
580 ;;                                                                       (read-header stream :apple-double)))
581 ;; 
582 ;;                                                     :key (function entry-kind)))))))
583 ;;   (mapcar (lambda (resources)
584 ;;               (mapcar (lambda (resource)
585 ;;                           (format-signature (resource-type resource)))
586 ;;                resources))
587 ;;           resources))
588
589
590 ;; (("FRED" "FRED") ("MPSR"))
591 ;; ((#S(resource :type 1179796804 :id 2 :name nil :attributes nil :data #(0 1 0 4 9 0 1 0 0 0))
592 ;;     #S(resource :type 1179796804 :id 3 :name nil :attributes nil :data #(0 0 6 77 111 110 97 99 111)))
593 ;;  (#S(resource :type 1297109842 :id 1005 :name nil :attributes nil :data #(0 9 77 111 110 97 99 111 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 0 8 0 44 0 6 1 240 2 168 0 44 0 6 1 240 2 168 0 0 0 0 0 0 0 188 0 0 0 188 0 0 0 0 1 0))))
594 ;; 
595 ;;  (map 'string 'code-char #(0 0 6 77 111 110 97 99 111))"\0\0\ 6Monaco"
596
597 ;;----------------------------------------------------------------------
598 ;; APPLE-FILE
599 ;;----------------------------------------------------------------------
600
601
602
603
604 (define-condition file-type-error (simple-error)
605   ())
606
607
608
609
610
611
612 (defgeneric apple-file-fork-pathname (path format fork)
613   (:documentation "
614 RETURN: the pathname of the specified FORK of the file at PATH, assuming a file in FORMAT.
615 PATH:   A pathname designator.
616 FORMAT: (member :apple-single :apple-double :apple-triple)
617 FORK:   (member :info :data :resource)
618 ")
619   (:method ((apple-file apple-file) format fork)
620     (apple-file-fork-pathname (apple-file-info-stream apple-file) format fork))
621   (:method ((stream file-stream) format fork)
622     (apple-file-fork-pathname (pathname stream) format fork))
623   (:method ((path string) format fork)
624     (apple-file-fork-pathname (pathname path) format fork))
625   (:method ((info-path pathname) (format (eql :apple-single)) fork)
626     (declare (ignore fork))
627     info-path)
628   (:method ((info-path pathname) (format (eql :apple-double)) fork)
629     (let ((name (pathname-name info-path)))
630       (ecase fork
631         ((:info :resource)
632          (if (string= "._" name :end2 (min 2 (length name)))
633            info-path
634            (make-pathname :name (format nil "._~A" name) :defaults info-path)))
635         ((:data)
636          (if (string= "._" name :end2 (min 2 (length name)))
637            (make-pathname :name (subseq name 2) :defaults info-path)
638            info-path)))))
639   (:method ((info-path pathname) (format (eql :apple-triple)) fork)
640     (make-pathname :type (ecase fork
641                            ((:info) "info")
642                            ((:data) "data")
643                            ((:resource) "rsrc"))
644                    :case :local
645                    :defaults info-path)))
646
647
648 (defun tree-structure-and-leaf-difference (a b &key (test (function eql)))
649   (cond
650     ((and (null a) (null b)) '=)
651     ((or (null a) (null b)) `(/= ,a ,b))
652     ((and (atom a) (atom b))
653      (if (funcall test a b)
654          '=
655          `(/= ,a ,b)))
656     ((or (atom a) (atom b)) `(/= ,a ,b))
657     (t (cons (tree-structure-and-leaf-difference (car a) (car b) :test test)
658              (tree-structure-and-leaf-difference (cdr a) (cdr b) :test test)))))
659
660 (defun test/apple-file-fork-pathname ()
661   #+unix
662   (let ((*default-pathname-defaults* #P"/"))
663     (assert
664      (tree-structure-and-leaf-difference 
665       (mapcar (lambda (format)
666                 (mapcar (lambda (fork)
667                           (apple-file-fork-pathname (make-pathname :name "test" :type "single" :case :local)
668                                                     format fork))
669                         '(:info :data :resource)))
670               '(:apple-single :apple-double :apple-triple))
671       (list (list (make-pathname :name "test" :type "single" :case :local)
672                   (make-pathname :name "test" :type "single" :case :local)
673                   (make-pathname :name "test" :type "single" :case :local))
674             (list (make-pathname :name "._test" :type "single" :case :local)
675                   (make-pathname :name "test" :type "single" :case :local)
676                   (make-pathname :name "._test" :type "single" :case :local))
677             (list (make-pathname :name "test" :type "info" :case :local)
678                   (make-pathname :name "test" :type "data" :case :local)
679                   (make-pathname :name "test" :type "rsrc" :case :local)))
680       :test 'pathname-match-p)))
681   :success)
682
683
684
685
686 ;; (open-apple-file pathname) --> apple-file
687 ;; (close-apple-file apple-file)
688 ;; (apple-file-data-fork-stream apple-file :direction :external-format :element-type :if-does-not-exist :if-exists) --> stream
689 ;; (apple-file-resource-fork-stream apple-file :direction :if-does-not-exist :if-exists) --> stream
690 ;; (apple-file-resources apple-file) --> resources
691
692
693 (defun open-apple-file (pathname &key (direction :input) (if-does-not-exist :error))
694   (assert (eq direction :input) () "non :input direction not supported yet.")
695   (flet ((get-header (info-path format)
696            (let* ((stream (open info-path
697                                 :direction :input
698                                 :if-does-not-exist nil
699                                 :element-type 'octet))
700                   (header (when stream
701                             (file-position stream 0)
702                             (ignore-errors (read-header stream format)))))
703              (when header
704                (setf (header-info-stream header) stream))
705              header)))
706     (let ((header (or (get-header (apple-file-fork-pathname pathname :apple-single :info) :apple-single)
707                       (get-header (apple-file-fork-pathname pathname :apple-double :info) :apple-double)
708                       (get-header (apple-file-fork-pathname pathname :apple-triple :info) :apple-triple))))
709       (if header
710         (make-instance 'apple-file
711           :header header
712           :info-stream (header-info-stream header)
713           :direction direction)
714         (case if-does-not-exist
715           (:error (error 'file-error :pathname pathname))
716           (otherwise if-does-not-exist))))))
717
718
719 (defgeneric close-apple-file (apple-file)
720   (:method ((apple-file apple-file))
721     (close (header-info-stream (apple-file-header apple-file)))))
722
723 (defun apple-file-data-fork (apple-file
724                              &key (direction :input)
725                                (external-format :default)
726                                (element-type 'character)
727                                (if-does-not-exist :error)
728                                if-exists)
729   (let ((data-path (apple-file-fork-pathname apple-file (apple-file-header-kind apple-file) :data))
730         (info-path (apple-file-fork-pathname apple-file (apple-file-header-kind apple-file) :info)))
731     (if (equalp data-path info-path)
732         (error "~S not implemented for apple-triple files yet." 'apple-file-data-fork)
733         (open data-path
734               :direction direction
735               :external-format external-format
736               :element-type element-type
737               :if-does-not-exist if-does-not-exist
738               :if-exists if-exists))))
739
740 (defun apple-file-resource-fork (apple-file)
741   (error "~S not implemented yet" 'apple-file-resource-fork))
742
743
744
745 ;;----------------------------------------------------------------------
746 ;; APPLE-FILE attributes
747 ;;----------------------------------------------------------------------
748
749 (defmacro define-attribute (name entry-key docstring &rest readers)
750   (labels ((wrap-readers (readers form)
751              (if (null readers)
752                  form
753                  (wrap-readers (rest readers) `(,(first readers) ,form)))))
754     `(defun ,name (apple-file)
755        ,docstring
756        (let ((entry (find ,entry-key (header-entries apple-file) :key (function entry-kind))))
757          (when entry ,(wrap-readers readers '(entry-decoded entry)))))))
758
759
760 (defun format-signature (signature)
761   (format nil "~C~C~C~C"
762           (code-char (ldb (byte 8 24) signature))
763           (code-char (ldb (byte 8 16) signature))
764           (code-char (ldb (byte 8  8) signature))
765           (code-char (ldb (byte 8  0) signature))))
766 (defun and-format-signature (creator) (values creator (format-signature creator)))
767 (defun location-x-y (finfo) (cons (finder-info-location.x finfo) (finder-info-location.y finfo)))
768
769 (define-attribute apple-file-real-name              :real-name           "RETURN: NIL or the real name string in the APPLE-FILE.")                                                                  
770 (define-attribute apple-file-comment                :comment             "RETURN: NIL or the comment string in the APPLE-FILE.")                                                                   
771 (define-attribute apple-file-icon-b&w               :icon-b&w            "RETURN: NIL or the black & white icon data (byte vector) in the APPLE-FILE.")                                            
772 (define-attribute apple-file-icon-color             :icon-color          "RETURN: NIL or the color icon data (byte vector) in the APPLE-FILE.")                                                    
773 (define-attribute apple-file-creation-date          :file-dates-info     "RETURN: NIL or the creation date (lisp universal-time) in the APPLE-FILE."     file-creation-date)                       
774 (define-attribute apple-file-modification-date      :file-dates-info     "RETURN: NIL or the modification date (lisp universal-time) in the APPLE-FILE." file-modification-date)                   
775 (define-attribute apple-file-backup-date            :file-dates-info     "RETURN: NIL or the backup date (lisp universal-time) in the APPLE-FILE."       file-backup-date)                         
776 (define-attribute apple-file-access-date            :file-dates-info     "RETURN: NIL or the access date (lisp universal-time) in the APPLE-FILE."       file-access-date)                         
777 (define-attribute apple-file-finder-creator         :finder-info         "RETURN: NIL or the creator (as integer and as string) of the APPLE-FILE."      finder-info-creator and-format-signature) 
778 (define-attribute apple-file-finder-type            :finder-info         "RETURN: NIL or the type (as integer and as string) of the APPLE-FILE."         finder-info-type    and-format-signature) 
779 (define-attribute apple-file-finder-location        :finder-info         "RETURN: NIL or the X, Y coordinates of the icon of the APPLE-FILE."            location-x-y)                         
780 (define-attribute apple-file-finder-icon-id         :finder-info         "RETURN: NIL or the icon ID of the APPLE-FILE."                                 finder-info-icon-id)                      
781 (define-attribute apple-file-finder-folder          :finder-info         "RETURN: NIL or the folder ID of the APPLE-FILE."                               finder-info-folder)                       
782 (define-attribute apple-file-finder-put-away-folder :finder-info         "RETURN: NIL or the put away folder ID of the APPLE-FILE."                      finder-info-put-away-folder)              
783 (define-attribute apple-file-macintosh-protected    :macintosh-file-info "RETURN: NIL or the protected flag of the APPLE-FILE."                          file-protected)
784 (define-attribute apple-file-macintosh-locked       :macintosh-file-info "RETURN: NIL or the locked flag of the APPLE-FILE."                             file-locked)
785 (define-attribute apple-file-prodos-access          :prodos-file-info    "RETURN: NIL or the PRODOS access code of the APPLE-FILE."                      file-access)
786 (define-attribute apple-file-prodos-type            :prodos-file-info    "RETURN: NIL or the PRODOS type code of the APPLE-FILE."                        file-type)
787 (define-attribute apple-file-prodos-auxiliary-type  :prodos-file-info    "RETURN: NIL or the PRODOS auxiliary type code of the APPLE-FILE."              file-auxiliary-type)
788 (define-attribute apple-file-msdos-attributes       :msdos-file-info     "RETURN: NIL or the MSDOS attributes of the APPLE-FILE."                        file-msdos-attributes)
789 (define-attribute apple-file-afp-backup-needed      :afp-file-info       "RETURN: NIL or the AFP backup needed flag of the APPLE-FILE."                  file-backup-needed)
790 (define-attribute apple-file-afp-system             :afp-file-info       "RETURN: NIL or the AFP system flag of the APPLE-FILE."                         afp-file-system)
791 (define-attribute apple-file-afp-multi-user         :afp-file-info       "RETURN: NIL or the AFP multi-user flag of the APPLE-FILE."                     afp-file-multi-user)
792 (define-attribute apple-file-afp-invisible          :afp-file-info       "RETURN: NIL or the AFP invisible flag of the APPLE-FILE."                      afp-file-invisible)
793 (define-attribute apple-file-afp-directory-id       :afp-file-info       "RETURN: NIL or the AFP directory ID of the APPLE-FILE."                        afp-file-directory-id)
794
795
796
797 ;;----------------------------------------------------------------------
798 ;;
799 ;;----------------------------------------------------------------------
800
801
802 (defun lsattr (path)
803   (format t "~A attributes:~%" path)
804   (with-open-file (stream path :element-type 'octet)
805     (let ((header (read-header stream :apple-double)))
806       (dolist (attribute '(apple-file-real-name              
807                            apple-file-comment                
808                            apple-file-icon-b&w               
809                            apple-file-icon-color             
810                            apple-file-creation-date          
811                            apple-file-modification-date      
812                            apple-file-backup-date            
813                            apple-file-access-date            
814                            apple-file-finder-creator         
815                            apple-file-finder-type            
816                            apple-file-finder-location        
817                            apple-file-finder-icon-id         
818                            apple-file-finder-folder          
819                            apple-file-finder-put-away-folder 
820                            apple-file-macintosh-protected    
821                            apple-file-macintosh-locked       
822                            apple-file-prodos-access          
823                            apple-file-prodos-type            
824                            apple-file-prodos-auxiliary-type  
825                            apple-file-msdos-attributes       
826                            apple-file-afp-backup-needed      
827                            apple-file-afp-system             
828                            apple-file-afp-multi-user         
829                            apple-file-afp-invisible          
830                            apple-file-afp-directory-id))
831         (let ((name   (subseq (string-downcase attribute) #.(length "apple-file-")))
832               (values (multiple-value-list (funcall attribute header))))
833           (when (first values)
834             (format t "~30A ~{~A~^ ~}~%" name values))))
835       (let ((resources (resources (resource-header (entry-decoded (find :resource-fork-id (header-entries header) :key (function entry-kind)))))))
836         (dolist (resources resources)
837           (format t "Resource type: ~A" (format-signature (resource-type (first resources))))
838           (dolist (resource resources)
839             (format t " ~A~@[(~A)~]" (resource-id resource) (resource-name resource)))
840           (terpri)))))
841   (values))
842
843
844 ;; (dolist (path  (directory  #P"/home/pjb/works/patchwork/examples/B/._*.*"))
845 ;;  (lsattr path)
846 ;;  (terpri))
847
848
849 ;; (defun make-apple-double-pathname (pathname)
850 ;;   (apple-file-fork-pathname pathname :apple-double :info))
851 ;; (make-apple-double-pathname "toto")
852 ;;
853 ;; (first (directory  #P"/home/pjb/works/patchwork/examples/B/._*.*"))
854 ;; #P"/home/pjb/works/patchwork/examples/B/\\._ ''PW-functionals.lib copie"
855 ;; ;; (remove-if-not (function probe-file)
856 ;; ;;                (directory  #P"/home/pjb/works/patchwork/examples/B/*.*")
857 ;; ;;                :key (function make-apple-double-pathname))
858 ;; (with-open-file (stream #P"/home/pjb/works/patchwork/examples/B/._%deÌ\81sordre"
859 ;;                         :element-type 'octet)
860 ;;   (let ((header (read-header stream :apple-double)))
861 ;;     (dolist (entry (header-entries header))
862 ;;       (print (entry-kind entry))
863 ;;       (print (read-entry-data stream entry)))))
864 ;; 
865 ;; (with-open-file (stream #P"/home/pjb/works/patchwork/examples/B/._%deÌ\81sordre"
866 ;;                         :element-type 'octet)
867 ;;    (read-header stream :apple-double))
868 ;; 
869 ;; ;; (format-signature 1413830740)
870 ;; ;; "TEXT"
871 ;; ;; (format-signature 1128483890)
872 ;; ;; "CCL2"
873 ;; 
874 ;; 
875 ;; #S(header :kind :apple-double :magic 333319 :version 131072
876 ;;           :entries (#S(entry :kind :finder-info :id 9 :offset 50 :length 3760
877 ;;                              :decoded #S(finder-info :type 1413830740 :creator 1128483890 :flags (:has-been-inited t :label nil) :location.y -1 :location.x -1 :folder 0 :icon-id 0 :script 0 :xflags 0 :comment-id 0 :put-away-folder 23779))
878 ;;                       
879 ;;                       #S(entry :kind :resource-fork-id :id 2 :offset 3810 :length 286
880 ;;                                :decoded #(0 0 1 0 0 0 1 0 0 0 0 0 0 0 0 30 84 104 105 115 32 114 101 115 111 117 114 99 101 32 102 111 114 107 32 105 110 116 101 110 116 105 111 110 97 108 108 121 32 108 101 102 116 32 98 108 97 110 107 32 32 32 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 1 0 0 0 0 0 0 0 0 30 0 0 0 0 0 0 0 0 0 28 0 30 255 255))))
881
882 (defun test/all ()
883  (test/apple-file-fork-pathname))
884
885 (test/all)
886
887
888 ;;;; THE END ;;;;