use strict;
use warnings;
use MIME::Base64;
use IO::Scalar;

my @PacketTag_names= (
   "Reserved - a packet tag must not have this value",
   "Public-Key Encrypted Session Key Packet",
   "Signature Packet",
   "Symmetric-Key Encrypted Session Key Packet",
   "One-Pass Signature Packet",
   "Secret Key Packet",
   "Public Key Packet",
   "Secret Subkey Packet",
   "Compressed Data Packet",
   "Symmetrically Encrypted Data Packet",
   "Marker Packet",
   "Literal Data Packet",
   "Trust Packet",
   "User ID Packet",
   "Public Subkey Packet"
   );
       

my %Public_alg_names= (

       1      => "RSA (Encrypt or Sign)",
       2      => "RSA Encrypt-Only",
       3      => "RSA Sign-Only",
       16      => "Elgamal (Encrypt-Only)",
       17      => "DSA (Digital Signature Standard)",
       18      => "Reserved for Elliptic Curve",
       19      => "Reserved for ECDSA",
       20      => "Elgamal (Encrypt or Sign)"
       );

my %sig_types= (
   0x00 => "Signature of a binary document.",
   0x01 => "Signature of a canonical text document.",
   0x02 => "Standalone signature.",
   0x10 => "Generic certification of a User ID and Public Key packet."
+,
   0x11 => "Persona certification of a User ID and Public Key packet."
+,
   0x12 => "Casual certification of a User ID and Public Key packet.",
   0x13 => "Positive certification of a User ID and Public Key packet.
+",
   0x18 => "Subkey Binding Signature",
   0x1F => "Signature directly on a key",
   0x20 => "Key revocation signature",
   0x30 => "Certification revocation signature",
   0x40 => "Timestamp signature."
   );
       

sub hexdump
# Format a split hex/ascii dump of the input.  Returns a list of
# formatted output lines.
# Input:  datastring, width in bytes, template line
# syntax of template line: replace $hex, $ascii, $offset.
 {
 my $x= shift;    #what to dump
 return () unless defined $x;
 my $width= shift || 16;   #how many bytes per row
 my $template= shift || '$offset: $hex | $ascii'."\n";
 my $offs= 0;
 my @results;    #the output -- list of formatted lines.
 while ($x =~ /(.{$width})|(.+)/gs) {
    my $partial= $2;  #true if this is the last line
    my $hex= $1 || $2;
    my $ascii= $hex;
    $hex =~ s/./unpack("H2",$&) . ' '/sge;   #convert to hex
    chop $hex;  #get rid of extra space after last element.
    $ascii =~ s/[^ -~]/./g;  #remove unprintable chars
    if ($partial) {
       #pad things out to the full length
       my $hexwid= 3*$width -1;
       $hex= pack ("A$hexwid", $hex);
       $ascii= pack ("A$width", $ascii);
       }
    my $result= $template;
    $result =~ s/\$offset/sprintf ("%04x", $offs)/e;
    $result =~ s/\$hex/$hex/;
    $result =~ s/\$ascii/$ascii/;
    push @results, $result;
    $offs += $width;
    }
 return @results;
 }

sub read_MPI
 {
 my $infile= shift;
 $infile->read (my $buf, 2);
 return undef  if length($buf) != 2;
 my $length= unpack ("n", $buf);
 $infile->read ($buf, ($length+7)/8);
 my $text= unpack ("B*", $buf);
 $text= '0' . $text  while (length($text) % 8 != 0);
 $text= unpack ("H*", pack ("B*", $text));
 if (wantarray) {  return ($text, $length) }
 else { return $text }
 }
 
sub fetch
 {
 my $infilename= $ARGV[0] || "John M. Dlugosz.asc";
 my $infile;
 open ($infile, '<', $infilename)  or die;
 my @text= <$infile>;
 close $infile;
 splice (@text, 0, 3);
 splice (@text, -2);
 my $binary= decode_base64 (join ('',@text));
 return $binary;
 }

sub readbyte
 {
 my $input= shift;
 $input->read (my $buf, 1) or return undef;
 return ord $buf;
 }

sub read_oldstyle_length
 {
 my $length_type= shift;
 my $input= shift;
 my $meta_length= (1, 2, 4, 0)[$length_type];
 if ($meta_length == 1) {
    return readbyte ($input);
    }
 if ($meta_length==2) {
    $input->read (my $buf, 2);
    return unpack ("n", $buf);
    }
 die "unimplemented $meta_length ";
 }


sub read_newstyle_length
 {
 my $input= shift;
 my $length= readbyte ($input);
 if ($length > 191 && $length <= 223) {
    # two-byte length
    my $byte2= readbyte ($input);
    $length= (($length-192)<<8 ) + $byte2 + 192
    }
 elsif ($length >= 224 && $length < 255) {
    die "partial lengths not supported"
    }
 elsif ($length == 255) {
    $input->read (my $buf, 4);
    $length= unpack ("N", $buf);
    }
 return $length;
 }
 
sub read_sig_packet
 {
 my ($packet_type, $packetdata, $level)= @_;
 my $input= new IO::Scalar (\$packetdata);
 my $margin= "\t" x $level;
 my $version= readbyte ($input);
 print "${margin}version $version";
 if ($version == 4) {
    $input->read (my $buf, 3);
    my ($type, $pub_alg, $hash_alg)= unpack ("ccc", $buf);
    printf ("${margin}signature type 0x%x, $sig_types{$type}\n", $type
+);
    print ("${margin}public-key alg $pub_alg ($Public_alg_names{$pub_a
+lg}), hash alg $hash_alg\n");
    return;
    }
 print "\n";
 }

sub read_public_key_packet
 {
 my ($packet_type, $packetdata, $level)= @_;
 my $input= new IO::Scalar (\$packetdata);
 my $margin= "\t" x $level;
 $input->read (my $buf, 5);
 my ($version, $creation_time)= unpack ("cN", $buf);
 print "${margin}version $version, created $creation_time\n";
 if ($version == 2) {
    die "version 2 tag deprecated.";
    }
 if ($version == 3) {
    warn "version 3 tag not supported.";
    return;
    }
 if ($version == 4) {
    my $alg= readbyte($input);
    print "${margin}Algorithm= $alg, $Public_alg_names{$alg}\n";
    return;
    }
 warn "unknown version";
 return;
 }

sub read_pub_session_packet
 {
 my ($packet_type, $packetdata, $level)= @_;
 my $input= new IO::Scalar (\$packetdata);
 my $margin= "\t" x $level;
 $input->read (my $buf, 10);
 my ($version, $keyID, $alg)= unpack ("c h16 c", $buf);
 print "${margin}version $version, key ID=$keyID, Algorithm= $alg, $Pu
+blic_alg_names{$alg}\n";
 for (;;) {
    my ($number, $bitlen)= read_MPI ($input);
    last  unless $bitlen;
    print "${margin}${bitlen}-bit integer\n";
    }
 }

sub readpacket
 {
 my $input= shift;
 my $PacketTag= readbyte ($input);
 return undef unless defined $PacketTag;
 printf "Packet tag is: %x\n", $PacketTag;
 unless ($PacketTag & 0x80) {
    die "not a valid Packet Tag";
    }
 my ($packet_type, $length);
 if ($PacketTag & 0x40) {
    # new style
    $packet_type= $PacketTag & 63;
    print "packet type is $packet_type, $PacketTag_names[$packet_type]
+\n";
    $length= read_newstyle_length ($input);
    }
 else {
    # old style
    $packet_type= ($PacketTag>>2)&15;
    print "packet type is old-style $packet_type, $PacketTag_names[$pa
+cket_type]\n";
    my $length_type= $PacketTag & 3;
    $length= read_oldstyle_length ($length_type, $input);
    }
 print "length is $length bytes\n";
 $input->read (my $buf, $length);
 read_public_key_packet ($packet_type, $buf, 1)  if ($packet_type==6 |
+| $packet_type==14 || $packet_type==5||$packet_type==7);
 read_sig_packet ($packet_type, $buf, 1)  if ($packet_type==2);
 read_pub_session_packet ($packet_type, $buf, 1)  if ($packet_type==1)
+;
 return 1;
 }


my $binary= fetch;
my $BIN= new IO::Scalar (\$binary);
1  while defined readpacket ($BIN);
[download]