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:
Matthew Flatt 2014-07-15 16:51:48 +01:00
parent dac09d8faf
commit 0bb1bab059
2 changed files with 18 additions and 4 deletions

View File

@ -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)))

View File

@ -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)