1 ! Copyright (C) 2007 Elie CHAFTARI
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: arrays asn1.ldap assocs byte-arrays combinators
5 continuations io io.binary io.streams.string kernel math
6 math.parser namespaces pack strings sequences accessors ;
10 : tag-classes ( -- seq )
11 { "universal" "application" "context_specific" "private" } ;
13 : builtin-syntax ( -- hashtable )
25 { 13 "string" } ! relative OID
49 TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
56 elements get id>> 31 bitand
57 dup elements get (>>tag)
59 [ "unsupported tag encoding: #{" %
65 get-id -6 shift tag-classes nth
66 elements get (>>tagclass) ;
70 zero? "primitive" "constructed" ?
71 elements get (>>encoding) ;
73 : set-content-length ( -- )
77 ] unless elements get (>>contentlength) ;
80 elements get contentlength>> read
81 elements get (>>newobj) ;
83 : set-objtype ( syntax -- )
84 builtin-syntax 2array [
85 elements get tagclass>> swap at
86 elements get encoding>> swap at
89 elements get (>>objtype)
99 elements get syntax>> read-ber
100 dup end = [ drop ] [ , (read-array) ] if
103 : read-array ( -- array ) [ (read-array) ] { } make ;
105 : set-case ( -- object )
106 elements get newobj>>
107 elements get objtype>> {
108 { "boolean" [ "\0" = not ] }
109 { "string" [ "" or ] }
110 { "integer" [ be> ] }
111 { "array" [ "" or [ read-array ] with-string-reader ] }
114 : set-id ( -- boolean )
115 read1 dup elements get (>>id) ;
117 : read-ber ( syntax -- object )
127 elements get syntax>> set-objtype
131 ! =========================================================
133 ! =========================================================
135 GENERIC: >ber ( obj -- byte-array )
136 M: fixnum >ber ( n -- byte-array )
137 >128-ber dup length 2 swap 2array
138 "cc" pack-native prepend ;
140 : >ber-enumerated ( n -- byte-array )
141 >128-ber >byte-array dup length 10 swap 2array
142 "CC" pack-native prepend ;
144 : >ber-length-encoding ( n -- byte-array )
148 1array "I" pack-be 0 swap remove dup length
149 HEX: 80 + 1array "C" pack-be prepend
152 ! =========================================================
154 ! =========================================================
156 M: bignum >ber ( n -- byte-array )
157 >128-ber >byte-array dup length
159 "range error in bignum" throw
161 2 swap 2array "CC" pack-native prepend
164 ! =========================================================
166 ! =========================================================
168 ! Universal octet-string has tag number 4, we should however
169 ! still be able to assign an arbitrary code number.
170 ! >ber words should be called within a with-ber.
175 : <tag> ( -- <tag> ) 4 tag boa ;
177 : with-ber ( quot -- )
181 ] with-scope ; inline
183 : set-tag ( value -- )
184 tagnum get (>>value) ;
186 M: string >ber ( str -- byte-array )
187 tagnum get tag-value 1array "C" pack-native swap dup
188 length >ber-length-encoding swapd append swap
191 : >ber-application-string ( n str -- byte-array )
192 >r HEX: 40 + set-tag r> >ber ;
194 GENERIC: >ber-contextspecific ( n obj -- byte-array )
195 M: string >ber-contextspecific ( n str -- byte-array )
196 >r HEX: 80 + set-tag r> >ber ;
198 ! =========================================================
200 ! =========================================================
202 : >ber-seq-internal ( array code -- byte-array )
203 1array "C" pack-native swap dup length >ber-length-encoding
204 swapd append swap [ number>string ] map "" join >array append ;
206 M: array >ber ( array -- byte-array )
207 HEX: 30 >ber-seq-internal ;
209 : >ber-set ( array -- byte-array )
210 HEX: 31 >ber-seq-internal ;
212 : >ber-sequence ( array -- byte-array )
213 HEX: 30 >ber-seq-internal ;
215 : >ber-appsequence ( array -- byte-array )
216 HEX: 60 >ber-seq-internal ;
218 M: array >ber-contextspecific ( array -- byte-array )
219 HEX: A0 >ber-seq-internal ;