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


line stmt bran cond sub pod time code
1             package Net::SSH::Perl::Key;
2 2     2   7634 use strict;
  2         32  
  2         71  
3 2     2   12 use warnings;
  2         11  
  2         80  
4              
5 2     2   1005 use Crypt::Digest::SHA256 qw( sha256 );
  2         5674  
  2         158  
6 2     2   920 use Crypt::Digest::MD5 qw( md5 );
  2         1223  
  2         112  
7 2     2   465 use Crypt::Misc qw( encode_b64 decode_b64 );
  2         7637  
  2         119  
8 2     2   468 use Net::SSH::Perl::Buffer;
  2         5  
  2         257  
9              
10             sub new {
11 3     3 1 567 my $class = shift;
12 3 100       11 if ($class eq __PACKAGE__) {
13 1         3 $class .= "::" . shift();
14 1     1   62 eval "use $class;";
  1         522  
  1         4  
  1         18  
15 1 50       5 die "Key class '$class' is unsupported: $@" if $@;
16             }
17 3         9 my $key = bless {}, $class;
18 3         25 $key->init(@_);
19 3         7 $key;
20             }
21              
22 2     2   14 use vars qw( %KEY_TYPES );
  2         4  
  2         864  
23             %KEY_TYPES = (
24             'ssh-dss' => 'DSA',
25             'ssh-rsa' => 'RSA',
26             'ssh-ed25519' => 'Ed25519',
27             'ecdsa-sha2-nistp256' => 'ECDSA256',
28             'ecdsa-sha2-nistp384' => 'ECDSA384',
29             'ecdsa-sha2-nistp521' => 'ECDSA521',
30             );
31              
32             sub new_from_blob {
33 0     0 0 0 my $class = shift;
34 0         0 my($blob) = @_;
35 0         0 my $b = Net::SSH::Perl::Buffer->new( MP => 'SSH1' );
36 0         0 $b->append($blob);
37 0         0 my $ssh_name = $b->get_str;
38 0 0       0 my $type = $KEY_TYPES{$ssh_name} or return;
39 0         0 __PACKAGE__->new($type, @_);
40             }
41              
42             sub extract_public {
43 0     0 1 0 my $class = shift;
44 0         0 my($blob) = pop @_;
45 0 0       0 my $expected_type = @_ ? shift : undef;
46              
47 0         0 my $type;
48             my $options;
49 0         0 foreach my $t (keys %KEY_TYPES) {
50 0 0       0 if ((my $type_offset = index($blob,$t)) >= 0) {
51 0         0 $type = $t;
52 0 0       0 $options = substr($blob,0,$type_offset,'') if $type_offset > 0;
53 0         0 last;
54             }
55             }
56              
57             # TODO do something with ssh options $options
58              
59 0 0       0 if (!defined $type) {
60 0         0 warn "Invalid public key line";
61 0         0 return;
62             }
63 0         0 substr($blob,0,length($type)+1,'');
64 0         0 my($data, $comment) = split /\s+/, $blob, 2;
65 0 0 0     0 if (defined $expected_type && $expected_type ne $type) {
66 0         0 warn "Requested type '$expected_type' mismatches actual type '$type'";
67 0         0 return;
68             }
69 0         0 $type = $KEY_TYPES{$type};
70 0         0 my $key = __PACKAGE__->new($type, decode_b64($data));
71 0         0 $key->comment($comment);
72 0         0 $key;
73             }
74              
75             BEGIN {
76 2     2   14 no strict 'refs'; ## no critic
  2         4  
  2         294  
77 2     2   39 for my $meth (qw( read_private keygen )) {
78             *$meth = sub {
79 0     0   0 my $class = shift;
80 0 0       0 if ($class eq __PACKAGE__) {
81 0         0 $class .= "::" . shift();
82 0         0 eval "use $class;";
83 0 0       0 die "Key class '$class' is unsupported: $@" if $@;
84             }
85 0         0 $class->$meth(@_);
86 4         82 };
87             }
88             }
89              
90 2     2   14 use vars qw( %OBJ_MAP );
  2         4  
  2         1494  
91             %OBJ_MAP = (
92             'DSA PRIVATE KEY' => [ 'DSA' ],
93             'SSH2 ENCRYPTED PRIVATE KEY' => [ 'DSA', [ 'SSH2' ] ],
94             'RSA PRIVATE KEY' => [ 'RSA' ],
95             'OPENSSH PRIVATE KEY' => [ 'Ed25519' ],
96             'EC PRIVATE KEY' => [ 'ECDSA' ],
97             );
98              
99             sub read_private_pem {
100 1     1 0 3 my $class = shift;
101 1         8 my $keyfile = $_[0];
102 1 50       46 open my $fh, '<', $keyfile or return;
103 1         47 chomp(my $desc = <$fh>);
104 1 50       18 close $fh or warn qq{Could not close "$keyfile": $!\n};
105 1 50       5 return unless $desc;
106 1         10 my($object) = $desc =~ /^-----?\s?BEGIN ([^\n\-]+)\s?-?----\s*$/;
107 1         7 $object =~ s/\s*$//;
108 1 50       5 my $rec = $OBJ_MAP{$object} or return;
109 1         3 $class = __PACKAGE__ . "::" . $rec->[0];
110 1     1   63 eval "use $class;";
  1         7  
  1         2  
  1         16  
111 1 50       4 die "Key class '$class' is unsupported: $@" if $@;
112 1 50       4 my @args = $rec->[1] ? @{ $rec->[1] } : ();
  0         0  
113 1         4 $class->read_private(@_, @args);
114             }
115              
116             sub init;
117             sub extract_public;
118             sub as_blob;
119             sub equal;
120             sub size;
121              
122             sub fingerprint {
123 0     0 1 0 my $key = shift;
124 0         0 my($type) = @_;
125 0         0 my $data = $key->fingerprint_raw;
126 0 0 0     0 $type && $type eq 'bubblebabble' ?
    0 0        
127             _fp_bubblebabble($data) :
128             $type && $type eq 'md5' ?
129             _fp_md5($data) :
130             _fp_sha256($data);
131             }
132              
133             sub _fp_bubblebabble {
134 0     0   0 eval "use Digest::BubbleBabble qw( bubblebabble )";
135 0 0       0 die "Can't load BubbleBabble implementation: $@" if $@;
136 0         0 eval "use Crypt::Digest::SHA1 qw( sha1 )";
137 0 0       0 die "Can't load SHA1: $@" if $@;
138 0         0 bubblebabble( Digest => sha1($_[0]) )
139             }
140              
141 0     0   0 sub _fp_sha256 { "SHA256:" . encode_b64(sha256(shift)) }
142 0     0   0 sub _fp_md5 { join ':', map { sprintf "%02x", ord } split //, md5($_[0]) }
  0         0  
143              
144             sub comment {
145 1     1 0 3 my $key = shift;
146 1         2 my $comment = shift;
147 1 50       5 $key->{comment} = $comment if defined $comment;
148 1         2 $key->{comment};
149             }
150              
151 0     0 1 0 sub dump_public { join ' ', grep { defined } $_[0]->ssh_name, encode_b64( $_[0]->as_blob ), $_[0]->comment }
  0         0  
152              
153             1;
154             __END__