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" } ;
: (set-tag) ( -- )
elements get id>> 31 bitand
- dup elements get (>>tag)
+ dup elements get tag<<
31 < [
[ "unsupported tag encoding: #{" %
get-id # "}" %
: set-tagclass ( -- )
get-id -6 shift tag-classes nth
- elements get (>>tagclass) ;
+ elements get tagclass<< ;
: set-encoding ( -- )
- get-id HEX: 20 bitand
+ get-id 0x20 bitand
zero? "primitive" "constructed" ?
- elements get (>>encoding) ;
+ elements get encoding<< ;
: set-content-length ( -- )
read1
dup 127 <= [
127 bitand read be>
- ] unless elements get (>>contentlength) ;
+ ] unless elements get contentlength<< ;
: set-newobj ( -- )
elements get contentlength>> read
- elements get (>>newobj) ;
+ elements get newobj<< ;
: set-objtype ( syntax -- )
builtin-syntax 2array [
elements get encoding>> swap at
elements get tag>>
swap at [
- elements get (>>objtype)
+ elements get objtype<<
] when*
] each ;
} case ;
: set-id ( -- boolean )
- read1 dup elements get (>>id) ;
+ read1 dup elements get id<< ;
: read-ber ( syntax -- object )
element new
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 (>>value) ;
+ tagnum get value<< ;
M: string >ber ( str -- byte-array )
tagnum get value>> 1array "C" pack-native swap dup
>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 ;