File Coverage

blib/lib/Net/SSH/Any/URI.pm
Criterion Covered Total %
statement 18 148 12.1
branch 0 80 0.0
condition 0 45 0.0
subroutine 6 22 27.2
pod 0 14 0.0
total 24 309 7.7


line stmt bran cond sub pod time code
1             package Net::SSH::Any::URI;
2              
3 1     1   3 use strict;
  1         1  
  1         21  
4 1     1   3 use warnings;
  1         1  
  1         16  
5 1     1   4 use Carp;
  1         0  
  1         37  
6 1     1   450 use Encode;
  1         6349  
  1         63  
7              
8 1     1   349 use Net::SSH::Any::Util qw(_warn);
  1         1  
  1         987  
9              
10             my @slots = qw(scheme user host port path);
11             my %is_slot = map { $_ => $_ } @slots;
12              
13             my %alias = (passwd => 'password', pwd => 'password');
14              
15              
16              
17             my %unsafe = (password => 1, passphrase => 1);
18              
19             my $IPv6_re = qr((?-xism::(?::[0-9a-fA-F]{1,4}){0,5}(?:(?::[0-9a-fA-F]{1,4}){1,2}|:(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})))|[0-9a-fA-F]{1,4}:(?:[0-9a-fA-F]{1,4}:(?:[0-9a-fA-F]{1,4}:(?:[0-9a-fA-F]{1,4}:(?:[0-9a-fA-F]{1,4}:(?:[0-9a-fA-F]{1,4}:(?:[0-9a-fA-F]{1,4}:(?:[0-9a-fA-F]{1,4}|:)|(?::(?:[0-9a-fA-F]{1,4})?|(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))))|:(?:(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))|[0-9a-fA-F]{1,4}(?::[0-9a-fA-F]{1,4})?|))|(?::(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))|:[0-9a-fA-F]{1,4}(?::(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))|(?::[0-9a-fA-F]{1,4}){0,2})|:))|(?:(?::[0-9a-fA-F]{1,4}){0,2}(?::(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))|(?::[0-9a-fA-F]{1,4}){1,2})|:))|(?:(?::[0-9a-fA-F]{1,4}){0,3}(?::(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))|(?::[0-9a-fA-F]{1,4}){1,2})|:))|(?:(?::[0-9a-fA-F]{1,4}){0,4}(?::(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))|(?::[0-9a-fA-F]{1,4}){1,2})|:))));
20              
21             sub uri_escape {
22 0     0 0   my $str = shift;
23 0 0         $str =~ s/([^A-Za-z0-9\-\._~\[\]])/sprintf "%%%02x", ord $1/ge if defined $str;
  0            
24 0           $str
25             }
26              
27             sub uri_escape_path { # doesn't escape slashes
28 0     0 0   my $str = shift;
29 0 0         $str =~ s/([^A-Za-z0-9\-\._~\[\]\/])/sprintf "%%%02x", ord $1/ge if defined $str;
  0            
30 0           $str
31             }
32              
33              
34              
35             sub uri_unescape {
36 0     0 0   my $str = shift;
37 0 0         $str =~ s/\%([\da-f]{2})/chr hex $1/ige if defined $str;
  0            
38 0           $str
39             }
40              
41             sub new {
42 0     0 0   my $class = shift;
43 0 0         my %opt = (@_ & 1 ? (uri => @_) : @_);
44 0           $_ = encode(latin1 => $_, Encode::FB_CROAK) for values %opt;
45 0           my $uri = delete $opt{uri};
46 0           my %c_params;
47 0           my %uri = (c_params => \%c_params);
48              
49 0           for (keys %alias) {
50 0 0         if (defined (my $opt = delete $opt{$_})) {
51 0   0       $opt{$alias{$_}} //= $opt;
52             }
53             }
54              
55 0 0         if (defined $uri) {
56 0 0         if (my ($scheme, $user, $password, $c_params, $ipv6, $host, $port, $path) =
57             $uri =~ m{^
58             \s* # trim space
59             (?:([\w+-]+)://)?+ # scheme
60             (?:
61             (?:([^\@:;]+))?+ # username
62             (?::([^\@;]*))?+ # : password
63             (?:;([^\@]*))?+ # c-params
64             \@ # @
65             )?+
66             (?> # host
67             ( # IPv6...
68             \[$IPv6_re\] # [IPv6]
69             | # or
70             $IPv6_re # IPv6
71             )
72             | # or
73             ([^\[\]\@:/]+) # hostname / ipv4
74             )
75             (?::([\w\%]+))?+ # port
76             (/.*)?+ # path
77             \s* # trim space
78             $}xo) {
79 0           @uri{qw(scheme user port path)} = map uri_unescape($_), $scheme, $user, $port, $path;
80              
81 0 0         if (defined $ipv6) {
82 0           $ipv6 =~ /^\[?(.*?)\]?$/;
83 0           $uri{host} = $1;
84             }
85             else {
86 0           $uri{host} = uri_unescape $host;
87             }
88              
89 0 0         $c_params{password} = [uri_unescape $password] if defined $password;
90              
91 0 0         if (defined $c_params) {
92 0           while ($c_params =~ /\G([^,=]*)=([^,=]*)(?:,|$)/gc) {
93 0           my ($k, $v) = ($1, $2);
94 0           my $k_unescaped = uri_unescape $k;
95 0   0       $k_unescaped = $alias{$k_unescaped} // $k_unescaped;
96 0           push @{$c_params{$k_unescaped}}, uri_unescape $v;
  0            
97             }
98 0 0         $c_params =~ /\G./gc and return;
99             }
100             }
101             else {
102 0           return;
103             }
104             }
105             else {
106 0 0         defined $opt{host} or croak "both uri and host are undefined";
107             }
108              
109 0           for (@slots) {
110 0           my $v = delete $opt{$_};
111 0 0 0       $uri{$_} //= $v if defined $v;
112             }
113              
114 0 0         if (defined (my $password = delete $opt{password})) {
115 0   0       $uri{c_params}{password} //= [$password];
116             }
117              
118 0           for (keys %opt) {
119 0           my $v = delete $opt{$_};
120 0 0 0       $c_params{$_} //= [$v] if defined $v;
121             }
122              
123 0           my $self = \%uri;
124 0           bless $self, $class;
125             }
126              
127             for my $slot (@slots) {
128             my $sub = sub {
129 0     0     my $self = shift;
130 0 0         if (@_) {
131 0 0         if (defined (my $v = shift)) {
132 0           $self->{$slot} = encode latin1 => $v, Encode::FB_CROAK;
133             }
134             else {
135 0 0         $slot eq 'host' and croak "attribute host is mandatory";
136 0           delete $self->{$slot};
137             }
138 0           return;
139             }
140 0           $self->{$slot};
141             };
142 1     1   4 no strict 'refs';
  1         1  
  1         640  
143             *$slot = $sub;
144             }
145              
146             sub bracketed_host {
147 0     0 0   my $self = shift;
148 0 0         @_ and croak 'bracketed_host is read only';
149 0           my $h = $self->{host};
150 0 0         ($h =~ /^$IPv6_re$/o ? "[$h]" : $h);
151             }
152              
153             sub c_params {
154 0     0 0   my $self = shift;
155 0 0         my $c_params = $self->{c_params} or return;
156 0           my @out;
157 0           for my $k (%$c_params) {
158 0           push @out, map { $k, $_ } @{$c_params->{$k}};
  0            
  0            
159             }
160 0           @out;
161             }
162              
163             sub c_param_count {
164 0     0 0   my ($self, $key) = @_;
165 0   0       $key = $alias{$key} // $key;
166 0 0         my $c_params = $self->{c_params} or return 0;
167 0 0         my $vs = $c_params->{$key} or return 0;
168 0           scalar (@$vs);
169             }
170              
171             sub c_param {
172 0     0 0   my ($self, $key) = @_;
173 0   0       $key = $alias{$key} // $key;
174 0 0         my $c_params = $self->{c_params} or return;
175 0 0         my $vs = $c_params->{$key} or return;
176 0 0         wantarray or croak "c_param used in scalar context is not supported";
177 0           @$vs;
178             }
179              
180             sub set_c_param {
181 0     0 0   my $self = shift;
182 0           my $key = shift;
183 0   0       $key = $alias{$key} // $key;
184 0           $self->{c_params}{$key} = [@_];
185             return
186 0           }
187              
188             sub password {
189 0     0 0   my $self = shift;
190 0           $self->{c_params}{password}[0];
191             }
192              
193             sub get {
194 0     0 0   my $self = shift;
195 0           my $key = shift;
196 0   0       $key = $alias{$key} // $key;
197 0   0       my @r = $self->{$key} // do {
198 0           my $a = $self->{c_params}{$key};
199 0 0         ($a ? @$a : ())
200             };
201 0 0 0       if (@r > 1 and not wantarray) {
202 0           _warn("\$uri->get($key) called on scalar context when it contains more than one entry");
203             }
204 0 0         wantarray ? @r : $r[0];
205             }
206              
207             sub set {
208 0     0 0   my $self = shift;
209 0           my $key = shift;
210 0   0       $key = $alias{$key} // $key;
211 0 0         if ($is_slot{$key}) {
212 0 0         @_ > 1 and _warn "URI attribute $key is an scalar but set($key) called with ".scalar(@_)." arguments";
213 0           $self->$key($_[0]);
214             }
215             else {
216 0           $self->set_c_param($key, @_);
217             }
218             ()
219 0           }
220              
221             sub or_set {
222 0     0 0   my $self = shift;
223 0           my $key = shift;
224 0   0       $key = $alias{$key} // $key;
225 0 0 0       $self->set($key, @_) unless defined $self->{$key} or defined $self->{c_params}{$key};
226             ()
227 0           }
228              
229             sub _c_params_escaped {
230 0     0     my ($self, $safe) = @_;
231 0   0       my $c_params = $self->{c_params} // return;
232 0           my @parts;
233 0           my $ix = 0;
234 0           for my $k (sort keys %$c_params) {
235 0           my $k_escaped = uri_escape $k;
236 0           for my $v (@{$c_params->{$k}}) {
  0            
237             push(@parts, ($ix++ ? ',' : ';'), $k_escaped, '=',
238 0 0 0       (($safe and $unsafe{$k}) ? '*****' : uri_escape $v));
    0          
239             }
240             }
241 0           @parts;
242             }
243              
244             sub uri {
245 0     0 0   my ($self, $safe) = @_;
246 0           my @parts;
247 0 0         push @parts, uri_escape($self->{user}) if defined $self->{user};
248 0           push @parts, $self->_c_params_escaped($safe);
249 0 0         push @parts, '@', if @parts;
250 0 0         unshift @parts, uri_escape($self->{scheme}), '://' if defined $self->{scheme};
251 0           my $h = $self->{host};
252 0 0         push @parts, ($h =~ /^$IPv6_re$/o ? "[$h]" : uri_escape($h));
253 0 0         push @parts, ':', uri_escape($self->{port}) if defined $self->{port};
254 0 0         push @parts, uri_escape_path($self->{path}) if defined $self->{path};
255 0           join '', @parts;
256             }
257              
258             *as_string = \&uri;
259              
260             1;