File Coverage

blib/lib/Convert/ASN1/_decode.pm

Criterion	Covered	Total	%
statement	229	281	81.4
branch	155	234	66.2
condition	48	98	48.9
subroutine	21	22	95.4
pod			n/a
total	453	635	71.3

# Copyright (c) 2000-2005 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::ASN1;
$Convert::ASN1::VERSION = '0.32'; # TRIAL
use strict;
use warnings;

BEGIN {
  local $SIG{__DIE__};
  eval { require bytes and 'bytes'->import };
}

# These are the subs that do the decode, they are called with
# 0      1    2       3     4
# $optn, $op, $stash, $var, $buf
# The order must be the same as the op definitions above

my @decode = (
  sub { die "internal error\n" },
  \&_dec_boolean,
  \&_dec_integer,
  \&_dec_bitstring,
  \&_dec_string,
  \&_dec_null,
  \&_dec_object_id,
  \&_dec_real,
  \&_dec_sequence,
  \&_dec_explicit,
  \&_dec_set,
  \&_dec_time,
  \&_dec_time,
  \&_dec_utf8,
  undef, # ANY
  undef, # CHOICE
  \&_dec_object_id,
  \&_dec_bcd,
);

my @ctr;
@ctr[opBITSTR, opSTRING, opUTF8] = (\&_ctr_bitstring,\&_ctr_string,\&_ctr_string);


sub _decode {
  my ($optn, $ops, $stash, $pos, $end, $seqof, $larr) = @_;
  my $idx = 0;

  # we try not to copy the input buffer at any time
  foreach my $buf ($_[-1]) {
    OP:
    foreach my $op (@{$ops}) {
      my $var = $op->[cVAR];

      if (length $op->[cTAG]) {

	TAGLOOP: {
	  my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr)
	    or do {
	      next OP if $pos==$end and ($seqof || defined $op->[cEXT]);
	      die "decode error";
	    };

	  if ($tag eq $op->[cTAG]) {

	    &{$decode[$op->[cTYPE]]}(
	      $optn,
	      $op,
	      $stash,
	      # We send 1 if there is not var as if there is the decode
	      # should be getting undef. So if it does not get undef
	      # it knows it has no variable
	      ($seqof ? $seqof->[$idx++] : defined($var) ? $stash->{$var} : ref($stash) eq 'SCALAR' ? $$stash : 1),
	      $buf,$npos,$len, $larr
	    );

	    $pos = $npos+$len+$indef;

	    redo TAGLOOP if $seqof && $pos < $end;
	    next OP;
	  }

	  if ($tag eq ($op->[cTAG] | pack("C",ASN_CONSTRUCTOR))
	      and my $ctr = $ctr[$op->[cTYPE]])
	  {
	    _decode(
	      $optn,
	      [$op],
	      undef,
	      $npos,
	      $npos+$len,
	      (\my @ctrlist),
	      $larr,
	      $buf,
	    );

        ($seqof
            ? $seqof->[$idx++] # = &{$ctr}(@ctrlist);
                : defined($var)
                    ? $stash->{$var} # = &{$ctr}(@ctrlist);
                        : ref($stash) eq 'SCALAR'
                            ? $$stash # = &{$ctr}(@ctrlist);
                                : my $any ) # = &{$ctr}(@ctrlist) FIX #43
        = &{$ctr}(@ctrlist);

	    $pos = $npos+$len+$indef;

	    redo TAGLOOP if $seqof && $pos < $end;
	    next OP;

	  }

	  if ($seqof || defined $op->[cEXT]) {
	    next OP;
	  }

	  die "decode error " . unpack("H*",$tag) ."<=>" . unpack("H*",$op->[cTAG]), " ",$pos," ",$op->[cTYPE]," ",$op->[cVAR]||'';
        }
      }
      else { # opTag length is zero, so it must be an ANY, CHOICE or EXTENSIONS

	if ($op->[cTYPE] == opANY) {

	  ANYLOOP: {

	    my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr)
	      or do {
		next OP if $pos==$end and ($seqof || defined $op->[cEXT]);
		die "decode error";
	      };

	    $len += $npos - $pos + $indef;

            my $handler;
            if ($op->[cDEFINE]) {
              $handler = $optn->{oidtable} && $optn->{oidtable}{$stash->{$op->[cDEFINE]}};
              $handler ||= $optn->{handlers}{$op->[cVAR]}{$stash->{$op->[cDEFINE]}};
            }

	    ($seqof ? $seqof->[$idx++] : ref($stash) eq 'SCALAR' ? $$stash : $stash->{$var})
	      = $handler ? $handler->decode(substr($buf,$pos,$len)) : substr($buf,$pos,$len);

	    $pos += $len;

	    redo ANYLOOP if $seqof && $pos < $end;
	  }
	}
	elsif ($op->[cTYPE] == opCHOICE) {

	  CHOICELOOP: {
	    my($tag,$len,$npos,$indef) = _decode_tl($buf,$pos,$end,$larr)
	      or do {
		next OP if $pos==$end and ($seqof || defined $op->[cEXT]);
		die "decode error";
	      };
	    my $extensions;
	    foreach my $cop (@{$op->[cCHILD]}) {

	      if ($tag eq $cop->[cTAG]) {

		my $nstash = $seqof
			? ($seqof->[$idx++]={})
			: defined($var)
				? ($stash->{$var}={})
				: ref($stash) eq 'SCALAR'
					? ($$stash={}) : $stash;

		&{$decode[$cop->[cTYPE]]}(
		  $optn,
		  $cop,
		  $nstash,
		  ($cop->[cVAR] ? $nstash->{$cop->[cVAR]} : undef),
		  $buf,$npos,$len,$larr,
		);

		$pos = $npos+$len+$indef;

		redo CHOICELOOP if $seqof && $pos < $end;
		next OP;
	      }

	      if ($cop->[cTYPE] == opEXTENSIONS) {
		$extensions = 1;
		next;
	      }

	      unless (length $cop->[cTAG]) {
		eval {
		  _decode(
		    $optn,
		    [$cop],
		    (\my %tmp_stash),
		    $pos,
		    $npos+$len+$indef,
		    undef,
		    $larr,
		    $buf,
		  );

		  my $nstash = $seqof
			  ? ($seqof->[$idx++]={})
			  : defined($var)
				  ? ($stash->{$var}={})
				  : ref($stash) eq 'SCALAR'
					  ? ($$stash={}) : $stash;

		  @{$nstash}{keys %tmp_stash} = values %tmp_stash;

		} or next;

		$pos = $npos+$len+$indef;

		redo CHOICELOOP if $seqof && $pos < $end;
		next OP;
	      }

	      if ($tag eq ($cop->[cTAG] | pack("C",ASN_CONSTRUCTOR))
		  and my $ctr = $ctr[$cop->[cTYPE]])
	      {
		my $nstash = $seqof
			? ($seqof->[$idx++]={})
			: defined($var)
				? ($stash->{$var}={})
				: ref($stash) eq 'SCALAR'
					? ($$stash={}) : $stash;

		_decode(
		  $optn,
		  [$cop],
		  undef,
		  $npos,
		  $npos+$len,
		  (\my @ctrlist),
		  $larr,
		  $buf,
		);

		$nstash->{$cop->[cVAR]} = &{$ctr}(@ctrlist);
		$pos = $npos+$len+$indef;

		redo CHOICELOOP if $seqof && $pos < $end;
		next OP;
	      }
	    }

	    if ($pos < $end && $extensions) {
	      $pos = $npos+$len+$indef;

	      redo CHOICELOOP if $seqof && $pos < $end;
	      next OP;
	    }
	  }
	  die "decode error" unless $op->[cEXT];
	}
	elsif ($op->[cTYPE] == opEXTENSIONS) {
	    $pos = $end; # Skip over the rest
        }
	else {
	  die "this point should never be reached";
	}
      }
    }
  }
  die "decode error $pos $end" unless $pos == $end;
}


sub _dec_boolean {
# 0      1    2       3     4     5     6
# $optn, $op, $stash, $var, $buf, $pos, $len

  $_[3] = unpack("C",substr($_[4],$_[5],1)) ? 1 : 0;
  1;
}


sub _dec_integer {
# 0      1    2       3     4     5     6
# $optn, $op, $stash, $var, $buf, $pos, $len

  my $buf = substr($_[4],$_[5],$_[6]);
  my $tmp = unpack("C",$buf) & 0x80 ? pack("C",255) : pack("C",0);
  if ($_[6] > 4) {
      $_[3] = os2ip($buf, $_[0]->{decode_bigint} || 'Math::BigInt');
  } else {
      # N unpacks an unsigned value
      $_[3] = unpack("l",pack("l",unpack("N", $tmp x (4-$_[6]) . $buf)));
  }
  1;
}


sub _dec_bitstring {
# 0      1    2       3     4     5     6
# $optn, $op, $stash, $var, $buf, $pos, $len

  $_[3] = [ substr($_[4],$_[5]+1,$_[6]-1), ($_[6]-1)*8-unpack("C",substr($_[4],$_[5],1)) ];
  1;
}


sub _dec_string {
# 0      1    2       3     4     5     6
# $optn, $op, $stash, $var, $buf, $pos, $len

  $_[3] = substr($_[4],$_[5],$_[6]);
  1;
}


sub _dec_null {
# 0      1    2       3     4     5     6
# $optn, $op, $stash, $var, $buf, $pos, $len

  $_[3] = exists($_[0]->{decode_null}) ? $_[0]->{decode_null} : 1;
  1;
}


sub _dec_object_id {
# 0      1    2       3     4     5     6
# $optn, $op, $stash, $var, $buf, $pos, $len

  my @data = unpack("w*",substr($_[4],$_[5],$_[6]));
  if ($_[1]->[cTYPE] == opOBJID and @data > 1) {
    if ($data[0] < 40) {
      splice(@data, 0, 1, 0, $data[0]);
    }
    elsif ($data[0] < 80) {
      splice(@data, 0, 1, 1, $data[0] - 40);
    }
    else {
      splice(@data, 0, 1, 2, $data[0] - 80);
    }
  }
  $_[3] = join(".", @data);
  1;
}


my @_dec_real_base = (2,8,16);

sub _dec_real {
# 0      1    2       3     4     5     6
# $optn, $op, $stash, $var, $buf, $pos, $len

  $_[3] = 0.0, return unless $_[6];

  my $first = unpack("C",substr($_[4],$_[5],1));
  if ($first & 0x80) {
    # A real number

    require POSIX;

    my $exp;
    my $expLen = $first & 0x3;
    my $estart = $_[5]+1;

    if($expLen == 3) {
      $estart++;
      $expLen = unpack("C",substr($_[4],$_[5]+1,1));
    }
    else {
      $expLen++;
    }
    _dec_integer(undef, undef, undef, $exp, $_[4],$estart,$expLen);

    my $mant = 0.0;
    for (reverse unpack("C*",substr($_[4],$estart+$expLen,$_[6]-1-$expLen))) {
      $exp +=8, $mant = (($mant+$_) / 256) ;
    }

    $mant *= 1 << (($first >> 2) & 0x3);
    $mant = - $mant if $first & 0x40;

    $_[3] = $mant * POSIX::pow($_dec_real_base[($first >> 4) & 0x3], $exp);
    return;
  }
  elsif($first & 0x40) {
    $_[3] =   POSIX::HUGE_VAL(),return if $first == 0x40;
    $_[3] = - POSIX::HUGE_VAL(),return if $first == 0x41;
  }
  elsif(substr($_[4],$_[5],$_[6]) =~ /^.([-+]?)0*(\d+(?:\.\d+(?:[Ee][-+]?\d+)?)?)$/s) {
    $_[3] = eval "$1$2";
    return;
  }

  die "REAL decode error\n";
}


sub _dec_explicit {
# 0      1    2       3     4     5     6     7
# $optn, $op, $stash, $var, $buf, $pos, $len, $larr

  local $_[1][cCHILD][0][cVAR] = $_[1][cVAR] unless $_[1][cCHILD][0][cVAR];

  _decode(
    $_[0], #optn
    $_[1]->[cCHILD],   #ops
    $_[2], #stash
    $_[5], #pos
    $_[5]+$_[6], #end
    undef, #loop
    $_[7],
    $_[4], #buf
  );
  1;
}
sub _dec_sequence {
# 0      1    2       3     4     5     6     7
# $optn, $op, $stash, $var, $buf, $pos, $len, $larr

  if (defined( my $ch = $_[1]->[cCHILD])) {
    _decode(
      $_[0], #optn
      $ch,   #ops
      (defined($_[3]) || $_[1]->[cLOOP]) ? $_[2] : ($_[3]= {}), #stash
      $_[5], #pos
      $_[5]+$_[6], #end
      $_[1]->[cLOOP] && ($_[3]=[]), #loop
      $_[7],
      $_[4], #buf
    );
  }
  else {
    $_[3] = substr($_[4],$_[5],$_[6]);
  }
  1;
}


sub _dec_set {
# 0      1    2       3     4     5     6     7
# $optn, $op, $stash, $var, $buf, $pos, $len, $larr

  # decode SET OF the same as SEQUENCE OF
  my $ch = $_[1]->[cCHILD];
  goto &_dec_sequence if $_[1]->[cLOOP] or !defined($ch);

  my ($optn, $pos, $larr) = @_[0,5,7];
  my $stash = defined($_[3]) ? $_[2] : ($_[3]={});
  my $end = $pos + $_[6];
  my @done;
  my $extensions;

  while ($pos < $end) {
    my($tag,$len,$npos,$indef) = _decode_tl($_[4],$pos,$end,$larr)
      or die "decode error";

    my ($idx, $any, $done) = (-1);

SET_OP:
    foreach my $op (@$ch) {
      $idx++;
      if (length($op->[cTAG])) {
	if ($tag eq $op->[cTAG]) {
	  my $var = $op->[cVAR];
	  &{$decode[$op->[cTYPE]]}(
	    $optn,
	    $op,
	    $stash,
	    # We send 1 if there is not var as if there is the decode
	    # should be getting undef. So if it does not get undef
	    # it knows it has no variable
	    (defined($var) ? $stash->{$var} : 1),
	    $_[4],$npos,$len,$larr,
	  );
	  $done = $idx;
	  last SET_OP;
	}
	if ($tag eq ($op->[cTAG] | pack("C",ASN_CONSTRUCTOR))
	    and my $ctr = $ctr[$op->[cTYPE]])
	{
	  _decode(
	    $optn,
	    [$op],
	    undef,
	    $npos,
	    $npos+$len,
	    (\my @ctrlist),
	    $larr,
	    $_[4],
	  );

	  $stash->{$op->[cVAR]} = &{$ctr}(@ctrlist)
	    if defined $op->[cVAR];
	  $done = $idx;
	  last SET_OP;
	}
	next SET_OP;
      }
      elsif ($op->[cTYPE] == opANY) {
	$any = $idx;
      }
      elsif ($op->[cTYPE] == opCHOICE) {
	my $var = $op->[cVAR];
	foreach my $cop (@{$op->[cCHILD]}) {
	  if ($tag eq $cop->[cTAG]) {
	    my $nstash = defined($var) ? ($stash->{$var}={}) : $stash;

	    &{$decode[$cop->[cTYPE]]}(
	      $optn,
	      $cop,
	      $nstash,
	      $nstash->{$cop->[cVAR]},
	      $_[4],$npos,$len,$larr,
	    );
	    $done = $idx;
	    last SET_OP;
	  }
	  if ($tag eq ($cop->[cTAG] | pack("C",ASN_CONSTRUCTOR))
	      and my $ctr = $ctr[$cop->[cTYPE]])
	  {
	    my $nstash = defined($var) ? ($stash->{$var}={}) : $stash;

	    _decode(
	      $optn,
	      [$cop],
	      undef,
	      $npos,
	      $npos+$len,
	      (\my @ctrlist),
	      $larr,
	      $_[4],
	    );

	    $nstash->{$cop->[cVAR]} = &{$ctr}(@ctrlist);
	    $done = $idx;
	    last SET_OP;
	  }
	}
      }
      elsif ($op->[cTYPE] == opEXTENSIONS) {
	  $extensions = $idx;
      }
      else {
	die "internal error";
      }
    }

    if (!defined($done) and defined($any)) {
      my $var = $ch->[$any][cVAR];
      $stash->{$var} = substr($_[4],$pos,$len+$npos-$pos) if defined $var;
      $done = $any;
    }

    if( !defined($done) && defined($extensions) ) {
      $done = $extensions;
    }

    die "decode error" if !defined($done) or $done[$done]++;

    $pos = $npos + $len + $indef;
  }

  die "decode error" unless $end == $pos;

  foreach my $idx (0..$#{$ch}) {
    die "decode error" unless $done[$idx] or $ch->[$idx][cEXT] or $ch->[$idx][cTYPE] == opEXTENSIONS;
  }

  1;
}


my %_dec_time_opt = ( unixtime => 0, withzone => 1, raw => 2);

sub _dec_time {
# 0      1    2       3     4     5     6
# $optn, $op, $stash, $var, $buf, $pos, $len

  my $mode = $_dec_time_opt{$_[0]->{'decode_time'} || ''} || 0;

  if ($mode == 2 or $_[6] == 0) {
    $_[3] = substr($_[4],$_[5],$_[6]);
    return;
  }

  my @bits = (substr($_[4],$_[5],$_[6])
     =~ /^((?:\d\d)?\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)((?:\.\d{1,3})?)(([-+])(\d\d)(\d\d)|Z)/)
     or die "bad time format";

  if ($bits[0] < 100) {
    $bits[0] += 100 if $bits[0] < 50;
  }
  else {
    $bits[0] -= 1900;
  }
  $bits[1] -= 1;
  require Time::Local;
  my $time = Time::Local::timegm(@bits[5,4,3,2,1,0]);
  $time += $bits[6] if length $bits[6];
  my $offset = 0;
  if ($bits[7] ne 'Z') {
    $offset = $bits[9] * 3600 + $bits[10] * 60;
    $offset = -$offset if $bits[8] eq '-';
    $time -= $offset;
  }
  $_[3] = $mode ? [$time,$offset] : $time;
}


sub _dec_utf8 {
# 0      1    2       3     4     5     6
# $optn, $op, $stash, $var, $buf, $pos, $len

  BEGIN {
    unless (CHECK_UTF8) {
      local $SIG{__DIE__};
      eval { require bytes } and 'bytes'->unimport;
      eval { require utf8  } and 'utf8'->import;
    }
  }

  if (CHECK_UTF8) {
    $_[3] = Encode::decode('utf8', substr($_[4],$_[5],$_[6]));
  }
  else {
    $_[3] = (substr($_[4],$_[5],$_[6]) =~ /(.*)/s)[0];
  }

  1;
}


sub _decode_tl {
  my($pos,$end,$larr) = @_[1,2,3];

  return if $pos >= $end;

  my $indef = 0;

  my $tag = substr($_[0], $pos++, 1);

  if((unpack("C",$tag) & 0x1f) == 0x1f) {
    my $b;
    my $n=1;
    do {
      return if $pos >= $end;
      $tag .= substr($_[0],$pos++,1);
      $b = ord substr($tag,-1);
    } while($b & 0x80);
  }
  return if $pos >= $end;

  my $len = ord substr($_[0],$pos++,1);

  if($len & 0x80) {
    $len &= 0x7f;

    if ($len) {
      return if $pos+$len > $end ;

      my $padding = $len < 4 ? "\0" x (4 - $len) : "";
      ($len,$pos) = (unpack("N", $padding . substr($_[0],$pos,$len)), $pos+$len);
    }
    else {
      unless (exists $larr->{$pos}) {
        _scan_indef($_[0],$pos,$end,$larr) or return;
      }
      $indef = 2;
      $len = $larr->{$pos};
    }
  }

  return if $pos+$len+$indef > $end;

  # return the tag, the length of the data, the position of the data
  # and the number of extra bytes for indefinite encoding

  ($tag, $len, $pos, $indef);
}

sub _scan_indef {
  my($pos,$end,$larr) = @_[1,2,3];
  my @depth = ( $pos );

  while(@depth) {
    return if $pos+2 > $end;

    if (substr($_[0],$pos,2) eq "\0\0") {
      my $end = $pos;
      my $stref = shift @depth;
      # replace pos with length = end - pos
      $larr->{$stref} = $end - $stref;
      $pos += 2;
      next;
    }
    return if $pos >= $end;

    my $tag = substr($_[0], $pos++, 1);

    if((unpack("C",$tag) & 0x1f) == 0x1f) {
      my $b;
      do {
	return if $pos >= $end;
	$tag .= substr($_[0],$pos++,1);
	$b = ord substr($tag,-1);
      } while($b & 0x80);
    }
    return if $pos >= $end;

    my $len = ord substr($_[0],$pos++,1);

    if($len & 0x80) {
      if ($len &= 0x7f) {
	return if $pos+$len > $end ;

	my $padding = $len < 4 ? "\0" x (4 - $len) : "";
	$pos += $len + unpack("N", $padding . substr($_[0],$pos,$len));
      }
      else {
        # reserve another list element
        unshift @depth, $pos;
      }
    }
    else {
      $pos += $len;
    }
  }

  1;
}

sub _ctr_string { join '', @_ }

sub _ctr_bitstring {
  [ join('', map { $_->[0] } @_), $_[-1]->[1] ]
}

sub _dec_bcd {
# 0      1    2       3     4     5     6
# $optn, $op, $stash, $var, $buf, $pos, $len

  ($_[3] = unpack("H*", substr($_[4],$_[5],$_[6]))) =~ s/[fF]$//;
  1;
}
1;