home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / ASN1.pm < prev    next >
Encoding:
Perl POD Document  |  2003-10-08  |  9.1 KB  |  434 lines
  1. # Copyright (c) 2000-2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
  2. # This program is free software; you can redistribute it and/or
  3. # modify it under the same terms as Perl itself.
  4.  
  5. package Convert::ASN1;
  6.  
  7. # $Id: ASN1.pm,v 1.29 2003/10/08 14:29:17 gbarr Exp $
  8.  
  9. use 5.004;
  10. use strict;
  11. use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS @opParts @opName $AUTOLOAD);
  12. use Exporter;
  13.  
  14. use constant CHECK_UTF8 => $] > 5.007;
  15.  
  16. BEGIN {
  17.  
  18.   if (CHECK_UTF8) {
  19.     require Encode;
  20.     require utf8;
  21.   }
  22.  
  23.   @ISA = qw(Exporter);
  24.   $VERSION = "0.18";
  25.  
  26.   %EXPORT_TAGS = (
  27.     io    => [qw(asn_recv asn_send asn_read asn_write asn_get asn_ready)],
  28.  
  29.     debug => [qw(asn_dump asn_hexdump)],
  30.  
  31.     const => [qw(ASN_BOOLEAN     ASN_INTEGER      ASN_BIT_STR      ASN_OCTET_STR
  32.          ASN_NULL        ASN_OBJECT_ID    ASN_REAL         ASN_ENUMERATED
  33.          ASN_SEQUENCE    ASN_SET          ASN_PRINT_STR    ASN_IA5_STR
  34.          ASN_UTC_TIME    ASN_GENERAL_TIME ASN_RELATIVE_OID
  35.          ASN_UNIVERSAL   ASN_APPLICATION  ASN_CONTEXT      ASN_PRIVATE
  36.          ASN_PRIMITIVE   ASN_CONSTRUCTOR  ASN_LONG_LEN     ASN_EXTENSION_ID ASN_BIT)],
  37.  
  38.     tag   => [qw(asn_tag asn_decode_tag2 asn_decode_tag asn_encode_tag asn_decode_length asn_encode_length)]
  39.   );
  40.  
  41.   @EXPORT_OK = map { @$_ } values %EXPORT_TAGS;
  42.   $EXPORT_TAGS{all} = \@EXPORT_OK;
  43.  
  44.   @opParts = qw(
  45.     cTAG cTYPE cVAR cLOOP cOPT cCHILD cDEFINE
  46.   );
  47.  
  48.   @opName = qw(
  49.     opUNKNOWN opBOOLEAN opINTEGER opBITSTR opSTRING opNULL opOBJID opREAL
  50.     opSEQUENCE opSET opUTIME opGTIME opUTF8 opANY opCHOICE opROID
  51.   );
  52.  
  53.   foreach my $l (\@opParts, \@opName) {
  54.     my $i = 0;
  55.     foreach my $name (@$l) {
  56.       my $j = $i++;
  57.       no strict 'refs';
  58.       *{__PACKAGE__ . '::' . $name} = sub () { $j }
  59.     }
  60.   }
  61. }
  62.  
  63. sub _internal_syms {
  64.   my $pkg = caller;
  65.   no strict 'refs';
  66.   for my $sub (@opParts,@opName,'dump_op') {
  67.     *{$pkg . '::' . $sub} = \&{__PACKAGE__ . '::' . $sub};
  68.   }
  69. }
  70.  
  71. sub ASN_BOOLEAN     () { 0x01 }
  72. sub ASN_INTEGER     () { 0x02 }
  73. sub ASN_BIT_STR     () { 0x03 }
  74. sub ASN_OCTET_STR     () { 0x04 }
  75. sub ASN_NULL         () { 0x05 }
  76. sub ASN_OBJECT_ID     () { 0x06 }
  77. sub ASN_REAL         () { 0x09 }
  78. sub ASN_ENUMERATED    () { 0x0A }
  79. sub ASN_RELATIVE_OID    () { 0x0D }
  80. sub ASN_SEQUENCE     () { 0x10 }
  81. sub ASN_SET         () { 0x11 }
  82. sub ASN_PRINT_STR    () { 0x13 }
  83. sub ASN_IA5_STR        () { 0x16 }
  84. sub ASN_UTC_TIME    () { 0x17 }
  85. sub ASN_GENERAL_TIME    () { 0x18 }
  86.  
  87. sub ASN_UNIVERSAL     () { 0x00 }
  88. sub ASN_APPLICATION     () { 0x40 }
  89. sub ASN_CONTEXT     () { 0x80 }
  90. sub ASN_PRIVATE        () { 0xC0 }
  91.  
  92. sub ASN_PRIMITIVE    () { 0x00 }
  93. sub ASN_CONSTRUCTOR    () { 0x20 }
  94.  
  95. sub ASN_LONG_LEN    () { 0x80 }
  96. sub ASN_EXTENSION_ID    () { 0x1F }
  97. sub ASN_BIT         () { 0x80 }
  98.  
  99.  
  100. sub new {
  101.   my $pkg = shift;
  102.   my $self = bless {}, $pkg;
  103.  
  104.   $self->configure(@_);
  105.   $self;
  106. }
  107.  
  108.  
  109. sub configure {
  110.   my $self = shift;
  111.   my %opt = @_;
  112.  
  113.   $self->{options}{encoding} = uc($opt{encoding} || 'BER');
  114.  
  115.   unless ($self->{options}{encoding} =~ /^[BD]ER$/) {
  116.     require Carp;
  117.     Carp::croak("Unsupported encoding format '$opt{encoding}'");
  118.   }
  119.  
  120.   for my $type (qw(encode decode)) {
  121.     if (exists $opt{$type}) {
  122.       while(my($what,$value) = each %{$opt{$type}}) {
  123.     $self->{options}{"${type}_${what}"} = $value;
  124.       }
  125.     }
  126.   }
  127. }
  128.  
  129.  
  130.  
  131. sub find {
  132.   my $self = shift;
  133.   my $what = shift;
  134.   return unless exists $self->{tree}{$what};
  135.   my %new = %$self;
  136.   $new{script} = $new{tree}->{$what};
  137.   bless \%new, ref($self);
  138. }
  139.  
  140.  
  141. sub prepare {
  142.   my $self = shift;
  143.   my $asn  = shift;
  144.  
  145.   $self = $self->new unless ref($self);
  146.   my $tree;
  147.   if( ref($asn) eq 'GLOB' ){
  148.     local $/ = undef;
  149.     my $txt = <$asn>;
  150.     $tree = Convert::ASN1::parser::parse($txt);
  151.   } else {
  152.     $tree = Convert::ASN1::parser::parse($asn);
  153.   }
  154.  
  155.   unless ($tree) {
  156.     $self->{error} = $@;
  157.     return;
  158.     ### If $self has been set to a new object, not returning
  159.     ### this object here will destroy the object, so the caller
  160.     ### won't be able to get at the error.
  161.   }
  162.  
  163.   $self->{tree} = _pack_struct($tree);
  164.   $self->{script} = (values %$tree)[0];
  165.   $self;
  166. }
  167.  
  168. sub prepare_file {
  169.   my $self = shift;
  170.   my $asnp = shift;
  171.  
  172.   local *ASN;
  173.   open( ASN, $asnp )
  174.       or do{ $self->{error} = $@; return; };
  175.   my $ret = $self->prepare( \*ASN );
  176.   close( ASN );
  177.   $ret;
  178. }
  179.  
  180. sub registeroid {
  181.   my $self = shift;
  182.   my $oid  = shift;
  183.   my $handler = shift;
  184.  
  185.   $self->{options}{oidtable}{$oid}=$handler;
  186.   $self->{oidtable}{$oid}=$handler;
  187. }
  188.  
  189. # In XS the will convert the tree between perl and C structs
  190.  
  191. sub _pack_struct { $_[0] }
  192. sub _unpack_struct { $_[0] }
  193.  
  194. ##
  195. ## Encoding
  196. ##
  197.  
  198. sub encode {
  199.   my $self  = shift;
  200.   my $stash = @_ == 1 ? shift : { @_ };
  201.   my $buf = '';
  202.   local $SIG{__DIE__};
  203.   eval { _encode($self->{options}, $self->{script}, $stash, [], $buf) }
  204.     or do { $self->{error} = $@; undef }
  205. }
  206.  
  207.  
  208.  
  209. # Encode tag value for encoding.
  210. # We assume that the tag has been correclty generated with asn_tag()
  211.  
  212. sub asn_encode_tag {
  213.   $_[0] >> 8
  214.     ? $_[0] & 0x8000
  215.       ? $_[0] & 0x800000
  216.     ? pack("V",$_[0])
  217.     : substr(pack("V",$_[0]),0,3)
  218.       : pack("v", $_[0])
  219.     : chr($_[0]);
  220. }
  221.  
  222.  
  223. # Encode a length. If < 0x80 then encode as a byte. Otherwise encode
  224. # 0x80 | num_bytes followed by the bytes for the number. top end
  225. # bytes of all zeros are not encoded
  226.  
  227. sub asn_encode_length {
  228.  
  229.   if($_[0] >> 7) {
  230.     my $lenlen = &num_length;
  231.  
  232.     return pack("Ca*", $lenlen | 0x80,  substr(pack("N",$_[0]), -$lenlen));
  233.   }
  234.  
  235.   return pack("C", $_[0]);
  236. }
  237.  
  238.  
  239. ##
  240. ## Decoding
  241. ##
  242.  
  243. sub decode {
  244.   my $self  = shift;
  245.  
  246.   local $SIG{__DIE__};
  247.   my $ret = eval { 
  248.     my (%stash, $result);
  249.     my $script = $self->{script};
  250.     my $stash = (1 == @$script && !$self->{script}[0][cVAR]) ? \$result : ($result=\%stash);
  251.  
  252.     _decode(
  253.     $self->{options},
  254.     $script,
  255.     $stash,
  256.     0,
  257.     length $_[0], 
  258.     undef,
  259.     [],
  260.     $_[0]);
  261.  
  262.     $result;
  263.   };
  264.   if ($@) {
  265.     $self->{'error'} = $@;
  266.     return undef;
  267.   }
  268.   $ret;
  269. }
  270.  
  271.  
  272. sub asn_decode_length {
  273.   return unless length $_[0];
  274.  
  275.   my $len = ord substr($_[0],0,1);
  276.  
  277.   if($len & 0x80) {
  278.     $len &= 0x7f or return (1,-1);
  279.  
  280.     return if $len >= length $_[0];
  281.  
  282.     return (1+$len, unpack("N", "\0" x (4 - $len) . substr($_[0],1,$len)));
  283.   }
  284.   return (1, $len);
  285. }
  286.  
  287.  
  288. sub asn_decode_tag {
  289.   return unless length $_[0];
  290.  
  291.   my $tag = ord $_[0];
  292.   my $n = 1;
  293.  
  294.   if(($tag & 0x1f) == 0x1f) {
  295.     my $b;
  296.     do {
  297.       return if $n >= length $_[0];
  298.       $b = ord substr($_[0],$n,1);
  299.       $tag |= $b << (8 * $n++);
  300.     } while($b & 0x80);
  301.   }
  302.   ($n, $tag);
  303. }
  304.  
  305.  
  306. sub asn_decode_tag2 {
  307.   return unless length $_[0];
  308.  
  309.   my $tag = ord $_[0];
  310.   my $num = $tag & 0x1f;
  311.   my $len = 1;
  312.  
  313.   if($num == 0x1f) {
  314.     $num = 0;
  315.     my $b;
  316.     do {
  317.       return if $len >= length $_[0];
  318.       $b = ord substr($_[0],$len++,1);
  319.       $num = ($num << 7) + ($b & 0x7f);
  320.     } while($b & 0x80);
  321.   }
  322.   ($len, $tag, $num);
  323. }
  324.  
  325.  
  326. ##
  327. ## Utilities
  328. ##
  329.  
  330. # How many bytes are needed to encode a number 
  331.  
  332. sub num_length {
  333.   $_[0] >> 8
  334.     ? $_[0] >> 16
  335.       ? $_[0] >> 24
  336.     ? 4
  337.     : 3
  338.       : 2
  339.     : 1
  340. }
  341.  
  342. # Convert from a bigint to an octet string
  343.  
  344. sub i2osp {
  345.     my($num, $biclass) = @_;
  346.     eval "use $biclass";
  347.     $num = $biclass->new($num);
  348.     my $neg = $num < 0
  349.       and $num = abs($num+1);
  350.     my $base = $biclass->new(256);
  351.     my $result = '';
  352.     while($num != 0) {
  353.         my $r = $num % $base;
  354.         $num = ($num-$r) / $base;
  355.         $result .= chr($r);
  356.     }
  357.     $result ^= chr(255) x length($result) if $neg;
  358.     return scalar reverse $result;
  359. }
  360.  
  361. # Convert from an octet string to a bigint
  362.  
  363. sub os2ip {
  364.     my($os, $biclass) = @_;
  365.     eval "require $biclass";
  366.     my $base = $biclass->new(256);
  367.     my $result = $biclass->new(0);
  368.     my $neg = ord($os) >= 0x80
  369.       and $os ^= chr(255) x length($os);
  370.     for (unpack("C*",$os)) {
  371.       $result = ($result * $base) + $_;
  372.     }
  373.     return $neg ? ($result + 1) * -1 : $result;
  374. }
  375.  
  376. # Given a class and a tag, calculate an integer which when encoded
  377. # will become the tag. This means that the class bits are always
  378. # in the bottom byte, so are the tag bits if tag < 30. Otherwise
  379. # the tag is in the upper 3 bytes. The upper bytes are encoded
  380. # with bit8 representing that there is another byte. This
  381. # means the max tag we can do is 0x1fffff
  382.  
  383. sub asn_tag {
  384.   my($class,$value) = @_;
  385.  
  386.   die sprintf "Bad tag class 0x%x",$class
  387.     if $class & ~0xe0;
  388.  
  389.   unless ($value & ~0x1f or $value == 0x1f) {
  390.     return (($class & 0xe0) | $value);
  391.   }
  392.  
  393.   die sprintf "Tag value 0x%08x too big\n",$value
  394.     if $value & 0xffe00000;
  395.  
  396.   $class = ($class | 0x1f) & 0xff;
  397.  
  398.   my @t = ($value & 0x7f);
  399.   unshift @t, (0x80 | ($value & 0x7f)) while $value >>= 7;
  400.   unpack("V",pack("C4",$class,@t,0,0));
  401. }
  402.  
  403.  
  404. BEGIN {
  405.   # When we have XS &_encode will be defined by the XS code
  406.   # so will all the subs in these required packages 
  407.   unless (defined &_encode) {
  408.     require Convert::ASN1::_decode;
  409.     require Convert::ASN1::_encode;
  410.     require Convert::ASN1::IO;
  411.   }
  412.  
  413.   require Convert::ASN1::parser;
  414. }
  415.  
  416. sub AUTOLOAD {
  417.   require Convert::ASN1::Debug if $AUTOLOAD =~ /dump/;
  418.   goto &{$AUTOLOAD} if defined &{$AUTOLOAD};
  419.   require Carp;
  420.   my $pkg = ref($_[0]) || ($_[0] =~ /^[\w\d]+(?:::[\w\d]+)*$/)[0];
  421.   if ($pkg and UNIVERSAL::isa($pkg, __PACKAGE__)) { # guess it was a method call
  422.     $AUTOLOAD =~ s/.*:://;
  423.     Carp::croak(sprintf q{Can't locate object method "%s" via package "%s"},$AUTOLOAD,$pkg);
  424.   }
  425.   else {
  426.     Carp::croak(sprintf q{Undefined subroutine &%s called}, $AUTOLOAD);
  427.   }
  428. }
  429.  
  430. sub DESTROY {}
  431.  
  432. sub error { $_[0]->{error} }
  433. 1;
  434.