USING: arrays asn1.ldap assocs byte-arrays combinators
continuations io io.binary io.streams.string kernel math
-math.parser namespaces pack strings sequences ;
+math.parser namespaces make pack strings sequences accessors ;
IN: asn1
+<PRIVATE
+
+: (>128-ber) ( n -- )
+ dup 0 > [
+ [ 0x7f bitand 0x80 bitor , ] keep -7 shift
+ (>128-ber)
+ ] [
+ drop
+ ] if ;
+
+PRIVATE>
+
+: >128-ber ( n -- str )
+ [
+ [ 0x7f bitand , ] keep -7 shift
+ (>128-ber)
+ ] { } make reverse ;
+
: tag-classes ( -- seq )
{ "universal" "application" "context_specific" "private" } ;
TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
-: <element> element new ;
-
-: set-id ( -- boolean )
- read1 dup elements get set-element-id ;
: get-id ( -- id )
- elements get element-id ;
+ elements get id>> ;
: (set-tag) ( -- )
- elements get element-id 31 bitand
- dup elements get set-element-tag
+ elements get id>> 31 bitand
+ dup elements get tag<<
31 < [
[ "unsupported tag encoding: #{" %
get-id # "}" %
: set-tagclass ( -- )
get-id -6 shift tag-classes nth
- elements get set-element-tagclass ;
+ elements get tagclass<< ;
: set-encoding ( -- )
- get-id HEX: 20 bitand
+ get-id 0x20 bitand
zero? "primitive" "constructed" ?
- elements get set-element-encoding ;
+ elements get encoding<< ;
: set-content-length ( -- )
read1
dup 127 <= [
127 bitand read be>
- ] unless elements get set-element-contentlength ;
+ ] unless elements get contentlength<< ;
: set-newobj ( -- )
- elements get element-contentlength read
- elements get set-element-newobj ;
+ elements get contentlength>> read
+ elements get newobj<< ;
: set-objtype ( syntax -- )
builtin-syntax 2array [
- elements get element-tagclass swap at
- elements get element-encoding swap at
- elements get element-tag
+ elements get tagclass>> swap at
+ elements get encoding>> swap at
+ elements get tag>>
swap at [
- elements get set-element-objtype
+ elements get objtype<<
] when*
] each ;
SYMBOL: end
-: (read-array) ( stream -- )
- elements get element-id [
- elements get element-syntax read-ber
+: (read-array) ( -- )
+ elements get id>> [
+ elements get syntax>> read-ber
dup end = [ drop ] [ , (read-array) ] if
] when ;
: read-array ( -- array ) [ (read-array) ] { } make ;
-: set-case ( -- )
- elements get element-newobj
- elements get element-objtype {
+: set-case ( -- object )
+ elements get newobj>>
+ elements get objtype>> {
{ "boolean" [ "\0" = not ] }
{ "string" [ "" or ] }
{ "integer" [ be> ] }
{ "array" [ "" or [ read-array ] with-string-reader ] }
} case ;
+: set-id ( -- boolean )
+ read1 dup elements get id<< ;
+
: read-ber ( syntax -- object )
- <element> elements set
- elements get set-element-syntax
+ element new
+ swap >>syntax
+ elements set
set-id [
(set-tag)
set-tagclass
set-encoding
set-content-length
set-newobj
- elements get element-syntax set-objtype
+ elements get syntax>> set-objtype
set-case
] [ end ] if ;
1array "C" pack-be
] [
1array "I" pack-be 0 swap remove dup length
- HEX: 80 + 1array "C" pack-be prepend
+ 0x80 + 1array "C" pack-be prepend
] if ;
! =========================================================
] with-scope ; inline
: set-tag ( value -- )
- tagnum get set-tag-value ;
+ tagnum get value<< ;
M: string >ber ( str -- byte-array )
- tagnum get tag-value 1array "C" pack-native swap dup
+ tagnum get value>> 1array "C" pack-native swap dup
length >ber-length-encoding swapd append swap
>byte-array append ;
: >ber-application-string ( n str -- byte-array )
- >r HEX: 40 + set-tag r> >ber ;
+ [ 0x40 + set-tag ] dip >ber ;
-GENERIC: >ber-contextspecific ( n obj -- byte-array )
-M: string >ber-contextspecific ( n str -- byte-array )
- >r HEX: 80 + set-tag r> >ber ;
+: >ber-contextspecific-string ( n str -- byte-array )
+ [ 0x80 + set-tag ] dip >ber ;
! =========================================================
! Array
swapd append swap [ number>string ] map "" join >array append ;
M: array >ber ( array -- byte-array )
- HEX: 30 >ber-seq-internal ;
+ 0x30 >ber-seq-internal ;
: >ber-set ( array -- byte-array )
- HEX: 31 >ber-seq-internal ;
+ 0x31 >ber-seq-internal ;
: >ber-sequence ( array -- byte-array )
- HEX: 30 >ber-seq-internal ;
+ 0x30 >ber-seq-internal ;
: >ber-appsequence ( array -- byte-array )
- HEX: 60 >ber-seq-internal ;
+ 0x60 >ber-seq-internal ;
-M: array >ber-contextspecific ( array -- byte-array )
- HEX: A0 >ber-seq-internal ;
+: >ber-contextspecific-array ( array -- byte-array )
+ 0xA0 >ber-seq-internal ;