From 80879d26834cbe6bf421d65c57cf0378c235b945 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 10 May 2014 08:07:09 -0400 Subject: [PATCH] Allowing inline data for tar-create. --- lib/chibi/tar.scm | 110 ++++++++++++++++++++++++++++++++-------------- lib/chibi/tar.sld | 2 +- 2 files changed, 79 insertions(+), 33 deletions(-) diff --git a/lib/chibi/tar.scm b/lib/chibi/tar.scm index 0c64146e..49077592 100644 --- a/lib/chibi/tar.scm +++ b/lib/chibi/tar.scm @@ -147,44 +147,89 @@ (tar-path-set! tar file) (tar-ustar-set! tar "ustar") (tar-ustar-version-set! tar "00") - (tar-mode-set! tar (file-mode st)) - (tar-uid-set! tar (file-owner st)) - (tar-gid-set! tar (file-group st)) - (tar-owner-set! tar (user-name (user-information (file-owner st)))) - (tar-group-set! tar (group-name (group-information (file-group st)))) - (tar-time-set! tar (+ 1262271600 (file-modification-time st))) - (tar-type-set! tar (cond ((file-link? st) "2") - ((file-character? st) "3") - ((file-block? st) "4") - ((file-directory? st) "5") - (else "0"))) - (if (equal? "0" (tar-type tar)) - (tar-size-set! tar (file-size st))) - (if (file-link? st) - (tar-link-name-set! tar (read-link file))) + (cond + (st + (tar-mode-set! tar (file-mode st)) + (tar-uid-set! tar (file-owner st)) + (tar-gid-set! tar (file-group st)) + (tar-owner-set! tar (user-name (user-information (file-owner st)))) + (tar-group-set! tar (group-name (group-information (file-group st)))) + (tar-time-set! tar (+ 1262271600 (file-modification-time st))) + (tar-type-set! tar (cond ((file-link? st) "2") + ((file-character? st) "3") + ((file-block? st) "4") + ((file-directory? st) "5") + (else "0"))) + (if (equal? "0" (tar-type tar)) + (tar-size-set! tar (file-size st))) + (if (file-link? st) + (tar-link-name-set! tar (read-link file))))) + tar)) + +(define (inline->tar file content . o) + (let ((tar (make-tar))) + (tar-path-set! tar file) + (tar-ustar-set! tar "ustar") + (tar-ustar-version-set! tar "00") + (tar-mode-set! tar (if (pair? o) (car o) #o644)) + (tar-uid-set! tar (current-user-id)) + (tar-gid-set! tar (current-group-id)) + (tar-owner-set! tar (user-name (user-information (current-user-id)))) + (tar-group-set! tar (group-name (group-information (current-group-id)))) + (tar-time-set! tar (exact (round (current-second)))) + (tar-type-set! tar "0") + (tar-size-set! tar (bytevector-length content)) tar)) ;; create an archive for a given file list (define (tar-create tarball files . o) - (let ((rename (if (pair? o) (car o) (lambda (f) #t)))) - (let ((out (open-binary-output-file tarball))) + (let* ((rename (if (pair? o) (car o) (lambda (f) f))) + (get-src + (lambda (x) (if (pair? x) (and (eq? 'rename (car x)) (cadr x)) x))) + (get-dest + (lambda (x) (rename (if (pair? x) + (if (eq? 'rename (car x)) + (car (cddr x)) + (cadr x)) + x)))) + (get-content + (lambda (x) (and (pair? x) (eq? 'inline (car x)) + (let ((c (car (cddr x)))) + (if (string? c) (string->utf8 c) c)))))) + (let ((out (cond ((eq? #t tarball) (current-output-port)) + ((eq? #f tarball) (open-output-bytevector)) + (else (open-binary-output-file tarball))))) (for-each (lambda (file) - (directory-fold-tree - file - (lambda (dir acc) (write-tar (file->tar dir) out)) - #f - (lambda (path acc) - (let ((f (rename path))) - (if f - (let ((tar (file->tar path))) - (if (string? f) - (tar-path-set! tar f)) - (write-tar tar out) - (if (equal? "0" (tar-type tar)) - (write-modulo-file out path 512)))))))) + (let ((src0 (get-src file)) + (dest0 (get-dest file)) + (content0 (get-content file))) + (define (kons x acc) + (let ((src (get-src x)) + (dest (if (equal? x src0) dest0 (get-dest x))) + (content (if (equal? x src0) content0 (get-content x)))) + (let ((tar (if content + (inline->tar dest content) + (file->tar src)))) + (tar-path-set! tar dest) + (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)))))))) + (if src0 + (directory-fold-tree src0 kons #f kons) + (kons src0 #f)))) files) - (close-output-port out)))) + (write-bytevector (make-bytevector 1024 0) out) + (let ((res (if (eq? #f tarball) (get-output-bytevector out)))) + (close-output-port out) + res)))) (define (main args) (let ((args (cdr args))) @@ -198,6 +243,7 @@ ((equal? "c" (car args)) (tar-create (cadr args) (cddr args))) ((equal? "f" (car args)) - (display (utf8->string (tar-extract-file (cadr args) (car (cddr args)))))) + (write-string + (utf8->string (tar-extract-file (cadr args) (car (cddr args)))))) (else (error "unknown tar command" (car args)))))) diff --git a/lib/chibi/tar.sld b/lib/chibi/tar.sld index f1a2ca95..d5693664 100644 --- a/lib/chibi/tar.sld +++ b/lib/chibi/tar.sld @@ -1,6 +1,6 @@ (define-library (chibi tar) - (import (scheme base) (scheme file) (srfi 1) (srfi 33) (scheme write) + (import (scheme base) (scheme file) (scheme time) (srfi 1) (srfi 33) (chibi string) (chibi binary-record) (chibi pathname) (chibi filesystem) (chibi system)) (export