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

;;; HFS+ extended attribute interface

#> #include <sys/xattr.h>
   #include <errno.h>
<#

;; list-extended-attributes returns a list of strings.  get-* and set-*
;; accept a string or symbol as a key.  get-extended-attributes returns
;; keys as symbols.

;; If attribute key or value changes size between calls to determine
;; size of buffer, we will return the smaller buffer or retry the call if larger.

(declare
 (disable-interrupts)   ; solely for errno
 )

(module hfs+
 (list-extended-attributes
  get-extended-attribute set-extended-attribute!
  remove-extended-attribute!
  get-extended-attributes)

(import scheme chicken foreign)
(import (only data-structures string-split))
(import foreigners)

;; ssize_t listxattr(const char *path, char *namebuf, size_t size, int options);
;; ssize_t flistxattr(int fd, char *namebuf, size_t size, int options);
(define listxattr
  (foreign-lambda int listxattr (const c-string) scheme-pointer int int))
(define flistxattr
  (foreign-lambda int flistxattr int scheme-pointer int int))

;; ssize_t getxattr(const char *path, const char *name, void *value, size_t size,
;;                  u_int32_t position, int options);
(define getxattr
  (foreign-lambda int getxattr (const c-string) (const c-string) scheme-pointer int
                  int int))
(define fgetxattr
  (foreign-lambda int fgetxattr int (const c-string) scheme-pointer int
                  int int))

;; int setxattr(const char *path, const char *name, void *value, size_t size,
;;              u_int32_t position, int options);
(define setxattr
  (foreign-lambda int setxattr (const c-string) (const c-string) scheme-pointer int
                  int int))
(define fsetxattr
  (foreign-lambda int fsetxattr int (const c-string) scheme-pointer int
                  int int))

;; int removexattr(const char *path, const char *name, int options);
(define removexattr
  (foreign-lambda int removexattr (const c-string) (const c-string) int))

(define-foreign-enum-type (xattr-options int)
  (xattr-options->int int->xattr-options)
  ((no-follow xattr/nofollow) XATTR_NOFOLLOW)
  ((create xattr/create) XATTR_CREATE)
  ((replace xattr/replace) XATTR_REPLACE))

(define strerror
  (foreign-lambda c-string strerror int))
;; Warning: A SRFI-18 thread might change errno from under us (but we still detect the error).
(define (xattr-error rc loc . args)
  (signal
   (make-composite-condition
    (make-property-condition 'exn 'location loc 'message (strerror rc) 'arguments args)
    (make-property-condition 'file)
    (make-property-condition 'hfs+ 'errno rc))))

(define (update-errno)
  (##sys#update-errno))
(define errno/range (foreign-value "ERANGE" int))
(define errno/noattr (foreign-value "ENOATTR" int))
(define errno/exist (foreign-value "EEXIST" int))

;;; Base API

;; Accepted options: #:no-follow (or 'no-follow) to prevent following symlink; if passing
;; a file descriptor, it is illegal to specify this option.
(define (list-extended-attributes file . options)
  (let ((c-options (xattr-options->int options))      ; #:create or #:replace is ignored
        (listxattr (if (number? file)
                       flistxattr
                       listxattr)))
    (let retry ()
      (let ((size (listxattr file #f 0 c-options)))
        (cond ((< size 0)
               (xattr-error (update-errno) 'list-extended-attributes file))
              ((= size 0)
               '())
              (else
               (let* ((buf (make-string size))
                      (new-size (listxattr file buf size c-options)))
                 (cond ((< new-size 0)
                        (let ((err (update-errno)))
                          (if (= err errno/range)    ; length increased since we called
                              (retry)
                              (xattr-error err 'list-extended-attributes file))))
                       ((< new-size size)            ; length decreased since we called
                        (string-split (substring buf 0 new-size) "\x00"))
                       (else
                        (string-split buf "\x00") )))))))))

;; Returns #f if attribute does not exist.  Signals an error
;; on any other getxattr failure, including file not found.
(define (get-extended-attribute file attribute . options)
  (let ((c-options (xattr-options->int options))
        (offset 0)
        (getxattr (if (number? file)
                       fgetxattr
                       getxattr))
        (attribute (if (symbol? attribute)
                       (symbol->string attribute)
                       attribute)))
    (let retry ()
      (let ((size (getxattr file attribute #f 0 offset c-options)))
        (cond ((< size 0)
               (let ((err (update-errno)))
                 (cond ((= err errno/noattr)
                        #f)
                       (else
                        (xattr-error err 'get-extended-attribute
                                     file attribute)))))
              ((= size 0)
               "")
              (else
               (let* ((buf (make-string size))
                      (new-size (getxattr file attribute buf
                                          size offset c-options)))
                 (cond ((< new-size 0)
                        (let ((err (update-errno)))
                          (cond ((= err errno/noattr) #f)
                                ((= err errno/range)  (retry))
                                (else
                                 (xattr-error err 'get-extended-attribute
                                              file attribute)))))
                       ((< new-size size) ; length decreased since we called
                        (substring buf 0 new-size))
                       (else
                        buf)))))))))

(define (set-extended-attribute! file attribute value . options)
  (let ((c-options (xattr-options->int options))  ; 'create + 'replace results in EINVAL
        (offset 0)
        (setxattr (if (number? file)
                      fsetxattr
                      setxattr))
        (attribute (if (symbol? attribute)
                       (symbol->string attribute)
                       attribute)))
    (let ((size (cond ((blob? value) (blob-size value))
                      ((string? value) (string-length value))
                      (else (error 'set-extended-attribute!
                                   "value must be a string or blob")))))
      (let ((rv (setxattr file attribute value size offset c-options)))
        (cond ((< rv 0)
               (let ((err (update-errno)))
                 (cond ((= err errno/noattr)
                        (error 'set-extended-attribute!
                               "attribute not found" attribute))
                       ((= err errno/exist)   ;; EEXIST is confusing
                        (error 'set-extended-attribute!
                               "attribute already exists" attribute))
                       (else
                        (xattr-error err 'set-extended-attribute!
                                     file attribute)))))
              ((> rv 0)
               (error 'set-extended-attribute!
                      "unexpected return value" rv))
              (else
               (void)))))))

;; Error signaled if attribute does not exist.  Unsure about this.
(define (remove-extended-attribute! file attribute . options)
  (let ((c-options (xattr-options->int options)))
    (let ((rv (removexattr file attribute c-options)))
      (cond ((< rv 0)
             (let ((err (update-errno)))
               (xattr-error err 'remove-extended-attribute! file attribute)))
            (else
             (void))))))

;;; Utilities

;; Returns an alist mapping attribute name (symbol) to value (string).
;; Possible optimization: If passed a filename, and #:nofollow is not specified,
;; we can open it and reuse the fd. (And must unwind-protect to close fd.)
(define (get-extended-attributes file . options)
  (map (lambda (a)
         (cons (string->symbol a)
               (apply get-extended-attribute file a options)))
       (apply list-extended-attributes file options)))

;; (define (get-resource-fork filename)
;;   ...)


)