]> wagner.pp.ru Git - openssl-gost/engine.git/blob - tcl_tests/asn.tcl
gost_crypt: Add magma_ctr_acpkm_omac_cipher
[openssl-gost/engine.git] / tcl_tests / asn.tcl
1 #-----------------------------------------------------------------------------
2 #   Copyright (C) 1999-2004 Jochen C. Loewer (loewerj@web.de)
3 #   Copyright (C) 2004-2006 Michael Schlenker (mic42@users.sourceforge.net)
4 #-----------------------------------------------------------------------------
5 #   
6 #   A partial ASN decoder/encoder implementation in plain Tcl. 
7 #
8 #   See ASN.1 (X.680) and BER (X.690).
9 #   See 'asn_ber_intro.txt' in this directory.
10 #
11 #   This software is copyrighted by Jochen C. Loewer (loewerj@web.de). The 
12 #   following terms apply to all files associated with the software unless 
13 #   explicitly disclaimed in individual files.
14 #
15 #   The authors hereby grant permission to use, copy, modify, distribute,
16 #   and license this software and its documentation for any purpose, provided
17 #   that existing copyright notices are retained in all copies and that this
18 #   notice is included verbatim in any distributions. No written agreement,
19 #   license, or royalty fee is required for any of the authorized uses.
20 #   Modifications to this software may be copyrighted by their authors
21 #   and need not follow the licensing terms described here, provided that
22 #   the new terms are clearly indicated on the first page of each file where
23 #   they apply.
24 #  
25 #   IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
26 #   FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
27 #   ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
28 #   DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
29 #   POSSIBILITY OF SUCH DAMAGE.
30 #
31 #   THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
32 #   INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
33 #   FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT.  THIS SOFTWARE
34 #   IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
35 #   NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
36 #   MODIFICATIONS.
37 #
38 #   written by Jochen Loewer
39 #   3 June, 1999
40 #
41 #   $Id: asn.tcl,v 1.1 2012-04-04 10:50:38 igus Exp $
42 #
43 #-----------------------------------------------------------------------------
44
45 # needed for using wide()
46 package require Tcl 8.4
47
48 namespace eval asn {
49     # Encoder commands
50     namespace export \
51         asnSequence \
52         asnSequenceFromList \
53         asnSet \
54         asnSetFromList \
55         asnApplicationConstr \
56         asnApplication \
57         asnContext\
58         asnContextConstr\
59         asnChoice \
60         asnChoiceConstr \
61         asnInteger \
62         asnEnumeration \
63         asnBoolean \
64         asnOctetString \
65         asnUTCTime \
66         asnNumericString \
67         asnPrintableString \
68         asnIA5String\
69         asnBMPString\
70         asnUTF8String\
71         asnBitString \
72         asnObjectIdentifer 
73         
74     # Decoder commands
75     namespace export \
76         asnGetResponse \
77         asnGetInteger \
78         asnGetEnumeration \
79         asnGetOctetString \
80         asnGetSequence \
81         asnGetSet \
82         asnGetApplication \
83         asnGetNumericString \
84         asnGetPrintableString \
85         asnGetIA5String \
86         asnGetBMPString \
87         asnGetUTF8String \
88         asnGetObjectIdentifier \
89         asnGetBoolean \
90         asnGetUTCTime \
91         asnGetBitString \
92         asnGetContext 
93     
94     # general BER utility commands    
95     namespace export \
96         asnPeekByte  \
97         asnGetLength \
98         asnRetag         
99         
100 }
101
102 #-----------------------------------------------------------------------------
103 # Implementation notes:
104 #
105 # See the 'asn_ber_intro.txt' in this directory for an introduction
106 # into BER/DER encoding of ASN.1 information. Bibliography information
107 #
108 #   A Layman's Guide to a Subset of ASN.1, BER, and DER
109 #
110 #   An RSA Laboratories Technical Note
111 #   Burton S. Kaliski Jr.
112 #   Revised November 1, 1993
113 #
114 #   Supersedes June 3, 1991 version, which was also published as
115 #   NIST/OSI Implementors' Workshop document SEC-SIG-91-17.
116 #   PKCS documents are available by electronic mail to
117 #   <pkcs@rsa.com>.
118 #
119 #   Copyright (C) 1991-1993 RSA Laboratories, a division of RSA
120 #   Data Security, Inc. License to copy this document is granted
121 #   provided that it is identified as "RSA Data Security, Inc.
122 #   Public-Key Cryptography Standards (PKCS)" in all material
123 #   mentioning or referencing this document.
124 #   003-903015-110-000-000
125 #
126 #-----------------------------------------------------------------------------
127
128 #-----------------------------------------------------------------------------
129 # asnLength : Encode some length data. Helper command.
130 #-----------------------------------------------------------------------------
131
132 proc ::asn::asnLength {len} {
133     
134     if {$len < 0} {
135         return -code error "Negative length octet requested"
136     }
137     if {$len < 128} {
138         # short form: ISO X.690 8.1.3.4 
139         return [binary format c $len]
140     }
141     # long form: ISO X.690 8.1.3.5
142     # try to use a minimal encoding, 
143     # even if not required by BER, but it is required by DER
144     # take care for signed vs. unsigned issues
145     if {$len < 256  } {
146         return [binary format H2c 81 [expr {$len - 256}]]
147     }
148     if {$len < 32769} {
149         # two octet signed value
150         return [binary format H2S 82 $len]
151     }
152     if {$len < 65536} {
153         return [binary format H2S 82 [expr {$len - 65536}]]
154     }
155     if {$len < 8388608} {
156         # three octet signed value    
157         return [binary format H2cS 83 [expr {$len >> 16}] [expr {($len & 0xFFFF) - 65536}]] 
158     }    
159     if {$len < 16777216} {
160         # three octet signed value    
161         return [binary format H2cS 83 [expr {($len >> 16) -256}] [expr {($len & 0xFFFF) -65536}]] 
162     }
163     if {$len < 2147483649} { 
164         # four octet signed value
165         return [binary format H2I 84 $len]
166     }
167     if {$len < 4294967296} {
168         # four octet unsigned value
169         return [binary format H2I 84 [expr {$len - 4294967296}]]
170     }
171     if {$len < 1099511627776} {
172         # five octet unsigned value
173         return [binary format H2 85][string range [binary format W $len] 3 end]  
174     }
175     if {$len < 281474976710656} {
176         # six octet unsigned value
177         return [binary format H2 86][string range [binary format W $len] 2 end]
178     }
179     if {$len < 72057594037927936} {
180         # seven octet value
181         return [binary format H2 87][string range [binary format W $len] 1 end]
182     }
183     
184     # must be a 64-bit wide signed value
185     return [binary format H2W 88 $len] 
186 }
187
188 #-----------------------------------------------------------------------------
189 # asnSequence : Assumes that the arguments are already ASN encoded.
190 #-----------------------------------------------------------------------------
191
192 proc ::asn::asnSequence {args} {
193     asnSequenceFromList $args
194 }
195
196 proc ::asn::asnSequenceFromList {lst} {
197     # The sequence tag is 0x30. The length is arbitrary and thus full
198     # length coding is required. The arguments have to be BER encoded
199     # already. Constructed value, definite-length encoding.
200
201     set out ""
202     foreach part $lst {
203         append out $part
204     }
205     set len [string length $out]
206     return [binary format H2a*a$len 30 [asnLength $len] $out]
207 }
208
209
210 #-----------------------------------------------------------------------------
211 # asnSet : Assumes that the arguments are already ASN encoded.
212 #-----------------------------------------------------------------------------
213
214 proc ::asn::asnSet {args} {
215     asnSetFromList $args
216 }
217
218 proc ::asn::asnSetFromList {lst} {
219     # The set tag is 0x31. The length is arbitrary and thus full
220     # length coding is required. The arguments have to be BER encoded
221     # already.
222
223     set out ""
224     foreach part $lst {
225         append out $part
226     }
227     set len [string length $out]
228     return [binary format H2a*a$len 31 [asnLength $len] $out]
229 }
230
231
232 #-----------------------------------------------------------------------------
233 # asnApplicationConstr
234 #-----------------------------------------------------------------------------
235
236 proc ::asn::asnApplicationConstr {appNumber args} {
237     # Packs the arguments into a constructed value with application tag.
238
239     set out ""
240     foreach part $args {
241         append out $part
242     }
243     set code [expr {0x060 + $appNumber}]
244     set len  [string length $out]
245     return [binary format ca*a$len $code [asnLength $len] $out]
246 }
247
248 #-----------------------------------------------------------------------------
249 # asnApplication
250 #-----------------------------------------------------------------------------
251
252 proc ::asn::asnApplication {appNumber data} {
253     # Packs the arguments into a constructed value with application tag.
254
255     set code [expr {0x040 + $appNumber}]
256     set len  [string length $data]
257     return [binary format ca*a$len $code [asnLength $len] $data]
258 }
259
260 #-----------------------------------------------------------------------------
261 # asnContextConstr
262 #-----------------------------------------------------------------------------
263
264 proc ::asn::asnContextConstr {contextNumber args} {
265     # Packs the arguments into a constructed value with application tag.
266
267     set out ""
268     foreach part $args {
269         append out $part
270     }
271     set code [expr {0x0A0 + $contextNumber}]
272     set len  [string length $out]
273     return [binary format ca*a$len $code [asnLength $len] $out]
274 }
275
276 #-----------------------------------------------------------------------------
277 # asnContext
278 #-----------------------------------------------------------------------------
279
280 proc ::asn::asnContext {contextNumber data} {
281     # Packs the arguments into a constructed value with application tag.
282     set code [expr {0x080 + $contextNumber}]
283     set len  [string length $data]
284     return [binary format ca*a$len $code [asnLength $len] $data]
285 }
286 #-----------------------------------------------------------------------------
287 # asnChoice
288 #-----------------------------------------------------------------------------
289
290 proc ::asn::asnChoice {appNumber args} {
291     # Packs the arguments into a choice construction.
292
293     set out ""
294     foreach part $args {
295         append out $part
296     }
297     set code [expr {0x080 + $appNumber}]
298     set len  [string length $out]
299     return [binary format ca*a$len $code [asnLength $len] $out]
300 }
301
302 #-----------------------------------------------------------------------------
303 # asnChoiceConstr
304 #-----------------------------------------------------------------------------
305
306 proc ::asn::asnChoiceConstr {appNumber args} {
307     # Packs the arguments into a choice construction.
308
309     set out ""
310     foreach part $args {
311         append out $part
312     }
313     set code [expr {0x0A0 + $appNumber}]
314     set len  [string length $out]
315     return [binary format ca*a$len $code [asnLength $len] $out]
316 }
317
318 #-----------------------------------------------------------------------------
319 # asnInteger : Encode integer value.
320 #-----------------------------------------------------------------------------
321
322 proc ::asn::asnInteger {number} {
323     asnIntegerOrEnum 02 $number
324 }
325
326 #-----------------------------------------------------------------------------
327 # asnEnumeration : Encode enumeration value.
328 #-----------------------------------------------------------------------------
329
330 proc ::asn::asnEnumeration {number} {
331     asnIntegerOrEnum 0a $number
332 }
333
334 #-----------------------------------------------------------------------------
335 # asnIntegerOrEnum : Common code for Integers and Enumerations
336 #                    No Bignum version, as we do not expect large Enums.
337 #-----------------------------------------------------------------------------
338
339 proc ::asn::asnIntegerOrEnum {tag number} {
340     # The integer tag is 0x02 , the Enum Tag 0x0a otherwise identical. 
341     # The length is 1, 2, 3, or 4, coded in a
342     # single byte. This can be done directly, no need to go through
343     # asnLength. The value itself is written in big-endian.
344
345     # Known bug/issue: The command cannot handle very wide integers, i.e.
346     # anything above 8 bytes length. Use asnBignumInteger for those.
347     
348     # check if we really have an int
349     set num $number
350     incr num
351     
352     if {($number >= -128) && ($number < 128)} {
353         return [binary format H2H2c $tag 01 $number]
354     }
355     if {($number >= -32768) && ($number < 32768)} {
356         return [binary format H2H2S $tag 02 $number]
357     }
358     if {($number >= -8388608) && ($number < 8388608)} {
359         set numberb [expr {$number & 0xFFFF}]
360         set numbera [expr {($number >> 16) & 0xFF}]
361         return [binary format H2H2cS $tag 03 $numbera $numberb]
362     }
363     if {($number >= -2147483648) && ($number < 2147483648)} {
364         return [binary format H2H2I $tag 04 $number]
365     }
366     if {($number >= -549755813888) && ($number < 549755813888)} {
367         set numberb [expr {$number & 0xFFFFFFFF}]
368         set numbera [expr {($number >> 32) & 0xFF}]
369         return [binary format H2H2cI $tag 05 $numbera $numberb]
370     }
371     if {($number >= -140737488355328) && ($number < 140737488355328)} {
372         set numberb [expr {$number & 0xFFFFFFFF}]
373         set numbera [expr {($number >> 32) & 0xFFFF}]
374         return [binary format H2H2SI $tag 06 $numbera $numberb]        
375     }
376     if {($number >= -36028797018963968) && ($number < 36028797018963968)} {
377         set numberc [expr {$number & 0xFFFFFFFF}]
378         set numberb [expr {($number >> 32) & 0xFFFF}]
379         set numbera [expr {($number >> 48) & 0xFF}]
380         return [binary format H2H2cSI $tag 07 $numbera $numberb $numberc]        
381     }    
382     if {($number >= -9223372036854775808) && ($number <= 9223372036854775807)} {
383         return [binary format H2H2W $tag 08 $number]
384     }
385     return -code error "Integer value to large to encode, use asnBigInteger" 
386 }
387
388 #-----------------------------------------------------------------------------
389 # asnBigInteger : Encode a long integer value using math::bignum
390 #-----------------------------------------------------------------------------
391
392 proc ::asn::asnBigInteger {bignum} {
393     # require math::bignum only if it is used
394     package require math::bignum
395     
396     # this is a hack to check for bignum...
397     if {[llength $bignum] < 2 || ([lindex $bignum 0] ne "bignum")} {
398         return -code error "expected math::bignum value got \"$bignum\""
399     }
400     if {[math::bignum::sign $bignum]} {
401         # generate two's complement form
402         set bits [math::bignum::bits $bignum]
403         set padding [expr {$bits % 8}]
404         set len [expr {int(ceil($bits / 8.0))}]
405         if {$padding == 0} {
406             # we need a complete extra byte for the sign
407             # unless this is a base 2 multiple
408             set test [math::bignum::fromstr 0]
409             math::bignum::setbit test [expr {$bits-1}]
410             if {[math::bignum::ne [math::bignum::abs $bignum] $test]} {
411                 incr len
412             }
413         }
414         set exp [math::bignum::pow \
415                     [math::bignum::fromstr 256] \
416                     [math::bignum::fromstr $len]]
417         set bignum [math::bignum::add $bignum $exp]
418         set hex [math::bignum::tostr $bignum 16]
419     } else {
420         set bits [math::bignum::bits $bignum]
421         if {($bits % 8) == 0 && $bits > 0} {
422             set pad "00"
423         } else {
424             set pad ""
425         }
426         set hex $pad[math::bignum::tostr $bignum 16]
427     }
428     if {[string length $hex]%2} {
429         set hex "0$hex"
430     }
431     set octets [expr {(([string length $hex]+1)/2)}]
432     return [binary format H2a*H* 02 [asnLength $octets] $hex]   
433 }
434
435
436 #-----------------------------------------------------------------------------
437 # asnBoolean : Encode a boolean value.
438 #-----------------------------------------------------------------------------
439
440 proc ::asn::asnBoolean {bool} {
441     # The boolean tag is 0x01. The length is always 1, coded in
442     # a single byte. This can be done directly, no need to go through
443     # asnLength. The value itself is written in big-endian.
444
445     return [binary format H2H2c 01 01 [expr {$bool ? 0x0FF : 0x0}]]
446 }
447
448 #-----------------------------------------------------------------------------
449 # asnOctetString : Encode a string of arbitrary bytes
450 #-----------------------------------------------------------------------------
451
452 proc ::asn::asnOctetString {string} {
453     # The octet tag is 0x04. The length is arbitrary, so we need
454     # 'asnLength' for full coding of the length.
455
456     set len [string length $string]
457     return [binary format H2a*a$len 04 [asnLength $len] $string]
458 }
459
460 #-----------------------------------------------------------------------------
461 # asnNull : Encode a null value
462 #-----------------------------------------------------------------------------
463
464 proc ::asn::asnNull {} {
465     # Null has only one valid encoding
466     return \x05\x00
467 }
468
469 #-----------------------------------------------------------------------------
470 # asnBitstring : Encode a Bit String value
471 #-----------------------------------------------------------------------------
472
473 proc ::asn::asnBitString {bitstring} {
474     # The bit string tag is 0x03.
475     # Bit strings can be either simple or constructed
476     # we always use simple encoding
477     
478     set bitlen [string length $bitstring]
479     set padding [expr {(8 - ($bitlen % 8)) % 8}]
480     set len [expr {($bitlen / 8) + 1}]
481     if {$padding != 0} {incr len}
482     
483     return [binary format H2a*B* 03 [asnLength $len] $bitstring]    
484 }
485
486 #-----------------------------------------------------------------------------
487 # asnUTCTime : Encode an UTC time string
488 #-----------------------------------------------------------------------------
489
490 proc ::asn::asnUTCTime {UTCtimestring} {
491     # the utc time tag is 0x17.
492     # 
493     # BUG: we do not check the string for well formedness
494     
495     set ascii [encoding convertto ascii $UTCtimestring]
496     set len [string length $ascii]
497     return [binary format H2a*a* 17 [asnLength $len] $ascii]
498 }
499
500 #-----------------------------------------------------------------------------
501 # asnPrintableString : Encode a printable string
502 #-----------------------------------------------------------------------------
503 namespace eval asn {
504     variable nonPrintableChars {[^ A-Za-z0-9'()+,.:/?=-]}
505 }       
506 proc ::asn::asnPrintableString {string} {
507     # the printable string tag is 0x13
508     variable nonPrintableChars
509     # it is basically a restricted ascii string
510     if {[regexp $nonPrintableChars $string ]} {
511         return -code error "Illegal character in PrintableString."
512     }
513     
514     # check characters
515     set ascii [encoding convertto ascii $string]
516     return [asnEncodeString 13 $ascii]
517 }
518
519 #-----------------------------------------------------------------------------
520 # asnIA5String : Encode an Ascii String
521 #-----------------------------------------------------------------------------
522 proc ::asn::asnIA5String {string} {
523     # the IA5 string tag is 0x16
524     # check for extended charachers
525     if {[string length $string]!=[string bytelength $string]} {
526         return -code error "Illegal character in IA5String"
527     }
528     set ascii [encoding convertto ascii $string]
529     return [asnEncodeString 16 $ascii]
530 }
531
532 #-----------------------------------------------------------------------------
533 # asnNumericString : Encode a Numeric String type
534 #-----------------------------------------------------------------------------
535 namespace eval asn {
536     variable nonNumericChars {[^0-9 ]}
537 }
538 proc ::asn::asnNumericString {string} {
539     # the Numeric String type has tag 0x12
540     variable nonNumericChars
541     if {[regexp $nonNumericChars $string]} {
542         return -code error "Illegal character in Numeric String."
543     }
544     
545     return [asnEncodeString 12 $string]
546 }
547 #----------------------------------------------------------------------
548 # asnBMPString: Encode a Tcl string as Basic Multinligval (UCS2) string
549 #-----------------------------------------------------------------------
550 proc asn::asnBMPString  {string} {
551     if {$::tcl_platform(byteOrder) eq "littleEndian"} {
552         set bytes ""
553         foreach {lo hi} [split [encoding convertto unicode $string] ""] {
554             append bytes $hi $lo
555         }       
556     } else {
557         set bytes [encoding convertto unicode $string]
558     }
559     return [asnEncodeString 1e $bytes]
560 }       
561 #---------------------------------------------------------------------------
562 # asnUTF8String: encode tcl string as UTF8 String
563 #----------------------------------------------------------------------------
564 proc asn::asnUTF8String {string} {
565     return [asnEncodeString 0c [encoding convertto utf-8 $string]]
566 }
567 #-----------------------------------------------------------------------------
568 # asnEncodeString : Encode an RestrictedCharacter String
569 #-----------------------------------------------------------------------------
570 proc ::asn::asnEncodeString {tag string} {
571     set len [string length $string]
572     return [binary format H2a*a$len $tag [asnLength $len] $string]    
573 }
574
575 #-----------------------------------------------------------------------------
576 # asnObjectIdentifier : Encode an Object Identifier value
577 #-----------------------------------------------------------------------------
578 proc ::asn::asnObjectIdentifier {oid} {
579     # the object identifier tag is 0x06
580     
581     if {[llength $oid] < 2} {
582         return -code error "OID must have at least two subidentifiers."
583     }
584     
585     # basic check that it is valid
586     foreach identifier $oid {
587         if {$identifier < 0} {
588             return -code error \
589                 "Malformed OID. Identifiers must be positive Integers."
590         }
591     }
592     
593     if {[lindex $oid 0] > 2} {
594             return -code error "First subidentifier must be 0,1 or 2"
595     }
596     if {[lindex $oid 1] > 39} {
597             return -code error \
598                 "Second subidentifier must be between 0 and 39"
599     }
600     
601     # handle the special cases directly
602     switch [llength $oid] {
603         2  {  return [binary format H2H2c 06 01 \
604                 [expr {[lindex $oid 0]*40+[lindex $oid 1]}]] }
605         default {
606               # This can probably be written much shorter. 
607               # Just a first try that works...
608               #
609               set octets [binary format c \
610                 [expr {[lindex $oid 0]*40+[lindex $oid 1]}]]
611               foreach identifier [lrange $oid 2 end] {
612                   set d 128
613                   if {$identifier < 128} {
614                     set subidentifier [list $identifier]
615                   } else {  
616                     set subidentifier [list]
617                     # find the largest divisor
618                     
619                     while {($identifier / $d) >= 128} { 
620                         set d [expr {$d * 128}] 
621                     }
622                     # and construct the subidentifiers
623                     set remainder $identifier
624                     while {$d >= 128} {
625                         set coefficient [expr {($remainder / $d) | 0x80}]
626                         set remainder [expr {$remainder % $d}]
627                         set d [expr {$d / 128}]
628                         lappend subidentifier $coefficient
629                     }
630                     lappend subidentifier $remainder
631                   }
632                   append octets [binary format c* $subidentifier]
633               }
634               return [binary format H2a*a* 06 \
635                       [asnLength [string length $octets]] $octets]
636         }
637     }
638
639 }
640
641 #-----------------------------------------------------------------------------
642 # asnGetResponse : Read a ASN response from a channel.
643 #-----------------------------------------------------------------------------
644
645 proc ::asn::asnGetResponse {sock data_var} {
646     upvar $data_var data
647
648     # We expect a sequence here (tag 0x30). The code below is an
649     # inlined replica of 'asnGetSequence', modified for reading from a
650     # channel instead of a string.
651
652     set tag [read $sock 1]
653
654     if {$tag == "\x30"} {
655     # The following code is a replica of 'asnGetLength', modified
656     # for reading the bytes from the channel instead of a string.
657
658         set len1 [read $sock 1]
659         binary scan $len1 c num
660         set length [expr {($num + 0x100) % 0x100}]
661
662         if {$length  >= 0x080} {
663         # The byte the read is not the length, but a prefix, and
664         # the lower nibble tells us how many bytes follow.
665
666             set len_length  [expr {$length & 0x7f}]
667
668         # BUG: We should not perform the value extraction for an
669         # BUG: improper length. It wastes cycles, and here it can
670         # BUG: cause us trouble, reading more data than there is
671         # BUG: on the channel. Depending on the channel
672         # BUG: configuration an attacker can induce us to block,
673         # BUG: causing a denial of service.
674             set lengthBytes [read $sock $len_length]
675
676             switch $len_length {
677                 1 {
678             binary scan $lengthBytes     c length 
679             set length [expr {($length + 0x100) % 0x100}]
680                 }
681                 2 { binary scan $lengthBytes     S length }
682                 3 { binary scan \x00$lengthBytes I length }
683                 4 { binary scan $lengthBytes     I length }
684                 default {
685                     return -code error \
686                         "length information too long ($len_length)"
687                 }
688             }
689         }
690
691     # Now that the length is known we get the remainder,
692     # i.e. payload, and construct proper in-memory BER encoded
693     # sequence.
694
695         set rest [read $sock $length]
696         set data [binary format aa*a$length $tag [asnLength $length] $rest]
697     }  else {
698     # Generate an error message if the data is not a sequence as
699     # we expected.
700
701         set tag_hex ""
702         binary scan $tag H2 tag_hex
703         return -code error "unknown start tag [string length $tag] $tag_hex"
704     }
705 }
706
707 #-----------------------------------------------------------------------------
708 # asnGetByte : Retrieve a single byte from the data (unsigned)
709 #-----------------------------------------------------------------------------
710
711 proc ::asn::asnGetByte {data_var byte_var} {
712     upvar $data_var data $byte_var byte
713     
714     binary scan [string index $data 0] c byte
715     set byte [expr {($byte + 0x100) % 0x100}]  
716     set data [string range $data 1 end]
717
718     return
719 }
720
721 #-----------------------------------------------------------------------------
722 # asnPeekByte : Retrieve a single byte from the data (unsigned) 
723 #               without removing it.
724 #-----------------------------------------------------------------------------
725
726 proc ::asn::asnPeekByte {data_var byte_var} {
727     upvar $data_var data $byte_var byte
728     
729     binary scan [string index $data 0] c byte
730     set byte [expr {($byte + 0x100) % 0x100}]  
731
732     return
733 }
734
735 #-----------------------------------------------------------------------------
736 # ansRetag: Remove an explicit tag with the real newTag
737 #
738 #-----------------------------------------------------------------------------
739 proc ::asn::asnRetag {data_var newTag} {
740     upvar 1 $data_var data  
741     asnGetByte data tag
742     set data [binary format c $newTag]$data
743 }
744
745 #-----------------------------------------------------------------------------
746 # asnGetBytes : Retrieve a block of 'length' bytes from the data.
747 #-----------------------------------------------------------------------------
748
749 proc ::asn::asnGetBytes {data_var length bytes_var} {
750     upvar $data_var data  $bytes_var bytes
751
752     incr length -1
753     set bytes [string range $data 0 $length]
754     incr length
755     set data [string range $data $length end]
756
757     return
758 }
759
760
761 #-----------------------------------------------------------------------------
762 # asnGetLength : Decode an ASN length value (See notes)
763 #-----------------------------------------------------------------------------
764
765 proc ::asn::asnGetLength {data_var length_var} {
766     upvar $data_var data  $length_var length
767
768     asnGetByte data length
769     if {$length == 0x080} {
770         return -code error "Indefinite length BER encoding not yet supported"
771     }
772     if {$length > 0x080} {
773     # The retrieved byte is a prefix value, and the integer in the
774     # lower nibble tells us how many bytes were used to encode the
775     # length data following immediately after this prefix.
776
777         set len_length [expr {$length & 0x7f}]
778         
779         if {[string length $data] < $len_length} {
780             return -code error \
781                 "length information invalid, not enough octets left" 
782         }
783         
784         asnGetBytes data $len_length lengthBytes
785
786         switch $len_length {
787             1 {
788         # Efficiently coded data will not go through this
789         # path, as small length values can be coded directly,
790         # without a prefix.
791
792             binary scan $lengthBytes     c length 
793             set length [expr {($length + 0x100) % 0x100}]
794             }
795             2 { binary scan $lengthBytes     S length 
796             set length [expr {($length + 0x10000) % 0x10000}]
797             }
798             3 { binary scan \x00$lengthBytes I length 
799             set length [expr {($length + 0x1000000) % 0x1000000}]
800             }
801             4 { binary scan $lengthBytes     I length 
802             set length [expr {(wide($length) + 0x100000000) % 0x100000000}]
803             }
804             default {                
805                 binary scan $lengthBytes H* hexstr
806                 # skip leading zeros which are allowed by BER
807                 set hexlen [string trimleft $hexstr 0] 
808                 # check if it fits into a 64-bit signed integer
809                 if {[string length $hexlen] > 16} {
810                     return -code error -errorcode {ARITH IOVERFLOW 
811                             {Length value too large for normal use, try asnGetBigLength}} \
812                             "Length value to large"
813                 } elseif {  [string length $hexlen] == 16 \
814                         && ([string index $hexlen 0] & 0x8)} { 
815                     # check most significant bit, if set we need bignum
816                     return -code error -errorcode {ARITH IOVERFLOW 
817                             {Length value too large for normal use, try asnGetBigLength}} \
818                             "Length value to large"
819                 } else {
820                     scan $hexstr "%lx" length
821                 }
822             }
823         }
824     }
825     return
826 }
827
828
829 #-----------------------------------------------------------------------------
830 # asnGetBigLength : Retrieve a length that can not be represented in 63-bit
831 #-----------------------------------------------------------------------------
832
833 proc ::asn::asnGetBigLength {data_var biglength_var} {
834
835     # Does any real world code really need this? 
836     # If we encounter this, we are doomed to fail anyway, 
837     # (there would be an Exabyte inside the data_var, )
838     #
839     # So i implement it just for completness.
840     # 
841     package require math::bignum
842     
843     upvar $data_var data  $length_var length
844
845     asnGetByte data length
846     if {$length == 0x080} {
847         return -code error "Indefinite length BER encoding not yet supported"
848     }
849     if {$length > 0x080} {
850     # The retrieved byte is a prefix value, and the integer in the
851     # lower nibble tells us how many bytes were used to encode the
852     # length data following immediately after this prefix.
853
854         set len_length [expr {$length & 0x7f}]
855         
856         if {[string length $data] < $len_length} {
857             return -code error \
858                 "length information invalid, not enough octets left" 
859         }
860         
861         asnGetBytes data $len_length lengthBytes
862         binary scan $lengthBytes H* hexlen
863         set length [math::bignum::fromstr $hexlen 16]
864     }
865     return
866 }
867
868 #-----------------------------------------------------------------------------
869 # asnGetInteger : Retrieve integer.
870 #-----------------------------------------------------------------------------
871
872 proc ::asn::asnGetInteger {data_var int_var} {
873     # Tag is 0x02. 
874
875     upvar $data_var data $int_var int
876
877     asnGetByte   data tag
878
879     if {$tag != 0x02} {
880         return -code error \
881             [format "Expected Integer (0x02), but got %02x" $tag]
882     }
883
884     asnGetLength data len
885     asnGetBytes  data $len integerBytes
886
887     set int ?
888
889     switch $len {
890         1 { binary scan $integerBytes     c int }
891         2 { binary scan $integerBytes     S int }
892         3 { 
893             # check for negative int and pad 
894             scan [string index $integerBytes 0] %c byte
895             if {$byte & 128} {
896                 binary scan \xff$integerBytes I int
897             } else {
898                 binary scan \x00$integerBytes I int 
899             }
900           }
901         4 { binary scan $integerBytes     I int }
902         5 -
903         6 -
904         7 -
905         8 {
906             # check for negative int and pad
907             scan [string index $integerBytes 0] %c byte
908             if {$byte & 128} {
909                 set pad [string repeat \xff [expr {8-$len}]]
910             } else {
911                 set pad [string repeat \x00 [expr {8-$len}]]
912             }
913             binary scan $pad$integerBytes W int 
914         }
915         default {
916         # Too long, or prefix coding was used.
917             return -code error "length information too long"
918         }
919     }
920     return
921 }
922
923 #-----------------------------------------------------------------------------
924 # asnGetBigInteger : Retrieve a big integer.
925 #-----------------------------------------------------------------------------
926
927 proc ::asn::asnGetBigInteger {data_var bignum_var} {
928     # require math::bignum only if it is used
929     package require math::bignum
930
931     # Tag is 0x02. We expect that the length of the integer is coded with
932     # maximal efficiency, i.e. without a prefix 0x81 prefix. If a prefix
933     # is used this decoder will fail.
934
935     upvar $data_var data $bignum_var bignum
936
937     asnGetByte   data tag
938
939     if {$tag != 0x02} {
940         return -code error \
941             [format "Expected Integer (0x02), but got %02x" $tag]
942     }
943
944     asnGetLength data len
945     asnGetBytes  data $len integerBytes
946     
947     binary scan $integerBytes H* hex
948     set bignum [math::bignum::fromstr $hex 16]
949     set bits [math::bignum::bits $bignum]
950     set exp [math::bignum::pow \
951                 [math::bignum::fromstr 2] \
952                 [math::bignum::fromstr $bits]]
953     set big [math::bignum::sub $bignum $exp]
954     set bignum $big
955     
956     return    
957 }
958
959
960
961 #-----------------------------------------------------------------------------
962 # asnGetEnumeration : Retrieve an enumeration id
963 #-----------------------------------------------------------------------------
964
965 proc ::asn::asnGetEnumeration {data_var enum_var} {
966     # This is like 'asnGetInteger', except for a different tag.
967
968     upvar $data_var data $enum_var enum
969
970     asnGetByte   data tag
971
972     if {$tag != 0x0a} {
973         return -code error \
974             [format "Expected Enumeration (0x0a), but got %02x" $tag]
975     }
976
977     asnGetLength data len
978     asnGetBytes  data $len integerBytes
979     set enum ?
980
981     switch $len {
982         1 { binary scan $integerBytes     c enum }
983         2 { binary scan $integerBytes     S enum }
984         3 { binary scan \x00$integerBytes I enum }
985         4 { binary scan $integerBytes     I enum }
986         default {
987             return -code error "length information too long"
988         }
989     }
990     return
991 }
992
993 #-----------------------------------------------------------------------------
994 # asnGetOctetString : Retrieve arbitrary string.
995 #-----------------------------------------------------------------------------
996
997 proc ::asn::asnGetOctetString {data_var string_var} {
998     # Here we need the full decoder for length data.
999
1000     upvar $data_var data $string_var string
1001     
1002     asnGetByte data tag
1003     if {$tag != 0x04} { 
1004         return -code error \
1005             [format "Expected Octet String (0x04), but got %02x" $tag]
1006     }
1007     asnGetLength data length
1008     asnGetBytes  data $length temp
1009     set string $temp
1010     return
1011 }
1012
1013 #-----------------------------------------------------------------------------
1014 # asnGetSequence : Retrieve Sequence data for further decoding.
1015 #-----------------------------------------------------------------------------
1016
1017 proc ::asn::asnGetSequence {data_var sequence_var} {
1018     # Here we need the full decoder for length data.
1019
1020     upvar $data_var data $sequence_var sequence
1021
1022     asnGetByte data tag
1023     if {$tag != 0x030} { 
1024         return -code error \
1025             [format "Expected Sequence (0x30), but got %02x" $tag]
1026     }    
1027     asnGetLength data length
1028     asnGetBytes  data $length temp
1029     set sequence $temp
1030     return
1031 }
1032
1033 #-----------------------------------------------------------------------------
1034 # asnGetSet : Retrieve Set data for further decoding.
1035 #-----------------------------------------------------------------------------
1036
1037 proc ::asn::asnGetSet {data_var set_var} {
1038     # Here we need the full decoder for length data.
1039
1040     upvar $data_var data $set_var set
1041
1042     asnGetByte data tag
1043     if {$tag != 0x031} { 
1044         return -code error \
1045             [format "Expected Set (0x31), but got %02x" $tag]
1046     }    
1047     asnGetLength data length
1048     asnGetBytes  data $length temp
1049     set set $temp
1050     return
1051 }
1052
1053 #-----------------------------------------------------------------------------
1054 # asnGetApplication
1055 #-----------------------------------------------------------------------------
1056
1057 proc ::asn::asnGetApplication {data_var appNumber_var {content_var {}} {constructed_var {}}} {
1058     upvar $data_var data $appNumber_var appNumber
1059
1060     asnGetByte   data tag
1061     asnGetLength data length
1062
1063     if {($tag & 0xC0) != 0x040} {
1064         return -code error \
1065             [format "Expected Application (0x60 or 0x40), but got %02x" $tag]
1066     }    
1067     set appNumber [expr {$tag & 0x1F}]
1068         if {[string length $constructed_var]} {
1069                 upvar 1 $constructed_var constructed
1070                 set constructed [expr {$tag & 0x20}]
1071         }
1072         if {[string length $content_var]} {
1073                 upvar 1 $content_var content
1074                 asnGetBytes data $length content
1075         }       
1076     return
1077 }
1078
1079 #-----------------------------------------------------------------------------
1080 # asnGetBoolean: decode a boolean value
1081 #-----------------------------------------------------------------------------
1082
1083 proc asn::asnGetBoolean {data_var bool_var} {
1084     upvar $data_var data $bool_var bool
1085
1086     asnGetByte data tag
1087     if {$tag != 0x01} {
1088         return -code error \
1089             [format "Expected Boolean (0x01), but got %02x" $tag]
1090     }
1091
1092     asnGetLength data length
1093     asnGetByte data byte
1094     set bool [expr {$byte == 0 ? 0 : 1}]    
1095     return
1096 }
1097
1098 #-----------------------------------------------------------------------------
1099 # asnGetUTCTime: Extract an UTC Time string from the data. Returns a string
1100 #                representing an UTC Time.
1101 #
1102 #-----------------------------------------------------------------------------
1103
1104 proc asn::asnGetUTCTime {data_var utc_var} {
1105     upvar $data_var data $utc_var utc
1106
1107     asnGetByte data tag
1108     if {$tag != 0x17} {
1109         return -code error \
1110             [format "Expected UTCTime (0x17), but got %02x" $tag]
1111     }
1112
1113     asnGetLength data length
1114     asnGetBytes data $length bytes
1115     
1116     # this should be ascii, make it explicit
1117     set bytes [encoding convertfrom ascii $bytes]
1118     binary scan $bytes a* utc
1119     
1120     return
1121 }
1122
1123
1124 #-----------------------------------------------------------------------------
1125 # asnGetBitString: Extract a Bit String value (a string of 0/1s) from the
1126 #                  ASN.1 data.
1127 #
1128 #-----------------------------------------------------------------------------
1129
1130 proc asn::asnGetBitString {data_var bitstring_var} {
1131     upvar $data_var data $bitstring_var bitstring
1132
1133     asnGetByte data tag
1134     if {$tag != 0x03} {
1135         return -code error \
1136             [format "Expected Bit String (0x03), but got %02x" $tag]
1137     }
1138     
1139     asnGetLength data length
1140     # get the number of padding bits used at the end
1141     asnGetByte data padding
1142     incr length -1
1143     asnGetBytes data $length bytes
1144     binary scan $bytes B* bits
1145     
1146     # cut off the padding bits
1147     set bits [string range $bits 0 end-$padding]
1148     set bitstring $bits
1149 }
1150
1151 #-----------------------------------------------------------------------------
1152 # asnGetObjectIdentifier: Decode an ASN.1 Object Identifier (OID) into
1153 #                         a Tcl list of integers.
1154 #-----------------------------------------------------------------------------
1155
1156 proc asn::asnGetObjectIdentifier {data_var oid_var} {
1157       upvar $data_var data $oid_var oid
1158
1159       asnGetByte data tag
1160       if {$tag != 0x06} {
1161         return -code error \
1162             [format "Expected Object Identifier (0x06), but got %02x" $tag]  
1163       }
1164       asnGetLength data length
1165       
1166       # the first byte encodes the OID parts in position 0 and 1
1167       asnGetByte data val
1168       set oid [expr {$val / 40}]
1169       lappend oid [expr {$val % 40}]
1170       incr length -1
1171       
1172       # the next bytes encode the remaining parts of the OID
1173       set bytes [list]
1174       set incomplete 0
1175       while {$length} {
1176         asnGetByte data octet
1177         incr length -1
1178         if {$octet < 128} {
1179             set oidval $octet
1180             set mult 128
1181             foreach byte $bytes {
1182                 if {$byte != {}} {
1183                 incr oidval [expr {$mult*$byte}]    
1184                 set mult [expr {$mult*128}]
1185                 }
1186             }
1187             lappend oid $oidval
1188             set bytes [list]
1189             set incomplete 0
1190         } else {
1191             set byte [expr {$octet-128}]
1192             set bytes [concat [list $byte] $bytes]
1193             set incomplete 1
1194         }                      
1195       }
1196       if {$incomplete} {
1197         return -code error "OID Data is incomplete, not enough octets."
1198       }
1199       return
1200 }
1201
1202 #-----------------------------------------------------------------------------
1203 # asnGetContext: Decode an explicit context tag 
1204 #
1205 #-----------------------------------------------------------------------------
1206
1207 proc ::asn::asnGetContext {data_var contextNumber_var {content_var {}} {constructed_var {}}} {
1208     upvar 1 $data_var data $contextNumber_var contextNumber
1209
1210     asnGetByte   data tag
1211     asnGetLength data length
1212
1213     if {($tag & 0xC0) != 0x080} {
1214         return -code error \
1215             [format "Expected Context (0xa0 or 0x80), but got %02x" $tag]
1216     }    
1217     set contextNumber [expr {$tag & 0x1F}]
1218         if {[string length $constructed_var]} {
1219                 upvar 1 $constructed_var constructed
1220                 set constructed [expr {$tag & 0x20}]
1221         }
1222         if {[string length $content_var]} {
1223                 upvar 1 $content_var content
1224                 asnGetBytes data $length content
1225         }       
1226     return
1227 }
1228
1229
1230 #-----------------------------------------------------------------------------
1231 # asnGetNumericString: Decode a Numeric String from the data
1232 #-----------------------------------------------------------------------------
1233
1234 proc ::asn::asnGetNumericString {data_var print_var} {
1235     upvar 1 $data_var data $print_var print
1236
1237     asnGetByte data tag
1238     if {$tag != 0x12} {
1239         return -code error \
1240             [format "Expected Numeric String (0x12), but got %02x" $tag]  
1241     }
1242     asnGetLength data length 
1243     asnGetBytes data $length string
1244     set print [encoding convertfrom ascii $string]
1245     return
1246 }
1247
1248 #-----------------------------------------------------------------------------
1249 # asnGetPrintableString: Decode a Printable String from the data
1250 #-----------------------------------------------------------------------------
1251
1252 proc ::asn::asnGetPrintableString {data_var print_var} {
1253     upvar $data_var data $print_var print
1254
1255     asnGetByte data tag
1256     if {$tag != 0x13} {
1257         return -code error \
1258             [format "Expected Printable String (0x13), but got %02x" $tag]  
1259     }
1260     asnGetLength data length 
1261     asnGetBytes data $length string
1262     set print [encoding convertfrom ascii $string]
1263     return
1264 }
1265
1266 #-----------------------------------------------------------------------------
1267 # asnGetIA5String: Decode a IA5(ASCII) String from the data
1268 #-----------------------------------------------------------------------------
1269
1270 proc ::asn::asnGetIA5String {data_var print_var} {
1271     upvar $data_var data $print_var print
1272
1273     asnGetByte data tag
1274     if {$tag != 0x16} {
1275         return -code error \
1276             [format "Expected IA5 String (0x16), but got %02x" $tag]  
1277     }
1278     asnGetLength data length 
1279     asnGetBytes data $length string
1280     set print [encoding convertfrom ascii $string]
1281     return
1282 }
1283 #------------------------------------------------------------------------
1284 # asnGetBMPString: Decode Basic Multiningval (UCS2 string) from data
1285 #------------------------------------------------------------------------
1286 proc asn::asnGetBMPString {data_var print_var} {
1287         upvar $data_var data $print_var print
1288     asnGetByte data tag
1289     if {$tag != 0x1e} {
1290         return -code error \
1291             [format "Expected BMP String (0x1e), but got %02x" $tag]  
1292     }
1293     asnGetLength data length 
1294         asnGetBytes data $length string
1295         if {$::tcl_platform(byteOrder) eq "littleEndian"} {
1296                 set str2 ""
1297                 foreach {hi lo} [split $string ""] {
1298                         append str2 $lo $hi
1299                 }
1300         } else {
1301                 set str2 $string
1302         }
1303         set print [encoding convertfrom unicode $str2]
1304         return
1305 }       
1306 #------------------------------------------------------------------------
1307 # asnGetUTF8String: Decode UTF8 string from data
1308 #------------------------------------------------------------------------
1309 proc asn::asnGetUTF8String {data_var print_var} {
1310         upvar $data_var data $print_var print
1311     asnGetByte data tag
1312     if {$tag != 0x0c} {
1313         return -code error \
1314             [format "Expected UTF8 String (0x0c), but got %02x" $tag]  
1315     }
1316     asnGetLength data length 
1317         asnGetBytes data $length string
1318         #there should be some error checking to see if input is
1319         #properly-formatted utf8
1320         set print [encoding convertfrom utf-8 $string]
1321         
1322         return
1323 }       
1324 #-----------------------------------------------------------------------------
1325 # asnGetNull: decode a NULL value
1326 #-----------------------------------------------------------------------------
1327
1328 proc ::asn::asnGetNull {data_var} {
1329     upvar $data_var data 
1330
1331     asnGetByte data tag
1332     if {$tag != 0x05} {
1333         return -code error \
1334             [format "Expected NULL (0x05), but got %02x" $tag]
1335     }
1336
1337     asnGetLength data length
1338     asnGetBytes data $length bytes
1339     
1340     # we do not check the null data, all bytes must be 0x00
1341     
1342     return
1343 }
1344
1345 #----------------------------------------------------------------------------
1346 # MultiType string routines
1347 #----------------------------------------------------------------------------
1348
1349 namespace eval asn {
1350         variable stringTypes
1351         array set stringTypes {
1352                 12 NumericString 
1353                 13 PrintableString 
1354                 16 IA5String 
1355                 1e BMPString 
1356                 0c UTF8String 
1357                 14 T61String
1358                 15 VideotexString
1359                 1a VisibleString
1360                 1b GeneralString
1361                 1c UniversalString
1362         }       
1363         variable defaultStringType UTF8
1364 }       
1365 #---------------------------------------------------------------------------
1366 # asnGetString - get readable string automatically detecting its type
1367 #---------------------------------------------------------------------------
1368 proc ::asn::asnGetString {data_var print_var {type_var {}}} {
1369         variable stringTypes
1370         upvar $data_var data $print_var print
1371         asnPeekByte data tag
1372         set tag [format %02x $tag]
1373         if {![info exists stringTypes($tag)]} {
1374                 return -code error "Expected one of string types, but got $tag"
1375         }
1376         asnGet$stringTypes($tag) data print
1377         if {[string length $type_var]} {
1378                 upvar $type_var type
1379                 set type $stringTypes($tag)
1380         }       
1381 }
1382 #---------------------------------------------------------------------
1383 # defaultStringType - set or query default type for unrestricted strings
1384 #---------------------------------------------------------------------
1385 proc ::asn::defaultStringType {{type {}}} {
1386         variable defaultStringType
1387         if {![string length $type]} {
1388                 return $defaultStringType
1389         }
1390         if {$type ne "BMP" && $type ne "UTF8"} {
1391                 return -code error "Invalid default string type. Should be one of BMP, UTF8"
1392         }
1393         set defaultStringType $type
1394         return
1395 }       
1396
1397 #---------------------------------------------------------------------------
1398 # asnString - encode readable string into most restricted type possible
1399 #---------------------------------------------------------------------------
1400
1401 proc ::asn::asnString {string} {
1402         variable nonPrintableChars
1403         variable nonNumericChars
1404         if {[string length $string]!=[string bytelength $string]} {
1405         # There are non-ascii character
1406                 variable defaultStringType
1407                 return [asn${defaultStringType}String $string]
1408         } elseif {![regexp $nonNumericChars $string]} {
1409                 return [asnNumericString $string]
1410         } elseif {![regexp $nonPrintableChars $string]} {
1411                 return [asnPrintableString $string]
1412         } else {
1413                 return [asnIA5String $string]
1414         }       
1415 }
1416
1417 #-----------------------------------------------------------------------------
1418 package provide asn 0.7.1
1419