File Coverage

blib/lib/Net/SSH/AuthorizedKey/Base.pm
Criterion Covered Total %
statement 159 174 91.3
branch 54 68 79.4
condition 5 6 83.3
subroutine 19 20 95.0
pod 1 11 9.0
total 238 279 85.3


line stmt bran cond sub pod time code
1             ###########################################
2             package Net::SSH::AuthorizedKey::Base;
3             ###########################################
4 12     12   46 use strict;
  12         13  
  12         309  
5 12     12   44 use warnings;
  12         12  
  12         281  
6 12     12   43 use Log::Log4perl qw(:easy);
  12         10  
  12         62  
7 12     12   7867 use Text::ParseWords;
  12         6377  
  12         739  
8 12     12   74 use Digest::MD5 qw(md5_hex);
  12         14  
  12         1022  
9              
10             # Accessors common for both ssh1 and ssh2 keys
11             our @accessors = qw(key type error email comment);
12             __PACKAGE__->make_accessor( $_ ) for @accessors;
13              
14             # Some functions must be implemented in the subclass
15             do {
16 12     12   50 no strict qw(refs);
  12         12  
  12         16362  
17              
18             *{__PACKAGE__ . "::$_"} = sub {
19 0     0   0 die "Whoa! '$_' in the virtual base class has to be ",
20             " implemented by a real subclass.";
21             };
22              
23             } for qw(option_type as_string);
24              
25             # Options accepted by all keys
26             our %VALID_OPTIONS = (
27             "no-port-forwarding" => 1,
28             "no-agent-forwarding" => 1,
29             "no-x11-forwarding" => 1,
30             "no-pty" => 1,
31             "no-user-rc" => 1,
32             command => "s",
33             environment => "s",
34             from => "s",
35             permitopen => "s",
36             tunnel => "s",
37             );
38              
39             ###########################################
40             sub new {
41             ###########################################
42 52     52 0 93 my($class, %options) = @_;
43              
44 52         165 my $self = {
45             error => "(no error)",
46             option_order => [],
47             %options,
48             };
49              
50 52         68 bless $self, $class;
51 52         122 return $self;
52             }
53              
54             ###########################################
55             sub option_type_global {
56             ###########################################
57 70     70 0 59 my($self, $key) = @_;
58              
59 70 50       106 if(exists $VALID_OPTIONS{ $key }) {
60 70         88 return $VALID_OPTIONS{ $key };
61             }
62              
63             # Maybe the subclass knows about it
64 0         0 return $self->option_type($key);
65             }
66              
67             ###########################################
68             sub options {
69             ###########################################
70 2     2 1 8 my($self) = @_;
71              
72             return {
73 2         4 map { $_ => $self->option( $_ ) }
74 2         4 keys %{ $self->{ options } }
  2         5  
75             };
76             }
77              
78             ###########################################
79             sub option {
80             ###########################################
81 70     70 0 108 my($self, $key, $value, $append) = @_;
82              
83 70         73 $key = lc $key;
84              
85 70         86 my $option_type = $self->option_type_global($key);
86              
87 70 50       107 if(! defined $option_type) {
88 0         0 LOGWARN "Illegal option '$key'";
89 0         0 return undef;
90             }
91              
92 70 100       92 if(defined $value) {
93              
94 57 100       58 if( $append ) {
95 45 100 100     95 if( $self->{options}->{$key} and
96             ref($self->{options}->{$key}) ne "ARRAY" ) {
97 3         6 $self->{options}->{$key} = [ $self->{options}->{$key} ];
98             }
99             } else {
100 12         28 $self->option_delete( $key );
101             }
102              
103 57 100       82 if($option_type eq "s") {
104 35 100 66     84 if( $self->{options}->{$key} and
105             ref($self->{options}->{$key}) eq "ARRAY" ) {
106 5         12 DEBUG "Adding option $key to $value";
107 5         16 push @{ $self->{options}->{$key} }, $value;
  5         8  
108             } else {
109 30         66 DEBUG "Setting option $key to $value";
110 30         122 $self->{options}->{$key} = $value;
111             }
112             } else {
113 22         49 $self->{options}->{$key} = undef;
114             }
115 57         37 push @{ $self->{option_order} }, $key;
  57         66  
116             }
117              
118 70 100       115 if( "$option_type" eq "1" ) {
119 25         47 return exists $self->{options}->{$key};
120             }
121              
122 45         91 return $self->{options}->{$key};
123             }
124              
125             ###########################################
126             sub option_delete {
127             ###########################################
128 15     15 0 15 my($self, $key) = @_;
129              
130 15         15 $key = lc $key;
131              
132 15         26 @{ $self->{option_order} } =
133 15         13 grep { $_ ne $key } @{ $self->{option_order} };
  67         60  
  15         18  
134              
135 15         19 delete $self->{options}->{$key};
136             }
137              
138             ###########################################
139             sub options_as_string {
140             ###########################################
141 69     69 0 54 my($self) = @_;
142              
143 69         68 my $string = "";
144 69         76 my @parts = ();
145              
146 69         53 for my $option ( @{ $self->{option_order} } ) {
  69         110  
147 76 100       92 if(defined $self->{options}->{$option}) {
148 46 100       61 if(ref($self->{options}->{$option}) eq "ARRAY") {
149 10         8 for (@{ $self->{options}->{$option} }) {
  10         13  
150 28         25 push @parts, option_quote($option, $_);
151             }
152             } else {
153 36         49 push @parts, option_quote($option, $self->{options}->{$option});
154             }
155             } else {
156 30         29 push @parts, $option;
157             }
158             }
159 69         188 return join(',', @parts);
160             }
161              
162             ###########################################
163             sub option_quote {
164             ###########################################
165 64     64 0 54 my($option, $text) = @_;
166              
167 64         67 $text =~ s/([\\"])/\\$1/g;
168 64         114 return "$option=\"" . $text . "\"";
169             }
170              
171             ###########################################
172             sub parse {
173             ###########################################
174 126     126 0 779 my($class, $string) = @_;
175              
176 126         261 DEBUG "Parsing line '$string'";
177              
178             # Clean up leading whitespace
179 126         516 $string =~ s/^\s+//;
180 126         113 $string =~ s/^#.*//;
181            
182 126 50       211 if(! length $string) {
183 0         0 DEBUG "Nothing to parse";
184 0         0 return;
185             }
186              
187 126 100       287 if(my $key = $class->key_read( $string ) ) {
188             # We found a key without options
189 34         79 $key->{options} = {};
190 34         715 DEBUG "Found ", $key->type(), " key: ", $key->as_string();
191 34         187 return $key;
192             }
193              
194             # No key found. Probably there are options in front of the key.
195             # By the way: the openssh-5.x parser doesn't allow escaped
196             # backslashes (\\), so we don't either.
197 92         718 my $rc = (
198             (my $key_string = $string) =~
199             s/^((?:
200             (?:"(?:\\"|.)*?)"|
201             \S
202             )+
203             )
204             //x );
205 92 50       326 my $options_string = ($rc ? $1 : "");
206 92         158 $key_string =~ s/^\s+//;
207              
208 92         197 DEBUG "Trying line with options stripped: [$key_string]";
209              
210 92 100       389 if(my $key = $class->key_read( $key_string ) ) {
211             # We found a key with options
212 18         33 $key->{options} = {};
213 18         43 $key->options_parse( $options_string );
214 18         388 DEBUG "Found ", $key->type(), " key: ", $key->as_string();
215 18         93 return $key;
216             }
217              
218 74         147 DEBUG "$class cannot parse line: $string";
219              
220 74         271 return undef;
221             }
222              
223             ###########################################
224             sub options_parse {
225             ###########################################
226 18     18 0 20 my($self, $string) = @_;
227              
228 18         47 DEBUG "Parsing options: [$string]";
229 18         120 my @options = parse_line(qr/\s*,\s*/, 0, $string);
230              
231             # delete empty/undefined fields
232 18 100       1936 @options = grep { defined $_ and length $_ } @options;
  48         152  
233              
234 18         24 DEBUG "Parsed options: ", join(' ', map { "[$_]" } @options);
  45         94  
235              
236 18         85 for my $option (@options) {
237 45         76 my($key, $value) = split /=/, $option, 2;
238 45 100       72 $value = 1 unless defined $value;
239 45         47 $value =~ s/^"(.*)"$/$1/; # remove quotes
240              
241 45         69 $self->option($key, $value, 1);
242             }
243             }
244              
245             ###########################################
246             sub fingerprint {
247             ###########################################
248 1     1 0 1 my($self) = @_;
249              
250 1         4 my $data = $self->options();
251              
252 1         4 my $string = join '', map { $_ => $data->{$_} } sort keys %$data;
  0         0  
253 1         24 $string .= $self->key();
254              
255 1         9 return md5_hex($string);
256             }
257              
258             ##################################################
259             # Poor man's Class::Struct
260             ##################################################
261             sub make_accessor {
262             ##################################################
263 96     96 0 145 my($package, $name) = @_;
264              
265 12     12   90 no strict qw(refs);
  12         16  
  12         1460  
266              
267 96         280 my $code = <
268             *{"$package\\::$name"} = sub {
269             my(\$self, \$value) = \@_;
270              
271             if(defined \$value) {
272             \$self->{$name} = \$value;
273             }
274             if(exists \$self->{$name}) {
275             return (\$self->{$name});
276             } else {
277             return "";
278             }
279             }
280             EOT
281 96 50       84 if(! defined *{"$package\::$name"}) {
  96         558  
282 96 50   21   10612 eval $code or die "$@";
  21 100       84  
  21 50       49  
  18 100       27  
  21 50       36  
  21 100       46  
  0 50       0  
  38 100       42  
  38 50       63  
  20 100       29  
  38 50       57  
  38 100       73  
  0 50       0  
  60 100       499  
  60 50       101  
  48 100       72  
  60 50       88  
  60         124  
  0         0  
  56         92  
  56         101  
  47         67  
  56         102  
  56         120  
  0         0  
  39         105  
  39         73  
  4         6  
  39         53  
  39         112  
  0         0  
  67         220  
  67         120  
  51         87  
  67         100  
  67         141  
  0         0  
  45         54  
  45         89  
  33         51  
  45         116  
  45         97  
  0         0  
  12         19  
  12         33  
  6         12  
  12         38  
  12         39  
  0            
283             }
284             }
285              
286             1;
287              
288             __END__