mac creator and type support

collects/mred/private/wx/cocoa/finfo.rkt

@@ -0,0 +1,149 @@
+#lang racket/base
+(require ffi/unsafe
+         ffi/unsafe/define
+         "utils.rkt"
+         "types.rkt")
+
+(provide file-creator-and-type)
+
+(define coreserv-lib (ffi-lib (format "/System/Library/Frameworks/CoreServices.framework/CoreServices")))
+
+(define-ffi-definer define-coreserv coreserv-lib)
+
+(define kFSCatInfoFinderInfo #x00000800)
+(define _FSCatalogInfoBitmap _uint32)
+
+(define _FSVolumeRefNum _int16)
+
+(define-cstruct _UTCDateTime
+  #:alignment 2
+  ([highSeconds _uint16]
+   [lowSeconds _uint32]
+   [fraction _uint16]))
+
+(define-cstruct _Point
+  ([v _short]
+   [h _short]))
+
+(define _OSType _uint32)
+
+(define-cstruct _FileInfo
+  #:alignment 2
+  ([fileType _OSType]
+   [fileCreator _OSType]
+   [finderFlags _uint16]
+   [location _Point]
+   [reservedField _uint16]))
+
+(define-cstruct _FSPermissionInfo
+  #:alignment 2
+  ([userID _uint32]
+   [groupID _uint32]
+   [word _uint32]
+   [fileSec _pointer]))
+
+(define-cstruct _FSCatalogInfo
+  #:alignment 2
+  ([nodeFlags _uint16]
+   [volume _FSVolumeRefNum]
+   [parentDirID _uint32]
+   [nodeID _uint32]
+   [sharingFlags _uint8]
+   [userPrivileges _uint8]
+   [reserved1 _uint8]
+   [reserved2 _uint8]
+   [createDate _UTCDateTime]
+   [contentModDate _UTCDateTime]
+   [attributeModDate _UTCDateTime]
+   [accessDate _UTCDateTime]
+   [backupDate _UTCDateTime]
+   [permissions _FSPermissionInfo]
+   [finderInfo _FileInfo]
+   ;; .... 144 or 148 bytes total
+   ))
+
+(define _FSRef _pointer) ; 80 bytes
+
+(define _OSStatus _sint32)
+
+(define-coreserv FSPathMakeRef (_fun _path _FSRef (_pointer = #f) -> _OSStatus))
+
+(define-coreserv FSGetCatalogInfo
+  (_fun _FSRef
+        _FSCatalogInfoBitmap 
+        _FSCatalogInfo-pointer
+        _pointer ; outname, #f is ok
+        _pointer ; fsSpec, #f is ok
+        _pointer ; parentRef, #f is ok
+        -> _OSStatus))
+
+(define-coreserv FSSetCatalogInfo
+  (_fun _FSRef
+        _FSCatalogInfoBitmap 
+        _FSCatalogInfo-pointer
+        -> _OSStatus))
+
+(define (path->fsref s)
+  (let ([fs (malloc 80)])
+    (let ([r (FSPathMakeRef s fs)])
+      (unless (zero? r)
+        (error 'file-creator-and-type "could not access file (~a): ~v"
+               r
+               s)))
+    fs))
+
+(define (int->str v)
+  (bytes (arithmetic-shift (bitwise-and v #xFF000000) -24)
+         (arithmetic-shift (bitwise-and v #xFF0000) -16)
+         (arithmetic-shift (bitwise-and v #xFF00) -8)
+         (bitwise-and v #xFF)))
+
+(define (str->int v)
+  (bitwise-ior (arithmetic-shift (bytes-ref v 0) 24)
+               (arithmetic-shift (bytes-ref v 1) 16)
+               (arithmetic-shift (bytes-ref v 2) 8)
+               (bytes-ref v 3)))
+
+
+(define (get-info v fs path)
+  (let ([r (FSGetCatalogInfo fs
+                             kFSCatInfoFinderInfo
+                             v
+                             #f #f #f)])
+    (unless (zero? r)
+      (error 'file-creator-and-file "lookup failed (~a): ~e"
+             r
+             path))))
+
+(define file-creator-and-type
+  (case-lambda
+   [(path)
+    (unless (path-string? path)
+      (raise-type-error 'file-creator-and-type "path string" path))
+    (let ([info (let ([fs (path->fsref path)]
+                      [v (cast (malloc 256) _pointer _FSCatalogInfo-pointer)])
+                  (get-info v fs path)
+                  (FSCatalogInfo-finderInfo v))])
+      (values (int->str (FileInfo-fileCreator info))
+              (int->str (FileInfo-fileType info))))]
+   [(path creator type)
+    (unless (path-string? path)
+      (raise-type-error 'file-creator-and-type "path string" path))
+    (unless (and (bytes? creator) (= 4 (bytes-length creator)))
+      (raise-type-error 'file-creator-and-type "bytes string of length 4" creator))
+    (unless (and (bytes? type) (= 4 (bytes-length type)))
+      (raise-type-error 'file-creator-and-type "bytes string of length 4" type))
+    (let ([fs (path->fsref path)]
+          [v (cast (malloc 256) _pointer _FSCatalogInfo-pointer)])
+      (let ([info (FSCatalogInfo-finderInfo v)])
+        (get-info v fs path)
+        (set-FileInfo-fileCreator! info (str->int creator))
+        (set-FileInfo-fileType! info (str->int type)))
+      (let ([r (FSSetCatalogInfo fs
+                                 kFSCatInfoFinderInfo
+                                 v)])
+        (unless (zero? r)
+          (error 'file-creator-and-file "change failed (~a): ~e"
+                 r
+                 path))))
+    (void)]))

collects/mred/private/wx/cocoa/procs.rkt

@@ -7,6 +7,7 @@
          "utils.rkt"
          "types.rkt"
          "frame.rkt"
+         "finfo.rkt" ; file-creator-and-type
          "../../lock.rkt"
          "../common/handlers.rkt")
 
@@ -77,7 +78,6 @@
 (define (set-executer proc)
   (void))
 (define-unimplemented send-event)
-(define-unimplemented file-creator-and-type)
 (define (begin-refresh-sequence) (void))
 (define (end-refresh-sequence) (void))
 (define-unimplemented run-printout)