libconvert-ber-perl-1.3200/0000755000175000017500000000000011267733103014421 5ustar nachonacholibconvert-ber-perl-1.3200/META.yml0000644000175000017500000000075411267733100015675 0ustar nachonacho--- #YAML:1.0 name: Convert-BER version: 1.32 abstract: Encode/decoing of ASN.1 using BER rules author: - Graham Barr license: perl distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 requires: {} no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.48 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 libconvert-ber-perl-1.3200/Makefile.PL0000644000175000017500000000057311267732336016407 0ustar nachonacho# This -*- perl -*- script makes the Makefile use 5.004; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Convert::BER', VERSION_FROM => 'BER.pm', ( eval { ExtUtils::MakeMaker->VERSION(6.21) } ? ( LICENSE => 'perl', AUTHOR => 'Graham Barr ', ABSTRACT => 'Encode/decoing of ASN.1 using BER rules' ) : () ), ); libconvert-ber-perl-1.3200/BER.pod0000644000175000017500000006021311267731754015551 0ustar nachonacho=head1 NAME Convert::BER - ASN.1 Basic Encoding Rules =head1 SYNOPSIS use Convert::BER; $ber = new Convert::BER; $ber->encode( INTEGER => 1, SEQUENCE => [ BOOLEAN => 0, STRING => "Hello", ], REAL => 3.7, ); $ber->decode( INTEGER => \$i, SEQUENCE => [ BOOLEAN => \$b, STRING => \$s, ], REAL => \$r, ); =head1 DESCRIPTION B this module is no longer supported, See L C provides an OO interface to encoding and decoding data using the ASN.1 Basic Encoding Rules (BER), a platform independent way of encoding structured binary data together with the structure. =head1 METHODS =over 4 =item new =item new ( BUFFER ) =item new ( opList ) C creates a new C object. =item encode ( opList ) Encode data in I appending to the data in the buffer. =item decode ( opList ) Decode the data in the buffer as described by I, starting where the last decode finished or position set by C. =item buffer ( [ BUFFER ] ) Return the buffer contents. If I is specified set the buffer contents and reset pos to zero. =item pos ( [ POS ] ) Without any arguments C returns the offset where the last decode finished, or the last offset set by C. If I is specified then I will be where the next decode starts. =item tag ( ) Returns the tag at the current position in the buffer. =item length ( ) Returns the length of the buffer. =item error ( ) Returns the error message associated with the last method, if any. This value is not automatically reset. If C or C returns undef, check this. =item dump ( [ FH ] ) Dump the buffer to the filehandle C, or STDERR if not specified. The output contains the hex dump of each element, and an ASN.1-like text representation of that element. =item hexdump ( [ FH ] ) Dump the buffer to the filehandle C, or STDERR if not specified. The output is hex with the possibly-printable text alongside. =back =head1 IO METHODS =over 4 =item read ( IO ) =item write ( IO ) =item recv ( SOCK ) =item send ( SOCK [, ADDR ] ) =back =head1 OPLIST An I is a list of I-I pairs. An operator can be any of those defined below, or any defined by sub-classing C, which will probably be derived from the primitives given here. The Is depend on whether BER is being encoded or decoded: =over 4 =item Encoding If the I is a scalar, just encode it. If the I is a reference to a list, then encode each item in the list in turn. If the I is a code reference, then execute the code. If the returned value is a scalar, encode that value. If the returned value is a reference to a list, encode each item in the list in turn. =item Decoding If the I is a reference to a scalar, decode the value into the scalar. If the I is a reference to a list, then decode all the items of this type into the list. Note that there must be at least one item to decode, otherwise the decode will fail. If the I is a code reference, then execute the code and decode the value into the reference returned from the evaluated code. =back =head1 PRIMITIVE OPERATORS These operators encode and decode the basic primitive types defined by BER. =head2 BOOLEAN A BOOLEAN value is either true or false. =over 4 =item Encoding The I is tested for boolean truth, and encoded appropriately. # Encode a TRUE value $ber->encode( BOOLEAN => 1, ) or die; =item Decoding The decoded Is will be either 1 or 0. # Decode a boolean value into $bval $ber->decode( BOOLEAN => \$bval, ) or die; =back =head2 INTEGER An INTEGER value is either a positive whole number, or a negative whole number, or zero. Numbers can either be native perl integers, or values of the C class. =over 4 =item Encoding The I is the integer value to be encoded. $ber->encode( INTEGER => -123456, ) or die; =item Decoding The I will be the decoded integer value. $ber->decode( INTEGER => \$ival, ) or die; =back =head2 STRING This is an OCTET STRING, which is an arbitrarily long binary value. =over 4 =item Encoding The I contains the binary value to be encoded. $ber->encode( STRING => "\xC0First character is hex C0", ) or die; =item Decoding The I will be the binary bytes. $ber->decode( STRING => \$sval, ) or die; =back =head2 NULL There is no value for NULL. You often use NULL in ASN.1 when you want to denote that something else is absent rather than just not encoding the 'something else'. =over 4 =item Encoding The Is are ignored, but must be present. $ber->encode( NULL => undef, ) or die; =item Decoding Dummy values are stored in the returned Is, as though they were present in the encoding. $ber->decode( NULL => \$nval, ) or die; =back =head2 OBJECT_ID An OBJECT_ID value is an OBJECT IDENTIFIER (also called an OID). This is a hierarchically structured value that is used in protocols to uniquely identify something. For example, SNMP (the Simple Network Management Protocol) uses OIDs to denote the information being requested, and LDAP (the Lightweight Directory Access Protocol, RFC 2251) uses OIDs to denote each attribute in a directory entry. Each level of the OID hierarchy is either zero or a positive integer. =over 4 =item Encoding The I should be a dotted-decimal representation of the OID. $ber->encode( OBJECT_ID => '2.5.4.0', # LDAP objectClass ) or die; =item Decoding The I will be the dotted-decimal representation of the OID. $ber->decode( OBJECT_ID => \$oval, ) or die; =back =head2 ENUM The ENUMERATED type is effectively the same as the INTEGER type. It exists so that friendly names can be assigned to certain integer values. To be useful, you should sub-class this operator. =head2 BIT_STRING The BIT STRING type is an arbitrarily long string of bits - C<0>'s and C<1>'s. =over 4 =item Encoding The I is a string of arbitrary C<0> and C<1> characters. As these are packed into 8-bit octets when encoding and there may not be a multiple of 8 bits to be encoded, trailing padding bits are added in the encoding. $ber->encode( BIT_STRING => '0011', ) or die; =item Decoding The I will be a string of C<0> and C<1> characters. The string will have the same number of bits as were encoded (the padding bits are ignored.) $ber->decode( BIT_STRING => \$bval, ) or die; =back =head2 BIT_STRING8 This is a variation of the BIT_STRING operator, which is optimized for writing bit strings which are multiples of 8-bits in length. You can use the BIT_STRING operator to decode BER encoded with the BIT_STRING8 operator (and vice-versa.) =over 4 =item Encoding The I should be the packed bits to encode, B a string of C<0> and C<1> characters. $ber->encode( BIT_STRING8 => pack('B8', '10110101'), ) or die; =item Decoding The I will be the decoded packed bits. $ber->decode( BIT_STRING8 => \$bval, ) or die; =back =head2 REAL The REAL type encodes an floating-point number. It requires the POSIX module. =over 4 =item Encoding The I should be the number to encode. $ber->encode( REAL => 3.14159265358979, ) or die; =item Decoding The I will be the decoded floating-point value. $ber->decode( REAL => \$rval, ); =head2 ObjectDescriptor The ObjectDescriptor type encodes an ObjectDescriptor string. It is a sub-class of C. =head2 UTF8String The UTF8String type encodes a string encoded in UTF-8. It is a sub-class of C. =head2 NumericString The NumericString type encodes a NumericString, which is defined to only contain the characters 0-9 and space. It is a sub-class of C. =head2 PrintableString The PrintableString type encodes a PrintableString, which is defined to only contain the characters A-Z, a-z, 0-9, space, and the punctuation characters ()-+=:',./?. It is a sub-class of C. =head2 TeletexString/T61String The TeletexString type encodes a TeletexString, which is a string containing characters according to the T.61 character set. Each T.61 character may be one or more bytes wide. It is a sub-class of C. T61String is an alternative name for TeletexString. =head2 VideotexString The VideotexString type encodes a VideotexString, which is a string. It is a sub-class of C. =head2 IA5String The IA5String type encodes an IA5String. IA5 (International Alphabet 5) is equivalent to US-ASCII. It is a sub-class of C. =head2 UTCTime The UTCTime type encodes a UTCTime value. Note this value only represents years using two digits, so it is not recommended in Y2K-compliant applications. It is a sub-class of C. UTCTime values must be strings like: yymmddHHMM[SS]Z or: yymmddHHMM[SS]sHHMM Where yy is the year, mm is the month (01-12), dd is the day (01-31), HH is the hour (00-23), MM is the minutes (00-60). SS is the optional seconds (00-61). The time is either terminated by the literal character Z, or a timezone offset. The "Z" character indicates Zulu time or UTC. The timezone offset specifies the sign s, which is + or -, and the difference in hours and minutes. =head2 GeneralizedTime The GeneralizedTime type encodes a GeneralizedTime value. Unlike C it represents years using 4 digits, so is Y2K-compliant. It is a sub-class of C. GeneralizedTime values must be strings like: yyyymmddHHMM[SS][.U][Z] or: yyyymmddHHMM[SS][.U]sHHMM Where yyyy is the year, mm is the month (01-12), dd is the day (01-31), HH is the hour (00-23), MM is the minutes (00-60). SS is the optional seconds (00-61). U is the optional fractional seconds value; a comma is permitted instead of a dot before this value. The time may be terminated by the literal character Z, or a timezone offset. The "Z" character indicates Zulu time or UTC. The timezone offset specifies the sign s, which is + or -, and the difference in hours and minutes. If there is timezone specified UTC is assumed. =head2 GraphicString The GraphicString type encodes a GraphicString value. It is a sub-class of C. =head2 VisibleString/ISO646String The VisibleString type encodes a VisibleString value, which is a value using the ISO646 character set. It is a sub-class of C. ISO646String is an alternative name for VisibleString. =head2 GeneralString The GeneralString type encodes a GeneralString value. It is a sub-class of C. =head2 UniversalString/CharacterString The UniveralString type encodes a UniveralString value, which is a value using the ISO10646 character set. Each character in ISO10646 is 4-bytes wide. It is a sub-class of C. CharacterString is an alternative name for UniversalString. =head2 BMPString The BMPString type encodes a BMPString value, which is a value using the Unicode character set. Each character in the Unicode character set is 2-bytes wide. It is a sub-class of C. =head1 CONSTRUCTED OPERATORS These operators are used to build constructed types, which contain values in different types, like a C structure. =head2 SEQUENCE A SEQUENCE is a complex type that contains other types, a bit like a C structure. Elements inside a SEQUENCE are encoded and decoded in the order given. =over 4 =item Encoding The I should be a reference to an array containing another I which defines the elements inside the SEQUENCE. $ber->encode( SEQUENCE => [ INTEGER => 123, BOOLEAN => [ 1, 0 ], ] ) or die; =item Decoding The I should a reference to an array that contains the I which decodes the contents of the SEQUENCE. $ber->decode( SEQUENCE => [ INTEGER => \$ival, BOOLEAN => \@bvals, ] ) or die; =back =head2 SET A SET is an complex type that contains other types, rather like a SEQUENCE. Elements inside a SET may be present in any order. =over 4 =item Encoding The I is the same as for the SEQUENCE operator. $ber->encode( SET => [ INTEGER => 13, STRING => 'Hello', ] ) or die; =item Decoding The I should be a reference to an B I to that used to encode the SET. The ordering of the I should not matter. $ber->decode( SET => [ STRING => \$sval, INTEGER => \$ival, ] ) or die; =back =head2 SEQUENCE_OF A SEQUENCE_OF is an ordered list of other types. =over 4 =item Encoding The I is a I followed by an I. The I must be a reference to a list or a hash: if it is to a list, then the I will be repeated once for every element in the list. If it is to a hash, then the I will be repeated once for every key in the hash (note that ordering of keys in a hash is not guaranteed by perl.) The remaining I will then usually contain Is which are code references. If the I is to a list, then the contents of that item in the list are passed as the only argument to the code reference. If the I is to a hash, then only the key is passed to the code. @vals = ( [ 10, 'Foo' ], [ 20, 'Bar' ] ); # List of refs to lists $ber->encode( SEQUENCE_OF => [ \@vals, SEQUENCE => [ INTEGER => sub { $_[0][0] }, # Passed a ref to the inner list STRING => sub { $_[0][1] }, # Passed a ref to the inner list ] ] ) or die; %hash = ( 40 => 'Baz', 30 => 'Bletch' ); # Just a hash $ber->decode( SEQUENCE_OF => [ \%hash, SEQUENCE => [ INTEGER => sub { $_[0] }, # Passed the key STRING => sub { $hash{$_[0]} }, # Passed the key ] ] ); =item Decoding The I must be a reference to a list containing a I and an I. The I must always be a reference to a scalar. Each value in the is usually a code reference. The code referenced is called with the value of the I (dereferenced); the value of the I is incremented for each item in the SEQUENCE_OF. $ber->decode( SEQUENCE_OF => [ \$count, # In the following subs, make space at the end of an array, and # return a reference to that newly created space. SEQUENCE => [ INTEGER => sub { $ival[$_[0]] = undef; \$ival[-1] }, STRING => sub { $sval[$_[0]] = undef; \$sval[-1] }, ] ] ) or die; =back =head2 SET_OF A SET_OF is an unordered list. This is treated in an identical way to a SEQUENCE_OF, except that no ordering should be inferred from the list passed or returned. =head1 SPECIAL OPERATORS =head2 BER It is sometimes useful to construct or deconstruct BER encodings in several pieces. The BER operator lets you do this. =over 4 =item Encoding The I should be another C object, which will be inserted into the buffer. If I is undefined then nothing is added. $tmp->encode( SEQUENCE => [ INTEGER => 20, STRING => 'Foo', ] ); $ber->encode( BER => $tmp, BOOLEAN => 1 ); =item Decoding I should be a reference to a scalar, which will contain a C object. This object will contain the remainder of the current sequence or set being decoded. # After this, ber2 will contain the encoded INTEGER B STRING. # sval will be ignored and left undefined, but bval will be decoded. The # decode of ber2 will return the integer and string values. $ber->decode( SEQUENCE => [ BER => \$ber2, STRING => \$sval, ], BOOLEAN => \$bval, ); $ber2->decode( INTEGER => \$ival, STRING => \$sval2, ); =back =head2 ANY This is like the C operator except that when decoding only the next item is decoded and placed into the C object returned. There is no difference when encoding. =over 4 =item Decoding I should be a reference to a scalar, which will contain a C object. This object will only contain the next single item in the current sequence being decoded. # After this, ber2 will decode further, and ival and sval # will be decoded. $ber->decode( INTEGER = \$ival, ANY => \$ber2, STRING => \$sval, ); =back =head2 OPTIONAL This operator allows you to specify that an element is absent from the encoding. =over 4 =item Encoding The I should be a reference to another list with another I. If all of the values of the inner I are defined, the entire OPTIONAL I will be encoded, otherwise it will be omitted. $ber->encode( SEQUENCE => [ INTEGER => 16, # Will be encoded OPTIONAL => [ INTEGER => undef, # Will not be encoded ], STRING => 'Foo', # Will be encoded ] ); =item Decoding The contents of I are decoded if possible, if not then decode continues at the next I-I pair. $ber->decode( SEQUENCE => [ INTEGER => \$ival1, OPTIONAL => [ INTEGER => \$ival2, ], STRING => \$sval, ] ); =back =head2 CHOICE The I is a list of alternate I-I pairs. Only one will be encoded, and only one will be decoded. =over 4 =item Encoding A scalar at the start of the I identifies which I alternative to use for encoding the value. A value of 0 means the first one is used, 1 means the second one, etc. # Encode the BMPString alternate of the CHOICE $ber->encode( CHOICE => [ 2, PrintableString => 'Printable', TeletexString => 'Teletex/T61', BMPString => 'BMP/Unicode', UniversalString => 'Universal/ISO10646', ] ) or die; =item Decoding A reference to a scalar at the start of the I is used to store which alternative is decoded (0 for the first one, 1 for the second one, etc.) Pass undef instead of the ref if you don't care about this, or you store all the alternate values in different variables. # Decode the above. # Afterwards, $alt will be set to 2, $str will be set to 'BMP/Unicode'. $ber->decode( CHOICE => [ \$alt, PrintableString => \$str, TeletexString => \$str, BMPString => \$str, UniversalString => \$str, ] ) or die; =back =head1 TAGS In BER everything being encoded has a tag, a length, and a value. Normally the tag is derived from the operator - so INTEGER has a different tag from a BOOLEAN, for instance. In some applications it is necessary to change the tags used. For example, a SET may need to contain two different INTEGER values. Tags may be changed in two ways, either IMPLICITly or EXPLICITly. With IMPLICIT tagging, the new tag completely replaces the old tag. With EXPLICIT tagging, the new tag is used B the old tag. C supports two ways of using IMPLICIT tagging. One method is to sub-class C, which is described in the next section. For small applications or those that think sub-classing is just too much then the operator may be passed an arrayref. The array must contain two elements, the first is the usual operator name and the second is the tag value to use, as shown below. $ber->encode( [ SEQUENCE => 0x34 ] => [ INTEGER => 10, STRING => "A" ] ) or die; This will encode a sequence, with a tag value of C<0x34>, which will contain and integer and a string which will have their default tag values. You may wish to construct your tags using some pre-defined functions such as C<&Convert::BER::BER_APPLICATION>, C<&Convert::BER::BER_CONTEXT>, etc, instead of calculating the tag values yourself. To use EXPLICIT tagging, enclose the original element in a SEQUENCE, and just override the SEQUENCE's tag as above. Don't forget to set the constructed bit using C<&Convert::BER::BER_CONSTRUCTOR>. For example, the ASN.1 definition: Foo ::= SEQUENCE { [0] EXPLICIT INTEGER, INTEGER } might be encoded using this: $ber->encode( SEQUENCE => [ [ SEQUENCE => &Convert::BER::BER_CONTEXT | &Convert::BER::BER_CONSTRUCTOR | 0 ] => [ INTEGER => 10, ], INTEGER => 11, ], ) or die; =head1 SUB-CLASSING For large applications where operators with non default tags are used a lot the above mechanism can be very error-prone. For this reason, C may be sub-classed. To do this the sub-class must call a static method C. The arguments to C is a list of arrayrefs. Each arrayref will define one new operator. Each arrayref contains three values, the first is the name of the operator, the second is how the data is encoded and the third is the tag value. To aid with the creation of these arguments C exports some variables and constant subroutines. For each operator defined by C, or a C sub-class, a scalar variable with the same name is available for import, for example C<$INTEGER> is available from C. And any operators defined by a new sub-class will be available for import from that class. One of these variables may be used as the second element of each arrayref. C also exports some constant subroutines that can be used to create the tag value. The subroutines exported are: BER_BOOLEAN BER_INTEGER BER_BIT_STR BER_OCTET_STR BER_NULL BER_OBJECT_ID BER_SEQUENCE BER_SET BER_UNIVERSAL BER_APPLICATION BER_CONTEXT BER_PRIVATE BER_PRIMITIVE BER_CONSTRUCTOR C also provides a subroutine called C to calculate an integer value that will be used to represent a tag. For tags with values less than 30 this is not needed, but for tags >= 30 then tag value passed for an operator definition must be the result of C C takes two arguments, the first is the tag class and the second is the tag value. Using this information a sub-class of Convert::BER can be created as shown below. package Net::LDAP::BER; use Convert::BER qw(/^(\$|BER_)/); use strict; use vars qw($VERSION @ISA); @ISA = qw(Convert::BER); $VERSION = "1.00"; Net::LDAP::BER->define( # Name Type Tag ######################################## [ REQ_UNBIND => $NULL, BER_APPLICATION | 0x02 ], [ REQ_COMPARE => $SEQUENCE, BER_APPLICATION | BER_CONSTRUCTOR | 0x0E ], [ REQ_ABANDON => $INTEGER, ber_tag(BER_APPLICATION, 0x10) ], ); This will create a new class C which has three new operators available. This class then may be used as follows $ber = new Net::LDAP::BER; $ber->encode( REQ_UNBIND => 0, REQ_COMPARE => [ REQ_ABANDON => 123, ] ); $ber->decode( REQ_UNBIND => \$var, REQ_COMPARE => [ REQ_ABANDON => \$num, ] ); Which will encode or decode the data using the formats and tags defined in the C sub-class. It also helps to make the code more readable. =head2 DEFINING NEW PACKING OPERATORS As well as defining new operators which inherit from existing operators it is also possible to define a new operator and how data is encoded and decoded. The interface for doing this is still changing but will be documented here when it is done. To be continued ... =head1 LIMITATIONS Convert::BER cannot support tags that contain more bits than can be stored in a scalar variable, typically this is 32 bits. Convert::BER cannot support items that have a packed length which cannot be stored in 32 bits. =head1 BUGS The C decode method fails if the encoded order is different to the I order. =head1 AUTHOR Graham Barr Significant POD updates from Chris Ridd =head1 COPYRIGHT Copyright (c) 1995-2000 Graham Barr. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut libconvert-ber-perl-1.3200/BER.pm0000644000175000017500000011750611267731607015410 0ustar nachonacho# Convert::BER.pm # # Copyright (c) 1995-1999 Graham Barr . All rights reserved. # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. package Convert::BER; use vars qw($VERSION @ISA); use Exporter (); use strict; use vars qw($VERSION @ISA @EXPORT_OK); BEGIN { if ($] >= 5.006) { require bytes; 'bytes'->import; } $VERSION = "1.32"; @ISA = qw(Exporter); @EXPORT_OK = qw( BER_BOOLEAN BER_INTEGER BER_BIT_STR BER_OCTET_STR BER_NULL BER_OBJECT_ID BER_REAL BER_SEQUENCE BER_SET BER_UNIVERSAL BER_APPLICATION BER_CONTEXT BER_PRIVATE BER_PRIMITIVE BER_CONSTRUCTOR BER_LONG_LEN BER_EXTENSION_ID BER_BIT ber_tag ); # 5.003 does not have UNIVERSAL::can unless(defined &UNIVERSAL::can) { *UNIVERSAL::can = sub { my($obj,$meth) = @_; my $pkg = ref($obj) || $obj; my @pkg = ($pkg); my %done; while(@pkg) { $pkg = shift @pkg; next if exists $done{$pkg}; $done{$pkg} = 1; no strict 'refs'; unshift @pkg,@{$pkg . "::ISA"} if(@{$pkg . "::ISA"}); return \&{$pkg . "::" . $meth} if defined(&{$pkg . "::" . $meth}); } undef; } } } ## ## Constants ## sub BER_BOOLEAN () { 0x01 } sub BER_INTEGER () { 0x02 } sub BER_BIT_STR () { 0x03 } sub BER_OCTET_STR () { 0x04 } sub BER_NULL () { 0x05 } sub BER_OBJECT_ID () { 0x06 } sub BER_REAL () { 0x09 } sub BER_ENUMERATED () { 0x0A } sub BER_SEQUENCE () { 0x10 } sub BER_SET () { 0x11 } sub BER_PRINT_STR () { 0x13 } sub BER_IA5_STR () { 0x16 } sub BER_UTC_TIME () { 0x17 } sub BER_GENERAL_TIME () { 0x18 } sub BER_UNIVERSAL () { 0x00 } sub BER_APPLICATION () { 0x40 } sub BER_CONTEXT () { 0x80 } sub BER_PRIVATE () { 0xC0 } sub BER_PRIMITIVE () { 0x00 } sub BER_CONSTRUCTOR () { 0x20 } sub BER_LONG_LEN () { 0x80 } sub BER_EXTENSION_ID () { 0x1F } sub BER_BIT () { 0x80 } # This module is used a lot so performance matters. For that reason it # is implemented as an ARRAY instead of a HASH. # inlined constants for array indices sub _BUFFER () { 0 } sub _POS () { 1 } sub _INDEX () { 2 } sub _ERROR () { 3 } sub _PEER () { 4 } sub _PACKAGE () { 0 } sub _TAG () { 1 } sub _PACK () { 2 } sub _PACK_ARRAY () { 3 } sub _UNPACK () { 4 } sub _UNPACK_ARRAY () { 5 } { Convert::BER->define( ## ## Syntax operator ## [ BER => undef, undef ], [ ANY => undef, undef ], [ CONSTRUCTED => undef, undef ], [ OPTIONAL => undef, undef ], [ CHOICE => undef, undef ], ## ## Primitive operators ## [ BOOLEAN => undef, BER_UNIVERSAL | BER_PRIMITIVE | BER_BOOLEAN ], [ INTEGER => undef, BER_UNIVERSAL | BER_PRIMITIVE | BER_INTEGER ], [ STRING => undef, BER_UNIVERSAL | BER_PRIMITIVE | BER_OCTET_STR ], [ NULL => undef, BER_UNIVERSAL | BER_PRIMITIVE | BER_NULL ], [ OBJECT_ID => undef, BER_UNIVERSAL | BER_PRIMITIVE | BER_OBJECT_ID ], [ BIT_STRING => undef, BER_UNIVERSAL | BER_PRIMITIVE | BER_BIT_STR ], [ BIT_STRING8 => undef, BER_UNIVERSAL | BER_PRIMITIVE | BER_BIT_STR ], [ REAL => undef, BER_UNIVERSAL | BER_PRIMITIVE | BER_REAL ], [ SEQUENCE => undef, BER_UNIVERSAL | BER_CONSTRUCTOR | BER_SEQUENCE ], [ SEQUENCE_OF => undef, BER_UNIVERSAL | BER_CONSTRUCTOR | BER_SEQUENCE ], ); ## ## These variables will be defined by the above ->define() call ## use vars qw($INTEGER $SEQUENCE $STRING $SEQUENCE_OF); Convert::BER->define( ## ## Sub-classed primitive operators ## [ ENUM => $INTEGER, BER_UNIVERSAL | BER_PRIMITIVE | BER_ENUMERATED ], [ SET => $SEQUENCE, BER_UNIVERSAL | BER_CONSTRUCTOR | BER_SET ], [ SET_OF => $SEQUENCE_OF, BER_UNIVERSAL | BER_CONSTRUCTOR | BER_SET ], [ ObjectDescriptor => $STRING, BER_UNIVERSAL | 7], [ UTF8String => $STRING, BER_UNIVERSAL | 12], [ NumericString => $STRING, BER_UNIVERSAL | 18], [ PrintableString => $STRING, BER_UNIVERSAL | 19], [ TeletexString => $STRING, BER_UNIVERSAL | 20], [ T61String => $STRING, BER_UNIVERSAL | 20], [ VideotexString => $STRING, BER_UNIVERSAL | 21], [ IA5String => $STRING, BER_UNIVERSAL | 22], [ GraphicString => $STRING, BER_UNIVERSAL | 25], [ VisibleString => $STRING, BER_UNIVERSAL | 26], [ ISO646String => $STRING, BER_UNIVERSAL | 26], [ GeneralString => $STRING, BER_UNIVERSAL | 27], [ UTCTime => $STRING, BER_UNIVERSAL | 23], [ GeneralizedTime => $STRING, BER_UNIVERSAL | 24], ); Convert::BER->define( [ '_Time_generic' => $STRING, undef ], [ TimeUZ => '_Time_generic', BER_UNIVERSAL | 23], [ TimeUL => '_Time_generic', BER_UNIVERSAL | 23], [ TimeGZ => '_Time_generic', BER_UNIVERSAL | 24], [ TimeGL => '_Time_generic', BER_UNIVERSAL | 24], ); } # only load Carp when needed sub croak { require Carp; goto &Carp::croak; } ## ## define: ## does all the hard work of dynamically building the BER class ## and BER-type classes ## sub define { my $pkg = shift; no strict 'refs'; # we do some naughty stuff here :-) $pkg = ref($pkg) || $pkg; while(@_) { my($name,$isa,$tag) = @{ $_[0] }; shift; my $subpkg = $pkg . "::" . $name; croak("Bad tag name '$name'") if($name =~ /\A(?:DESTROY|VERSION)\Z/); if(defined $isa) { my $isapkg = $pkg->can('_' . $isa) or croak "Unknown BER tag type '$isa'"; @{$subpkg . "::ISA"} = ( &{$isapkg}()->[ _PACKAGE ] ) unless @{$subpkg . "::ISA"}; $tag = $subpkg->tag unless defined $tag; } if(defined &{$subpkg . "::tag"}) { croak "tags for '$name' do not match " unless $subpkg->tag == $tag; } else { *{$subpkg . "::tag"} = sub { $tag }; } push(@{$pkg . "::EXPORT_OK"}, '$' . $name, $name); *{$pkg . "::" . $name} = \$name; my @data = ( $subpkg, $subpkg->tag, map { $subpkg->can($_) } qw(pack pack_array unpack unpack_array) ); { my $const = $tag; *{$pkg . "::" . $name} = sub () { $const } unless defined &{$pkg . "::" . $name}; } *{$pkg . "::_" . $name} = sub { \@data }; } } # Now we have done the naughty stuff, make sure we do no more use strict; sub ber_tag { my($t,$e) = @_; $e ||= 0; # unsigned; if($e < 30) { return (($t & 0xe0) | $e); } $t = ($t | 0x1f) & 0xff; if ($e & 0xffe00000) { die "Too big"; } my @t = (); push(@t, ($b >> 14) | 0x80) if ($b = ($e & 0x001fc000)); push(@t, ($b >> 7) | 0x80) if ($b = ($e & 0xffffff80)); unpack("V",pack("C4",$t,@t,$e & 0x7f,0,0)); } sub new { my $package = shift; my $class = ref($package) || $package; my $self = bless [ @_ == 1 ? shift : "", 0, ref($package) ? $package->[ Convert::BER::_INDEX() ] : [], ], $class; @_ ? $self->encode(@_) : $self; } ## ## Some basic subs for packing/unpacking data ## These methods would be called by the BER-type classes ## sub num_length { return 1 if ( ($_[0] & 0xff) == $_[0]); return 2 if ( ($_[0] & 0xffff) == $_[0]); return 3 if ( ($_[0] & 0xffffff) == $_[0]); return 4; } sub pos { my $ber = shift; @_ ? ($ber->[ Convert::BER::_POS() ] = shift) : $ber->[ Convert::BER::_POS() ]; } sub pack { my $ber = shift; $ber->[ Convert::BER::_BUFFER() ] .= $_[0]; 1; } sub unpack { my($ber,$len) = @_; my $pos = $ber->[ Convert::BER::_POS() ]; my $npos = $pos + $len; die "Buffer empty" if ($npos > CORE::length($ber->[ Convert::BER::_BUFFER() ])); $ber->[ Convert::BER::_POS() ] = $npos; substr($ber->[ Convert::BER::_BUFFER() ],$pos,$len); } sub pack_tag { my($ber,$tag) = @_; # small tag number are more common, so check $tag size in reverse order unless(($tag & 0x1f) == 0x1f) { $ber->[ Convert::BER::_BUFFER() ] .= chr( $tag ); return 1; } unless($tag & ~0x7fff) { $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("v",$tag); return 2; } unless($tag & ~0x7fffff) { $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("vc",$tag, ($tag >> 16)); return 3; } $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("V",$tag); return 4; } sub unpack_tag { my($ber,$expect) = @_; my $pos = $ber->[ Convert::BER::_POS() ]; my $len = CORE::length($ber->[ Convert::BER::_BUFFER() ]); die "Buffer empty" if($pos >= $len); my $tag = CORE::unpack("C",substr($ber->[ Convert::BER::_BUFFER() ],$pos++,1 )); if(($tag & 0x1f) == 0x1f) { my $b; my $s = 8; do { die "Buffer empty" if($pos >= $len); $b = CORE::unpack("C",substr($ber->[ Convert::BER::_BUFFER() ],$pos++,1)); $tag |= $b << $s; $s += 8; } while($b & 0x80); } die sprintf("Expecting tag 0x%x, found 0x%x",$expect,$tag) if(defined($expect) && ($tag != $expect)); $ber->[ Convert::BER::_POS() ] = $pos; $tag } sub pack_length { my($ber,$len) = @_; if($len & ~0x7f) { my $lenlen = num_length($len); $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("C", $lenlen | 0x80) . substr(CORE::pack("N",$len), 0 - $lenlen); return $lenlen + 1; } $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("C", $len); return 1; } sub unpack_length { my $ber = shift; my $pos = $ber->[ Convert::BER::_POS() ]; die "Buffer empty" if($pos >= CORE::length($ber->[ Convert::BER::_BUFFER() ])); my $len = CORE::unpack("C", substr($ber->[ Convert::BER::_BUFFER() ],$pos++,1)); if($len & 0x80) { my $buf; $len &= 0x7f; die "Buffer empty" if(($pos+$len) > CORE::length($ber->[ Convert::BER::_BUFFER() ])); my $tmp = "\0" x (4 - $len) . substr($ber->[ Convert::BER::_BUFFER() ],$pos,$len); $pos += $len; $len = $len ? CORE::unpack("N",$tmp) : -1; } $ber->[ Convert::BER::_POS() ] = $pos; $len; } ## ## User interface (public) method ## sub error { my $ber = shift; $ber->[ Convert::BER::_ERROR() ]; } sub tag { my $ber = shift; my $pos = $ber->[ Convert::BER::_POS() ]; my $tag = eval { local($SIG{'__DIE__'}); unpack_tag($ber) } or return undef; $ber->[ Convert::BER::_POS() ] = $pos; $tag; } sub length { my $ber = shift; CORE::length($ber->[ Convert::BER::_BUFFER() ]); } sub buffer { my $ber = shift; if(@_) { $ber->[ Convert::BER::_POS() ] = 0; $ber->[ Convert::BER::_BUFFER() ] = "" . shift; } $ber->[ Convert::BER::_BUFFER() ]; } ## ## just for debug :-) ## sub _hexdump { my($fmt,$pos) = @_[1,2]; # Don't copy buffer $pos ||= 0; my $offset = 0; my $cnt = 1 << 4; my $len = CORE::length($_[0]); my $linefmt = ("%02X " x $cnt) . "%s\n"; print "\n"; while ($offset < $len) { my $data = substr($_[0],$offset,$cnt); my @y = CORE::unpack("C*",$data); printf $fmt,$pos if $fmt; # On the last time through replace '%02X ' with '__ ' for the # missing values substr($linefmt, 5*@y,5*($cnt-@y)) = "__ " x ($cnt - @y) if @y != $cnt; # Change non-printable chars to '.' $data =~ s/[\x00-\x1f\x7f-\xff]/./sg; printf $linefmt, @y,$data; $offset += $cnt; $pos += $cnt; } } my %type = ( split(/[\t\n]\s*/, q(10 SEQUENCE 01 BOOLEAN 0A ENUM 11 SET 02 INTEGER 03 BIT STRING C0 PRIVATE [%d] 04 STRING 40 APPLICATION [%d] 05 NULL 06 OBJECT ID 80 CONTEXT [%d] ) ) ); sub dump { my $ber = shift; my $fh = @_ ? shift : \*STDERR; my $ofh = select($fh); my $pos = 0; my $indent = ""; my @seqend = (); my $length = CORE::length($ber->[ Convert::BER::_BUFFER() ]); my $fmt = $length > 0xffff ? "%08X" : "%04X"; local $ber->[ Convert::BER::_POS() ]; $ber->[ Convert::BER::_POS() ] = 0; while(1) { while (@seqend && $ber->[ Convert::BER::_POS() ] >= $seqend[0]) { $indent = substr($indent,2); shift @seqend; printf "$fmt : %s}\n",$ber->[ Convert::BER::_POS() ],$indent; } last unless $ber->[ Convert::BER::_POS() ] < $length; my $start = $ber->[ Convert::BER::_POS() ]; my $tag = unpack_tag($ber); my $pos = $ber->[ Convert::BER::_POS() ]; my $len = Convert::BER::unpack_length($ber); if($tag == 0 && $len == 0) { $seqend[0] = 0; redo; } printf $fmt. " %02X %4d: %s",$start,$tag,$len,$indent; my $label = $type{sprintf("%02X",$tag & ~0x20)} || $type{sprintf("%02X",$tag & 0xC0)} || "UNIVERSAL [%d]"; if (($tag & 0x1f) == 0x1f) { my $k = $tag >> 8; my $j = 0; while($k) { $j = ($j << 7) | ($k & 0x7f); $k >>= 8; } my $l = $label; $l =~ s/%d/0x%x/; printf $l, $j; } else { printf $label, $tag & ~0xE0; } if ($tag & BER_CONSTRUCTOR) { print " {\n"; if($len < 0) { unshift(@seqend, ~(1<<31)); } else { unshift(@seqend, $ber->[ Convert::BER::_POS() ] + $len); } $indent .= " "; next; } $ber->[ Convert::BER::_POS() ] = $pos; my $tmp; for ($label) { # switch /^INTEGER/ && do { Convert::BER::INTEGER->unpack($ber,\$tmp); printf " = %d\n",$tmp; last; }; /^ENUM/ && do { Convert::BER::ENUM->unpack($ber,\$tmp); printf " = %d\n",$tmp; last; }; /^BOOLEAN/ && do { Convert::BER::BOOLEAN->unpack($ber,\$tmp); printf " = %s\n",$tmp ? 'TRUE' : 'FALSE'; last; }; /^OBJECT ID/ && do { Convert::BER::OBJECT_ID->unpack($ber,\$tmp); printf " = %s\n",$tmp; last; }; /^NULL/ && do { $ber->[ Convert::BER::_POS() ] = $pos+1; print "\n"; last; }; /^STRING/ && do { Convert::BER::STRING->unpack($ber,\$tmp); if ($tmp =~ /[\x00-\x1f\x7f-\xff]/s) { _hexdump($tmp,$fmt . " : ".$indent, $pos); } else { printf " = '%s'\n",$tmp; } last; }; /^BIT STRING/ && do { Convert::BER::BIT_STRING->unpack($ber,\$tmp); print " = ",$tmp,"\n"; last; }; # default -- dump hex data Convert::BER::STRING->unpack($ber,\$tmp); _hexdump($tmp,$fmt . " : ".$indent, $pos); } } select($ofh); } sub hexdump { my $ber = shift; my $fh = @_ ? shift : \*STDERR; my $ofh = select($fh); _hexdump($ber->[ Convert::BER::_BUFFER() ]); print "\n"; select($ofh); } ## ## And now the real guts of it, the encoding and decoding routines ## sub encode { my $ber = shift; local($SIG{'__DIE__'}); $ber->[ Convert::BER::_INDEX() ] = []; return $ber if eval { Convert::BER::_encode($ber,\@_) }; $ber->[ Convert::BER::_ERROR() ] = $@; undef; } sub _encode { my $ber = shift; my $desc = shift; my $i = 0; while($i < @$desc ) { my $type = $desc->[$i++]; my $arg = $desc->[$i++]; my $tag = undef; ($type,$tag) = @$type if(ref($type) eq 'ARRAY'); my $can = $ber->can('_' . $type); die "Unknown element '$type'" unless $can; my $data = &$can(); my $pkg = $data->[ Convert::BER::_PACKAGE() ]; $tag = $data->[ Convert::BER::_TAG() ] unless defined $tag; $arg = &{$arg}(@{$ber->[ Convert::BER::_INDEX() ]}) if(ref($arg) eq 'CODE'); if(ref($arg) eq 'ARRAY') { if($can = $data->[Convert::BER::_PACK_ARRAY() ]) { pack_tag($ber,$tag) if defined $tag; &{$can}($pkg,$ber,$arg); } else { my $a; foreach $a (@$arg) { pack_tag($ber,$tag) if defined $tag; &{$data->[Convert::BER::_PACK() ]}($pkg,$ber,$a); } } } else { pack_tag($ber,$tag) if defined $tag; &{$data->[Convert::BER::_PACK() ]}($pkg,$ber,$arg); } } 1; } sub decode { my $ber = shift; my $pos = $ber->[ Convert::BER::_POS() ]; local($SIG{'__DIE__'}); $ber->[ Convert::BER::_INDEX() ] = []; return $ber if eval { Convert::BER::_decode($ber,\@_) }; $ber->[ Convert::BER::_ERROR() ] = $@; $ber->[ Convert::BER::_POS() ] = $pos; undef; } sub _decode { my $ber = shift; my $desc = shift; my $i = 0; my $argc; TAG: for($argc = @$desc ; $argc > 0 ; $argc -= 2) { my $type = $desc->[$i++]; my $arg = $desc->[$i++]; my $tag = undef; ($type,$tag) = @$type if(ref($type) eq 'ARRAY'); my $can = $ber->can('_' . $type); die "Unknown element '$type'" unless $can; my $data = &$can(); my $pkg = $data->[ Convert::BER::_PACKAGE() ]; $tag = $data->[ Convert::BER::_TAG() ] unless defined $tag; $arg = &{$arg}(@{$ber->[ Convert::BER::_INDEX() ]}) if(ref($arg) eq 'CODE'); if(ref($arg) eq 'ARRAY') { if($data->[ Convert::BER::_UNPACK_ARRAY() ]) { unpack_tag($ber,$tag) if(defined $tag); &{$data->[ Convert::BER::_UNPACK_ARRAY() ]}($pkg,$ber,$arg); } else { @$arg = (); while(CORE::length($ber->[ Convert::BER::_BUFFER() ]) > $ber->[ Convert::BER::_POS() ]) { if(defined $tag) { next TAG unless eval { unpack_tag($ber,$tag) }; } push @$arg, undef; &{$data->[ Convert::BER::_UNPACK() ]}($pkg,$ber,\$arg->[-1]); } } } else { eval { unpack_tag($ber,$tag) if(defined $tag); &{$data->[ Convert::BER::_UNPACK() ]}($pkg,$ber,$arg); 1; } or ($$arg = undef, die); } } 1; } ## ## a couple of routines to interface to a file descriptor. ## sub read { my $ber = shift; my $io = shift; my $indef = shift; # We need to read one packet, and exactly only one packet. # So we have to read the first few bytes one at a time, until # we have enough to decode a tage and a length. We then know # how many more bytes to read $ber = $ber->new unless ref($ber); $ber->[ _BUFFER() ] = "" unless $indef; my $pos = CORE::length($ber->[ _BUFFER() ]); my $start = $pos; # The first byte is the tag sysread($io,$ber->[ _BUFFER() ],1,$pos++) or goto READ_ERR; # print STDERR "-"x80,"\n"; # print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n"; my $ch = ord(substr($ber->[ _BUFFER() ],-1)); # Tag may be multi-byte if(($ch & 0x1f) == 0x1f) { do { sysread($io, $ber->[ _BUFFER() ], 1, $pos++) or goto READ_ERR; $ch = ord(substr($ber->[ _BUFFER() ],-1)); } while($ch & 0x80); } # print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n"; # The next byte will be the first byte of the length sysread($io, $ber->[ _BUFFER() ], 1, $pos++) or goto READ_ERR; # print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n"; $ch = ord(substr($ber->[ _BUFFER() ],-1)); # print STDERR CORE::unpack("H*",substr($ber->[ _BUFFER() ],-1))," $ch\n"; # May be a multi-byte length if($ch & 0x80) { my $len = $ch & 0x7f; unless ($len) { # print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n"; # OK we have an indefinate length while(1) { Convert::BER::read($ber,$io,1); my $p = CORE::length($ber->[ _BUFFER() ]); if(($p - $pos) == 2 && substr($ber->[ _BUFFER() ],-2) eq "\0\0") { # print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n","-"x80,"\n"; return $ber; } $pos = $p; } } while($len) { my $n = sysread($io, $ber->[ _BUFFER() ], $len, $pos) or goto READ_ERR; $len -= $n; $pos += $n; } } # print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n"; # We can now unpack a tage and a length to determine how many more # bytes to read $ber->[ _POS() ] = $start; unpack_tag($ber); my $len = unpack_length($ber); while($len > 0) { my $got; goto READ_ERR unless( $got = sysread($io, $ber->[ _BUFFER() ],$len,CORE::length($ber->[ _BUFFER() ])) ); $len -= $got; } # Reset pos back to the beginning. $ber->[ _POS() ] = 0; # print STDERR CORE::unpack("H*",$ber->[ _BUFFER() ]),"\n"; return $ber; READ_ERR: $@ = "I/O Error $! " . CORE::unpack("H*",$ber->[ _BUFFER() ]); return undef; } sub write { my $ber = shift; my $io = shift; local($SIG{'__DIE__'}); my $togo = CORE::length($ber->[ _BUFFER() ]); my $pos = 0; while($togo) { my $len; unless ($len = syswrite($io, $ber->[ _BUFFER() ],$togo,$pos)) { $@ = "I/O Error $!"; return; } $togo -= $len; $pos += $len; } 1; } sub send { my $ber = shift; my $sock = shift; local($SIG{'__DIE__'}); eval { # Enable reporting a 'Broken pipe' error rather than dying. local ($SIG{PIPE}) = "IGNORE"; @_ ? send($sock,$ber->[ _BUFFER() ],0,$_[0]) : send($sock,$ber->[ _BUFFER() ],0); } or die "I/O Error: $!"; } sub recv { my $ber = shift; my $sock = shift; require Socket; # for Socket::MSG_PEEK local $SIG{'__DIE__'}; $ber = $ber->new unless ref($ber); $ber->[ _BUFFER() ] = ""; # We do not know the size of the datagram, so we have to PEEK --GMB # is there an easier way to determine the packet size ?? my $n = 128; die "I/O Error: $!" unless ((defined recv($sock,$ber->[ _BUFFER() ],$n,Socket::MSG_PEEK())) and not $!); # PEEK until we have the complete tag and length of the BER # packet. Use the length to determine how much data to read from # the socket. This is an attempt to ensure that we read the # entire packet and that we don't read into the next packet, if # there is one. my $len; # Keep reading until we've read enough of the packet to unpack # the BER length field. for(;;) { # If we can decode a tag and length we can detemine the length if(defined($len = eval { $ber->[ _POS() ] = 0; unpack_tag($ber); unpack_length($ber) + $ber->[ _POS() ]; }) # unpack_length will return -1 for unknown length && $len >= $ber->[ _POS() ]) { $n = $len; last; } # peek some more $n <<= 1; die "I/O Error: $!" unless ((defined recv($sock,$ber->[ _BUFFER() ],$n,Socket::MSG_PEEK())) and not $!); } # now we know the size, get it again but without MSG_PEEK # this will cause the kernel to remove the datagram from it's queue # If the data on the socket doesn't correspond to a valid BER # object, the loop above could have read something it thought was # the length and this loop could then block waiting for that many # bytes, which will never arrive. What do you do about something # like that? $ber->[ _POS() ] = 0; $ber->[ _BUFFER() ] = ""; my ($read, $tmp); $read = 0; while ($read < $n) { $ber->[ _PEER() ] = recv($sock, $tmp, $n - $read, 0); die "I/O Error: $!" unless ((defined ( $ber->[ _PEER() ] ) and not $!)); $read += CORE::length($tmp); $ber->[ _BUFFER() ] .= $tmp; } $ber; } ## ## The primitive packages ## package Convert::BER::BER; sub pack { my($self,$ber,$arg) = @_; $ber->[ Convert::BER::_BUFFER() ] .= $arg->[ Convert::BER::_BUFFER() ] if ref($arg); 1; } sub unpack { my($self,$ber,$arg) = @_; my $len = CORE::length($ber->[ Convert::BER::_BUFFER() ]) - $ber->[ Convert::BER::_POS() ]; $$arg = $ber->new(Convert::BER::unpack($ber,$len)); 1; } package Convert::BER::ANY; sub pack { my($self,$ber,$arg) = @_; $ber->[ Convert::BER::_BUFFER() ] .= $arg->[ Convert::BER::_BUFFER() ]; 1; } sub unpack { my($self,$ber,$arg) = @_; my $pos = $ber->[ Convert::BER::_POS() ]; my $tag = Convert::BER::unpack_tag($ber); my $len = Convert::BER::unpack_length($ber) + $ber->[ Convert::BER::_POS() ] - $pos; $ber->[ Convert::BER::_POS() ] = $pos; $$arg = $ber->new(Convert::BER::unpack($ber,$len)); 1; } ## ## ## package Convert::BER::BOOLEAN; sub pack { my($self,$ber,$arg) = @_; Convert::BER::pack_length($ber,1); $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("c", $arg ? 0xff : 0x00); 1; } sub unpack { my($self,$ber,$arg) = @_; my $len = Convert::BER::unpack_length($ber); $$arg = CORE::unpack("c", Convert::BER::unpack($ber,$len)) ? 1 : 0; 1; } ## ## ## package Convert::BER::INTEGER; ## ## Math::BigInt support ## sub pack_bigint { my($self,$ber,$arg) = @_; require Math::BigInt; my $neg = ($arg < 0) ? 1 : 0; my @octet = (); my $num = new Math::BigInt(abs($arg)); $num -= 1 if $neg; while($num > 0) { my($i,$y) = $num->bdiv(256); $num = new Math::BigInt($i); $y = $y ^ 0xff if $neg; unshift(@octet,$y); } @octet = (0) unless @octet; my $msb = ($octet[0] & 0x80) ? 1 : 0; unshift(@octet,$neg ? 0xff : 0x00) if($neg != $msb); Convert::BER::pack_length($ber, scalar @octet); $ber->[ Convert::BER::_BUFFER() ] .= CORE::pack("C*",@octet); 1; } sub unpack_bigint { my($self,$ber,$arg) = @_; require Math::BigInt; my $len = Convert::BER::unpack_length($ber); my @octet = CORE::unpack("C*",Convert::BER::unpack($ber,$len)); my $neg = ($octet[0] & 0x80) ? 1 : 0; my $val = $$arg = 0; while(@octet) { my $oct = shift @octet; $oct = $oct ^ 0xff if $neg; $val *= (1<<8); $val += $oct; } $val = -1 - $val if $neg; 1; } ## ## Math::BigInteger support ## sub pack_biginteger { my($self,$ber,$arg) = @_; my($len,$data); my $offset = 0; require Math::BigInteger; # save has no concept of +/- my $v = $arg->cmp(new Math::BigInteger(0)); if($v) { if($v < 0) { my $b = $arg->bits + 8; $b -= $b % 8; my $tmp = new Math::BigInteger(1); $tmp->lshift(new Math::BigInteger(1), $b); $arg = $tmp + $arg; } $data = $arg->save; $len = CORE::length($data); my $c = ord(substr($data,0,1)); if($c == 0) { for( ; $len > 1 ; $len--, $offset++) { my $ch = ord(substr($data,$offset,1)); if($ch & 0xff) { if($ch & 0x80) { $len++; $offset--; } last; } } } elsif($c == 0xff) { for( ; $len > 1 ; $len--, $offset++) { my $ch = ord(substr($data,$offset,1)); unless($ch == 0xff) { unless($ch & 0x80) { $len++; $offset--; } last; } } } } else { $len = 1; $data = CORE::pack("C",0); } Convert::BER::pack_length($ber,$len); $ber->[ Convert::BER::_BUFFER() ] .= substr($data,$offset); return 1; } sub unpack_biginteger { my($self,$ber,$arg) = @_; require Math::BigInteger; my $len = Convert::BER::unpack_length($ber); my $data = Convert::BER::unpack($ber,$len); my $int = restore Math::BigInteger $data; # restore has no concept of +/- if(ord(substr($data,0,1)) & 0x80) { my $tmp = new Math::BigInteger; $tmp->lshift(new Math::BigInteger(1), $len * 8); $tmp = new Math::BigInteger(0) - $tmp; $int = $tmp + $int; } $$arg = $int; return 1; } ## ## ## sub pack { my($self,$ber,$arg) = @_; if(ref $arg) { goto &pack_bigint if UNIVERSAL::isa($arg,'Math::BigInt'); goto &pack_biginteger if UNIVERSAL::isa($arg,'Math::BigInteger'); } my $neg = ($arg < 0) ? 1 : 0; my $len = Convert::BER::num_length($neg ? ~ $arg : $arg); my $msb = $arg & (0x80 << (($len - 1) * 8)); $len++ if(($msb && not($neg)) || ($neg && not($msb))); Convert::BER::pack_length($ber,$len); $ber->[ Convert::BER::_BUFFER() ] .= substr(CORE::pack("N",$arg), 0 - $len); 1; } sub unpack { my($self,$ber,$arg) = @_; if( ref($arg) && ref($$arg) ) { goto &unpack_bigint if UNIVERSAL::isa($$arg,'Math::BigInt'); goto &unpack_biginteger if UNIVERSAL::isa($$arg,'Math::BigInteger'); } my $len = Convert::BER::unpack_length($ber); my $tmp = "\0" x (4 - $len) . Convert::BER::unpack($ber,$len); my $val = CORE::unpack("N",$tmp); $val -= 0x1 << ($len * 8) if($val & (0x1 << (($len * 8) - 1))); $$arg = $val; 1; } ## ## ## package Convert::BER::NULL; sub pack { my($self,$ber,$arg) = @_; Convert::BER::pack_length($ber,0); } sub unpack { my($self,$ber,$arg) = @_; Convert::BER::unpack_length($ber); $$arg = 1; } ## ## ## package Convert::BER::STRING; sub pack { my($self,$ber,$arg) = @_; Convert::BER::pack_length($ber,CORE::length($arg)); $ber->[ Convert::BER::_BUFFER() ] .= $arg; } sub unpack { my($self,$ber,$arg) = @_; my $len = Convert::BER::unpack_length($ber); $$arg = Convert::BER::unpack($ber,$len); 1; } ## ## ## package Convert::BER::SEQUENCE; sub pack { my($self,$ber,$arg) = @_; Convert::BER::pack_length($ber,CORE::length($arg->[ Convert::BER::_BUFFER() ])); $ber->[ Convert::BER::_BUFFER() ] .= $arg->[ Convert::BER::_BUFFER() ]; 1; } sub unpack { my($self,$ber,$arg) = @_; my $len = Convert::BER::unpack_length($ber); $$arg = $ber->new(Convert::BER::unpack($ber,$len)); 1; } sub pack_array { my($self,$ber,$arg) = @_; my $ber2 = $ber->new; return undef unless defined($ber2->_encode($arg)); Convert::BER::pack_length($ber,CORE::length($ber2->[ Convert::BER::_BUFFER() ])); $ber->[ Convert::BER::_BUFFER() ] .= $ber2->[ Convert::BER::_BUFFER() ]; 1; } sub unpack_array { my($self,$ber,$arg) = @_; my $ber2; $self->unpack($ber,\$ber2); $ber2->_decode($arg); die "Sequence buffer not empty" if CORE::length($ber2->[ Convert::BER::_BUFFER() ]) != $ber2->[ Convert::BER::_POS() ]; 1; } ## ## ## package Convert::BER::OBJECT_ID; sub pack { my($self,$ber,$arg) = @_; my @data = ($arg =~ /(\d+)/g); if(@data < 2) { @data = (0); } else { my $first = $data[1] + ($data[0] * 40); splice(@data,0,2,$first); } @data = map { my @d = ($_); if($_ >= 0x80) { @d = (); my $v = 0 | $_; # unsigned while($v) { unshift(@d, 0x80 | ($v & 0x7f)); $v >>= 7; } $d[-1] &= 0x7f; } @d; } @data; my $data = CORE::pack("C*", @data); Convert::BER::pack_length($ber,CORE::length($data)); $ber->[ Convert::BER::_BUFFER() ] .= $data; 1; } sub unpack { my($self,$ber,$arg) = @_; my $len = Convert::BER::unpack_length($ber); my @ch = CORE::unpack("C*",Convert::BER::unpack($ber,$len)); my @data = (); my $val = 0; while(@ch) { my $ch = shift @ch; $val = ($val << 7) | ($ch & 0x7f); unless($ch & 0x80) { push @data, $val; $val = 0; } } if(@data) { my $first = shift @data; unshift @data, $first % 40; unshift @data, int($first / 40); # unshift @data, ""; } $$arg = join(".",@data); 1; } ## ## ## package Convert::BER::CONSTRUCTED; BEGIN { # Cannot call import here as Convert::BER has not been initialized *BER_CONSTRUCTOR = *Convert::BER::BER_CONSTRUCTOR } sub pack { my($self,$ber,$arg) = @_; Convert::BER::pack_tag($ber,$arg->tag | BER_CONSTRUCTOR); Convert::BER::pack_length($ber,CORE::length($arg->[ Convert::BER::_BUFFER() ])); $ber->[ Convert::BER::_BUFFER() ] .= $arg->[ Convert::BER::_BUFFER() ]; 1; } sub unpack { my($self,$ber,$arg) = @_; my $tag = Convert::BER::unpack_tag($ber); die "Not constructed" unless $tag & BER_CONSTRUCTOR; my $len = Convert::BER::unpack_length($ber); my $buf = $ber->new( Convert::BER::unpack($ber,$len)); die &{$ber}(0,"Bad construction") unless( ($buf->tag | BER_CONSTRUCTOR) == $tag); $$arg = $buf; 1; } sub pack_array { my($self,$ber,$arg) = @_; $self->_encode($arg); } sub unpack_array { my($self,$ber,$arg) = @_; my $ber2; $self->unpack($ber,\$ber2); $ber2->_decode($arg); } ## ## ## package Convert::BER::OPTIONAL; # optional elements # allows skipping in the encode if it comes across structures like # OPTIONAL => [ BOOLEAN => undef ] # or more realistically # my $foo = undef; # $foo = 1 if (arg->{'allowed'}; # $ber->encode(SEQUENCE => [ # STRING => $name, # OPTIONAL => [ BOOLEAN => $foo ] # ]); sub pack_array { my($self,$ber,$arg) = @_; my $a; my @newarg; foreach $a (@$arg) { return unless defined $a; my $c = ref($a) eq "CODE" ? &{$a}(@{$ber->[ Convert::BER::_INDEX() ]}) : $a; return unless defined $c; push @newarg, $c; } shift @newarg if (@newarg & 1); Convert::BER::_encode($ber,\@newarg); } sub unpack_array { my($self,$ber,$arg) = @_; my($yes,$ref); my $pos = $ber->[ Convert::BER::_POS() ]; if(@$arg & 1) { $ref = [ @$arg ]; $yes = shift @$ref; } else { $ref = $arg; } if (eval { Convert::BER::_decode($ber,$ref) }) { $$yes = 1 if ref($yes); } else { $$yes = undef if ref($yes); $ber->[ Convert::BER::_POS() ] = $pos; } 1; } ## ## ## package Convert::BER::SEQUENCE_OF; sub pack_array { my($self,$ber,$arg) = @_; my($n,@desc) = @$arg; my $i; $n = &{$n}(@{$ber->[ Convert::BER::_INDEX() ]}) if ref($n) eq 'CODE'; push(@{$ber->[ Convert::BER::_INDEX() ]},0); my $b = $ber->new; if(ref($n) eq 'HASH') { my $v; foreach $v (keys %$n) { $ber->[ Convert::BER::_INDEX() ][-1] = $v; $b->_encode(\@desc); } } elsif(ref($n) eq 'ARRAY') { my $v; foreach $v (@$n) { $ber->[ Convert::BER::_INDEX() ][-1] = $v; $b->_encode(\@desc); } } else { while($n--) { $b->_encode(\@desc); $ber->[ Convert::BER::_INDEX() ][-1] += 1; } } pop @{$ber->[ Convert::BER::_INDEX() ]}; Convert::BER::pack_length($ber,CORE::length($b->[ Convert::BER::_BUFFER() ])); $ber->[ Convert::BER::_BUFFER() ] .= $b->[ Convert::BER::_BUFFER() ]; 1; } sub unpack_array { my($self,$ber,$arg) = @_; my($nref,@desc) = @$arg; push(@{$ber->[ Convert::BER::_INDEX() ]},0); my $len = Convert::BER::unpack_length($ber); my $b = $ber->new(Convert::BER::unpack($ber,$len)); my $pos = $ber->[ Convert::BER::_POS() ]; my $n; while(CORE::length($b->[ Convert::BER::_BUFFER() ]) > $b->[ Convert::BER::_POS() ]) { $b->_decode(\@desc); $ber->[ Convert::BER::_INDEX() ][-1] += 1; } $$nref = pop @{$ber->[ Convert::BER::_INDEX() ]}; 1; } ## ## ## package Convert::BER::BIT_STRING; sub pack { my($self,$ber,$arg) = @_; my $less = (8 - (CORE::length($arg) & 7)) & 7; $arg .= "0" x $less if $less; my $data = CORE::pack("B*",$arg); Convert::BER::pack_length($ber,CORE::length($data)+1); $ber->[ Convert::BER::_BUFFER() ] .= chr($less) . $data; } sub unpack { my($self,$ber,$arg) = @_; my $len = Convert::BER::unpack_length($ber); my $data = Convert::BER::unpack($ber,$len); my $less; ($less,$data) = CORE::unpack("C B*",$data,); $less = ord($less) & 7; substr($data,-$less) = '' if $less; $$arg = $data; 1; } ## ## ## package Convert::BER::BIT_STRING8; sub pack { my($self,$ber,$arg) = @_; Convert::BER::pack_length($ber,CORE::length($arg)+1); $ber->[ Convert::BER::_BUFFER() ] .= chr(0) . $arg; } sub unpack { my($self,$ber,$arg) = @_; my $len = Convert::BER::unpack_length($ber); my $less = Convert::BER::unpack($ber,1); my $data = $len > 1 ? Convert::BER::unpack($ber,$len-1) : ""; $$arg = $data; 1; } ## ## ## package Convert::BER::REAL; sub pack { my($self,$ber,$arg) = @_; require POSIX; my $data = ""; if($arg) { my $s = 128; if($arg < 0) { $s |= 64; $arg = -$arg; } my @e = (); my @m = (); my($v,$e) = POSIX::frexp($arg); $e -= 53; my $ae = abs($e); if($ae < 0x80) { @e = ($e & 0xff); } elsif($ae < 0x8000) { @e = map { $_ & 0xff } ($e>>8,$e); $s |= 1; } elsif($ae < 0x800000) { @e = map { $_ & 0xff } ($e>>16,$e>>8,$e); $s |= 2; } else { @e = (4, map { $_ & 0xff } ($e>>24,$e>>16,$e>>8,$e)); $s |= 3; } $v = POSIX::ldexp($v,5); my $f = POSIX::floor($v); my $i = int($f); @m = ($i & 0xff); $v -= $f; for (1..2) { $v = POSIX::ldexp($v,24); $f = POSIX::floor($v); $i = int($f); push @m, ($i >> 16) & 0xff, ($i >> 8) & 0xff, $i & 0xff; $v -= $f; } $data = pack("C*",$s,@e,@m); } my $len = length($data); Convert::BER::pack_length($ber,$len); Convert::BER::pack($ber,$data) if $len; } my @base = (1,3,4,4); sub unpack { my($self,$ber,$arg) = @_; my $len = Convert::BER::unpack_length($ber); unless($len) { $$arg = undef; return 1; } my $data = Convert::BER::unpack($ber,$len); my $byte = unpack("C*",$data); if($byte & 0x80) { $data = reverse $data; chop($data); require POSIX; # The sins for using REAL my $base = $base[($byte & 0x30) >> 4]; my $scale = $base & 0xC; my $elen = $byte & 0x3; $elen = ord(chop($data)) - 1 if $elen == 3; die "Bad REAL encoding" unless $elen >= 0 && $elen <= 3; my $exp = ord chop($data); $exp = -256 + $exp if $exp > 127; while ($elen--) { $exp *= 256; $exp += ord chop($data); } $exp = $exp * $base + $scale; my $v = 0; while(length($data)) { $v = POSIX::ldexp($v,8) + ord chop($data); } $v = POSIX::ldexp($v,$exp) if $exp; $v = -1 * $v if $byte & 0x40; # negative $$arg = $v; } elsif($byte & 0x40) { require POSIX; $$arg = POSIX::HUGE_VAL() * (($byte & 1) ? -1 : 1); } elsif(substr($data,1) =~ /^\s*([-+]?)0*(\d+(?:\.\d+(?:[Ee][-+]?\d+)?)?)\s*$/) { $$arg = eval "$1$2"; } else { $$arg = undef; } 1; } ## ## ## package Convert::BER::_Time_generic; sub pack { my($self,$ber,$arg) = @_; my $islocal = $self->isa('Convert::BER::TimeUL') || $self->isa('Convert::BER::TimeGL'); my $isgen = $self->isa('Convert::BER::TimeGL') || $self->isa('Convert::BER::TimeGZ'); my @time = $islocal ? localtime($arg) : gmtime($arg); my $off = 'Z'; if($islocal) { my @g = gmtime($arg); my $v = ($time[1] - $g[1]) + ($time[2] - $g[2]) * 60; my $d = $time[7] - $g[7]; if($d == 1 || $d < -1) { $v += 1440; } elsif($d > 1) { $v -= 1440; } $off = sprintf("%+03d%02d",$v / 60, abs($v % 60)); } $time[4] += 1; $time[5] = $isgen ? $time[5] + 1900 : $time[5] % 100; my $str = sprintf("%02d"x6, @time[5,4,3,2,1,0]); if($isgen) { my $split = $arg - int($arg); $str .= sprintf(".%03d", int($split * 1000)) if($split); } Convert::BER::STRING::pack($self,$ber,$str . $off); } sub unpack { my($self,$ber,$arg) = @_; my $str; if(Convert::BER::STRING::unpack($self,$ber,\$str)) { my $isgen = $self->isa('Convert::BER::TimeGL') || $self->isa('Convert::BER::TimeGZ'); my $n = $isgen ? 4 : 2; my ($Y,$M,$D,$h,$m,$s,$z) = $str =~ /^ (\d{$n}) (\d\d) (\d\d) (\d\d) (\d\d) ((?:\d\d(?:\.\d+)?)?) (Z|[-+]\d{4}) $/x or die "Bad Time string '$str'"; my $offset = 0; if($z ne 'Z') { use integer; $offset = ((($z / 100) * 60) + ($z % 100)) * 60; } if($s > int($s)) { # fraction of a seccond $offset -= ($s - int($s)); } $M -= 1; if($isgen) { # GeneralizedTime uses 4-digit years $Y -= 1900; } elsif($Y <= 50) { # ASN.1 UTCTime $Y += 100; # specifies <=50 = 2000..2050, >50 = 1951..1999 } require Time::Local; $$arg = Time::Local::timegm(int($s),$m,$h,$D,$M,$Y) - $offset; } } package Convert::BER::CHOICE; sub pack_array { my($self,$ber,$arg) = @_; my $n = $arg->[0]; if(defined($n)) { my $i = ($n * 2) + 2; die "Bad CHOICE index $n" if $n < 0 || $i > @$arg; $ber->_encode([$arg->[$i-1], $arg->[$i]]); } 1; } sub unpack_array { my($self,$ber,$arg) = @_; my($i,$m,$err); $m = @$arg; my $want = Convert::BER::tag($ber); for($i = 1 ; $i < $m ; $i += 2) { my $tag; my $type = $arg->[$i]; ($type,$tag) = @$type if(ref($type) eq 'ARRAY'); my $can = UNIVERSAL::can($ber,'_' . $type); die "Unknown element '$type'" unless $can; my $data = &$can(); $tag = $data->[ Convert::BER::_TAG() ] unless defined $tag; next unless $tag == $want; if ( eval { Convert::BER::_decode($ber,[@{$arg}[$i,$i+1]]) }) { my $choice = $arg->[0]; $$choice = ($i - 1) >> 1; return 1; } $err = $@ if $@; } die ($err || sprintf("Cannot decode CHOICE, found tag 0x%X\n",$want)); } 1; libconvert-ber-perl-1.3200/MANIFEST.SKIP0000644000175000017500000000031311267732511016316 0ustar nachonacho^_build ^Build$ ^blib ~$ \.bak$ \.DS_Store cover_db \..*\.sw.?$ ^Makefile$ ^pm_to_blib$ ^MakeMaker-\d ^blibdirs$ \.old$ ^#.*#$ ^\.# ^TODO$ ^PLANS$ ^doc/ ^benchmarks ^\._.*$ \.shipit ^Convert-BER \.git.* libconvert-ber-perl-1.3200/t/0000755000175000017500000000000011267733100014661 5ustar nachonacholibconvert-ber-perl-1.3200/t/00prim.t0000644000175000017500000001263711150563443016170 0ustar nachonacho#!/usr/local/bin/perl BEGIN { if ($] >= 5.006) { require bytes; 'bytes'->import; } } # # Test that the primitive operators are working # use Convert::BER; print "1..90\n"; $tcount = $test = 1; sub test (&) { my $sub = shift; eval { $sub->() }; print "not ok ",$test++,"\n" while($test < $tcount); warn "count mismatch test=$test tcount=$tcount" unless $test == $tcount; $tcount = $test; } ## ## Assumptions. I assume perl truncates values for me, check them ## $tcount += 6; test { my $tag = 0x31323334; print "not " unless chr($tag) eq "4"; print "ok ",$test++,"\n"; print "not " unless pack("n",$tag) eq "34"; print "ok ",$test++,"\n"; print "not " unless pack("nc",$tag>>8,$tag) eq "234"; print "ok ",$test++,"\n"; $tag = 0x81828384; print "not " unless ord(chr($tag)) == 0x84; print "ok ",$test++,"\n"; print "not " unless pack("n",$tag) eq pack("C*",0x83,0x84); print "ok ",$test++,"\n"; print "not " unless pack("nc",$tag>>8,$tag) eq pack("C*",0x82,0x83,0x84); print "ok ",$test++,"\n"; }; ## ## NULL ## $tcount += 4; test { print "# NULL\n"; $ber = Convert::BER->new->encode( NULL => 0 ) or die; print "ok ",$test++,"\n"; my $result = pack("C*", 0x05, 0x00); die unless $ber->buffer eq $result; print "ok ",$test++,"\n"; my $null = undef; $ber->decode(NULL => \$null) or die; print "ok ",$test++,"\n"; die unless $null; print "ok ",$test++,"\n"; }; ## ## BOOLEAN (tests 4 - 12) ## foreach $val (0,1,-99) { print "# BOOLEAN $val\n"; $tcount += 5; test { my $ber = Convert::BER->new->encode( BOOLEAN => $val) or die; print "ok ",$test++,"\n"; my $result = pack("C*", 0x01, 0x01, $val ? 0xFF : 0); die unless $ber->buffer eq $result; print "ok ",$test++,"\n"; my $bool = undef; die unless $ber->decode( BOOLEAN => \$bool); print "ok ",$test++,"\n"; die unless defined($bool); print "ok ",$test++,"\n"; die unless(!$bool == !$val); print "ok ",$test++,"\n"; }; } ## ## INTEGER (tests 13 - 21) ## my %INTEGER = ( 0 => pack("C*", 0x02, 0x01, 0x00), 0x667799 => pack("C*", 0x02, 0x03, 0x66, 0x77, 0x99), -457 => pack("C*", 0x02, 0x02, 0xFE, 0x37), ); while(($v,$result) = each %INTEGER) { $val = eval($v); print "# INTEGER $val\n"; $tcount += 5; test { my $ber = Convert::BER->new->encode( INTEGER => $val) or die; print "ok ",$test++,"\n"; die unless $ber->buffer eq $result; print "ok ",$test++,"\n"; my $int = undef; die unless $ber->decode( INTEGER => \$int); print "ok ",$test++,"\n"; die unless defined($int); print "ok ",$test++,"\n"; die unless ($int == $val); print "ok ",$test++,"\n"; } } ## ## STRING ## my %STRING = ( "" => pack("C*", 0x04, 0x00), "A string" => pack("CCa*", 0x04, 0x08, "A string"), ); while(($val,$result) = each %STRING) { print "# STRING '$val'\n"; $tcount += 5; test { my $ber = Convert::BER->new->encode( STRING => $val) or die; print "ok ",$test++,"\n"; die unless $ber->buffer eq $result; print "ok ",$test++,"\n"; my $str = undef; die unless $ber->decode( STRING => \$str); print "ok ",$test++,"\n"; die unless defined($str); print "ok ",$test++,"\n"; die unless ($str eq $val); print "ok ",$test++,"\n"; } } ## ## OBJECT_ID ## my %OBJECT_ID = ( "1.2.3.4.5" => pack("C*", 0x06, 0x04, 0x2A, 0x03, 0x04, 0x05), "2.5.457" => pack("C*", 0x06, 0x03, 0x55, 0x83, 0x49), ); while(($val,$result) = each %OBJECT_ID) { print "# OBJECT_ID $val\n"; $tcount += 5; test { my $ber = Convert::BER->new->encode( OBJECT_ID => $val) or die; print "ok ",$test++,"\n"; die unless $ber->buffer eq $result; print "ok ",$test++,"\n"; my $oid = undef; die unless $ber->decode( OBJECT_ID => \$oid); print "ok ",$test++,"\n"; die unless defined($oid); print "ok ",$test++,"\n"; die unless ($oid eq $val); print "ok ",$test++,"\n"; } } ## ## ENUM ## my %ENUM = ( 0 => pack("C*", 0x0A, 0x01, 0x00), -99 => pack("C*", 0x0A, 0x01, 0x9D), 6573456 => pack("C*", 0x0A, 0x03, 0x64, 0x4D, 0x90), ); while(($v,$result) = each %ENUM) { $val = eval($v); print "# ENUM $val\n"; $tcount += 5; test { my $ber = Convert::BER->new->encode( ENUM => $val) or die; print "ok ",$test++,"\n"; die unless $ber->buffer eq $result; print "ok ",$test++,"\n"; my $enum = undef; die unless $ber->decode( ENUM => \$enum); print "ok ",$test++,"\n"; die unless defined($enum); print "ok ",$test++,"\n"; die unless ($enum == $val); print "ok ",$test++,"\n"; } } ## ## BIT STRING ## my %BSTR = ( '0' => pack("C*", 0x03, 0x02, 0x07, 0x00), '00110011' => pack("C*", 0x03, 0x02, 0x00, 0x33), '011011100101110111' => pack("C*", 0x03, 0x04, 0x06, 0x6E, 0x5D, 0xC0), ); while(($val,$result) = each %BSTR) { print "# BIT STRING $val\n"; $tcount += 5; test { my $ber = Convert::BER->new->encode( BIT_STRING => $val) or die; print "ok ",$test++,"\n"; die unless $ber->buffer eq $result; print "ok ",$test++,"\n"; my $bstr = undef; die unless $ber->decode( BIT_STRING => \$bstr); print "ok ",$test++,"\n"; die unless defined($bstr); print "ok ",$test++,"\n"; die unless ($bstr eq $val); print "ok ",$test++,"\n"; } } libconvert-ber-perl-1.3200/t/02seq.t0000644000175000017500000000206111150563443016001 0ustar nachonacho#!/usr/local/bin/perl # # Test the use of sequences # use Convert::BER; print "1..5\n"; $test = 1; $ber = Convert::BER->new->encode( SEQUENCE => [ INTEGER => 1, BOOLEAN => 0, STRING => "A string" ] ); if($ber) { my $data = $ber->buffer; print "ok ",$test++,"\n"; my $result = pack("C*", 0x30, 0x10, 0x02, 0x01, 0x01, 0x01, 0x01, 0x00, 0x04, 0x08, 0x41, 0x20, 0x73, 0x74, 0x72, 0x69, 0x6E, 0x67 ); print "not " unless $ber->buffer eq $result; print "ok ",$test++,"\n"; my $seq = undef; print "not " unless $ber->decode(SEQUENCE => \$seq) && $seq; print "ok ",$test++,"\n"; print "not " unless substr($result,2) eq $seq->buffer; print "ok ",$test++,"\n"; $ber = new Convert::BER($data); my($int,$bool,$str); $ber->decode( SEQUENCE => [ INTEGER => \$int, BOOLEAN => \$bool, STRING => \$str, ] ) && ($int == 1) && !$bool && ($str eq "A string") or print "not "; print "ok ",$test++,"\n"; } print "not ok ",$test++,"\n" while($test <= 5); libconvert-ber-perl-1.3200/t/07io.t0000644000175000017500000000276611150563443015641 0ustar nachonacho#!/usr/local/bin/perl # # Test that the primitive operators are working # use Convert::BER; my $sock = require IO::Socket; print $sock ? "1..5\n" : "1..2\n"; my $result = pack("C*", 0x30, 0x3D, 0x04, 0x04, 0x46, 0x72, 0x65, 0x64, 0x30, 0x13, 0x04, 0x11, 0x41, 0x20, 0x73, 0x74, 0x72, 0x69, 0x6E, 0x67, 0x20, 0x66, 0x6F, 0x72, 0x20, 0x66, 0x72, 0x65, 0x64, 0x04, 0x03, 0x4A, 0x6F, 0x65, 0x30, 0x1B, 0x04, 0x03, 0x68, 0x61, 0x73, 0x04, 0x01, 0x61, 0x04, 0x04, 0x6C, 0x69, 0x73, 0x74, 0x04, 0x02, 0x6F, 0x66, 0x04, 0x07, 0x73, 0x74, 0x72, 0x69, 0x6E, 0x67, 0x73); my $ber = Convert::BER->new($result); ($file = $0) =~ s/t$/dat/; open(OUT,"> $file"); $ber->write(\*OUT); close(OUT); open(IN,"< $file"); sysread(IN,$buffer,1024); close(IN); print "not " unless $buffer eq $result; print "ok 1\n"; open(IN,"< $file"); $ber = Convert::BER->new; $ber->read(\*IN); close(IN); print "not " unless $ber->buffer eq $result; print "ok 2\n"; unlink($file); if( require IO::Socket ) { use Socket; my $src = IO::Socket::INET->new(Proto => 'udp'); my $dst = IO::Socket::INET->new(Proto => 'udp'); bind($dst, pack_sockaddr_in(0, INADDR_ANY)); my $host = $dst->sockhost eq '0.0.0.0' ? '127.0.0.1' : $dst->sockhost; my $addr = pack_sockaddr_in($dst->sockport, inet_aton($host)); $ber->send($src,$addr) or print "not "; print "ok 3\n"; my $b2 = Convert::BER->recv($dst) or print "not "; print "ok 4\n"; print "not " unless $b2 && $b2->buffer eq $result; print "ok 5\n"; } libconvert-ber-perl-1.3200/t/04comp.t0000644000175000017500000000324211150563443016153 0ustar nachonacho#!/usr/local/bin/perl # # Complex test # use Convert::BER; print "1..1\n"; @data = ( [ 0, { fred => 'joe' } ], [ 1, { beth => [ 'jack', 'paul' ] } ] ); $ber = new Convert::BER; $ber->encode( SEQUENCE => [ INTEGER => 1, SEQUENCE_OF => [ \@data, # this sub will be called for each # element in the array @data # each element of @data is an array ref # of which the first element is a number ENUM => sub { $_[0]->[0] }, # this sub will be called for each # element in the array @data # each element of @data is an array ref # of which the second element is a hashref SEQUENCE_OF => [ sub { $_[0]->[1] }, # this sub will be called for each # key in the hashref returned by the sub above # $_[0] will be the hashref, $_[1] will # be the key being processed STRING => sub { $_[1] }, SET => [ # Depending on whether the hashref entry # contains a scalar or an array ref will # determine how many strings are added STRING => sub { $_[0]->[1]{$_[1]} } ] ] ] ] ); my $result = pack("C*", 0x30, 0x30, 0x02, 0x01, 0x01, 0x30, 0x2B, 0x0A, 0x01, 0x00, 0x30, 0x0D, 0x04, 0x04, 0x66, 0x72, 0x65, 0x64, 0x31, 0x05, 0x04, 0x03, 0x6A, 0x6F, 0x65, 0x0A, 0x01, 0x01, 0x30, 0x14, 0x04, 0x04, 0x62, 0x65, 0x74, 0x68, 0x31, 0x0C, 0x04, 0x04, 0x6A, 0x61, 0x63, 0x6B, 0x04, 0x04, 0x70, 0x61, 0x75, 0x6C); print "not " unless $ber->buffer eq $result; print "ok 1\n"; libconvert-ber-perl-1.3200/t/06opt.t0000644000175000017500000000210711150563443016020 0ustar nachonacho#!/usr/local/bin/perl # # Test that the primitive operators are working # use Convert::BER; print "1..6\n"; # This testcase needs more tests $tcount = $test = 1; sub test (&) { my $sub = shift; eval { $sub->() }; print "not ok ",$test++,"\n" while($test < $tcount); warn "count mismatch test=$test tcount=$tcount" unless $test == $tcount; $tcount = $test; } ## ## Test building optional ## $tcount += 4; test { my $ber = Convert::BER->new->encode( OPTIONAL => [ INTEGER => 0x35 ] ) or die; print "ok ",$test++,"\n"; my $result = pack("C*", 0x02, 0x01, 0x35); die $ber->hexdump unless $ber->buffer eq $result; print "ok ",$test++,"\n"; my $int; $ber->decode( OPTIONAL => [ INTEGER => \$int ]) or die; print "ok ",$test++,"\n"; die unless $int == 0x35; print "ok ",$test++,"\n"; }; $tcount += 2; test { my $ber = Convert::BER->new->encode( OPTIONAL => [ INTEGER => undef ] ) or die; print "ok ",$test++,"\n"; my $result = ""; die $ber->dump unless $ber->buffer eq $result; print "ok ",$test++,"\n"; }; libconvert-ber-perl-1.3200/t/09hightags.t0000644000175000017500000001714711150563443017031 0ustar nachonacho#!/usr/local/bin/perl # # Test that high tag values (greater than 30) work # use lib "/l/dbi"; use Convert::BER 1.31 qw(/BER/ ber_tag); print "1..213\n"; $tcount = $test = 1; sub test (&) { my $sub = shift; eval { $sub->() }; ## print "# $@" if $@; print "not ok ",$test++," # skipped\n" while($test < $tcount); warn "count mismatch test=$test tcount=$tcount" unless $test == $tcount; $tcount = $test; } ## ## IMPLICIT TAG, inline ## @TAGS = (# Value Bytes in tag ################################################### [ber_tag(0,38), 0x1f, 0x26], [ber_tag(BER_CONTEXT,39), 0x9f, 0x27], [ber_tag(BER_APPLICATION,40), 0x5f, 0x28], [ber_tag(BER_UNIVERSAL,41), 0x1f, 0x29], [ber_tag(BER_PRIVATE,42), 0xdf, 0x2a], [ber_tag(BER_PRIMITIVE,43), 0x1f, 0x2b], [ber_tag(BER_CONSTRUCTOR,44), 0x3f, 0x2c], [ber_tag(0,0x138), 0x1f, 0x82, 0x38], [ber_tag(BER_CONTEXT,0x139), 0x9f, 0x82, 0x39], [ber_tag(BER_APPLICATION,0x140), 0x5f, 0x82, 0x40], [ber_tag(BER_UNIVERSAL,0x141), 0x1f, 0x82, 0x41], [ber_tag(BER_PRIVATE,0x142), 0xdf, 0x82, 0x42], [ber_tag(BER_PRIMITIVE,0x143), 0x1f, 0x82, 0x43], [ber_tag(BER_CONSTRUCTOR,0x144), 0x3f, 0x82, 0x44], [ber_tag(BER_CONTEXT | BER_CONSTRUCTOR, 1), 0xa1], ); # [type, value, length and value bytes]. @VALUES = ([STRING => "A string", 0x08, 0x41, 0x20, 0x73, 0x74, 0x72, 0x69, 0x6E, 0x67], [SEQUENCE => [INTEGER => 1, BOOLEAN => 0, STRING => "A string",], 0x10, # length 0x02, 0x01, 0x01, # integer 0x01, 0x01, 0x00, # boolean 0x04, 0x08, 0x41, 0x20, 0x73, 0x74, 0x72, 0x69, 0x6E, 0x67 # string ], ); foreach $tagref (@TAGS) { my ($tag, @tag) = @$tagref; foreach $valref (@VALUES) { my ($type, $val, @result) = @$valref; printf "# [$type => 0x%x] => %s\n", $tag, (ref $val) ? "@$val" : $val; $tcount += 6; test { my $ber = Convert::BER->new->encode([$type=>$tag] => $val) or die; print "ok ",$test++,"\n"; die "Bad tag value" unless $ber->tag() == $tag; print "ok ",$test++,"\n"; my $result = pack("C*", @tag, @result); die "Bad result" unless $ber->buffer eq $result; print "ok ",$test++,"\n"; if ("STRING" eq $type) { my $str = undef; $ber->decode( [ $type => $tag ] => \$str) or die; print "ok ",$test++,"\n"; die "Defined" unless defined($str); print "ok ",$test++,"\n"; die "Equal" unless ($str eq $val); print "ok ",$test++,"\n"; } elsif ("SEQUENCE" eq $type) { my ($int, $bool, $str) = (undef, undef, undef); $ber->decode( [ $type => $tag ] => [ INTEGER => \$int, BOOLEAN => \$bool, STRING => \$str, ] ) or die; print "ok ",$test++,"\n"; die "Defined" unless defined($str) && defined($int) && defined($bool); print "ok ",$test++,"\n"; die "Equal" unless ($str eq "A string") && ($int==1) && ($bool==0); print "ok ",$test++,"\n"; } } } } ## ## IMPLICIT TAG, subclass ## package Test::BER; use Convert::BER qw(/BER_/ /^\$/ ber_tag); @ISA = qw(Convert::BER); Test::BER->define( # Name Type Tag ######################################## [ SUB_STRING => $STRING, ber_tag(BER_CONTEXT | BER_PRIMITIVE, 0x101) ], [ SUB_SEQ => $SEQUENCE, ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, 0x300) ], [ SUB_SEQ_OF => $SEQUENCE_OF, ber_tag(BER_APPLICATION | BER_CONSTRUCTOR, 0x36) ], ); package main; ## ## SUB_STRING ## my %STRING = ( "" => pack("C*", 0x9F, 0x82, 0x01, 0x00), "A string" => pack("CCCCa*", 0x9F, 0x82, 0x01, 0x08, "A string"), ); while(($val,$result) = each %STRING) { print "# SUB_STRING '$val'\n"; $tcount += 5; test { my $ber = Test::BER->new->encode( SUB_STRING => $val) or die; print "ok ",$test++,"\n"; die unless $ber->buffer eq $result; print "ok ",$test++,"\n"; my $str = undef; die unless $ber->decode( SUB_STRING => \$str); print "ok ",$test++,"\n"; die unless defined($str); print "ok ",$test++,"\n"; die unless ($str eq $val); print "ok ",$test++,"\n"; } } ## ## SUB_SEQ ## print "# SUB_SEQ\n"; $tcount += 6; test { my $ber = Test::BER->new->encode( SUB_SEQ => [ INTEGER => 1, BOOLEAN => 0, STRING => "A string" ] ) or die; my $data = $ber->buffer; print "ok ",$test++,"\n"; my $result = pack("C*", 0x7F, 0x86, 0x00, # tag 0x10, # length 0x02, 0x01, 0x01, # integer 0x01, 0x01, 0x00, # boolean 0x04, 0x08, 0x41, 0x20, 0x73, 0x74, 0x72, 0x69, 0x6E, 0x67 ); die unless $ber->buffer eq $result; print "ok ",$test++,"\n"; my $seq = undef; die unless $ber->decode(SUB_SEQ => \$seq) && $seq; print "ok ",$test++,"\n"; die unless substr($result,4) eq $seq->buffer; print "ok ",$test++,"\n"; $ber = new Test::BER($data) or die; print "ok ",$test++,"\n"; my($int,$bool,$str); $ber->decode( SUB_SEQ => [ INTEGER => \$int, BOOLEAN => \$bool, STRING => \$str, ] ) && ($int == 1) && !$bool && ($str eq "A string") or die; print "ok ",$test++,"\n"; }; ## ## SUB_SEQ_OF ## $tcount += 5; print "# SUB_SEQ_OF\n"; test { my $ber = Test::BER->new->encode( SUB_SEQ_OF => [ 4, INTEGER => 1 ]) or die; print "ok ",$test++,"\n"; $result = pack("C*", 0x7F, 0x36, # tag 0x0C, # length 0x02, 0x01, 0x01, 0x02, 0x01, 0x01, 0x02, 0x01, 0x01, 0x02, 0x01, 0x01); die unless $ber->buffer eq $result; print "ok ",$test++,"\n"; my $i; my $count; $ber->decode( SUB_SEQ_OF => [ \$count, INTEGER => \$i ] ) or die; print "ok ",$test++,"\n"; die unless $i == 1; print "ok ",$test++,"\n"; die unless $count == 4; print "ok ",$test++,"\n"; }; ## ## EXPLICIT TAG ## @ETAGS = ( ber_tag(BER_CONTEXT | BER_CONSTRUCTOR, 40), ber_tag(BER_CONTEXT | BER_CONSTRUCTOR, 140), ber_tag(BER_CONTEXT | BER_CONSTRUCTOR, 1140), ber_tag(BER_CONTEXT | BER_CONSTRUCTOR, 11140), ); foreach $tag (@ETAGS) { printf "# EXTENDED TAG 0x%x\n", $tag; $tcount += 3; test { my $ber = Convert::BER->new->encode( SEQUENCE => [ [ SEQUENCE => $tag ] => [ INTEGER => 10 ], INTEGER => 11, ] ) or die; print "ok ", $test++, "\n"; my ($i1, $i2) = (undef, undef); $ber->decode(SEQUENCE => [ [SEQUENCE => $tag] => [INTEGER => \$i1], INTEGER => \$i2 ]) or die; print "ok ", $test++, "\n"; die unless $i1 == 10 && $i2 == 11; print "ok ", $test++, "\n"; } } libconvert-ber-perl-1.3200/t/05class.t0000644000175000017500000000566511150563443016336 0ustar nachonacho#!/usr/local/bin/perl # # Test that sub-classing of Convert::BER works # use Convert::BER; package Test::BER; use Convert::BER qw(/BER_/ /^\$/); @ISA = qw(Convert::BER); Test::BER->define( # Name Type Tag ######################################## [ SUB_STRING => $STRING, undef ], [ SUB_SEQ => $SEQUENCE, BER_APPLICATION | BER_CONSTRUCTOR | 0x00 ], [ SUB_SEQ_OF => $SEQUENCE_OF, BER_APPLICATION | BER_CONSTRUCTOR | 0x06 ], ); package main; print "1..21\n"; $tcount = $test = 1; sub test (&) { my $sub = shift; eval { $sub->() }; print "not ok ",$test++," # skipped\n" while($test < $tcount); warn "count mismatch test=$test tcount=$tcount" unless $test == $tcount; $tcount = $test; } ## ## SUB_STRING ## my %STRING = ( "" => pack("C*", 0x04, 0x00), "A string" => pack("CCa*", 0x04, 0x08, "A string"), ); while(($val,$result) = each %STRING) { print "# STRING '$val'\n"; $tcount += 5; test { my $ber = Test::BER->new->encode( SUB_STRING => $val) or die; print "ok ",$test++,"\n"; die unless $ber->buffer eq $result; print "ok ",$test++,"\n"; my $str = undef; die unless $ber->decode( STRING => \$str); print "ok ",$test++,"\n"; die unless defined($str); print "ok ",$test++,"\n"; die unless ($str eq $val); print "ok ",$test++,"\n"; } } ## ## SUB_SEQ ## print "# SUB_SEQ\n"; $tcount += 6; test { my $ber = Test::BER->new->encode( SUB_SEQ => [ INTEGER => 1, BOOLEAN => 0, STRING => "A string" ] ) or die; my $data = $ber->buffer; print "ok ",$test++,"\n"; my $result = pack("C*", 0x60, 0x10, 0x02, 0x01, 0x01, 0x01, 0x01, 0x00, 0x04, 0x08, 0x41, 0x20, 0x73, 0x74, 0x72, 0x69, 0x6E, 0x67 ); die unless $ber->buffer eq $result; print "ok ",$test++,"\n"; my $seq = undef; die unless $ber->decode(SUB_SEQ => \$seq) && $seq; print "ok ",$test++,"\n"; die unless substr($result,2) eq $seq->buffer; print "ok ",$test++,"\n"; $ber = new Test::BER($data) or die; print "ok ",$test++,"\n"; my($int,$bool,$str); $ber->decode( SUB_SEQ => [ INTEGER => \$int, BOOLEAN => \$bool, STRING => \$str, ] ) && ($int == 1) && !$bool && ($str eq "A string") or die; print "ok ",$test++,"\n"; }; ## ## SUB_SEQ_OF ## $tcount += 5; print "# SUB_SEQ_OF\n"; test { $ber = Test::BER->new->encode( SUB_SEQ_OF => [ 4, INTEGER => 1 ]) or die; print "ok ",$test++,"\n"; $result = pack("C*", 0x66, 0x0C, 0x02, 0x01, 0x01, 0x02, 0x01, 0x01, 0x02, 0x01, 0x01, 0x02, 0x01, 0x01); die unless $ber->buffer eq $result; print "ok ",$test++,"\n"; my $i; my $count; $ber->decode( SUB_SEQ_OF => [ \$count, INTEGER => \$i ] ) or die; print "ok ",$test++,"\n"; die unless $i == 1; print "ok ",$test++,"\n"; die unless $count == 4; print "ok ",$test++,"\n"; }; libconvert-ber-perl-1.3200/t/01basic.t0000644000175000017500000000472711150563443016304 0ustar nachonacho#!/usr/local/bin/perl # # Test that the primitive operators are working # use Convert::BER; print "1..19\n"; $tcount = $test = 1; sub test (&) { my $sub = shift; eval { $sub->() }; print "not ok ",$test++,"\n" while($test < $tcount); warn "count mismatch test=$test tcount=$tcount" unless $test == $tcount; $tcount = $test; } ## ## Test array tags ## $tcount += 4; test { my $ber = Convert::BER->new->encode( [ NULL, 0x35 ] => 0 ) or die; print "ok ",$test++,"\n"; my $result = pack("C*", 0x35, 0x00); die unless $ber->buffer eq $result; print "ok ",$test++,"\n"; my $null; $ber->decode( [ NULL, 0x35 ] => \$null) or die; print "ok ",$test++,"\n"; die unless $null; print "ok ",$test++,"\n"; }; ## ## Test array ref value ## $tcount += 5; test { my $ber = Convert::BER->new->encode( STRING => [qw(two strings)] ); die unless $ber; print "ok ",$test++,"\n"; my $result = pack("C*", 0x04, 0x03, 0x74, 0x77, 0x6F, 0x04, 0x07, 0x73, 0x74, 0x72, 0x69, 0x6E, 0x67, 0x73); die unless $ber->buffer eq $result; print "ok ",$test++,"\n"; my @str = (); $ber->decode( STRING => \@str) or die; print "ok ",$test++,"\n"; die unless @str == 2; print "ok ",$test++,"\n"; die unless join("~",@str) eq "two~strings"; print "ok ",$test++,"\n"; }; ## ## Test sub returning value ## $tcount += 4; test { my $ber = Convert::BER->new->encode( INTEGER => sub { 0xABCDEF } ); die unless $ber; print "ok ",$test++,"\n"; my $result = pack("C*", 0x02, 0x04, 0x00, 0xAB, 0xCD, 0xEF); die unless $ber->buffer eq $result; print "ok ",$test++,"\n"; my $int; $ber->decode( INTEGER => \$int) or die; print "ok ",$test++,"\n"; die unless $int == 0xABCDEF; print "ok ",$test++,"\n"; }; ## ## Test sub returning array ref value ## $tcount += 6; test { my $ber = Convert::BER->new->encode( ENUM => sub { [ 0xFEDCBA, -96 ] } ); die unless $ber; print "ok ",$test++,"\n"; my $result = pack("C*", 0x0A, 0x04, 0x00, 0xFE, 0xDC, 0xBA, 0x0A, 0x01, 0xA0); die unless $ber->buffer eq $result; print "ok ",$test++,"\n"; my @int = (); $ber->decode( ENUM => \@int) or die; print "ok ",$test++,"\n"; die unless @int == 2; print "ok ",$test++,"\n"; die unless $int[0] == 0xFEDCBA; print "ok ",$test++,"\n"; die unless $int[1] == -96; print "ok ",$test++,"\n"; }; libconvert-ber-perl-1.3200/t/03seqof.t0000644000175000017500000001053611150563443016335 0ustar nachonacho#!/usr/local/bin/perl # # Test that the primitive operators are working # use Convert::BER; print "1..19\n"; $test = 1; $tcount = 0; ####################################################################### $tcount += 5; $ber = Convert::BER->new->encode( SEQUENCE_OF => [ 4, INTEGER => 1 ]); while($ber) { print "ok ",$test++,"\n"; $result = pack("C*", 0x30, 0x0C, 0x02, 0x01, 0x01, 0x02, 0x01, 0x01, 0x02, 0x01, 0x01, 0x02, 0x01, 0x01); last unless $ber->buffer eq $result; print "ok ",$test++,"\n"; my $i; my $count; $ber->decode( SEQUENCE_OF => [ \$count, INTEGER => \$i ] ) or last; print "ok ",$test++,"\n"; last unless $i == 1; print "ok ",$test++,"\n"; last unless $count == 4; print "ok ",$test++,"\n"; last; } print "not ok ",$test++,"\n" while($test <= $tcount); ####################################################################### $tcount += 7; my %hash = ( Fred => "A string for fred", Joe => [qw(has a list of strings)]); $ber = Convert::BER->new->encode( SEQUENCE_OF => [ \%hash, STRING => sub { $_[0] }, SEQUENCE => [ STRING => sub { $hash{ $_[0] } } ] ]); while($ber) { print "ok ",$test++,"\n"; $result = pack("C*", 0x30, 0x3D, 0x04, 0x04, 0x46, 0x72, 0x65, 0x64, 0x30, 0x13, 0x04, 0x11, 0x41, 0x20, 0x73, 0x74, 0x72, 0x69, 0x6E, 0x67, 0x20, 0x66, 0x6F, 0x72, 0x20, 0x66, 0x72, 0x65, 0x64, 0x04, 0x03, 0x4A, 0x6F, 0x65, 0x30, 0x1B, 0x04, 0x03, 0x68, 0x61, 0x73, 0x04, 0x01, 0x61, 0x04, 0x04, 0x6C, 0x69, 0x73, 0x74, 0x04, 0x02, 0x6F, 0x66, 0x04, 0x07, 0x73, 0x74, 0x72, 0x69, 0x6E, 0x67, 0x73); unless ($ber->buffer eq $result) { # This test is a bit naughty as it depends on the hash order of # perl. Unfortunatley this changed in 5.7 so we have a different result $result = pack("C*", 0x30, 0x3D, 0x04, 0x03, 0x4A, 0x6F, 0x65, 0x30, 0x1B, 0x04, 0x03, 0x68, 0x61, 0x73, 0x04, 0x01, 0x61, 0x04, 0x04, 0x6C, 0x69, 0x73, 0x74, 0x04, 0x02, 0x6F, 0x66, 0x04, 0x07, 0x73, 0x74, 0x72, 0x69, 0x6E, 0x67, 0x73, 0x04, 0x04, 0x46, 0x72, 0x65, 0x64, 0x30, 0x13, 0x04, 0x11, 0x41, 0x20, 0x73, 0x74, 0x72, 0x69, 0x6E, 0x67, 0x20, 0x66, 0x6F, 0x72, 0x20, 0x66, 0x72, 0x65, 0x64); } unless ($ber->buffer eq $result) { print "# Expecting\n"; Convert::BER->new($result)->hexdump(*STDOUT); print "# Got\n"; $ber->hexdump(*STDOUT); last; } print "ok ",$test++,"\n"; my @arr = (); my %h; $ber->decode( SEQUENCE_OF => [ \$count, STRING => sub { \$arr[$_[0]] } , SEQUENCE => [ STRING => sub { $h{$arr[$_[0]]} ||= [] } ] ] ) or last; print "ok ",$test++,"\n"; last unless @arr == 2; print "ok ",$test++,"\n"; last unless $count == 2; print "ok ",$test++,"\n"; last unless ref($h{Fred}) eq 'ARRAY' && @{$h{Fred}} == 1 && $h{Fred}->[0] eq "A string for fred"; print "ok ",$test++,"\n"; last unless ref($h{Joe}) eq 'ARRAY' && @{$h{Joe}} == 5 && join("~",@{$h{Joe}}) eq "has~a~list~of~strings"; print "ok ",$test++,"\n"; last; } print "not ok ",$test++,"\n" while($test <= $tcount); ####################################################################### $tcount += 7; my @array = ( [qw(A list)],[qw(of lists)]); $ber = Convert::BER->new->encode( SEQUENCE_OF => [ \@array, SEQUENCE => [ STRING => sub { $_[0] }, ] ]); while($ber) { print "ok ",$test++,"\n"; $result = pack("C*", 0x30, 0x18, 0x30, 0x09, 0x04, 0x01, 0x41, 0x04, 0x04, 0x6C, 0x69, 0x73, 0x74, 0x30, 0x0B, 0x04, 0x02, 0x6F, 0x66, 0x04, 0x05, 0x6C, 0x69, 0x73, 0x74, 0x73); last unless $ber->buffer eq $result; print "ok ",$test++,"\n"; my @arr = (); my %h; $ber->decode( SEQUENCE_OF => [ \$count, SEQUENCE => [ STRING => sub { $arr[$_[0]] ||= [] } ] ] ) or last; print "ok ",$test++,"\n"; last unless @arr == 2; print "ok ",$test++,"\n"; last unless $count == 2; print "ok ",$test++,"\n"; last unless ref($arr[0]) eq 'ARRAY' && @{$arr[0]} == 2 && join("~",@{$arr[0]}) eq "A~list"; print "ok ",$test++,"\n"; last unless ref($arr[1]) eq 'ARRAY' && @{$arr[1]} == 2 && join("~",@{$arr[1]}) eq "of~lists"; print "ok ",$test++,"\n"; last; } print "not ok ",$test++,"\n" while($test <= $tcount); libconvert-ber-perl-1.3200/t/08tag.t0000644000175000017500000000210311150563443015767 0ustar nachonacho#!/usr/local/bin/perl use Convert::BER qw(/BER/ ber_tag); print "1..22\n"; my $i = 1; sub test ($$) { unless ($_[0] == $_[1]) { printf "# expecting 0x%x, got 0x%x\nnot ",@_; } print "ok ",$i++,"\n"; } test 0x00, ber_tag(0,0); test 0x81, ber_tag(BER_CONTEXT,1); test 0x42, ber_tag(BER_APPLICATION,2); test 0x03, ber_tag(BER_UNIVERSAL,3); test 0xC4, ber_tag(BER_PRIVATE,4); test 0x05, ber_tag(BER_PRIMITIVE,5); test 0x26, ber_tag(BER_CONSTRUCTOR,6); test 0x261f, ber_tag(0,38); test 0x279f, ber_tag(BER_CONTEXT,39); test 0x285f, ber_tag(BER_APPLICATION,40); test 0x291f, ber_tag(BER_UNIVERSAL,41); test 0x2adf, ber_tag(BER_PRIVATE,42); test 0x2b1f, ber_tag(BER_PRIMITIVE,43); test 0x2c3f, ber_tag(BER_CONSTRUCTOR,44); test 0x38821f, ber_tag(0,0x138); test 0x39829f, ber_tag(BER_CONTEXT,0x139); test 0x40825f, ber_tag(BER_APPLICATION,0x140); test 0x41821f, ber_tag(BER_UNIVERSAL,0x141); test 0x4282df, ber_tag(BER_PRIVATE,0x142); test 0x43821f, ber_tag(BER_PRIMITIVE,0x143); test 0x44823f, ber_tag(BER_CONSTRUCTOR,0x144); test 0xa1, ber_tag(BER_CONTEXT | BER_CONSTRUCTOR,1); libconvert-ber-perl-1.3200/MANIFEST0000644000175000017500000000055211267733100015551 0ustar nachonachoBER.pm BER.pod ChangeLog Makefile.PL MANIFEST This list of files MANIFEST.SKIP README t/00prim.t t/01basic.t t/02seq.t t/03seqof.t t/04comp.t t/05class.t t/06opt.t t/07io.t t/08tag.t t/09hightags.t META.yml Module meta-data (added by MakeMaker) SIGNATURE Public-key signature (added by MakeMaker) libconvert-ber-perl-1.3200/ChangeLog0000644000175000017500000001203411267732623016201 0ustar nachonacho1.32 -- Wed Oct 21 20:29:30 CDT 2009 * remove label INIT, not valid as of 5.11.0 Change 739 on 2002/08/19 by (Graham Barr) Dont generate PPD Change 738 on 2002/08/19 by (Graham Barr) Dont depend on hash order in t/03seqof.t and try both possible results Change 613 on 2001/04/10 by (Graham Barr) Fix test for 5.7 (test result depends on hash order) Change 500 on 2000/04/30 by (Graham Barr) Release 1.31 Change 499 on 2000/04/30 by (Graham Barr) * Patch for tags >= 0x1f and new tests Change 493 on 2000/04/18 by (Graham Barr) Release 1.30 Change 492 on 2000/04/18 by (Graham Barr) added implementation for ber_tag() Change 463 on 2000/03/29 by (Graham Barr) Release 1.29 Change 462 on 2000/03/29 by (Graham Barr) added C for perl 5.6 and later Change 459 on 2000/03/29 by (Graham Barr) Makefile.PL - Corrected ABSTRACT Change 439 on 2000/03/29 by (Graham Barr) Release 1.28 Change 438 on 2000/03/29 by (Graham Barr) PPD stuff added to Makefile.PL Change 433 on 2000/03/29 by (Graham Barr) POD updates from Chris Ridd Change 421 on 2000/03/28 by (Graham Barr) OBJ_ID had an extra . Change 338 on 1999/09/25 by (Graham Barr) Applied patch from Gennis Emerson - doc updates - fixes to snd/recv Change 336 on 1999/09/24 by (Graham Barr) - Fix for unpacking into an array Change 295 on 1999/04/08 by (Graham Barr) Release 1.26 Change 279 on 1999/03/26 by (Graham Barr) Applied a readability patch from Gisle Aas Change 278 on 1999/03/26 by (Graham Barr) The start of support for indefinite length encoding. Change 277 on 1999/03/26 by (Graham Barr) Add bind() call to t/07io.t to prevent hangs on some systems Change 251 on 1999/02/09 by (Graham Barr) Added optional control argument to OPTIONAL Change 247 on 1999/02/05 by (Graham Barr) Added CHOICE Change 246 on 1999/02/04 by (Graham Barr) fixed read() to loop on sysread() until the correct number of bytes are read Change 241 on 1998/12/23 by (Graham Barr) - made error from ->read() more descrptive - added t/07io.t - added new types as sub-type of STRING ObjectDescriptor, UTF8String, NumericString, PrintableString TeletexString, T61String, VideotexString, IA5String, GraphicString, VisibleString, ISO646String, GeneralString, UTCTime, GeneralizedTime - added special time tags TimeUL TimeUZ TimeGL TimeGZ - added BIT_STRING8 a special BIT_STRING that can only deal with multiples of 8 the data is passed directlry, not as a string of '1's and '0's like BIT_STRING - added SET_OF as sub-type of SEQUENCE_OF - enhanced IO routines for better performance - protected eval{}'s against $SIG{__DIE__} Change 233 on 1998/11/09 by (Graham Barr) Now created constant subs in the sub-class package for the tag values and adds them to EXPORT_OK Change 227 on 1998/11/04 by (Graham Barr) - local($SIG{__DIE__}) when using eval/die Change 233 on 1998/11/09 by (Graham Barr) Now created constant subs in the sub-class package for the tag values and adds them to EXPORT_OK Change 227 on 1998/11/04 by (Graham Barr) - local($SIG{__DIE__}) when using eval/die *** Release 1.21 Change 205 on 1998/10/21 by (Graham Barr) dump and dumphex how accept a filehandle new dump sub with more readable output added support for BIT STRING Change 202 on 1998/10/16 by (Graham Barr) 30% speed improvement by remove use of method calls internally Change 193 on 1998/10/04 by (Graham Barr) Convert::BER - now works with 5.003 Change 192 on 1998/09/26 by (Graham Barr) - OPTIONAL can now optianlly encode, passing undef anywhere in the opList will cause the whole list not to be encoded - BER will no longer complain if passed undef as an argument, it will just do nothing. Change 174 on 1998/07/21 by (Graham Barr) Added CORE:: prefixes to keep 5.005-beta quiet Tue Jun 16 1998 (Graham Barr) t/00prim.t - tweak to ensure test runs on the Mac Mon Jun 8 1998 (Graham Barr) Added some tests to t/00prim.t Changed date in pod Sun Jun 7 1998 (Graham Barr) more speed improvements, approx 30% faster encode - changed to use an array instead of hash - new num_length - new pack_tag - inlines some internal method calls - speedup changes to num_length Sun Nov 30 1997 (Graham Barr) - unpack_tag was not checking that it unpacked what was expected Wed Nov 5 1997 (Graham Barr) Updated BER.pod libconvert-ber-perl-1.3200/README0000644000175000017500000000052511150563443015302 0ustar nachonachoConvert::BER is a perl object class implementation to encode and decode objects as described by ITU-T standard X.209 (ASN.1) using Basic Encoding Rules (BER) Copyright (c) 1995-7 Graham Barr . All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. libconvert-ber-perl-1.3200/SIGNATURE0000644000175000017500000000332111267733103015704 0ustar nachonachoThis file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.55. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 SHA1 a6b5c36c7e719a8e8fa446f68195ca3134bcd965 BER.pm SHA1 5415883258ce9ca18d847265e9f4f941a37a7acb BER.pod SHA1 a55af310a77459b3c73034a4559c9d4575456e9d ChangeLog SHA1 c9941dc0f24c1a61cc4b3aa92c58f9d1efc391c7 MANIFEST SHA1 f76e8b27a2cf3307ae223de679859f09d7f2d189 MANIFEST.SKIP SHA1 f78b92ed299dad299c7d10b8da54d15849c9bb16 META.yml SHA1 e2f7d555757ce9ee3a672463951a1baaa4cd01a5 Makefile.PL SHA1 50f1a0d1dde8c16b82fd1922dc3d23eaca04724f README SHA1 487d2d541a216983ac7ed818920e26803889dcdc t/00prim.t SHA1 d4654f9d2c85e46ef5a2cc0379973c9c6c630c80 t/01basic.t SHA1 c1f3601fd887f2e388ad1b5a93b4ab89b0861f58 t/02seq.t SHA1 2ad40a49e91ace6b848dfad087d186479baffbf5 t/03seqof.t SHA1 446fc271d32834b5dc1b32d638bbf1df9cee03ca t/04comp.t SHA1 3a9c1505bc048ee0cd30487706542c8ad6f49bce t/05class.t SHA1 e4d53a9ff78d660e906d2399be6d88bd2c18a0cc t/06opt.t SHA1 b6b7706efdc0da1a2ba08e883acc6e58889d37ee t/07io.t SHA1 f16b521b5e95ae5fe4ed2cc82faa4a3161b1b017 t/08tag.t SHA1 0de8d41a1e7c664076251ad6bc92e4e151a1245b t/09hightags.t -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.10 (Darwin) iEYEARECAAYFAkrftkAACgkQR0BL4gbYw3SjOwCdFX7m2J/iVJsWshKw/NQqF6Pj JCYAn2ZyOVG8ho/KtdXiNpi2GIQ0Lfn1 =Zmgi -----END PGP SIGNATURE-----