File Coverage

blib/lib/Net/SSH/Perl/Key.pm

Criterion	Covered	Total	%
statement	61	110	55.4
branch	10	42	23.8
condition	0	9	0.0
subroutine	15	23	65.2
pod	4	7	57.1
total	90	191	47.1

# $Id: Key.pm,v 1.20 2008/10/02 20:46:17 turnstep Exp $

package Net::SSH::Perl::Key;
use strict;
use warnings;

use Crypt::Digest::SHA256 qw( sha256 );
use Crypt::Digest::MD5 qw( md5 );
use Crypt::Misc qw( encode_b64 decode_b64 );
use Net::SSH::Perl::Buffer;

sub new {
    my $class = shift;
    if ($class eq __PACKAGE__) {
        $class .= "::" . shift();
        eval "use $class;";
        die "Key class '$class' is unsupported: $@" if $@;
    }
    my $key = bless {}, $class;
    $key->init(@_);
    $key;
}

use vars qw( %KEY_TYPES );
%KEY_TYPES = (
    'ssh-dss' => 'DSA',
    'ssh-rsa' => 'RSA',
    'ssh-ed25519' => 'Ed25519',
    'ecdsa-sha2-nistp256' => 'ECDSA256',
    'ecdsa-sha2-nistp384' => 'ECDSA384',
    'ecdsa-sha2-nistp521' => 'ECDSA521',
);

sub new_from_blob {
    my $class = shift;
    my($blob) = @_;
    my $b = Net::SSH::Perl::Buffer->new( MP => 'SSH1' );
    $b->append($blob);
    my $ssh_name = $b->get_str;
    my $type = $KEY_TYPES{$ssh_name} or return;
    __PACKAGE__->new($type, @_);
}

sub extract_public {
    my $class = shift;
    my($blob) = pop @_;
    my $expected_type = @_ ? shift : undef;

    my $type;
    my $options;
    foreach my $t (keys %KEY_TYPES) {
        if ((my $type_offset = index($blob,$t)) >= 0) {
            $type = $t;
            $options = substr($blob,0,$type_offset,'') if $type_offset > 0;
            last;
        }
    }

    # TODO do something with ssh options $options

    if (!defined $type) {
        warn "Invalid public key line";
        return;
    }
    substr($blob,0,length($type)+1,'');
    my($data, $comment) = split /\s+/, $blob, 2;
    if (defined $expected_type && $expected_type ne $type) {
        warn "Requested type '$expected_type' mismatches actual type '$type'";
        return;
    }
    $type = $KEY_TYPES{$type};
    my $key = __PACKAGE__->new($type, decode_b64($data));
    $key->comment($comment);
    $key;
}

BEGIN {
    no strict 'refs'; ## no critic
    for my $meth (qw( read_private keygen )) {
        *$meth = sub {
            my $class = shift;
            if ($class eq __PACKAGE__) {
                $class .= "::" . shift();
                eval "use $class;";
                die "Key class '$class' is unsupported: $@" if $@;
            }
            $class->$meth(@_);
        };
    }
}

use vars qw( %OBJ_MAP );
%OBJ_MAP = (
    'DSA PRIVATE KEY'  => [ 'DSA' ],
    'SSH2 ENCRYPTED PRIVATE KEY' => [ 'DSA', [ 'SSH2' ] ],
    'RSA PRIVATE KEY'  => [ 'RSA' ],
    'OPENSSH PRIVATE KEY'  => [ 'Ed25519' ],
    'EC PRIVATE KEY' => [ 'ECDSA' ],
);

sub read_private_pem {
    my $class = shift;
    my $keyfile = $_[0];
    open my $fh, '<', $keyfile or return;
    chomp(my $desc = <$fh>);
    close $fh or warn qq{Could not close "$keyfile": $!\n};
    return unless $desc;
    my($object) = $desc =~ /^-----?\s?BEGIN ([^\n\-]+)\s?-?----\s*$/;
    $object =~ s/\s*$//;
    my $rec = $OBJ_MAP{$object} or return;
    $class = __PACKAGE__ . "::" . $rec->[0];
    eval "use $class;";
    die "Key class '$class' is unsupported: $@" if $@;
    my @args = $rec->[1] ? @{ $rec->[1] } : ();
    $class->read_private(@_, @args);
}

sub init;
sub extract_public;
sub as_blob;
sub equal;
sub size;

sub fingerprint {
    my $key = shift;
    my($type) = @_;
    my $data = $key->fingerprint_raw;
    $type && $type eq 'bubblebabble' ?
        _fp_bubblebabble($data) :
        $type && $type eq 'md5' ?
          _fp_md5($data) :
          _fp_sha256($data);
}

sub _fp_bubblebabble {
    eval "use Digest::BubbleBabble qw( bubblebabble )";
    die "Can't load BubbleBabble implementation: $@" if $@;
    eval "use Crypt::Digest::SHA1 qw( sha1 )";
    die "Can't load SHA1: $@" if $@;
    bubblebabble( Digest => sha1($_[0]) )
}

sub _fp_sha256 { "SHA256:" . encode_b64(sha256(shift)) }
sub _fp_md5 { join ':', map { sprintf "%02x", ord } split //, md5($_[0]) }

sub comment {
    my $key = shift;
    my $comment = shift;
    $key->{comment} = $comment if defined $comment;
    $key->{comment};
}

sub dump_public { join ' ', grep { defined } $_[0]->ssh_name, encode_b64( $_[0]->as_blob ), $_[0]->comment }

1;
__END__