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 (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)))
@ -223,8 +245,8 @@
(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)))
(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 (cond
((assoc (tar-path tar) acc) ((assoc (tar-path tar) acc)
@ -237,17 +259,18 @@
(current-error-port))) (current-error-port)))
acc)) acc))
(else (else
(write-tar tar out) (let ((acc (tar-add-directories tar out acc)))
(cond (write-tar tar out)
((and (string? src) (equal? "0" (tar-type tar))) (cond
(write-modulo-file out src 512)) ((and (string? src) (equal? "0" (tar-type tar)))
(content (write-modulo-file out src 512))
(write-bytevector content out) (content
(let ((rem (modulo (bytevector-length content) 512))) (write-bytevector content out)
(if (positive? rem) (let ((rem (modulo (bytevector-length content) 512)))
(write-bytevector (if (positive? rem)
(make-bytevector (- 512 rem) 0) out))))) (write-bytevector
(cons (cons (tar-path tar) src) acc))))) (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 acc kons) (directory-fold-tree src0 kons acc kons)
(kons src0 acc)))) (kons src0 acc))))