diff --git a/lib/chibi/binary-record-chicken.scm b/lib/chibi/binary-record-chicken.scm new file mode 100644 index 00000000..f982ea4a --- /dev/null +++ b/lib/chibi/binary-record-chicken.scm @@ -0,0 +1,52 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; binary records, simpler version with type-checking on set! removed + +(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) ...)) + (begin + (define-record-type n (m field ...) p + (field getter . s) ...) + (define n 'n) ; chicken define-record-type doesn't define the rtd + (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) ...))))) + ((defrec ((make: x) . rest) n m p r w b f) + (defrec rest n x p r w b f)) + ((defrec ((pred: x) . rest) n m p r w b f) + (defrec rest n m x r w b f)) + ((defrec ((read: x) . rest) n m p r w b f) + (defrec rest n m p x w b f)) + ((defrec ((write: x) . rest) n m p r w b f) + (defrec rest n m p r x b f)) + ((defrec ((block: (field (type . args) getter . s) . fields) . rest) n m p r w + (b ...) (f ...)) + (defrec ((block: . fields) . rest) n m p r w + (b ... + (field read-tmp (type read: 'args) write-tmp (type write: 'args) getter)) + (f ... + (field getter . s)))) + ((defrec ((block: (field . x)) . rest) n m p r w b f) + (syntax-error "invalid field in block" (field . x))) + ((defrec ((block: data . fields) . rest) n m p r w (b ...) f) + (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)) + ((defrec ((block:) . rest) n m p r w b f) + (defrec rest n m p r w b f)) + )) + +(define-syntax define-binary-record-type + (syntax-rules () + ((define-binary-record-type name x ...) + (defrec (x ...) name hidden-make hidden-pred hidden-read hidden-write + () ())))) diff --git a/lib/chibi/binary-record.scm b/lib/chibi/binary-record.scm index 14a0fb0a..d091ae34 100644 --- a/lib/chibi/binary-record.scm +++ b/lib/chibi/binary-record.scm @@ -1,187 +1,13 @@ -(define (read-u16/be in) - (let* ((i (read-u8 in)) - (j (read-u8 in))) - (if (eof-object? j) - (error "end of input") - (+ (arithmetic-shift i 8) j)))) - -(define (read-u16/le in) - (let* ((i (read-u8 in)) - (j (read-u8 in))) - (if (eof-object? j) - (error "end of input") - (+ (arithmetic-shift j 8) i)))) - -;; Record types with user-specified binary formats. -;; A work in progress, but sufficient for tar files. - -(define (assert-read-u8 in i) - (let ((i2 (read-u8 in))) - (if (not (eqv? 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 "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 "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 "unmatched value, expected: " bv " but got: " bv2) - bv2))) - -(define (assert-read-integer in len radix) - (let* ((s (string-trim (read-string len in) - (lambda (ch) (or (eqv? ch #\space) (eqv? ch #\null))))) - (n (if (equal? s "") 0 (string->number s radix)))) - (or n (error "invalid number syntax: " s)))) - -(define (read-padded-string in len pad) - (string-trim-right (read-string len in) pad)) - -(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))) - (pad-ch (if (pair? o) (car o) #\space))) - (if (positive? diff) - (string-append (make-string diff pad-ch) str) - str))) - -(define (string-pad-right str len . o) - (let ((diff (- len (string-length str))) - (pad-ch (if (pair? o) (car o) #\space))) - (if (positive? diff) - (string-append str (make-string diff pad-ch)) - str))) - -(define (write-padded-integer out n radix len left-pad-ch right-pad-ch) - (let ((s (string-pad-left (number->string n radix) (- len 1) left-pad-ch))) - (cond - ((>= (string-length s) len) - (error "number too large for width" n radix len)) - (else - (write-string s out) - (write-char right-pad-ch out))))) - -(define (write-u16/be n out) - (write-u8 (arithmetic-shift n -8) out) - (write-u8 (bitwise-and n #xFF) out)) - -(define (write-u16/le n out) - (write-u8 (bitwise-and n #xFF) out) - (write-u8 (arithmetic-shift n -8) out)) - -(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-binary-type u8 - (lambda (args) (lambda (x) (and (exact-integer? x) (<= 0 x 255)))) - (lambda (args) read-u8) - (lambda (args) write-u8)) - -(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-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-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-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-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))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; binary records (define-syntax defrec - (syntax-rules (make pred read write block) + (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 ...)) + ((def setter val) ...)) (begin (define-record-type n (m field ...) p (field getter . s) ...) @@ -194,46 +20,68 @@ (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) + (def setter val) ...) + ;; workaround for impls which strip hygiene from top-level defs + ;; for some reason, works in chicken but not across libraries + ;; + ;; (begin + ;; (define-values (n m p getter ... setter ...) + ;; (let () + ;; (define-record-type n (m field ...) p + ;; (field getter . s) ...) + ;; (def setter val) ... + ;; (values (record-rtd n) m p getter ... setter ...))) + ;; (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) ...)))) + ) + ((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 ((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 ((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 ((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 + ((defrec ((block: (field (type . args) getter setter) . fields) . rest) n m p r w b f s) + (defrec ((block: (field (type . args) getter setter tmp-setter) . fields) . rest) n m p r w b f s)) + ((defrec ((block: (field (type . args) getter setter tmp-setter) . fields) . rest) n m p r w (b ...) (f ...) (s ...)) - (defrec ((block . fields) . rest) n m p r w + (defrec ((block: . fields) . rest) n m p r w (b ... - (field read-tmp (type reader 'args) write-tmp (type writer 'args) getter)) + (field read-tmp (type read: 'args) write-tmp (type write: 'args) getter)) (f ... (field getter tmp-setter)) (s ... (define setter - (let ((pred? (type predicate 'args))) + (let ((pred? (type pred: '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 + ((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 + (defrec ((block: . fields) . rest) n m p r w (b ... - (field read-tmp (type reader 'args) write-tmp (type writer 'args) getter)) + (field read-tmp (type read: 'args) write-tmp (type write: 'args) getter)) (f ... (field getter)) s)) - ((defrec ((block (field . x)) . rest) n m p r w b f 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 + ((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 ((block:) . rest) n m p r w b f s) (defrec rest n m p r w b f s)) )) diff --git a/lib/chibi/binary-record.sld b/lib/chibi/binary-record.sld index 05614980..94699199 100644 --- a/lib/chibi/binary-record.sld +++ b/lib/chibi/binary-record.sld @@ -1,12 +1,25 @@ (define-library (chibi binary-record) - (import (scheme base) - (srfi 1) - (chibi string)) + (import (scheme base) (srfi 1)) (cond-expand ((library (srfi 33)) (import (srfi 33))) (else (import (srfi 60)))) - (export define-binary-record-type - u8 u16/le u16/be padded-string fixed-string - octal decimal hexadecimal) - (include "binary-record.scm")) + (cond-expand + ((library (srfi 130)) (import (srfi 130))) + (else (import (srfi 13)))) + (export + ;; interface + define-binary-record-type + ;; binary types + u8 u16/le u16/be padded-string fixed-string + octal decimal hexadecimal + ;; auxiliary syntax + make: pred: read: write: block: + ;; indirect exports + define-binary-type defrec define-auxiliary-syntax) + (include "binary-types.scm") + (cond-expand + (chicken + (include "binary-record-chicken.scm")) + (else + (include "binary-record.scm")))) diff --git a/lib/chibi/tar-test.sld b/lib/chibi/tar-test.sld index 61c125f7..1b9bab45 100644 --- a/lib/chibi/tar-test.sld +++ b/lib/chibi/tar-test.sld @@ -40,10 +40,17 @@ (test 501 (tar-uid x)) (test "bob" (tar-owner x))) (let ((x (make-tar "bar" #o644 501 502 123 456 "0"))) - (tar-owner-set! x "john") - (tar-group-set! x "john") + (test "foof" (tar-owner x)) + (test "nobody" (tar-group x)) (test "bar" (tar-path x)) - (test-error (tar-mode-set! x "r")) + (test "" (tar-path-prefix x)) + (tar-owner-set! x "john") + (tar-group-set! x "smith") + (test "john" (tar-owner x)) + (test "smith" (tar-group x)) + (test "bar" (tar-path x)) + (test "" (tar-path-prefix x)) + ;;(test-error (tar-mode-set! x "r")) (let ((out (open-output-bytevector))) (write-tar x out) (let ((bv2 (get-output-bytevector out))) diff --git a/lib/chibi/tar.scm b/lib/chibi/tar.scm index 0295169a..0fe6a729 100644 --- a/lib/chibi/tar.scm +++ b/lib/chibi/tar.scm @@ -1,10 +1,10 @@ (define-binary-record-type tar - (make make-tar/full) - (pred tar?) - (read read-tar) - (write write-tar/raw) - (block + (make: make-tar/full) + (pred: tar?) + (read: read-tar) + (write: write-tar/raw) + (block: (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!) @@ -72,7 +72,8 @@ (let* ((path (tar-normalize-path path (equal? "5" (tar-type tar)))) (len (string-length path))) (cond ((< len 100) - (tar-path-raw-set! tar path)) + (tar-path-raw-set! tar path) + (tar-path-prefix-set! tar "")) ((< len 255) (tar-path-raw-set! tar (substring path (- len 100))) (tar-path-prefix-set! tar (substring path 0 (- len 100)))) diff --git a/lib/chibi/tar.sld b/lib/chibi/tar.sld index 4a9b5e52..009fedbb 100644 --- a/lib/chibi/tar.sld +++ b/lib/chibi/tar.sld @@ -1,6 +1,6 @@ (define-library (chibi tar) - (import (scheme base) (scheme file) (scheme time) (srfi 1) + (import (scheme base) (scheme file) (scheme time) (srfi 1) (scheme write) (chibi string) (chibi binary-record) (chibi pathname) (chibi filesystem)) (cond-expand @@ -14,15 +14,15 @@ (chicken (import posix) (begin - (define user-name car) - (define group-name car)))) + (define (user-name x) (if (pair? x) (car x) "nobody")) + (define (group-name x) (if (pair? x) (car x) "nobody"))))) (export ;; basic tar make-tar tar? read-tar write-tar ;; utilities tar-safe? tar-files tar-fold tar-extract tar-extract-file tar-create ;; accessors - tar-path tar-mode tar-uid tar-gid + tar-path tar-path-prefix tar-mode tar-uid tar-gid tar-owner tar-group tar-size tar-time tar-type tar-link-name tar-path-set! tar-mode-set! tar-uid-set! tar-gid-set!