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

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) (define (tar-path tar)
(string-append (tar-path-prefix tar) (tar-path-raw 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) (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) (cond ((< len 100)
(tar-path-raw-set! tar path)) (tar-path-raw-set! tar path))
((< len 255) ((< len 255)
@ -184,10 +191,12 @@
;; 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)))
(no-recurse? (and (pair? o) (pair? (cdr o)) (cadr o)))
(get-src (get-src
(lambda (x) (if (pair? x) (and (eq? 'rename (car x)) (cadr x)) x))) (lambda (x) (if (pair? x) (and (eq? 'rename (car x)) (cadr x)) x)))
(get-dest (get-dest
(lambda (x) (rename (if (pair? x) (lambda (x)
(rename (if (pair? x)
(if (eq? 'rename (car x)) (if (eq? 'rename (car x))
(car (cddr x)) (car (cddr x))
(cadr x)) (cadr x))
@ -222,7 +231,7 @@
(if (positive? rem) (if (positive? rem)
(write-bytevector (write-bytevector
(make-bytevector (- 512 rem) 0) out)))))))) (make-bytevector (- 512 rem) 0) out))))))))
(if src0 (if (and src0 (not no-recurse?))
(directory-fold-tree src0 kons #f kons) (directory-fold-tree src0 kons #f kons)
(kons src0 #f)))) (kons src0 #f))))
files) files)