source: project/release/4/hfs+/trunk/hfs+.scm @ 15278

Last change on this file since 15278 was 15278, checked in by Jim Ursetto, 12 years ago

hfs+: update to version 0.3 (copyfile)

File size: 12.7 KB
Line 
1;;; HFS+ extended attribute interface
2
3;; Copyright (c) 2009 Jim Ursetto.  All Rights Reserved.
4;; License: BSD.  However, see copyfile.h, which is included
5;; in this distribution, and is under the APSL.
6
7#> #include <sys/xattr.h>
8   /* copyfile.h can be obtained from
9    * http://www.opensource.apple.com/source/Libc/Libc-391.5.18/darwin/copyfile.h */
10   #include "copyfile.h"
11   #include <errno.h>
12<#
13
14;; list-extended-attributes returns a list of strings.  get-* and set-*
15;; accept a string or symbol as a key.  get-extended-attributes returns
16;; keys as symbols.
17
18;; If attribute key or value changes size between calls to determine
19;; size of buffer, we will return the smaller buffer or retry the call if larger.
20
21(declare
22 (disable-interrupts)   ; solely for errno
23 )
24
25(module hfs+
26 (list-extended-attributes
27  get-extended-attribute set-extended-attribute!
28  remove-extended-attribute!
29  get-extended-attributes
30  clear-extended-attributes!
31  copyfile copyfile-check
32  pack-appledouble unpack-appledouble)
33
34(import scheme chicken foreign)
35(import (only data-structures string-split))
36(import foreigners)
37
38;; ssize_t listxattr(const char *path, char *namebuf, size_t size, int options);
39;; ssize_t flistxattr(int fd, char *namebuf, size_t size, int options);
40(define listxattr
41  (foreign-lambda int listxattr (const c-string) scheme-pointer int int))
42(define flistxattr
43  (foreign-lambda int flistxattr int scheme-pointer int int))
44
45;; ssize_t getxattr(const char *path, const char *name, void *value, size_t size,
46;;                  u_int32_t position, int options);
47(define getxattr
48  (foreign-lambda int getxattr (const c-string) (const c-string) scheme-pointer int
49                  int int))
50(define fgetxattr
51  (foreign-lambda int fgetxattr int (const c-string) scheme-pointer int
52                  int int))
53
54;; int setxattr(const char *path, const char *name, void *value, size_t size,
55;;              u_int32_t position, int options);
56(define setxattr
57  (foreign-lambda int setxattr (const c-string) (const c-string) scheme-pointer int
58                  int int))
59(define fsetxattr
60  (foreign-lambda int fsetxattr int (const c-string) scheme-pointer int
61                  int int))
62
63;; int removexattr(const char *path, const char *name, int options);
64(define removexattr
65  (foreign-lambda int removexattr (const c-string) (const c-string) int))
66(define fremovexattr
67  (foreign-lambda int fremovexattr int (const c-string) int))
68
69(define _copyfile
70  (foreign-lambda int copyfile (const c-string) (const c-string) c-pointer int))
71
72(define-foreign-enum-type (xattr-options int)
73  (xattr-options->int int->xattr-options)
74  ((no-follow xattr/nofollow) XATTR_NOFOLLOW)
75  ((create xattr/create) XATTR_CREATE)
76  ((replace xattr/replace) XATTR_REPLACE)
77  ((silent xattr/silent) "0")  ; hack -- not a real API option :)
78  )
79
80(define-foreign-enum-type (copyfile-options int)
81  (copyfile-options->int int->copyfile-options)
82  ((acl copyfile/acl) COPYFILE_ACL)
83  ((stat copyfile/stat) COPYFILE_STAT)
84  ((xattr copyfile/xattr) COPYFILE_XATTR)
85  ((data copyfile/data) COPYFILE_DATA)
86  ((security copyfile/security) COPYFILE_SECURITY)
87  ((metadata copyfile/metadata) COPYFILE_METADATA)
88  ((all copyfile/all) COPYFILE_ALL)
89  ((check copyfile/check) COPYFILE_CHECK)
90  ((pack copyfile/pack) COPYFILE_PACK)
91  ((unpack copyfile/unpack) COPYFILE_UNPACK)
92  ((exclusive copyfile/excl) COPYFILE_EXCL)
93  ((no-follow-source copyfile/no-follow-source) COPYFILE_NOFOLLOW_SRC)
94  ((no-follow-dest copyfile/no-follow-dest) COPYFILE_NOFOLLOW_DST)
95  ((move copyfile/move) COPYFILE_MOVE)
96  ((unlink copyfile/unlink) COPYFILE_UNLINK)
97  ((no-follow copyfile/no-follow) COPYFILE_NOFOLLOW)
98;;   ((silent copyfile/silent) "0")  ; hack -- not a real API option :)
99  )
100
101(define strerror
102  (foreign-lambda c-string strerror int))
103;; Warning: A SRFI-18 thread might change errno from under us (but we still detect the error).
104(define (xattr-error rc loc . args)
105  (signal
106   (make-composite-condition
107    (make-property-condition 'exn 'location loc 'message (strerror rc) 'arguments args)
108    (make-property-condition 'file)
109    (make-property-condition 'hfs+ 'errno rc))))
110
111(define (update-errno)
112  (##sys#update-errno))
113(define errno/range (foreign-value "ERANGE" int))
114(define errno/noattr (foreign-value "ENOATTR" int))
115(define errno/exist (foreign-value "EEXIST" int))
116
117;;; Base API - Extended attributes
118
119;; Accepted options: #:no-follow (or 'no-follow) to prevent following symlink; if passing
120;; a file descriptor, it is illegal to specify this option.
121(define (list-extended-attributes file . options)
122  (let ((c-options (xattr-options->int options))      ; #:create or #:replace is ignored
123        (listxattr (if (number? file)
124                       flistxattr
125                       listxattr)))
126    (let retry ()
127      (let ((size (listxattr file #f 0 c-options)))
128        (cond ((< size 0)
129               (xattr-error (update-errno) 'list-extended-attributes file))
130              ((= size 0)
131               '())
132              (else
133               (let* ((buf (make-string size))
134                      (new-size (listxattr file buf size c-options)))
135                 (cond ((< new-size 0)
136                        (let ((err (update-errno)))
137                          (if (= err errno/range)    ; length increased since we called
138                              (retry)
139                              (xattr-error err 'list-extended-attributes file))))
140                       ((< new-size size)            ; length decreased since we called
141                        (string-split (substring buf 0 new-size) "\x00"))
142                       (else
143                        (string-split buf "\x00") )))))))))
144
145;; Returns #f if attribute does not exist.  Signals an error
146;; on any other getxattr failure, including file not found.
147(define (get-extended-attribute file attribute . options)
148  (let ((c-options (xattr-options->int options))
149        (offset 0)
150        (getxattr (if (number? file)
151                       fgetxattr
152                       getxattr))
153        (attribute (if (symbol? attribute)
154                       (symbol->string attribute)
155                       attribute)))
156    (let retry ()
157      (let ((size (getxattr file attribute #f 0 offset c-options)))
158        (cond ((< size 0)
159               (let ((err (update-errno)))
160                 (cond ((= err errno/noattr)
161                        #f)
162                       (else
163                        (xattr-error err 'get-extended-attribute
164                                     file attribute)))))
165              ((= size 0)
166               "")
167              (else
168               (let* ((buf (make-string size))
169                      (new-size (getxattr file attribute buf
170                                          size offset c-options)))
171                 (cond ((< new-size 0)
172                        (let ((err (update-errno)))
173                          (cond ((= err errno/noattr) #f)
174                                ((= err errno/range)  (retry))
175                                (else
176                                 (xattr-error err 'get-extended-attribute
177                                              file attribute)))))
178                       ((< new-size size) ; length decreased since we called
179                        (substring buf 0 new-size))
180                       (else
181                        buf)))))))))
182
183;; #:silent could, possibly, fail silently on errno/noattr or errno/exist.
184(define (set-extended-attribute! file attribute value . options)
185  (let ((c-options (xattr-options->int options))  ; 'create + 'replace results in EINVAL
186        (offset 0)
187        (setxattr (if (number? file)
188                      fsetxattr
189                      setxattr))
190        (attribute (if (symbol? attribute)
191                       (symbol->string attribute)
192                       attribute)))
193    (let ((size (cond ((blob? value) (blob-size value))
194                      ((string? value) (string-length value))
195                      (else (error 'set-extended-attribute!
196                                   "value must be a string or blob")))))
197      (let ((rv (setxattr file attribute value size offset c-options)))
198        (cond ((< rv 0)
199               (let ((err (update-errno)))
200                 (cond ((= err errno/noattr)
201                        (error 'set-extended-attribute!
202                               "attribute not found" attribute))
203                       ((= err errno/exist)   ;; EEXIST is confusing
204                        (error 'set-extended-attribute!
205                               "attribute already exists" attribute))
206                       (else
207                        (xattr-error err 'set-extended-attribute!
208                                     file attribute)))))
209              ((> rv 0)
210               (error 'set-extended-attribute!
211                      "unexpected return value" rv))
212              (else
213               (void)))))))
214
215;; Error signaled if attribute does not exist, but if you give the
216;; #:silent option it will fail silently.
217(define (remove-extended-attribute! file attribute . options)
218  (let ((c-options (xattr-options->int options))
219        (attribute (if (symbol? attribute)
220                       (symbol->string attribute)
221                       attribute))
222        (removexattr (if (number? file)
223                         fremovexattr
224                         removexattr)))
225    (let ((rv (removexattr file attribute c-options)))
226      (cond ((< rv 0)
227             (let ((err (update-errno)))
228               (if (and (= err errno/noattr)
229                        (memq #:silent options))
230                   (void)
231                   (xattr-error err 'remove-extended-attribute! file attribute))))
232            ((> rv 0)
233             (error 'remove-extended-attribute!
234                    "unexpected return value" rv))
235            (else
236             (void))))))
237
238;;; Base API - Copyfile
239
240;; [copyfile is not officially supported on Tiger and, although metadata pack/unpack
241;;  to AppleDouble files seems to work fine, copying actual data via #:data or #:all
242;;  will throw a spurious error or crash.  #:move doesn't seem to work, but #:excl does.
243;;  #:no-follow is ignored for packing (critical) and unpacking (not).]
244
245;; Copies FROM file to TO file using OS X copyfile(3) API,
246;; preserving HFS+ metadata as specified in copyfile OPTIONS.
247(define (copyfile from to . options)
248  (let ((c-options (copyfile-options->int options)))
249    (let ((rv (_copyfile from to #f c-options)))
250      (cond ((< rv 0)
251             (xattr-error (update-errno) 'copyfile
252                          from to))
253            (else rv)))))
254
255;;; Utilities
256
257;; Returns an alist mapping attribute name (symbol) to value (string).
258;; Possible optimization: If passed a filename, and #:nofollow is not specified,
259;; we can open it and reuse the fd. (And must unwind-protect to close fd.)
260(define (get-extended-attributes file . options)
261  (map (lambda (a)
262         (cons (string->symbol a)
263               (apply get-extended-attribute file a options)))
264       (apply list-extended-attributes file options)))
265
266(define (clear-extended-attributes! file . options)
267  (for-each
268   (lambda (x)
269     (apply remove-extended-attribute! file x options))
270   (apply list-extended-attributes file options)))
271
272;; (define (get-resource-fork filename)
273;;   ...)
274
275;; Pack/unpack all HFS+ metadata (xattrs, acls, POSIX stat).  If no
276;; error occurs, pack returns #f when no metadata was present (and
277;; does not write a file) or #t if metadata was present (and a file is
278;; written).  Unpack always returns #t.  Extra options are passed into
279;; copyfile; relevant ones might be #:excl, #:move and #:no-follow,
280;; although #:move and #:no-follow do not work correctly under Tiger.
281(define (pack-appledouble from to . options)
282  (if (= 0 (apply copyfile from #f #:check #:metadata options))
283      #f
284      (and (apply copyfile from to #:pack #:metadata options) #t)))
285(define (unpack-appledouble from to . options)
286  (and (apply copyfile from to #:unpack #:metadata options) #t))
287
288;; Return a list of symbols denoting the attributes that WOULD be
289;; copied from the FROM file, according to the OPTIONS provided.
290;; Example call: (copyfile-check "foo.txt" #:metadata)
291;; Example return: '(acl stat extended-attributes) meaning
292;; COPYFILE_ACL, COPYFILE_STAT, COPYFILE_XATTR.
293(define (copyfile-check from . options)
294  (let ((options (cons 'check options)))
295    (let ((rv (apply copyfile from #f options)))
296      (cond ((= rv 0) '())
297            ((> rv 0)
298             ;; enumtypes won't decompose into their component bitfields
299             ;; we could also case all 8 possibilities
300             `(,@(if (= 0 (bitwise-and rv copyfile/acl)) '() '(acls))
301               ,@(if (= 0 (bitwise-and rv copyfile/stat)) '() '(stat))
302               ,@(if (= 0 (bitwise-and rv copyfile/xattr)) '() '(extended-attributes))))
303            (else (error 'copyfile-check "unexpected copyfile return value" rv))))))
304
305)
Note: See TracBrowser for help on using the repository browser.