File Coverage

blib/lib/Convert/PEM.pm

Criterion	Covered	Total	%
statement	134	138	97.1
branch	30	52	57.6
condition	10	22	45.4
subroutine	22	23	95.6
pod	7	13	53.8
total	203	248	81.8

package Convert::PEM;
use strict;
use 5.008_001;

use base qw( Class::ErrorHandler );

use MIME::Base64;
use Digest::MD5 qw( md5 );
use Convert::ASN1;
use Carp qw( croak );
use Convert::PEM::CBC;

use vars qw( $VERSION );
$VERSION = '0.08';

sub new {
    my $class = shift;
    my $pem = bless { }, $class;
    $pem->init(@_);
}

sub init {
    my $pem = shift;
    my %param = @_;
    unless (exists $param{ASN} && exists $param{Name}) {
        return (ref $pem)->error("init: Name and ASN are required");
    }
    else {
        $pem->{ASN} = $param{ASN};
        $pem->{Name} = $param{Name};
    }
    $pem->{Macro} = $param{Macro};
    my $asn = $pem->{_asn} = Convert::ASN1->new;
    $asn->prepare( $pem->{ASN} ) or
        return (ref $pem)->error("ASN prepare failed: $asn->{error}");
    $pem;
}

sub asn    { $_[0]->{_asn} }
sub ASN    { $_[0]->{ASN} }
sub name   { $_[0]->{Name} }

sub read {
    my $pem = shift;
    my %param = @_;

    my $blob;
    local *FH;
    my $fname = delete $param{Filename};
    open FH, $fname or
        return $pem->error("Can't open $fname: $!");
    $blob = do { local $/;  };
    close FH;

    $param{Content} = $blob;
    $pem->decode(%param);
}

sub write {
    my $pem = shift;
    my %param = @_;

    my $fname = delete $param{Filename} or
        return $pem->error("write: Filename is required");
    my $blob = $pem->encode(%param);

    local *FH;
    open FH, ">$fname" or
        return $pem->error("Can't open $fname: $!");
    print FH $blob;
    close FH;
    $blob;
}

sub decode {
    my $pem = shift;
    my %param = @_;
    my $blob = $param{Content} or
        return $pem->error("'Content' is required");
    chomp $blob;

    my $dec = $pem->explode($blob) or return;
    my $name = $param{Name} || $pem->name;
    return $pem->error("Object $dec->{Object} does not match " . $name)
        unless $dec->{Object} eq $name;

    my $head = $dec->{Headers};
    my $buf = $dec->{Content};
    my %headers = map { $_->[0] => $_->[1] } @$head;
    if (%headers && $headers{'Proc-Type'} eq '4,ENCRYPTED') {
        $buf = $pem->decrypt( Ciphertext => $buf,
                              Info       => $headers{'DEK-Info'},
                              Password   => $param{Password} )
            or return;
    }

    my $asn = $pem->asn;
    if (my $macro = ($param{Macro} || $pem->{Macro})) {
        $asn = $asn->find($macro) or
            return $pem->error("Can't find Macro $macro");
    }
    my $obj = $asn->decode($buf) or
        return $pem->error("ASN decode failed: $asn->{error}");

    $obj;
}

sub encode {
    my $pem = shift;
    my %param = @_;

    my $asn = $pem->asn;
    if (my $macro = ($param{Macro} || $pem->{Macro})) {
        $asn = $asn->find($macro) or
            return $pem->error("Can't find Macro $macro");
    }
    my $buf = $asn->encode( $param{Content} ) or
        return $pem->error("ASN encode failed: $asn->{error}");

    my(@headers);
    if ($param{Password}) {
        my($info);
        ($buf, $info) = $pem->encrypt( Plaintext => $buf,
                                       Password  => $param{Password} )
            or return;
        push @headers, [ 'Proc-Type' => '4,ENCRYPTED' ];
        push @headers, [ 'DEK-Info'  => $info ];
    }

    $pem->implode( Object  => $param{Name} || $pem->name,
                   Headers => \@headers,
                   Content => $buf );
}

sub explode {
    my $pem = shift;
    my($message) = @_;

    # Canonicalize line endings into "\n".
    $message =~ s/\r\n|\n|\r/\n/g;

    my($head, $object, $headers, $content, $tail) = $message =~
        m:(-----BEGIN ([^\n\-]+)-----)\n(.*?\n\n)?(.+)(-----END .*?-----)$:s;
    my $buf = decode_base64($content);

    my @headers;
    if ($headers) {
        for my $h ( split /\n/, $headers ) {
            my($k, $v) = split /:\s*/, $h, 2;
            push @headers, [ $k => $v ] if $k;
        }
    }

    { Content => $buf,
      Object  => $object,
      Headers => \@headers }
}

sub implode {
    my $pem = shift;
    my %param = @_;
    my $head = "-----BEGIN $param{Object}-----";
    my $tail = "-----END $param{Object}-----";
    my $content = encode_base64( $param{Content}, '' );
    $content =~ s!(.{1,64})!$1\n!g;
    my $headers = join '',
                  map { "$_->[0]: $_->[1]\n" }
                  @{ $param{Headers} };
    $headers .= "\n" if $headers;
    "$head\n$headers$content$tail\n";
}

use vars qw( %CTYPES );
%CTYPES = ('DES-EDE3-CBC' => 'Crypt::DES_EDE3');

sub decrypt {
    my $pem = shift;
    my %param = @_;
    my $passphrase = $param{Password} || "";
    my($ctype, $iv) = split /,/, $param{Info};
    my $cmod = $CTYPES{$ctype} or
        return $pem->error("Unrecognized cipher: '$ctype'");
    $iv = pack "H*", $iv;
    my $cbc = Convert::PEM::CBC->new(
                   Passphrase => $passphrase,
                   Cipher     => $cmod,
                   IV         => $iv );
    my $buf = $cbc->decrypt($param{Ciphertext}) or
        return $pem->error("Decryption failed: " . $cbc->errstr);
    $buf;
}

sub encrypt {
    my $pem = shift;
    my %param = @_;
    $param{Password} or return $param{Plaintext};
    my $ctype = $param{Cipher} || 'DES-EDE3-CBC';
    my $cmod = $CTYPES{$ctype} or
        return $pem->error("Unrecognized cipher: '$ctype'");
    my $cbc = Convert::PEM::CBC->new(
                    Passphrase => $param{Password},
                    Cipher     => $cmod );
    my $iv = uc join '', unpack "H*", $cbc->iv;
    my $buf = $cbc->encrypt($param{Plaintext}) or
        return $pem->error("Encryption failed: " . $cbc->errstr);
    ($buf, "$ctype,$iv");
}

1;
__END__