155 lines
4.6 KiB
Racket
155 lines
4.6 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
ffi/unsafe/define
|
|
"utils.rkt"
|
|
"types.rkt")
|
|
|
|
(provide
|
|
(protect-out 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
|
|
([highSeconds _uint16]
|
|
[lowSeconds _uint32]
|
|
[fraction _uint16])
|
|
#:alignment 2)
|
|
|
|
(define-cstruct _Point
|
|
([v _short]
|
|
[h _short]))
|
|
|
|
(define _OSType _uint32)
|
|
|
|
(define-cstruct _FileInfo
|
|
([fileType _OSType]
|
|
[fileCreator _OSType]
|
|
[finderFlags _uint16]
|
|
[location _Point]
|
|
[reservedField _uint16])
|
|
#:alignment 2)
|
|
|
|
(define-cstruct _FSPermissionInfo
|
|
([userID _uint32]
|
|
[groupID _uint32]
|
|
[word _uint32]
|
|
[fileSec _pointer])
|
|
#:alignment 2)
|
|
|
|
(define-cstruct _FSCatalogInfo
|
|
([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
|
|
)
|
|
#:alignment 2)
|
|
|
|
(define _FSRef _pointer) ; 80 bytes
|
|
|
|
(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)
|
|
(filesystem-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)
|
|
(filesystem-error 'file-creator-and-type "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) _gcpointer (_gcable _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) _gcpointer (_gcable _FSCatalogInfo-pointer))])
|
|
(get-info v fs path)
|
|
(let ([info (FSCatalogInfo-finderInfo v)])
|
|
(set-FileInfo-fileCreator! info (str->int creator))
|
|
(set-FileInfo-fileType! info (str->int type)))
|
|
(let ([r (FSSetCatalogInfo fs
|
|
kFSCatInfoFinderInfo
|
|
v)])
|
|
(unless (zero? r)
|
|
(filesystem-error 'file-creator-and-type "change failed (~a): ~e"
|
|
r
|
|
path))))
|
|
(void)]))
|
|
|
|
|
|
(define (filesystem-error sym fmt . args)
|
|
(raise (exn:fail:filesystem
|
|
(string-append (format "~a: " sym)
|
|
(apply format fmt args))
|
|
(current-continuation-marks))))
|