suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

ds-store/alias: fix for Mac OS X 10.4

Browse Source
This commit is contained in:
Matthew Flatt 2013-09-10 07:47:31 -06:00
parent 24fc16674b
commit 1829a03bb6
1 changed files with 37 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
pkgs/ds-store-pkgs/ds-store-lib/alias.rkt
View File

@ -14,7 +14,29 @@
(get-ffi-obj 'FSNewAliasFromPath
CoreServices
(_fun _path _path _int (h : (_ptr o _pointer)) (_ptr io _int) -> (r : _int) -> (if (zero? r) h #f))
(lambda () #f)))
;; Fallback when FSNewAliasFromPath is not available:
(define _FSRef _pointer) ; 80 bytes
(define FSPathMakeRef
(get-ffi-obj 'FSPathMakeRef
CoreServices
(_fun _path _FSRef (_pointer = #f) -> (r : _int)
-> (unless (zero? r)
(error 'FSPathMakeRef "failed")))))
(define FSNewAliasUnicode
(get-ffi-obj 'FSNewAliasUnicode
CoreServices
(_fun _FSRef
_FSRef
_uint
_string/utf-16
(h : (_ptr o _pointer))
(_ptr io _int)
-> (r : _int)
-> (if (zero? r) h #f))
make-unavailable))
(define GetAliasSize
(get-ffi-obj 'GetAliasSize
CoreServices
@ -29,10 +51,21 @@
(define (path->alias-bytes file
#:wrt [wrt #f])
(define h
(FSNewAliasFromPath wrt
file
0
0))
(if FSNewAliasFromPath
(FSNewAliasFromPath wrt
file
0
0)
(let ([wrt-fs (and wrt (malloc 80))]
[fs (malloc 80)])
(when wrt (FSPathMakeRef wrt wrt-fs))
(define-values (base name dir?) (split-path file))
(FSPathMakeRef base fs)
(FSNewAliasUnicode wrt-fs
fs
(string-length (path->string name)) ; FIXME: should be utf-16 count
(path->string name)
0))))
(and h
(let ([sz (GetAliasSize h)])
(define bstr (make-bytes sz))