File Coverage

blib/lib/Net/SFTP/Foreign/Helpers.pm
Criterion Covered Total %
statement 31 198 15.6
branch 1 112 0.8
condition 1 18 5.5
subroutine 11 37 29.7
pod n/a
total 44 365 12.0


line stmt bran cond sub pod time code
1             package Net::SFTP::Foreign::Helpers;
2              
3             our $VERSION = '1.74_06';
4              
5 3     3   23 use strict;
  3         7  
  3         92  
6 3     3   16 use warnings;
  3         7  
  3         88  
7 3     3   16 use Carp qw(croak carp);
  3         4  
  3         198  
8              
9             our @CARP_NOT = qw(Net::SFTP::Foreign);
10              
11 3     3   17 use Scalar::Util qw(tainted);
  3         15  
  3         455  
12              
13             require Exporter;
14             our @ISA = qw(Exporter);
15             our @EXPORT = qw( _sort_entries
16             _gen_wanted
17             _ensure_list
18             _catch_tainted_args
19             _debug
20             _gen_converter
21             _hexdump
22             $debug
23             );
24             our @EXPORT_OK = qw( _is_lnk
25             _is_dir
26             _is_reg
27             _do_nothing
28             _glob_to_regex
29             _file_part
30             _umask_save_and_set
31             _tcroak
32             _untaint );
33              
34             our $debug;
35              
36             BEGIN {
37 3 50 33 3   1119 eval "use Time::HiRes 'time'"
38             if ($debug and $debug & 256)
39             }
40              
41             sub _debug {
42 0     0     local ($\, $!);
43 0           my $caller = '';
44 0 0         if ( $debug & 8192) {
45 0           $caller = (caller 1)[3];
46 0           $caller =~ s/[\w:]*:://;
47 0           $caller .= ': ';
48             }
49              
50 0 0         my $line = join(' ', map { defined $_ ? $_ : '' } @_);
  0            
51              
52 0 0         if ($debug & 256) {
53 0           my $ts = sprintf("%010.5f", time);
54 0           print STDERR "#$$ $ts $caller $line\n";
55             }
56             else {
57 0           print STDERR "# $caller $line\n";
58             }
59             }
60              
61             sub _hexdump {
62 0     0     local ($\, $!);
63 3     3   28 no warnings qw(uninitialized);
  3         6  
  3         1928  
64 0           my $data = shift;
65 0           while ($data =~ /(.{1,32})/smg) {
66 0           my $line=$1;
67 0           my @c= (( map { sprintf "%02x",$_ } unpack('C*', $line)),
  0            
68             ((" ") x 32))[0..31];
69 0 0         $line=~s/(.)/ my $c=$1; unpack("c",$c)>=32 ? $c : '.' /egms;
  0            
  0            
70 0           local $\;
71 0           print STDERR join(" ", @c, '|', $line), "\n";
72             }
73             }
74              
75       0     sub _do_nothing {}
76              
77             {
78             my $has_sk;
79             sub _has_sk {
80 0 0   0     unless (defined $has_sk) {
81 0           local $@;
82 0           local $SIG{__DIE__};
83 0           eval { require Sort::Key };
  0            
84 0           $has_sk = ($@ eq '');
85             }
86 0           return $has_sk;
87             }
88             }
89              
90             sub _sort_entries {
91 0     0     my $e = shift;
92 0 0         if (_has_sk) {
93 0     0     &Sort::Key::keysort_inplace(sub { $_->{filename} }, $e);
  0            
94             }
95             else {
96 0           @$e = sort { $a->{filename} cmp $b->{filename} } @$e;
  0            
97             }
98             }
99              
100             sub _gen_wanted {
101 0     0     my ($ow, $onw) = my ($w, $nw) = @_;
102 0 0         if (ref $w eq 'Regexp') {
103 0     0     $w = sub { $_[1]->{filename} =~ $ow }
104 0           }
105              
106 0 0         if (ref $nw eq 'Regexp') {
    0          
107 0     0     $nw = sub { $_[1]->{filename} !~ $onw }
108 0           }
109             elsif (defined $nw) {
110 0     0     $nw = sub { !&$onw };
  0            
111             }
112              
113 0 0 0       if (defined $w and defined $nw) {
114 0 0   0     return sub { &$nw and &$w }
115 0           }
116              
117 0   0       return $w || $nw;
118             }
119              
120             sub _ensure_list {
121 0     0     my $l = shift;
122 0 0         return () unless defined $l;
123 0           local $@;
124 0           local $SIG{__DIE__};
125 0           local $SIG{__WARN__};
126 3     3   25 no warnings;
  3         6  
  3         3812  
127 0 0         (eval { @$l; 1 } ? @$l : $l);
  0            
  0            
128             }
129              
130             sub _glob_to_regex {
131 0     0     my ($glob, $strict_leading_dot, $ignore_case) = @_;
132              
133 0           my ($regex, $in_curlies, $escaping);
134 0           my $wildcards = 0;
135              
136 0           my $first_byte = 1;
137 0           while ($glob =~ /\G(.)/g) {
138 0           my $char = $1;
139             # print "char: $char\n";
140 0 0         if ($char eq '\\') {
141 0           $escaping = 1;
142             }
143             else {
144 0 0         if ($first_byte) {
145 0 0         if ($strict_leading_dot) {
146 0 0         $regex .= '(?=[^\.])' unless $char eq '.';
147             }
148 0           $first_byte = 0;
149             }
150 0 0         if ($char eq '/') {
151 0           $first_byte = 1;
152             }
153 0 0         if ($escaping) {
154 0           $regex .= quotemeta $char;
155             }
156             else {
157 0           $wildcards++;
158 0 0 0       if ($char eq '*') {
    0          
    0          
    0          
    0          
    0          
159 0           $regex .= ".*";
160             }
161             elsif ($char eq '?') {
162 0           $regex .= '.'
163             }
164             elsif ($char eq '{') {
165 0           $regex .= '(?:(?:';
166 0           ++$in_curlies;
167             }
168             elsif ($char eq '}') {
169 0           $regex .= "))";
170 0           --$in_curlies;
171 0 0         $in_curlies < 0
172             and croak "invalid glob pattern";
173             }
174             elsif ($char eq ',' && $in_curlies) {
175 0           $regex .= ")|(?:";
176             }
177             elsif ($char eq '[') {
178 0 0         if ($glob =~ /\G((?:\\.|[^\]])+)\]/g) {
179 0           $regex .= "[$1]"
180             }
181             else {
182 0           croak "invalid glob pattern";
183             }
184             }
185             else {
186 0           $wildcards--;
187 0           $regex .= quotemeta $char;
188             }
189             }
190              
191 0           $escaping = 0;
192             }
193             }
194              
195 0 0         croak "invalid glob pattern" if $in_curlies;
196              
197 0 0         my $re = $ignore_case ? qr/^$regex$/i : qr/^$regex$/;
198 0 0         wantarray ? ($re, ($wildcards > 0 ? 1 : undef)) : $re
    0          
199             }
200              
201             sub _tcroak {
202 0 0   0     if (${^TAINT} > 0) {
203 0           push @_, " while running with -T switch";
204 0           goto &croak;
205             }
206 0 0         if (${^TAINT} < 0) {
207 0           push @_, " while running with -t switch";
208 0           goto &carp;
209             }
210             }
211              
212             sub _catch_tainted_args {
213 0     0     my $i;
214 0           for (@_) {
215 0 0         next unless $i++;
216 0 0         if (tainted($_)) {
    0          
217 0           my (undef, undef, undef, $subn) = caller 1;
218 0 0         my $msg = ( $subn =~ /::([a-z]\w*)$/
219             ? "Insecure argument '$_' on '$1' method call"
220             : "Insecure argument '$_' on method call" );
221 0           _tcroak($msg);
222             }
223             elsif (ref($_)) {
224 0           for (grep tainted($_),
225 0           do { local ($@, $SIG{__DIE__}); eval { values %$_ }}) {
  0            
  0            
226 0           my (undef, undef, undef, $subn) = caller 1;
227 0 0         my $msg = ( $subn =~ /::([a-z]\w*)$/
228             ? "Insecure argument on '$1' method call"
229             : "Insecure argument on method call" );
230 0           _tcroak($msg);
231             }
232             }
233             }
234             }
235              
236             sub _gen_dos2unix {
237 0     0     my $unix2dos = shift;
238 0 0         my $name = ($unix2dos ? 'unix2dos' : 'dos2unix');
239 0           my $previous;
240             my $done;
241             sub {
242 0 0   0     $done and die "Internal error: bad calling sequence for $name transformation";
243 0           my $adjustment = 0;
244 0           for (@_) {
245 0 0 0       if ($debug and $debug & 128) {
246 0           _debug ("before $name: previous: $previous, data follows...");
247 0           _hexdump($_);
248             }
249 0 0         if (length) {
    0          
250 0 0         if ($previous) {
251 0           $adjustment++;
252 0           $_ = "\x0d$_";
253             }
254 0           $adjustment -= $previous = s/\x0d\z//s;
255 0 0         if ($unix2dos) {
256 0           $adjustment += s/(?
257             }
258             else {
259 0           $adjustment -= s/\x0d\x0a/\x0a/gs;
260             }
261             }
262             elsif ($previous) {
263 0           $previous = 0;
264 0           $done = 1;
265 0           $adjustment++;
266 0           $_ = "\x0d";
267             }
268 0 0 0       if ($debug and $debug & 128) {
269 0           _debug ("after $name: previous: $previous, adjustment: $adjustment, data follows...");
270 0           _hexdump($_);
271             }
272 0           return $adjustment;
273             }
274             }
275 0           }
276              
277             sub _gen_converter {
278 0     0     my $conversion = shift;
279              
280 0 0         return undef unless defined $conversion;
281              
282 0 0         if (ref $conversion) {
    0          
    0          
283 0 0         if (ref $conversion eq 'CODE') {
284             return sub {
285 0     0     my $before = length $_[0];
286 0           $conversion->($_[0]);
287 0           length($_[0]) - $before;
288             }
289 0           }
290             else {
291 0           croak "unsupported conversion argument"
292             }
293             }
294             elsif ($conversion eq 'dos2unix') {
295 0           return _gen_dos2unix(0);
296             }
297             elsif ($conversion eq 'unix2dos') {
298 0           return _gen_dos2unix(1);
299             }
300             else {
301 0           croak "unknown conversion '$conversion'";
302             }
303             }
304              
305 3     3   27 use constant S_IFMT => 0170000;
  3         6  
  3         227  
306 3     3   29 use constant S_IFLNK => 0120000;
  3         6  
  3         204  
307 3     3   23 use constant S_IFDIR => 0040000;
  3         6  
  3         164  
308 3     3   22 use constant S_IFREG => 0100000;
  3         5  
  3         1146  
309              
310 0     0     sub _is_lnk { (S_IFMT & shift) == S_IFLNK }
311 0     0     sub _is_dir { (S_IFMT & shift) == S_IFDIR }
312 0     0     sub _is_reg { (S_IFMT & shift) == S_IFREG }
313              
314             sub _file_part {
315 0     0     my $path = shift;
316 0 0         $path =~ m{([^/]*)$} or croak "unable to get file part from path '$path'";
317 0           $1;
318             }
319              
320             sub _untaint {
321 0 0   0     if (${^TAINT}) {
322 0           for (@_) {
323 0 0         defined or next;
324 0           ($_) = /(.*)/s
325             }
326             }
327             }
328              
329             sub _umask_save_and_set {
330 0     0     my $umask = shift;
331 0 0         if (defined $umask) {
332 0           my $old = umask $umask;
333 0           return bless \$old, 'Net::SFTP::Foreign::Helpers::umask_saver';
334             }
335             ()
336 0           }
337              
338 0     0     sub Net::SFTP::Foreign::Helpers::umask_saver::DESTROY { umask ${$_[0]} }
  0            
339              
340             1;
341