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

Ensuring parent directories in tar-create.

Browse source
This commit is contained in:
Alex Shinn 2014-08-24 21:19:47 +09:00
parent 89661f8b75
commit 101c61f083
1 changed files with 37 additions and 14 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

27
lib/chibi/tar.scm
View file

@ -1,4 +1,3 @@
(define-binary-record-type tar (define-binary-record-type tar
(make (make-tar)) (make (make-tar))
(write write-tar-raw) (write write-tar-raw)
@ -193,6 +192,29 @@
(tar-size-set! tar (bytevector-length content)) (tar-size-set! tar (bytevector-length content))
tar)) tar))
(define (tar-add-directories tar out acc)
(let lp ((dir (path-directory (tar-path tar))) (acc acc))
(let ((dir/ (if (string-suffix? "/" dir) dir (string-append dir "/"))))
(cond
((member dir '("" "." "/")) acc)
((assoc dir/ acc) (lp (path-directory dir) acc))
(else
(let ((acc (lp (path-directory dir) (cons (cons dir/ #f) acc))))
(let ((tar2 (make-tar)))
(tar-path-set! tar2 dir/)
(tar-ustar-set! tar2 "ustar")
(tar-ustar-version-set! tar2 "00")
(tar-mode-set! tar2 (bitwise-ior #o111 (tar-mode tar) ))
(tar-uid-set! tar2 (tar-uid tar))
(tar-gid-set! tar2 (tar-gid tar))
(tar-owner-set! tar2 (tar-owner tar))
(tar-group-set! tar2 (tar-group tar))
(tar-time-set! tar2 (tar-time tar))
(tar-type-set! tar2 "5")
(tar-size-set! tar2 0)
(write-tar tar2 out)
acc)))))))
;; create an archive for a given file list ;; create an archive for a given file list
(define (tar-create tarball files . o) (define (tar-create tarball files . o)
(let* ((rename (if (pair? o) (car o) (lambda (f) f))) (let* ((rename (if (pair? o) (car o) (lambda (f) f)))
@ -237,6 +259,7 @@
(current-error-port))) (current-error-port)))
acc)) acc))
(else (else
(let ((acc (tar-add-directories tar out acc)))
(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)))
@ -247,7 +270,7 @@
(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))))) (cons (cons (tar-path tar) src) acc))))))
(if (and src0 (not no-recurse?)) (if (and src0 (not no-recurse?))
(directory-fold-tree src0 kons acc kons) (directory-fold-tree src0 kons acc kons)
(kons src0 acc)))) (kons src0 acc))))