File Coverage

blib/lib/Net/SSH/Any/Util.pm
Criterion Covered Total %
statement 23 85 27.0
branch 0 38 0.0
condition 0 11 0.0
subroutine 8 24 33.3
pod n/a
total 31 158 19.6


line stmt bran cond sub pod time code
1             package Net::SSH::Any::Util;
2              
3 1     1   20 BEGIN { *debug = \$Net::SSH::Any::debug }
4              
5 1     1   3 use strict;
  1         2  
  1         14  
6 1     1   3 use warnings;
  1         1  
  1         15  
7 1     1   3 use Carp;
  1         1  
  1         39  
8 1     1   3 use File::Spec;
  1         1  
  1         13  
9 1     1   420 use Time::HiRes ();
  1         1002  
  1         217  
10              
11             require Exporter;
12             our @ISA = qw(Exporter);
13             our @EXPORT = qw($debug _debug _debugf _debug_dump _debug_hexdump
14             _sub_options _croak_bad_options
15             _first_defined _array_or_scalar_to_list
16             _inc_numbered _gen_wanted
17             _scp_escape_name _scp_unescape_name
18             _warn);
19              
20             our $debug ||= 0;
21              
22 0     0   0 sub _warn { warnings::warnif('Net::SSH::Any', join(': ', @_)) }
23              
24             sub _debug {
25 0     0   0 local ($@, $!, $_);
26 0 0       0 print STDERR '#', (Time::HiRes::time() - $^T), ': ', (map { defined($_) ? $_ : '' } @_), "\n";
  0         0  
27             }
28              
29             sub _debugf {
30 0     0   0 my $t = shift;
31 0 0       0 _debug sprintf($t, map { defined($_) ? $_ : '' } @_);
  0         0  
32             }
33              
34             sub _debug_dump {
35 0     0   0 require Data::Dumper;
36 0         0 local $Data::Dumper::Terse = 1;
37 0         0 local $Data::Dumper::Indent = 0;
38 0         0 my $head = shift;
39 0         0 _debug("$head: ", Data::Dumper::Dumper(@_));
40             }
41              
42             sub _debug_hexdump {
43 1     1   8 no warnings qw(uninitialized);
  1         1  
  1         740  
44 0     0   0 my $head = shift;
45 0         0 local ($@, $!, $_);
46 0         0 _debugf("%s (%d bytes):", $head, length($_[0]));
47 0 0       0 if ($debug & 16384) {
48 0         0 my $data = shift;
49 0         0 while ($data =~ /(.{1,32})/smg) {
50 0         0 my $line = $1;
51 0         0 my @c= (( map { sprintf "%02x",$_ } unpack('C*', $line)),
  0         0  
52             ((" ") x 32))[0..31];
53 0 0       0 $line=~s/(.)/ my $c=$1; unpack("c",$c)>=32 ? $c : '.' /egms;
  0         0  
  0         0  
54 0         0 print STDERR "#> ", join(" ", @c, '|', $line), "\n";
55 0 0 0     0 if (!($debug & 32768) and $data =~ /(=?.)/csmg) {
56 0         0 print STDERR "#> ...\n";
57 0         0 last;
58             }
59             }
60             }
61             }
62              
63 0   0 0   0 sub _first_defined { defined && return $_ for @_; return }
  0         0  
64              
65             my %good;
66              
67             sub _sub_options {
68 5     5   5 my $sub = shift;
69 5         5 my $pkg = caller;
70 5         5 $good{"${pkg}::$sub"} = { map { $_ => 1 } @_ };
  34         47  
71             }
72              
73             sub _croak_bad_options (\%) {
74 0     0     my $opts = shift;
75 0 0         if (%$opts) {
76 0           my $sub = (caller 1)[3];
77 0           my $good = $good{$sub};
78 0 0         my @keys = ( $good ? grep !$good->{$_}, keys %$opts : keys %$opts);
79 0 0         if (@keys) {
80 0           croak "Invalid or bad combination of options ('" . join("', '", @keys) . "')";
81             }
82             }
83             }
84              
85 0 0   0     sub _array_or_scalar_to_list { map { defined($_) ? (ref $_ eq 'ARRAY' ? @$_ : $_ ) : () } @_ }
  0 0          
86              
87             sub _inc_numbered {
88 0 0   0     $_[0] =~ s{^(.*)\((\d+)\)((?:\.[^\.]*)?)$}{"$1(" . ($2+1) . ")$3"}e or
  0            
89             $_[0] =~ s{((?:\.[^\.]*)?)$}{(1)$1};
90 0 0 0       $debug and $debug & 128 and _debug("numbering to: $_[0]");
91             }
92              
93             sub _gen_wanted {
94 0     0     my ($ow, $onw) = my ($w, $nw) = @_;
95 0 0         if (ref $w eq 'Regexp') {
96 0     0     $w = sub { $_[0]{remote} =~ $ow }
97 0           }
98              
99 0 0         if (ref $nw eq 'Regexp') {
100 0     0     $nw = sub { $_[0]{remote} =~ $onw }
101 0           }
102              
103 0 0 0       if (defined $w and defined $nw) {
104 0 0   0     return sub { &$nw and not &$w }
105 0           }
106              
107 0 0         return $w if defined $w;
108 0 0   0     return sub { not &$nw } if defined $nw;
  0            
109 0           undef;
110             }
111              
112             sub _scp_unescape_name {
113 0 0   0     s/\\\\|\\\^([@-Z])/$1 ? chr(ord($1) - 64) : '\\'/ge for @_;
  0            
114             }
115              
116             sub _scp_escape_name {
117 0     0     for (@_) {
118 0           s/\\/\\\\/;
119 0           s/([\x00-\x1f])/'\\^' . chr(64 + ord($1))/ge;
  0            
120             }
121             }
122              
123             # sub _mkpath {
124             # my $path = shift;
125             # my @start = File::Spec->splitdir(File::Spec->rel2abs($path));
126             # my @end;
127             # while (@start) {
128             # my $start = File::Spec->join(@start);
129             # last if -d $start;
130             # push @end, pop @start;
131             # }
132             # while (@end) {
133             # push @start, pop @end;
134             # my $start = File::Spec->join(@start);
135             # return unless -d $start or mkdir $start;
136             # }
137             # 1;
138             # }
139              
140             1;