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

Allowing inline data for tar-create.

Browse source
This commit is contained in:
Alex Shinn 2014-05-10 08:07:09 -04:00
parent 056eb0c6ce
commit 80879d2683
2 changed files with 79 additions and 33 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

110
lib/chibi/tar.scm
View file

@ -147,44 +147,89 @@
(tar-path-set! tar file) (tar-path-set! tar file)
(tar-ustar-set! tar "ustar") (tar-ustar-set! tar "ustar")
(tar-ustar-version-set! tar "00") (tar-ustar-version-set! tar "00")
(tar-mode-set! tar (file-mode st)) (cond
(tar-uid-set! tar (file-owner st)) (st
(tar-gid-set! tar (file-group st)) (tar-mode-set! tar (file-mode st))
(tar-owner-set! tar (user-name (user-information (file-owner st)))) (tar-uid-set! tar (file-owner st))
(tar-group-set! tar (group-name (group-information (file-group st)))) (tar-gid-set! tar (file-group st))
(tar-time-set! tar (+ 1262271600 (file-modification-time st))) (tar-owner-set! tar (user-name (user-information (file-owner st))))
(tar-type-set! tar (cond ((file-link? st) "2") (tar-group-set! tar (group-name (group-information (file-group st))))
((file-character? st) "3") (tar-time-set! tar (+ 1262271600 (file-modification-time st)))
((file-block? st) "4") (tar-type-set! tar (cond ((file-link? st) "2")
((file-directory? st) "5") ((file-character? st) "3")
(else "0"))) ((file-block? st) "4")
(if (equal? "0" (tar-type tar)) ((file-directory? st) "5")
(tar-size-set! tar (file-size st))) (else "0")))
(if (file-link? st) (if (equal? "0" (tar-type tar))
(tar-link-name-set! tar (read-link file))) (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)) tar))
;; 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) #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 (for-each
(lambda (file) (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))))
(write-tar tar out) (tar-path-set! tar dest)
(if (equal? "0" (tar-type tar)) (write-tar tar out)
(write-modulo-file out path 512)))))))) (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) 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) (define (main args)
(let ((args (cdr args))) (let ((args (cdr args)))
@ -198,6 +243,7 @@
((equal? "c" (car args)) ((equal? "c" (car args))
(tar-create (cadr args) (cddr args))) (tar-create (cadr args) (cddr args)))
((equal? "f" (car 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 (else
(error "unknown tar command" (car args)))))) (error "unknown tar command" (car args))))))

2
lib/chibi/tar.sld
View file

@ -1,6 +1,6 @@
(define-library (chibi tar) (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 string) (chibi binary-record)
(chibi pathname) (chibi filesystem) (chibi system)) (chibi pathname) (chibi filesystem) (chibi system))
(export (export