1 ! Copyright (C) 2007 Elie CHAFTARI
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors arrays assocs byte-arrays combinators endian io
5 io.streams.string kernel make math math.parser namespaces pack
14 [ 0x7f bitand 0x80 bitor , ] keep -7 shift
22 : >128-ber ( n -- str )
24 [ 0x7f bitand , ] keep -7 shift
28 : tag-classes ( -- seq )
29 { "universal" "application" "context_specific" "private" } ;
31 : builtin-syntax ( -- hashtable )
43 { 13 "string" } ! relative OID
67 TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
73 ERROR: unsupported-tag-encoding id ;
76 elements get id>> 31 bitand
77 dup elements get tag<<
79 get-id unsupported-tag-encoding
83 get-id -6 shift tag-classes nth
84 elements get tagclass<< ;
88 zero? "primitive" "constructed" ?
89 elements get encoding<< ;
91 : set-content-length ( -- )
95 ] unless elements get contentlength<< ;
98 elements get contentlength>> read
99 elements get newobj<< ;
101 : set-objtype ( syntax -- )
102 builtin-syntax 2array [
103 elements get tagclass>> of
104 elements get encoding>> of
107 elements get objtype<<
115 : (read-array) ( -- )
117 elements get syntax>> read-ber
118 dup end = [ drop ] [ , (read-array) ] if
121 : read-array ( -- array ) [ (read-array) ] { } make ;
123 : set-case ( -- object )
124 elements get newobj>>
125 elements get objtype>> {
126 { "boolean" [ "\0" = not ] }
127 { "string" [ "" or ] }
128 { "integer" [ be> ] }
129 { "array" [ "" or [ read-array ] with-string-reader ] }
132 : set-id ( -- boolean )
133 read1 dup elements get id<< ;
135 : read-ber ( syntax -- object )
145 elements get syntax>> set-objtype
149 ! =========================================================
151 ! =========================================================
153 GENERIC: >ber ( obj -- byte-array )
154 M: fixnum >ber ( n -- byte-array )
155 >128-ber dup length 2 swap 2array
156 "cc" pack-native B{ } prepend-as ;
158 : >ber-enumerated ( n -- byte-array )
159 >128-ber dup length 10 swap 2array
160 "CC" pack-native B{ } prepend-as ;
162 : >ber-length-encoding ( n -- byte-array )
166 1array "I" pack-be 0 swap remove dup length
167 0x80 + 1array "C" pack-be B{ } prepend-as
170 ! =========================================================
172 ! =========================================================
174 M: bignum >ber ( n -- byte-array )
177 "range error in bignum" throw
179 2 swap 2array "CC" pack-native B{ } prepend-as
182 ! =========================================================
184 ! =========================================================
186 ! Universal octet-string has tag number 4, we should however
187 ! still be able to assign an arbitrary code number.
188 ! >ber words should be called within a with-ber.
193 : <tag> ( -- <tag> ) 4 tag boa ;
195 : with-ber ( quot -- )
196 [ <tag> tagnum ] dip with-variable ; inline
198 : set-tag ( value -- )
201 M: string >ber ( str -- byte-array )
202 tagnum get value>> 1array "C" pack-native swap dup
203 length >ber-length-encoding swapd append swap
206 : >ber-application-string ( n str -- byte-array )
207 [ 0x40 + set-tag ] dip >ber ;
209 : >ber-contextspecific-string ( n str -- byte-array )
210 [ 0x80 + set-tag ] dip >ber ;
212 ! =========================================================
214 ! =========================================================
216 : >ber-seq-internal ( array code -- byte-array )
217 1array "C" pack-native swap dup length >ber-length-encoding
218 swapd append swap [ number>string ] map { } concat-as append ;
220 M: array >ber ( array -- byte-array )
221 0x30 >ber-seq-internal ;
223 : >ber-set ( array -- byte-array )
224 0x31 >ber-seq-internal ;
226 : >ber-sequence ( array -- byte-array )
227 0x30 >ber-seq-internal ;
229 : >ber-appsequence ( array -- byte-array )
230 0x60 >ber-seq-internal ;
232 : >ber-contextspecific-array ( array -- byte-array )
233 0xA0 >ber-seq-internal ;