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

file/untar: try to better accomodate Windows permissions

Browse Source
This commit is contained in:
Matthew Flatt 2012-11-19 17:06:07 -07:00
parent 68bdf190d7
commit a9d2a8a764
1 changed files with 20 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
collects/file/untar.rkt
View File

@ -113,10 +113,10 @@
(lambda () (lambda ()
(try-file-op (try-file-op
(lambda () (lambda ()
(file-or-directory-permissions filename mode))) (file-or-directory-permissions* filename mode #t)))
(try-file-op (try-file-op
(lambda () (lambda ()
(file-or-directory-modify-seconds filename mod-time)))) (file-or-directory-modify-seconds* filename mod-time #t))))
delays)] delays)]
[(file) [(file)
(define-values (base name dir?) (split-path filename)) (define-values (base name dir?) (split-path filename))
@ -128,10 +128,10 @@
(copy-bytes size in out))) (copy-bytes size in out)))
(try-file-op (try-file-op
(lambda () (lambda ()
(file-or-directory-permissions filename mode))) (file-or-directory-permissions* filename mode #f)))
(try-file-op (try-file-op
(lambda () (lambda ()
(file-or-directory-modify-seconds filename mod-time))) (file-or-directory-modify-seconds* filename mod-time #f)))
(copy-bytes (- total-len size) in #f) (copy-bytes (- total-len size) in #f)
delays] delays]
[(link) [(link)
@ -192,3 +192,19 @@
(log-error "untar: ~a" (exn-message exn)) (log-error "untar: ~a" (exn-message exn))
(void))]) (void))])
(thunk))) (thunk)))
(define (file-or-directory-modify-seconds* filename mod-time dir?)
(unless (and dir? (eq? (system-type) 'windows))
(file-or-directory-modify-seconds filename mod-time)))
(define (file-or-directory-permissions* file perms dir?)
(file-or-directory-permissions file
(case (system-type)
[(windows)
;; corce perms to be the same for user, group, and others
(define user-perms (bitwise-and #o700))
(bitwise-ior user-perms
(arithmetic-shift user-perms -3)
(arithmetic-shift user-perms -6))]
[else perms])))