goodbye
parent
c9dd1f7321
commit
964ced9cdf
@ -1,123 +0,0 @@
|
||||
#lang debug racket/base
|
||||
(require racket/class
|
||||
sugar/unstable/class
|
||||
racket/generic
|
||||
racket/private/generic-methods
|
||||
"private/generic.rkt"
|
||||
racket/port
|
||||
racket/dict)
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define-generics posable
|
||||
(pos posable [new-pos])
|
||||
#:defaults
|
||||
([port? (define (pos p [new-pos #f]) (when new-pos
|
||||
(file-position p new-pos))
|
||||
(file-position p))]))
|
||||
|
||||
(define posable<%>
|
||||
(interface* ()
|
||||
([(generic-property gen:posable)
|
||||
(generic-method-table gen:posable
|
||||
(define (pos o [new-pos #f]) (send o pos new-pos)))])))
|
||||
|
||||
(define-generics codable
|
||||
(decode codable #:parent [parent] [stream])
|
||||
(encode codable [val] [stream] #:parent [parent]))
|
||||
|
||||
|
||||
(define codable<%>
|
||||
(interface* ()
|
||||
([(generic-property gen:codable)
|
||||
(generic-method-table gen:codable
|
||||
(define (decode o [port (current-input-port)] #:parent [parent #f])
|
||||
(send o decode port parent))
|
||||
(define (encode o [val #f] [port (current-output-port)] #:parent [parent #f])
|
||||
(when (port? val)
|
||||
(raise-argument-error 'encode "encodable value" val))
|
||||
(send o encode port val parent)))])))
|
||||
|
||||
|
||||
(define-generics sizable
|
||||
(size sizable [val] [parent]))
|
||||
|
||||
(define sizable<%>
|
||||
(interface* ()
|
||||
([(generic-property gen:sizable)
|
||||
(generic-method-table gen:sizable
|
||||
(define (size o [val #f] [parent #f]) (send o size val parent)))])))
|
||||
|
||||
(define (dump x)
|
||||
(define (dump-dict x)
|
||||
(for/list ([(k v) (in-dict x)])
|
||||
(cons (dump k) (dump v))))
|
||||
(let loop ([x x])
|
||||
(cond
|
||||
[(input-port? x) (port->bytes x)]
|
||||
[(output-port? x) (get-output-bytes x)]
|
||||
[(and (object? x)
|
||||
(memq 'dump (interface->method-names (object-interface x)))) (send x dump)]
|
||||
[(dict? x) (dump-dict x)]
|
||||
[(list? x) (map loop x)]
|
||||
[else x])))
|
||||
|
||||
#;(define dumpable<%>
|
||||
(interface* ()
|
||||
([(generic-property gen:dumpable)
|
||||
(generic-method-table gen:dumpable
|
||||
(define (dump o) (send o dump)))])))
|
||||
|
||||
(define (symbol-append . syms)
|
||||
(string->symbol (apply string-append (map symbol->string syms))))
|
||||
|
||||
(define xenomorph-base%
|
||||
(class* object% (codable<%> sizable<%>)
|
||||
(super-new)
|
||||
(field [_hash (make-hash)]
|
||||
[_list null])
|
||||
|
||||
(define/pubment (decode port [parent #f] . args)
|
||||
;; todo: is `indexable?` really a necessary condition? doesn't seem to break anything withou it
|
||||
#;(when parent (unless (indexable? parent)
|
||||
#;(raise-argument-error (symbol-append (get-class-name) ':decode) "indexable" parent)))
|
||||
(define ip (cond
|
||||
[(bytes? port) (open-input-bytes port)]
|
||||
[(input-port? port) port]
|
||||
[else (raise-argument-error (symbol-append (get-class-name) ':decode) "bytes or input port" port)]))
|
||||
(post-decode (inner (void) decode ip parent) port parent . args))
|
||||
|
||||
(define/pubment (encode port val-in [parent #f] . args)
|
||||
#;(report* port val-in parent)
|
||||
(define val (pre-encode val-in port))
|
||||
#;(when parent (unless (indexable? parent)
|
||||
(raise-argument-error (symbol-append (get-class-name) ':encode) "indexable" parent)))
|
||||
(define op (cond
|
||||
[(output-port? port) port]
|
||||
[(not port) (open-output-bytes)]
|
||||
[else (raise-argument-error 'Xenomorph "output port or #f" port)]))
|
||||
(define encode-result (inner (void) encode op val parent . args))
|
||||
(when (bytes? encode-result)
|
||||
(write-bytes encode-result op))
|
||||
(when (not port) (get-output-bytes op)))
|
||||
|
||||
(define/pubment (size [val #f] [parent #f] . args)
|
||||
(when parent (unless (indexable? parent)
|
||||
(raise-argument-error (symbol-append (get-class-name) ':size) "indexable" parent)))
|
||||
(define result (inner (void) size val parent . args))
|
||||
(cond
|
||||
[(void? result) 0]
|
||||
[(and (integer? result) (not (negative? result))) result]
|
||||
[else (raise-argument-error (symbol-append (get-class-name) ':size) "nonnegative integer" result)]))
|
||||
|
||||
(define/public (get-class-name) (define-values (name _) (object-info this))
|
||||
(or name 'Xenomorph))
|
||||
|
||||
(define/public (post-decode val . _) val)
|
||||
(define/public (pre-encode val . _) val)
|
||||
(define/public (dump) (void))))
|
||||
|
||||
(define-class-predicates xenomorph-base%)
|
||||
|
||||
(define-subclass xenomorph-base% (RestructureBase))
|
||||
(define-subclass RestructureBase (Streamcoder))
|
||||
|
||||
@ -1,49 +0,0 @@
|
||||
#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"))
|
||||
@ -1,60 +0,0 @@
|
||||
#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))
|
||||
@ -1,26 +0,0 @@
|
||||
#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)))
|
||||
|
||||
@ -1,4 +0,0 @@
|
||||
#lang info
|
||||
|
||||
(define scribblings '(("scribblings/xenomorph.scrbl" ())))
|
||||
(define compile-omit-paths '("test/"))
|
||||
@ -1,83 +0,0 @@
|
||||
#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)))
|
||||
|
||||
@ -1,18 +0,0 @@
|
||||
#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")
|
||||
@ -1,30 +0,0 @@
|
||||
#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))))
|
||||
|
||||
@ -1,107 +0,0 @@
|
||||
#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))
|
||||
@ -1,23 +0,0 @@
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base br/syntax) racket/class br/define "../base.rkt")
|
||||
(provide (all-defined-out) (all-from-out "../base.rkt"))
|
||||
|
||||
|
||||
(define-macro (test-module . EXPRS)
|
||||
#`(module+ test
|
||||
(require #,(datum->syntax caller-stx 'rackunit) #,(datum->syntax caller-stx 'racket/serialize))
|
||||
. EXPRS))
|
||||
|
||||
(define index? (λ (x) (and (number? x) (integer? x) (not (negative? x)))))
|
||||
|
||||
(define key? symbol?)
|
||||
(define (keys? x) (and (pair? x) (andmap key? x)))
|
||||
|
||||
(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)))
|
||||
|
||||
(struct LazyThunk (proc) #:transparent)
|
||||
@ -1,24 +0,0 @@
|
||||
#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)))
|
||||
|
||||
@ -1,36 +0,0 @@
|
||||
#lang racket/base
|
||||
(require "private/helper.rkt")
|
||||
(provide type-sizes get-type-size)
|
||||
|
||||
(define-values (int-keys byte-values) (for*/lists (int-keys byte-values)
|
||||
([signed (in-list '("u" ""))]
|
||||
[bit-size (in-list '(8 16 24 32))])
|
||||
(values (format "~aint~a" signed bit-size) (/ bit-size 8))))
|
||||
|
||||
(define type-sizes (for/hash ([type-key (in-list (append '("float" "double") int-keys))]
|
||||
[byte-value (in-list (append '(4 8) byte-values))]
|
||||
#:when #t
|
||||
[endian (in-list '("" "be" "le"))])
|
||||
(values (string->symbol (string-append type-key endian)) byte-value)))
|
||||
|
||||
(define (get-type-size key)
|
||||
(hash-ref type-sizes key (λ () (raise-argument-error 'DecodeStream:get-type-size "valid type" key))))
|
||||
|
||||
(test-module
|
||||
(check-equal? (get-type-size 'int8) 1)
|
||||
(check-equal? (get-type-size 'uint8) 1)
|
||||
(check-equal? (get-type-size 'uint8be) 1)
|
||||
(check-equal? (get-type-size 'int16) 2)
|
||||
(check-equal? (get-type-size 'uint16) 2)
|
||||
(check-equal? (get-type-size 'uint16be) 2)
|
||||
(check-equal? (get-type-size 'uint16le) 2)
|
||||
(check-equal? (get-type-size 'uint32) 4)
|
||||
(check-equal? (get-type-size 'uint32le) 4)
|
||||
(check-equal? (get-type-size 'int32be) 4)
|
||||
(check-equal? (get-type-size 'float) 4)
|
||||
(check-equal? (get-type-size 'floatle) 4)
|
||||
(check-equal? (get-type-size 'floatbe) 4)
|
||||
(check-equal? (get-type-size 'double) 8)
|
||||
(check-equal? (get-type-size 'doublele) 8)
|
||||
(check-equal? (get-type-size 'doublebe) 8)
|
||||
(check-exn exn:fail:contract? (λ () (get-type-size 'not-a-type))))
|
||||
@ -1,91 +0,0 @@
|
||||
#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))
|
||||
@ -1,51 +0,0 @@
|
||||
#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)))
|
||||
@ -1,46 +0,0 @@
|
||||
#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))
|
||||
@ -1,37 +0,0 @@
|
||||
#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))))
|
||||
@ -1,14 +0,0 @@
|
||||
#lang racket/base
|
||||
|
||||
(require "array-test.rkt"
|
||||
"bitfield-test.rkt"
|
||||
"buffer-test.rkt"
|
||||
"enum-test.rkt"
|
||||
"lazy-array-test.rkt"
|
||||
"number-test.rkt"
|
||||
"optional-test.rkt"
|
||||
"pointer-test.rkt"
|
||||
"reserved-test.rkt"
|
||||
"string-test.rkt"
|
||||
"struct-test.rkt"
|
||||
"versioned-struct-test.rkt")
|
||||
@ -1,339 +0,0 @@
|
||||
#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))
|
||||
@ -1,116 +0,0 @@
|
||||
#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)))
|
||||
@ -1,239 +0,0 @@
|
||||
#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))))
|
||||
@ -1,35 +0,0 @@
|
||||
#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)))
|
||||
@ -1,131 +0,0 @@
|
||||
#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")))
|
||||
@ -1,126 +0,0 @@
|
||||
#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"))
|
||||
|
||||
@ -1,21 +0,0 @@
|
||||
#lang racket/base
|
||||
(require rackunit
|
||||
xenomorph
|
||||
racket/class)
|
||||
|
||||
(define Person
|
||||
(make-object Struct
|
||||
(list (cons 'name (make-object StringT uint8 'utf8))
|
||||
(cons 'age uint8))))
|
||||
|
||||
;; decode a person from a port
|
||||
(define ip (open-input-bytes #"\4MikeA"))
|
||||
(define x (send Person decode ip))
|
||||
|
||||
(module+ test
|
||||
(check-equal? (dict-ref x 'name) "Mike")
|
||||
(check-equal? (dict-ref x 'age) 65))
|
||||
|
||||
;; encode a person from a hash
|
||||
(module+ test
|
||||
(check-equal? (send Person encode #f (hasheq 'name "Mike" 'age 65)) #"\4MikeA"))
|
||||
@ -1,344 +0,0 @@
|
||||
#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")))
|
||||
@ -1,15 +0,0 @@
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
"number.rkt"
|
||||
"private/generic.rkt"
|
||||
"private/helper.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define (resolve-length len-arg [stream #f] [parent #f])
|
||||
(cond
|
||||
[(not len-arg) #f]
|
||||
[(number? len-arg) len-arg]
|
||||
[(procedure? len-arg) (len-arg parent)]
|
||||
[(and parent (key? len-arg)) (ref parent len-arg)] ; treat as key into RStruct parent
|
||||
[(and stream (NumberT? len-arg)) (send len-arg decode stream)]
|
||||
[else (raise-argument-error 'resolveLength "fixed-size argument" len-arg)]))
|
||||
@ -1,155 +0,0 @@
|
||||
#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)
|
||||
|#
|
||||
)
|
||||
|
||||
|
||||
Loading…
Reference in New Issue