path: root/Master/tlpkg/tlperl/lib/Convert/ASN1/IO.pm

# Copyright (c) 2000-2005 Graham Barr <gbarr@pobox.com>. 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;

use strict;
use Socket;

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

sub asn_recv { # $socket, $buffer, $flags

  my $peer;
  my $buf;
  my $n = 128;
  my $pos = 0;
  my $depth = 0;
  my $len = 0;
  my($tmp,$tb,$lb);

  MORE:
  for(
    $peer = recv($_[0],$buf,$n,MSG_PEEK);
    defined $peer;
    $peer = recv($_[0],$buf,$n<<=1,MSG_PEEK)
  ) {

    if ($depth) { # Are we searching of "\0\0"

      unless (2+$pos <= length $buf) {
	next MORE if $n == length $buf;
	last MORE;
      }

      if(substr($buf,$pos,2) eq "\0\0") {
	unless (--$depth) {
	  $len = $pos + 2;
	  last MORE;
	}
      }
    }

    # If we can decode a tag and length we can detemine the length
    ($tb,$tmp) = asn_decode_tag(substr($buf,$pos));
    unless ($tb || $pos+$tb < length $buf) {
      next MORE if $n == length $buf;
      last MORE;
    }

    if (ord(substr($buf,$pos+$tb,1)) == 0x80) {
      # indefinite length, grrr!
      $depth++;
      $pos += $tb + 1;
      redo MORE;
    }

    ($lb,$len) = asn_decode_length(substr($buf,$pos+$tb));

    if ($lb) {
      if ($depth) {
	$pos += $tb + $lb + $len;
	redo MORE;
      }
      else {
	$len += $tb + $lb + $pos;
	last MORE;
      }
    }
  }

  if (defined $peer) {
    if ($len > length $buf) {
      # Check we can read the whole element
      goto error
	unless defined($peer = recv($_[0],$buf,$len,MSG_PEEK));

      if ($len > length $buf) {
	# Cannot get whole element
	$_[1]='';
	return $peer;
      }
    }
    elsif ($len == 0) {
      $_[1] = '';
      return $peer;
    }

    if ($_[2] & MSG_PEEK) {
      $_[1] =  substr($buf,0,$len);
    }
    elsif (!defined($peer = recv($_[0],$_[1],$len,0))) {
      goto error;
    }

    return $peer;
  }

error:
    $_[1] = undef;
}

sub asn_read { # $fh, $buffer, $offset

  # 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 tag and a length. We then know
  # how many more bytes to read

  if ($_[2]) {
    if ($_[2] > length $_[1]) {
      require Carp;
      Carp::carp("Offset beyond end of buffer");
      return;
    }
    substr($_[1],$_[2]) = '';
  }
  else {
    $_[1] = '';
  }

  my $pos = 0;
  my $need = 0;
  my $depth = 0;
  my $ch;
  my $n;
  my $e;
  

  while(1) {
    $need = ($pos + ($depth * 2)) || 2;

    while(($n = $need - length $_[1]) > 0) {
      $e = sysread($_[0],$_[1],$n,length $_[1]) or
	goto READ_ERR;
    }

    my $tch = ord(substr($_[1],$pos++,1));
    # Tag may be multi-byte
    if(($tch & 0x1f) == 0x1f) {
      my $ch;
      do {
        $need++;
	while(($n = $need - length $_[1]) > 0) {
	  $e = sysread($_[0],$_[1],$n,length $_[1]) or
	      goto READ_ERR;
	}
	$ch = ord(substr($_[1],$pos++,1));
      } while($ch & 0x80);
    }

    $need = $pos + 1;

    while(($n = $need - length $_[1]) > 0) {
      $e = sysread($_[0],$_[1],$n,length $_[1]) or
	  goto READ_ERR;
    }

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

    if($len & 0x80) {
      unless ($len &= 0x7f) {
	$depth++;
	next;
      }
      $need = $pos + $len;

      while(($n = $need - length $_[1]) > 0) {
	$e = sysread($_[0],$_[1],$n,length $_[1]) or
	    goto READ_ERR;
      }

      $pos += $len + unpack("N", "\0" x (4 - $len) . substr($_[1],$pos,$len));
    }
    elsif (!$len && !$tch) {
      die "Bad ASN PDU" unless $depth;
      unless (--$depth) {
	last;
      }
    }
    else {
      $pos += $len;
    }

    last unless $depth;
  }

  while(($n = $pos - length $_[1]) > 0) {
    $e = sysread($_[0],$_[1],$n,length $_[1]) or
      goto READ_ERR;
  }

  return length $_[1];

READ_ERR:
    $@ = defined($e) ? "Unexpected EOF" : "I/O Error $!"; # . CORE::unpack("H*",$_[1]);
    return undef;
}

sub asn_send { # $sock, $buffer, $flags, $to

  @_ == 4
    ? send($_[0],$_[1],$_[2],$_[3])
    : send($_[0],$_[1],$_[2]);
}

sub asn_write { # $sock, $buffer

  syswrite($_[0],$_[1], length $_[1]);
}

sub asn_get { # $fh

  my $fh = ref($_[0]) ? $_[0] : \($_[0]);
  my $href = \%{*$fh};

  $href->{'asn_buffer'} = '' unless exists $href->{'asn_buffer'};

  my $need = delete $href->{'asn_need'} || 0;
  while(1) {
    next if $need;
    my($tb,$tag) = asn_decode_tag($href->{'asn_buffer'}) or next;
    my($lb,$len) = asn_decode_length(substr($href->{'asn_buffer'},$tb,8)) or next;
    $need = $tb + $lb + $len;
  }
  continue {
    if ($need && $need <= length $href->{'asn_buffer'}) {
      my $ret = substr($href->{'asn_buffer'},0,$need);
      substr($href->{'asn_buffer'},0,$need) = '';
      return $ret;
    }

    my $get = $need > 1024 ? $need : 1024;

    sysread($_[0], $href->{'asn_buffer'}, $get, length $href->{'asn_buffer'})
      or return undef;
  }
}

sub asn_ready { # $fh

  my $fh = ref($_[0]) ? $_[0] : \($_[0]);
  my $href = \%{*$fh};

  return 0 unless exists $href->{'asn_buffer'};
  
  return $href->{'asn_need'} <= length $href->{'asn_buffer'}
    if exists $href->{'asn_need'};

  my($tb,$tag) = asn_decode_tag($href->{'asn_buffer'}) or return 0;
  my($lb,$len) = asn_decode_length(substr($href->{'asn_buffer'},$tb,8)) or return 0;

  $href->{'asn_need'} = $tb + $lb + $len;

  $href->{'asn_need'} <= length $href->{'asn_buffer'};
}

1;