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

Auto-normalizing directory paths in tar-create to have a / suffix.

Browse source
This commit is contained in:
Alex Shinn 2014-05-27 06:23:19 +09:00
parent 31bbbfc8ad
commit c558f19743
1 changed files with 16 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

15
lib/chibi/tar.scm
View file

@ -40,8 +40,15 @@
(define (tar-path tar)
(string-append (tar-path-prefix tar) (tar-path-raw tar)))
(define (tar-normalize-path tar path)
(cond ((string-suffix? "/." path) (string-trim-right path #\.))
((and (not (string-suffix? "/" path)) (equal? "5" (tar-type tar)))
(string-append path "/"))
(else path)))
(define (tar-path-set! tar path)
(let ((len (string-length path)))
(let* ((path (tar-normalize-path tar path))
(len (string-length path)))
(cond ((< len 100)
(tar-path-raw-set! tar path))
((< len 255)
@ -184,10 +191,12 @@
;; create an archive for a given file list
(define (tar-create tarball files . o)
(let* ((rename (if (pair? o) (car o) (lambda (f) f)))
(no-recurse? (and (pair? o) (pair? (cdr o)) (cadr o)))
(get-src
(lambda (x) (if (pair? x) (and (eq? 'rename (car x)) (cadr x)) x)))
(get-dest
(lambda (x) (rename (if (pair? x)
(lambda (x)
(rename (if (pair? x)
(if (eq? 'rename (car x))
(car (cddr x))
(cadr x))
@ -222,7 +231,7 @@
(if (positive? rem)
(write-bytevector
(make-bytevector (- 512 rem) 0) out))))))))
(if src0
(if (and src0 (not no-recurse?))
(directory-fold-tree src0 kons #f kons)
(kons src0 #f))))
files)