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

51
lib/chibi/tar.scm
View file

@ -1,4 +1,3 @@
(define-binary-record-type tar
(make (make-tar))
(write write-tar-raw)
@ -193,6 +192,29 @@
(tar-size-set! tar (bytevector-length content))
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
(define (tar-create tarball files . o)
(let* ((rename (if (pair? o) (car o) (lambda (f) f)))
@ -223,8 +245,8 @@
(dest (if (equal? x src0) dest0 (get-dest x)))
(content (if (equal? x src0) content0 (get-content x)))
(tar (if content
(inline->tar dest content)
(file->tar src))))
(inline->tar dest content)
(file->tar src))))
(tar-path-set! tar dest)
(cond
((assoc (tar-path tar) acc)
@ -237,17 +259,18 @@
(current-error-port)))
acc))
(else
(write-tar tar out)
(cond
((and (string? src) (equal? "0" (tar-type tar)))
(write-modulo-file out src 512))
(content
(write-bytevector content out)
(let ((rem (modulo (bytevector-length content) 512)))
(if (positive? rem)
(write-bytevector
(make-bytevector (- 512 rem) 0) out)))))
(cons (cons (tar-path tar) src) acc)))))
(let ((acc (tar-add-directories tar out acc)))
(write-tar tar out)
(cond
((and (string? src) (equal? "0" (tar-type tar)))
(write-modulo-file out src 512))
(content
(write-bytevector content out)
(let ((rem (modulo (bytevector-length content) 512)))
(if (positive? rem)
(write-bytevector
(make-bytevector (- 512 rem) 0) out)))))
(cons (cons (tar-path tar) src) acc))))))
(if (and src0 (not no-recurse?))
(directory-fold-tree src0 kons acc kons)
(kons src0 acc))))