new xenomorph
parent
677b41e833
commit
50a553c18f
@ -1,19 +0,0 @@
|
||||
#lang racket/base
|
||||
(require racket/require)
|
||||
|
||||
(define-syntax-rule (r+p ID ...)
|
||||
(begin (require ID ...) (provide (all-from-out ID ...))))
|
||||
|
||||
(r+p "redo/array.rkt"
|
||||
"redo/bitfield.rkt"
|
||||
"redo/buffer.rkt"
|
||||
"redo/enum.rkt"
|
||||
"redo/helper.rkt"
|
||||
"redo/lazy-array.rkt"
|
||||
"redo/number.rkt"
|
||||
"redo/optional.rkt"
|
||||
"redo/pointer.rkt"
|
||||
"redo/reserved.rkt"
|
||||
"redo/string.rkt"
|
||||
"redo/struct.rkt"
|
||||
"redo/versioned-struct.rkt")
|
||||
@ -1,235 +0,0 @@
|
||||
#lang debug racket/base
|
||||
(require "helper.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/src/Number.coffee
|
||||
|#
|
||||
|
||||
(define (unsigned->signed uint bits)
|
||||
(define most-significant-bit-mask (arithmetic-shift 1 (sub1 bits)))
|
||||
(- (bitwise-xor uint most-significant-bit-mask) most-significant-bit-mask))
|
||||
|
||||
(define (signed->unsigned sint bits)
|
||||
(bitwise-and sint (arithmetic-shift 1 bits)))
|
||||
|
||||
(define (reverse-bytes bstr)
|
||||
(apply bytes
|
||||
(for/list ([b (in-bytes bstr (sub1 (bytes-length bstr)) -1 -1)])
|
||||
b)))
|
||||
|
||||
(define (exact-if-possible x) (if (integer? x) (inexact->exact x) x))
|
||||
|
||||
(define system-endian (if (system-big-endian?) 'be 'le))
|
||||
|
||||
(define/pre-encode (xint-encode i val [port-arg (current-output-port)] #:parent [parent #f])
|
||||
(unless (xint? i)
|
||||
(raise-argument-error 'encode "xint instance" i))
|
||||
(define-values (bound-min bound-max) (bounds i))
|
||||
(unless (<= bound-min val bound-max)
|
||||
(raise-argument-error 'encode (format "value that fits within ~a ~a-byte int (~a to ~a)" (if (xint-signed i) "signed" "unsigned") (xint-size i) bound-min bound-max) val))
|
||||
(unless (or (not port-arg) (output-port? port-arg))
|
||||
(raise-argument-error 'encode "output port or #f" port-arg))
|
||||
(define port (if (output-port? port-arg) port-arg (open-output-bytes)))
|
||||
(parameterize ([current-output-port port])
|
||||
(define bs (for/fold ([bs null]
|
||||
[val (exact-if-possible val)]
|
||||
#:result bs)
|
||||
([i (in-range (xint-size i))])
|
||||
(values (cons (bitwise-and val #xff) bs) (arithmetic-shift val -8))))
|
||||
(define res (apply bytes ((if (eq? (xint-endian i) 'be) values reverse) bs)))
|
||||
(if port-arg (write-bytes res) res)))
|
||||
|
||||
(define/post-decode (xint-decode i [port-arg (current-input-port)] #:parent [parent #f])
|
||||
(unless (xint? i)
|
||||
(raise-argument-error 'decode "xint instance" i))
|
||||
(define port (->input-port port-arg))
|
||||
(parameterize ([current-input-port port])
|
||||
(define bstr (read-bytes (xint-size i)))
|
||||
(define bs ((if (eq? (xint-endian i) system-endian)
|
||||
values
|
||||
reverse-bytes) bstr))
|
||||
(define uint (for/sum ([b (in-bytes bs)]
|
||||
[i (in-naturals)])
|
||||
(arithmetic-shift b (* 8 i))))
|
||||
(if (xint-signed i) (unsigned->signed uint (bits i)) uint)))
|
||||
|
||||
(struct xnumber xbase () #:transparent)
|
||||
|
||||
(struct xint xnumber (size signed endian) #:transparent
|
||||
#:methods gen:xenomorphic
|
||||
[(define decode xint-decode)
|
||||
(define encode xint-encode)
|
||||
(define size (λ (i [item #f] #:parent [parent #f]) (xint-size i)))])
|
||||
|
||||
(define (+xint [size 2] #:signed [signed #true] #:endian [endian system-endian])
|
||||
(unless (exact-positive-integer? size)
|
||||
(raise-argument-error '+xint "exact positive integer" size))
|
||||
(unless (memq endian '(le be))
|
||||
(raise-argument-error '+xint "'le or 'be" endian))
|
||||
(xint size signed endian))
|
||||
|
||||
(define (type-tag i)
|
||||
(string->symbol
|
||||
(string-append (if (xint-signed i) "" "u")
|
||||
"int"
|
||||
(number->string (bits i))
|
||||
(if (> (xint-size i) 1) (symbol->string (xint-endian i)) ""))))
|
||||
|
||||
(define (bits i) (* (xint-size i) 8))
|
||||
|
||||
(define (bounds i)
|
||||
(unless (xint? i)
|
||||
(raise-argument-error 'bounds "integer instance" i))
|
||||
;; if a signed integer has n bits, it can contain a number
|
||||
;; between - (expt 2 (sub1 n)) and (sub1 (expt 2 (sub1 n)).
|
||||
(let* ([signed-max (sub1 (arithmetic-shift 1 (sub1 (bits i))))]
|
||||
[signed-min (sub1 (- signed-max))]
|
||||
[delta (if (xint-signed i) 0 signed-min)])
|
||||
(values (- signed-min delta) (- signed-max delta))))
|
||||
|
||||
(define int8 (+xint 1))
|
||||
(define int16 (+xint 2))
|
||||
(define int24 (+xint 3))
|
||||
(define int32 (+xint 4))
|
||||
(define uint8 (+xint 1 #:signed #f))
|
||||
(define uint16 (+xint 2 #:signed #f))
|
||||
(define uint24 (+xint 3 #:signed #f))
|
||||
(define uint32 (+xint 4 #:signed #f))
|
||||
(define int8be (+xint 1 #:endian 'be))
|
||||
(define int16be (+xint 2 #:endian 'be))
|
||||
(define int24be (+xint 3 #:endian 'be))
|
||||
(define int32be (+xint 4 #:endian 'be))
|
||||
(define uint8be (+xint 1 #:signed #f #:endian 'be))
|
||||
(define uint16be (+xint 2 #:signed #f #:endian 'be))
|
||||
(define uint24be (+xint 3 #:signed #f #:endian 'be))
|
||||
(define uint32be (+xint 4 #:signed #f #:endian 'be))
|
||||
(define int8le (+xint 1 #:endian 'le))
|
||||
(define int16le (+xint 2 #:endian 'le))
|
||||
(define int24le (+xint 3 #:endian 'le))
|
||||
(define int32le (+xint 4 #:endian 'le))
|
||||
(define uint8le (+xint 1 #:signed #f #:endian 'le))
|
||||
(define uint16le (+xint 2 #:signed #f #:endian 'le))
|
||||
(define uint24le (+xint 3 #:signed #f #:endian 'le))
|
||||
(define uint32le (+xint 4 #:signed #f #:endian 'le))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(check-exn exn:fail:contract? (λ () (+xint 'not-a-valid-type)))
|
||||
(check-exn exn:fail:contract? (λ () (encode uint8 256 #f)))
|
||||
(check-not-exn (λ () (encode uint8 255 #f)))
|
||||
(check-exn exn:fail:contract? (λ () (encode int8 256 #f)))
|
||||
(check-exn exn:fail:contract? (λ () (encode int8 255 #f)))
|
||||
(check-not-exn (λ () (encode int8 127 #f)))
|
||||
(check-not-exn (λ () (encode int8 -128 #f)))
|
||||
(check-exn exn:fail:contract? (λ () (encode int8 -129 #f)))
|
||||
(check-exn exn:fail:contract? (λ () (encode uint16 (add1 #xffff) #f)))
|
||||
(check-not-exn (λ () (encode uint16 #xffff #f)))
|
||||
|
||||
(let ([i (+xint 2 #:signed #f #:endian 'le)]
|
||||
[ip (open-input-bytes (bytes 1 2 3 4))]
|
||||
[op (open-output-bytes)])
|
||||
(check-equal? (decode i ip) 513) ;; 1000 0000 0100 0000
|
||||
(check-equal? (decode i ip) 1027) ;; 1100 0000 0010 0000
|
||||
(encode i 513 op)
|
||||
(check-equal? (get-output-bytes op) (bytes 1 2))
|
||||
(encode i 1027 op)
|
||||
(check-equal? (get-output-bytes op) (bytes 1 2 3 4)))
|
||||
|
||||
(let ([i (+xint 2 #:signed #f #:endian 'be)]
|
||||
[ip (open-input-bytes (bytes 1 2 3 4))]
|
||||
[op (open-output-bytes)])
|
||||
(check-equal? (decode i ip) 258) ;; 0100 0000 1000 0000
|
||||
(check-equal? (decode i ip) 772) ;; 0010 0000 1100 0000
|
||||
(encode i 258 op)
|
||||
(check-equal? (get-output-bytes op) (bytes 1 2))
|
||||
(encode i 772 op)
|
||||
(check-equal? (get-output-bytes op) (bytes 1 2 3 4)))
|
||||
|
||||
(check-equal? (size (+xint 1)) 1)
|
||||
(check-equal? (size (+xint)) 2)
|
||||
(check-equal? (size (+xint 4)) 4)
|
||||
(check-equal? (size (+xint 8)) 8)
|
||||
|
||||
(check-equal? (decode int8 (bytes 127)) 127)
|
||||
(check-equal? (decode int8 (bytes 255)) -1)
|
||||
(check-equal? (encode int8 -1 #f) (bytes 255))
|
||||
(check-equal? (encode int8 127 #f) (bytes 127)))
|
||||
|
||||
(define/post-decode (xfloat-decode xf [port-arg (current-input-port)] #:parent [parent #f])
|
||||
(unless (xfloat? xf)
|
||||
(raise-argument-error 'decode "xfloat instance" xf))
|
||||
(define bs (read-bytes (xfloat-size xf) (->input-port port-arg)))
|
||||
(floating-point-bytes->real bs (eq? (xfloat-endian xf) 'be)))
|
||||
|
||||
(define/pre-encode (xfloat-encode xf val [port (current-output-port)] #:parent [parent #f])
|
||||
(unless (xfloat? xf)
|
||||
(raise-argument-error 'encode "xfloat instance" xf))
|
||||
(unless (or (not port) (output-port? port))
|
||||
(raise-argument-error 'encode "output port or #f" port))
|
||||
(define res (real->floating-point-bytes val (xfloat-size xf) (eq? (xfloat-endian xf) 'be)))
|
||||
(if port (write-bytes res port) res))
|
||||
|
||||
(struct xfloat xnumber (size endian) #:transparent
|
||||
#:methods gen:xenomorphic
|
||||
[(define decode xfloat-decode)
|
||||
(define encode xfloat-encode)
|
||||
(define size (λ (i [item #f] #:parent [parent #f]) (xfloat-size i)))])
|
||||
|
||||
(define (+xfloat [size 4] #:endian [endian system-endian])
|
||||
(unless (exact-positive-integer? size)
|
||||
(raise-argument-error '+xfloat "exact positive integer" size))
|
||||
(unless (memq endian '(le be))
|
||||
(raise-argument-error '+xfloat "'le or 'be" endian))
|
||||
(xfloat size endian))
|
||||
|
||||
(define float (+xfloat 4))
|
||||
(define floatbe (+xfloat 4 #:endian 'be))
|
||||
(define floatle (+xfloat 4 #:endian 'le))
|
||||
|
||||
(define double (+xfloat 8))
|
||||
(define doublebe (+xfloat 8 #:endian 'be))
|
||||
(define doublele (+xfloat 8 #:endian 'le))
|
||||
|
||||
(define/post-decode (xfixed-decode xf [port-arg (current-input-port)] #:parent [parent #f])
|
||||
(unless (xfixed? xf)
|
||||
(raise-argument-error 'decode "xfixed instance" xf))
|
||||
(define int (xint-decode xf port-arg))
|
||||
(exact-if-possible (/ int (fixed-shift xf) 1.0)))
|
||||
|
||||
(define/pre-encode (xfixed-encode xf val [port (current-output-port)] #:parent [parent #f])
|
||||
(unless (xfixed? xf)
|
||||
(raise-argument-error 'encode "xfixed instance" xf))
|
||||
(define int (exact-if-possible (floor (* val (fixed-shift xf)))))
|
||||
(xint-encode xf int port))
|
||||
|
||||
(struct xfixed xint (fracbits) #:transparent
|
||||
#:methods gen:xenomorphic
|
||||
[(define decode xfixed-decode)
|
||||
(define encode xfixed-encode)
|
||||
(define size (λ (i [item #f] #:parent [parent #f]) (xint-size i)))])
|
||||
|
||||
(define (+xfixed [size 2] #:signed [signed #true] #:endian [endian system-endian] [fracbits (/ (* size 8) 2)])
|
||||
(unless (exact-positive-integer? size)
|
||||
(raise-argument-error '+xfixed "exact positive integer" size))
|
||||
(unless (exact-positive-integer? fracbits)
|
||||
(raise-argument-error '+xfixed "exact positive integer" fracbits))
|
||||
(unless (memq endian '(le be))
|
||||
(raise-argument-error '+xfixed "'le or 'be" endian))
|
||||
(xfixed size signed endian fracbits))
|
||||
|
||||
(define (fixed-shift xf)
|
||||
(arithmetic-shift 1 (xfixed-fracbits xf)))
|
||||
|
||||
(define fixed16 (+xfixed 2))
|
||||
(define fixed16be (+xfixed 2 #:endian 'be))
|
||||
(define fixed16le (+xfixed 2 #:endian 'le))
|
||||
(define fixed32 (+xfixed 4))
|
||||
(define fixed32be (+xfixed 4 #:endian 'be))
|
||||
(define fixed32le (+xfixed 4 #:endian 'le))
|
||||
|
||||
(module+ test
|
||||
(define bs (encode fixed16be 123.45 #f))
|
||||
(check-equal? bs #"{s")
|
||||
(check-equal? (ceiling (* (decode fixed16be bs) 100)) 12345.0))
|
||||
@ -1,134 +0,0 @@
|
||||
#lang debug racket/base
|
||||
(require racket/dict "helper.rkt" "util.rkt" "number.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/src/String.coffee
|
||||
|#
|
||||
|
||||
(define (read-encoded-string len [encoding 'ascii])
|
||||
(define proc (case encoding
|
||||
[(utf16le) (error 'bah)]
|
||||
[(ucs2) (error 'bleh)]
|
||||
[(utf8) bytes->string/utf-8]
|
||||
[(ascii) bytes->string/latin-1]
|
||||
[else values]))
|
||||
(proc (read-bytes len)))
|
||||
|
||||
(define (write-encoded-string string [encoding 'ascii])
|
||||
;; todo: handle encodings correctly.
|
||||
;; right now just utf8 and ascii are correct
|
||||
(define proc (case encoding
|
||||
[(ucs2 utf8 ascii) string->bytes/utf-8]
|
||||
[(utf16le) (error 'swap-bytes-unimplemented)]
|
||||
[else (error 'unsupported-string-encoding)]))
|
||||
(write-bytes (proc string)))
|
||||
|
||||
(define (count-nonzero-chars port)
|
||||
;; helper function for String
|
||||
;; counts nonzero chars from current position
|
||||
(bytes-length (car (regexp-match-peek "[^\u0]*" port))))
|
||||
|
||||
(define (bytes-left-in-port? port)
|
||||
(not (eof-object? (peek-byte port))))
|
||||
|
||||
(define (byte-length val encoding)
|
||||
(define encoder
|
||||
(case encoding
|
||||
[(ascii utf8) string->bytes/utf-8]))
|
||||
(bytes-length (encoder (format "~a" val))))
|
||||
|
||||
(define/post-decode (xstring-decode xs [port-arg (current-input-port)] #:parent [parent #f])
|
||||
(define port (->input-port port-arg))
|
||||
(parameterize ([current-input-port port])
|
||||
(let ([len (or (resolve-length (xstring-len xs) #:parent parent) (count-nonzero-chars port))]
|
||||
[encoding (if (procedure? (xstring-encoding xs))
|
||||
(or ((xstring-encoding xs) parent) 'ascii)
|
||||
(xstring-encoding xs))]
|
||||
[adjustment (if (and (not (xstring-len xs)) (bytes-left-in-port? port)) 1 0)])
|
||||
(define string (read-encoded-string len encoding))
|
||||
(pos port (+ (pos port) adjustment))
|
||||
string)))
|
||||
|
||||
(define/pre-encode (xstring-encode xs val [port-arg (current-output-port)] #:parent [parent #f])
|
||||
(define port (if (output-port? port-arg) port-arg (open-output-bytes)))
|
||||
(parameterize ([current-output-port port])
|
||||
(let* ([val (format "~a" val)]
|
||||
[encoding (if (procedure? (xstring-encoding xs))
|
||||
(or ((xstring-encoding xs) (and parent (dict-ref parent val)) 'ascii))
|
||||
(xstring-encoding xs))])
|
||||
(define encoded-length (byte-length val encoding))
|
||||
(when (and (exact-nonnegative-integer? (xstring-len xs)) (> encoded-length (xstring-len xs)))
|
||||
(raise-argument-error 'xstring-encode (format "string no longer than ~a" (xstring-len xs)) val))
|
||||
(when (xint? (xstring-len xs))
|
||||
(encode (xstring-len xs) encoded-length))
|
||||
(write-encoded-string val encoding)
|
||||
(when (not (xstring-len xs)) (write-byte #x00)) ; null terminated when no len
|
||||
(unless port-arg (get-output-bytes port)))))
|
||||
|
||||
(define/finalize-size (xstring-size xs [val #f] #:parent [parent #f])
|
||||
(cond
|
||||
[val (define encoding (if (procedure? (xstring-encoding xs))
|
||||
(or ((xstring-encoding xs) (and parent (dict-ref parent val)) 'ascii))
|
||||
(xstring-encoding xs)))
|
||||
(define string-size (byte-length val (if (eq? encoding 'utf16be) 'utf16le encoding)))
|
||||
(define strlen-size (cond
|
||||
[(not (xstring-len xs)) 1]
|
||||
[(xint? (xstring-len xs)) (size (xstring-len xs))]
|
||||
[else 0]))
|
||||
(+ string-size strlen-size)]
|
||||
[else (resolve-length (xstring-len xs) #f #:parent parent)]))
|
||||
|
||||
(struct xstring xbase (len encoding) #:transparent
|
||||
#:methods gen:xenomorphic
|
||||
[(define decode xstring-decode)
|
||||
(define encode xstring-encode)
|
||||
(define size xstring-size)])
|
||||
|
||||
(define supported-encodings '(ascii utf8))
|
||||
(define (+xstring [len-arg #f] [enc-arg #f]
|
||||
#:length [len-kwarg #f] #:encoding [enc-kwarg #f])
|
||||
(define len (or len-arg len-kwarg))
|
||||
(define encoding (or enc-arg enc-kwarg 'ascii))
|
||||
(unless (length-resolvable? len)
|
||||
(raise-argument-error '+xarray "length-resolvable?" len))
|
||||
(unless (or (procedure? encoding) (memq encoding supported-encodings))
|
||||
(raise-argument-error '+xarray (format "procedure or member of ~v" supported-encodings) encoding))
|
||||
(xstring len encoding))
|
||||
|
||||
(define (xsymbol-decode xs [port-arg (current-input-port)] #:parent [parent #f])
|
||||
(string->symbol (xstring-decode xs port-arg #:parent parent)))
|
||||
|
||||
(define (xsymbol-encode xs val [port (current-output-port)] #:parent [parent #f])
|
||||
(unless (xsymbol? xs)
|
||||
(raise-argument-error 'encode "xsymbol instance" xs))
|
||||
(unless (or (string? val) (symbol? val))
|
||||
(raise-argument-error 'xsymbol-encode "symbol or string" val))
|
||||
(xstring-encode xs (if (symbol? val) val (string->symbol val)) port #:parent parent))
|
||||
|
||||
(struct xsymbol xstring () #:transparent
|
||||
#:methods gen:xenomorphic
|
||||
[(define decode xsymbol-decode)
|
||||
(define encode xsymbol-encode)
|
||||
(define size xstring-size)])
|
||||
|
||||
(define (+xsymbol [len-arg #f] [enc-arg #f]
|
||||
#:length [len-kwarg #f] #:encoding [enc-kwarg #f])
|
||||
(define len (or len-arg len-kwarg))
|
||||
(define encoding (or enc-arg enc-kwarg 'ascii))
|
||||
(xsymbol len encoding))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(define S-fixed (+xstring 4 'utf8))
|
||||
(check-equal? (encode S-fixed "Mike" #f) #"Mike")
|
||||
(check-exn exn:fail? (λ () (encode S-fixed "Mikes" #f))) ; too long for fixed string
|
||||
(define S (+xstring uint8 'utf8))
|
||||
(check-equal? (decode S #"\2BCDEF") "BC")
|
||||
(check-equal? (encode S "Mike" #f) #"\4Mike")
|
||||
(check-equal? (size (+xstring) "foobar") 7) ; null terminated when no len
|
||||
(check-equal? (decode (+xsymbol 4) #"Mike") 'Mike)
|
||||
(check-equal? (encode (+xsymbol 4) 'Mike #f) #"Mike")
|
||||
(check-equal? (encode (+xsymbol 4) "Mike" #f) #"Mike")
|
||||
(check-exn exn:fail:contract? (λ () (encode (+xsymbol 4) 42 #f))))
|
||||
@ -1,156 +0,0 @@
|
||||
#lang debug racket/base
|
||||
(require (prefix-in d: racket/dict)
|
||||
racket/promise
|
||||
racket/sequence
|
||||
racket/list
|
||||
"helper.rkt"
|
||||
"number.rkt"
|
||||
sugar/unstable/dict)
|
||||
(provide (all-defined-out))
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/src/Struct.coffee
|
||||
|#
|
||||
|
||||
(define private-keys '(parent _startOffset _currentOffset _length))
|
||||
|
||||
(define (choose-dict d k)
|
||||
(if (memq k private-keys)
|
||||
(struct-dict-res-_pvt d)
|
||||
(struct-dict-res-_kv d)))
|
||||
|
||||
(struct struct-dict-res (_kv _pvt) #:transparent
|
||||
#:methods d:gen:dict
|
||||
[(define (dict-set! d k v) (d:dict-set! (choose-dict d k) k v))
|
||||
(define (dict-ref d k [thunk #f])
|
||||
(define res (d:dict-ref (choose-dict d k) k thunk))
|
||||
(force res))
|
||||
(define (dict-remove! d k) (d:dict-remove! (choose-dict d k) k))
|
||||
;; public keys only
|
||||
(define (dict-keys d) (d:dict-keys (struct-dict-res-_kv d)))
|
||||
(define (dict-iterate-first d) (and (pair? (dict-keys d)) 0))
|
||||
(define (dict-iterate-next d i) (and (< (add1 i) (length (dict-keys d))) (add1 i)))
|
||||
(define (dict-iterate-key d i) (list-ref (dict-keys d) i))
|
||||
(define (dict-iterate-value d i) (dict-ref d (dict-iterate-key d i)))])
|
||||
|
||||
(define (+struct-dict-res [_kv (mhasheq)] [_pvt (mhasheq)])
|
||||
(struct-dict-res _kv _pvt))
|
||||
|
||||
(define (_setup port parent len)
|
||||
(define sdr (+struct-dict-res)) ; not mere hash
|
||||
(d:dict-set*! sdr 'parent parent
|
||||
'_startOffset (pos port)
|
||||
'_currentOffset 0
|
||||
'_length len)
|
||||
sdr)
|
||||
|
||||
(define (_parse-fields port sdr fields)
|
||||
(unless (assocs? fields)
|
||||
(raise-argument-error '_parse-fields "assocs" fields))
|
||||
(for/fold ([sdr sdr])
|
||||
([(key type) (d:in-dict fields)])
|
||||
(define val (if (procedure? type)
|
||||
(type sdr)
|
||||
(decode type port #:parent sdr)))
|
||||
(unless (void? val)
|
||||
(d:dict-set! sdr key val))
|
||||
(d:dict-set! sdr '_currentOffset (- (pos port) (d:dict-ref sdr '_startOffset)))
|
||||
sdr))
|
||||
|
||||
(define (sdr-to-hash sdr)
|
||||
(for/hasheq ([(k v) (d:in-dict sdr)]
|
||||
#:unless (memq k private-keys))
|
||||
(values k v)))
|
||||
|
||||
(define-syntax-rule (decode/hash . ARGS)
|
||||
(sdr-to-hash (decode . ARGS)))
|
||||
|
||||
(define (xstruct-decode xs [port-arg (current-input-port)] #:parent [parent #f] [len 0])
|
||||
(define port (->input-port port-arg))
|
||||
(parameterize ([current-input-port port])
|
||||
;; _setup and _parse-fields are separate to cooperate with VersionedStruct
|
||||
(define res
|
||||
(post-decode xs
|
||||
(let* ([sdr (_setup port parent len)] ; returns StructDictRes
|
||||
[sdr (_parse-fields port sdr (xstruct-fields xs))])
|
||||
sdr)))
|
||||
(unless (d:dict? res)
|
||||
(raise-result-error 'xstruct-decode "dict" res))
|
||||
res))
|
||||
|
||||
(define/finalize-size (xstruct-size xs [val #f] #:parent [parent-arg #f] [include-pointers #t])
|
||||
(define parent (mhasheq 'parent parent-arg
|
||||
'val val
|
||||
'pointerSize 0))
|
||||
(define fields-size (for/sum ([(key type) (d:in-dict (xstruct-fields xs))]
|
||||
#:when (xenomorphic? type))
|
||||
(size type (and val (d:dict-ref val key)) #:parent parent)))
|
||||
(define pointers-size (if include-pointers (d:dict-ref parent 'pointerSize) 0))
|
||||
(+ fields-size pointers-size))
|
||||
|
||||
(define (xstruct-encode xs val-arg [port-arg (current-output-port)] #:parent [parent-arg #f])
|
||||
(unless (d:dict? val-arg)
|
||||
(raise-argument-error 'xstruct-encode "dict" val-arg))
|
||||
(define port (if (output-port? port-arg) port-arg (open-output-bytes)))
|
||||
(parameterize ([current-output-port port])
|
||||
;; check keys first, since `size` also relies on keys being valid
|
||||
(define val (let* ([val (pre-encode xs val-arg)]
|
||||
#;[val (inner res pre-encode val . args)])
|
||||
(unless (d:dict? val) (raise-result-error 'xstruct-encode "dict" val))
|
||||
val))
|
||||
(unless (andmap (λ (key) (memq key (d:dict-keys val))) (d:dict-keys (xstruct-fields xs)))
|
||||
(raise-argument-error 'xstruct-encode
|
||||
(format "dict that contains superset of Struct keys: ~a" (d:dict-keys (xstruct-fields xs))) (d:dict-keys val)))
|
||||
|
||||
(define parent (mhash 'pointers empty
|
||||
'startOffset (pos port)
|
||||
'parent parent-arg
|
||||
'val val
|
||||
'pointerSize 0))
|
||||
|
||||
; deliberately use `xstruct-size` instead of `size` to use extra arg
|
||||
(d:dict-set! parent 'pointerOffset (+ (pos port) (xstruct-size xs val #:parent parent #f)))
|
||||
|
||||
(for ([(key type) (d:in-dict (xstruct-fields xs))])
|
||||
(encode type (d:dict-ref val key) #:parent parent))
|
||||
(for ([ptr (in-list (d:dict-ref parent 'pointers))])
|
||||
(encode (d:dict-ref ptr 'type) (d:dict-ref ptr 'val) #:parent (d:dict-ref ptr 'parent)))
|
||||
(unless port-arg (get-output-bytes port))))
|
||||
|
||||
(struct structish xbase () #:transparent)
|
||||
(struct xstruct structish (fields) #:transparent #:mutable
|
||||
#:methods gen:xenomorphic
|
||||
[(define decode xstruct-decode)
|
||||
(define encode xstruct-encode)
|
||||
(define size xstruct-size)])
|
||||
|
||||
(define (+xstruct . dicts)
|
||||
(define args (flatten dicts))
|
||||
(unless (even? (length args))
|
||||
(raise-argument-error '+xstruct "equal keys and values" dicts))
|
||||
(define fields (for/list ([kv (in-slice 2 args)])
|
||||
(unless (symbol? (car kv))
|
||||
(raise-argument-error '+xstruct "symbol" (car kv)))
|
||||
(apply cons kv)))
|
||||
(unless (d:dict? fields)
|
||||
(raise-argument-error '+xstruct "dict" fields))
|
||||
(xstruct fields))
|
||||
|
||||
(module+ test
|
||||
(require rackunit "number.rkt")
|
||||
(define (random-pick xs) (list-ref xs (random (length xs))))
|
||||
(check-exn exn:fail:contract? (λ () (+xstruct 42)))
|
||||
(for ([i (in-range 20)])
|
||||
;; make random structs and make sure we can round trip
|
||||
(define field-types
|
||||
(for/list ([i (in-range 40)])
|
||||
(random-pick (list uint8 uint16be uint16le uint32be uint32le double))))
|
||||
(define size-num-types
|
||||
(for/sum ([num-type (in-list field-types)])
|
||||
(size num-type)))
|
||||
(define xs (+xstruct (for/list ([num-type (in-list field-types)])
|
||||
(cons (gensym) num-type))))
|
||||
(define bs (apply bytes (for/list ([i (in-range size-num-types)])
|
||||
(random 256))))
|
||||
(check-equal? (encode xs (decode xs bs) #f) bs)))
|
||||
@ -1,106 +0,0 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
"../helper.rkt"
|
||||
"../array.rkt"
|
||||
"../number.rkt"
|
||||
"../pointer.rkt"
|
||||
sugar/unstable/dict)
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Array.coffee
|
||||
|#
|
||||
|
||||
(test-case
|
||||
"decode fixed length"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
|
||||
(check-equal? (decode (+xarray uint8 4)) '(1 2 3 4))))
|
||||
|
||||
(test-case
|
||||
"decode with post-decode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
|
||||
(define xa (+xarray uint8 4))
|
||||
(set-post-decode! xa (λ (val . _) (map (λ (x) (* 2 x)) val)))
|
||||
(check-equal? (decode xa) '(2 4 6 8))))
|
||||
|
||||
(test-case
|
||||
"decode fixed number of bytes"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
|
||||
(check-equal? (decode (+xarray uint16be 4 'bytes)) '(258 772))))
|
||||
|
||||
(test-case
|
||||
"decode length from parent key"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
|
||||
(check-equal? (decode (+xarray uint8 'len) #:parent (mhash 'len 4)) '(1 2 3 4))))
|
||||
|
||||
(test-case
|
||||
"decode byte count from parent key"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
|
||||
(check-equal? (decode (+xarray uint16be 'len 'bytes) #:parent (mhash 'len 4)) '(258 772))))
|
||||
|
||||
(test-case
|
||||
"decode length as number before array"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 4 1 2 3 4 5))])
|
||||
(check-equal? (decode (+xarray uint8 uint8)) '(1 2 3 4))))
|
||||
|
||||
(test-case
|
||||
"decode byte count as number before array"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 4 1 2 3 4 5))])
|
||||
(check-equal? (decode (+xarray uint16be uint8 'bytes)) '(258 772))))
|
||||
|
||||
(test-case
|
||||
"decode length from function"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
|
||||
(check-equal? (decode (+xarray uint8 (λ _ 4))) '(1 2 3 4))))
|
||||
|
||||
(test-case
|
||||
"decode byte count from function"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
|
||||
(check-equal? (decode (+xarray uint16be (λ _ 4) 'bytes)) '(258 772))))
|
||||
|
||||
(test-case
|
||||
"decode to the end of parent if no length given"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
|
||||
(check-equal? (decode (+xarray uint8) #:parent (mhash '_length 4 '_startOffset 0)) '(1 2 3 4))))
|
||||
|
||||
(test-case
|
||||
"decode to the end of the stream if parent exists, but its length is 0"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
|
||||
(check-equal? (decode (+xarray uint8) #:parent (mhash '_length 0 '_startOffset 0)) '(1 2 3 4 5))))
|
||||
|
||||
(test-case
|
||||
"decode to the end of the stream if no parent and length is given"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4))])
|
||||
(check-equal? (decode (+xarray uint8)) '(1 2 3 4 ))))
|
||||
|
||||
(test-case
|
||||
"use array length"
|
||||
(check-equal? (size (+xarray uint8 10) '(1 2 3 4)) 4))
|
||||
|
||||
(test-case
|
||||
"add size of length field before string"
|
||||
(check-equal? (size (+xarray uint8 uint8) '(1 2 3 4)) 5))
|
||||
|
||||
(test-case
|
||||
"use defined length if no value given"
|
||||
(check-equal? (size (+xarray uint8 10)) 10))
|
||||
|
||||
(test-case
|
||||
"encode using array length"
|
||||
(check-equal? (encode (+xarray uint8 10) '(1 2 3 4) #f) (bytes 1 2 3 4)))
|
||||
|
||||
(test-case
|
||||
"encode with pre-encode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
|
||||
(define xa (+xarray uint8 4))
|
||||
(set-pre-encode! xa (λ (val . _) (map (λ (x) (* 2 x)) val)))
|
||||
(check-equal? (encode xa '(1 2 3 4) #f) (bytes 2 4 6 8))))
|
||||
|
||||
(test-case
|
||||
"encode length as number before array"
|
||||
(check-equal? (encode (+xarray uint8 uint8) '(1 2 3 4) #f) (bytes 4 1 2 3 4)))
|
||||
|
||||
(test-case
|
||||
"add pointers after array if length is encoded at start"
|
||||
(check-equal? (encode (+xarray (+xpointer #:offset-type uint8
|
||||
#:type uint8) uint8) '(1 2 3 4) #f) (bytes 4 5 6 7 8 1 2 3 4)))
|
||||
@ -1,76 +0,0 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
racket/match
|
||||
racket/list
|
||||
sugar/unstable/dict
|
||||
"../helper.rkt"
|
||||
"../number.rkt"
|
||||
"../bitfield.rkt")
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Bitfield.coffee
|
||||
|#
|
||||
|
||||
(define bitfield (+xbitfield uint8 '(Jack Kack Lack Mack Nack Oack Pack Quack)))
|
||||
(match-define (list JACK KACK LACK MACK NACK OACK PACK QUACK)
|
||||
(map (λ (x) (arithmetic-shift 1 x)) (range 8)))
|
||||
|
||||
(test-case
|
||||
"bitfield should have the right size"
|
||||
(check-equal? (size bitfield) 1))
|
||||
|
||||
(test-case
|
||||
"bitfield should decode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes (bitwise-ior JACK MACK PACK NACK QUACK)))])
|
||||
(check-equal? (decode bitfield) (mhasheq 'Quack #t
|
||||
'Nack #t
|
||||
'Lack #f
|
||||
'Oack #f
|
||||
'Pack #t
|
||||
'Mack #t
|
||||
'Jack #t
|
||||
'Kack #f))))
|
||||
|
||||
(test-case
|
||||
"bitfield should decode with post-decode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes (bitwise-ior JACK MACK PACK NACK QUACK)))])
|
||||
(set-post-decode! bitfield (λ (fh . _) (hash-set! fh 'foo 42) fh))
|
||||
(check-equal? (decode bitfield) (mhasheq 'Quack #t
|
||||
'Nack #t
|
||||
'Lack #f
|
||||
'Oack #f
|
||||
'Pack #t
|
||||
'Mack #t
|
||||
'Jack #t
|
||||
'Kack #f
|
||||
'foo 42))))
|
||||
|
||||
(test-case
|
||||
"bitfield should encode"
|
||||
(check-equal? (encode bitfield (mhasheq 'Quack #t
|
||||
'Nack #t
|
||||
'Lack #f
|
||||
'Oack #f
|
||||
'Pack #t
|
||||
'Mack #t
|
||||
'Jack #t
|
||||
'Kack #f) #f)
|
||||
(bytes (bitwise-ior JACK MACK PACK NACK QUACK))))
|
||||
|
||||
(test-case
|
||||
"bitfield should encode with pre-encode"
|
||||
(set-pre-encode! bitfield (λ (fh . _)
|
||||
(hash-set! fh 'Jack #f)
|
||||
(hash-set! fh 'Mack #f)
|
||||
(hash-set! fh 'Pack #f)
|
||||
fh))
|
||||
(check-equal? (encode bitfield (mhasheq 'Quack #t
|
||||
'Nack #t
|
||||
'Lack #f
|
||||
'Oack #f
|
||||
'Pack #t
|
||||
'Mack #t
|
||||
'Jack #t
|
||||
'Kack #f) #f)
|
||||
(bytes (bitwise-ior NACK QUACK))))
|
||||
@ -1,64 +0,0 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
sugar/unstable/dict
|
||||
"../buffer.rkt"
|
||||
"../number.rkt"
|
||||
"../helper.rkt")
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Buffer.coffee
|
||||
|#
|
||||
|
||||
(test-case
|
||||
"buffer should decode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes #xab #xff #x1f #xb6))])
|
||||
(define buf (+xbuffer #:length 2))
|
||||
(check-equal? (decode buf) (bytes #xab #xff))
|
||||
(check-equal? (decode buf) (bytes #x1f #xb6))))
|
||||
|
||||
(test-case
|
||||
"buffer should error on invalid length"
|
||||
(check-exn exn:fail:contract? (λ () (+xbuffer #:length #true))))
|
||||
|
||||
(test-case
|
||||
"buffer should decode with post-decode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes #xab #xff #x1f #xb6))])
|
||||
(define buf (+xbuffer #:length 2))
|
||||
(set-post-decode! buf (λ (bs) (bytes 1 2)))
|
||||
(check-equal? (decode buf) (bytes 1 2))
|
||||
(check-equal? (decode buf) (bytes 1 2))))
|
||||
|
||||
(test-case
|
||||
"buffer should decode with parent key length"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes #xab #xff #x1f #xb6))])
|
||||
(define buf (+xbuffer #:length 'len))
|
||||
(check-equal? (decode buf #:parent (hash 'len 3)) (bytes #xab #xff #x1f))
|
||||
(check-equal? (decode buf #:parent (hash 'len 1)) (bytes #xb6))))
|
||||
|
||||
(test-case
|
||||
"size should return size"
|
||||
(check-equal? (size (+xbuffer #:length 2) (bytes #xab #xff)) 2))
|
||||
|
||||
(test-case
|
||||
"size should use defined length if no value given"
|
||||
(check-equal? (size (+xbuffer #:length 10)) 10))
|
||||
|
||||
(test-case
|
||||
"encode should encode"
|
||||
(let ([buf (+xbuffer 2)])
|
||||
(check-equal? (bytes-append
|
||||
(encode buf (bytes #xab #xff) #f)
|
||||
(encode buf (bytes #x1f #xb6) #f)) (bytes #xab #xff #x1f #xb6))))
|
||||
|
||||
(test-case
|
||||
"encode should encode with pre-encode"
|
||||
(let ([buf (+xbuffer 2)])
|
||||
(set-pre-encode! buf (λ (bs) (bytes 1 2)))
|
||||
(check-equal? (bytes-append
|
||||
(encode buf (bytes #xab #xff) #f)
|
||||
(encode buf (bytes #x1f #xb6) #f)) (bytes 1 2 1 2))))
|
||||
|
||||
(test-case
|
||||
"encode should encode length before buffer"
|
||||
(check-equal? (encode (+xbuffer #:length uint8) (bytes #xab #xff) #f) (bytes 2 #xab #xff)))
|
||||
@ -1,64 +0,0 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
sugar/unstable/dict
|
||||
"../helper.rkt"
|
||||
"../number.rkt"
|
||||
"../enum.rkt")
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Enum.coffee
|
||||
|#
|
||||
|
||||
(define e (+xenum #:type uint8
|
||||
#:values '("foo" "bar" "baz")))
|
||||
|
||||
(test-case
|
||||
"should error with invalid type"
|
||||
(check-exn exn:fail:contract? (λ () (+xenum 42))))
|
||||
|
||||
(test-case
|
||||
"should error with invalid values"
|
||||
(check-exn exn:fail:contract? (λ () (+xenum #:values 42))))
|
||||
|
||||
(test-case
|
||||
"should have the right size"
|
||||
(check-equal? (size e) 1))
|
||||
|
||||
(test-case
|
||||
"decode should decode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 0))])
|
||||
(check-equal? (decode e) "bar")
|
||||
(check-equal? (decode e) "baz")
|
||||
(check-equal? (decode e) "foo")))
|
||||
|
||||
(test-case
|
||||
"decode should decode with post-decode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 0))])
|
||||
(set-post-decode! e (λ (val) "foobar"))
|
||||
(check-equal? (decode e) "foobar")
|
||||
(check-equal? (decode e) "foobar")
|
||||
(check-equal? (decode e) "foobar")))
|
||||
|
||||
(test-case
|
||||
"encode should encode"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode e "bar")
|
||||
(encode e "baz")
|
||||
(encode e "foo")
|
||||
(check-equal? (dump (current-output-port)) (bytes 1 2 0))))
|
||||
|
||||
(test-case
|
||||
"encode should encode with pre-encode"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(set-pre-encode! e (λ (val) "foo"))
|
||||
(encode e "bar")
|
||||
(encode e "baz")
|
||||
(encode e "foo")
|
||||
(check-equal? (dump (current-output-port)) (bytes 0 0 0))))
|
||||
|
||||
(test-case
|
||||
"should throw on unknown option"
|
||||
(set-pre-encode! e values)
|
||||
(set-post-decode! e values)
|
||||
(check-exn exn:fail:contract? (λ () (encode e "unknown" (open-output-bytes)))))
|
||||
@ -1,209 +0,0 @@
|
||||
#lang racket/base
|
||||
(require rackunit "../number.rkt" "../helper.rkt")
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Number.coffee
|
||||
|#
|
||||
|
||||
(test-case
|
||||
"uint8: decode, size, encode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes #xab #xff))])
|
||||
(check-equal? (decode uint8) #xab)
|
||||
(check-equal? (decode uint8) #xff))
|
||||
(check-equal? (size uint8) 1)
|
||||
(let ([port (open-output-bytes)])
|
||||
(encode uint8 #xab port)
|
||||
(encode uint8 #xff port)
|
||||
(check-equal? (dump port) (bytes #xab #xff))))
|
||||
|
||||
(test-case
|
||||
"uint8: decode with post-decode, size, encode with pre-encode"
|
||||
(define myuint8 (+xint 1 #:signed #f))
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes #xab #xff))])
|
||||
(set-post-decode! myuint8 (λ (b) #xdeadbeef))
|
||||
(check-equal? (decode myuint8) #xdeadbeef)
|
||||
(check-equal? (decode myuint8) #xdeadbeef))
|
||||
(check-equal? (size myuint8) 1)
|
||||
(let ([port (open-output-bytes)])
|
||||
(set-pre-encode! myuint8 (λ (b) #xcc))
|
||||
(encode myuint8 #xab port)
|
||||
(encode myuint8 #xff port)
|
||||
(check-equal? (dump port) (bytes #xcc #xcc))))
|
||||
|
||||
(test-case
|
||||
"uint16 is the same endianness as the platform"
|
||||
(check-equal? (decode uint16 (bytes 0 1))
|
||||
(decode (if (system-big-endian?) uint16be uint16le) (bytes 0 1))))
|
||||
|
||||
(test-case
|
||||
"uint16be: decode, size, encode"
|
||||
(check-equal? (decode uint16be (open-input-bytes (bytes #xab #xff))) #xabff)
|
||||
(check-equal? (size uint16be) 2)
|
||||
(check-equal? (encode uint16be #xabff #f) (bytes #xab #xff)))
|
||||
|
||||
(test-case
|
||||
"uint16le: decode, size, encode"
|
||||
(check-equal? (decode uint16le (open-input-bytes (bytes #xff #xab))) #xabff)
|
||||
(check-equal? (size uint16le) 2)
|
||||
(check-equal? (encode uint16le #xabff #f) (bytes #xff #xab)))
|
||||
|
||||
(test-case
|
||||
"uint24 is the same endianness as the platform"
|
||||
(check-equal? (decode uint24 (bytes 0 1 2))
|
||||
(decode (if (system-big-endian?) uint24be uint24le) (bytes 0 1 2))))
|
||||
(test-case
|
||||
"uint24be: decode, size, encode"
|
||||
(check-equal? (decode uint24be (open-input-bytes (bytes #xff #xab #x24))) #xffab24)
|
||||
(check-equal? (size uint24be) 3)
|
||||
(check-equal? (encode uint24be #xffab24 #f) (bytes #xff #xab #x24)))
|
||||
|
||||
(test-case
|
||||
"uint24le: decode, size, encode"
|
||||
(check-equal? (decode uint24le (open-input-bytes (bytes #x24 #xab #xff))) #xffab24)
|
||||
(check-equal? (size uint24le) 3)
|
||||
(check-equal? (encode uint24le #xffab24 #f) (bytes #x24 #xab #xff)))
|
||||
|
||||
(test-case
|
||||
"uint32 is the same endianness as the platform"
|
||||
(check-equal? (decode uint32 (bytes 0 1 2 3))
|
||||
(decode (if (system-big-endian?) uint32be uint32le) (bytes 0 1 2 3))))
|
||||
(test-case
|
||||
"uint32be: decode, size, encode"
|
||||
(check-equal? (decode uint32be (open-input-bytes (bytes #xff #xab #x24 #xbf))) #xffab24bf)
|
||||
(check-equal? (size uint32be) 4)
|
||||
(check-equal? (encode uint32be #xffab24bf #f) (bytes #xff #xab #x24 #xbf)))
|
||||
|
||||
(test-case
|
||||
"uint32le: decode, size, encode"
|
||||
(check-equal? (decode uint32le (open-input-bytes (bytes #xbf #x24 #xab #xff))) #xffab24bf)
|
||||
(check-equal? (size uint32le) 4)
|
||||
(check-equal? (encode uint32le #xffab24bf #f) (bytes #xbf #x24 #xab #xff)))
|
||||
|
||||
(test-case
|
||||
"int8: decode, size, encode"
|
||||
(let ([port (open-input-bytes (bytes #x7f #xff))])
|
||||
(check-equal? (decode int8 port) 127)
|
||||
(check-equal? (decode int8 port) -1))
|
||||
(check-equal? (size int8) 1)
|
||||
(let ([port (open-output-bytes)])
|
||||
(encode int8 127 port)
|
||||
(encode int8 -1 port)
|
||||
(check-equal? (dump port) (bytes #x7f #xff))))
|
||||
|
||||
(test-case
|
||||
"int32 is the same endianness as the platform"
|
||||
(check-equal? (decode int16 (bytes 0 1))
|
||||
(decode (if (system-big-endian?) int16be int16le) (bytes 0 1))))
|
||||
(test-case
|
||||
"int16be: decode, size, encode"
|
||||
(let ([port (open-input-bytes (bytes #xff #xab))])
|
||||
(check-equal? (decode int16be port) -85))
|
||||
(check-equal? (size int16be) 2)
|
||||
(let ([port (open-output-bytes)])
|
||||
(encode int16be -85 port)
|
||||
(check-equal? (dump port) (bytes #xff #xab))))
|
||||
|
||||
(test-case
|
||||
"int16le: decode, size, encode"
|
||||
(check-equal? (decode int16le (open-input-bytes (bytes #xab #xff))) -85)
|
||||
(check-equal? (size int16le) 2)
|
||||
(check-equal? (encode int16le -85 #f) (bytes #xab #xff)))
|
||||
|
||||
(test-case
|
||||
"int24 is the same endianness as the platform"
|
||||
(check-equal? (decode int24 (bytes 0 1 2))
|
||||
(decode (if (system-big-endian?) int24be int24le) (bytes 0 1 2))))
|
||||
(test-case
|
||||
"int24be: decode, size, encode"
|
||||
(check-equal? (decode int24be (open-input-bytes (bytes #xff #xab #x24))) -21724)
|
||||
(check-equal? (size int24be) 3)
|
||||
(check-equal? (encode int24be -21724 #f) (bytes #xff #xab #x24)))
|
||||
|
||||
(test-case
|
||||
"int24le: decode, size, encode"
|
||||
(check-equal? (decode int24le (open-input-bytes (bytes #x24 #xab #xff))) -21724)
|
||||
(check-equal? (size int24le) 3)
|
||||
(check-equal? (encode int24le -21724 #f) (bytes #x24 #xab #xff)))
|
||||
(test-case
|
||||
"int32 is the same endianness as the platform"
|
||||
(check-equal? (decode int32 (bytes 0 1 2 3))
|
||||
(decode (if (system-big-endian?) int32be int32le) (bytes 0 1 2 3))))
|
||||
|
||||
(test-case
|
||||
"int32be: decode, size, encode"
|
||||
(check-equal? (decode int32be (open-input-bytes (bytes #xff #xab #x24 #xbf))) -5561153)
|
||||
(check-equal? (size int32be) 4)
|
||||
(check-equal? (encode int32be -5561153 #f) (bytes #xff #xab #x24 #xbf)))
|
||||
|
||||
(test-case
|
||||
"int32le: decode, size, encode"
|
||||
(check-equal? (decode int32le (open-input-bytes (bytes #xbf #x24 #xab #xff))) -5561153)
|
||||
(check-equal? (size int32le) 4)
|
||||
(check-equal? (encode int32le -5561153 #f) (bytes #xbf #x24 #xab #xff)))
|
||||
|
||||
(test-case
|
||||
"float is the same endianness as the platform"
|
||||
(check-equal? (decode float (bytes 0 1 2 3))
|
||||
(decode (if (system-big-endian?) floatbe floatle) (bytes 0 1 2 3))))
|
||||
(test-case
|
||||
"floatbe: decode, size, encode"
|
||||
(check-= (decode floatbe (open-input-bytes (bytes #x43 #x7a #x8c #xcd))) 250.55 0.01)
|
||||
(check-equal? (size floatbe) 4)
|
||||
(check-equal? (encode floatbe 250.55 #f) (bytes #x43 #x7a #x8c #xcd)))
|
||||
|
||||
(test-case
|
||||
"floatle: decode, size, encode"
|
||||
(check-= (decode floatle (open-input-bytes (bytes #xcd #x8c #x7a #x43))) 250.55 0.01)
|
||||
(check-equal? (size floatle) 4)
|
||||
(check-equal? (encode floatle 250.55 #f) (bytes #xcd #x8c #x7a #x43)))
|
||||
|
||||
(test-case
|
||||
"double is the same endianness as the platform"
|
||||
(check-equal? (decode double (bytes 0 1 2 3 4 5 6 7))
|
||||
(decode (if (system-big-endian?) doublebe doublele) (bytes 0 1 2 3 4 5 6 7))))
|
||||
(test-case
|
||||
"doublebe: decode, size, encode"
|
||||
(check-equal? (decode doublebe (open-input-bytes (bytes #x40 #x93 #x4a #x3d #x70 #xa3 #xd7 #x0a))) 1234.56)
|
||||
(check-equal? (size doublebe) 8)
|
||||
(check-equal? (encode doublebe 1234.56 #f) (bytes #x40 #x93 #x4a #x3d #x70 #xa3 #xd7 #x0a)))
|
||||
|
||||
(test-case
|
||||
"doublele: decode, size, encode"
|
||||
(check-equal? (decode doublele (open-input-bytes (bytes #x0a #xd7 #xa3 #x70 #x3d #x4a #x93 #x40))) 1234.56)
|
||||
(check-equal? (size doublele) 8)
|
||||
(check-equal? (encode doublele 1234.56 #f) (bytes #x0a #xd7 #xa3 #x70 #x3d #x4a #x93 #x40)))
|
||||
|
||||
(test-case
|
||||
"fixed16 is the same endianness as the platform"
|
||||
(check-equal? (decode fixed16 (bytes 0 1))
|
||||
(decode (if (system-big-endian?) fixed16be fixed16le) (bytes 0 1))))
|
||||
|
||||
(test-case
|
||||
"fixed16be: decode, size, encode"
|
||||
(check-= (decode fixed16be (open-input-bytes (bytes #x19 #x57))) 25.34 0.01)
|
||||
(check-equal? (size fixed16be) 2)
|
||||
(check-equal? (encode fixed16be 25.34 #f) (bytes #x19 #x57)))
|
||||
|
||||
(test-case
|
||||
"fixed16le: decode, size, encode"
|
||||
(check-= (decode fixed16le (open-input-bytes (bytes #x57 #x19))) 25.34 0.01)
|
||||
(check-equal? (size fixed16le) 2)
|
||||
(check-equal? (encode fixed16le 25.34 #f) (bytes #x57 #x19)))
|
||||
|
||||
(test-case
|
||||
"fixed32 is the same endianness as the platform"
|
||||
(check-equal? (decode fixed32 (bytes 0 1 2 3))
|
||||
(decode (if (system-big-endian?) fixed32be fixed32le) (bytes 0 1 2 3))))
|
||||
|
||||
(test-case
|
||||
"fixed32be: decode, size, encode"
|
||||
(check-= (decode fixed32be (open-input-bytes (bytes #x00 #xfa #x8c #xcc))) 250.55 0.01)
|
||||
(check-equal? (size fixed32be) 4)
|
||||
(check-equal? (encode fixed32be 250.55 #f) (bytes #x00 #xfa #x8c #xcc)))
|
||||
|
||||
(test-case
|
||||
"fixed32le: decode, size, encode"
|
||||
(check-= (decode fixed32le (open-input-bytes (bytes #xcc #x8c #xfa #x00))) 250.55 0.01)
|
||||
(check-equal? (size fixed32le) 4)
|
||||
(check-equal? (encode fixed32le 250.55 #f) (bytes #xcc #x8c #xfa #x00)))
|
||||
@ -1,116 +0,0 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
"../helper.rkt"
|
||||
"../number.rkt"
|
||||
"../optional.rkt")
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Optional.coffee
|
||||
|#
|
||||
|
||||
(test-case
|
||||
"decode should not decode when condition is falsy"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+xoptional #:type uint8 #:condition #f))
|
||||
(check-equal? (decode optional) (void))
|
||||
(check-equal? (pos (current-input-port)) 0)))
|
||||
|
||||
(test-case
|
||||
"decode with post-decode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+xoptional #:type uint8 #:condition #f))
|
||||
(set-post-decode! optional (λ (val) 42))
|
||||
(check-equal? (decode optional) 42)
|
||||
(check-equal? (pos (current-input-port)) 0)))
|
||||
|
||||
(test-case
|
||||
"decode should not decode when condition is a function and falsy"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+xoptional #:type uint8 #:condition (λ _ #f)))
|
||||
(check-equal? (decode optional) (void))
|
||||
(check-equal? (pos (current-input-port)) 0)))
|
||||
|
||||
(test-case
|
||||
"decode should decode when condition is omitted"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+xoptional #:type uint8))
|
||||
(check-not-equal? (decode optional) (void))
|
||||
(check-equal? (pos (current-input-port)) 1)))
|
||||
|
||||
(test-case
|
||||
"decode should decode when condition is truthy"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+xoptional #:type uint8 #:condition #t))
|
||||
(check-not-equal? (decode optional) (void))
|
||||
(check-equal? (pos (current-input-port)) 1)))
|
||||
|
||||
(test-case
|
||||
"decode should decode when condition is a function and truthy"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+xoptional #:type uint8 #:condition (λ _ #t)))
|
||||
(check-not-equal? (decode optional) (void))
|
||||
(check-equal? (pos (current-input-port)) 1)))
|
||||
|
||||
(test-case
|
||||
"size"
|
||||
(check-equal? (size (+xoptional #:type uint8 #:condition #f)) 0))
|
||||
|
||||
(test-case
|
||||
"size should return 0 when condition is a function and falsy"
|
||||
(check-equal? (size (+xoptional #:type uint8 #:condition (λ _ #f))) 0))
|
||||
|
||||
(test-case
|
||||
"size should return given type size when condition is omitted"
|
||||
(check-equal? (size (+xoptional #:type uint8)) 1))
|
||||
|
||||
(test-case
|
||||
"size should return given type size when condition is truthy"
|
||||
(check-equal? (size (+xoptional #:type uint8 #:condition #t)) 1))
|
||||
|
||||
(test-case
|
||||
"size should return given type size when condition is a function and truthy"
|
||||
(check-equal? (size (+xoptional #:type uint8 #:condition (λ _ #t))) 1))
|
||||
|
||||
(test-case
|
||||
"encode should not encode when condition is falsy"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+xoptional #:type uint8 #:condition #f))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes))))
|
||||
|
||||
(test-case
|
||||
"encode with pre-encode"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+xoptional #:type uint8))
|
||||
(set-pre-encode! optional (λ (val) 42))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes 42))))
|
||||
|
||||
(test-case
|
||||
"encode should not encode when condition is a function and falsy"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+xoptional #:type uint8 #:condition (λ _ #f)))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes))))
|
||||
|
||||
(test-case
|
||||
"encode should encode when condition is omitted"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+xoptional #:type uint8))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes 128))))
|
||||
|
||||
(test-case
|
||||
"encode should encode when condition is truthy"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+xoptional #:type uint8 #:condition #t))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes 128))))
|
||||
|
||||
(test-case
|
||||
"encode should encode when condition is a function and truthy"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+xoptional #:type uint8 #:condition (λ _ #t)))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes 128))))
|
||||
@ -1,211 +0,0 @@
|
||||
#lang debug racket/base
|
||||
(require rackunit
|
||||
racket/dict
|
||||
"../helper.rkt"
|
||||
"../pointer.rkt"
|
||||
"../number.rkt"
|
||||
"../struct.rkt"
|
||||
racket/promise
|
||||
sugar/unstable/dict)
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
|
||||
|#
|
||||
|
||||
(test-case
|
||||
"decode should handle null pointers"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(check-false (decode (+xpointer) #:parent (mhash '_startOffset 50)))))
|
||||
|
||||
(test-case
|
||||
"decode should use local offsets from start of parent by default"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 53))])
|
||||
(check-equal? (decode (+xpointer) #:parent (mhash '_startOffset 0)) 53)))
|
||||
|
||||
(test-case
|
||||
"decode should support immediate offsets"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 53))])
|
||||
(check-equal? (decode (+xpointer #:style 'immediate)) 53)))
|
||||
|
||||
(test-case
|
||||
"decode should support offsets relative to the parent"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0 0 1 53))])
|
||||
(pos (current-input-port) 2)
|
||||
(check-equal? (decode (+xpointer #:style 'parent)
|
||||
#:parent (mhash 'parent (mhash '_startOffset 2))) 53)))
|
||||
|
||||
(test-case
|
||||
"decode should support global offsets"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 4 0 0 0 53))])
|
||||
(pos (current-input-port) 2)
|
||||
(check-equal? (decode (+xpointer #:style 'global)
|
||||
#:parent (mhash 'parent (mhash 'parent (mhash '_startOffset 2))))
|
||||
53)))
|
||||
|
||||
(test-case
|
||||
"decode should support offsets relative to a property on the parent"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 0 0 0 0 53))])
|
||||
(check-equal? (decode (+xpointer #:relative-to (λ (parent) (dict-ref (dict-ref parent 'parent) 'ptr)))
|
||||
#:parent (mhash '_startOffset 0 'parent (mhash 'ptr 4)))
|
||||
53)))
|
||||
|
||||
(test-case
|
||||
"decode should support returning pointer if there is no decode type"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 4))])
|
||||
(check-equal? (decode (+xpointer uint8 'void)
|
||||
#:parent (mhash '_startOffset 0)) 4)))
|
||||
|
||||
(test-case
|
||||
"decode should support decoding pointers lazily"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 53))])
|
||||
(define res (decode (+xstruct (dictify 'ptr (+xpointer #:lazy #t)))))
|
||||
(check-true (promise? (dict-ref (struct-dict-res-_kv res) 'ptr)))
|
||||
(check-equal? (dict-ref res 'ptr) 53)))
|
||||
|
||||
(test-case
|
||||
"size"
|
||||
(let ([parent (mhash 'pointerSize 0)])
|
||||
(check-equal? (size (+xpointer) 10 #:parent parent) 1)
|
||||
(check-equal? (dict-ref parent 'pointerSize) 1)))
|
||||
|
||||
(test-case
|
||||
"size should add to immediate pointerSize"
|
||||
(let ([parent (mhash 'pointerSize 0)])
|
||||
(check-equal? (size (+xpointer #:style 'immediate) 10 #:parent parent) 1)
|
||||
(check-equal? (dict-ref parent 'pointerSize) 1)))
|
||||
|
||||
(test-case
|
||||
"size should add to parent pointerSize"
|
||||
(let ([parent (mhash 'parent (mhash 'pointerSize 0))])
|
||||
(check-equal? (size (+xpointer #:style 'parent) 10 #:parent parent) 1)
|
||||
(check-equal? (dict-ref (dict-ref parent 'parent) 'pointerSize) 1)))
|
||||
|
||||
(test-case
|
||||
"size should add to global pointerSize"
|
||||
(let ([parent (mhash 'parent (mhash 'parent (mhash 'parent (mhash 'pointerSize 0))))])
|
||||
(check-equal? (size (+xpointer #:style 'global) 10 #:parent parent) 1)
|
||||
(check-equal? (dict-ref (dict-ref (dict-ref (dict-ref parent 'parent) 'parent) 'parent) 'pointerSize) 1)))
|
||||
|
||||
(test-case
|
||||
"size should handle void pointers"
|
||||
(let ([parent (mhash 'pointerSize 0)])
|
||||
(check-equal? (size (+xpointer uint8 'void) (+xvoid-pointer uint8 50) #:parent parent) 1)
|
||||
(check-equal? (dict-ref parent 'pointerSize) 1)))
|
||||
|
||||
(test-case
|
||||
"size should throw if no type and not a void pointer"
|
||||
(let ([parent (mhash 'pointerSize 0)])
|
||||
(check-exn exn:fail:contract? (λ () (size (+xpointer uint8 'void) 30 #:parent parent)))))
|
||||
|
||||
(test-case
|
||||
"size should return a fixed size without a value"
|
||||
(check-equal? (size (+xpointer)) 1))
|
||||
|
||||
(test-case
|
||||
"encode should handle null pointers"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define parent (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 0
|
||||
'pointers null))
|
||||
(encode (+xpointer) #f #:parent parent)
|
||||
(check-equal? (dict-ref parent 'pointerSize) 0)
|
||||
(check-equal? (dump (current-output-port)) (bytes 0))))
|
||||
|
||||
(test-case
|
||||
"encode should handle local offsets"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define parent (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 1
|
||||
'pointers null))
|
||||
(encode (+xpointer) 10 #:parent parent)
|
||||
(check-equal? (dict-ref parent 'pointerOffset) 2)
|
||||
(check-equal? (dict-ref parent 'pointers) (list (mhasheq 'type uint8
|
||||
'val 10
|
||||
'parent parent)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 1))))
|
||||
|
||||
(test-case
|
||||
"encode should handle immediate offsets"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define parent (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 1
|
||||
'pointers null))
|
||||
(encode (+xpointer #:style 'immediate) 10 #:parent parent)
|
||||
(check-equal? (dict-ref parent 'pointerOffset) 2)
|
||||
(check-equal? (dict-ref parent 'pointers) (list (mhasheq 'type uint8
|
||||
'val 10
|
||||
'parent parent)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 0))))
|
||||
|
||||
(test-case
|
||||
"encode should handle offsets relative to parent"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define parent (mhash 'parent (mhash 'pointerSize 0
|
||||
'startOffset 3
|
||||
'pointerOffset 5
|
||||
'pointers null)))
|
||||
(encode (+xpointer #:style 'parent) 10 #:parent parent)
|
||||
(check-equal? (dict-ref (dict-ref parent 'parent) 'pointerOffset) 6)
|
||||
(check-equal? (dict-ref (dict-ref parent 'parent) 'pointers) (list (mhasheq 'type uint8
|
||||
'val 10
|
||||
'parent parent)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 2))))
|
||||
|
||||
(test-case
|
||||
"encode should handle global offsets"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define parent (mhash 'parent
|
||||
(mhash 'parent
|
||||
(mhash 'parent (mhash 'pointerSize 0
|
||||
'startOffset 3
|
||||
'pointerOffset 5
|
||||
'pointers null)))))
|
||||
(encode (+xpointer #:style 'global) 10 #:parent parent)
|
||||
(check-equal? (dict-ref (dict-ref (dict-ref (dict-ref parent 'parent) 'parent) 'parent) 'pointerOffset) 6)
|
||||
(check-equal? (dict-ref (dict-ref (dict-ref (dict-ref parent 'parent) 'parent) 'parent) 'pointers)
|
||||
(list (mhasheq 'type uint8
|
||||
'val 10
|
||||
'parent parent)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 5))))
|
||||
|
||||
(test-case
|
||||
"encode should support offsets relative to a property on the parent"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define parent (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 10
|
||||
'pointers null
|
||||
'val (mhash 'ptr 4)))
|
||||
(encode (+xpointer #:relative-to (λ (parent) (dict-ref parent 'ptr))) 10 #:parent parent)
|
||||
(check-equal? (dict-ref parent 'pointerOffset) 11)
|
||||
(check-equal? (dict-ref parent 'pointers) (list (mhasheq 'type uint8
|
||||
'val 10
|
||||
'parent parent)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 6))))
|
||||
|
||||
(test-case
|
||||
"encode should support void pointers"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define parent (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 1
|
||||
'pointers null))
|
||||
(encode (+xpointer uint8 'void) (+xvoid-pointer uint8 55) #:parent parent)
|
||||
(check-equal? (dict-ref parent 'pointerOffset) 2)
|
||||
(check-equal? (dict-ref parent 'pointers) (list (mhasheq 'type uint8
|
||||
'val 55
|
||||
'parent parent)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 1))))
|
||||
|
||||
(test-case
|
||||
"encode should throw if not a void pointer instance"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define parent (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 1
|
||||
'pointers null))
|
||||
(check-exn exn:fail:contract? (λ () (encode (+xpointer uint8 'void) 44 #:parent parent)))))
|
||||
@ -1,48 +0,0 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
"../number.rkt"
|
||||
"../helper.rkt"
|
||||
"../reserved.rkt")
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Reserved.coffee
|
||||
|#
|
||||
|
||||
(test-case
|
||||
"size should have a default count of 1"
|
||||
(check-equal? (size (+xreserved uint8)) 1))
|
||||
|
||||
(test-case
|
||||
"size should allow custom counts and types"
|
||||
(check-equal? (size (+xreserved uint16be 10)) 20))
|
||||
|
||||
(test-case
|
||||
"should decode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0 0))])
|
||||
(define reserved (+xreserved uint16be))
|
||||
(check-equal? (decode reserved) (void))
|
||||
(check-equal? (pos (current-input-port)) 2)))
|
||||
|
||||
(test-case
|
||||
"should decode with post-decode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0 0))])
|
||||
(define reserved (+xreserved uint16be))
|
||||
(set-post-decode! reserved (λ (val) 42))
|
||||
(check-equal? (decode reserved) 42)
|
||||
(check-equal? (pos (current-input-port)) 2)))
|
||||
|
||||
(test-case
|
||||
"should encode"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define reserved (+xreserved uint16be))
|
||||
(encode reserved #f)
|
||||
(check-equal? (dump (current-output-port)) (bytes 0 0))))
|
||||
|
||||
(test-case
|
||||
"should encode with pre-encode"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define reserved (+xreserved uint32be))
|
||||
(set-pre-encode! reserved (λ (val) 42))
|
||||
(encode reserved #f)
|
||||
(check-equal? (dump (current-output-port)) (bytes 0 0 0 0))))
|
||||
@ -1,124 +0,0 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
"../helper.rkt"
|
||||
"../string.rkt"
|
||||
"../number.rkt"
|
||||
sugar/unstable/dict)
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/String.coffee
|
||||
|#
|
||||
|
||||
(test-case
|
||||
"decode fixed length"
|
||||
(parameterize ([current-input-port (open-input-bytes #"testing")])
|
||||
(check-equal? (decode (+xstring 7)) "testing")))
|
||||
|
||||
(test-case
|
||||
"decode fixed length with post-decode"
|
||||
(parameterize ([current-input-port (open-input-bytes #"testing")])
|
||||
(define xs (+xstring 7))
|
||||
(set-post-decode! xs (λ (val) "ring a ding"))
|
||||
(check-equal? (decode xs) "ring a ding")))
|
||||
|
||||
(test-case
|
||||
"decode length from parent key"
|
||||
(parameterize ([current-input-port (open-input-bytes #"testing")])
|
||||
(check-equal? (decode (+xstring 'len) #:parent (mhash 'len 7)) "testing")))
|
||||
|
||||
(test-case
|
||||
"decode length as number before string"
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x07testing")])
|
||||
(check-equal? (decode (+xstring uint8) #:parent (mhash 'len 7)) "testing")))
|
||||
|
||||
(test-case
|
||||
"decode utf8"
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "🍻"))])
|
||||
(check-equal? (decode (+xstring 4 'utf8)) "🍻")))
|
||||
|
||||
(test-case
|
||||
"decode encoding computed from function"
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "🍻"))])
|
||||
(check-equal? (decode (+xstring 4 (λ _ 'utf8))) "🍻")))
|
||||
|
||||
(test-case
|
||||
"decode null-terminated string and read past terminator"
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "🍻\x00"))])
|
||||
(check-equal? (decode (+xstring #f 'utf8)) "🍻")
|
||||
(check-equal? (pos (current-input-port)) 5)))
|
||||
|
||||
(test-case
|
||||
"decode remainder of buffer when null-byte missing"
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "🍻"))])
|
||||
(check-equal? (decode (+xstring #f 'utf8)) "🍻")))
|
||||
|
||||
(test-case
|
||||
"size should use string length"
|
||||
(check-equal? (size (+xstring 7) "testing") 7))
|
||||
|
||||
(test-case
|
||||
"size should use correct encoding"
|
||||
(check-equal? (size (+xstring 10 'utf8) "🍻") 4))
|
||||
|
||||
(test-case
|
||||
"size should use encoding from function"
|
||||
(check-equal? (size (+xstring 10 (λ _ 'utf8)) "🍻") 4))
|
||||
|
||||
(test-case
|
||||
"should add size of length field before string"
|
||||
(check-equal? (size (+xstring uint8 'utf8) "🍻") 5))
|
||||
|
||||
; todo: it "should work with utf16be encoding"
|
||||
|
||||
(test-case
|
||||
"size should take null-byte into account"
|
||||
(check-equal? (size (+xstring #f 'utf8) "🍻") 5))
|
||||
|
||||
(test-case
|
||||
"size should use defined length if no value given"
|
||||
(check-equal? (size (+xstring 10)) 10))
|
||||
|
||||
(test-case
|
||||
"encode using string length"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+xstring 7) "testing")
|
||||
(check-equal? (dump (current-output-port)) #"testing")))
|
||||
|
||||
(test-case
|
||||
"encode using string length and pre-encode"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define xs (+xstring 7))
|
||||
(set-pre-encode! xs (compose1 list->string reverse string->list))
|
||||
(encode xs "testing")
|
||||
(check-equal? (dump (current-output-port)) #"gnitset")))
|
||||
|
||||
(test-case
|
||||
"encode length as number before string"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+xstring uint8) "testing")
|
||||
(check-equal? (dump (current-output-port)) #"\x07testing")))
|
||||
|
||||
(test-case
|
||||
"encode length as number before string utf8"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+xstring uint8 'utf8) "testing 😜")
|
||||
(check-equal? (dump (current-output-port)) (string->bytes/utf-8 "\x0ctesting 😜"))))
|
||||
|
||||
(test-case
|
||||
"encode utf8"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+xstring 4 'utf8) "🍻" )
|
||||
(check-equal? (dump (current-output-port)) (string->bytes/utf-8 "🍻"))))
|
||||
|
||||
(test-case
|
||||
"encode encoding computed from function"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+xstring 4 (λ _ 'utf8)) "🍻")
|
||||
(check-equal? (dump (current-output-port)) (string->bytes/utf-8 "🍻"))))
|
||||
|
||||
(test-case
|
||||
"encode null-terminated string"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+xstring #f 'utf8) "🍻" )
|
||||
(check-equal? (dump (current-output-port)) (string->bytes/utf-8 "🍻\x00"))))
|
||||
@ -1,80 +0,0 @@
|
||||
#lang debug racket/base
|
||||
(require rackunit racket/dict
|
||||
"../helper.rkt"
|
||||
"../struct.rkt"
|
||||
"../string.rkt"
|
||||
"../pointer.rkt"
|
||||
"../number.rkt"
|
||||
sugar/unstable/dict)
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee
|
||||
|#
|
||||
|
||||
(test-case
|
||||
"decode into an object"
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")])
|
||||
(check-equal?
|
||||
(decode/hash (+xstruct 'name (+xstring #:length uint8) 'age uint8))
|
||||
(hasheq 'name "roxyb" 'age 21))))
|
||||
|
||||
(test-case
|
||||
"decode with process hook"
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x20")])
|
||||
(define struct (+xstruct 'name (+xstring #:length uint8) 'age uint8))
|
||||
(set-post-decode! struct (λ (o . _) (dict-set! o 'canDrink (>= (dict-ref o 'age) 21)) o))
|
||||
(check-equal? (decode/hash struct)
|
||||
(hasheq 'name "roxyb" 'age 32 'canDrink #t))))
|
||||
|
||||
(test-case
|
||||
"decode supports function keys"
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x20")])
|
||||
(define struct (+xstruct 'name (+xstring #:length uint8) 'age uint8 'canDrink (λ (o) (>= (dict-ref o 'age) 21))))
|
||||
(check-equal? (decode/hash struct)
|
||||
(hasheq 'name "roxyb" 'age 32 'canDrink #t))))
|
||||
|
||||
(test-case
|
||||
"compute the correct size"
|
||||
(check-equal? (size (+xstruct 'name (+xstring #:length uint8) 'age uint8)
|
||||
(hasheq 'name "roxyb" 'age 32)) 7))
|
||||
|
||||
(test-case
|
||||
"compute the correct size with pointers"
|
||||
(check-equal? (size (+xstruct 'name (+xstring #:length uint8)
|
||||
'age uint8
|
||||
'ptr (+xpointer #:type (+xstring #:length uint8)))
|
||||
(mhash 'name "roxyb" 'age 21 'ptr "hello")) 14))
|
||||
|
||||
(test-case
|
||||
"get the correct size when no value is given"
|
||||
(check-equal? (size (+xstruct 'name (+xstring 4) 'age uint8)) 5))
|
||||
|
||||
(test-case
|
||||
"throw when getting non-fixed length size and no value is given"
|
||||
(check-exn exn:fail:contract? (λ () (size (+xstruct 'name (+xstring #:length uint8) 'age uint8)))))
|
||||
|
||||
(test-case
|
||||
"encode objects to buffers"
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")])
|
||||
(check-equal? (decode/hash (+xstruct 'name (+xstring #:length uint8) 'age uint8))
|
||||
(hasheq 'name "roxyb" 'age 21))))
|
||||
|
||||
(test-case
|
||||
"support pre-encode hook"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define struct (+xstruct 'nameLength uint8
|
||||
'name (+xstring 'nameLength)
|
||||
'age uint8))
|
||||
(set-pre-encode! struct (λ (val) (dict-set! val 'nameLength (string-length (dict-ref val 'name))) val))
|
||||
(encode struct (mhasheq 'name "roxyb" 'age 21))
|
||||
(check-equal? (dump (current-output-port)) #"\x05roxyb\x15")))
|
||||
|
||||
(test-case
|
||||
"encode pointer data after structure"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define struct (+xstruct 'name (+xstring #:length uint8)
|
||||
'age uint8
|
||||
'ptr (+xpointer #:type (+xstring #:length uint8))))
|
||||
(encode struct (hasheq 'name "roxyb" 'age 21 'ptr "hello"))
|
||||
(check-equal? (dump (current-output-port)) #"\x05roxyb\x15\x08\x05hello")))
|
||||
@ -1,248 +0,0 @@
|
||||
#lang debug racket/base
|
||||
(require rackunit
|
||||
racket/dict
|
||||
sugar/unstable/dict
|
||||
"../helper.rkt"
|
||||
"../number.rkt"
|
||||
"../string.rkt"
|
||||
"../pointer.rkt"
|
||||
"../versioned-struct.rkt")
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffee
|
||||
|#
|
||||
|
||||
(test-case
|
||||
"decode should get version from number type"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")])
|
||||
(check-equal? (decode/hash vstruct) (hasheq 'name "roxyb" 'age 21 'version 0)))
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x01\x0aroxyb 🤘\x15\x00"))])
|
||||
(check-equal? (decode/hash vstruct) (hasheq 'name "roxyb 🤘" 'age 21 'version 1 'gender 0)))))
|
||||
|
||||
(test-case
|
||||
"decode should throw for unknown version"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05\x05roxyb\x15")])
|
||||
(check-exn exn:fail:contract? (λ () (decode vstruct))))))
|
||||
|
||||
(test-case
|
||||
"decode should support common header block"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
'header (dictify 'age uint8
|
||||
'alive uint8)
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii))
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'gender uint8)))])
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x00\x15\x01\x05roxyb")])
|
||||
(check-equal? (decode/hash vstruct) (hasheq 'name "roxyb"
|
||||
'age 21
|
||||
'alive 1
|
||||
'version 0)))
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x01\x15\x01\x0aroxyb 🤘\x00"))])
|
||||
(check-equal? (decode/hash vstruct) (hasheq 'name "roxyb 🤘"
|
||||
'age 21
|
||||
'version 1
|
||||
'alive 1
|
||||
'gender 0)))))
|
||||
|
||||
(test-case
|
||||
"decode should support parent version key"
|
||||
(let ([vstruct (+xversioned-struct 'version
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")])
|
||||
(check-equal? (decode/hash vstruct #:parent (mhash 'version 0))
|
||||
(hasheq 'name "roxyb" 'age 21 'version 0)))
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x0aroxyb 🤘\x15\x00"))])
|
||||
(check-equal? (decode/hash vstruct #:parent (mhash 'version 1))
|
||||
(hasheq 'name "roxyb 🤘" 'age 21 'version 1 'gender 0)))))
|
||||
|
||||
(test-case
|
||||
"decode should support sub versioned structs"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring uint8))
|
||||
1 (dictify 'name (+xstring uint8)
|
||||
'isDessert uint8)))))])
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")])
|
||||
(check-equal? (decode/hash vstruct #:parent (mhash 'version 0))
|
||||
(hasheq 'name "roxyb" 'age 21 'version 0)))
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x01\x00\x05pasta")])
|
||||
(check-equal? (decode/hash vstruct #:parent (mhash 'version 0))
|
||||
(hasheq 'name "pasta" 'version 0)))
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x01\x01\x09ice cream\x01")])
|
||||
(check-equal? (decode/hash vstruct #:parent (mhash 'version 0))
|
||||
(hasheq 'name "ice cream" 'isDessert 1 'version 1)))))
|
||||
|
||||
(test-case
|
||||
"decode should support process hook"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
(set-post-decode! vstruct (λ (val) (dict-set! val 'processed "true") val))
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")])
|
||||
(check-equal? (decode/hash vstruct)
|
||||
(hasheq 'name "roxyb" 'processed "true" 'age 21 'version 0)))))
|
||||
|
||||
(test-case
|
||||
"size should compute the correct size"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
(check-equal? (size vstruct (mhasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 0)) 8)
|
||||
(check-equal? (size vstruct (mhasheq 'name "roxyb 🤘"
|
||||
'gender 0
|
||||
'age 21
|
||||
'version 1)) 14)))
|
||||
|
||||
(test-case
|
||||
"size should throw for unknown version"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
(check-exn exn:fail:contract? (λ () (size vstruct (mhasheq 'name "roxyb" 'age 21 'version 5))))))
|
||||
|
||||
(test-case
|
||||
"size should support common header block"
|
||||
(let ([struct (+xversioned-struct uint8
|
||||
(dictify
|
||||
'header (dictify 'age uint8
|
||||
'alive uint8)
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii))
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'gender uint8)))])
|
||||
(check-equal? (size struct (mhasheq 'name "roxyb" 'age 21 'alive 1 'version 0)) 9)
|
||||
(check-equal? (size struct (mhasheq 'name "roxyb 🤘" 'gender 0 'age 21 'alive 1 'version 1)) 15)))
|
||||
|
||||
(test-case
|
||||
"size should compute the correct size with pointers"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'ptr (+xpointer #:offset-type uint8
|
||||
#:type (+xstring uint8)))))])
|
||||
(check-equal? (size vstruct (mhasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 1
|
||||
'ptr "hello")) 15)))
|
||||
|
||||
(test-case
|
||||
"size should throw if no value is given"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
(check-exn exn:fail:contract? (λ () (size vstruct)))))
|
||||
|
||||
(test-case
|
||||
"encode should encode objects to buffers"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))]
|
||||
[op (open-output-bytes)])
|
||||
(encode vstruct (mhasheq 'name "roxyb" 'age 21 'version 0) op)
|
||||
(encode vstruct (mhasheq 'name "roxyb 🤘" 'age 21 'gender 0 'version 1) op)
|
||||
(check-equal? (dump op) (string->bytes/utf-8 "\x00\x05roxyb\x15\x01\x0aroxyb 🤘\x15\x00"))))
|
||||
|
||||
(test-case
|
||||
"encode should throw for unknown version"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))]
|
||||
[op (open-output-bytes)])
|
||||
(check-exn exn:fail:contract? (λ () (encode vstruct op (mhasheq 'name "roxyb" 'age 21 'version 5))))))
|
||||
|
||||
(test-case
|
||||
"encode should support common header block"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
'header (dictify 'age uint8
|
||||
'alive uint8)
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii))
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'gender uint8)))]
|
||||
[op (open-output-bytes)])
|
||||
(encode vstruct (mhasheq 'name "roxyb" 'age 21 'alive 1 'version 0) op)
|
||||
(encode vstruct (mhasheq 'name "roxyb 🤘" 'gender 0 'age 21 'alive 1 'version 1) op)
|
||||
(check-equal? (dump op) (string->bytes/utf-8 "\x00\x15\x01\x05roxyb\x01\x15\x01\x0aroxyb 🤘\x00"))))
|
||||
|
||||
(test-case
|
||||
"encode should encode pointer data after structure"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'ptr (+xpointer #:offset-type uint8
|
||||
#:type (+xstring uint8)))))]
|
||||
[op (open-output-bytes)])
|
||||
(encode vstruct (mhasheq 'version 1 'name "roxyb" 'age 21 'ptr "hello") op)
|
||||
|
||||
(check-equal? (dump op) (string->bytes/utf-8 "\x01\x05roxyb\x15\x09\x05hello"))))
|
||||
|
||||
(test-case
|
||||
"encode should support preEncode hook"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))]
|
||||
[stream (open-output-bytes)])
|
||||
(set-pre-encode! vstruct (λ (val) (dict-set! val 'version (if (dict-ref val 'gender #f) 1 0)) val))
|
||||
(encode vstruct (mhasheq 'name "roxyb" 'age 21 'version 0) stream)
|
||||
(encode vstruct (mhasheq 'name "roxyb 🤘" 'age 21 'gender 0) stream)
|
||||
(check-equal? (dump stream) (string->bytes/utf-8 "\x00\x05roxyb\x15\x01\x0aroxyb 🤘\x15\x00"))))
|
||||
@ -1,108 +0,0 @@
|
||||
#lang racket/base
|
||||
(require "helper.rkt" "struct.rkt"
|
||||
racket/dict
|
||||
sugar/unstable/dict)
|
||||
(provide (all-defined-out) decode/hash)
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
|
||||
|#
|
||||
|
||||
(define/post-decode (xversioned-struct-decode xvs [port-arg (current-input-port)] #:parent [parent #f] [length 0])
|
||||
(define port (->input-port port-arg))
|
||||
(define res (_setup port parent length))
|
||||
|
||||
(dict-set! res 'version
|
||||
(cond
|
||||
[(integer? (xversioned-struct-type xvs)) (xversioned-struct-type xvs)]
|
||||
#;[forced-version] ; for testing purposes: pass an explicit version
|
||||
[(or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs)))
|
||||
(unless parent
|
||||
(raise-argument-error 'xversioned-struct-decode "valid parent" parent))
|
||||
((xversioned-struct-version-getter xvs) parent)]
|
||||
[else (decode (xversioned-struct-type xvs) port)]))
|
||||
|
||||
(when (dict-ref (xversioned-struct-versions xvs) 'header #f)
|
||||
(_parse-fields port res (dict-ref (xversioned-struct-versions xvs) 'header)))
|
||||
|
||||
(define fields (or (dict-ref (xversioned-struct-versions xvs) (dict-ref res 'version #f) #f)
|
||||
(raise-argument-error 'xversioned-struct-decode "valid version key" (cons version (xversioned-struct-versions xvs)))))
|
||||
|
||||
(cond
|
||||
[(xversioned-struct? fields) (decode fields port #:parent parent)]
|
||||
[else (_parse-fields port res fields)
|
||||
res]))
|
||||
|
||||
(define/finalize-size (xversioned-struct-size xvs [val #f] #:parent [parent-arg #f] [include-pointers #t])
|
||||
(unless val
|
||||
(raise-argument-error 'xversioned-struct-size "value" val))
|
||||
(define parent (mhash 'parent parent-arg 'val val 'pointerSize 0))
|
||||
(define version-size
|
||||
(if (not (or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs))))
|
||||
(size (xversioned-struct-type xvs) (dict-ref val 'version) #:parent parent)
|
||||
0))
|
||||
(define header-size
|
||||
(for/sum ([(key type) (in-dict (or (dict-ref (xversioned-struct-versions xvs) 'header #f) null))])
|
||||
(size type (and val (dict-ref val key)) #:parent parent)))
|
||||
(define fields-size
|
||||
(let ([fields (or (dict-ref (xversioned-struct-versions xvs) (dict-ref val 'version))
|
||||
(raise-argument-error 'xversioned-struct-size "valid version key" version))])
|
||||
(for/sum ([(key type) (in-dict fields)])
|
||||
(size type (and val (dict-ref val key)) #:parent parent))))
|
||||
(define pointer-size (if include-pointers (dict-ref parent 'pointerSize) 0))
|
||||
(+ version-size header-size fields-size pointer-size))
|
||||
|
||||
(define/pre-encode (xversioned-struct-encode xvs val [port-arg (current-output-port)] #:parent [parent-arg #f])
|
||||
(define port (if (output-port? port-arg) port-arg (open-output-bytes)))
|
||||
(parameterize ([current-output-port port])
|
||||
(unless (dict? val)
|
||||
(raise-argument-error 'xversioned-struct-encode "dict" val))
|
||||
|
||||
(define parent (mhash 'pointers null
|
||||
'startOffset (pos port)
|
||||
'parent parent-arg
|
||||
'val val
|
||||
'pointerSize 0))
|
||||
(dict-set! parent 'pointerOffset (+ (pos port) (xversioned-struct-size xvs val #:parent parent #f)))
|
||||
|
||||
(when (not (or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs))))
|
||||
(encode (xversioned-struct-type xvs) (dict-ref val 'version #f)))
|
||||
|
||||
(when (dict-ref (xversioned-struct-versions xvs) 'header #f)
|
||||
(for ([(key type) (in-dict (dict-ref (xversioned-struct-versions xvs) 'header))])
|
||||
(encode type (dict-ref val key) #:parent parent)))
|
||||
|
||||
(define fields (or (dict-ref (xversioned-struct-versions xvs) (dict-ref val 'version #f))
|
||||
(raise-argument-error 'xversioned-struct-encode "valid version key" version)))
|
||||
|
||||
(unless (andmap (λ (key) (member key (dict-keys val))) (dict-keys fields))
|
||||
(raise-argument-error 'xversioned-struct-encode (format "hash that contains superset of Struct keys: ~a" (dict-keys fields)) (hash-keys val)))
|
||||
|
||||
(for ([(key type) (in-dict fields)])
|
||||
(encode type (dict-ref val key) #:parent parent))
|
||||
(for ([ptr (in-list (dict-ref parent 'pointers))])
|
||||
(encode (dict-ref ptr 'type) (dict-ref ptr 'val) #:parent (dict-ref ptr 'parent)))
|
||||
|
||||
(unless port-arg (get-output-bytes port))))
|
||||
|
||||
(struct xversioned-struct structish (type versions version-getter version-setter) #:transparent #:mutable
|
||||
#:methods gen:xenomorphic
|
||||
[(define decode xversioned-struct-decode)
|
||||
(define encode xversioned-struct-encode)
|
||||
(define size xversioned-struct-size)])
|
||||
|
||||
(define (+xversioned-struct type [versions (dictify)])
|
||||
(unless (for/or ([proc (list integer? procedure? xenomorphic? symbol?)])
|
||||
(proc type))
|
||||
(raise-argument-error '+xversioned-struct "integer, procedure, symbol, or xenomorphic" type))
|
||||
(unless (and (dict? versions) (andmap (λ (v) (or (dict? v) (structish? v))) (dict-values versions)))
|
||||
(raise-argument-error '+xversioned-struct "dict of dicts or structish" versions))
|
||||
(define version-getter (cond
|
||||
[(procedure? type) type]
|
||||
[(symbol? type) (λ (parent) (dict-ref parent type))]))
|
||||
(define version-setter (cond
|
||||
[(procedure? type) type]
|
||||
[(symbol? type) (λ (parent version) (dict-set! parent type version))]))
|
||||
(xversioned-struct type versions version-getter version-setter))
|
||||
|
||||
@ -1,51 +1,76 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
sugar/unstable/dict
|
||||
racket/match
|
||||
racket/list
|
||||
racket/match)
|
||||
sugar/unstable/dict
|
||||
"../helper.rkt"
|
||||
"../number.rkt"
|
||||
"../bitfield.rkt")
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Bitfield.coffee
|
||||
|#
|
||||
|
||||
;describe 'Bitfield', ->
|
||||
; bitfield = new Bitfield uint8, ['Jack', 'Kack', 'Lack', 'Mack', 'Nack', 'Oack', 'Pack', 'Quack']
|
||||
; JACK = 1 << 0
|
||||
; KACK = 1 << 1
|
||||
; LACK = 1 << 2
|
||||
; MACK = 1 << 3
|
||||
; NACK = 1 << 4
|
||||
; OACK = 1 << 5
|
||||
; PACK = 1 << 6
|
||||
; QUACK = 1 << 7
|
||||
|
||||
(define bitfield (+Bitfield uint8 '(Jack Kack Lack Mack Nack Oack Pack Quack)))
|
||||
(define bitfield (+xbitfield uint8 '(Jack Kack Lack Mack Nack Oack Pack Quack)))
|
||||
(match-define (list JACK KACK LACK MACK NACK OACK PACK QUACK)
|
||||
(map (λ (x) (arithmetic-shift 1 x)) (range 8)))
|
||||
|
||||
; it 'should have the right size', ->
|
||||
(check-equal? (size bitfield) 1)
|
||||
(test-case
|
||||
"bitfield should have the right size"
|
||||
(check-equal? (size bitfield) 1))
|
||||
|
||||
(test-case
|
||||
"bitfield should decode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes (bitwise-ior JACK MACK PACK NACK QUACK)))])
|
||||
(check-equal? (decode bitfield) (mhasheq 'Quack #t
|
||||
'Nack #t
|
||||
'Lack #f
|
||||
'Oack #f
|
||||
'Pack #t
|
||||
'Mack #t
|
||||
'Jack #t
|
||||
'Kack #f))))
|
||||
|
||||
(test-case
|
||||
"bitfield should decode with post-decode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes (bitwise-ior JACK MACK PACK NACK QUACK)))])
|
||||
(set-post-decode! bitfield (λ (fh . _) (hash-set! fh 'foo 42) fh))
|
||||
(check-equal? (decode bitfield) (mhasheq 'Quack #t
|
||||
'Nack #t
|
||||
'Lack #f
|
||||
'Oack #f
|
||||
'Pack #t
|
||||
'Mack #t
|
||||
'Jack #t
|
||||
'Kack #f
|
||||
'foo 42))))
|
||||
|
||||
; it 'should decode', ->
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes (bitwise-ior JACK MACK PACK NACK QUACK)))])
|
||||
(check-equal? (decode bitfield) (mhasheq 'Quack #t
|
||||
'Nack #t
|
||||
'Lack #f
|
||||
'Oack #f
|
||||
'Pack #t
|
||||
'Mack #t
|
||||
'Jack #t
|
||||
'Kack #f)))
|
||||
(test-case
|
||||
"bitfield should encode"
|
||||
(check-equal? (encode bitfield (mhasheq 'Quack #t
|
||||
'Nack #t
|
||||
'Lack #f
|
||||
'Oack #f
|
||||
'Pack #t
|
||||
'Mack #t
|
||||
'Jack #t
|
||||
'Kack #f) #f)
|
||||
(bytes (bitwise-ior JACK MACK PACK NACK QUACK))))
|
||||
|
||||
; it 'should encode', (done) ->
|
||||
(check-equal? (encode bitfield (mhasheq 'Quack #t
|
||||
'Nack #t
|
||||
'Lack #f
|
||||
'Oack #f
|
||||
'Pack #t
|
||||
'Mack #t
|
||||
'Jack #t
|
||||
'Kack #f) #f)
|
||||
(bytes (bitwise-ior JACK MACK PACK NACK QUACK)))
|
||||
(test-case
|
||||
"bitfield should encode with pre-encode"
|
||||
(set-pre-encode! bitfield (λ (fh . _)
|
||||
(hash-set! fh 'Jack #f)
|
||||
(hash-set! fh 'Mack #f)
|
||||
(hash-set! fh 'Pack #f)
|
||||
fh))
|
||||
(check-equal? (encode bitfield (mhasheq 'Quack #t
|
||||
'Nack #t
|
||||
'Lack #f
|
||||
'Oack #f
|
||||
'Pack #t
|
||||
'Mack #t
|
||||
'Jack #t
|
||||
'Kack #f) #f)
|
||||
(bytes (bitwise-ior NACK QUACK))))
|
||||
|
||||
@ -1,46 +1,64 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
sugar/unstable/dict)
|
||||
|
||||
sugar/unstable/dict
|
||||
"../buffer.rkt"
|
||||
"../number.rkt"
|
||||
"../helper.rkt")
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Buffer.coffee
|
||||
|#
|
||||
|
||||
;describe 'Buffer', ->
|
||||
; describe 'decode', ->
|
||||
; it 'should decode', ->
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes #xab #xff #x1f #xb6))])
|
||||
(define buf (+BufferT 2))
|
||||
(check-equal? (decode buf) (bytes #xab #xff))
|
||||
(check-equal? (decode buf) (bytes #x1f #xb6)))
|
||||
|
||||
|
||||
; it 'should decode with parent key length', ->
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes #xab #xff #x1f #xb6))])
|
||||
(define buf (+BufferT 'len))
|
||||
(check-equal? (decode buf #:parent (hash 'len 3)) (bytes #xab #xff #x1f))
|
||||
(check-equal? (decode buf #:parent (hash 'len 1)) (bytes #xb6)))
|
||||
(test-case
|
||||
"buffer should decode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes #xab #xff #x1f #xb6))])
|
||||
(define buf (+xbuffer #:length 2))
|
||||
(check-equal? (decode buf) (bytes #xab #xff))
|
||||
(check-equal? (decode buf) (bytes #x1f #xb6))))
|
||||
|
||||
(test-case
|
||||
"buffer should error on invalid length"
|
||||
(check-exn exn:fail:contract? (λ () (+xbuffer #:length #true))))
|
||||
|
||||
; describe 'size', ->
|
||||
; it 'should return size', ->
|
||||
(check-equal? (size (+BufferT 2) (bytes #xab #xff)) 2)
|
||||
(test-case
|
||||
"buffer should decode with post-decode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes #xab #xff #x1f #xb6))])
|
||||
(define buf (+xbuffer #:length 2))
|
||||
(set-post-decode! buf (λ (bs) (bytes 1 2)))
|
||||
(check-equal? (decode buf) (bytes 1 2))
|
||||
(check-equal? (decode buf) (bytes 1 2))))
|
||||
|
||||
(test-case
|
||||
"buffer should decode with parent key length"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes #xab #xff #x1f #xb6))])
|
||||
(define buf (+xbuffer #:length 'len))
|
||||
(check-equal? (decode buf #:parent (hash 'len 3)) (bytes #xab #xff #x1f))
|
||||
(check-equal? (decode buf #:parent (hash 'len 1)) (bytes #xb6))))
|
||||
|
||||
; it 'should use defined length if no value given', ->x
|
||||
(check-equal? (size (+BufferT 10)) 10)
|
||||
(test-case
|
||||
"size should return size"
|
||||
(check-equal? (size (+xbuffer #:length 2) (bytes #xab #xff)) 2))
|
||||
|
||||
(test-case
|
||||
"size should use defined length if no value given"
|
||||
(check-equal? (size (+xbuffer #:length 10)) 10))
|
||||
|
||||
; describe 'encode', ->
|
||||
; it 'should encode', (done) ->
|
||||
(let ([buf (+BufferT 2)])
|
||||
(check-equal? (bytes-append
|
||||
(encode buf (bytes #xab #xff) #f)
|
||||
(encode buf (bytes #x1f #xb6) #f)) (bytes #xab #xff #x1f #xb6)))
|
||||
(test-case
|
||||
"encode should encode"
|
||||
(let ([buf (+xbuffer 2)])
|
||||
(check-equal? (bytes-append
|
||||
(encode buf (bytes #xab #xff) #f)
|
||||
(encode buf (bytes #x1f #xb6) #f)) (bytes #xab #xff #x1f #xb6))))
|
||||
|
||||
(test-case
|
||||
"encode should encode with pre-encode"
|
||||
(let ([buf (+xbuffer 2)])
|
||||
(set-pre-encode! buf (λ (bs) (bytes 1 2)))
|
||||
(check-equal? (bytes-append
|
||||
(encode buf (bytes #xab #xff) #f)
|
||||
(encode buf (bytes #x1f #xb6) #f)) (bytes 1 2 1 2))))
|
||||
|
||||
; it 'should encode length before buffer', (done) ->
|
||||
(check-equal? (encode (+BufferT uint8) (bytes #xab #xff) #f) (bytes 2 #xab #xff))
|
||||
(test-case
|
||||
"encode should encode length before buffer"
|
||||
(check-equal? (encode (+xbuffer #:length uint8) (bytes #xab #xff) #f) (bytes 2 #xab #xff)))
|
||||
@ -1,37 +1,64 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
sugar/unstable/dict)
|
||||
sugar/unstable/dict
|
||||
"../helper.rkt"
|
||||
"../number.rkt"
|
||||
"../enum.rkt")
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Enum.coffee
|
||||
|#
|
||||
|
||||
;describe 'Enum', ->
|
||||
; e = new Enum uint8, ['foo', 'bar', 'baz']
|
||||
; it 'should have the right size', ->
|
||||
; e.size().should.equal 1
|
||||
(define e (+xenum #:type uint8
|
||||
#:values '("foo" "bar" "baz")))
|
||||
|
||||
(define e (+Enum uint8 '("foo" "bar" "baz")))
|
||||
(check-equal? (size e) 1)
|
||||
(test-case
|
||||
"should error with invalid type"
|
||||
(check-exn exn:fail:contract? (λ () (+xenum 42))))
|
||||
|
||||
(test-case
|
||||
"should error with invalid values"
|
||||
(check-exn exn:fail:contract? (λ () (+xenum #:values 42))))
|
||||
|
||||
; it 'should decode', ->
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 0))])
|
||||
(check-equal? (decode e) "bar")
|
||||
(check-equal? (decode e) "baz")
|
||||
(check-equal? (decode e) "foo"))
|
||||
(test-case
|
||||
"should have the right size"
|
||||
(check-equal? (size e) 1))
|
||||
|
||||
(test-case
|
||||
"decode should decode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 0))])
|
||||
(check-equal? (decode e) "bar")
|
||||
(check-equal? (decode e) "baz")
|
||||
(check-equal? (decode e) "foo")))
|
||||
|
||||
; it 'should encode', (done) ->
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode e "bar")
|
||||
(encode e "baz")
|
||||
(encode e "foo")
|
||||
(check-equal? (dump (current-output-port)) (bytes 1 2 0)))
|
||||
(test-case
|
||||
"decode should decode with post-decode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 0))])
|
||||
(set-post-decode! e (λ (val) "foobar"))
|
||||
(check-equal? (decode e) "foobar")
|
||||
(check-equal? (decode e) "foobar")
|
||||
(check-equal? (decode e) "foobar")))
|
||||
|
||||
(test-case
|
||||
"encode should encode"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode e "bar")
|
||||
(encode e "baz")
|
||||
(encode e "foo")
|
||||
(check-equal? (dump (current-output-port)) (bytes 1 2 0))))
|
||||
|
||||
; it 'should throw on unknown option', ->
|
||||
(test-case
|
||||
"encode should encode with pre-encode"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(set-pre-encode! e (λ (val) "foo"))
|
||||
(encode e "bar")
|
||||
(encode e "baz")
|
||||
(encode e "foo")
|
||||
(check-equal? (dump (current-output-port)) (bytes 0 0 0))))
|
||||
|
||||
(check-exn exn:fail:contract? (λ () (encode e "unknown" (open-output-bytes))))
|
||||
(test-case
|
||||
"should throw on unknown option"
|
||||
(set-pre-encode! e values)
|
||||
(set-post-decode! e values)
|
||||
(check-exn exn:fail:contract? (λ () (encode e "unknown" (open-output-bytes)))))
|
||||
@ -1,339 +1,209 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
racket/class
|
||||
sugar/unstable/dict)
|
||||
|
||||
(require rackunit "../number.rkt" "../helper.rkt")
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Number.coffee
|
||||
|#
|
||||
|
||||
;describe 'Number', ->
|
||||
; describe 'uint8', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes #xab #xff))])
|
||||
(check-equal? (decode uint8) #xab)
|
||||
(check-equal? (decode uint8) #xff))
|
||||
|
||||
(check-equal? (size uint8) 1)
|
||||
|
||||
(let ([port (open-output-bytes)])
|
||||
(encode uint8 #xab port)
|
||||
(encode uint8 #xff port)
|
||||
(check-equal? (dump port) (bytes #xab #xff)))
|
||||
|
||||
|
||||
; describe 'uint16', ->
|
||||
; it 'is an alias for uint16be', ->
|
||||
; modified test: `uint16` is the same endianness as the platform
|
||||
(check-equal? (decode uint16 (bytes 0 1)) (send (if (system-big-endian?)
|
||||
uint16be
|
||||
uint16le) decode (bytes 0 1)))
|
||||
|
||||
; describe 'uint16be', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode uint16be (open-input-bytes (bytes #xab #xff))) #xabff)
|
||||
(check-equal? (size uint16be) 2)
|
||||
(check-equal? (encode uint16be #xabff #f) (bytes #xab #xff))
|
||||
|
||||
;
|
||||
; describe 'uint16le', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode uint16le (open-input-bytes (bytes #xff #xab))) #xabff)
|
||||
(check-equal? (size uint16le) 2)
|
||||
(check-equal? (encode uint16le #xabff #f) (bytes #xff #xab))
|
||||
|
||||
;
|
||||
; describe 'uint24', ->
|
||||
; it 'is an alias for uint24be', ->
|
||||
;; modified test: `uint24` is the same endianness as the platform
|
||||
(check-equal? (decode uint24 (bytes 0 1 2)) (send (if (system-big-endian?)
|
||||
uint24be
|
||||
uint24le) decode (bytes 0 1 2)))
|
||||
|
||||
;
|
||||
; describe 'uint24be', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode uint24be (open-input-bytes (bytes #xff #xab #x24))) #xffab24)
|
||||
(check-equal? (size uint24be) 3)
|
||||
(check-equal? (encode uint24be #xffab24 #f) (bytes #xff #xab #x24))
|
||||
|
||||
;
|
||||
; describe 'uint24le', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode uint24le (open-input-bytes (bytes #x24 #xab #xff))) #xffab24)
|
||||
(check-equal? (size uint24le) 3)
|
||||
(check-equal? (encode uint24le #xffab24 #f) (bytes #x24 #xab #xff))
|
||||
|
||||
;
|
||||
; describe 'uint32', ->
|
||||
; it 'is an alias for uint32be', ->
|
||||
;; modified test: `uint32` is the same endianness as the platform
|
||||
(check-equal? (decode uint32 (bytes 0 1 2 3)) (send (if (system-big-endian?)
|
||||
uint32be
|
||||
uint32le) decode (bytes 0 1 2 3)))
|
||||
|
||||
;
|
||||
; describe 'uint32be', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode uint32be (open-input-bytes (bytes #xff #xab #x24 #xbf))) #xffab24bf)
|
||||
(check-equal? (size uint32be) 4)
|
||||
(check-equal? (encode uint32be #xffab24bf #f) (bytes #xff #xab #x24 #xbf))
|
||||
|
||||
;
|
||||
; describe 'uint32le', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode uint32le (open-input-bytes (bytes #xbf #x24 #xab #xff))) #xffab24bf)
|
||||
(check-equal? (size uint32le) 4)
|
||||
(check-equal? (encode uint32le #xffab24bf #f) (bytes #xbf #x24 #xab #xff))
|
||||
|
||||
|
||||
;
|
||||
; describe 'int8', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(let ([port (open-input-bytes (bytes #x7f #xff))])
|
||||
(check-equal? (decode int8 port) 127)
|
||||
(check-equal? (decode int8 port) -1))
|
||||
|
||||
(check-equal? (size int8) 1)
|
||||
|
||||
(let ([port (open-output-bytes)])
|
||||
(encode int8 127 port)
|
||||
(encode int8 -1 port)
|
||||
(check-equal? (dump port) (bytes #x7f #xff)))
|
||||
|
||||
|
||||
;
|
||||
; describe 'int16', ->
|
||||
; it 'is an alias for int16be', ->
|
||||
; int16.should.equal int16be
|
||||
|
||||
;; modified test: `int16` is the same endianness as the platform
|
||||
(check-equal? (decode int16 (bytes 0 1)) (send (if (system-big-endian?)
|
||||
int16be
|
||||
int16le) decode (bytes 0 1)))
|
||||
|
||||
|
||||
;
|
||||
; describe 'int16be', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(let ([port (open-input-bytes (bytes #xff #xab))])
|
||||
(check-equal? (decode int16be port) -85))
|
||||
|
||||
(check-equal? (size int16be) 2)
|
||||
|
||||
(let ([port (open-output-bytes)])
|
||||
(encode int16be -85 port)
|
||||
(check-equal? (dump port) (bytes #xff #xab)))
|
||||
|
||||
|
||||
; describe 'int16le', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode int16le (open-input-bytes (bytes #xab #xff))) -85)
|
||||
(check-equal? (size int16le) 2)
|
||||
(check-equal? (encode int16le -85 #f) (bytes #xab #xff))
|
||||
|
||||
|
||||
;
|
||||
; describe 'int24', ->
|
||||
; it 'is an alias for int24be', ->
|
||||
; int24.should.equal int24be
|
||||
|
||||
;; modified test: `int24` is the same endianness as the platform
|
||||
(check-equal? (decode int24 (bytes 0 1 2)) (send (if (system-big-endian?)
|
||||
int24be
|
||||
int24le) decode (bytes 0 1 2)))
|
||||
|
||||
|
||||
;
|
||||
; describe 'int24be', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode int24be (open-input-bytes (bytes #xff #xab #x24))) -21724)
|
||||
(check-equal? (size int24be) 3)
|
||||
(check-equal? (encode int24be -21724 #f) (bytes #xff #xab #x24))
|
||||
|
||||
;
|
||||
; describe 'int24le', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode int24le (open-input-bytes (bytes #x24 #xab #xff))) -21724)
|
||||
(check-equal? (size int24le) 3)
|
||||
(check-equal? (encode int24le -21724 #f) (bytes #x24 #xab #xff))
|
||||
|
||||
|
||||
|
||||
; describe 'int32', ->
|
||||
; it 'is an alias for int32be', ->
|
||||
; modified test: `int32` is the same endianness as the platform
|
||||
(check-equal? (decode int32 (bytes 0 1 2 3)) (send (if (system-big-endian?)
|
||||
int32be
|
||||
int32le) decode (bytes 0 1 2 3)))
|
||||
|
||||
|
||||
|
||||
;
|
||||
; describe 'int32be', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode int32be (open-input-bytes (bytes #xff #xab #x24 #xbf))) -5561153)
|
||||
(check-equal? (size int32be) 4)
|
||||
(check-equal? (encode int32be -5561153 #f) (bytes #xff #xab #x24 #xbf))
|
||||
|
||||
;
|
||||
; describe 'int32le', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode int32le (open-input-bytes (bytes #xbf #x24 #xab #xff))) -5561153)
|
||||
(check-equal? (size int32le) 4)
|
||||
(check-equal? (encode int32le -5561153 #f) (bytes #xbf #x24 #xab #xff))
|
||||
|
||||
;
|
||||
; describe 'float', ->
|
||||
; it 'is an alias for floatbe', ->
|
||||
; modified test: `float` is the same endianness as the platform
|
||||
(check-equal? (decode float (bytes 0 1 2 3)) (send (if (system-big-endian?)
|
||||
floatbe
|
||||
floatle) decode (bytes 0 1 2 3)))
|
||||
|
||||
;
|
||||
; describe 'floatbe', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-= (decode floatbe (open-input-bytes (bytes #x43 #x7a #x8c #xcd))) 250.55 0.01)
|
||||
(check-equal? (size floatbe) 4)
|
||||
(check-equal? (encode floatbe 250.55 #f) (bytes #x43 #x7a #x8c #xcd))
|
||||
|
||||
;
|
||||
; describe 'floatle', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-= (decode floatle (open-input-bytes (bytes #xcd #x8c #x7a #x43))) 250.55 0.01)
|
||||
(check-equal? (size floatle) 4)
|
||||
(check-equal? (encode floatle 250.55 #f) (bytes #xcd #x8c #x7a #x43))
|
||||
|
||||
;
|
||||
; describe 'double', ->
|
||||
; it 'is an alias for doublebe', ->
|
||||
; modified test: `double` is the same endianness as the platform
|
||||
(check-equal? (decode double (bytes 0 1 2 3 4 5 6 7)) (send (if (system-big-endian?)
|
||||
doublebe
|
||||
doublele) decode (bytes 0 1 2 3 4 5 6 7)))
|
||||
|
||||
;
|
||||
; describe 'doublebe', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode doublebe (open-input-bytes (bytes #x40 #x93 #x4a #x3d #x70 #xa3 #xd7 #x0a))) 1234.56)
|
||||
(check-equal? (size doublebe) 8)
|
||||
(check-equal? (encode doublebe 1234.56 #f) (bytes #x40 #x93 #x4a #x3d #x70 #xa3 #xd7 #x0a))
|
||||
|
||||
;
|
||||
; describe 'doublele', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode doublele (open-input-bytes (bytes #x0a #xd7 #xa3 #x70 #x3d #x4a #x93 #x40))) 1234.56)
|
||||
(check-equal? (size doublele) 8)
|
||||
(check-equal? (encode doublele 1234.56 #f) (bytes #x0a #xd7 #xa3 #x70 #x3d #x4a #x93 #x40))
|
||||
|
||||
;
|
||||
; describe 'fixed16', ->
|
||||
; it 'is an alias for fixed16be', ->
|
||||
; modified test: `fixed16` is the same endianness as the platform
|
||||
(check-equal? (decode fixed16 (bytes 0 1)) (send (if (system-big-endian?)
|
||||
fixed16be
|
||||
fixed16le) decode (bytes 0 1)))
|
||||
|
||||
;
|
||||
; describe 'fixed16be', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-= (decode fixed16be (open-input-bytes (bytes #x19 #x57))) 25.34 0.01)
|
||||
(check-equal? (size fixed16be) 2)
|
||||
(check-equal? (encode fixed16be 25.34 #f) (bytes #x19 #x57))
|
||||
|
||||
;
|
||||
; describe 'fixed16le', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-= (decode fixed16le (open-input-bytes (bytes #x57 #x19))) 25.34 0.01)
|
||||
(check-equal? (size fixed16le) 2)
|
||||
(check-equal? (encode fixed16le 25.34 #f) (bytes #x57 #x19))
|
||||
|
||||
;
|
||||
; describe 'fixed32', ->
|
||||
; it 'is an alias for fixed32be', ->
|
||||
; modified test: `fixed32` is the same endianness as the platform
|
||||
|
||||
(check-equal? (decode fixed32 (bytes 0 1 2 3)) (send (if (system-big-endian?)
|
||||
fixed32be
|
||||
fixed32le) decode (bytes 0 1 2 3)))
|
||||
|
||||
;
|
||||
; describe 'fixed32be', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
(check-= (decode fixed32be (open-input-bytes (bytes #x00 #xfa #x8c #xcc))) 250.55 0.01)
|
||||
(check-equal? (size fixed32be) 4)
|
||||
(check-equal? (encode fixed32be 250.55 #f) (bytes #x00 #xfa #x8c #xcc))
|
||||
|
||||
;
|
||||
; describe 'fixed32le', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-= (decode fixed32le (open-input-bytes (bytes #xcc #x8c #xfa #x00))) 250.55 0.01)
|
||||
(check-equal? (size fixed32le) 4)
|
||||
(check-equal? (encode fixed32le 250.55 #f) (bytes #xcc #x8c #xfa #x00))
|
||||
(test-case
|
||||
"uint8: decode, size, encode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes #xab #xff))])
|
||||
(check-equal? (decode uint8) #xab)
|
||||
(check-equal? (decode uint8) #xff))
|
||||
(check-equal? (size uint8) 1)
|
||||
(let ([port (open-output-bytes)])
|
||||
(encode uint8 #xab port)
|
||||
(encode uint8 #xff port)
|
||||
(check-equal? (dump port) (bytes #xab #xff))))
|
||||
|
||||
(test-case
|
||||
"uint8: decode with post-decode, size, encode with pre-encode"
|
||||
(define myuint8 (+xint 1 #:signed #f))
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes #xab #xff))])
|
||||
(set-post-decode! myuint8 (λ (b) #xdeadbeef))
|
||||
(check-equal? (decode myuint8) #xdeadbeef)
|
||||
(check-equal? (decode myuint8) #xdeadbeef))
|
||||
(check-equal? (size myuint8) 1)
|
||||
(let ([port (open-output-bytes)])
|
||||
(set-pre-encode! myuint8 (λ (b) #xcc))
|
||||
(encode myuint8 #xab port)
|
||||
(encode myuint8 #xff port)
|
||||
(check-equal? (dump port) (bytes #xcc #xcc))))
|
||||
|
||||
(test-case
|
||||
"uint16 is the same endianness as the platform"
|
||||
(check-equal? (decode uint16 (bytes 0 1))
|
||||
(decode (if (system-big-endian?) uint16be uint16le) (bytes 0 1))))
|
||||
|
||||
(test-case
|
||||
"uint16be: decode, size, encode"
|
||||
(check-equal? (decode uint16be (open-input-bytes (bytes #xab #xff))) #xabff)
|
||||
(check-equal? (size uint16be) 2)
|
||||
(check-equal? (encode uint16be #xabff #f) (bytes #xab #xff)))
|
||||
|
||||
(test-case
|
||||
"uint16le: decode, size, encode"
|
||||
(check-equal? (decode uint16le (open-input-bytes (bytes #xff #xab))) #xabff)
|
||||
(check-equal? (size uint16le) 2)
|
||||
(check-equal? (encode uint16le #xabff #f) (bytes #xff #xab)))
|
||||
|
||||
(test-case
|
||||
"uint24 is the same endianness as the platform"
|
||||
(check-equal? (decode uint24 (bytes 0 1 2))
|
||||
(decode (if (system-big-endian?) uint24be uint24le) (bytes 0 1 2))))
|
||||
(test-case
|
||||
"uint24be: decode, size, encode"
|
||||
(check-equal? (decode uint24be (open-input-bytes (bytes #xff #xab #x24))) #xffab24)
|
||||
(check-equal? (size uint24be) 3)
|
||||
(check-equal? (encode uint24be #xffab24 #f) (bytes #xff #xab #x24)))
|
||||
|
||||
(test-case
|
||||
"uint24le: decode, size, encode"
|
||||
(check-equal? (decode uint24le (open-input-bytes (bytes #x24 #xab #xff))) #xffab24)
|
||||
(check-equal? (size uint24le) 3)
|
||||
(check-equal? (encode uint24le #xffab24 #f) (bytes #x24 #xab #xff)))
|
||||
|
||||
(test-case
|
||||
"uint32 is the same endianness as the platform"
|
||||
(check-equal? (decode uint32 (bytes 0 1 2 3))
|
||||
(decode (if (system-big-endian?) uint32be uint32le) (bytes 0 1 2 3))))
|
||||
(test-case
|
||||
"uint32be: decode, size, encode"
|
||||
(check-equal? (decode uint32be (open-input-bytes (bytes #xff #xab #x24 #xbf))) #xffab24bf)
|
||||
(check-equal? (size uint32be) 4)
|
||||
(check-equal? (encode uint32be #xffab24bf #f) (bytes #xff #xab #x24 #xbf)))
|
||||
|
||||
(test-case
|
||||
"uint32le: decode, size, encode"
|
||||
(check-equal? (decode uint32le (open-input-bytes (bytes #xbf #x24 #xab #xff))) #xffab24bf)
|
||||
(check-equal? (size uint32le) 4)
|
||||
(check-equal? (encode uint32le #xffab24bf #f) (bytes #xbf #x24 #xab #xff)))
|
||||
|
||||
(test-case
|
||||
"int8: decode, size, encode"
|
||||
(let ([port (open-input-bytes (bytes #x7f #xff))])
|
||||
(check-equal? (decode int8 port) 127)
|
||||
(check-equal? (decode int8 port) -1))
|
||||
(check-equal? (size int8) 1)
|
||||
(let ([port (open-output-bytes)])
|
||||
(encode int8 127 port)
|
||||
(encode int8 -1 port)
|
||||
(check-equal? (dump port) (bytes #x7f #xff))))
|
||||
|
||||
(test-case
|
||||
"int32 is the same endianness as the platform"
|
||||
(check-equal? (decode int16 (bytes 0 1))
|
||||
(decode (if (system-big-endian?) int16be int16le) (bytes 0 1))))
|
||||
(test-case
|
||||
"int16be: decode, size, encode"
|
||||
(let ([port (open-input-bytes (bytes #xff #xab))])
|
||||
(check-equal? (decode int16be port) -85))
|
||||
(check-equal? (size int16be) 2)
|
||||
(let ([port (open-output-bytes)])
|
||||
(encode int16be -85 port)
|
||||
(check-equal? (dump port) (bytes #xff #xab))))
|
||||
|
||||
(test-case
|
||||
"int16le: decode, size, encode"
|
||||
(check-equal? (decode int16le (open-input-bytes (bytes #xab #xff))) -85)
|
||||
(check-equal? (size int16le) 2)
|
||||
(check-equal? (encode int16le -85 #f) (bytes #xab #xff)))
|
||||
|
||||
(test-case
|
||||
"int24 is the same endianness as the platform"
|
||||
(check-equal? (decode int24 (bytes 0 1 2))
|
||||
(decode (if (system-big-endian?) int24be int24le) (bytes 0 1 2))))
|
||||
(test-case
|
||||
"int24be: decode, size, encode"
|
||||
(check-equal? (decode int24be (open-input-bytes (bytes #xff #xab #x24))) -21724)
|
||||
(check-equal? (size int24be) 3)
|
||||
(check-equal? (encode int24be -21724 #f) (bytes #xff #xab #x24)))
|
||||
|
||||
(test-case
|
||||
"int24le: decode, size, encode"
|
||||
(check-equal? (decode int24le (open-input-bytes (bytes #x24 #xab #xff))) -21724)
|
||||
(check-equal? (size int24le) 3)
|
||||
(check-equal? (encode int24le -21724 #f) (bytes #x24 #xab #xff)))
|
||||
(test-case
|
||||
"int32 is the same endianness as the platform"
|
||||
(check-equal? (decode int32 (bytes 0 1 2 3))
|
||||
(decode (if (system-big-endian?) int32be int32le) (bytes 0 1 2 3))))
|
||||
|
||||
(test-case
|
||||
"int32be: decode, size, encode"
|
||||
(check-equal? (decode int32be (open-input-bytes (bytes #xff #xab #x24 #xbf))) -5561153)
|
||||
(check-equal? (size int32be) 4)
|
||||
(check-equal? (encode int32be -5561153 #f) (bytes #xff #xab #x24 #xbf)))
|
||||
|
||||
(test-case
|
||||
"int32le: decode, size, encode"
|
||||
(check-equal? (decode int32le (open-input-bytes (bytes #xbf #x24 #xab #xff))) -5561153)
|
||||
(check-equal? (size int32le) 4)
|
||||
(check-equal? (encode int32le -5561153 #f) (bytes #xbf #x24 #xab #xff)))
|
||||
|
||||
(test-case
|
||||
"float is the same endianness as the platform"
|
||||
(check-equal? (decode float (bytes 0 1 2 3))
|
||||
(decode (if (system-big-endian?) floatbe floatle) (bytes 0 1 2 3))))
|
||||
(test-case
|
||||
"floatbe: decode, size, encode"
|
||||
(check-= (decode floatbe (open-input-bytes (bytes #x43 #x7a #x8c #xcd))) 250.55 0.01)
|
||||
(check-equal? (size floatbe) 4)
|
||||
(check-equal? (encode floatbe 250.55 #f) (bytes #x43 #x7a #x8c #xcd)))
|
||||
|
||||
(test-case
|
||||
"floatle: decode, size, encode"
|
||||
(check-= (decode floatle (open-input-bytes (bytes #xcd #x8c #x7a #x43))) 250.55 0.01)
|
||||
(check-equal? (size floatle) 4)
|
||||
(check-equal? (encode floatle 250.55 #f) (bytes #xcd #x8c #x7a #x43)))
|
||||
|
||||
(test-case
|
||||
"double is the same endianness as the platform"
|
||||
(check-equal? (decode double (bytes 0 1 2 3 4 5 6 7))
|
||||
(decode (if (system-big-endian?) doublebe doublele) (bytes 0 1 2 3 4 5 6 7))))
|
||||
(test-case
|
||||
"doublebe: decode, size, encode"
|
||||
(check-equal? (decode doublebe (open-input-bytes (bytes #x40 #x93 #x4a #x3d #x70 #xa3 #xd7 #x0a))) 1234.56)
|
||||
(check-equal? (size doublebe) 8)
|
||||
(check-equal? (encode doublebe 1234.56 #f) (bytes #x40 #x93 #x4a #x3d #x70 #xa3 #xd7 #x0a)))
|
||||
|
||||
(test-case
|
||||
"doublele: decode, size, encode"
|
||||
(check-equal? (decode doublele (open-input-bytes (bytes #x0a #xd7 #xa3 #x70 #x3d #x4a #x93 #x40))) 1234.56)
|
||||
(check-equal? (size doublele) 8)
|
||||
(check-equal? (encode doublele 1234.56 #f) (bytes #x0a #xd7 #xa3 #x70 #x3d #x4a #x93 #x40)))
|
||||
|
||||
(test-case
|
||||
"fixed16 is the same endianness as the platform"
|
||||
(check-equal? (decode fixed16 (bytes 0 1))
|
||||
(decode (if (system-big-endian?) fixed16be fixed16le) (bytes 0 1))))
|
||||
|
||||
(test-case
|
||||
"fixed16be: decode, size, encode"
|
||||
(check-= (decode fixed16be (open-input-bytes (bytes #x19 #x57))) 25.34 0.01)
|
||||
(check-equal? (size fixed16be) 2)
|
||||
(check-equal? (encode fixed16be 25.34 #f) (bytes #x19 #x57)))
|
||||
|
||||
(test-case
|
||||
"fixed16le: decode, size, encode"
|
||||
(check-= (decode fixed16le (open-input-bytes (bytes #x57 #x19))) 25.34 0.01)
|
||||
(check-equal? (size fixed16le) 2)
|
||||
(check-equal? (encode fixed16le 25.34 #f) (bytes #x57 #x19)))
|
||||
|
||||
(test-case
|
||||
"fixed32 is the same endianness as the platform"
|
||||
(check-equal? (decode fixed32 (bytes 0 1 2 3))
|
||||
(decode (if (system-big-endian?) fixed32be fixed32le) (bytes 0 1 2 3))))
|
||||
|
||||
(test-case
|
||||
"fixed32be: decode, size, encode"
|
||||
(check-= (decode fixed32be (open-input-bytes (bytes #x00 #xfa #x8c #xcc))) 250.55 0.01)
|
||||
(check-equal? (size fixed32be) 4)
|
||||
(check-equal? (encode fixed32be 250.55 #f) (bytes #x00 #xfa #x8c #xcc)))
|
||||
|
||||
(test-case
|
||||
"fixed32le: decode, size, encode"
|
||||
(check-= (decode fixed32le (open-input-bytes (bytes #xcc #x8c #xfa #x00))) 250.55 0.01)
|
||||
(check-equal? (size fixed32le) 4)
|
||||
(check-equal? (encode fixed32le 250.55 #f) (bytes #xcc #x8c #xfa #x00)))
|
||||
@ -1,116 +1,116 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
sugar/unstable/dict)
|
||||
"../helper.rkt"
|
||||
"../number.rkt"
|
||||
"../optional.rkt")
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Optional.coffee
|
||||
|#
|
||||
|
||||
;describe 'Optional', ->
|
||||
; describe 'decode', ->
|
||||
; it 'should not decode when condition is falsy', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+Optional uint8 #f))
|
||||
(check-equal? (decode optional) (void))
|
||||
(check-equal? (pos (current-input-port)) 0))
|
||||
|
||||
; it 'should not decode when condition is a function and falsy', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+Optional uint8 (λ _ #f)))
|
||||
(check-equal? (decode optional) (void))
|
||||
(check-equal? (pos (current-input-port)) 0))
|
||||
|
||||
|
||||
; it 'should decode when condition is omitted', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+Optional uint8))
|
||||
(check-not-equal? (decode optional) (void))
|
||||
(check-equal? (pos (current-input-port)) 1))
|
||||
|
||||
;
|
||||
; it 'should decode when condition is truthy', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+Optional uint8 #t))
|
||||
(check-not-equal? (decode optional) (void))
|
||||
(check-equal? (pos (current-input-port)) 1))
|
||||
|
||||
|
||||
; it 'should decode when condition is a function and truthy', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+Optional uint8 (λ _ #t)))
|
||||
(check-not-equal? (decode optional) (void))
|
||||
(check-equal? (pos (current-input-port)) 1))
|
||||
|
||||
|
||||
; describe 'size', ->
|
||||
|
||||
(check-equal? (size (+Optional uint8 #f)) 0)
|
||||
|
||||
;
|
||||
; it 'should return 0 when condition is a function and falsy', ->
|
||||
|
||||
(check-equal? (size (+Optional uint8 (λ _ #f))) 0)
|
||||
|
||||
|
||||
; it 'should return given type size when condition is omitted', ->
|
||||
|
||||
(check-equal? (size (+Optional uint8)) 1)
|
||||
|
||||
|
||||
; it 'should return given type size when condition is truthy', ->
|
||||
|
||||
(check-equal? (size (+Optional uint8 #t)) 1)
|
||||
|
||||
|
||||
; it 'should return given type size when condition is a function and truthy', ->
|
||||
|
||||
(check-equal? (size (+Optional uint8 (λ _ #t))) 1)
|
||||
|
||||
|
||||
; describe 'encode', ->
|
||||
; it 'should not encode when condition is falsy', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+Optional uint8 #f))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes)))
|
||||
|
||||
|
||||
; it 'should not encode when condition is a function and falsy', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+Optional uint8 (λ _ #f)))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes)))
|
||||
|
||||
|
||||
;
|
||||
; it 'should encode when condition is omitted', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+Optional uint8))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes 128)))
|
||||
|
||||
|
||||
; it 'should encode when condition is truthy', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+Optional uint8 #t))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes 128)))
|
||||
|
||||
|
||||
; it 'should encode when condition is a function and truthy', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+Optional uint8 (λ _ #t)))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes 128)))
|
||||
(test-case
|
||||
"decode should not decode when condition is falsy"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+xoptional #:type uint8 #:condition #f))
|
||||
(check-equal? (decode optional) (void))
|
||||
(check-equal? (pos (current-input-port)) 0)))
|
||||
|
||||
(test-case
|
||||
"decode with post-decode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+xoptional #:type uint8 #:condition #f))
|
||||
(set-post-decode! optional (λ (val) 42))
|
||||
(check-equal? (decode optional) 42)
|
||||
(check-equal? (pos (current-input-port)) 0)))
|
||||
|
||||
(test-case
|
||||
"decode should not decode when condition is a function and falsy"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+xoptional #:type uint8 #:condition (λ _ #f)))
|
||||
(check-equal? (decode optional) (void))
|
||||
(check-equal? (pos (current-input-port)) 0)))
|
||||
|
||||
(test-case
|
||||
"decode should decode when condition is omitted"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+xoptional #:type uint8))
|
||||
(check-not-equal? (decode optional) (void))
|
||||
(check-equal? (pos (current-input-port)) 1)))
|
||||
|
||||
(test-case
|
||||
"decode should decode when condition is truthy"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+xoptional #:type uint8 #:condition #t))
|
||||
(check-not-equal? (decode optional) (void))
|
||||
(check-equal? (pos (current-input-port)) 1)))
|
||||
|
||||
(test-case
|
||||
"decode should decode when condition is a function and truthy"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+xoptional #:type uint8 #:condition (λ _ #t)))
|
||||
(check-not-equal? (decode optional) (void))
|
||||
(check-equal? (pos (current-input-port)) 1)))
|
||||
|
||||
(test-case
|
||||
"size"
|
||||
(check-equal? (size (+xoptional #:type uint8 #:condition #f)) 0))
|
||||
|
||||
(test-case
|
||||
"size should return 0 when condition is a function and falsy"
|
||||
(check-equal? (size (+xoptional #:type uint8 #:condition (λ _ #f))) 0))
|
||||
|
||||
(test-case
|
||||
"size should return given type size when condition is omitted"
|
||||
(check-equal? (size (+xoptional #:type uint8)) 1))
|
||||
|
||||
(test-case
|
||||
"size should return given type size when condition is truthy"
|
||||
(check-equal? (size (+xoptional #:type uint8 #:condition #t)) 1))
|
||||
|
||||
(test-case
|
||||
"size should return given type size when condition is a function and truthy"
|
||||
(check-equal? (size (+xoptional #:type uint8 #:condition (λ _ #t))) 1))
|
||||
|
||||
(test-case
|
||||
"encode should not encode when condition is falsy"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+xoptional #:type uint8 #:condition #f))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes))))
|
||||
|
||||
(test-case
|
||||
"encode with pre-encode"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+xoptional #:type uint8))
|
||||
(set-pre-encode! optional (λ (val) 42))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes 42))))
|
||||
|
||||
(test-case
|
||||
"encode should not encode when condition is a function and falsy"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+xoptional #:type uint8 #:condition (λ _ #f)))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes))))
|
||||
|
||||
(test-case
|
||||
"encode should encode when condition is omitted"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+xoptional #:type uint8))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes 128))))
|
||||
|
||||
(test-case
|
||||
"encode should encode when condition is truthy"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+xoptional #:type uint8 #:condition #t))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes 128))))
|
||||
|
||||
(test-case
|
||||
"encode should encode when condition is a function and truthy"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+xoptional #:type uint8 #:condition (λ _ #t)))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes 128))))
|
||||
@ -1,239 +1,211 @@
|
||||
#lang racket/base
|
||||
#lang debug racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
sugar/unstable/js
|
||||
sugar/unstable/dict
|
||||
racket/class
|
||||
"../private/helper.rkt")
|
||||
racket/dict
|
||||
"../helper.rkt"
|
||||
"../pointer.rkt"
|
||||
"../number.rkt"
|
||||
"../struct.rkt"
|
||||
racket/promise
|
||||
sugar/unstable/dict)
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
|
||||
|#
|
||||
|
||||
|
||||
;describe 'Pointer', ->
|
||||
; describe 'decode', ->
|
||||
; it 'should handle null pointers', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(check-false (decode (+Pointer uint8 uint8) #:parent (mhash '_startOffset 50))))
|
||||
|
||||
|
||||
; it 'should use local offsets from start of parent by default', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 53))])
|
||||
(check-equal? (decode (+Pointer uint8 uint8) #:parent (mhash '_startOffset 0)) 53))
|
||||
|
||||
|
||||
; it 'should support immediate offsets', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 53))])
|
||||
(check-equal? (decode (+Pointer uint8 uint8 (mhash 'type 'immediate))) 53))
|
||||
|
||||
|
||||
; it 'should support offsets relative to the parent', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0 0 1 53))])
|
||||
(pos (current-input-port) 2)
|
||||
(check-equal? (decode (+Pointer uint8 uint8 (mhash 'type 'parent))
|
||||
#:parent (mhash 'parent (mhash '_startOffset 2))) 53))
|
||||
|
||||
|
||||
; it 'should support global offsets', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 4 0 0 0 53))])
|
||||
(pos (current-input-port) 2)
|
||||
(check-equal? (decode (+Pointer uint8 uint8 (mhash 'type 'global))
|
||||
#:parent (mhash 'parent (mhash 'parent (mhash '_startOffset 2))))
|
||||
53))
|
||||
|
||||
|
||||
; it 'should support offsets relative to a property on the parent', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 0 0 0 0 53))])
|
||||
(check-equal? (decode (+Pointer uint8 uint8 (mhash 'relativeTo (λ (ctx) (· ctx parent ptr))))
|
||||
#:parent (mhash '_startOffset 0 'parent (mhash 'ptr 4)))
|
||||
53))
|
||||
|
||||
|
||||
; it 'should support returning pointer if there is no decode type', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 4))])
|
||||
(check-equal? (decode (+Pointer uint8 'void)
|
||||
#:parent (mhash '_startOffset 0)) 4))
|
||||
|
||||
|
||||
; it 'should support decoding pointers lazily', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 53))])
|
||||
(define res (decode (+Struct (dictify 'ptr (+Pointer uint8 uint8 (mhasheq 'lazy #t))))))
|
||||
(check-true (LazyThunk? (hash-ref (get-field _kv res) 'ptr)))
|
||||
(check-equal? (· res ptr) 53))
|
||||
|
||||
|
||||
|
||||
; describe 'size', ->
|
||||
|
||||
(let ([ctx (mhash 'pointerSize 0)])
|
||||
(check-equal? (size (+Pointer uint8 uint8) 10 ctx) 1)
|
||||
(check-equal? (· ctx pointerSize) 1))
|
||||
|
||||
|
||||
|
||||
; it 'should add to immediate pointerSize', ->
|
||||
|
||||
(let ([ctx (mhash 'pointerSize 0)])
|
||||
(check-equal? (size (+Pointer uint8 uint8 (mhash 'type 'immediate)) 10 ctx) 1)
|
||||
(check-equal? (· ctx pointerSize) 1))
|
||||
|
||||
|
||||
; it 'should add to parent pointerSize', ->
|
||||
|
||||
(let ([ctx (mhash 'parent (mhash 'pointerSize 0))])
|
||||
(check-equal? (size (+Pointer uint8 uint8 (mhash 'type 'parent)) 10 ctx) 1)
|
||||
(check-equal? (· ctx parent pointerSize) 1))
|
||||
|
||||
|
||||
|
||||
; it 'should add to global pointerSize', ->
|
||||
|
||||
(let ([ctx (mhash 'parent (mhash 'parent (mhash 'parent (mhash 'pointerSize 0))))])
|
||||
(check-equal? (size (+Pointer uint8 uint8 (mhash 'type 'global)) 10 ctx) 1)
|
||||
(check-equal? (· ctx parent parent parent pointerSize) 1))
|
||||
|
||||
|
||||
|
||||
; it 'should handle void pointers', ->
|
||||
|
||||
(let ([ctx (mhash 'pointerSize 0)])
|
||||
(check-equal? (size (+Pointer uint8 'void) (+VoidPointer uint8 50) ctx) 1)
|
||||
(check-equal? (· ctx pointerSize) 1))
|
||||
|
||||
|
||||
; it 'should throw if no type and not a void pointer', ->
|
||||
|
||||
(let ([ctx (mhash 'pointerSize 0)])
|
||||
(check-exn exn:fail:contract? (λ () (size (+Pointer uint8 'void) 30 ctx))))
|
||||
|
||||
|
||||
; it 'should return a fixed size without a value', ->
|
||||
|
||||
(check-equal? (size (+Pointer uint8 uint8)) 1)
|
||||
|
||||
|
||||
; describe 'encode', ->
|
||||
; it 'should handle null pointers', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define ctx (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 0
|
||||
'pointers null))
|
||||
(encode (+Pointer uint8 uint8) #f #:parent ctx)
|
||||
(check-equal? (· ctx pointerSize) 0)
|
||||
(check-equal? (dump (current-output-port)) (bytes 0)))
|
||||
|
||||
|
||||
; it 'should handle local offsets', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define ctx (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 1
|
||||
'pointers null))
|
||||
(encode (+Pointer uint8 uint8) 10 #:parent ctx)
|
||||
(check-equal? (· ctx pointerOffset) 2)
|
||||
(check-equal? (· ctx pointers) (list (mhasheq 'type uint8
|
||||
'val 10
|
||||
'parent ctx)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 1)))
|
||||
|
||||
|
||||
; it 'should handle immediate offsets', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define ctx (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 1
|
||||
'pointers null))
|
||||
(encode (+Pointer uint8 uint8 (mhash 'type 'immediate)) 10 #:parent ctx)
|
||||
(check-equal? (· ctx pointerOffset) 2)
|
||||
(check-equal? (· ctx pointers) (list (mhasheq 'type uint8
|
||||
'val 10
|
||||
'parent ctx)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 0)))
|
||||
|
||||
|
||||
; it 'should handle offsets relative to parent', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define ctx (mhash 'parent (mhash 'pointerSize 0
|
||||
'startOffset 3
|
||||
'pointerOffset 5
|
||||
'pointers null)))
|
||||
(encode (+Pointer uint8 uint8 (mhash 'type 'parent)) 10 #:parent ctx)
|
||||
(check-equal? (· ctx parent pointerOffset) 6)
|
||||
(check-equal? (· ctx parent pointers) (list (mhasheq 'type uint8
|
||||
'val 10
|
||||
'parent ctx)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 2)))
|
||||
|
||||
|
||||
|
||||
; it 'should handle global offsets', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define ctx (mhash 'parent
|
||||
(mhash 'parent
|
||||
(mhash 'parent (mhash 'pointerSize 0
|
||||
'startOffset 3
|
||||
'pointerOffset 5
|
||||
'pointers null)))))
|
||||
(encode (+Pointer uint8 uint8 (mhash 'type 'global)) 10 #:parent ctx)
|
||||
(check-equal? (· ctx parent parent parent pointerOffset) 6)
|
||||
(check-equal? (· ctx parent parent parent pointers) (list (mhasheq 'type uint8
|
||||
'val 10
|
||||
'parent ctx)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 5)))
|
||||
|
||||
|
||||
; it 'should support offsets relative to a property on the parent', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define ctx (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 10
|
||||
'pointers null
|
||||
'val (mhash 'ptr 4)))
|
||||
(encode (+Pointer uint8 uint8 (mhash 'relativeTo (λ (ctx) (· ctx ptr)))) 10 #:parent ctx)
|
||||
(check-equal? (· ctx pointerOffset) 11)
|
||||
(check-equal? (· ctx pointers) (list (mhasheq 'type uint8
|
||||
'val 10
|
||||
'parent ctx)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 6)))
|
||||
|
||||
|
||||
; it 'should support void pointers', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define ctx (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 1
|
||||
'pointers null))
|
||||
(encode (+Pointer uint8 'void) (+VoidPointer uint8 55) #:parent ctx)
|
||||
(check-equal? (· ctx pointerOffset) 2)
|
||||
(check-equal? (· ctx pointers) (list (mhasheq 'type uint8
|
||||
'val 55
|
||||
'parent ctx)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 1)))
|
||||
|
||||
|
||||
; it 'should throw if not a void pointer instance', ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define ctx (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 1
|
||||
'pointers null))
|
||||
(check-exn exn:fail:contract? (λ () (encode (+Pointer uint8 'void) 44 #:parent ctx))))
|
||||
(test-case
|
||||
"decode should handle null pointers"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(check-false (decode (+xpointer) #:parent (mhash '_startOffset 50)))))
|
||||
|
||||
(test-case
|
||||
"decode should use local offsets from start of parent by default"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 53))])
|
||||
(check-equal? (decode (+xpointer) #:parent (mhash '_startOffset 0)) 53)))
|
||||
|
||||
(test-case
|
||||
"decode should support immediate offsets"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 53))])
|
||||
(check-equal? (decode (+xpointer #:style 'immediate)) 53)))
|
||||
|
||||
(test-case
|
||||
"decode should support offsets relative to the parent"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0 0 1 53))])
|
||||
(pos (current-input-port) 2)
|
||||
(check-equal? (decode (+xpointer #:style 'parent)
|
||||
#:parent (mhash 'parent (mhash '_startOffset 2))) 53)))
|
||||
|
||||
(test-case
|
||||
"decode should support global offsets"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 4 0 0 0 53))])
|
||||
(pos (current-input-port) 2)
|
||||
(check-equal? (decode (+xpointer #:style 'global)
|
||||
#:parent (mhash 'parent (mhash 'parent (mhash '_startOffset 2))))
|
||||
53)))
|
||||
|
||||
(test-case
|
||||
"decode should support offsets relative to a property on the parent"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 0 0 0 0 53))])
|
||||
(check-equal? (decode (+xpointer #:relative-to (λ (parent) (dict-ref (dict-ref parent 'parent) 'ptr)))
|
||||
#:parent (mhash '_startOffset 0 'parent (mhash 'ptr 4)))
|
||||
53)))
|
||||
|
||||
(test-case
|
||||
"decode should support returning pointer if there is no decode type"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 4))])
|
||||
(check-equal? (decode (+xpointer uint8 'void)
|
||||
#:parent (mhash '_startOffset 0)) 4)))
|
||||
|
||||
(test-case
|
||||
"decode should support decoding pointers lazily"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 53))])
|
||||
(define res (decode (+xstruct (dictify 'ptr (+xpointer #:lazy #t)))))
|
||||
(check-true (promise? (dict-ref (struct-dict-res-_kv res) 'ptr)))
|
||||
(check-equal? (dict-ref res 'ptr) 53)))
|
||||
|
||||
(test-case
|
||||
"size"
|
||||
(let ([parent (mhash 'pointerSize 0)])
|
||||
(check-equal? (size (+xpointer) 10 #:parent parent) 1)
|
||||
(check-equal? (dict-ref parent 'pointerSize) 1)))
|
||||
|
||||
(test-case
|
||||
"size should add to immediate pointerSize"
|
||||
(let ([parent (mhash 'pointerSize 0)])
|
||||
(check-equal? (size (+xpointer #:style 'immediate) 10 #:parent parent) 1)
|
||||
(check-equal? (dict-ref parent 'pointerSize) 1)))
|
||||
|
||||
(test-case
|
||||
"size should add to parent pointerSize"
|
||||
(let ([parent (mhash 'parent (mhash 'pointerSize 0))])
|
||||
(check-equal? (size (+xpointer #:style 'parent) 10 #:parent parent) 1)
|
||||
(check-equal? (dict-ref (dict-ref parent 'parent) 'pointerSize) 1)))
|
||||
|
||||
(test-case
|
||||
"size should add to global pointerSize"
|
||||
(let ([parent (mhash 'parent (mhash 'parent (mhash 'parent (mhash 'pointerSize 0))))])
|
||||
(check-equal? (size (+xpointer #:style 'global) 10 #:parent parent) 1)
|
||||
(check-equal? (dict-ref (dict-ref (dict-ref (dict-ref parent 'parent) 'parent) 'parent) 'pointerSize) 1)))
|
||||
|
||||
(test-case
|
||||
"size should handle void pointers"
|
||||
(let ([parent (mhash 'pointerSize 0)])
|
||||
(check-equal? (size (+xpointer uint8 'void) (+xvoid-pointer uint8 50) #:parent parent) 1)
|
||||
(check-equal? (dict-ref parent 'pointerSize) 1)))
|
||||
|
||||
(test-case
|
||||
"size should throw if no type and not a void pointer"
|
||||
(let ([parent (mhash 'pointerSize 0)])
|
||||
(check-exn exn:fail:contract? (λ () (size (+xpointer uint8 'void) 30 #:parent parent)))))
|
||||
|
||||
(test-case
|
||||
"size should return a fixed size without a value"
|
||||
(check-equal? (size (+xpointer)) 1))
|
||||
|
||||
(test-case
|
||||
"encode should handle null pointers"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define parent (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 0
|
||||
'pointers null))
|
||||
(encode (+xpointer) #f #:parent parent)
|
||||
(check-equal? (dict-ref parent 'pointerSize) 0)
|
||||
(check-equal? (dump (current-output-port)) (bytes 0))))
|
||||
|
||||
(test-case
|
||||
"encode should handle local offsets"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define parent (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 1
|
||||
'pointers null))
|
||||
(encode (+xpointer) 10 #:parent parent)
|
||||
(check-equal? (dict-ref parent 'pointerOffset) 2)
|
||||
(check-equal? (dict-ref parent 'pointers) (list (mhasheq 'type uint8
|
||||
'val 10
|
||||
'parent parent)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 1))))
|
||||
|
||||
(test-case
|
||||
"encode should handle immediate offsets"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define parent (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 1
|
||||
'pointers null))
|
||||
(encode (+xpointer #:style 'immediate) 10 #:parent parent)
|
||||
(check-equal? (dict-ref parent 'pointerOffset) 2)
|
||||
(check-equal? (dict-ref parent 'pointers) (list (mhasheq 'type uint8
|
||||
'val 10
|
||||
'parent parent)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 0))))
|
||||
|
||||
(test-case
|
||||
"encode should handle offsets relative to parent"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define parent (mhash 'parent (mhash 'pointerSize 0
|
||||
'startOffset 3
|
||||
'pointerOffset 5
|
||||
'pointers null)))
|
||||
(encode (+xpointer #:style 'parent) 10 #:parent parent)
|
||||
(check-equal? (dict-ref (dict-ref parent 'parent) 'pointerOffset) 6)
|
||||
(check-equal? (dict-ref (dict-ref parent 'parent) 'pointers) (list (mhasheq 'type uint8
|
||||
'val 10
|
||||
'parent parent)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 2))))
|
||||
|
||||
(test-case
|
||||
"encode should handle global offsets"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define parent (mhash 'parent
|
||||
(mhash 'parent
|
||||
(mhash 'parent (mhash 'pointerSize 0
|
||||
'startOffset 3
|
||||
'pointerOffset 5
|
||||
'pointers null)))))
|
||||
(encode (+xpointer #:style 'global) 10 #:parent parent)
|
||||
(check-equal? (dict-ref (dict-ref (dict-ref (dict-ref parent 'parent) 'parent) 'parent) 'pointerOffset) 6)
|
||||
(check-equal? (dict-ref (dict-ref (dict-ref (dict-ref parent 'parent) 'parent) 'parent) 'pointers)
|
||||
(list (mhasheq 'type uint8
|
||||
'val 10
|
||||
'parent parent)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 5))))
|
||||
|
||||
(test-case
|
||||
"encode should support offsets relative to a property on the parent"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define parent (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 10
|
||||
'pointers null
|
||||
'val (mhash 'ptr 4)))
|
||||
(encode (+xpointer #:relative-to (λ (parent) (dict-ref parent 'ptr))) 10 #:parent parent)
|
||||
(check-equal? (dict-ref parent 'pointerOffset) 11)
|
||||
(check-equal? (dict-ref parent 'pointers) (list (mhasheq 'type uint8
|
||||
'val 10
|
||||
'parent parent)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 6))))
|
||||
|
||||
(test-case
|
||||
"encode should support void pointers"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define parent (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 1
|
||||
'pointers null))
|
||||
(encode (+xpointer uint8 'void) (+xvoid-pointer uint8 55) #:parent parent)
|
||||
(check-equal? (dict-ref parent 'pointerOffset) 2)
|
||||
(check-equal? (dict-ref parent 'pointers) (list (mhasheq 'type uint8
|
||||
'val 55
|
||||
'parent parent)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 1))))
|
||||
|
||||
(test-case
|
||||
"encode should throw if not a void pointer instance"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define parent (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 1
|
||||
'pointers null))
|
||||
(check-exn exn:fail:contract? (λ () (encode (+xpointer uint8 'void) 44 #:parent parent)))))
|
||||
|
||||
@ -1,35 +1,48 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
sugar/unstable/dict)
|
||||
"../number.rkt"
|
||||
"../helper.rkt"
|
||||
"../reserved.rkt")
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Reserved.coffee
|
||||
|#
|
||||
|
||||
;describe 'Reserved', ->
|
||||
; it 'should have a default count of 1', ->
|
||||
|
||||
(check-equal? (size (+Reserved uint8)) 1)
|
||||
|
||||
|
||||
; it 'should allow custom counts and types', ->
|
||||
|
||||
(check-equal? (size (+Reserved uint16be 10)) 20)
|
||||
|
||||
|
||||
; it 'should decode', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0 0))])
|
||||
(define reserved (+Reserved uint16be))
|
||||
(check-equal? (decode reserved) (void))
|
||||
(check-equal? (pos (current-input-port)) 2))
|
||||
|
||||
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define reserved (+Reserved uint16be))
|
||||
(encode reserved #f)
|
||||
(check-equal? (dump (current-output-port)) (bytes 0 0)))
|
||||
(test-case
|
||||
"size should have a default count of 1"
|
||||
(check-equal? (size (+xreserved uint8)) 1))
|
||||
|
||||
(test-case
|
||||
"size should allow custom counts and types"
|
||||
(check-equal? (size (+xreserved uint16be 10)) 20))
|
||||
|
||||
(test-case
|
||||
"should decode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0 0))])
|
||||
(define reserved (+xreserved uint16be))
|
||||
(check-equal? (decode reserved) (void))
|
||||
(check-equal? (pos (current-input-port)) 2)))
|
||||
|
||||
(test-case
|
||||
"should decode with post-decode"
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0 0))])
|
||||
(define reserved (+xreserved uint16be))
|
||||
(set-post-decode! reserved (λ (val) 42))
|
||||
(check-equal? (decode reserved) 42)
|
||||
(check-equal? (pos (current-input-port)) 2)))
|
||||
|
||||
(test-case
|
||||
"should encode"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define reserved (+xreserved uint16be))
|
||||
(encode reserved #f)
|
||||
(check-equal? (dump (current-output-port)) (bytes 0 0))))
|
||||
|
||||
(test-case
|
||||
"should encode with pre-encode"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define reserved (+xreserved uint32be))
|
||||
(set-pre-encode! reserved (λ (val) 42))
|
||||
(encode reserved #f)
|
||||
(check-equal? (dump (current-output-port)) (bytes 0 0 0 0))))
|
||||
@ -1,131 +1,124 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
"../helper.rkt"
|
||||
"../string.rkt"
|
||||
"../number.rkt"
|
||||
sugar/unstable/dict)
|
||||
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/String.coffee
|
||||
|#
|
||||
|
||||
;describe 'String', ->
|
||||
; describe 'decode', ->
|
||||
; it 'should decode fixed length', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"testing")])
|
||||
(check-equal? (decode (+StringT 7)) "testing"))
|
||||
|
||||
|
||||
; it 'should decode length from parent key', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"testing")])
|
||||
(check-equal? (decode (+StringT 'len) #:parent (mhash 'len 7)) "testing"))
|
||||
|
||||
|
||||
; it 'should decode length as number before string', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x07testing")])
|
||||
(check-equal? (decode (+StringT uint8) #:parent (mhash 'len 7)) "testing"))
|
||||
|
||||
|
||||
;; it 'should decode utf8', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "🍻"))])
|
||||
(check-equal? (decode (+StringT 4 'utf8)) "🍻"))
|
||||
|
||||
;; it 'should decode encoding computed from function', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "🍻"))])
|
||||
(check-equal? (decode (+StringT 4 (λ _ 'utf8))) "🍻"))
|
||||
|
||||
|
||||
; it 'should decode null-terminated string and read past terminator', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "🍻\x00"))])
|
||||
(check-equal? (decode (+StringT #f 'utf8)) "🍻")
|
||||
(check-equal? (pos (current-input-port)) 5))
|
||||
|
||||
|
||||
; it 'should decode remainder of buffer when null-byte missing', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "🍻"))])
|
||||
(check-equal? (decode (+StringT #f 'utf8)) "🍻"))
|
||||
|
||||
|
||||
; describe 'size', ->
|
||||
; it 'should use string length', ->
|
||||
|
||||
(check-equal? (size (+StringT 7) "testing") 7)
|
||||
|
||||
|
||||
; it 'should use correct encoding', ->
|
||||
|
||||
(check-equal? (size (+StringT 10 'utf8) "🍻") 4)
|
||||
|
||||
|
||||
; it 'should use encoding from function', ->
|
||||
|
||||
(check-equal? (size (+StringT 10 (λ _ 'utf8)) "🍻") 4)
|
||||
|
||||
|
||||
; it 'should add size of length field before string', ->
|
||||
|
||||
(check-equal? (size (+StringT uint8 'utf8) "🍻") 5)
|
||||
|
||||
|
||||
; todo
|
||||
; it 'should work with utf16be encoding', ->
|
||||
|
||||
|
||||
; it 'should take null-byte into account', ->
|
||||
|
||||
(check-equal? (size (+StringT #f 'utf8) "🍻") 5)
|
||||
|
||||
|
||||
; it 'should use defined length if no value given', ->
|
||||
|
||||
(check-equal? (size (+StringT 10)) 10)
|
||||
|
||||
;
|
||||
; describe 'encode', ->
|
||||
; it 'should encode using string length', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+StringT 7) "testing")
|
||||
(check-equal? (dump (current-output-port)) #"testing"))
|
||||
|
||||
|
||||
; it 'should encode length as number before string', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+StringT uint8) "testing")
|
||||
(check-equal? (dump (current-output-port)) #"\x07testing"))
|
||||
|
||||
|
||||
; it 'should encode length as number before string utf8', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+StringT uint8 'utf8) "testing 😜")
|
||||
(check-equal? (dump (current-output-port)) (string->bytes/utf-8 "\x0ctesting 😜")))
|
||||
|
||||
|
||||
; it 'should encode utf8', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+StringT 4 'utf8) "🍻" )
|
||||
(check-equal? (dump (current-output-port)) (string->bytes/utf-8 "🍻")))
|
||||
|
||||
|
||||
; it 'should encode encoding computed from function', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+StringT 4 (λ _ 'utf8)) "🍻")
|
||||
(check-equal? (dump (current-output-port)) (string->bytes/utf-8 "🍻")))
|
||||
|
||||
|
||||
; it 'should encode null-terminated string', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+StringT #f 'utf8) "🍻" )
|
||||
(check-equal? (dump (current-output-port)) (string->bytes/utf-8 "🍻\x00")))
|
||||
(test-case
|
||||
"decode fixed length"
|
||||
(parameterize ([current-input-port (open-input-bytes #"testing")])
|
||||
(check-equal? (decode (+xstring 7)) "testing")))
|
||||
|
||||
(test-case
|
||||
"decode fixed length with post-decode"
|
||||
(parameterize ([current-input-port (open-input-bytes #"testing")])
|
||||
(define xs (+xstring 7))
|
||||
(set-post-decode! xs (λ (val) "ring a ding"))
|
||||
(check-equal? (decode xs) "ring a ding")))
|
||||
|
||||
(test-case
|
||||
"decode length from parent key"
|
||||
(parameterize ([current-input-port (open-input-bytes #"testing")])
|
||||
(check-equal? (decode (+xstring 'len) #:parent (mhash 'len 7)) "testing")))
|
||||
|
||||
(test-case
|
||||
"decode length as number before string"
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x07testing")])
|
||||
(check-equal? (decode (+xstring uint8) #:parent (mhash 'len 7)) "testing")))
|
||||
|
||||
(test-case
|
||||
"decode utf8"
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "🍻"))])
|
||||
(check-equal? (decode (+xstring 4 'utf8)) "🍻")))
|
||||
|
||||
(test-case
|
||||
"decode encoding computed from function"
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "🍻"))])
|
||||
(check-equal? (decode (+xstring 4 (λ _ 'utf8))) "🍻")))
|
||||
|
||||
(test-case
|
||||
"decode null-terminated string and read past terminator"
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "🍻\x00"))])
|
||||
(check-equal? (decode (+xstring #f 'utf8)) "🍻")
|
||||
(check-equal? (pos (current-input-port)) 5)))
|
||||
|
||||
(test-case
|
||||
"decode remainder of buffer when null-byte missing"
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "🍻"))])
|
||||
(check-equal? (decode (+xstring #f 'utf8)) "🍻")))
|
||||
|
||||
(test-case
|
||||
"size should use string length"
|
||||
(check-equal? (size (+xstring 7) "testing") 7))
|
||||
|
||||
(test-case
|
||||
"size should use correct encoding"
|
||||
(check-equal? (size (+xstring 10 'utf8) "🍻") 4))
|
||||
|
||||
(test-case
|
||||
"size should use encoding from function"
|
||||
(check-equal? (size (+xstring 10 (λ _ 'utf8)) "🍻") 4))
|
||||
|
||||
(test-case
|
||||
"should add size of length field before string"
|
||||
(check-equal? (size (+xstring uint8 'utf8) "🍻") 5))
|
||||
|
||||
; todo: it "should work with utf16be encoding"
|
||||
|
||||
(test-case
|
||||
"size should take null-byte into account"
|
||||
(check-equal? (size (+xstring #f 'utf8) "🍻") 5))
|
||||
|
||||
(test-case
|
||||
"size should use defined length if no value given"
|
||||
(check-equal? (size (+xstring 10)) 10))
|
||||
|
||||
(test-case
|
||||
"encode using string length"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+xstring 7) "testing")
|
||||
(check-equal? (dump (current-output-port)) #"testing")))
|
||||
|
||||
(test-case
|
||||
"encode using string length and pre-encode"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define xs (+xstring 7))
|
||||
(set-pre-encode! xs (compose1 list->string reverse string->list))
|
||||
(encode xs "testing")
|
||||
(check-equal? (dump (current-output-port)) #"gnitset")))
|
||||
|
||||
(test-case
|
||||
"encode length as number before string"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+xstring uint8) "testing")
|
||||
(check-equal? (dump (current-output-port)) #"\x07testing")))
|
||||
|
||||
(test-case
|
||||
"encode length as number before string utf8"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+xstring uint8 'utf8) "testing 😜")
|
||||
(check-equal? (dump (current-output-port)) (string->bytes/utf-8 "\x0ctesting 😜"))))
|
||||
|
||||
(test-case
|
||||
"encode utf8"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+xstring 4 'utf8) "🍻" )
|
||||
(check-equal? (dump (current-output-port)) (string->bytes/utf-8 "🍻"))))
|
||||
|
||||
(test-case
|
||||
"encode encoding computed from function"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+xstring 4 (λ _ 'utf8)) "🍻")
|
||||
(check-equal? (dump (current-output-port)) (string->bytes/utf-8 "🍻"))))
|
||||
|
||||
(test-case
|
||||
"encode null-terminated string"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+xstring #f 'utf8) "🍻" )
|
||||
(check-equal? (dump (current-output-port)) (string->bytes/utf-8 "🍻\x00"))))
|
||||
@ -1,126 +1,80 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
racket/class
|
||||
sugar/unstable/dict
|
||||
sugar/unstable/js
|
||||
"../private/generic.rkt")
|
||||
#lang debug racket/base
|
||||
(require rackunit racket/dict
|
||||
"../helper.rkt"
|
||||
"../struct.rkt"
|
||||
"../string.rkt"
|
||||
"../pointer.rkt"
|
||||
"../number.rkt"
|
||||
sugar/unstable/dict)
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee
|
||||
|#
|
||||
|
||||
|
||||
;describe 'Struct', ->
|
||||
; describe 'decode', ->
|
||||
; it 'should decode into an object', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")])
|
||||
(check-equal?
|
||||
(dump (decode (+Struct (dictify 'name (+StringT uint8)
|
||||
'age uint8))))
|
||||
(hasheq 'name "roxyb" 'age 21)))
|
||||
|
||||
|
||||
|
||||
; it 'should support process hook', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x20")])
|
||||
(define struct (+Struct (dictify 'name (+StringT uint8)
|
||||
'age uint8)))
|
||||
(set-field! post-decode struct (λ (o . _) (ref-set! o 'canDrink (>= (· o age) 21)) o))
|
||||
(check-equal? (dump (decode struct))
|
||||
(hasheq 'name "roxyb" 'age 32 'canDrink #t)))
|
||||
|
||||
|
||||
|
||||
; it 'should support function keys', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x20")])
|
||||
(define struct (+Struct (dictify 'name (+StringT uint8)
|
||||
'age uint8
|
||||
'canDrink (λ (o) (>= (ref o 'age) 21)))))
|
||||
(check-equal? (dump (decode struct))
|
||||
(hasheq 'name "roxyb" 'age 32 'canDrink #t)))
|
||||
|
||||
|
||||
|
||||
|
||||
;
|
||||
; describe 'size', ->
|
||||
; it 'should compute the correct size', ->
|
||||
|
||||
(check-equal? (size (+Struct (dictify
|
||||
'name (+StringT uint8)
|
||||
'age uint8))
|
||||
(hasheq 'name "roxyb" 'age 32)) 7)
|
||||
|
||||
|
||||
|
||||
; it 'should compute the correct size with pointers', ->
|
||||
|
||||
(check-equal? (size (+Struct (dictify
|
||||
'name (+StringT uint8)
|
||||
'age uint8
|
||||
'ptr (+Pointer uint8 (+StringT uint8))))
|
||||
(mhash 'name "roxyb" 'age 21 'ptr "hello")) 14)
|
||||
|
||||
|
||||
; it 'should get the correct size when no value is given', ->
|
||||
|
||||
(check-equal? (size (+Struct (dictify
|
||||
'name (+StringT 4)
|
||||
'age uint8))) 5)
|
||||
|
||||
; it 'should throw when getting non-fixed length size and no value is given', ->
|
||||
|
||||
(check-exn exn:fail:contract? (λ () (size (+Struct (dictify 'name (+StringT uint8)
|
||||
'age uint8)))))
|
||||
|
||||
|
||||
|
||||
;
|
||||
; describe 'encode', ->
|
||||
; it 'should encode objects to buffers', (done) ->
|
||||
; stream = new EncodeStream
|
||||
; stream.pipe concat (buf) ->
|
||||
; buf.should.deep.equal new Buffer '\x05roxyb\x15'
|
||||
; done()
|
||||
;
|
||||
; struct = new Struct
|
||||
; name: new StringT uint8
|
||||
; age: uint8
|
||||
;
|
||||
; struct.encode stream,
|
||||
; name: 'roxyb'
|
||||
; age: 21
|
||||
;
|
||||
; stream.end()
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")])
|
||||
(check-equal? (dump (decode (+Struct (dictify 'name (+StringT uint8)
|
||||
'age uint8))))
|
||||
(hasheq 'name "roxyb" 'age 21)))
|
||||
|
||||
|
||||
; it 'should support preEncode hook', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define struct (+Struct (dictify 'nameLength uint8
|
||||
'name (+StringT 'nameLength)
|
||||
'age uint8)))
|
||||
(set-field! pre-encode struct (λ (val port) (ref-set! val 'nameLength (length (ref val 'name))) val))
|
||||
(encode struct (mhasheq 'name "roxyb" 'age 21))
|
||||
(check-equal? (dump (current-output-port)) #"\x05roxyb\x15"))
|
||||
|
||||
|
||||
; it 'should encode pointer data after structure', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define struct (+Struct (dictify 'name (+StringT uint8)
|
||||
'age uint8
|
||||
'ptr (+Pointer uint8 (+StringT uint8)))))
|
||||
(encode struct (hasheq 'name "roxyb" 'age 21 'ptr "hello"))
|
||||
(check-equal? (dump (current-output-port)) #"\x05roxyb\x15\x08\x05hello"))
|
||||
|
||||
(test-case
|
||||
"decode into an object"
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")])
|
||||
(check-equal?
|
||||
(decode/hash (+xstruct 'name (+xstring #:length uint8) 'age uint8))
|
||||
(hasheq 'name "roxyb" 'age 21))))
|
||||
|
||||
(test-case
|
||||
"decode with process hook"
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x20")])
|
||||
(define struct (+xstruct 'name (+xstring #:length uint8) 'age uint8))
|
||||
(set-post-decode! struct (λ (o . _) (dict-set! o 'canDrink (>= (dict-ref o 'age) 21)) o))
|
||||
(check-equal? (decode/hash struct)
|
||||
(hasheq 'name "roxyb" 'age 32 'canDrink #t))))
|
||||
|
||||
(test-case
|
||||
"decode supports function keys"
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x20")])
|
||||
(define struct (+xstruct 'name (+xstring #:length uint8) 'age uint8 'canDrink (λ (o) (>= (dict-ref o 'age) 21))))
|
||||
(check-equal? (decode/hash struct)
|
||||
(hasheq 'name "roxyb" 'age 32 'canDrink #t))))
|
||||
|
||||
(test-case
|
||||
"compute the correct size"
|
||||
(check-equal? (size (+xstruct 'name (+xstring #:length uint8) 'age uint8)
|
||||
(hasheq 'name "roxyb" 'age 32)) 7))
|
||||
|
||||
(test-case
|
||||
"compute the correct size with pointers"
|
||||
(check-equal? (size (+xstruct 'name (+xstring #:length uint8)
|
||||
'age uint8
|
||||
'ptr (+xpointer #:type (+xstring #:length uint8)))
|
||||
(mhash 'name "roxyb" 'age 21 'ptr "hello")) 14))
|
||||
|
||||
(test-case
|
||||
"get the correct size when no value is given"
|
||||
(check-equal? (size (+xstruct 'name (+xstring 4) 'age uint8)) 5))
|
||||
|
||||
(test-case
|
||||
"throw when getting non-fixed length size and no value is given"
|
||||
(check-exn exn:fail:contract? (λ () (size (+xstruct 'name (+xstring #:length uint8) 'age uint8)))))
|
||||
|
||||
(test-case
|
||||
"encode objects to buffers"
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")])
|
||||
(check-equal? (decode/hash (+xstruct 'name (+xstring #:length uint8) 'age uint8))
|
||||
(hasheq 'name "roxyb" 'age 21))))
|
||||
|
||||
(test-case
|
||||
"support pre-encode hook"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define struct (+xstruct 'nameLength uint8
|
||||
'name (+xstring 'nameLength)
|
||||
'age uint8))
|
||||
(set-pre-encode! struct (λ (val) (dict-set! val 'nameLength (string-length (dict-ref val 'name))) val))
|
||||
(encode struct (mhasheq 'name "roxyb" 'age 21))
|
||||
(check-equal? (dump (current-output-port)) #"\x05roxyb\x15")))
|
||||
|
||||
(test-case
|
||||
"encode pointer data after structure"
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define struct (+xstruct 'name (+xstring #:length uint8)
|
||||
'age uint8
|
||||
'ptr (+xpointer #:type (+xstring #:length uint8))))
|
||||
(encode struct (hasheq 'name "roxyb" 'age 21 'ptr "hello"))
|
||||
(check-equal? (dump (current-output-port)) #"\x05roxyb\x15\x08\x05hello")))
|
||||
@ -1,344 +1,248 @@
|
||||
#lang racket/base
|
||||
#lang debug racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
racket/class
|
||||
"../private/generic.rkt"
|
||||
sugar/unstable/dict)
|
||||
racket/dict
|
||||
sugar/unstable/dict
|
||||
"../helper.rkt"
|
||||
"../number.rkt"
|
||||
"../string.rkt"
|
||||
"../pointer.rkt"
|
||||
"../versioned-struct.rkt")
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffee
|
||||
|#
|
||||
|
||||
;describe 'VersionedStruct', ->
|
||||
; describe 'decode', ->
|
||||
; it 'should get version from number type', ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")])
|
||||
(check-equal? (dump (decode struct)) (hasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 0)))
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x01\x0aroxyb 🤘\x15\x00"))])
|
||||
(check-equal? (dump (decode struct)) (hasheq 'name "roxyb 🤘"
|
||||
'age 21
|
||||
'version 1
|
||||
'gender 0))))
|
||||
|
||||
|
||||
; it 'should throw for unknown version', ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05\x05roxyb\x15")])
|
||||
(check-exn exn:fail:contract? (λ () (decode struct)))))
|
||||
|
||||
|
||||
;
|
||||
; it 'should support common header block', ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
'header (dictify 'age uint8
|
||||
'alive uint8)
|
||||
0 (dictify 'name (+StringT uint8 'ascii))
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'gender uint8)))])
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x00\x15\x01\x05roxyb")])
|
||||
(check-equal? (dump (decode struct)) (hasheq 'name "roxyb"
|
||||
(test-case
|
||||
"decode should get version from number type"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")])
|
||||
(check-equal? (decode/hash vstruct) (hasheq 'name "roxyb" 'age 21 'version 0)))
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x01\x0aroxyb 🤘\x15\x00"))])
|
||||
(check-equal? (decode/hash vstruct) (hasheq 'name "roxyb 🤘" 'age 21 'version 1 'gender 0)))))
|
||||
|
||||
(test-case
|
||||
"decode should throw for unknown version"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05\x05roxyb\x15")])
|
||||
(check-exn exn:fail:contract? (λ () (decode vstruct))))))
|
||||
|
||||
(test-case
|
||||
"decode should support common header block"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
'header (dictify 'age uint8
|
||||
'alive uint8)
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii))
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'gender uint8)))])
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x00\x15\x01\x05roxyb")])
|
||||
(check-equal? (decode/hash vstruct) (hasheq 'name "roxyb"
|
||||
'age 21
|
||||
'alive 1
|
||||
'version 0)))
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x01\x15\x01\x0aroxyb 🤘\x00"))])
|
||||
(check-equal? (dump (decode struct)) (hasheq 'name "roxyb 🤘"
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x01\x15\x01\x0aroxyb 🤘\x00"))])
|
||||
(check-equal? (decode/hash vstruct) (hasheq 'name "roxyb 🤘"
|
||||
'age 21
|
||||
'version 1
|
||||
'alive 1
|
||||
'gender 0))))
|
||||
|
||||
|
||||
; it 'should support parent version key', ->
|
||||
|
||||
(let ([struct (+VersionedStruct 'version
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")])
|
||||
(check-equal? (dump (decode struct #:parent (mhash 'version 0))) (hasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 0)))
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x0aroxyb 🤘\x15\x00"))])
|
||||
(check-equal? (dump (decode struct #:parent (mhash 'version 1))) (hasheq 'name "roxyb 🤘"
|
||||
'age 21
|
||||
'version 1
|
||||
'gender 0))))
|
||||
|
||||
|
||||
|
||||
;
|
||||
; it 'should support sub versioned structs', ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8))
|
||||
1 (dictify 'name (+StringT uint8)
|
||||
'isDessert uint8)))))])
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")])
|
||||
(check-equal? (dump (decode struct #:parent (mhash 'version 0))) (hasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 0)))
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x01\x00\x05pasta")])
|
||||
(check-equal? (dump (decode struct #:parent (mhash 'version 0))) (hasheq 'name "pasta"
|
||||
'version 0)))
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x01\x01\x09ice cream\x01")])
|
||||
(check-equal? (dump (decode struct #:parent (mhash 'version 0))) (hasheq 'name "ice cream"
|
||||
'isDessert 1
|
||||
'version 1))))
|
||||
|
||||
|
||||
;
|
||||
; it 'should support process hook', ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
(set-field! post-decode struct (λ (o stream ctx) (ref-set! o 'processed "true") o))
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")])
|
||||
(check-equal? (dump (decode struct)) (hasheq 'name "roxyb"
|
||||
'processed "true"
|
||||
'age 21
|
||||
'version 0))))
|
||||
|
||||
|
||||
;
|
||||
; describe 'size', ->
|
||||
; it 'should compute the correct size', ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
|
||||
(check-equal? (size struct (mhasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 0)) 8)
|
||||
|
||||
(check-equal? (size struct (mhasheq 'name "roxyb 🤘"
|
||||
'gender 0
|
||||
'age 21
|
||||
'version 1)) 14))
|
||||
|
||||
|
||||
|
||||
|
||||
;
|
||||
; it 'should throw for unknown version', ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
|
||||
(check-exn exn:fail:contract? (λ () (size struct (mhasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 5)))))
|
||||
|
||||
|
||||
;
|
||||
; it 'should support common header block', ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
'header (dictify 'age uint8
|
||||
'alive uint8)
|
||||
0 (dictify 'name (+StringT uint8 'ascii))
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'gender uint8)))])
|
||||
|
||||
(check-equal? (size struct (mhasheq 'name "roxyb"
|
||||
'age 21
|
||||
'alive 1
|
||||
'version 0)) 9)
|
||||
|
||||
(check-equal? (size struct (mhasheq 'name "roxyb 🤘"
|
||||
'gender 0
|
||||
'age 21
|
||||
'alive 1
|
||||
'version 1)) 15))
|
||||
|
||||
|
||||
|
||||
; it 'should compute the correct size with pointers', ->
|
||||
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'ptr (+Pointer uint8 (+StringT uint8)))))])
|
||||
|
||||
(check-equal? (size struct (mhasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 1
|
||||
'ptr "hello")) 15))
|
||||
|
||||
|
||||
;
|
||||
; it 'should throw if no value is given', ->
|
||||
|
||||
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
|
||||
(check-exn exn:fail:contract? (λ () (size struct))))
|
||||
|
||||
|
||||
|
||||
; describe 'encode', ->
|
||||
; it 'should encode objects to buffers', (done) ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))]
|
||||
[port (open-output-bytes)])
|
||||
(encode struct (mhasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 0) port)
|
||||
(encode struct (mhasheq 'name "roxyb 🤘"
|
||||
'age 21
|
||||
'gender 0
|
||||
'version 1) port)
|
||||
(check-equal? (dump port) (string->bytes/utf-8 "\x00\x05roxyb\x15\x01\x0aroxyb 🤘\x15\x00")))
|
||||
|
||||
|
||||
;
|
||||
; it 'should throw for unknown version', ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))]
|
||||
[port (open-output-bytes)])
|
||||
(check-exn exn:fail:contract? (λ () (encode struct port (mhasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 5)))))
|
||||
|
||||
|
||||
|
||||
; it 'should support common header block', (done) ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
'header (dictify 'age uint8
|
||||
'alive uint8)
|
||||
0 (dictify 'name (+StringT uint8 'ascii))
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'gender uint8)))]
|
||||
[stream (open-output-bytes)])
|
||||
|
||||
(encode struct (mhasheq 'name "roxyb"
|
||||
'age 21
|
||||
'alive 1
|
||||
'version 0) stream)
|
||||
|
||||
(encode struct (mhasheq 'name "roxyb 🤘"
|
||||
'gender 0
|
||||
'age 21
|
||||
'alive 1
|
||||
'version 1) stream)
|
||||
|
||||
(check-equal? (dump stream) (string->bytes/utf-8 "\x00\x15\x01\x05roxyb\x01\x15\x01\x0aroxyb 🤘\x00")))
|
||||
|
||||
|
||||
|
||||
; it 'should encode pointer data after structure', (done) ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'ptr (+Pointer uint8 (+StringT uint8)))))]
|
||||
[stream (open-output-bytes)])
|
||||
(encode struct (mhasheq 'version 1
|
||||
'name "roxyb"
|
||||
'age 21
|
||||
'ptr "hello") stream)
|
||||
|
||||
(check-equal? (dump stream) (string->bytes/utf-8 "\x01\x05roxyb\x15\x09\x05hello")))
|
||||
|
||||
|
||||
|
||||
|
||||
; it 'should support preEncode hook', (done) ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))]
|
||||
[stream (open-output-bytes)])
|
||||
(set-field! pre-encode struct (λ (val port) (ref-set! val 'version (if (ref val 'gender) 1 0)) val))
|
||||
(encode struct (mhasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 0) stream)
|
||||
(encode struct (mhasheq 'name "roxyb 🤘"
|
||||
'age 21
|
||||
'gender 0) stream)
|
||||
(check-equal? (dump stream) (string->bytes/utf-8 "\x00\x05roxyb\x15\x01\x0aroxyb 🤘\x15\x00")))
|
||||
'gender 0)))))
|
||||
|
||||
(test-case
|
||||
"decode should support parent version key"
|
||||
(let ([vstruct (+xversioned-struct 'version
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")])
|
||||
(check-equal? (decode/hash vstruct #:parent (mhash 'version 0))
|
||||
(hasheq 'name "roxyb" 'age 21 'version 0)))
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x0aroxyb 🤘\x15\x00"))])
|
||||
(check-equal? (decode/hash vstruct #:parent (mhash 'version 1))
|
||||
(hasheq 'name "roxyb 🤘" 'age 21 'version 1 'gender 0)))))
|
||||
|
||||
(test-case
|
||||
"decode should support sub versioned structs"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring uint8))
|
||||
1 (dictify 'name (+xstring uint8)
|
||||
'isDessert uint8)))))])
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")])
|
||||
(check-equal? (decode/hash vstruct #:parent (mhash 'version 0))
|
||||
(hasheq 'name "roxyb" 'age 21 'version 0)))
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x01\x00\x05pasta")])
|
||||
(check-equal? (decode/hash vstruct #:parent (mhash 'version 0))
|
||||
(hasheq 'name "pasta" 'version 0)))
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x01\x01\x09ice cream\x01")])
|
||||
(check-equal? (decode/hash vstruct #:parent (mhash 'version 0))
|
||||
(hasheq 'name "ice cream" 'isDessert 1 'version 1)))))
|
||||
|
||||
(test-case
|
||||
"decode should support process hook"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
(set-post-decode! vstruct (λ (val) (dict-set! val 'processed "true") val))
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")])
|
||||
(check-equal? (decode/hash vstruct)
|
||||
(hasheq 'name "roxyb" 'processed "true" 'age 21 'version 0)))))
|
||||
|
||||
(test-case
|
||||
"size should compute the correct size"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
(check-equal? (size vstruct (mhasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 0)) 8)
|
||||
(check-equal? (size vstruct (mhasheq 'name "roxyb 🤘"
|
||||
'gender 0
|
||||
'age 21
|
||||
'version 1)) 14)))
|
||||
|
||||
(test-case
|
||||
"size should throw for unknown version"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
(check-exn exn:fail:contract? (λ () (size vstruct (mhasheq 'name "roxyb" 'age 21 'version 5))))))
|
||||
|
||||
(test-case
|
||||
"size should support common header block"
|
||||
(let ([struct (+xversioned-struct uint8
|
||||
(dictify
|
||||
'header (dictify 'age uint8
|
||||
'alive uint8)
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii))
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'gender uint8)))])
|
||||
(check-equal? (size struct (mhasheq 'name "roxyb" 'age 21 'alive 1 'version 0)) 9)
|
||||
(check-equal? (size struct (mhasheq 'name "roxyb 🤘" 'gender 0 'age 21 'alive 1 'version 1)) 15)))
|
||||
|
||||
(test-case
|
||||
"size should compute the correct size with pointers"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'ptr (+xpointer #:offset-type uint8
|
||||
#:type (+xstring uint8)))))])
|
||||
(check-equal? (size vstruct (mhasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 1
|
||||
'ptr "hello")) 15)))
|
||||
|
||||
(test-case
|
||||
"size should throw if no value is given"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
(check-exn exn:fail:contract? (λ () (size vstruct)))))
|
||||
|
||||
(test-case
|
||||
"encode should encode objects to buffers"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))]
|
||||
[op (open-output-bytes)])
|
||||
(encode vstruct (mhasheq 'name "roxyb" 'age 21 'version 0) op)
|
||||
(encode vstruct (mhasheq 'name "roxyb 🤘" 'age 21 'gender 0 'version 1) op)
|
||||
(check-equal? (dump op) (string->bytes/utf-8 "\x00\x05roxyb\x15\x01\x0aroxyb 🤘\x15\x00"))))
|
||||
|
||||
(test-case
|
||||
"encode should throw for unknown version"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))]
|
||||
[op (open-output-bytes)])
|
||||
(check-exn exn:fail:contract? (λ () (encode vstruct op (mhasheq 'name "roxyb" 'age 21 'version 5))))))
|
||||
|
||||
(test-case
|
||||
"encode should support common header block"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
'header (dictify 'age uint8
|
||||
'alive uint8)
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii))
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'gender uint8)))]
|
||||
[op (open-output-bytes)])
|
||||
(encode vstruct (mhasheq 'name "roxyb" 'age 21 'alive 1 'version 0) op)
|
||||
(encode vstruct (mhasheq 'name "roxyb 🤘" 'gender 0 'age 21 'alive 1 'version 1) op)
|
||||
(check-equal? (dump op) (string->bytes/utf-8 "\x00\x15\x01\x05roxyb\x01\x15\x01\x0aroxyb 🤘\x00"))))
|
||||
|
||||
(test-case
|
||||
"encode should encode pointer data after structure"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'ptr (+xpointer #:offset-type uint8
|
||||
#:type (+xstring uint8)))))]
|
||||
[op (open-output-bytes)])
|
||||
(encode vstruct (mhasheq 'version 1 'name "roxyb" 'age 21 'ptr "hello") op)
|
||||
|
||||
(check-equal? (dump op) (string->bytes/utf-8 "\x01\x05roxyb\x15\x09\x05hello"))))
|
||||
|
||||
(test-case
|
||||
"encode should support preEncode hook"
|
||||
(let ([vstruct (+xversioned-struct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+xstring #:length uint8 #:encoding 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+xstring #:length uint8 #:encoding 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))]
|
||||
[stream (open-output-bytes)])
|
||||
(set-pre-encode! vstruct (λ (val) (dict-set! val 'version (if (dict-ref val 'gender #f) 1 0)) val))
|
||||
(encode vstruct (mhasheq 'name "roxyb" 'age 21 'version 0) stream)
|
||||
(encode vstruct (mhasheq 'name "roxyb 🤘" 'age 21 'gender 0) stream)
|
||||
(check-equal? (dump stream) (string->bytes/utf-8 "\x00\x05roxyb\x15\x01\x0aroxyb 🤘\x15\x00"))))
|
||||
@ -0,0 +1,49 @@
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/list
|
||||
sugar/unstable/class
|
||||
sugar/unstable/dict
|
||||
"private/generic.rkt"
|
||||
"private/helper.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/src/Bitfield.coffee
|
||||
|#
|
||||
|
||||
(define-subclass Streamcoder (Bitfield type [flags empty])
|
||||
(unless (andmap (λ (f) (or (key? f) (not f))) flags)
|
||||
(raise-argument-error 'Bitfield "list of keys" flags))
|
||||
|
||||
(define/augment (decode stream . _)
|
||||
(define flag-hash (mhasheq))
|
||||
(for* ([val (in-value (send type decode stream))]
|
||||
[(flag i) (in-indexed flags)]
|
||||
#:when flag)
|
||||
(hash-set! flag-hash flag (bitwise-bit-set? val i)))
|
||||
flag-hash)
|
||||
|
||||
(define/augment (size . _) (send type size))
|
||||
|
||||
(define/augment (encode port flag-hash [ctx #f])
|
||||
(define bit-int (for/sum ([(flag i) (in-indexed flags)]
|
||||
#:when (and flag (ref flag-hash flag)))
|
||||
(arithmetic-shift 1 i)))
|
||||
(send type encode port bit-int))
|
||||
|
||||
(define/override (get-class-name) 'Bitfield))
|
||||
|
||||
|
||||
(test-module
|
||||
(require "number.rkt")
|
||||
(define bfer (+Bitfield uint16be '(bold italic underline #f shadow condensed extended)))
|
||||
(define bf (send bfer decode #"\0\25"))
|
||||
(check-equal? (length (ref-keys bf)) 6) ; omits #f flag
|
||||
(check-true (ref bf 'bold))
|
||||
(check-true (ref bf 'underline))
|
||||
(check-true (ref bf 'shadow))
|
||||
(check-false (ref bf 'italic))
|
||||
(check-false (ref bf 'condensed))
|
||||
(check-false (ref bf 'extended))
|
||||
(check-equal? (encode bfer bf #f) #"\0\25"))
|
||||
@ -0,0 +1,60 @@
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
sugar/unstable/class
|
||||
"private/generic.rkt"
|
||||
"private/helper.rkt"
|
||||
"number.rkt"
|
||||
"utils.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/src/Buffer.coffee
|
||||
|#
|
||||
|
||||
#|
|
||||
A Buffer is a container object for any data object that supports random access
|
||||
A Node Buffer object is basically a byte string.
|
||||
First argument must be a string, Buffer, ArrayBuffer, Array, or array-like object.
|
||||
A Restructure RBuffer object is separate.
|
||||
|#
|
||||
|
||||
(define (+Buffer xs [type #f])
|
||||
((if (string? xs)
|
||||
string->bytes/utf-8
|
||||
list->bytes) xs))
|
||||
|
||||
(define-subclass xenomorph-base% (RBuffer [len #xffff])
|
||||
|
||||
(define/augment (decode port [parent #f])
|
||||
(define decoded-len (resolve-length len port parent))
|
||||
(read-bytes decoded-len port))
|
||||
|
||||
(define/augment (size [val #f] [parent #f])
|
||||
(when val (unless (bytes? val)
|
||||
(raise-argument-error 'Buffer:size "bytes" val)))
|
||||
(if val
|
||||
(bytes-length val)
|
||||
(resolve-length len val parent)))
|
||||
|
||||
(define/augment (encode port buf [parent #f])
|
||||
(unless (bytes? buf)
|
||||
(raise-argument-error 'Buffer:encode "bytes" buf))
|
||||
(define op (or port (open-output-bytes)))
|
||||
(when (NumberT? len)
|
||||
(send len encode op (length buf)))
|
||||
(write-bytes buf op)
|
||||
(unless port (get-output-bytes op))))
|
||||
|
||||
(define-subclass RBuffer (BufferT))
|
||||
|
||||
|
||||
#;(test-module
|
||||
(require "stream.rkt")
|
||||
(define stream (+DecodeStream #"\2BCDEF"))
|
||||
(define S (+String uint8 'utf8))
|
||||
(check-equal? (send S decode stream) "BC")
|
||||
(define os (+EncodeStream))
|
||||
(send S encode os "Mike")
|
||||
(check-equal? (send os dump) #"\4Mike")
|
||||
(check-equal? (send (+String) size "foobar") 6))
|
||||
@ -0,0 +1,26 @@
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/list
|
||||
sugar/unstable/class
|
||||
"private/helper.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/src/Enum.coffee
|
||||
|#
|
||||
|
||||
(define-subclass xenomorph-base% (Enum type [options empty])
|
||||
|
||||
(define/augment (decode stream . _)
|
||||
(define index (send type decode stream))
|
||||
(or (list-ref options index) index))
|
||||
|
||||
(define/augment (size . _) (send type size))
|
||||
|
||||
(define/augment (encode stream val [ctx #f])
|
||||
(define index (index-of options val))
|
||||
(unless index
|
||||
(raise-argument-error 'Enum:encode "valid option" val))
|
||||
(send type encode stream index)))
|
||||
|
||||
@ -0,0 +1,83 @@
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
sugar/unstable/class
|
||||
sugar/unstable/dict
|
||||
"private/generic.rkt"
|
||||
"private/helper.rkt"
|
||||
"utils.rkt"
|
||||
"array.rkt"
|
||||
"number.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/src/LazyArray.coffee
|
||||
|#
|
||||
|
||||
(define (get o i) (send o get i))
|
||||
(define (LazyArray->list o) (send o to-list))
|
||||
|
||||
(define-subclass object% (InnerLazyArray type [len #f] [port-in #f] [ctx #f])
|
||||
(field ([port port] (cond
|
||||
[(bytes? port-in) (open-input-bytes port-in)]
|
||||
[(port? port-in) port-in]
|
||||
[else (raise-argument-error 'LazyArray "port" port)])))
|
||||
(define starting-pos (pos port))
|
||||
(define item-cache (mhasheqv)) ; integer-keyed hash, rather than list
|
||||
|
||||
|
||||
(define/public-final (get index)
|
||||
(unless (<= 0 index (sub1 len))
|
||||
(raise-argument-error 'LazyArray:get (format "index in range 0 to ~a" (sub1 len)) index))
|
||||
(ref! item-cache index (λ ()
|
||||
(define orig-pos (pos port))
|
||||
(pos port (+ starting-pos (* (send type size #f ctx) index)))
|
||||
(define new-item (send type decode port ctx))
|
||||
(pos port orig-pos)
|
||||
new-item)))
|
||||
|
||||
(define/public-final (to-list)
|
||||
(for/list ([i (in-range len)])
|
||||
(get i))))
|
||||
|
||||
|
||||
(define-subclass ArrayT (LazyArray)
|
||||
(inherit-field len type)
|
||||
|
||||
(define/override (decode port [parent #f])
|
||||
(define starting-pos (pos port)) ; ! placement matters. `resolve-length` will change `pos`
|
||||
(define decoded-len (resolve-length len port parent))
|
||||
(let ([parent (if (NumberT? len)
|
||||
(mhasheq 'parent parent
|
||||
'_startOffset starting-pos
|
||||
'_currentOffset 0
|
||||
'_length len)
|
||||
parent)])
|
||||
(define res (+InnerLazyArray type decoded-len port parent))
|
||||
(pos port (+ (pos port) (* decoded-len (send type size #f parent))))
|
||||
res))
|
||||
|
||||
(define/override (size [val #f] [ctx #f])
|
||||
(super size (if (InnerLazyArray? val)
|
||||
(send val to-list)
|
||||
val) ctx))
|
||||
|
||||
(define/override (encode port val [ctx #f])
|
||||
(super encode port (if (InnerLazyArray? val)
|
||||
(send val to-list)
|
||||
val) ctx)))
|
||||
|
||||
(test-module
|
||||
(define bstr #"ABCD1234")
|
||||
(define ds (open-input-bytes bstr))
|
||||
(define la (+LazyArray uint8 4))
|
||||
(define ila (decode la ds))
|
||||
(check-equal? (pos ds) 4)
|
||||
(check-equal? (get ila 1) 66)
|
||||
(check-equal? (get ila 3) 68)
|
||||
(check-equal? (pos ds) 4)
|
||||
(check-equal? (LazyArray->list ila) '(65 66 67 68))
|
||||
(define la2 (+LazyArray int16be (λ (t) 4)))
|
||||
(check-equal? (encode la2 '(1 2 3 4) #f) #"\0\1\0\2\0\3\0\4")
|
||||
(check-equal? (send (decode la2 (open-input-bytes #"\0\1\0\2\0\3\0\4")) to-list) '(1 2 3 4)))
|
||||
|
||||
@ -0,0 +1,18 @@
|
||||
#lang racket/base
|
||||
|
||||
(define-syntax-rule (r+p ID ...)
|
||||
(begin (require ID ...) (provide (all-from-out ID ...))))
|
||||
|
||||
(r+p "array.rkt"
|
||||
"base.rkt"
|
||||
"bitfield.rkt"
|
||||
"buffer.rkt"
|
||||
"enum.rkt"
|
||||
"lazy-array.rkt"
|
||||
"number.rkt"
|
||||
"optional.rkt"
|
||||
"pointer.rkt"
|
||||
"reserved.rkt"
|
||||
"string.rkt"
|
||||
"struct.rkt"
|
||||
"versioned-struct.rkt")
|
||||
@ -0,0 +1,30 @@
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
sugar/unstable/class
|
||||
"private/helper.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/src/Optional.coffee
|
||||
|#
|
||||
|
||||
(define-subclass xenomorph-base% (Optional type [condition #t])
|
||||
|
||||
(define (resolve-condition parent)
|
||||
(if (procedure? condition)
|
||||
(condition parent)
|
||||
condition))
|
||||
|
||||
(define/augment (decode stream parent)
|
||||
(when (resolve-condition parent)
|
||||
(send type decode stream parent)))
|
||||
|
||||
(define/augment (size val parent)
|
||||
(when (resolve-condition parent)
|
||||
(send type size val parent)))
|
||||
|
||||
(define/augment (encode stream val parent)
|
||||
(when (resolve-condition parent)
|
||||
(send type encode stream val parent))))
|
||||
|
||||
@ -0,0 +1,107 @@
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
sugar/unstable/class
|
||||
sugar/unstable/case
|
||||
sugar/unstable/dict
|
||||
sugar/unstable/js
|
||||
"private/generic.rkt"
|
||||
"private/helper.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/src/Pointer.coffee
|
||||
|#
|
||||
|
||||
(define (resolve-void-pointer type val)
|
||||
(cond
|
||||
[type (values type val)]
|
||||
[(VoidPointer? val) (values (· val type) (· val value))]
|
||||
[else (raise-argument-error 'Pointer:size "VoidPointer" val)]))
|
||||
|
||||
(define (find-top-ctx ctx)
|
||||
(cond
|
||||
[(· ctx parent) => find-top-ctx]
|
||||
[else ctx]))
|
||||
|
||||
(define-subclass xenomorph-base% (Pointer offset-type type-in [options (mhasheq)])
|
||||
(field [type (and (not (eq? type-in 'void)) type-in)])
|
||||
(define pointer-style (or (· options type) 'local))
|
||||
(define allow-null (or (· options allowNull) #t))
|
||||
(define null-value (or (· options nullValue) 0))
|
||||
(define lazy (· options lazy))
|
||||
(define relative-getter-or-0 (or (· options relativeTo) (λ (ctx) 0))) ; changed this to a simple lambda
|
||||
|
||||
(define/augment (decode port [ctx #f])
|
||||
(define offset (send offset-type decode port ctx))
|
||||
(cond
|
||||
[(and allow-null (= offset null-value)) #f] ; handle null pointers
|
||||
[else
|
||||
(define relative (+ (caseq pointer-style
|
||||
[(local) (· ctx _startOffset)]
|
||||
[(immediate) (- (pos port) (send offset-type size))]
|
||||
[(parent) (· ctx parent _startOffset)]
|
||||
[(global) (or (· (find-top-ctx ctx) _startOffset) 0)]
|
||||
[else (error 'unknown-pointer-style)])
|
||||
(relative-getter-or-0 ctx)))
|
||||
(define ptr (+ offset relative))
|
||||
(cond
|
||||
[type (define val (void))
|
||||
(define (decode-value)
|
||||
(cond
|
||||
[(not (void? val)) val]
|
||||
[else
|
||||
(define orig-pos (pos port))
|
||||
(pos port ptr)
|
||||
(set! val (send type decode port ctx))
|
||||
(pos port orig-pos)
|
||||
val]))
|
||||
(if lazy
|
||||
(LazyThunk decode-value)
|
||||
(decode-value))]
|
||||
[else ptr])]))
|
||||
|
||||
|
||||
(define/augment (size [val #f] [ctx #f])
|
||||
(let*-values ([(parent) ctx]
|
||||
[(ctx) (caseq pointer-style
|
||||
[(local immediate) ctx]
|
||||
[(parent) (· ctx parent)]
|
||||
[(global) (find-top-ctx ctx)]
|
||||
[else (error 'unknown-pointer-style)])]
|
||||
[(type val) (resolve-void-pointer type val)])
|
||||
(when (and val ctx)
|
||||
(ref-set! ctx 'pointerSize (and (· ctx pointerSize)
|
||||
(+ (· ctx pointerSize) (send type size val parent)))))
|
||||
(send offset-type size)))
|
||||
|
||||
|
||||
(define/augment (encode port val [ctx #f])
|
||||
(unless ctx
|
||||
;; todo: furnish default pointer context? adapt from Struct?
|
||||
(raise-argument-error 'Pointer:encode "valid pointer context" ctx))
|
||||
(if (not val)
|
||||
(send offset-type encode port null-value)
|
||||
(let* ([parent ctx]
|
||||
[ctx (caseq pointer-style
|
||||
[(local immediate) ctx]
|
||||
[(parent) (· ctx parent)]
|
||||
[(global) (find-top-ctx ctx)]
|
||||
[else (error 'unknown-pointer-style)])]
|
||||
[relative (+ (caseq pointer-style
|
||||
[(local parent) (· ctx startOffset)]
|
||||
[(immediate) (+ (pos port) (send offset-type size val parent))]
|
||||
[(global) 0])
|
||||
(relative-getter-or-0 (· parent val)))])
|
||||
|
||||
(send offset-type encode port (- (· ctx pointerOffset) relative))
|
||||
|
||||
(let-values ([(type val) (resolve-void-pointer type val)])
|
||||
(ref-set! ctx 'pointers (append (· ctx pointers) (list (mhasheq 'type type
|
||||
'val val
|
||||
'parent parent))))
|
||||
(ref-set! ctx 'pointerOffset (+ (· ctx pointerOffset) (send type size val parent))))))))
|
||||
|
||||
|
||||
;; A pointer whose type is determined at decode time
|
||||
(define-subclass object% (VoidPointer type value))
|
||||
@ -0,0 +1,24 @@
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
sugar/unstable/class
|
||||
"private/helper.rkt"
|
||||
"utils.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/src/Reserved.coffee
|
||||
|#
|
||||
|
||||
(define-subclass xenomorph-base% (Reserved type [count 1])
|
||||
|
||||
(define/augment (decode port parent)
|
||||
(pos port (+ (pos port) (size #f parent)))
|
||||
(void))
|
||||
|
||||
(define/augment (size [val #f] [parent #f])
|
||||
(* (send type size) (resolve-length count #f parent)))
|
||||
|
||||
(define/augment (encode port val [parent #f])
|
||||
(make-bytes (size val parent) 0)))
|
||||
|
||||
@ -0,0 +1,91 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
sugar/unstable/dict)
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Array.coffee
|
||||
|#
|
||||
|
||||
;describe 'Array', ->
|
||||
; describe 'decode', ->
|
||||
; it 'should decode fixed length', ->
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
|
||||
(check-equal? (decode (+ArrayT uint8 4)) '(1 2 3 4)))
|
||||
|
||||
|
||||
; it 'should decode fixed amount of bytes', ->
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
|
||||
(check-equal? (decode (+ArrayT uint16be 4 'bytes)) '(258 772)))
|
||||
|
||||
|
||||
; it 'should decode length from parent key', ->
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
|
||||
(check-equal? (decode (+ArrayT uint8 'len) #:parent (mhash 'len 4)) '(1 2 3 4)))
|
||||
|
||||
|
||||
; it 'should decode amount of bytes from parent key', ->
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
|
||||
(check-equal? (decode (+ArrayT uint16be 'len 'bytes) #:parent (mhash 'len 4)) '(258 772)))
|
||||
|
||||
|
||||
; it 'should decode length as number before array', ->
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 4 1 2 3 4 5))])
|
||||
(check-equal? (decode (+ArrayT uint8 uint8)) '(1 2 3 4)))
|
||||
|
||||
|
||||
; it 'should decode amount of bytes as number before array', ->
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 4 1 2 3 4 5))])
|
||||
(check-equal? (decode (+ArrayT uint16be uint8 'bytes)) '(258 772)))
|
||||
|
||||
|
||||
; it 'should decode length from function', ->
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
|
||||
(check-equal? (decode (+ArrayT uint8 (λ _ 4))) '(1 2 3 4)))
|
||||
|
||||
|
||||
; it 'should decode amount of bytes from function', ->
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
|
||||
(check-equal? (decode (+ArrayT uint16be (λ _ 4) 'bytes)) '(258 772)))
|
||||
|
||||
|
||||
; it 'should decode to the end of the parent if no length is given', ->
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
|
||||
(check-equal? (decode (+ArrayT uint8) #:parent (mhash '_length 4 '_startOffset 0)) '(1 2 3 4)))
|
||||
|
||||
|
||||
; decode to the end of the stream if parent exists, but its length is 0
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4 5))])
|
||||
(check-equal? (decode (+ArrayT uint8) #:parent (mhash '_length 0 '_startOffset 0)) '(1 2 3 4 5)))
|
||||
|
||||
|
||||
; it 'should decode to the end of the stream if no parent and length is given', ->
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 3 4))])
|
||||
(check-equal? (decode (+ArrayT uint8)) '(1 2 3 4 )))
|
||||
|
||||
|
||||
; describe 'size', ->
|
||||
; it 'should use array length', ->
|
||||
(check-equal? (size (+ArrayT uint8 10) '(1 2 3 4)) 4)
|
||||
|
||||
|
||||
; it 'should add size of length field before string', ->
|
||||
(check-equal? (size (+ArrayT uint8 uint8) '(1 2 3 4)) 5)
|
||||
|
||||
|
||||
; it 'should use defined length if no value given', ->
|
||||
(check-equal? (size (+ArrayT uint8 10)) 10)
|
||||
|
||||
|
||||
; describe 'encode', ->
|
||||
; it 'should encode using array length', (done) ->
|
||||
(check-equal? (encode (+ArrayT uint8 10) '(1 2 3 4) #f) (bytes 1 2 3 4))
|
||||
|
||||
|
||||
; it 'should encode length as number before array', (done) ->
|
||||
(check-equal? (encode (+ArrayT uint8 uint8) '(1 2 3 4) #f) (bytes 4 1 2 3 4))
|
||||
|
||||
|
||||
; it 'should add pointers after array if length is encoded at start', (done) ->
|
||||
(check-equal? (encode (+ArrayT (+Pointer uint8 uint8) uint8) '(1 2 3 4) #f) (bytes 4 5 6 7 8 1 2 3 4))
|
||||
@ -0,0 +1,51 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
sugar/unstable/dict
|
||||
racket/list
|
||||
racket/match)
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Bitfield.coffee
|
||||
|#
|
||||
|
||||
;describe 'Bitfield', ->
|
||||
; bitfield = new Bitfield uint8, ['Jack', 'Kack', 'Lack', 'Mack', 'Nack', 'Oack', 'Pack', 'Quack']
|
||||
; JACK = 1 << 0
|
||||
; KACK = 1 << 1
|
||||
; LACK = 1 << 2
|
||||
; MACK = 1 << 3
|
||||
; NACK = 1 << 4
|
||||
; OACK = 1 << 5
|
||||
; PACK = 1 << 6
|
||||
; QUACK = 1 << 7
|
||||
|
||||
(define bitfield (+Bitfield uint8 '(Jack Kack Lack Mack Nack Oack Pack Quack)))
|
||||
(match-define (list JACK KACK LACK MACK NACK OACK PACK QUACK)
|
||||
(map (λ (x) (arithmetic-shift 1 x)) (range 8)))
|
||||
|
||||
; it 'should have the right size', ->
|
||||
(check-equal? (size bitfield) 1)
|
||||
|
||||
; it 'should decode', ->
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes (bitwise-ior JACK MACK PACK NACK QUACK)))])
|
||||
(check-equal? (decode bitfield) (mhasheq 'Quack #t
|
||||
'Nack #t
|
||||
'Lack #f
|
||||
'Oack #f
|
||||
'Pack #t
|
||||
'Mack #t
|
||||
'Jack #t
|
||||
'Kack #f)))
|
||||
|
||||
; it 'should encode', (done) ->
|
||||
(check-equal? (encode bitfield (mhasheq 'Quack #t
|
||||
'Nack #t
|
||||
'Lack #f
|
||||
'Oack #f
|
||||
'Pack #t
|
||||
'Mack #t
|
||||
'Jack #t
|
||||
'Kack #f) #f)
|
||||
(bytes (bitwise-ior JACK MACK PACK NACK QUACK)))
|
||||
@ -0,0 +1,46 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
sugar/unstable/dict)
|
||||
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Buffer.coffee
|
||||
|#
|
||||
|
||||
;describe 'Buffer', ->
|
||||
; describe 'decode', ->
|
||||
; it 'should decode', ->
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes #xab #xff #x1f #xb6))])
|
||||
(define buf (+BufferT 2))
|
||||
(check-equal? (decode buf) (bytes #xab #xff))
|
||||
(check-equal? (decode buf) (bytes #x1f #xb6)))
|
||||
|
||||
|
||||
; it 'should decode with parent key length', ->
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes #xab #xff #x1f #xb6))])
|
||||
(define buf (+BufferT 'len))
|
||||
(check-equal? (decode buf #:parent (hash 'len 3)) (bytes #xab #xff #x1f))
|
||||
(check-equal? (decode buf #:parent (hash 'len 1)) (bytes #xb6)))
|
||||
|
||||
|
||||
; describe 'size', ->
|
||||
; it 'should return size', ->
|
||||
(check-equal? (size (+BufferT 2) (bytes #xab #xff)) 2)
|
||||
|
||||
|
||||
; it 'should use defined length if no value given', ->x
|
||||
(check-equal? (size (+BufferT 10)) 10)
|
||||
|
||||
|
||||
; describe 'encode', ->
|
||||
; it 'should encode', (done) ->
|
||||
(let ([buf (+BufferT 2)])
|
||||
(check-equal? (bytes-append
|
||||
(encode buf (bytes #xab #xff) #f)
|
||||
(encode buf (bytes #x1f #xb6) #f)) (bytes #xab #xff #x1f #xb6)))
|
||||
|
||||
|
||||
; it 'should encode length before buffer', (done) ->
|
||||
(check-equal? (encode (+BufferT uint8) (bytes #xab #xff) #f) (bytes 2 #xab #xff))
|
||||
@ -0,0 +1,37 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
sugar/unstable/dict)
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Enum.coffee
|
||||
|#
|
||||
|
||||
;describe 'Enum', ->
|
||||
; e = new Enum uint8, ['foo', 'bar', 'baz']
|
||||
; it 'should have the right size', ->
|
||||
; e.size().should.equal 1
|
||||
|
||||
(define e (+Enum uint8 '("foo" "bar" "baz")))
|
||||
(check-equal? (size e) 1)
|
||||
|
||||
|
||||
; it 'should decode', ->
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 0))])
|
||||
(check-equal? (decode e) "bar")
|
||||
(check-equal? (decode e) "baz")
|
||||
(check-equal? (decode e) "foo"))
|
||||
|
||||
|
||||
; it 'should encode', (done) ->
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode e "bar")
|
||||
(encode e "baz")
|
||||
(encode e "foo")
|
||||
(check-equal? (dump (current-output-port)) (bytes 1 2 0)))
|
||||
|
||||
|
||||
; it 'should throw on unknown option', ->
|
||||
|
||||
(check-exn exn:fail:contract? (λ () (encode e "unknown" (open-output-bytes))))
|
||||
@ -0,0 +1,339 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
racket/class
|
||||
sugar/unstable/dict)
|
||||
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Number.coffee
|
||||
|#
|
||||
|
||||
;describe 'Number', ->
|
||||
; describe 'uint8', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes #xab #xff))])
|
||||
(check-equal? (decode uint8) #xab)
|
||||
(check-equal? (decode uint8) #xff))
|
||||
|
||||
(check-equal? (size uint8) 1)
|
||||
|
||||
(let ([port (open-output-bytes)])
|
||||
(encode uint8 #xab port)
|
||||
(encode uint8 #xff port)
|
||||
(check-equal? (dump port) (bytes #xab #xff)))
|
||||
|
||||
|
||||
; describe 'uint16', ->
|
||||
; it 'is an alias for uint16be', ->
|
||||
; modified test: `uint16` is the same endianness as the platform
|
||||
(check-equal? (decode uint16 (bytes 0 1)) (send (if (system-big-endian?)
|
||||
uint16be
|
||||
uint16le) decode (bytes 0 1)))
|
||||
|
||||
; describe 'uint16be', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode uint16be (open-input-bytes (bytes #xab #xff))) #xabff)
|
||||
(check-equal? (size uint16be) 2)
|
||||
(check-equal? (encode uint16be #xabff #f) (bytes #xab #xff))
|
||||
|
||||
;
|
||||
; describe 'uint16le', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode uint16le (open-input-bytes (bytes #xff #xab))) #xabff)
|
||||
(check-equal? (size uint16le) 2)
|
||||
(check-equal? (encode uint16le #xabff #f) (bytes #xff #xab))
|
||||
|
||||
;
|
||||
; describe 'uint24', ->
|
||||
; it 'is an alias for uint24be', ->
|
||||
;; modified test: `uint24` is the same endianness as the platform
|
||||
(check-equal? (decode uint24 (bytes 0 1 2)) (send (if (system-big-endian?)
|
||||
uint24be
|
||||
uint24le) decode (bytes 0 1 2)))
|
||||
|
||||
;
|
||||
; describe 'uint24be', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode uint24be (open-input-bytes (bytes #xff #xab #x24))) #xffab24)
|
||||
(check-equal? (size uint24be) 3)
|
||||
(check-equal? (encode uint24be #xffab24 #f) (bytes #xff #xab #x24))
|
||||
|
||||
;
|
||||
; describe 'uint24le', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode uint24le (open-input-bytes (bytes #x24 #xab #xff))) #xffab24)
|
||||
(check-equal? (size uint24le) 3)
|
||||
(check-equal? (encode uint24le #xffab24 #f) (bytes #x24 #xab #xff))
|
||||
|
||||
;
|
||||
; describe 'uint32', ->
|
||||
; it 'is an alias for uint32be', ->
|
||||
;; modified test: `uint32` is the same endianness as the platform
|
||||
(check-equal? (decode uint32 (bytes 0 1 2 3)) (send (if (system-big-endian?)
|
||||
uint32be
|
||||
uint32le) decode (bytes 0 1 2 3)))
|
||||
|
||||
;
|
||||
; describe 'uint32be', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode uint32be (open-input-bytes (bytes #xff #xab #x24 #xbf))) #xffab24bf)
|
||||
(check-equal? (size uint32be) 4)
|
||||
(check-equal? (encode uint32be #xffab24bf #f) (bytes #xff #xab #x24 #xbf))
|
||||
|
||||
;
|
||||
; describe 'uint32le', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode uint32le (open-input-bytes (bytes #xbf #x24 #xab #xff))) #xffab24bf)
|
||||
(check-equal? (size uint32le) 4)
|
||||
(check-equal? (encode uint32le #xffab24bf #f) (bytes #xbf #x24 #xab #xff))
|
||||
|
||||
|
||||
;
|
||||
; describe 'int8', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(let ([port (open-input-bytes (bytes #x7f #xff))])
|
||||
(check-equal? (decode int8 port) 127)
|
||||
(check-equal? (decode int8 port) -1))
|
||||
|
||||
(check-equal? (size int8) 1)
|
||||
|
||||
(let ([port (open-output-bytes)])
|
||||
(encode int8 127 port)
|
||||
(encode int8 -1 port)
|
||||
(check-equal? (dump port) (bytes #x7f #xff)))
|
||||
|
||||
|
||||
;
|
||||
; describe 'int16', ->
|
||||
; it 'is an alias for int16be', ->
|
||||
; int16.should.equal int16be
|
||||
|
||||
;; modified test: `int16` is the same endianness as the platform
|
||||
(check-equal? (decode int16 (bytes 0 1)) (send (if (system-big-endian?)
|
||||
int16be
|
||||
int16le) decode (bytes 0 1)))
|
||||
|
||||
|
||||
;
|
||||
; describe 'int16be', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(let ([port (open-input-bytes (bytes #xff #xab))])
|
||||
(check-equal? (decode int16be port) -85))
|
||||
|
||||
(check-equal? (size int16be) 2)
|
||||
|
||||
(let ([port (open-output-bytes)])
|
||||
(encode int16be -85 port)
|
||||
(check-equal? (dump port) (bytes #xff #xab)))
|
||||
|
||||
|
||||
; describe 'int16le', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode int16le (open-input-bytes (bytes #xab #xff))) -85)
|
||||
(check-equal? (size int16le) 2)
|
||||
(check-equal? (encode int16le -85 #f) (bytes #xab #xff))
|
||||
|
||||
|
||||
;
|
||||
; describe 'int24', ->
|
||||
; it 'is an alias for int24be', ->
|
||||
; int24.should.equal int24be
|
||||
|
||||
;; modified test: `int24` is the same endianness as the platform
|
||||
(check-equal? (decode int24 (bytes 0 1 2)) (send (if (system-big-endian?)
|
||||
int24be
|
||||
int24le) decode (bytes 0 1 2)))
|
||||
|
||||
|
||||
;
|
||||
; describe 'int24be', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode int24be (open-input-bytes (bytes #xff #xab #x24))) -21724)
|
||||
(check-equal? (size int24be) 3)
|
||||
(check-equal? (encode int24be -21724 #f) (bytes #xff #xab #x24))
|
||||
|
||||
;
|
||||
; describe 'int24le', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode int24le (open-input-bytes (bytes #x24 #xab #xff))) -21724)
|
||||
(check-equal? (size int24le) 3)
|
||||
(check-equal? (encode int24le -21724 #f) (bytes #x24 #xab #xff))
|
||||
|
||||
|
||||
|
||||
; describe 'int32', ->
|
||||
; it 'is an alias for int32be', ->
|
||||
; modified test: `int32` is the same endianness as the platform
|
||||
(check-equal? (decode int32 (bytes 0 1 2 3)) (send (if (system-big-endian?)
|
||||
int32be
|
||||
int32le) decode (bytes 0 1 2 3)))
|
||||
|
||||
|
||||
|
||||
;
|
||||
; describe 'int32be', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode int32be (open-input-bytes (bytes #xff #xab #x24 #xbf))) -5561153)
|
||||
(check-equal? (size int32be) 4)
|
||||
(check-equal? (encode int32be -5561153 #f) (bytes #xff #xab #x24 #xbf))
|
||||
|
||||
;
|
||||
; describe 'int32le', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode int32le (open-input-bytes (bytes #xbf #x24 #xab #xff))) -5561153)
|
||||
(check-equal? (size int32le) 4)
|
||||
(check-equal? (encode int32le -5561153 #f) (bytes #xbf #x24 #xab #xff))
|
||||
|
||||
;
|
||||
; describe 'float', ->
|
||||
; it 'is an alias for floatbe', ->
|
||||
; modified test: `float` is the same endianness as the platform
|
||||
(check-equal? (decode float (bytes 0 1 2 3)) (send (if (system-big-endian?)
|
||||
floatbe
|
||||
floatle) decode (bytes 0 1 2 3)))
|
||||
|
||||
;
|
||||
; describe 'floatbe', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-= (decode floatbe (open-input-bytes (bytes #x43 #x7a #x8c #xcd))) 250.55 0.01)
|
||||
(check-equal? (size floatbe) 4)
|
||||
(check-equal? (encode floatbe 250.55 #f) (bytes #x43 #x7a #x8c #xcd))
|
||||
|
||||
;
|
||||
; describe 'floatle', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-= (decode floatle (open-input-bytes (bytes #xcd #x8c #x7a #x43))) 250.55 0.01)
|
||||
(check-equal? (size floatle) 4)
|
||||
(check-equal? (encode floatle 250.55 #f) (bytes #xcd #x8c #x7a #x43))
|
||||
|
||||
;
|
||||
; describe 'double', ->
|
||||
; it 'is an alias for doublebe', ->
|
||||
; modified test: `double` is the same endianness as the platform
|
||||
(check-equal? (decode double (bytes 0 1 2 3 4 5 6 7)) (send (if (system-big-endian?)
|
||||
doublebe
|
||||
doublele) decode (bytes 0 1 2 3 4 5 6 7)))
|
||||
|
||||
;
|
||||
; describe 'doublebe', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode doublebe (open-input-bytes (bytes #x40 #x93 #x4a #x3d #x70 #xa3 #xd7 #x0a))) 1234.56)
|
||||
(check-equal? (size doublebe) 8)
|
||||
(check-equal? (encode doublebe 1234.56 #f) (bytes #x40 #x93 #x4a #x3d #x70 #xa3 #xd7 #x0a))
|
||||
|
||||
;
|
||||
; describe 'doublele', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-equal? (decode doublele (open-input-bytes (bytes #x0a #xd7 #xa3 #x70 #x3d #x4a #x93 #x40))) 1234.56)
|
||||
(check-equal? (size doublele) 8)
|
||||
(check-equal? (encode doublele 1234.56 #f) (bytes #x0a #xd7 #xa3 #x70 #x3d #x4a #x93 #x40))
|
||||
|
||||
;
|
||||
; describe 'fixed16', ->
|
||||
; it 'is an alias for fixed16be', ->
|
||||
; modified test: `fixed16` is the same endianness as the platform
|
||||
(check-equal? (decode fixed16 (bytes 0 1)) (send (if (system-big-endian?)
|
||||
fixed16be
|
||||
fixed16le) decode (bytes 0 1)))
|
||||
|
||||
;
|
||||
; describe 'fixed16be', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-= (decode fixed16be (open-input-bytes (bytes #x19 #x57))) 25.34 0.01)
|
||||
(check-equal? (size fixed16be) 2)
|
||||
(check-equal? (encode fixed16be 25.34 #f) (bytes #x19 #x57))
|
||||
|
||||
;
|
||||
; describe 'fixed16le', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-= (decode fixed16le (open-input-bytes (bytes #x57 #x19))) 25.34 0.01)
|
||||
(check-equal? (size fixed16le) 2)
|
||||
(check-equal? (encode fixed16le 25.34 #f) (bytes #x57 #x19))
|
||||
|
||||
;
|
||||
; describe 'fixed32', ->
|
||||
; it 'is an alias for fixed32be', ->
|
||||
; modified test: `fixed32` is the same endianness as the platform
|
||||
|
||||
(check-equal? (decode fixed32 (bytes 0 1 2 3)) (send (if (system-big-endian?)
|
||||
fixed32be
|
||||
fixed32le) decode (bytes 0 1 2 3)))
|
||||
|
||||
;
|
||||
; describe 'fixed32be', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
(check-= (decode fixed32be (open-input-bytes (bytes #x00 #xfa #x8c #xcc))) 250.55 0.01)
|
||||
(check-equal? (size fixed32be) 4)
|
||||
(check-equal? (encode fixed32be 250.55 #f) (bytes #x00 #xfa #x8c #xcc))
|
||||
|
||||
;
|
||||
; describe 'fixed32le', ->
|
||||
; it 'should decode', ->
|
||||
; it 'should have a size', ->
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(check-= (decode fixed32le (open-input-bytes (bytes #xcc #x8c #xfa #x00))) 250.55 0.01)
|
||||
(check-equal? (size fixed32le) 4)
|
||||
(check-equal? (encode fixed32le 250.55 #f) (bytes #xcc #x8c #xfa #x00))
|
||||
@ -0,0 +1,116 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
sugar/unstable/dict)
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Optional.coffee
|
||||
|#
|
||||
|
||||
;describe 'Optional', ->
|
||||
; describe 'decode', ->
|
||||
; it 'should not decode when condition is falsy', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+Optional uint8 #f))
|
||||
(check-equal? (decode optional) (void))
|
||||
(check-equal? (pos (current-input-port)) 0))
|
||||
|
||||
; it 'should not decode when condition is a function and falsy', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+Optional uint8 (λ _ #f)))
|
||||
(check-equal? (decode optional) (void))
|
||||
(check-equal? (pos (current-input-port)) 0))
|
||||
|
||||
|
||||
; it 'should decode when condition is omitted', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+Optional uint8))
|
||||
(check-not-equal? (decode optional) (void))
|
||||
(check-equal? (pos (current-input-port)) 1))
|
||||
|
||||
;
|
||||
; it 'should decode when condition is truthy', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+Optional uint8 #t))
|
||||
(check-not-equal? (decode optional) (void))
|
||||
(check-equal? (pos (current-input-port)) 1))
|
||||
|
||||
|
||||
; it 'should decode when condition is a function and truthy', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(define optional (+Optional uint8 (λ _ #t)))
|
||||
(check-not-equal? (decode optional) (void))
|
||||
(check-equal? (pos (current-input-port)) 1))
|
||||
|
||||
|
||||
; describe 'size', ->
|
||||
|
||||
(check-equal? (size (+Optional uint8 #f)) 0)
|
||||
|
||||
;
|
||||
; it 'should return 0 when condition is a function and falsy', ->
|
||||
|
||||
(check-equal? (size (+Optional uint8 (λ _ #f))) 0)
|
||||
|
||||
|
||||
; it 'should return given type size when condition is omitted', ->
|
||||
|
||||
(check-equal? (size (+Optional uint8)) 1)
|
||||
|
||||
|
||||
; it 'should return given type size when condition is truthy', ->
|
||||
|
||||
(check-equal? (size (+Optional uint8 #t)) 1)
|
||||
|
||||
|
||||
; it 'should return given type size when condition is a function and truthy', ->
|
||||
|
||||
(check-equal? (size (+Optional uint8 (λ _ #t))) 1)
|
||||
|
||||
|
||||
; describe 'encode', ->
|
||||
; it 'should not encode when condition is falsy', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+Optional uint8 #f))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes)))
|
||||
|
||||
|
||||
; it 'should not encode when condition is a function and falsy', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+Optional uint8 (λ _ #f)))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes)))
|
||||
|
||||
|
||||
;
|
||||
; it 'should encode when condition is omitted', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+Optional uint8))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes 128)))
|
||||
|
||||
|
||||
; it 'should encode when condition is truthy', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+Optional uint8 #t))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes 128)))
|
||||
|
||||
|
||||
; it 'should encode when condition is a function and truthy', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define optional (+Optional uint8 (λ _ #t)))
|
||||
(encode optional 128)
|
||||
(check-equal? (dump (current-output-port)) (bytes 128)))
|
||||
@ -0,0 +1,239 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
sugar/unstable/js
|
||||
sugar/unstable/dict
|
||||
racket/class
|
||||
"../private/helper.rkt")
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Pointer.coffee
|
||||
|#
|
||||
|
||||
|
||||
;describe 'Pointer', ->
|
||||
; describe 'decode', ->
|
||||
; it 'should handle null pointers', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0))])
|
||||
(check-false (decode (+Pointer uint8 uint8) #:parent (mhash '_startOffset 50))))
|
||||
|
||||
|
||||
; it 'should use local offsets from start of parent by default', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 53))])
|
||||
(check-equal? (decode (+Pointer uint8 uint8) #:parent (mhash '_startOffset 0)) 53))
|
||||
|
||||
|
||||
; it 'should support immediate offsets', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 53))])
|
||||
(check-equal? (decode (+Pointer uint8 uint8 (mhash 'type 'immediate))) 53))
|
||||
|
||||
|
||||
; it 'should support offsets relative to the parent', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0 0 1 53))])
|
||||
(pos (current-input-port) 2)
|
||||
(check-equal? (decode (+Pointer uint8 uint8 (mhash 'type 'parent))
|
||||
#:parent (mhash 'parent (mhash '_startOffset 2))) 53))
|
||||
|
||||
|
||||
; it 'should support global offsets', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 2 4 0 0 0 53))])
|
||||
(pos (current-input-port) 2)
|
||||
(check-equal? (decode (+Pointer uint8 uint8 (mhash 'type 'global))
|
||||
#:parent (mhash 'parent (mhash 'parent (mhash '_startOffset 2))))
|
||||
53))
|
||||
|
||||
|
||||
; it 'should support offsets relative to a property on the parent', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 0 0 0 0 53))])
|
||||
(check-equal? (decode (+Pointer uint8 uint8 (mhash 'relativeTo (λ (ctx) (· ctx parent ptr))))
|
||||
#:parent (mhash '_startOffset 0 'parent (mhash 'ptr 4)))
|
||||
53))
|
||||
|
||||
|
||||
; it 'should support returning pointer if there is no decode type', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 4))])
|
||||
(check-equal? (decode (+Pointer uint8 'void)
|
||||
#:parent (mhash '_startOffset 0)) 4))
|
||||
|
||||
|
||||
; it 'should support decoding pointers lazily', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 1 53))])
|
||||
(define res (decode (+Struct (dictify 'ptr (+Pointer uint8 uint8 (mhasheq 'lazy #t))))))
|
||||
(check-true (LazyThunk? (hash-ref (get-field _kv res) 'ptr)))
|
||||
(check-equal? (· res ptr) 53))
|
||||
|
||||
|
||||
|
||||
; describe 'size', ->
|
||||
|
||||
(let ([ctx (mhash 'pointerSize 0)])
|
||||
(check-equal? (size (+Pointer uint8 uint8) 10 ctx) 1)
|
||||
(check-equal? (· ctx pointerSize) 1))
|
||||
|
||||
|
||||
|
||||
; it 'should add to immediate pointerSize', ->
|
||||
|
||||
(let ([ctx (mhash 'pointerSize 0)])
|
||||
(check-equal? (size (+Pointer uint8 uint8 (mhash 'type 'immediate)) 10 ctx) 1)
|
||||
(check-equal? (· ctx pointerSize) 1))
|
||||
|
||||
|
||||
; it 'should add to parent pointerSize', ->
|
||||
|
||||
(let ([ctx (mhash 'parent (mhash 'pointerSize 0))])
|
||||
(check-equal? (size (+Pointer uint8 uint8 (mhash 'type 'parent)) 10 ctx) 1)
|
||||
(check-equal? (· ctx parent pointerSize) 1))
|
||||
|
||||
|
||||
|
||||
; it 'should add to global pointerSize', ->
|
||||
|
||||
(let ([ctx (mhash 'parent (mhash 'parent (mhash 'parent (mhash 'pointerSize 0))))])
|
||||
(check-equal? (size (+Pointer uint8 uint8 (mhash 'type 'global)) 10 ctx) 1)
|
||||
(check-equal? (· ctx parent parent parent pointerSize) 1))
|
||||
|
||||
|
||||
|
||||
; it 'should handle void pointers', ->
|
||||
|
||||
(let ([ctx (mhash 'pointerSize 0)])
|
||||
(check-equal? (size (+Pointer uint8 'void) (+VoidPointer uint8 50) ctx) 1)
|
||||
(check-equal? (· ctx pointerSize) 1))
|
||||
|
||||
|
||||
; it 'should throw if no type and not a void pointer', ->
|
||||
|
||||
(let ([ctx (mhash 'pointerSize 0)])
|
||||
(check-exn exn:fail:contract? (λ () (size (+Pointer uint8 'void) 30 ctx))))
|
||||
|
||||
|
||||
; it 'should return a fixed size without a value', ->
|
||||
|
||||
(check-equal? (size (+Pointer uint8 uint8)) 1)
|
||||
|
||||
|
||||
; describe 'encode', ->
|
||||
; it 'should handle null pointers', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define ctx (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 0
|
||||
'pointers null))
|
||||
(encode (+Pointer uint8 uint8) #f #:parent ctx)
|
||||
(check-equal? (· ctx pointerSize) 0)
|
||||
(check-equal? (dump (current-output-port)) (bytes 0)))
|
||||
|
||||
|
||||
; it 'should handle local offsets', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define ctx (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 1
|
||||
'pointers null))
|
||||
(encode (+Pointer uint8 uint8) 10 #:parent ctx)
|
||||
(check-equal? (· ctx pointerOffset) 2)
|
||||
(check-equal? (· ctx pointers) (list (mhasheq 'type uint8
|
||||
'val 10
|
||||
'parent ctx)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 1)))
|
||||
|
||||
|
||||
; it 'should handle immediate offsets', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define ctx (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 1
|
||||
'pointers null))
|
||||
(encode (+Pointer uint8 uint8 (mhash 'type 'immediate)) 10 #:parent ctx)
|
||||
(check-equal? (· ctx pointerOffset) 2)
|
||||
(check-equal? (· ctx pointers) (list (mhasheq 'type uint8
|
||||
'val 10
|
||||
'parent ctx)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 0)))
|
||||
|
||||
|
||||
; it 'should handle offsets relative to parent', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define ctx (mhash 'parent (mhash 'pointerSize 0
|
||||
'startOffset 3
|
||||
'pointerOffset 5
|
||||
'pointers null)))
|
||||
(encode (+Pointer uint8 uint8 (mhash 'type 'parent)) 10 #:parent ctx)
|
||||
(check-equal? (· ctx parent pointerOffset) 6)
|
||||
(check-equal? (· ctx parent pointers) (list (mhasheq 'type uint8
|
||||
'val 10
|
||||
'parent ctx)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 2)))
|
||||
|
||||
|
||||
|
||||
; it 'should handle global offsets', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define ctx (mhash 'parent
|
||||
(mhash 'parent
|
||||
(mhash 'parent (mhash 'pointerSize 0
|
||||
'startOffset 3
|
||||
'pointerOffset 5
|
||||
'pointers null)))))
|
||||
(encode (+Pointer uint8 uint8 (mhash 'type 'global)) 10 #:parent ctx)
|
||||
(check-equal? (· ctx parent parent parent pointerOffset) 6)
|
||||
(check-equal? (· ctx parent parent parent pointers) (list (mhasheq 'type uint8
|
||||
'val 10
|
||||
'parent ctx)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 5)))
|
||||
|
||||
|
||||
; it 'should support offsets relative to a property on the parent', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define ctx (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 10
|
||||
'pointers null
|
||||
'val (mhash 'ptr 4)))
|
||||
(encode (+Pointer uint8 uint8 (mhash 'relativeTo (λ (ctx) (· ctx ptr)))) 10 #:parent ctx)
|
||||
(check-equal? (· ctx pointerOffset) 11)
|
||||
(check-equal? (· ctx pointers) (list (mhasheq 'type uint8
|
||||
'val 10
|
||||
'parent ctx)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 6)))
|
||||
|
||||
|
||||
; it 'should support void pointers', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define ctx (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 1
|
||||
'pointers null))
|
||||
(encode (+Pointer uint8 'void) (+VoidPointer uint8 55) #:parent ctx)
|
||||
(check-equal? (· ctx pointerOffset) 2)
|
||||
(check-equal? (· ctx pointers) (list (mhasheq 'type uint8
|
||||
'val 55
|
||||
'parent ctx)))
|
||||
(check-equal? (dump (current-output-port)) (bytes 1)))
|
||||
|
||||
|
||||
; it 'should throw if not a void pointer instance', ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define ctx (mhash 'pointerSize 0
|
||||
'startOffset 0
|
||||
'pointerOffset 1
|
||||
'pointers null))
|
||||
(check-exn exn:fail:contract? (λ () (encode (+Pointer uint8 'void) 44 #:parent ctx))))
|
||||
@ -0,0 +1,35 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
sugar/unstable/dict)
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Reserved.coffee
|
||||
|#
|
||||
|
||||
;describe 'Reserved', ->
|
||||
; it 'should have a default count of 1', ->
|
||||
|
||||
(check-equal? (size (+Reserved uint8)) 1)
|
||||
|
||||
|
||||
; it 'should allow custom counts and types', ->
|
||||
|
||||
(check-equal? (size (+Reserved uint16be 10)) 20)
|
||||
|
||||
|
||||
; it 'should decode', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (bytes 0 0))])
|
||||
(define reserved (+Reserved uint16be))
|
||||
(check-equal? (decode reserved) (void))
|
||||
(check-equal? (pos (current-input-port)) 2))
|
||||
|
||||
|
||||
; it 'should encode', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define reserved (+Reserved uint16be))
|
||||
(encode reserved #f)
|
||||
(check-equal? (dump (current-output-port)) (bytes 0 0)))
|
||||
@ -0,0 +1,131 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
sugar/unstable/dict)
|
||||
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/String.coffee
|
||||
|#
|
||||
|
||||
;describe 'String', ->
|
||||
; describe 'decode', ->
|
||||
; it 'should decode fixed length', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"testing")])
|
||||
(check-equal? (decode (+StringT 7)) "testing"))
|
||||
|
||||
|
||||
; it 'should decode length from parent key', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"testing")])
|
||||
(check-equal? (decode (+StringT 'len) #:parent (mhash 'len 7)) "testing"))
|
||||
|
||||
|
||||
; it 'should decode length as number before string', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x07testing")])
|
||||
(check-equal? (decode (+StringT uint8) #:parent (mhash 'len 7)) "testing"))
|
||||
|
||||
|
||||
;; it 'should decode utf8', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "🍻"))])
|
||||
(check-equal? (decode (+StringT 4 'utf8)) "🍻"))
|
||||
|
||||
;; it 'should decode encoding computed from function', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "🍻"))])
|
||||
(check-equal? (decode (+StringT 4 (λ _ 'utf8))) "🍻"))
|
||||
|
||||
|
||||
; it 'should decode null-terminated string and read past terminator', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "🍻\x00"))])
|
||||
(check-equal? (decode (+StringT #f 'utf8)) "🍻")
|
||||
(check-equal? (pos (current-input-port)) 5))
|
||||
|
||||
|
||||
; it 'should decode remainder of buffer when null-byte missing', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "🍻"))])
|
||||
(check-equal? (decode (+StringT #f 'utf8)) "🍻"))
|
||||
|
||||
|
||||
; describe 'size', ->
|
||||
; it 'should use string length', ->
|
||||
|
||||
(check-equal? (size (+StringT 7) "testing") 7)
|
||||
|
||||
|
||||
; it 'should use correct encoding', ->
|
||||
|
||||
(check-equal? (size (+StringT 10 'utf8) "🍻") 4)
|
||||
|
||||
|
||||
; it 'should use encoding from function', ->
|
||||
|
||||
(check-equal? (size (+StringT 10 (λ _ 'utf8)) "🍻") 4)
|
||||
|
||||
|
||||
; it 'should add size of length field before string', ->
|
||||
|
||||
(check-equal? (size (+StringT uint8 'utf8) "🍻") 5)
|
||||
|
||||
|
||||
; todo
|
||||
; it 'should work with utf16be encoding', ->
|
||||
|
||||
|
||||
; it 'should take null-byte into account', ->
|
||||
|
||||
(check-equal? (size (+StringT #f 'utf8) "🍻") 5)
|
||||
|
||||
|
||||
; it 'should use defined length if no value given', ->
|
||||
|
||||
(check-equal? (size (+StringT 10)) 10)
|
||||
|
||||
;
|
||||
; describe 'encode', ->
|
||||
; it 'should encode using string length', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+StringT 7) "testing")
|
||||
(check-equal? (dump (current-output-port)) #"testing"))
|
||||
|
||||
|
||||
; it 'should encode length as number before string', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+StringT uint8) "testing")
|
||||
(check-equal? (dump (current-output-port)) #"\x07testing"))
|
||||
|
||||
|
||||
; it 'should encode length as number before string utf8', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+StringT uint8 'utf8) "testing 😜")
|
||||
(check-equal? (dump (current-output-port)) (string->bytes/utf-8 "\x0ctesting 😜")))
|
||||
|
||||
|
||||
; it 'should encode utf8', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+StringT 4 'utf8) "🍻" )
|
||||
(check-equal? (dump (current-output-port)) (string->bytes/utf-8 "🍻")))
|
||||
|
||||
|
||||
; it 'should encode encoding computed from function', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+StringT 4 (λ _ 'utf8)) "🍻")
|
||||
(check-equal? (dump (current-output-port)) (string->bytes/utf-8 "🍻")))
|
||||
|
||||
|
||||
; it 'should encode null-terminated string', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(encode (+StringT #f 'utf8) "🍻" )
|
||||
(check-equal? (dump (current-output-port)) (string->bytes/utf-8 "🍻\x00")))
|
||||
@ -0,0 +1,126 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
racket/class
|
||||
sugar/unstable/dict
|
||||
sugar/unstable/js
|
||||
"../private/generic.rkt")
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/Struct.coffee
|
||||
|#
|
||||
|
||||
|
||||
;describe 'Struct', ->
|
||||
; describe 'decode', ->
|
||||
; it 'should decode into an object', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")])
|
||||
(check-equal?
|
||||
(dump (decode (+Struct (dictify 'name (+StringT uint8)
|
||||
'age uint8))))
|
||||
(hasheq 'name "roxyb" 'age 21)))
|
||||
|
||||
|
||||
|
||||
; it 'should support process hook', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x20")])
|
||||
(define struct (+Struct (dictify 'name (+StringT uint8)
|
||||
'age uint8)))
|
||||
(set-field! post-decode struct (λ (o . _) (ref-set! o 'canDrink (>= (· o age) 21)) o))
|
||||
(check-equal? (dump (decode struct))
|
||||
(hasheq 'name "roxyb" 'age 32 'canDrink #t)))
|
||||
|
||||
|
||||
|
||||
; it 'should support function keys', ->
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x20")])
|
||||
(define struct (+Struct (dictify 'name (+StringT uint8)
|
||||
'age uint8
|
||||
'canDrink (λ (o) (>= (ref o 'age) 21)))))
|
||||
(check-equal? (dump (decode struct))
|
||||
(hasheq 'name "roxyb" 'age 32 'canDrink #t)))
|
||||
|
||||
|
||||
|
||||
|
||||
;
|
||||
; describe 'size', ->
|
||||
; it 'should compute the correct size', ->
|
||||
|
||||
(check-equal? (size (+Struct (dictify
|
||||
'name (+StringT uint8)
|
||||
'age uint8))
|
||||
(hasheq 'name "roxyb" 'age 32)) 7)
|
||||
|
||||
|
||||
|
||||
; it 'should compute the correct size with pointers', ->
|
||||
|
||||
(check-equal? (size (+Struct (dictify
|
||||
'name (+StringT uint8)
|
||||
'age uint8
|
||||
'ptr (+Pointer uint8 (+StringT uint8))))
|
||||
(mhash 'name "roxyb" 'age 21 'ptr "hello")) 14)
|
||||
|
||||
|
||||
; it 'should get the correct size when no value is given', ->
|
||||
|
||||
(check-equal? (size (+Struct (dictify
|
||||
'name (+StringT 4)
|
||||
'age uint8))) 5)
|
||||
|
||||
; it 'should throw when getting non-fixed length size and no value is given', ->
|
||||
|
||||
(check-exn exn:fail:contract? (λ () (size (+Struct (dictify 'name (+StringT uint8)
|
||||
'age uint8)))))
|
||||
|
||||
|
||||
|
||||
;
|
||||
; describe 'encode', ->
|
||||
; it 'should encode objects to buffers', (done) ->
|
||||
; stream = new EncodeStream
|
||||
; stream.pipe concat (buf) ->
|
||||
; buf.should.deep.equal new Buffer '\x05roxyb\x15'
|
||||
; done()
|
||||
;
|
||||
; struct = new Struct
|
||||
; name: new StringT uint8
|
||||
; age: uint8
|
||||
;
|
||||
; struct.encode stream,
|
||||
; name: 'roxyb'
|
||||
; age: 21
|
||||
;
|
||||
; stream.end()
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")])
|
||||
(check-equal? (dump (decode (+Struct (dictify 'name (+StringT uint8)
|
||||
'age uint8))))
|
||||
(hasheq 'name "roxyb" 'age 21)))
|
||||
|
||||
|
||||
; it 'should support preEncode hook', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define struct (+Struct (dictify 'nameLength uint8
|
||||
'name (+StringT 'nameLength)
|
||||
'age uint8)))
|
||||
(set-field! pre-encode struct (λ (val port) (ref-set! val 'nameLength (length (ref val 'name))) val))
|
||||
(encode struct (mhasheq 'name "roxyb" 'age 21))
|
||||
(check-equal? (dump (current-output-port)) #"\x05roxyb\x15"))
|
||||
|
||||
|
||||
; it 'should encode pointer data after structure', (done) ->
|
||||
|
||||
(parameterize ([current-output-port (open-output-bytes)])
|
||||
(define struct (+Struct (dictify 'name (+StringT uint8)
|
||||
'age uint8
|
||||
'ptr (+Pointer uint8 (+StringT uint8)))))
|
||||
(encode struct (hasheq 'name "roxyb" 'age 21 'ptr "hello"))
|
||||
(check-equal? (dump (current-output-port)) #"\x05roxyb\x15\x08\x05hello"))
|
||||
|
||||
@ -0,0 +1,344 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
racket/class
|
||||
"../private/generic.rkt"
|
||||
sugar/unstable/dict)
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbutterick/restructure/blob/master/test/VersionedStruct.coffee
|
||||
|#
|
||||
|
||||
;describe 'VersionedStruct', ->
|
||||
; describe 'decode', ->
|
||||
; it 'should get version from number type', ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")])
|
||||
(check-equal? (dump (decode struct)) (hasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 0)))
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x01\x0aroxyb 🤘\x15\x00"))])
|
||||
(check-equal? (dump (decode struct)) (hasheq 'name "roxyb 🤘"
|
||||
'age 21
|
||||
'version 1
|
||||
'gender 0))))
|
||||
|
||||
|
||||
; it 'should throw for unknown version', ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05\x05roxyb\x15")])
|
||||
(check-exn exn:fail:contract? (λ () (decode struct)))))
|
||||
|
||||
|
||||
;
|
||||
; it 'should support common header block', ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
'header (dictify 'age uint8
|
||||
'alive uint8)
|
||||
0 (dictify 'name (+StringT uint8 'ascii))
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'gender uint8)))])
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x00\x15\x01\x05roxyb")])
|
||||
(check-equal? (dump (decode struct)) (hasheq 'name "roxyb"
|
||||
'age 21
|
||||
'alive 1
|
||||
'version 0)))
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x01\x15\x01\x0aroxyb 🤘\x00"))])
|
||||
(check-equal? (dump (decode struct)) (hasheq 'name "roxyb 🤘"
|
||||
'age 21
|
||||
'version 1
|
||||
'alive 1
|
||||
'gender 0))))
|
||||
|
||||
|
||||
; it 'should support parent version key', ->
|
||||
|
||||
(let ([struct (+VersionedStruct 'version
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x05roxyb\x15")])
|
||||
(check-equal? (dump (decode struct #:parent (mhash 'version 0))) (hasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 0)))
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes (string->bytes/utf-8 "\x0aroxyb 🤘\x15\x00"))])
|
||||
(check-equal? (dump (decode struct #:parent (mhash 'version 1))) (hasheq 'name "roxyb 🤘"
|
||||
'age 21
|
||||
'version 1
|
||||
'gender 0))))
|
||||
|
||||
|
||||
|
||||
;
|
||||
; it 'should support sub versioned structs', ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8))
|
||||
1 (dictify 'name (+StringT uint8)
|
||||
'isDessert uint8)))))])
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")])
|
||||
(check-equal? (dump (decode struct #:parent (mhash 'version 0))) (hasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 0)))
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x01\x00\x05pasta")])
|
||||
(check-equal? (dump (decode struct #:parent (mhash 'version 0))) (hasheq 'name "pasta"
|
||||
'version 0)))
|
||||
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x01\x01\x09ice cream\x01")])
|
||||
(check-equal? (dump (decode struct #:parent (mhash 'version 0))) (hasheq 'name "ice cream"
|
||||
'isDessert 1
|
||||
'version 1))))
|
||||
|
||||
|
||||
;
|
||||
; it 'should support process hook', ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
(set-field! post-decode struct (λ (o stream ctx) (ref-set! o 'processed "true") o))
|
||||
(parameterize ([current-input-port (open-input-bytes #"\x00\x05roxyb\x15")])
|
||||
(check-equal? (dump (decode struct)) (hasheq 'name "roxyb"
|
||||
'processed "true"
|
||||
'age 21
|
||||
'version 0))))
|
||||
|
||||
|
||||
;
|
||||
; describe 'size', ->
|
||||
; it 'should compute the correct size', ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
|
||||
(check-equal? (size struct (mhasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 0)) 8)
|
||||
|
||||
(check-equal? (size struct (mhasheq 'name "roxyb 🤘"
|
||||
'gender 0
|
||||
'age 21
|
||||
'version 1)) 14))
|
||||
|
||||
|
||||
|
||||
|
||||
;
|
||||
; it 'should throw for unknown version', ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
|
||||
(check-exn exn:fail:contract? (λ () (size struct (mhasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 5)))))
|
||||
|
||||
|
||||
;
|
||||
; it 'should support common header block', ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
'header (dictify 'age uint8
|
||||
'alive uint8)
|
||||
0 (dictify 'name (+StringT uint8 'ascii))
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'gender uint8)))])
|
||||
|
||||
(check-equal? (size struct (mhasheq 'name "roxyb"
|
||||
'age 21
|
||||
'alive 1
|
||||
'version 0)) 9)
|
||||
|
||||
(check-equal? (size struct (mhasheq 'name "roxyb 🤘"
|
||||
'gender 0
|
||||
'age 21
|
||||
'alive 1
|
||||
'version 1)) 15))
|
||||
|
||||
|
||||
|
||||
; it 'should compute the correct size with pointers', ->
|
||||
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'ptr (+Pointer uint8 (+StringT uint8)))))])
|
||||
|
||||
(check-equal? (size struct (mhasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 1
|
||||
'ptr "hello")) 15))
|
||||
|
||||
|
||||
;
|
||||
; it 'should throw if no value is given', ->
|
||||
|
||||
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))])
|
||||
|
||||
(check-exn exn:fail:contract? (λ () (size struct))))
|
||||
|
||||
|
||||
|
||||
; describe 'encode', ->
|
||||
; it 'should encode objects to buffers', (done) ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))]
|
||||
[port (open-output-bytes)])
|
||||
(encode struct (mhasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 0) port)
|
||||
(encode struct (mhasheq 'name "roxyb 🤘"
|
||||
'age 21
|
||||
'gender 0
|
||||
'version 1) port)
|
||||
(check-equal? (dump port) (string->bytes/utf-8 "\x00\x05roxyb\x15\x01\x0aroxyb 🤘\x15\x00")))
|
||||
|
||||
|
||||
;
|
||||
; it 'should throw for unknown version', ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))]
|
||||
[port (open-output-bytes)])
|
||||
(check-exn exn:fail:contract? (λ () (encode struct port (mhasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 5)))))
|
||||
|
||||
|
||||
|
||||
; it 'should support common header block', (done) ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
'header (dictify 'age uint8
|
||||
'alive uint8)
|
||||
0 (dictify 'name (+StringT uint8 'ascii))
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'gender uint8)))]
|
||||
[stream (open-output-bytes)])
|
||||
|
||||
(encode struct (mhasheq 'name "roxyb"
|
||||
'age 21
|
||||
'alive 1
|
||||
'version 0) stream)
|
||||
|
||||
(encode struct (mhasheq 'name "roxyb 🤘"
|
||||
'gender 0
|
||||
'age 21
|
||||
'alive 1
|
||||
'version 1) stream)
|
||||
|
||||
(check-equal? (dump stream) (string->bytes/utf-8 "\x00\x15\x01\x05roxyb\x01\x15\x01\x0aroxyb 🤘\x00")))
|
||||
|
||||
|
||||
|
||||
; it 'should encode pointer data after structure', (done) ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'ptr (+Pointer uint8 (+StringT uint8)))))]
|
||||
[stream (open-output-bytes)])
|
||||
(encode struct (mhasheq 'version 1
|
||||
'name "roxyb"
|
||||
'age 21
|
||||
'ptr "hello") stream)
|
||||
|
||||
(check-equal? (dump stream) (string->bytes/utf-8 "\x01\x05roxyb\x15\x09\x05hello")))
|
||||
|
||||
|
||||
|
||||
|
||||
; it 'should support preEncode hook', (done) ->
|
||||
|
||||
(let ([struct (+VersionedStruct uint8
|
||||
(dictify
|
||||
0 (dictify 'name (+StringT uint8 'ascii)
|
||||
'age uint8)
|
||||
1 (dictify 'name (+StringT uint8 'utf8)
|
||||
'age uint8
|
||||
'gender uint8)))]
|
||||
[stream (open-output-bytes)])
|
||||
(set-field! pre-encode struct (λ (val port) (ref-set! val 'version (if (ref val 'gender) 1 0)) val))
|
||||
(encode struct (mhasheq 'name "roxyb"
|
||||
'age 21
|
||||
'version 0) stream)
|
||||
(encode struct (mhasheq 'name "roxyb 🤘"
|
||||
'age 21
|
||||
'gender 0) stream)
|
||||
(check-equal? (dump stream) (string->bytes/utf-8 "\x00\x05roxyb\x15\x01\x0aroxyb 🤘\x15\x00")))
|
||||
@ -0,0 +1,155 @@
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/list
|
||||
sugar/unstable/class
|
||||
sugar/unstable/dict
|
||||
sugar/unstable/js
|
||||
racket/dict
|
||||
"struct.rkt"
|
||||
"private/generic.rkt"
|
||||
"private/helper.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbuttrackerick/restructure/blob/master/src/VersionedStruct.coffee
|
||||
|#
|
||||
|
||||
|
||||
(define-subclass Struct (VersionedStruct type [versions (dictify)])
|
||||
|
||||
(unless (for/or ([proc (list integer? procedure? xenomorph-base%? symbol?)])
|
||||
(proc type))
|
||||
(raise-argument-error 'VersionedStruct "integer, function, symbol, or Restructure object" type))
|
||||
(unless (and (dict? versions) (andmap (λ (val) (or (dict? val) (Struct? val))) (map cdr versions)))
|
||||
(raise-argument-error 'VersionedStruct "dict of dicts or Structs" versions))
|
||||
|
||||
(inherit _setup _parse-fields post-decode)
|
||||
(inherit-field fields)
|
||||
(field [forced-version #f]
|
||||
[versionGetter void]
|
||||
[versionSetter void])
|
||||
|
||||
(when (or (key? type) (procedure? type))
|
||||
(set-field! versionGetter this (if (procedure? type)
|
||||
type
|
||||
(λ (parent) (ref parent type))))
|
||||
(set-field! versionSetter this (if (procedure? type)
|
||||
type
|
||||
(λ (parent version) (ref-set! parent type version)))))
|
||||
|
||||
(define/override (decode stream [parent #f] [length 0])
|
||||
(define res (_setup stream parent length))
|
||||
|
||||
(ref-set! res 'version
|
||||
(cond
|
||||
[forced-version] ; for testing purposes: pass an explicit version
|
||||
[(or (key? type) (procedure? type))
|
||||
(unless parent
|
||||
(raise-argument-error 'VersionedStruct:decode "valid parent" parent))
|
||||
(versionGetter parent)]
|
||||
[else (send type decode stream)]))
|
||||
|
||||
(when (ref versions 'header)
|
||||
(_parse-fields stream res (ref versions 'header)))
|
||||
|
||||
(define fields (or (ref versions (ref res 'version)) (raise-argument-error 'VersionedStruct:decode "valid version key" (cons version (· this versions)))))
|
||||
|
||||
|
||||
(cond
|
||||
[(VersionedStruct? fields) (send fields decode stream parent)]
|
||||
[else
|
||||
(_parse-fields stream res fields)
|
||||
res]))
|
||||
|
||||
(define/public-final (force-version! version)
|
||||
(set! forced-version version))
|
||||
|
||||
(define/override (encode stream val [parent #f])
|
||||
(unless (hash? val)
|
||||
(raise-argument-error 'VersionedStruct:encode "hash" val))
|
||||
|
||||
(define ctx (mhash 'pointers empty
|
||||
'startOffset (pos stream)
|
||||
'parent parent
|
||||
'val val
|
||||
'pointerSize 0))
|
||||
|
||||
(ref-set! ctx 'pointerOffset (+ (pos stream) (size val ctx #f)))
|
||||
|
||||
(when (not (or (key? type) (procedure? type)))
|
||||
(send type encode stream (or forced-version (· val version))))
|
||||
|
||||
(when (ref versions 'header)
|
||||
(for ([(key type) (in-dict (ref versions 'header))])
|
||||
(send type encode stream (ref val key) ctx)))
|
||||
|
||||
(define fields (or (ref versions (or forced-version (· val version))) (raise-argument-error 'VersionedStruct:encode "valid version key" version)))
|
||||
|
||||
(unless (andmap (λ (key) (member key (ref-keys val))) (ref-keys fields))
|
||||
(raise-argument-error 'VersionedStruct:encode (format "hash that contains superset of Struct keys: ~a" (dict-keys fields)) (hash-keys val)))
|
||||
|
||||
(for ([(key type) (in-dict fields)])
|
||||
(send type encode stream (ref val key) ctx))
|
||||
|
||||
(for ([ptr (in-list (ref ctx 'pointers))])
|
||||
(send (ref ptr 'type) encode stream (ref ptr 'val) (ref ptr 'parent))))
|
||||
|
||||
|
||||
(define/override (size [val #f] [parent #f] [includePointers #t])
|
||||
(unless (or val forced-version)
|
||||
(raise-argument-error 'VersionedStruct:size "value" val))
|
||||
|
||||
(define ctx (mhash 'parent parent
|
||||
'val val
|
||||
'pointerSize 0))
|
||||
|
||||
(+ (if (not (or (key? type) (procedure? type)))
|
||||
(send type size (or forced-version (ref val 'version)) ctx)
|
||||
0)
|
||||
|
||||
(for/sum ([(key type) (in-dict (or (ref versions 'header) empty))])
|
||||
(send type size (and val (ref val key)) ctx))
|
||||
|
||||
(let ([fields (or (ref versions (or forced-version (ref val 'version)))
|
||||
(raise-argument-error 'VersionedStruct:encode "valid version key" version))])
|
||||
(for/sum ([(key type) (in-dict fields)])
|
||||
(send type size (and val (ref val key)) ctx)))
|
||||
|
||||
(if includePointers (ref ctx 'pointerSize) 0))))
|
||||
|
||||
#;(test-module
|
||||
(require "number.rkt")
|
||||
(define (random-pick xs) (list-ref xs (random (length xs))))
|
||||
(check-exn exn:fail:contract? (λ () (+VersionedStruct 42 42)))
|
||||
|
||||
;; make random versioned structs and make sure we can round trip
|
||||
#;(for ([i (in-range 1)])
|
||||
(define field-types (for/list ([i (in-range 1)])
|
||||
(random-pick (list uint8 uint16be uint16le uint32be uint32le double))))
|
||||
(define num-versions 20)
|
||||
(define which-struct (random num-versions))
|
||||
(define struct-versions (for/list ([v (in-range num-versions)])
|
||||
(cons v (for/list ([num-type (in-list field-types)])
|
||||
(cons (gensym) num-type)))))
|
||||
(define vs (+VersionedStruct which-struct struct-versions))
|
||||
(define struct-size (for/sum ([num-type (in-list (map cdr (ref struct-versions which-struct)))])
|
||||
(send num-type size)))
|
||||
(define bs (apply bytes (for/list ([i (in-range struct-size)])
|
||||
(random 256))))
|
||||
(check-equal? (send vs encode #f (send vs decode bs)) bs))
|
||||
|
||||
(define s (+Struct (dictify 'a uint8 'b uint8 'c uint8)))
|
||||
(check-equal? (send s size) 3)
|
||||
(define vs (+VersionedStruct uint8 (dictify 1 (dictify 'd s) 2 (dictify 'e s 'f s))))
|
||||
(send vs force-version! 1)
|
||||
(check-equal? (send vs size) 6)
|
||||
#|
|
||||
(define s2 (+Struct (dictify 'a vs)))
|
||||
(check-equal? (send s2 size) 6)
|
||||
(define vs2 (+VersionedStruct (λ (p) 2) (dictify 1 vs 2 vs)))
|
||||
(check-equal? (send vs2 size) 6)
|
||||
|#
|
||||
)
|
||||
|
||||
|
||||
@ -1,155 +1,108 @@
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/list
|
||||
sugar/unstable/class
|
||||
sugar/unstable/dict
|
||||
sugar/unstable/js
|
||||
(require "helper.rkt" "struct.rkt"
|
||||
racket/dict
|
||||
"struct.rkt"
|
||||
"private/generic.rkt"
|
||||
"private/helper.rkt")
|
||||
(provide (all-defined-out))
|
||||
sugar/unstable/dict)
|
||||
(provide (all-defined-out) decode/hash)
|
||||
|
||||
#|
|
||||
approximates
|
||||
https://github.com/mbuttrackerick/restructure/blob/master/src/VersionedStruct.coffee
|
||||
https://github.com/mbutterick/restructure/blob/master/src/VersionedStruct.coffee
|
||||
|#
|
||||
|
||||
|
||||
(define-subclass Struct (VersionedStruct type [versions (dictify)])
|
||||
|
||||
(unless (for/or ([proc (list integer? procedure? xenomorph-base%? symbol?)])
|
||||
(proc type))
|
||||
(raise-argument-error 'VersionedStruct "integer, function, symbol, or Restructure object" type))
|
||||
(unless (and (dict? versions) (andmap (λ (val) (or (dict? val) (Struct? val))) (map cdr versions)))
|
||||
(raise-argument-error 'VersionedStruct "dict of dicts or Structs" versions))
|
||||
|
||||
(inherit _setup _parse-fields post-decode)
|
||||
(inherit-field fields)
|
||||
(field [forced-version #f]
|
||||
[versionGetter void]
|
||||
[versionSetter void])
|
||||
|
||||
(when (or (key? type) (procedure? type))
|
||||
(set-field! versionGetter this (if (procedure? type)
|
||||
type
|
||||
(λ (parent) (ref parent type))))
|
||||
(set-field! versionSetter this (if (procedure? type)
|
||||
type
|
||||
(λ (parent version) (ref-set! parent type version)))))
|
||||
|
||||
(define/override (decode stream [parent #f] [length 0])
|
||||
(define res (_setup stream parent length))
|
||||
|
||||
(ref-set! res 'version
|
||||
(cond
|
||||
[forced-version] ; for testing purposes: pass an explicit version
|
||||
[(or (key? type) (procedure? type))
|
||||
(unless parent
|
||||
(raise-argument-error 'VersionedStruct:decode "valid parent" parent))
|
||||
(versionGetter parent)]
|
||||
[else (send type decode stream)]))
|
||||
|
||||
(when (ref versions 'header)
|
||||
(_parse-fields stream res (ref versions 'header)))
|
||||
(define/post-decode (xversioned-struct-decode xvs [port-arg (current-input-port)] #:parent [parent #f] [length 0])
|
||||
(define port (->input-port port-arg))
|
||||
(define res (_setup port parent length))
|
||||
|
||||
(dict-set! res 'version
|
||||
(cond
|
||||
[(integer? (xversioned-struct-type xvs)) (xversioned-struct-type xvs)]
|
||||
#;[forced-version] ; for testing purposes: pass an explicit version
|
||||
[(or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs)))
|
||||
(unless parent
|
||||
(raise-argument-error 'xversioned-struct-decode "valid parent" parent))
|
||||
((xversioned-struct-version-getter xvs) parent)]
|
||||
[else (decode (xversioned-struct-type xvs) port)]))
|
||||
|
||||
(when (dict-ref (xversioned-struct-versions xvs) 'header #f)
|
||||
(_parse-fields port res (dict-ref (xversioned-struct-versions xvs) 'header)))
|
||||
|
||||
(define fields (or (ref versions (ref res 'version)) (raise-argument-error 'VersionedStruct:decode "valid version key" (cons version (· this versions)))))
|
||||
|
||||
(define fields (or (dict-ref (xversioned-struct-versions xvs) (dict-ref res 'version #f) #f)
|
||||
(raise-argument-error 'xversioned-struct-decode "valid version key" (cons version (xversioned-struct-versions xvs)))))
|
||||
|
||||
(cond
|
||||
[(VersionedStruct? fields) (send fields decode stream parent)]
|
||||
[else
|
||||
(_parse-fields stream res fields)
|
||||
res]))
|
||||
|
||||
(define/public-final (force-version! version)
|
||||
(set! forced-version version))
|
||||
|
||||
(define/override (encode stream val [parent #f])
|
||||
(unless (hash? val)
|
||||
(raise-argument-error 'VersionedStruct:encode "hash" val))
|
||||
|
||||
(define ctx (mhash 'pointers empty
|
||||
'startOffset (pos stream)
|
||||
'parent parent
|
||||
'val val
|
||||
'pointerSize 0))
|
||||
|
||||
(ref-set! ctx 'pointerOffset (+ (pos stream) (size val ctx #f)))
|
||||
|
||||
(when (not (or (key? type) (procedure? type)))
|
||||
(send type encode stream (or forced-version (· val version))))
|
||||
|
||||
(when (ref versions 'header)
|
||||
(for ([(key type) (in-dict (ref versions 'header))])
|
||||
(send type encode stream (ref val key) ctx)))
|
||||
|
||||
(define fields (or (ref versions (or forced-version (· val version))) (raise-argument-error 'VersionedStruct:encode "valid version key" version)))
|
||||
|
||||
(unless (andmap (λ (key) (member key (ref-keys val))) (ref-keys fields))
|
||||
(raise-argument-error 'VersionedStruct:encode (format "hash that contains superset of Struct keys: ~a" (dict-keys fields)) (hash-keys val)))
|
||||
|
||||
(for ([(key type) (in-dict fields)])
|
||||
(send type encode stream (ref val key) ctx))
|
||||
|
||||
(for ([ptr (in-list (ref ctx 'pointers))])
|
||||
(send (ref ptr 'type) encode stream (ref ptr 'val) (ref ptr 'parent))))
|
||||
|
||||
(cond
|
||||
[(xversioned-struct? fields) (decode fields port #:parent parent)]
|
||||
[else (_parse-fields port res fields)
|
||||
res]))
|
||||
|
||||
(define/finalize-size (xversioned-struct-size xvs [val #f] #:parent [parent-arg #f] [include-pointers #t])
|
||||
(unless val
|
||||
(raise-argument-error 'xversioned-struct-size "value" val))
|
||||
(define parent (mhash 'parent parent-arg 'val val 'pointerSize 0))
|
||||
(define version-size
|
||||
(if (not (or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs))))
|
||||
(size (xversioned-struct-type xvs) (dict-ref val 'version) #:parent parent)
|
||||
0))
|
||||
(define header-size
|
||||
(for/sum ([(key type) (in-dict (or (dict-ref (xversioned-struct-versions xvs) 'header #f) null))])
|
||||
(size type (and val (dict-ref val key)) #:parent parent)))
|
||||
(define fields-size
|
||||
(let ([fields (or (dict-ref (xversioned-struct-versions xvs) (dict-ref val 'version))
|
||||
(raise-argument-error 'xversioned-struct-size "valid version key" version))])
|
||||
(for/sum ([(key type) (in-dict fields)])
|
||||
(size type (and val (dict-ref val key)) #:parent parent))))
|
||||
(define pointer-size (if include-pointers (dict-ref parent 'pointerSize) 0))
|
||||
(+ version-size header-size fields-size pointer-size))
|
||||
|
||||
(define/pre-encode (xversioned-struct-encode xvs val [port-arg (current-output-port)] #:parent [parent-arg #f])
|
||||
(define port (if (output-port? port-arg) port-arg (open-output-bytes)))
|
||||
(parameterize ([current-output-port port])
|
||||
(unless (dict? val)
|
||||
(raise-argument-error 'xversioned-struct-encode "dict" val))
|
||||
|
||||
(define parent (mhash 'pointers null
|
||||
'startOffset (pos port)
|
||||
'parent parent-arg
|
||||
'val val
|
||||
'pointerSize 0))
|
||||
(dict-set! parent 'pointerOffset (+ (pos port) (xversioned-struct-size xvs val #:parent parent #f)))
|
||||
|
||||
(when (not (or (symbol? (xversioned-struct-type xvs)) (procedure? (xversioned-struct-type xvs))))
|
||||
(encode (xversioned-struct-type xvs) (dict-ref val 'version #f)))
|
||||
|
||||
(when (dict-ref (xversioned-struct-versions xvs) 'header #f)
|
||||
(for ([(key type) (in-dict (dict-ref (xversioned-struct-versions xvs) 'header))])
|
||||
(encode type (dict-ref val key) #:parent parent)))
|
||||
|
||||
(define fields (or (dict-ref (xversioned-struct-versions xvs) (dict-ref val 'version #f))
|
||||
(raise-argument-error 'xversioned-struct-encode "valid version key" version)))
|
||||
|
||||
(unless (andmap (λ (key) (member key (dict-keys val))) (dict-keys fields))
|
||||
(raise-argument-error 'xversioned-struct-encode (format "hash that contains superset of Struct keys: ~a" (dict-keys fields)) (hash-keys val)))
|
||||
|
||||
(for ([(key type) (in-dict fields)])
|
||||
(encode type (dict-ref val key) #:parent parent))
|
||||
(for ([ptr (in-list (dict-ref parent 'pointers))])
|
||||
(encode (dict-ref ptr 'type) (dict-ref ptr 'val) #:parent (dict-ref ptr 'parent)))
|
||||
|
||||
(define/override (size [val #f] [parent #f] [includePointers #t])
|
||||
(unless (or val forced-version)
|
||||
(raise-argument-error 'VersionedStruct:size "value" val))
|
||||
|
||||
(define ctx (mhash 'parent parent
|
||||
'val val
|
||||
'pointerSize 0))
|
||||
(unless port-arg (get-output-bytes port))))
|
||||
|
||||
(+ (if (not (or (key? type) (procedure? type)))
|
||||
(send type size (or forced-version (ref val 'version)) ctx)
|
||||
0)
|
||||
|
||||
(for/sum ([(key type) (in-dict (or (ref versions 'header) empty))])
|
||||
(send type size (and val (ref val key)) ctx))
|
||||
|
||||
(let ([fields (or (ref versions (or forced-version (ref val 'version)))
|
||||
(raise-argument-error 'VersionedStruct:encode "valid version key" version))])
|
||||
(for/sum ([(key type) (in-dict fields)])
|
||||
(send type size (and val (ref val key)) ctx)))
|
||||
|
||||
(if includePointers (ref ctx 'pointerSize) 0))))
|
||||
|
||||
#;(test-module
|
||||
(require "number.rkt")
|
||||
(define (random-pick xs) (list-ref xs (random (length xs))))
|
||||
(check-exn exn:fail:contract? (λ () (+VersionedStruct 42 42)))
|
||||
|
||||
;; make random versioned structs and make sure we can round trip
|
||||
#;(for ([i (in-range 1)])
|
||||
(define field-types (for/list ([i (in-range 1)])
|
||||
(random-pick (list uint8 uint16be uint16le uint32be uint32le double))))
|
||||
(define num-versions 20)
|
||||
(define which-struct (random num-versions))
|
||||
(define struct-versions (for/list ([v (in-range num-versions)])
|
||||
(cons v (for/list ([num-type (in-list field-types)])
|
||||
(cons (gensym) num-type)))))
|
||||
(define vs (+VersionedStruct which-struct struct-versions))
|
||||
(define struct-size (for/sum ([num-type (in-list (map cdr (ref struct-versions which-struct)))])
|
||||
(send num-type size)))
|
||||
(define bs (apply bytes (for/list ([i (in-range struct-size)])
|
||||
(random 256))))
|
||||
(check-equal? (send vs encode #f (send vs decode bs)) bs))
|
||||
|
||||
(define s (+Struct (dictify 'a uint8 'b uint8 'c uint8)))
|
||||
(check-equal? (send s size) 3)
|
||||
(define vs (+VersionedStruct uint8 (dictify 1 (dictify 'd s) 2 (dictify 'e s 'f s))))
|
||||
(send vs force-version! 1)
|
||||
(check-equal? (send vs size) 6)
|
||||
#|
|
||||
(define s2 (+Struct (dictify 'a vs)))
|
||||
(check-equal? (send s2 size) 6)
|
||||
(define vs2 (+VersionedStruct (λ (p) 2) (dictify 1 vs 2 vs)))
|
||||
(check-equal? (send vs2 size) 6)
|
||||
|#
|
||||
)
|
||||
(struct xversioned-struct structish (type versions version-getter version-setter) #:transparent #:mutable
|
||||
#:methods gen:xenomorphic
|
||||
[(define decode xversioned-struct-decode)
|
||||
(define encode xversioned-struct-encode)
|
||||
(define size xversioned-struct-size)])
|
||||
|
||||
(define (+xversioned-struct type [versions (dictify)])
|
||||
(unless (for/or ([proc (list integer? procedure? xenomorphic? symbol?)])
|
||||
(proc type))
|
||||
(raise-argument-error '+xversioned-struct "integer, procedure, symbol, or xenomorphic" type))
|
||||
(unless (and (dict? versions) (andmap (λ (v) (or (dict? v) (structish? v))) (dict-values versions)))
|
||||
(raise-argument-error '+xversioned-struct "dict of dicts or structish" versions))
|
||||
(define version-getter (cond
|
||||
[(procedure? type) type]
|
||||
[(symbol? type) (λ (parent) (dict-ref parent type))]))
|
||||
(define version-setter (cond
|
||||
[(procedure? type) type]
|
||||
[(symbol? type) (λ (parent version) (dict-set! parent type version))]))
|
||||
(xversioned-struct type versions version-getter version-setter))
|
||||
|
||||
|
||||
Loading…
Reference in New Issue