Allowing inline data for tar-create.

lib/chibi/tar.scm

@@ -147,6 +147,8 @@
     (tar-path-set! tar file)
     (tar-ustar-set! tar "ustar")
     (tar-ustar-version-set! tar "00")
+    (cond
+     (st
       (tar-mode-set! tar (file-mode st))
       (tar-uid-set! tar (file-owner st))
       (tar-gid-set! tar (file-group st))
@@ -161,30 +163,73 @@
       (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-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* ((rename (if (pair? o) (car o) (lambda (f) f)))
-    (let ((out (open-binary-output-file tarball)))
+         (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
+         (let ((src0 (get-src file))
-          file
+               (dest0 (get-dest file))
-          (lambda (dir acc) (write-tar (file->tar dir) out))
+               (content0 (get-content file)))
-          #f
+           (define (kons x acc)
-          (lambda (path acc)
+             (let ((src (get-src x))
-            (let ((f (rename path)))
+                   (dest (if (equal? x src0) dest0 (get-dest x)))
-              (if f
+                   (content (if (equal? x src0) content0 (get-content x))))
-                  (let ((tar (file->tar path)))
+               (let ((tar (if content
-                    (if (string? f)
+                              (inline->tar dest content)
-                        (tar-path-set! tar f))
+                              (file->tar src))))
+                 (tar-path-set! tar dest)
                  (write-tar tar out)
-                    (if (equal? "0" (tar-type tar))
+                 (cond
-                        (write-modulo-file out path 512))))))))
+                  ((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))))))

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