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

Last change on this file since 15012 was 15012, checked in by Jim Ursetto, 11 years ago

hfs+: update to version 0.2

File size: 9.0 KB
Line 
1;;; HFS+ extended attribute interface
2
3#> #include <sys/xattr.h>
4   #include <errno.h>
5<#
6
7;; list-extended-attributes returns a list of strings.  get-* and set-*
8;; accept a string or symbol as a key.  get-extended-attributes returns
9;; keys as symbols.
10
11;; If attribute key or value changes size between calls to determine
12;; size of buffer, we will return the smaller buffer or retry the call if larger.
13
14(declare
15 (disable-interrupts)   ; solely for errno
16 )
17
18(module hfs+
19 (list-extended-attributes
20  get-extended-attribute set-extended-attribute!
21  remove-extended-attribute!
22  get-extended-attributes
23  clear-extended-attributes!)
24
25(import scheme chicken foreign)
26(import (only data-structures string-split))
27(import foreigners)
28
29;; ssize_t listxattr(const char *path, char *namebuf, size_t size, int options);
30;; ssize_t flistxattr(int fd, char *namebuf, size_t size, int options);
31(define listxattr
32  (foreign-lambda int listxattr (const c-string) scheme-pointer int int))
33(define flistxattr
34  (foreign-lambda int flistxattr int scheme-pointer int int))
35
36;; ssize_t getxattr(const char *path, const char *name, void *value, size_t size,
37;;                  u_int32_t position, int options);
38(define getxattr
39  (foreign-lambda int getxattr (const c-string) (const c-string) scheme-pointer int
40                  int int))
41(define fgetxattr
42  (foreign-lambda int fgetxattr int (const c-string) scheme-pointer int
43                  int int))
44
45;; int setxattr(const char *path, const char *name, void *value, size_t size,
46;;              u_int32_t position, int options);
47(define setxattr
48  (foreign-lambda int setxattr (const c-string) (const c-string) scheme-pointer int
49                  int int))
50(define fsetxattr
51  (foreign-lambda int fsetxattr int (const c-string) scheme-pointer int
52                  int int))
53
54;; int removexattr(const char *path, const char *name, int options);
55(define removexattr
56  (foreign-lambda int removexattr (const c-string) (const c-string) int))
57(define fremovexattr
58  (foreign-lambda int fremovexattr int (const c-string) int))
59
60(define-foreign-enum-type (xattr-options int)
61  (xattr-options->int int->xattr-options)
62  ((no-follow xattr/nofollow) XATTR_NOFOLLOW)
63  ((create xattr/create) XATTR_CREATE)
64  ((replace xattr/replace) XATTR_REPLACE)
65  ((silent xattr/silent) "0")  ; hack -- not a real API option :)
66  )
67
68(define strerror
69  (foreign-lambda c-string strerror int))
70;; Warning: A SRFI-18 thread might change errno from under us (but we still detect the error).
71(define (xattr-error rc loc . args)
72  (signal
73   (make-composite-condition
74    (make-property-condition 'exn 'location loc 'message (strerror rc) 'arguments args)
75    (make-property-condition 'file)
76    (make-property-condition 'hfs+ 'errno rc))))
77
78(define (update-errno)
79  (##sys#update-errno))
80(define errno/range (foreign-value "ERANGE" int))
81(define errno/noattr (foreign-value "ENOATTR" int))
82(define errno/exist (foreign-value "EEXIST" int))
83
84;;; Base API
85
86;; Accepted options: #:no-follow (or 'no-follow) to prevent following symlink; if passing
87;; a file descriptor, it is illegal to specify this option.
88(define (list-extended-attributes file . options)
89  (let ((c-options (xattr-options->int options))      ; #:create or #:replace is ignored
90        (listxattr (if (number? file)
91                       flistxattr
92                       listxattr)))
93    (let retry ()
94      (let ((size (listxattr file #f 0 c-options)))
95        (cond ((< size 0)
96               (xattr-error (update-errno) 'list-extended-attributes file))
97              ((= size 0)
98               '())
99              (else
100               (let* ((buf (make-string size))
101                      (new-size (listxattr file buf size c-options)))
102                 (cond ((< new-size 0)
103                        (let ((err (update-errno)))
104                          (if (= err errno/range)    ; length increased since we called
105                              (retry)
106                              (xattr-error err 'list-extended-attributes file))))
107                       ((< new-size size)            ; length decreased since we called
108                        (string-split (substring buf 0 new-size) "\x00"))
109                       (else
110                        (string-split buf "\x00") )))))))))
111
112;; Returns #f if attribute does not exist.  Signals an error
113;; on any other getxattr failure, including file not found.
114(define (get-extended-attribute file attribute . options)
115  (let ((c-options (xattr-options->int options))
116        (offset 0)
117        (getxattr (if (number? file)
118                       fgetxattr
119                       getxattr))
120        (attribute (if (symbol? attribute)
121                       (symbol->string attribute)
122                       attribute)))
123    (let retry ()
124      (let ((size (getxattr file attribute #f 0 offset c-options)))
125        (cond ((< size 0)
126               (let ((err (update-errno)))
127                 (cond ((= err errno/noattr)
128                        #f)
129                       (else
130                        (xattr-error err 'get-extended-attribute
131                                     file attribute)))))
132              ((= size 0)
133               "")
134              (else
135               (let* ((buf (make-string size))
136                      (new-size (getxattr file attribute buf
137                                          size offset c-options)))
138                 (cond ((< new-size 0)
139                        (let ((err (update-errno)))
140                          (cond ((= err errno/noattr) #f)
141                                ((= err errno/range)  (retry))
142                                (else
143                                 (xattr-error err 'get-extended-attribute
144                                              file attribute)))))
145                       ((< new-size size) ; length decreased since we called
146                        (substring buf 0 new-size))
147                       (else
148                        buf)))))))))
149
150;; #:silent could, possibly, fail silently on errno/noattr or errno/exist.
151(define (set-extended-attribute! file attribute value . options)
152  (let ((c-options (xattr-options->int options))  ; 'create + 'replace results in EINVAL
153        (offset 0)
154        (setxattr (if (number? file)
155                      fsetxattr
156                      setxattr))
157        (attribute (if (symbol? attribute)
158                       (symbol->string attribute)
159                       attribute)))
160    (let ((size (cond ((blob? value) (blob-size value))
161                      ((string? value) (string-length value))
162                      (else (error 'set-extended-attribute!
163                                   "value must be a string or blob")))))
164      (let ((rv (setxattr file attribute value size offset c-options)))
165        (cond ((< rv 0)
166               (let ((err (update-errno)))
167                 (cond ((= err errno/noattr)
168                        (error 'set-extended-attribute!
169                               "attribute not found" attribute))
170                       ((= err errno/exist)   ;; EEXIST is confusing
171                        (error 'set-extended-attribute!
172                               "attribute already exists" attribute))
173                       (else
174                        (xattr-error err 'set-extended-attribute!
175                                     file attribute)))))
176              ((> rv 0)
177               (error 'set-extended-attribute!
178                      "unexpected return value" rv))
179              (else
180               (void)))))))
181
182;; Error signaled if attribute does not exist, but if you give the
183;; #:silent option it will fail silently.
184(define (remove-extended-attribute! file attribute . options)
185  (let ((c-options (xattr-options->int options))
186        (attribute (if (symbol? attribute)
187                       (symbol->string attribute)
188                       attribute))
189        (removexattr (if (number? file)
190                         fremovexattr
191                         removexattr)))
192    (let ((rv (removexattr file attribute c-options)))
193      (cond ((< rv 0)
194             (let ((err (update-errno)))
195               (if (and (= err errno/noattr)
196                        (memq #:silent options))
197                   (void)
198                   (xattr-error err 'remove-extended-attribute! file attribute))))
199            ((> rv 0)
200             (error 'remove-extended-attribute!
201                    "unexpected return value" rv))
202            (else
203             (void))))))
204
205;;; Utilities
206
207;; Returns an alist mapping attribute name (symbol) to value (string).
208;; Possible optimization: If passed a filename, and #:nofollow is not specified,
209;; we can open it and reuse the fd. (And must unwind-protect to close fd.)
210(define (get-extended-attributes file . options)
211  (map (lambda (a)
212         (cons (string->symbol a)
213               (apply get-extended-attribute file a options)))
214       (apply list-extended-attributes file options)))
215
216(define (clear-extended-attributes! file . options)
217  (for-each
218   (lambda (x)
219     (apply remove-extended-attribute! file x options))
220   (apply list-extended-attributes file options)))
221
222;; (define (get-resource-fork filename)
223;;   ...)
224
225
226)
Note: See TracBrowser for help on using the repository browser.