file/tar: don't try to read link permissions or timestamp
Links don't (normally) have those properties, and attempting to read them makes a link fail when its target does not exist.
This commit is contained in:
parent
dac09d8faf
commit
0bb1bab059
|
@ -63,7 +63,8 @@
|
|||
|
||||
(define (zip-tests zip unzip timestamps?
|
||||
#:dir-name [ex1 "ex1"]
|
||||
#:file-name [f2 "f2"])
|
||||
#:file-name [f2 "f2"]
|
||||
#:links? [links? #f])
|
||||
(make-directory* ex1)
|
||||
(make-file (build-path ex1 "f1"))
|
||||
(make-file (build-path ex1 f2))
|
||||
|
@ -71,6 +72,10 @@
|
|||
(define more-dir (build-path ex1 "more"))
|
||||
(make-directory* more-dir)
|
||||
(make-file (build-path more-dir "f4"))
|
||||
(when links?
|
||||
(make-file-or-directory-link "f1" (build-path ex1 "f1-link"))
|
||||
(make-file-or-directory-link "more" (build-path ex1 "more-link"))
|
||||
(make-file-or-directory-link "no" (build-path ex1 "no-link")))
|
||||
|
||||
(zip "a.zip" ex1)
|
||||
(when timestamps? (sleep 3)) ; at least 2 seconds, plus 1 to likely change parity
|
||||
|
@ -111,8 +116,9 @@
|
|||
(zip-tests zip unzip #f)
|
||||
(zip-tests (make-zip #f) (make-unzip #f) 'file)
|
||||
(zip-tests (make-zip #t) (make-unzip #t) 'file)
|
||||
(zip-tests tar untar #t)
|
||||
(zip-tests tar untar #t #:links? #t)
|
||||
(zip-tests tar untar #t
|
||||
#:links? #t
|
||||
#:dir-name (make-string 64 #\d)
|
||||
#:file-name (make-string 64 #\f)))
|
||||
|
||||
|
|
|
@ -76,13 +76,21 @@
|
|||
(set! cksum (+ cksum d))
|
||||
(loop (sub1 q) (quotient n 8)))))
|
||||
(advance len))
|
||||
(define attrib-path
|
||||
(if link?
|
||||
;; For a link, use attributes of the containing directory:
|
||||
(let-values ([(base name dir?) (split-path path)])
|
||||
(or (and (path? base)
|
||||
base)
|
||||
(current-directory)))
|
||||
path))
|
||||
;; see http://www.mkssoftware.com/docs/man4/tar.4.asp for format spec
|
||||
(write-block tar-name-length file-name)
|
||||
(write-octal 8 (path-attributes path dir?))
|
||||
(write-octal 8 (path-attributes attrib-path dir?))
|
||||
(write-octal 8 0) ; always root (uid)
|
||||
(write-octal 8 0) ; always root (gid)
|
||||
(write-octal 12 size)
|
||||
(write-octal 12 (get-timestamp path))
|
||||
(write-octal 12 (get-timestamp attrib-path))
|
||||
;; set checksum later, consider it "all blanks" for cksum
|
||||
(set! cksum-p p) (set! cksum (+ cksum (* 8 32))) (advance 8)
|
||||
(write-block* 1 (if link? #"2" (if dir? #"5" #"0"))) ; type-flag: dir/file (no symlinks)
|
||||
|
|
Loading…
Reference in New Issue
Block a user