move tlperl.straw to tlperl

git-svn-id: svn://tug.org/texlive/trunk@18210 c570f23f-e606-0410-a88d-b1316a301751

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