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 ;
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 ;
51 : <element> element construct-empty ;
53 : set-id ( -- boolean )
54 read1 dup elements get set-element-id ;
57 elements get element-id ;
60 elements get element-id 31 bitand
61 dup elements get set-element-tag
63 [ "unsupported tag encoding: #{" %
69 get-id -6 shift tag-classes nth
70 elements get set-element-tagclass ;
74 zero? "primitive" "constructed" ?
75 elements get set-element-encoding ;
77 : set-content-length ( -- )
81 ] unless elements get set-element-contentlength ;
84 elements get element-contentlength read
85 elements get set-element-newobj ;
87 : set-objtype ( syntax -- )
88 builtin-syntax 2array [
89 elements get element-tagclass swap at
90 elements get element-encoding swap at
91 elements get element-tag
93 elements get set-element-objtype
101 : (read-array) ( stream -- )
102 elements get element-id [
103 elements get element-syntax read-ber
104 dup end = [ drop ] [ , (read-array) ] if
107 : read-array ( -- array ) [ (read-array) ] { } make ;
110 elements get element-newobj
111 elements get element-objtype {
112 { "boolean" [ "\0" = not ] }
113 { "string" [ "" or ] }
114 { "integer" [ be> ] }
115 { "array" [ "" or [ read-array ] with-string-reader ] }
118 : read-ber ( syntax -- object )
119 <element> elements set
120 elements get set-element-syntax
127 elements get element-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 construct-boa ;
177 : with-ber ( quot -- )
181 ] with-scope ; inline
183 : set-tag ( value -- )
184 tagnum get set-tag-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 ;