Changeset 15278 in project

Timestamp:

07/31/09 00:49:53 (10 years ago)

Author:

Jim Ursetto

Message:

hfs+: update to version 0.3 (copyfile)

Location:

release/4/hfs+/trunk

Files:

• copyfile.h (added)
• hfs+.meta (modified) (1 diff)
• hfs+.scm (modified) (7 diffs)
• hfs+.setup (modified) (1 diff)
• test.scm (modified) (1 diff)

release/4/hfs+/trunk/hfs+.meta

@@ -7 +7 @@
  (doc-from-wiki)
  (needs foreigners)
- (files "hfs+.scm" "hfs+.setup" "hfs+.html"))
+ (files "hfs+.scm" "hfs+.setup" "hfs+.html" "copyfile.h"))

release/4/hfs+/trunk/hfs+.scm

@@ -1 +1 @@
 ;;; HFS+ extended attribute interface
 
+;; Copyright (c) 2009 Jim Ursetto.  All Rights Reserved.
+;; License: BSD.  However, see copyfile.h, which is included
+;; in this distribution, and is under the APSL.
+
 #> #include <sys/xattr.h>
+   /* copyfile.h can be obtained from
+    * http://www.opensource.apple.com/source/Libc/Libc-391.5.18/darwin/copyfile.h */
+   #include "copyfile.h"
    #include <errno.h>
 <#
@@ -21 +28 @@
   remove-extended-attribute!
   get-extended-attributes
-  clear-extended-attributes!)
+  clear-extended-attributes!
+  copyfile copyfile-check
+  pack-appledouble unpack-appledouble)
 
 (import scheme chicken foreign)
@@ -58 +67 @@
   (foreign-lambda int fremovexattr int (const c-string) int))
 
+(define _copyfile
+  (foreign-lambda int copyfile (const c-string) (const c-string) c-pointer int))
+
 (define-foreign-enum-type (xattr-options int)
   (xattr-options->int int->xattr-options)
@@ -64 +76 @@
   ((replace xattr/replace) XATTR_REPLACE)
   ((silent xattr/silent) "0")  ; hack -- not a real API option :)
+  )
+
+(define-foreign-enum-type (copyfile-options int)
+  (copyfile-options->int int->copyfile-options)
+  ((acl copyfile/acl) COPYFILE_ACL)
+  ((stat copyfile/stat) COPYFILE_STAT)
+  ((xattr copyfile/xattr) COPYFILE_XATTR)
+  ((data copyfile/data) COPYFILE_DATA)
+  ((security copyfile/security) COPYFILE_SECURITY)
+  ((metadata copyfile/metadata) COPYFILE_METADATA)
+  ((all copyfile/all) COPYFILE_ALL)
+  ((check copyfile/check) COPYFILE_CHECK)
+  ((pack copyfile/pack) COPYFILE_PACK)
+  ((unpack copyfile/unpack) COPYFILE_UNPACK)
+  ((exclusive copyfile/excl) COPYFILE_EXCL)
+  ((no-follow-source copyfile/no-follow-source) COPYFILE_NOFOLLOW_SRC)
+  ((no-follow-dest copyfile/no-follow-dest) COPYFILE_NOFOLLOW_DST)
+  ((move copyfile/move) COPYFILE_MOVE)
+  ((unlink copyfile/unlink) COPYFILE_UNLINK)
+  ((no-follow copyfile/no-follow) COPYFILE_NOFOLLOW)
+;;   ((silent copyfile/silent) "0")  ; hack -- not a real API option :)
   )
 
@@ -82 +115 @@
 (define errno/exist (foreign-value "EEXIST" int))
 
-;;; Base API
+;;; Base API - Extended attributes
 
 ;; Accepted options: #:no-follow (or 'no-follow) to prevent following symlink; if passing
@@ -203 +236 @@
              (void))))))
 
+;;; Base API - Copyfile
+
+;; [copyfile is not officially supported on Tiger and, although metadata pack/unpack
+;;  to AppleDouble files seems to work fine, copying actual data via #:data or #:all
+;;  will throw a spurious error or crash.  #:move doesn't seem to work, but #:excl does.
+;;  #:no-follow is ignored for packing (critical) and unpacking (not).]
+
+;; Copies FROM file to TO file using OS X copyfile(3) API,
+;; preserving HFS+ metadata as specified in copyfile OPTIONS.
+(define (copyfile from to . options)
+  (let ((c-options (copyfile-options->int options)))
+    (let ((rv (_copyfile from to #f c-options)))
+      (cond ((< rv 0)
+             (xattr-error (update-errno) 'copyfile
+                          from to))
+            (else rv)))))
+
 ;;; Utilities
 
@@ -223 +273 @@
 ;;   ...)
 
+;; Pack/unpack all HFS+ metadata (xattrs, acls, POSIX stat).  If no
+;; error occurs, pack returns #f when no metadata was present (and
+;; does not write a file) or #t if metadata was present (and a file is
+;; written).  Unpack always returns #t.  Extra options are passed into
+;; copyfile; relevant ones might be #:excl, #:move and #:no-follow,
+;; although #:move and #:no-follow do not work correctly under Tiger.
+(define (pack-appledouble from to . options)
+  (if (= 0 (apply copyfile from #f #:check #:metadata options))
+      #f
+      (and (apply copyfile from to #:pack #:metadata options) #t)))
+(define (unpack-appledouble from to . options)
+  (and (apply copyfile from to #:unpack #:metadata options) #t))
+
+;; Return a list of symbols denoting the attributes that WOULD be
+;; copied from the FROM file, according to the OPTIONS provided.
+;; Example call: (copyfile-check "foo.txt" #:metadata)
+;; Example return: '(acl stat extended-attributes) meaning
+;; COPYFILE_ACL, COPYFILE_STAT, COPYFILE_XATTR.
+(define (copyfile-check from . options)
+  (let ((options (cons 'check options)))
+    (let ((rv (apply copyfile from #f options)))
+      (cond ((= rv 0) '())
+            ((> rv 0)
+             ;; enumtypes won't decompose into their component bitfields
+             ;; we could also case all 8 possibilities
+             `(,@(if (= 0 (bitwise-and rv copyfile/acl)) '() '(acls))
+               ,@(if (= 0 (bitwise-and rv copyfile/stat)) '() '(stat))
+               ,@(if (= 0 (bitwise-and rv copyfile/xattr)) '() '(extended-attributes))))
+            (else (error 'copyfile-check "unexpected copyfile return value" rv))))))
 
 )

release/4/hfs+/trunk/hfs+.setup

@@ -4 +4 @@
  'foreigners
  '("hfs+.so" "hfs+.import.so")
- '((version 0.2)))
+ '((version 0.3)))

release/4/hfs+/trunk/test.scm

@@ -4 +4 @@
 (use hfs+)
 (use files)
+(use posix)
 
 ;; Assumes UNIX files are created with no attributes.
-;; Untested: NOFOLLOW.  Setting resource forks.  Finder info.  Removing resource forks
-;; (evidently must set to "").
+;; Untested: Finder info.  Removing resource forks
+;; (must set to "").
 
-(define file (create-temporary-file "hfs-test"))
+(test-group
+ "extended-attribute handling"
 
-(test "empty initial attribute set"
- '()
- (list-extended-attributes file))
+ (define file (create-temporary-file "hfs-test"))
+ (define link (string-append file ".link")) ; meh
+
+ (test "empty initial attribute set"
+       '()
+       (list-extended-attributes file))
 
 ;; (set-extended-attribute! file "com.apple.FinderInfo" (make-string 32 #\x00))
-(set-extended-attribute! file "chicken.baz" "quux")
-(set-extended-attribute! file "chicken.zot" "erp")
-(set-extended-attribute! file "chicken.foo" "bar")
+ (set-extended-attribute! file "chicken.baz" "quux")
+ (set-extended-attribute! file "chicken.zot" "erp")
+ (set-extended-attribute! file "chicken.foo" "bar")
 
-(test "list three attributes in chicken namespace"
-      '("chicken.baz" "chicken.foo" "chicken.zot")
-      (sort (list-extended-attributes file) string<?))
-(test "get three attributes in chicken namespace"
-      '("quux" "erp" "bar")
-      (list (get-extended-attribute file "chicken.baz")
-            (get-extended-attribute file "chicken.zot")
-            (get-extended-attribute file "chicken.foo")))
+ (test "list three attributes in chicken namespace"
+       '("chicken.baz" "chicken.foo" "chicken.zot")
+       (sort (list-extended-attributes file) string<?))
+ (test "get three attributes in chicken namespace"
+       '("quux" "erp" "bar")
+       (list (get-extended-attribute file "chicken.baz")
+             (get-extended-attribute file "chicken.zot")
+             (get-extended-attribute file "chicken.foo")))
 
-(test "replace existing attribute"
-      #t
-      (begin
-        (set-extended-attribute! file "chicken.foo" "bar-updated" #:replace)
-        #t))
-(test-error "replace non-existent attribute (error)"
-            (set-extended-attribute! file "chicken.foo" "bar-updated" #:update))
-(test "create non-existent attribute ok"
-      #t
-      (begin
-        (set-extended-attribute! file "chicken.new" "new" #:create)
-        #t))
-(test-error "create existing attribute (error)"
-            (set-extended-attribute! file "chicken.new" "new" #:create))
+ (test "replace existing attribute"
+       #t
+       (begin
+         (set-extended-attribute! file "chicken.foo" "bar-updated" #:replace)
+         #t))
+ (test-error "replace non-existent attribute (error)"
+             (set-extended-attribute! file "chicken.foo" "bar-updated" #:update))
+ (test "create non-existent attribute ok"
+       #t
+       (begin
+         (set-extended-attribute! file "chicken.new" "new" #:create)
+         #t))
+ (test-error "create existing attribute (error)"
+             (set-extended-attribute! file "chicken.new" "new" #:create))
 
-(remove-extended-attribute! file "chicken.foo")
-(test "three attributes after one removed"
-      '("chicken.baz" "chicken.new" "chicken.zot")
-      (sort (list-extended-attributes file) string<?))
+ (remove-extended-attribute! file "chicken.foo")
+ (test "three attributes after one removed"
+       '("chicken.baz" "chicken.new" "chicken.zot")
+       (sort (list-extended-attributes file) string<?))
 
-(for-each (lambda (x)
-            (remove-extended-attribute! file x))
-          (list-extended-attributes file))
-(test "remove remaining attributes"
-      '()
-      (sort (list-extended-attributes file) string<?))
+ (create-symbolic-link file link)
+ (set-extended-attribute! link "chicken.link" "nugget" #:no-follow)
+ (test "get attributes, following link"
+       (list "quux" #f)
+       (list (get-extended-attribute link "chicken.baz")
+             (get-extended-attribute link "chicken.link")))
+ (test "get attributes, on link itself"
+       (list #f "nugget")
+       (list (get-extended-attribute link "chicken.baz"  #:no-follow)
+             (get-extended-attribute link "chicken.link" #:no-follow)))
 
-(test-error "remove non-existent attribute (error)"
-            (remove-extended-attribute! file "chicken.baz"))
+ (for-each (lambda (x)
+             (remove-extended-attribute! file x))
+           (list-extended-attributes file))
+ (test "remove remaining attributes"
+       '()
+       (sort (list-extended-attributes file) string<?))
+
+ (test-error "remove non-existent attribute (error)"
+             (remove-extended-attribute! file "chicken.baz"))
+
+ (delete-file file)
+ (delete-file link))
+
+;;; copyfile
+
+(test-group
+ "copyfile"
+
+;; Untested: ACL preservation
+;; Can't test on Tiger: copyfile data->data ; will segfault
+
+ (set! file (create-temporary-file "hfs-test"))
+ (set! link (string-append file ".link")) ; meh
+ (set! unpacked-file (create-temporary-file "hfs-test"))
+ (define packed-file (string-append "._" file))
+ (define packed-link (string-append "._" link))
+ (set! unpacked-link-file (create-temporary-file "hfs-test"))
+ (set! unpacked-link (string-append unpacked-link-file ".link")) 
+
+ (test (string-append "set extended attributes on " file)
+       #t
+       (begin
+         (set-extended-attribute! file "com.apple.ResourceFork" "spoon!")
+         (set-extended-attribute! file "org.3e8.private" "eye")
+         #t))
+ (test (string-append "pack " file " to appledouble " packed-file)
+       #t
+       (pack-appledouble file packed-file))
+ (test (string-append "unpack " file " to " unpacked-file)
+       #t
+       (unpack-appledouble packed-file unpacked-file))
+ (test (string-append "recover resource fork from " unpacked-file)
+       "spoon!"
+       (get-extended-attribute unpacked-file "com.apple.ResourceFork"))
+ (test (string-append "recover private attribute from " unpacked-file)
+       "eye"
+       (get-extended-attribute unpacked-file "org.3e8.private"))
+
+ (test (string-append "check attributes on " unpacked-file)
+       '(xattr)
+       (copyfile-check unpacked-file #:metadata))
+
+ ;; Attempt to copy attributes from a symbolic link to another symbolic link.
+ ;; This will fail on 10.4, which does not honor no-follow on unpack/pack.
+ ;; Set attributes on the links and backing files beforehand so we can
+ ;; see what propagates through.
+ (create-symbolic-link file link)
+ (create-symbolic-link unpacked-link-file unpacked-link)
+ (set-extended-attribute! link "org.3e8.private" "file")
+ (set-extended-attribute! link "org.3e8.private" "link" #:no-follow)
+ (set-extended-attribute! unpacked-link "org.3e8.private"
+                          "unpacked-link" #:no-follow)
+ (set-extended-attribute! unpacked-link-file "org.3e8.private"
+                          "unpacked-link-file" #:no-follow)
+ (pack-appledouble link packed-link #:no-follow)
+ (unpack-appledouble packed-link unpacked-link #:no-follow)
+ (test (string-append "recover private attribute from symlink (fails on 10.4)")
+       "link"
+       (get-extended-attribute unpacked-link "org.3e8.private" #:no-follow))
+ (test (string-append "recover private attribute from backing file (fails on 10.4)")
+       "unpacked-link-file"
+       (get-extended-attribute link "org.3e8.private"))
+ 
+ (delete-file file)
+ (delete-file link)
+ (delete-file unpacked-file)
+ (delete-file unpacked-link)
+ (delete-file unpacked-link-file) 
+ (delete-file packed-file)
+ (delete-file packed-link))
+
+(test-group
+ "unimplemented or untested"
+ (test (string-append "copyfile #:data")
+       0
+       (error "cannot test data->data copyfile on Tiger, may segfault")))
 
 ;;; further tests go here
-
-(delete-file file)