File Coverage

blib/lib/Crypt/OpenPGP/PacketFactory.pm

Criterion	Covered	Total	%
statement	366	366	100.0
branch	46	66	69.7
condition	13	21	61.9
subroutine	122	122	100.0
pod	2	2	100.0
total	549	577	95.1

package Crypt::OpenPGP::PacketFactory;
use strict;
use warnings;

our $VERSION = '1.19'; # VERSION

use Crypt::OpenPGP::Constants qw( :packet );
use Crypt::OpenPGP::ErrorHandler;
use base qw( Crypt::OpenPGP::ErrorHandler );

our %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_USER_ATTRIBUTE() => { class => 'Crypt::OpenPGP::UserAttribute' },
    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' },
);

our %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__