Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 13:49:17 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

tar-create skips duplicate outputs (gracefully for directories)

Browse source
This commit is contained in:
Alex Shinn 2014-06-10 20:49:07 +09:00
parent 1ab7d12b21
commit b4961ee70d
1 changed files with 25 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

38
lib/chibi/tar.scm
View file

@ -208,19 +208,30 @@
(let ((out (cond ((eq? #t tarball) (current-output-port)) (let ((out (cond ((eq? #t tarball) (current-output-port))
((eq? #f tarball) (open-output-bytevector)) ((eq? #f tarball) (open-output-bytevector))
(else (open-binary-output-file tarball))))) (else (open-binary-output-file tarball)))))
(for-each (fold
(lambda (file) (lambda (file acc)
(let ((src0 (get-src file)) (let ((src0 (get-src file))
(dest0 (get-dest file)) (dest0 (get-dest file))
(content0 (get-content file))) (content0 (get-content file)))
(define (kons x acc) (define (kons x acc)
(let ((src (get-src x)) (let* ((src (get-src x))
(dest (if (equal? x src0) dest0 (get-dest x))) (dest (if (equal? x src0) dest0 (get-dest x)))
(content (if (equal? x src0) content0 (get-content x)))) (content (if (equal? x src0) content0 (get-content x)))
(let ((tar (if content (tar (if content
(inline->tar dest content) (inline->tar dest content)
(file->tar src)))) (file->tar src))))
(tar-path-set! tar dest) (tar-path-set! tar dest)
(cond
((assoc (tar-path tar) acc)
=> (lambda (prev)
(if (not (and (file-directory? src)
(file-directory? (cdr prev))))
(write-string
(string-append "tar-create: duplicate file: "
dest "\n")
(current-error-port)))
acc))
(else
(write-tar tar out) (write-tar tar out)
(cond (cond
((and (string? src) (equal? "0" (tar-type tar))) ((and (string? src) (equal? "0" (tar-type tar)))
@ -230,11 +241,12 @@
(let ((rem (modulo (bytevector-length content) 512))) (let ((rem (modulo (bytevector-length content) 512)))
(if (positive? rem) (if (positive? rem)
(write-bytevector (write-bytevector
(make-bytevector (- 512 rem) 0) out)))))))) (make-bytevector (- 512 rem) 0) out)))))
(cons (cons (tar-path tar) src) acc)))))
(if (and src0 (not no-recurse?)) (if (and src0 (not no-recurse?))
(directory-fold-tree src0 kons #f kons) (directory-fold-tree src0 kons acc kons)
(kons src0 #f)))) (kons src0 acc))))
files) '() files)
(write-bytevector (make-bytevector 1024 0) out) (write-bytevector (make-bytevector 1024 0) out)
(let ((res (if (eq? #f tarball) (get-output-bytevector out)))) (let ((res (if (eq? #f tarball) (get-output-bytevector out))))
(close-output-port out) (close-output-port out)