mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-09 05:57:36 +02:00
Allowing inline data for tar-create.
This commit is contained in:
Alex Shinn
parent
056eb0c6ce
commit
80879d2683
2 changed files with 79 additions and 33 deletions
|
|
@ -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))))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue