diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Crypt/OpenPGP/PacketFactory.pm')
| -rwxr-xr-x | Master/tlpkg/tlperl/lib/Crypt/OpenPGP/PacketFactory.pm | 255 |
1 files changed, 255 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Crypt/OpenPGP/PacketFactory.pm b/Master/tlpkg/tlperl/lib/Crypt/OpenPGP/PacketFactory.pm new file mode 100755 index 00000000000..eba1ad88def --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Crypt/OpenPGP/PacketFactory.pm @@ -0,0 +1,255 @@ +package Crypt::OpenPGP::PacketFactory; +use strict; + +use Crypt::OpenPGP::Constants qw( :packet ); +use Crypt::OpenPGP::ErrorHandler; +use base qw( Crypt::OpenPGP::ErrorHandler ); + +use vars qw( %PACKET_TYPES %PACKET_TYPES_BY_CLASS ); +%PACKET_TYPES = ( + PGP_PKT_PUBKEY_ENC() => { class => 'Crypt::OpenPGP::SessionKey' }, + PGP_PKT_SIGNATURE() => { class => 'Crypt::OpenPGP::Signature' }, + PGP_PKT_SYMKEY_ENC() => { class => 'Crypt::OpenPGP::SKSessionKey' }, + PGP_PKT_ONEPASS_SIG() => { class => 'Crypt::OpenPGP::OnePassSig' }, + PGP_PKT_SECRET_KEY() => { class => 'Crypt::OpenPGP::Certificate', + args => [ 1, 0 ] }, + PGP_PKT_PUBLIC_KEY() => { class => 'Crypt::OpenPGP::Certificate', + args => [ 0, 0 ] }, + PGP_PKT_SECRET_SUBKEY() => { class => 'Crypt::OpenPGP::Certificate', + args => [ 1, 1 ] }, + PGP_PKT_USER_ID() => { class => 'Crypt::OpenPGP::UserID' }, + PGP_PKT_PUBLIC_SUBKEY() => { class => 'Crypt::OpenPGP::Certificate', + args => [ 0, 1 ] }, + PGP_PKT_COMPRESSED() => { class => 'Crypt::OpenPGP::Compressed' }, + PGP_PKT_ENCRYPTED() => { class => 'Crypt::OpenPGP::Ciphertext' }, + PGP_PKT_MARKER() => { class => 'Crypt::OpenPGP::Marker' }, + PGP_PKT_PLAINTEXT() => { class => 'Crypt::OpenPGP::Plaintext' }, + PGP_PKT_RING_TRUST() => { class => 'Crypt::OpenPGP::Trust' }, + PGP_PKT_ENCRYPTED_MDC() => { class => 'Crypt::OpenPGP::Ciphertext', + args => [ 1 ] }, + PGP_PKT_MDC() => { class => 'Crypt::OpenPGP::MDC' }, +); + +%PACKET_TYPES_BY_CLASS = map { $PACKET_TYPES{$_}{class} => $_ } keys %PACKET_TYPES; + +sub parse { + my $class = shift; + my($buf, $find, $parse) = @_; + return unless $buf && $buf->offset < $buf->length; + my(%find, %parse); + if ($find) { + %find = ref($find) eq 'ARRAY' ? (map { $_ => 1 } @$find) : + ($find => 1); + } + else { + %find = map { $_ => 1 } keys %PACKET_TYPES; + } + if ($parse) { + %parse = ref($parse) eq 'ARRAY' ? (map { $_ => 1 } @$parse) : + ($parse => 1); + } + else { + %parse = %find; + } + + my($type, $len, $partial, $hdrlen, $b); + do { + ($type, $len, $partial, $hdrlen) = $class->_parse_header($buf); + $b = $buf->extract($len ? $len : $buf->length - $buf->offset); + return unless $type; + } while !$find{$type}; ## Skip + + while ($partial) { + my $off = $buf->offset; + (my($nlen), $partial) = $class->_parse_new_len_header($buf); + $len += $nlen + ($buf->offset - $off); + $b->append( $buf->get_bytes($nlen) ); + } + + my $obj; + if ($parse{$type} && (my $ref = $PACKET_TYPES{$type})) { + my $pkt_class = $ref->{class}; + my @args = $ref->{args} ? @{ $ref->{args} } : (); + eval "use $pkt_class;"; + return $class->error("Loading $pkt_class failed: $@") if $@; + $obj = $pkt_class->parse($b, @args); + } + else { + $obj = { type => $type, length => $len, + __pkt_len => $len + $hdrlen, __unparsed => 1 }; + } + $obj; +} + +sub _parse_header { + my $class = shift; + my($buf) = @_; + return unless $buf && $buf->offset < $buf->length; + + my $off_start = $buf->offset; + my $tag = $buf->get_int8; + return $class->error("Parse error: bit 7 not set!") + unless $tag & 0x80; + my $is_new = $tag & 0x40; + my($type, $len, $partial); + if ($is_new) { + $type = $tag & 0x3f; + ($len, $partial) = $class->_parse_new_len_header($buf); + } + else { + $type = ($tag>>2)&0xf; + my $lenbytes = (($tag&3)==3) ? 0 : (1<<($tag & 3)); + $len = 0; + for (1..$lenbytes) { + $len <<= 8; + $len += $buf->get_int8; + } + } + ($type, $len, $partial, $buf->offset - $off_start); +} + +sub _parse_new_len_header { + my $class = shift; + my($buf) = @_; + return unless $buf && $buf->offset < $buf->length; + my $lb1 = $buf->get_int8; + my($partial, $len); + if ($lb1 <= 191) { + $len = $lb1; + } elsif ($lb1 <= 223) { + $len = (($lb1-192) << 8) + $buf->get_int8 + 192; + } elsif ($lb1 < 255) { + $partial++; + $len = 1 << ($lb1 & 0x1f); + } else { + $len = $buf->get_int32; + } + ($len, $partial); +} + +sub save { + my $class = shift; + my @objs = @_; + my $ser = ''; + for my $obj (@objs) { + my $body = $obj->save; + my $len = length($body); + my $type = $obj->can('pkt_type') ? $obj->pkt_type : + $PACKET_TYPES_BY_CLASS{ref($obj)}; + my $hdrlen = $obj->can('pkt_hdrlen') ? $obj->pkt_hdrlen : undef; + my $buf = Crypt::OpenPGP::Buffer->new; + if ($obj->{is_new} || $type > 15) { + my $tag = 0xc0 | ($type & 0x3f); + $buf->put_int8($tag); + return $class->error("Can't write partial length packets") + unless $len; + if ($len < 192) { + $buf->put_int8($len); + } elsif ($len < 8384) { + $len -= 192; + $buf->put_int8(int($len / 256) + 192); + $buf->put_int8($len % 256); + } else { + $buf->put_int8(0xff); + $buf->put_int32($len); + } + } + else { + unless ($hdrlen) { + if (!defined $len) { + $hdrlen = 0; + } elsif ($len < 256) { + $hdrlen = 1; + } elsif ($len < 65536) { + $hdrlen = 2; + } else { + $hdrlen = 4; + } + } + return $class->error("Packet overflow: overflow preset len") + if $hdrlen == 1 && $len > 255; + $hdrlen = 4 if $hdrlen == 2 && $len > 65535; + my $tag = 0x80 | ($type << 2); + if ($hdrlen == 0) { + $buf->put_int8($tag | 3); + } elsif ($hdrlen == 1) { + $buf->put_int8($tag); + $buf->put_int8($len); + } elsif ($hdrlen == 2) { + $buf->put_int8($tag | 1); + $buf->put_int16($len); + } else { + $buf->put_int8($tag | 2); + $buf->put_int32($len); + } + } + $buf->put_bytes($body); + $ser .= $buf->bytes; + } + $ser; +} + +1; +__END__ + +=head1 NAME + +Crypt::OpenPGP::PacketFactory - Parse and save PGP packet streams + +=head1 SYNOPSIS + + use Crypt::OpenPGP::PacketFactory; + + my $buf = Crypt::OpenPGP::Buffer->new; + while (my $packet = Crypt::OpenPGP::PacketFactory->parse($buf)) { + ## Do something with $packet + } + + my @packets; + my $serialized = Crypt::OpenPGP::PacketFactory->save(@packets); + +=head1 DESCRIPTION + +I<Crypt::OpenPGP::PacketFactory> parses PGP buffers (objects of type +I<Crypt::OpenPGP::Buffer>) and generates packet objects of various +packet classes (for example, I<Crypt::OpenPGP::Certificate> objects, +I<Crypt::OpenPGP::Signature> objects, etc.). It also takes lists of +packets, serializes each of them, and adds type/length headers to +them, forming a stream of packets suitable for armouring, writing +to disk, sending through email, etc. + +=head1 USAGE + +=head2 Crypt::OpenPGP::PacketFactory->parse($buffer [, $find ]) + +Given a buffer object I<$buffer> of type I<Crypt::OpenPGP::Buffer>, +iterates through the packets serialized in the buffer, parsing +each one, and returning each packet one by one. In other words, given +a buffer, it acts as a standard iterator. + +By default I<parse> parses and returns all packets in the buffer, of +any packet type. If you are only looking for packets of a specific +type, though, it makes no sense to return every packet; you can +control which packets I<parse> parses and returns with I<$find>, which +should be a reference to a list of packet types to find in the buffer. +Only packets of those types will be parsed and returned to you. You +can get the packet type constants from I<Crypt::OpenPGP::Constants> +by importing the C<:packet> tag. + +Returns the next packet in the buffer until the end of the buffer +is reached (or until there are no more of the packets which you wish +to find), at which point returns a false value. + +=head2 Crypt::OpenPGP::PacketFactory->save(@packets) + +Given a list of packets I<@packets>, serializes each packet, then +adds a type/length header on to each one, resulting in a string of +octets representing the serialized packets, suitable for passing in +to I<parse>, or for writing to disk, or anywhere else. + +=head1 AUTHOR & COPYRIGHTS + +Please see the Crypt::OpenPGP manpage for author, copyright, and +license information. + +=cut |