[ Index ]

PHP Cross Reference of Unnamed Project

title

Body

[close]

/se3-unattended/var/se3/unattended/install/linuxaux/opt/perl/lib/site_perl/5.10.0/Convert/ -> ASN1.pm (source)

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


Generated: Tue Mar 17 22:47:18 2015 Cross-referenced by PHPXref 0.7.1