mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
converting (chibi binary-record) to pure syntax-rules
This commit is contained in:
Alex Shinn
parent
d152dd6237
commit
2c93246f34
4 changed files with 240 additions and 314 deletions
|
|
@ -19,25 +19,25 @@
|
|||
(define (assert-read-u8 in i)
|
||||
(let ((i2 (read-u8 in)))
|
||||
(if (not (eqv? i i2))
|
||||
(error "unexpected value: " i i2)
|
||||
(error "unmatched value, expected: " i " but got: " i2)
|
||||
i2)))
|
||||
|
||||
(define (assert-read-char in ch)
|
||||
(let ((ch2 (read-char in)))
|
||||
(if (not (eqv? ch ch2))
|
||||
(error "unexpected value: " ch ch2)
|
||||
(error "unmatched value, expected: " ch " but got: " ch2)
|
||||
ch2)))
|
||||
|
||||
(define (assert-read-string in s)
|
||||
(let ((s2 (read-string (string-length s) in)))
|
||||
(if (not (equal? s s2))
|
||||
(error "unexpected value: " s s2)
|
||||
(error "unmatched value, expected: " s " but got: " s2)
|
||||
s2)))
|
||||
|
||||
(define (assert-read-bytevector in bv)
|
||||
(let ((bv2 (read-bytevector (bytevector-length bv) in)))
|
||||
(if (not (equal? bv bv2))
|
||||
(error "unexpected value: " bv bv2)
|
||||
(error "unmatched value, expected: " bv " but got: " bv2)
|
||||
bv2)))
|
||||
|
||||
(define (assert-read-integer in len radix)
|
||||
|
|
@ -49,36 +49,21 @@
|
|||
(define (read-padded-string in len pad)
|
||||
(string-trim-right (read-string len in) pad))
|
||||
|
||||
(define (expand-read rename in spec)
|
||||
(case (car spec)
|
||||
((literal)
|
||||
(let ((val (cadr spec)))
|
||||
(cond ((integer? val) `(,(rename 'assert-read-u8) ,in ,val))
|
||||
((char? val) `(,(rename 'assert-read-char) ,in ,val))
|
||||
((string? val) `(,(rename 'assert-read-string) ,in ,val))
|
||||
((bytevector? val) `(,(rename 'assert-read-bytevector) ,in ,val))
|
||||
(else (error "unknown binary literal: " val)))))
|
||||
((u8)
|
||||
`(,(rename 'read-u8) ,in))
|
||||
((u16/be)
|
||||
`(,(rename 'read-u16/be) ,in))
|
||||
((u16/le)
|
||||
`(,(rename 'read-u16/le) ,in))
|
||||
((octal)
|
||||
`(,(rename 'assert-read-integer) ,in ,(cadr spec) 8))
|
||||
((decimal)
|
||||
`(,(rename 'assert-read-integer) ,in ,(cadr spec) 10))
|
||||
((hexadecimal)
|
||||
`(,(rename 'assert-read-integer) ,in ,(cadr spec) 16))
|
||||
((fixed-string)
|
||||
(let ((len (cadr spec)))
|
||||
`(,(rename 'read-string) ,len ,in)))
|
||||
((padded-string)
|
||||
(let ((len (cadr spec))
|
||||
(pad (if (pair? (cddr spec)) (car (cddr spec)) #\null)))
|
||||
`(,(rename 'read-padded-string) ,in ,len ,pad)))
|
||||
(else
|
||||
(error "unknown binary format: " spec))))
|
||||
(define (read-literal val)
|
||||
(cond
|
||||
((integer? val) (lambda (in) (assert-read-u8 in val)))
|
||||
((char? val) (lambda (in) (assert-read-char in val)))
|
||||
((string? val) (lambda (in) (assert-read-string in val)))
|
||||
((bytevector? val) (lambda (in) (assert-read-bytevector in val)))
|
||||
(else (error "unknown binary literal: " val))))
|
||||
|
||||
(define (write-literal val)
|
||||
(cond
|
||||
((integer? val) (lambda (x out) (write-u8 val out)))
|
||||
((char? val) (lambda (x out) (write-char val out)))
|
||||
((string? val) (lambda (x out) (write-string val out)))
|
||||
((bytevector? val) (lambda (x out) (write-bytevector val out)))
|
||||
(else (error "unknown binary literal: " val))))
|
||||
|
||||
(define (string-pad-left str len . o)
|
||||
(let ((diff (- len (string-length str)))
|
||||
|
|
@ -111,190 +96,149 @@
|
|||
(write-u8 (bitwise-and n #xFF) out)
|
||||
(write-u8 (arithmetic-shift n -8) out))
|
||||
|
||||
(define (expand-write rename out val spec)
|
||||
(let ((_if (rename 'if))
|
||||
(_not (rename 'not))
|
||||
(_let (rename 'let))
|
||||
(_string-length (rename 'string-length))
|
||||
(_write-string (rename 'write-string))
|
||||
(_write-bytevector (rename 'write-bytevector))
|
||||
(_error (rename 'error))
|
||||
(_> (rename '>))
|
||||
(_= (rename '=)))
|
||||
(case (car spec)
|
||||
((literal)
|
||||
(let ((val (cadr spec)))
|
||||
(cond ((integer? val) `(,(rename 'write-u8) ,val ,out))
|
||||
((char? val) `(,(rename 'write-char) ,val ,out))
|
||||
((string? val) `(,_write-string ,val ,out))
|
||||
((bytevector? val) `(,_write-bytevector ,val ,out))
|
||||
(else (error "unknown binary literal: " val)))))
|
||||
((u8)
|
||||
`(,(rename 'write-u8) ,val ,out))
|
||||
((u16/be)
|
||||
`(,(rename 'write-u16/be) ,val ,out))
|
||||
((u16/le)
|
||||
`(,(rename 'write-u16/le) ,val ,out))
|
||||
((octal)
|
||||
`(,(rename 'write-padded-integer) ,out ,val 8 ,(cadr spec) #\0 #\null))
|
||||
((decimal)
|
||||
`(,(rename 'write-padded-integer) ,out ,val 10 ,(cadr spec) #\0 #\null))
|
||||
((hexadecimal)
|
||||
`(,(rename 'write-padded-integer) ,out ,val 16 ,(cadr spec) #\0 #\null))
|
||||
((fixed-string)
|
||||
(let ((len (cadr spec)))
|
||||
`(,_if (,_not (,_= ,len (,_string-length ,val)))
|
||||
(,_error "wrong field length: " ,val ,len)
|
||||
(,_write-string ,val ,out))))
|
||||
((padded-string)
|
||||
(let ((len (cadr spec))
|
||||
(pad (if (pair? (cddr spec)) (car (cddr spec)) #\null)))
|
||||
`(,_let ((l (,_string-length ,val)))
|
||||
(,_if (,_> l ,len)
|
||||
(,_error "field too large: " ,val ,len)
|
||||
(,_write-string (,(rename 'string-pad-right) ,val ,len ,pad)
|
||||
,out)))))
|
||||
(else
|
||||
(error "unknown binary format: " spec)))))
|
||||
(define-syntax define-binary-type
|
||||
(syntax-rules ()
|
||||
((define-binary-type name gen-pred gen-read gen-write)
|
||||
(define-syntax name
|
||||
(syntax-rules (predicate reader writer)
|
||||
((name predicate args) (gen-pred args))
|
||||
((name reader args) (gen-read args))
|
||||
((name writer args) (gen-write args)))))))
|
||||
|
||||
(define (expand-assert rename spec x v)
|
||||
(let ((_if (rename 'if))
|
||||
(_not (rename 'not))
|
||||
(_error (rename 'error))
|
||||
(_integer? (rename 'integer?))
|
||||
(_string? (rename 'string?))
|
||||
(_string-length (rename 'string-length))
|
||||
(_> (rename '>)))
|
||||
(case (car spec)
|
||||
((literal) #t)
|
||||
((u8 u16/be u16/le octal decimal hexadecimal)
|
||||
`(,_if (,_not (,_integer? ,v))
|
||||
(,_error "expected an integer" ,v)))
|
||||
((fixed-string padded-string)
|
||||
(let ((len (cadr spec)))
|
||||
`(,_if (,_not (,_string? ,v))
|
||||
(,_error "expected a string" ,v)
|
||||
(,_if (,_> (,_string-length ,v) ,len)
|
||||
(,_error "string too long" ,v ,len)))))
|
||||
(else (error "unknown binary format: " spec)))))
|
||||
(define-binary-type u8
|
||||
(lambda (args) (lambda (x) (and (exact-integer? x) (<= 0 x 255))))
|
||||
(lambda (args) read-u8)
|
||||
(lambda (args) write-u8))
|
||||
|
||||
(define (expand-default rename spec)
|
||||
(case (car spec)
|
||||
((literal) (cadr spec))
|
||||
((u8 u16/be u16/le octal decimal hexadecimal) 0)
|
||||
((fixed-string) (make-string (cadr spec) #\space))
|
||||
((padded-string) "")
|
||||
(else (error "unknown binary format: " spec))))
|
||||
(define-binary-type u16/le
|
||||
(lambda (args) (lambda (x) (and (exact-integer? x) (<= 0 x 65536))))
|
||||
(lambda (args) read-u16/le)
|
||||
(lambda (args) write-u16/le))
|
||||
|
||||
(define (param-ref ls key . o)
|
||||
(cond ((assq key ls) => cadr) ((pair? o) (car o)) (else #f)))
|
||||
(define-binary-type u16/be
|
||||
(lambda (args) (lambda (x) (and (exact-integer? x) (<= 0 x 65536))))
|
||||
(lambda (args) read-u16/be)
|
||||
(lambda (args) write-u16/be))
|
||||
|
||||
(define (symbol-append a b)
|
||||
(string->symbol (string-append (symbol->string a) (symbol->string b))))
|
||||
(define-binary-type padded-string
|
||||
(lambda (args)
|
||||
(let ((len (car args)))
|
||||
(lambda (x) (and (string? x) (<= (string-length x) len)))))
|
||||
(lambda (args)
|
||||
(let ((len (car args))
|
||||
(pad (if (pair? (cdr args)) (cadr args) #\null)))
|
||||
(lambda (in) (read-padded-string in len pad))))
|
||||
(lambda (args)
|
||||
(let ((len (car args))
|
||||
(pad (if (pair? (cdr args)) (cadr args) #\null)))
|
||||
(lambda (str out)
|
||||
(write-string (string-pad-right str len pad) out)))))
|
||||
|
||||
(define-record-type Field
|
||||
(make-field name get set raw-set spec)
|
||||
field?
|
||||
(name field-name)
|
||||
(get field-get)
|
||||
(set field-set)
|
||||
(raw-set field-raw-set)
|
||||
(spec field-spec))
|
||||
(define-binary-type fixed-string
|
||||
(lambda (args)
|
||||
(let ((len (car args)))
|
||||
(lambda (x) (and (string? x) (= (string-length x) len)))))
|
||||
(lambda (args)
|
||||
(let ((len (car args)))
|
||||
(lambda (in)
|
||||
(read-string len in))))
|
||||
(lambda (args)
|
||||
(lambda (str out)
|
||||
(write-string str out))))
|
||||
|
||||
(define (extract-fields type ls)
|
||||
(let lp ((ls ls) (res '()))
|
||||
(cond
|
||||
((null? ls)
|
||||
(reverse res))
|
||||
((not (pair? (car ls)))
|
||||
(lp (cdr ls) (cons (make-field '_ #f #f #f `(literal ,(car ls))) res)))
|
||||
(else
|
||||
(let* ((name (caar ls))
|
||||
(get (or (param-ref (car ls) 'getter)
|
||||
(and (not (eq? name '_))
|
||||
(symbol-append type (symbol-append '- name)))))
|
||||
(set (or (param-ref (car ls) 'setter)
|
||||
(and (not (eq? name '_))
|
||||
(symbol-append (symbol-append type '-)
|
||||
(symbol-append name '-set!)))))
|
||||
(raw-set (and set (symbol-append '% set)))
|
||||
(spec0 (cadr (car ls)))
|
||||
(spec (if (pair? spec0) spec0 (list spec0))))
|
||||
(lp (cdr ls) (cons (make-field name get set raw-set spec) res)))))))
|
||||
(define-binary-type octal
|
||||
(lambda (args) exact-integer?)
|
||||
(lambda (args)
|
||||
(let ((len (car args)))
|
||||
(lambda (in) (assert-read-integer in len 8))))
|
||||
(lambda (args)
|
||||
(let ((len (car args)))
|
||||
(lambda (n out)
|
||||
(write-padded-integer out n 8 len #\0 #\null)))))
|
||||
|
||||
(define-binary-type decimal
|
||||
(lambda (args) exact-integer?)
|
||||
(lambda (args)
|
||||
(let ((len (car args)))
|
||||
(lambda (in) (assert-read-integer in len 10))))
|
||||
(lambda (args)
|
||||
(let ((len (car args)))
|
||||
(lambda (n out)
|
||||
(write-padded-integer out n 10 len #\0 #\null)))))
|
||||
|
||||
(define-binary-type hexadecimal
|
||||
(lambda (args) exact-integer?)
|
||||
(lambda (args)
|
||||
(let ((len (car args)))
|
||||
(lambda (in) (assert-read-integer in len 16))))
|
||||
(lambda (args)
|
||||
(let ((len (car args)))
|
||||
(lambda (n out)
|
||||
(write-padded-integer out n 16 len #\0 #\null)))))
|
||||
|
||||
(define-syntax defrec
|
||||
(syntax-rules (make pred read write block)
|
||||
((defrec () n m p r w
|
||||
((field-tmp field-read field-read-expr field-write field-write-expr field-get) ...)
|
||||
((field getter . s) ...)
|
||||
(defs ...))
|
||||
(begin
|
||||
(define-record-type n (m field ...) p
|
||||
(field getter . s) ...)
|
||||
(define r
|
||||
(let ((field-read field-read-expr) ...)
|
||||
(lambda (in)
|
||||
(let* ((field-tmp (field-read in)) ...)
|
||||
(m field ...)))))
|
||||
(define w
|
||||
(let ((field-write field-write-expr) ...)
|
||||
(lambda (x out)
|
||||
(field-write (field-get x) out) ...)))
|
||||
defs ...))
|
||||
((defrec ((make x) . rest) n m p r w b f s)
|
||||
(defrec rest n x p r w b f s))
|
||||
((defrec ((pred x) . rest) n m p r w b f s)
|
||||
(defrec rest n m x r w b f s))
|
||||
((defrec ((read x) . rest) n m p r w b f s)
|
||||
(defrec rest n m p x w b f s))
|
||||
((defrec ((write x) . rest) n m p r w b f s)
|
||||
(defrec rest n m p r x b f s))
|
||||
((defrec ((block (field (type . args) getter setter) . fields) . rest) n m p r w
|
||||
(b ...) (f ...) (s ...))
|
||||
(defrec ((block . fields) . rest) n m p r w
|
||||
(b ...
|
||||
(field read-tmp (type reader 'args) write-tmp (type writer 'args) getter))
|
||||
(f ...
|
||||
(field getter tmp-setter))
|
||||
(s ...
|
||||
(define setter
|
||||
(let ((pred? (type predicate 'args)))
|
||||
(lambda (x val)
|
||||
(if (not (pred? val))
|
||||
(error "invalid val for" 'field val))
|
||||
(tmp-setter x val)))))))
|
||||
((defrec ((block (field (type . args) getter) . fields) . rest) n m p r w
|
||||
(b ...) (f ...) s)
|
||||
(defrec ((block . fields) . rest) n m p r w
|
||||
(b ...
|
||||
(field read-tmp (type reader 'args) write-tmp (type writer 'args) getter))
|
||||
(f ...
|
||||
(field getter))
|
||||
s))
|
||||
((defrec ((block (field . x)) . rest) n m p r w b f s)
|
||||
(syntax-error "invalid field in block" (field . x)))
|
||||
((defrec ((block data . fields) . rest) n m p r w (b ...) f s)
|
||||
(defrec ((block . fields) . rest) n m p r w
|
||||
(b ...
|
||||
(tmp-data read-tmp (read-literal 'data) write-tmp (write-literal 'data) (lambda (x) x)))
|
||||
f
|
||||
s))
|
||||
((defrec ((block) . rest) n m p r w b f s)
|
||||
(defrec rest n m p r w b f s))
|
||||
))
|
||||
|
||||
(define-syntax define-binary-record-type
|
||||
(er-macro-transformer
|
||||
(lambda (expr rename compare)
|
||||
(let ((name (cadr expr))
|
||||
(ls (cddr expr)))
|
||||
(if (not (and (identifier? name) (every list? ls)))
|
||||
(error "invalid syntax: " expr))
|
||||
(let* ((type (or (param-ref ls 'type) (symbol-append 'type- name)))
|
||||
(pred (or (param-ref ls 'predicate) (symbol-append name '?)))
|
||||
(make (or (param-ref ls 'make) (symbol-append 'make- name)))
|
||||
(make-spec (if (pair? make) make (list make)))
|
||||
(%make (rename (symbol-append '% (car make-spec))))
|
||||
(%%make (rename (symbol-append '%% (car make-spec))))
|
||||
(reader (or (param-ref ls 'read) (symbol-append 'read- name)))
|
||||
(writer (or (param-ref ls 'write) (symbol-append 'write- name)))
|
||||
(block (assq 'block ls))
|
||||
(_begin (rename 'begin))
|
||||
(_define (rename 'define))
|
||||
(_define-record-type (rename 'define-record-type))
|
||||
(_let (rename 'let)))
|
||||
(if (not block)
|
||||
(error "missing binary record block: " expr))
|
||||
(let* ((fields (extract-fields name (cdr block)))
|
||||
(named-fields (filter (lambda (f) (not (eq? '_ (field-name f))))
|
||||
fields)))
|
||||
`(,_begin
|
||||
(,_define ,name ',ls)
|
||||
(,_define-record-type
|
||||
,type (,%%make) ,pred
|
||||
,@(map
|
||||
(lambda (f)
|
||||
`(,(field-name f) ,(field-get f) ,(field-raw-set f)))
|
||||
named-fields))
|
||||
,@(map
|
||||
(lambda (f)
|
||||
`(,_define (,(field-set f) x v)
|
||||
,(expand-assert rename (field-spec f) 'x 'v)
|
||||
(,(field-raw-set f) x v)))
|
||||
named-fields)
|
||||
(,_define (,%make)
|
||||
(let ((res (,%%make)))
|
||||
,@(map
|
||||
(lambda (f)
|
||||
`(,(field-raw-set f)
|
||||
res
|
||||
,(expand-default rename (field-spec f))))
|
||||
named-fields)
|
||||
res))
|
||||
(,_define ,make-spec
|
||||
(,_let ((res (,%make)))
|
||||
,@(map
|
||||
(lambda (x)
|
||||
(let ((field (find (lambda (f) (eq? x (field-name f)))
|
||||
fields)))
|
||||
`(,(field-set field) res ,x)))
|
||||
(cdr make-spec))
|
||||
res))
|
||||
(,_define (,reader in)
|
||||
(,_let ((res (,%make)))
|
||||
,@(map
|
||||
(lambda (f)
|
||||
(if (eq? '_ (field-name f))
|
||||
(expand-read rename 'in (field-spec f))
|
||||
`(,(field-set f)
|
||||
res
|
||||
,(expand-read rename 'in (field-spec f)))))
|
||||
fields)
|
||||
res))
|
||||
(,_define (,writer x out)
|
||||
,@(map
|
||||
(lambda (f)
|
||||
(expand-write rename
|
||||
'out
|
||||
`(,(field-get f) x)
|
||||
(field-spec f)))
|
||||
fields)))))))))
|
||||
(syntax-rules ()
|
||||
((define-binary-record-type name x ...)
|
||||
(defrec (x ...) name hidden-make hidden-pred hidden-read hidden-write
|
||||
() () ()))))
|
||||
|
|
|
|||
|
|
@ -6,16 +6,7 @@
|
|||
(cond-expand
|
||||
((library (srfi 33)) (import (srfi 33)))
|
||||
(else (import (srfi 60))))
|
||||
(cond-expand
|
||||
(chibi
|
||||
(import (only (chibi) identifier? er-macro-transformer)))
|
||||
(chicken
|
||||
(import chicken)
|
||||
(begin
|
||||
(define identifier? symbol?)))
|
||||
(sagittarius
|
||||
(import (sagittarius))
|
||||
(begin
|
||||
(define identifier? symbol?))))
|
||||
(export define-binary-record-type)
|
||||
(export define-binary-record-type
|
||||
u8 u16/le u16/be padded-string fixed-string
|
||||
octal decimal hexadecimal)
|
||||
(include "binary-record.scm"))
|
||||
|
|
|
|||
|
|
@ -39,14 +39,7 @@
|
|||
(test "foo" (tar-path x))
|
||||
(test 501 (tar-uid x))
|
||||
(test "bob" (tar-owner x)))
|
||||
(let ((x (make-tar)))
|
||||
(tar-path-set! x "bar")
|
||||
(tar-mode-set! x #o644)
|
||||
(tar-uid-set! x 501)
|
||||
(tar-gid-set! x 502)
|
||||
(tar-size-set! x 123)
|
||||
(tar-time-set! x 456)
|
||||
(tar-ustar-set! x "ustar")
|
||||
(let ((x (make-tar "bar" #o644 501 502 123 456 "0")))
|
||||
(tar-owner-set! x "john")
|
||||
(tar-group-set! x "john")
|
||||
(test "bar" (tar-path x))
|
||||
|
|
|
|||
|
|
@ -1,52 +1,75 @@
|
|||
|
||||
(define-binary-record-type tar
|
||||
(make (make-tar))
|
||||
(write write-tar-raw)
|
||||
(make make-tar/full)
|
||||
(pred tar?)
|
||||
(read read-tar)
|
||||
(write write-tar/raw)
|
||||
(block
|
||||
(path (padded-string 100) (getter tar-path-raw) (setter tar-path-raw-set!))
|
||||
(mode (octal 8))
|
||||
(uid (octal 8))
|
||||
(gid (octal 8))
|
||||
(size (octal 12))
|
||||
(time (octal 12))
|
||||
(checksum (octal 8))
|
||||
(type (fixed-string 1))
|
||||
(link-name (padded-string 100))
|
||||
(ustar (padded-string 6))
|
||||
(ustar-version (padded-string 2))
|
||||
(owner (padded-string 32))
|
||||
(group (padded-string 32))
|
||||
(device-major (octal 8))
|
||||
(device-minor (octal 8))
|
||||
(path-prefix (padded-string 155))
|
||||
(path (padded-string 100) tar-path-raw tar-path-raw-set!)
|
||||
(mode (octal 8) tar-mode tar-mode-set!)
|
||||
(uid (octal 8) tar-uid tar-uid-set!)
|
||||
(gid (octal 8) tar-gid tar-gid-set!)
|
||||
(size (octal 12) tar-size tar-size-set!)
|
||||
(time (octal 12) tar-time tar-time-set!)
|
||||
(checksum (octal 8) tar-checksum tar-checksum-set!)
|
||||
(type (fixed-string 1) tar-type tar-type-set!)
|
||||
(link-name (padded-string 100) tar-link-name tar-link-name-set!)
|
||||
(ustar (padded-string 6) tar-ustar tar-ustar-set!)
|
||||
(ustar-version (padded-string 2) tar-ustar-version)
|
||||
(owner (padded-string 32) tar-owner tar-owner-set!)
|
||||
(group (padded-string 32) tar-group tar-group-set!)
|
||||
(device-major (octal 8) tar-device-major tar-device-major-set!)
|
||||
(device-minor (octal 8) tar-device-minor tar-device-minor-set!)
|
||||
(path-prefix (padded-string 155) tar-path-prefix tar-path-prefix-set!)
|
||||
#u8(0 0 0 0 0 0 0 0 0 0 0 0)))
|
||||
|
||||
(define (file-owner-or-nobody uid)
|
||||
(or (user-name (user-information uid)) "nobody"))
|
||||
(define (file-group-or-nobody gid)
|
||||
(or (group-name (group-information gid)) "nobody"))
|
||||
|
||||
(define (make-tar file mode uid gid size mod-time type . o)
|
||||
(let* ((link (if (pair? o) (car o) ""))
|
||||
(raw-path (tar-normalize-path file (equal? "5" type)))
|
||||
(len (string-length raw-path))
|
||||
(path
|
||||
(if (< len 100) raw-path (substring raw-path (- len 100))))
|
||||
(path-prefix
|
||||
(if (< len 100) "" (substring raw-path 0 (- len 100)))))
|
||||
(if (>= len 255)
|
||||
(error "path name too long" raw-path))
|
||||
(make-tar/full path (bitwise-and #o7777 mode) uid gid size
|
||||
mod-time 0 type link "ustar" "00"
|
||||
(file-owner-or-nobody uid) (file-group-or-nobody gid)
|
||||
0 0 path-prefix)))
|
||||
|
||||
(define (tar-compute-checksum tar)
|
||||
(let ((tmp (open-output-bytevector)))
|
||||
(write-tar-raw tar tmp)
|
||||
(let ((bv (get-output-bytevector tmp)))
|
||||
(do ((i 0 (+ i 1))) ((= i 8))
|
||||
(bytevector-u8-set! bv (+ i 148) 32))
|
||||
(let ((tmp-out (open-output-bytevector)))
|
||||
(write-tar/raw tar tmp-out)
|
||||
(let ((bv (get-output-bytevector tmp-out)))
|
||||
(do ((i 0 (+ i 1))
|
||||
(sum 0 (+ sum (bytevector-u8-ref bv i))))
|
||||
(sum 0 (+ sum (if (<= 148 i 155) ; checksum itself is spaces
|
||||
32
|
||||
(bytevector-u8-ref bv i)))))
|
||||
((= i 512) sum)))))
|
||||
|
||||
;; wrap the writer to automatically compute the checksum
|
||||
(define (write-tar tar out)
|
||||
(tar-checksum-set! tar (tar-compute-checksum tar))
|
||||
(write-tar-raw tar out))
|
||||
(write-tar/raw tar out))
|
||||
|
||||
;; wrap the path to use the prefix
|
||||
(define (tar-path tar)
|
||||
(string-append (tar-path-prefix tar) (tar-path-raw tar)))
|
||||
|
||||
(define (tar-normalize-path tar path)
|
||||
(define (tar-normalize-path path . o)
|
||||
(cond ((string-suffix? "/." path) (string-trim-right path #\.))
|
||||
((and (not (string-suffix? "/" path)) (equal? "5" (tar-type tar)))
|
||||
((and (not (string-suffix? "/" path)) (and (pair? o) (car o)))
|
||||
(string-append path "/"))
|
||||
(else path)))
|
||||
|
||||
(define (tar-path-set! tar path)
|
||||
(let* ((path (tar-normalize-path tar path))
|
||||
(let* ((path (tar-normalize-path path (equal? "5" (tar-type tar))))
|
||||
(len (string-length path)))
|
||||
(cond ((< len 100)
|
||||
(tar-path-raw-set! tar path))
|
||||
|
|
@ -147,50 +170,30 @@
|
|||
(lambda (tar bv) (if (equal? (tar-path tar) file) (return bv))))
|
||||
#f)))
|
||||
|
||||
(define (file-owner-or-nobody st)
|
||||
(or (user-name (user-information (file-owner st))) "nobody"))
|
||||
(define (file-group-or-nobody st)
|
||||
(or (group-name (group-information (file-group st))) "nobody"))
|
||||
|
||||
(define (file->tar file)
|
||||
(let ((tar (make-tar))
|
||||
(st (file-link-status file)))
|
||||
(tar-path-set! tar file)
|
||||
(tar-ustar-set! tar "ustar")
|
||||
(tar-ustar-version-set! tar "00")
|
||||
(cond
|
||||
(st
|
||||
(tar-mode-set! tar (bitwise-and #o7777 (file-mode st)))
|
||||
(tar-uid-set! tar (file-owner st))
|
||||
(tar-gid-set! tar (file-group st))
|
||||
(tar-owner-set! tar (file-owner-or-nobody st))
|
||||
(tar-group-set! tar (file-group-or-nobody st))
|
||||
(tar-time-set! tar (file-modification-time st))
|
||||
(tar-type-set! tar (cond ((file-link? st) "2")
|
||||
(let* ((st (file-link-status file))
|
||||
(type (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))
|
||||
(else "0"))))
|
||||
(make-tar file
|
||||
(file-mode st)
|
||||
(file-owner st)
|
||||
(file-group st)
|
||||
(if (equal? "0" type) (file-size st) 0)
|
||||
(file-modification-time st)
|
||||
type
|
||||
(if (file-link? st) (read-link file) ""))))
|
||||
|
||||
(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))
|
||||
(make-tar file
|
||||
(if (pair? o) (car o) #o644)
|
||||
(current-user-id)
|
||||
(current-group-id)
|
||||
(bytevector-length content)
|
||||
(exact (round (current-second)))
|
||||
"0"))
|
||||
|
||||
(define (tar-add-directories tar out acc)
|
||||
(let lp ((dir (path-directory (tar-path tar))) (acc acc))
|
||||
|
|
@ -200,18 +203,13 @@
|
|||
((assoc dir/ acc) (lp (path-directory dir) acc))
|
||||
(else
|
||||
(let ((acc (lp (path-directory dir) (cons (cons dir/ #f) acc))))
|
||||
(let ((tar2 (make-tar)))
|
||||
(tar-path-set! tar2 dir/)
|
||||
(tar-ustar-set! tar2 "ustar")
|
||||
(tar-ustar-version-set! tar2 "00")
|
||||
(tar-mode-set! tar2 (bitwise-ior #o111 (tar-mode tar) ))
|
||||
(tar-uid-set! tar2 (tar-uid tar))
|
||||
(tar-gid-set! tar2 (tar-gid tar))
|
||||
(tar-owner-set! tar2 (tar-owner tar))
|
||||
(tar-group-set! tar2 (tar-group tar))
|
||||
(tar-time-set! tar2 (tar-time tar))
|
||||
(tar-type-set! tar2 "5")
|
||||
(tar-size-set! tar2 0)
|
||||
(let ((tar2 (make-tar dir/
|
||||
(bitwise-ior #o111 (tar-mode tar))
|
||||
(tar-uid tar)
|
||||
(tar-gid tar)
|
||||
0
|
||||
(tar-time tar)
|
||||
"5")))
|
||||
(write-tar tar2 out)
|
||||
acc)))))))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue