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

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

import hfs+ egg

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