File Coverage

lib/File/Util.pm
Criterion Covered Total %
statement 605 772 78.3
branch 381 698 54.5
condition 155 335 46.2
subroutine 58 68 85.2
pod 40 40 100.0
total 1239 1913 64.7


line stmt bran cond sub pod time code
1 20     20   470339 use 5.006;
  20         52  
2 20     20   62 use strict;
  20         19  
  20         382  
3 20     20   63 use warnings;
  20         22  
  20         545  
4              
5 20     20   58 use lib 'lib';
  20         15  
  20         67  
6              
7             package File::Util;
8             $File::Util::VERSION = '4.161200';
9 20     20   7055 use File::Util::Definitions qw( :all );
  20         29  
  20         3933  
10 20     20   5030 use File::Util::Interface::Modern qw( :all );
  20         24  
  20         1896  
11              
12 20     20   80 use Scalar::Util qw( blessed );
  20         20  
  20         558  
13 20     20   57 use Exporter;
  20         18  
  20         1727  
14              
15             our $AUTHORITY = 'cpan:TOMMY';
16             our @ISA = qw( Exporter );
17              
18             # some of the symbols below come from File::Util::Definitions
19             our @EXPORT_OK = qw(
20             NL can_flock ebcdic existent needs_binmode
21             SL strip_path is_readable is_writable valid_filename
22             OS bitmask return_path file_type escape_filename
23             is_bin created last_access last_changed last_modified
24             isbin split_path atomize_path diagnostic abort_depth
25             size can_read can_write read_limit can_utf8
26             default_path strict_path
27             );
28              
29             our %EXPORT_TAGS = ( all => [ @EXPORT_OK ], diag => [ ] );
30              
31             our $WANT_DIAGNOSTICS = 0;
32              
33             # --------------------------------------------------------
34             # LEGACY methods (which get replaced in AUTOLOAD)
35             # --------------------------------------------------------
36 20     20   8741 use subs qw( can_read can_write isbin readlimit );
  20         353  
  20         81  
37              
38             # --------------------------------------------------------
39             # Constructor
40             # --------------------------------------------------------
41             sub new {
42 23     23 1 3455 my $this = { };
43              
44 23         57 bless $this, shift @_;
45              
46 23   50     117 my $in = $this->_parse_in( @_ ) || { };
47              
48 23   50     168 $this->{opts} = $in || { };
49              
50 23   100     165 $this->{opts}->{onfail} ||= 'die';
51              
52             # let constructor argument override globals, but set
53             # constructor opts to global values if they have not
54             # overridden them...
55              
56             $USE_FLOCK = $in->{use_flock}
57             if exists $in->{use_flock}
58 23 100 66     74 && defined $in->{use_flock};
59              
60 23         38 $this->{opts}->{use_flock} = $USE_FLOCK;
61              
62             $WANT_DIAGNOSTICS = $in->{diag}
63             if exists $in->{diag}
64 23 50 33     73 && defined $in->{diag};
65              
66 23         35 $this->{opts}->{diag} = $WANT_DIAGNOSTICS;
67              
68             $in->{read_limit} = defined $in->{read_limit}
69             ? $in->{read_limit}
70             : defined $in->{readlimit}
71             ? $in->{readlimit}
72 23 100       112 : undef;
    100          
73              
74 23         30 delete $in->{readlimit};
75 23 100       68 delete $in->{read_limit} if !defined $in->{read_limit};
76              
77             $READ_LIMIT = $in->{read_limit}
78             if exists $in->{read_limit}
79             && defined $in->{read_limit}
80 23 50 66     81 && $in->{read_limit} !~ /\D/;
      66        
81              
82 23         35 $this->{opts}->{read_limit} = $READ_LIMIT;
83              
84             $ABORT_DEPTH = $in->{abort_depth}
85             if exists $in->{abort_depth}
86             && defined $in->{abort_depth}
87 23 50 66     94 && $in->{abort_depth} !~ /\D/;
      66        
88              
89 23         32 $this->{opts}->{abort_depth} = $ABORT_DEPTH;
90              
91 23         57 return $this;
92             }
93              
94              
95             # --------------------------------------------------------
96             # File::Util::import()
97             # --------------------------------------------------------
98             sub import {
99              
100 21     21   180 my ( $class, @wanted_symbols ) = @_;
101              
102 21 50       54 ++$WANT_DIAGNOSTICS if grep { /(?
  28         75  
103              
104 21         26842 $class->export_to_level( 1, @_ );
105             }
106              
107              
108             # --------------------------------------------------------
109             # File::Util::list_dir()
110             # --------------------------------------------------------
111             sub list_dir {
112 79     79 1 1685 my $this = shift @_;
113 79         73 my $dir = shift @_;
114 79 100       177 my $opts = ref $_[0] eq 'REF' ? ${ shift @_ } : $this->_remove_opts( \@_ );
  48         49  
115              
116 79         65 my ( @dir_contents, $subdirs, $files );
117              
118 79         72 my $abort_depth = $opts->{abort_depth};
119              
120             # We can bypass all this extra checking/validation when we are recursing
121             # because we know we called ourself correctly--
122              
123             # INPUT VALIDATION AND DEFAULT VALUES
124              
125 79 100       110 if ( !$opts->{_recursing} ) { # bypass all this if recursing
126              
127 31 50 33     128 return $this->_throw(
128             'no input' => {
129             meth => 'list_dir',
130             missing => 'a directory name',
131             opts => $opts,
132             }
133             ) unless defined $dir && length $dir;
134              
135             $abort_depth =
136             defined $opts->{abort_depth}
137             ? $opts->{abort_depth}
138             : defined $this->{opts}->{abort_depth}
139             ? $this->{opts}->{abort_depth}
140 31 50       83 : $ABORT_DEPTH;
    50          
141              
142             # in case somebody wants to list_dir( "/tmp////" ) which is legal!
143 31 50       299 $dir =~ s/(?<=.)[\/\\:]+$// unless $dir =~ /^$WINROOT$/o;
144              
145             # recurse_fast implies recurse, and so does the legacy opt "follow"
146 31 50 33     104 $opts->{recurse} = 1 if $opts->{recurse_fast} || $opts->{follow};
147              
148             # "." and ".." make no sense (and cause infinite loops) when recursing...
149 31 100       49 $opts->{no_fsdots} = 1 if $opts->{recurse}; # ...so skip them
150              
151             # be compatible with GNU find
152 31 50       46 $opts->{max_depth} = delete $opts->{maxdepth} if $opts->{maxdepth};
153              
154             # break off immediately to helper function if asked to make a ref-tree
155 31 50       43 return $this->_as_tree( $dir => $opts ) if $opts->{as_tree};
156              
157 31 50       372 return $this->_throw( 'no such file' => { opts => $opts, filename => $dir } )
158             unless -e $dir;
159              
160 31 50       204 return $this->_throw (
161             'called opendir on a file' => {
162             filename => $dir,
163             opts => $opts,
164             }
165             ) unless -d $dir;
166             }
167              
168             # RUNAWAY RECURSION PREVENTION...
169              
170             # We have to keep an eye on recursion; we do it with a shared-reference.
171             # scalar references didn't work for me, so I'm using a hashref with a
172             # single key-value and it works beautifully
173             $opts->{_recursion} = {
174             _fast => $opts->{recurse_fast},
175             _base => $dir,
176             _isroot => ( $dir eq '/' || $dir =~ /^$WINROOT/ ) ? 1 : 0,
177             _depth => 0,
178             _inodes => {},
179 79 50 33     416 } unless defined $opts->{_recursion};
    100          
180              
181             # ...AND FILESYSTEM LOOPING PREVENTION ARE TIED TOGETHER...
182              
183 79 50       119 if ( !$opts->{_recursion}->{_fast} )
184             {
185 79         727 my ( $dev, $inode ) = lstat $dir;
186              
187 79 50       132 if ( $inode ) { # noop on windows which always returns zero (0) for inode
188              
189             # keep track of dir inodes or we're going to get stuck in filesystem
190             # loops the following bit of code incrementally populates (with each
191             # recursion) a hash table with keys named for the dev ID and inode of
192             # the directory, for every directory found
193              
194             warn sprintf
195             qq(*WARNING! Filesystem loop detected at %s, dev %s, inode %s\n),
196             $dir, $dev, $inode
197             and return( () )
198 79 50 0     217 if exists $opts->{_recursion}{_inodes}{ $dev, $inode };
199              
200 79         164 $opts->{_recursion}{_inodes}{ $dev, $inode } = undef;
201             }
202             }
203              
204             # DETERMINE DEPTH AND BAIL IF TOO DEEP
205              
206             # this is highly dependent on OS platform, and also whether or not we are
207             # listing a root directory, which makes optimizations harder ( / or C:\ )
208             # *note - $SL comes from File::Util::Definitions
209              
210 79         62 my $trailing_dirs;
211              
212 79 50       98 if ( $opts->{_recursion}{_isroot} )
213             {
214 0         0 ( $trailing_dirs ) =
215             $dir =~ /^ \Q$opts->{_recursion}{_base}\E (.+) /x;
216             }
217             else
218             {
219 79         438 ( $trailing_dirs ) =
220             $dir =~ /^ \Q$opts->{_recursion}{_base}$SL\E (.+) /x;
221             }
222              
223 79 50       114 if ( $SL eq '/' )
224             {
225 79 100       151 $opts->{_recursion}{_depth} = $trailing_dirs =~ tr/\/// + 1
226             if defined $trailing_dirs;
227             }
228             else
229             {
230 0 0       0 $opts->{_recursion}{_depth} = $trailing_dirs =~ tr/[\\:]// + 1
231             if defined $trailing_dirs;
232             }
233              
234             return( () ) if
235             $opts->{max_depth} &&
236 79 50 33     138 $opts->{_recursion}{_depth} >= $opts->{max_depth};
237              
238             # fail if the shared reference indicates we're to deep
239             return $this->_throw(
240             'abort_depth exceeded' => {
241             meth => 'list_dir',
242             abort_depth => $abort_depth,
243             opts => $opts,
244             dir => $dir,
245             }
246 79 50 33     129 ) if $opts->{_recursion}{_depth} == $abort_depth && $abort_depth != 0;
247              
248             # ACTUAL READING OF THE DIRECTORY
249              
250 79 50       1324 opendir my $dir_fh, $dir
251             or return $this->_throw
252             (
253             'bad opendir' => {
254             dirname => $dir,
255             exception => $!,
256             opts => $opts,
257             }
258             );
259              
260             # LEGACY_MATCHING
261              
262             # this form of matching is deprecated and is not robust. backward compat
263             # is preserved here, but it will soon no longer even be mentioned in the
264             # documentation, becoming useful only to the legacy code that relies on it
265              
266             # primitive pattern matching at top level only, applied to both files & dirs
267             @dir_contents = defined $opts->{pattern}
268 79 50       732 ? grep /$opts->{pattern}/, readdir $dir_fh
269             : readdir $dir_fh;
270              
271             # primitive pattern matching applied recursively to only files; if it were
272             # applied to both files AND dirs, recursion would often break unexpectedly
273             # for users unaware that they couldn't recurse into dirs that didn't match
274             # the pattern they probably intended only for files
275             @dir_contents = defined $opts->{rpattern}
276 79 100       291 ? grep { -d $dir . SL . $_ || /$opts->{rpattern}/ } @dir_contents
  48 100       530  
277             : @dir_contents;
278              
279 79 50       471 closedir $dir_fh
280             or return $this->_throw(
281             'close dir' => {
282             dir => $dir,
283             exception => $!,
284             opts => $opts,
285             }
286             );
287              
288             # get rid of "." and ".." if they are unwanted, and try to do it as fast
289             # as possible for large directories; Devel::NYTprof says this is faster
290 79 100       117 if ( $opts->{no_fsdots} )
291             {
292 73 50 33     139 if ( $dir_contents[0] eq '.' && $dir_contents[1] eq '..' )
293             {
294 0         0 @dir_contents = splice @dir_contents, 2;
295             }
296             else
297             {
298 73         69 @dir_contents = grep { !/$FSDOTS/ } @dir_contents;
  542         1090  
299             }
300             }
301              
302             # SEPARATION OF DIRS FROM FILES
303              
304 79 50 33     540 my $dir_base = # << we use this further down
305             ( $dir ne '/' && $dir !~ /^$WINROOT$/ )
306             ? $dir . SL
307             : $dir;
308              
309 79         133 while ( @dir_contents ) # !! don't do: while my $foo = shift !!
310             {
311 456         366 my $dir_entry = shift @dir_contents;
312              
313 456 100 66     4185 if ( -d $dir_base . $dir_entry && !-l $dir_base . $dir_entry )
314             {
315 60         144 push @$subdirs, $dir_entry
316             }
317 396         720 else { push @$files, $dir_entry }
318             }
319              
320             # ADVANCED MATCHING
321 79 100       138 if ( !defined $opts->{_matching} )
322             {
323             $opts->{_matching} =
324             $opts->{files_match} ||
325             $opts->{dirs_match} ||
326             $opts->{parent_matches} ||
327 31   100     147 $opts->{path_matches} || 0;
328              
329 31         50 $opts->{_matching} = !!$opts->{_matching};
330             }
331              
332 79 100       114 if ( $opts->{_matching} )
333             {
334 51         81 ( $subdirs, $files ) =
335             _list_dir_matching( $opts, $dir, $subdirs, $files );
336             }
337              
338             # prepend full path information to each file name if paths were
339             # requested, or if we are recursing. Then separate the directories
340             # and files off into @dirs and @itmes, respectively
341 79 100 66     183 if ( $opts->{recurse} || $opts->{with_paths} )
342             {
343 73         81 @$subdirs = map { $dir_base . $_ } @$subdirs;
  48         110  
344 73         82 @$files = map { $dir_base . $_ } @$files;
  162         231  
345             }
346              
347             # CALLBACKS (HIGHER ORDER FUNCTIONS)
348              
349             # here below is where we invoke the callbacks on dirs, files, or both.
350              
351 79 100       133 if ( my $cb = $opts->{callback} ) {
352              
353 5 50       14 $this->throw( qq(callback "$cb" not a coderef), $opts )
354             unless ref $cb eq 'CODE';
355              
356 5         16 $cb->( $dir, \@$subdirs, \@$files, $opts->{_recursion}{_depth} );
357             }
358              
359 79 50       128 if ( my $cb = $opts->{d_callback} ) {
360              
361 0 0       0 $this->throw( qq(d_callback "$cb" not a coderef), $opts )
362             unless ref $cb eq 'CODE';
363              
364 0         0 $cb->( $dir, \@$subdirs, $opts->{_recursion}{_depth} );
365             }
366              
367 79 50       99 if ( my $cb = $opts->{f_callback} ) {
368              
369 0 0       0 $this->throw( qq(f_callback "$cb" not a coderef), $opts )
370             unless ref $cb eq 'CODE';
371              
372 0         0 $cb->( $dir, \@$files, $opts->{_recursion}{_depth} );
373             }
374              
375             # RECURSION
376 79 100 33     194 if
      66        
377             (
378             $opts->{recurse} && !
379             (
380             $opts->{max_depth} && # don't recurse if we will then be at max depth
381             $opts->{_recursion}{_depth} == $opts->{max_depth} - 1
382             )
383             ) {
384             # recurse into all subdirs
385 25         29 for my $subdir ( @$subdirs ) {
386              
387             # certain opts need to be defined, overridden, added, or removed
388             # completely before recursing. That's why we redefine everything
389             # here below, eliminating potential user-error where incompatible
390             # options would otherwise break recursion and/or cause confusion
391              
392             my $recurse_opts = {
393             as_ref => 1,
394             with_paths => 1,
395             no_fsdots => 1,
396             abort_depth => $abort_depth,
397             max_depth => $opts->{max_depth},
398             onfail => $opts->{onfail},
399             diag => $opts->{diag},
400             rpattern => $opts->{rpattern},
401             files_match => $opts->{files_match},
402             dirs_match => $opts->{dirs_match},
403             parent_matches => $opts->{parent_matches},
404             path_matches => $opts->{path_matches},
405             callback => $opts->{callback},
406             d_callback => $opts->{d_callback},
407             f_callback => $opts->{f_callback},
408             _matching => $opts->{_matching},
409             _patterns => $opts->{_patterns} || {},
410             _recursion => $opts->{_recursion},
411 48   100     358 _recursing => 1,
412             };
413              
414 48         104 my ( $dirs_ref, $files_ref ) =
415             $this->list_dir( $subdir => \$recurse_opts );
416              
417 48 50 33     179 push @$subdirs, @$dirs_ref
418             if ref $dirs_ref && ref $dirs_ref eq 'ARRAY';
419              
420 48 50 33     246 push @$files, @$files_ref
421             if ref $files_ref && ref $files_ref eq 'ARRAY';
422             }
423             }
424              
425             # FINAL PREPARATIONS before returning results
426              
427 79 100 66     179 if (
      66        
428             !$opts->{_recursing} &&
429             (
430             $opts->{path_matches} || $opts->{parent_matches}
431             )
432             ) {
433 10         15 @$subdirs = _list_dir_lastround_dirmatch( $opts, $subdirs );
434             }
435              
436             # cosmetic formatting for directories/
437 79 50       103 if ( $opts->{sl_after_dirs} ) {
438              
439             # append directory separator to everything but the "dots"
440 0         0 $_ .= SL for grep { !/$FSDOTS/ } @$subdirs;
  0         0  
441             }
442              
443             # sorting
444 79 50       89 if ( $opts->{ignore_case} ) {
445              
446 0         0 $subdirs = [ sort { uc $a cmp uc $b } @$subdirs ];
  0         0  
447 0         0 $files = [ sort { uc $a cmp uc $b } @$files ];
  0         0  
448             }
449             else {
450              
451 79         135 $subdirs = [ sort { $a cmp $b } @$subdirs ];
  28         61  
452 79         124 $files = [ sort { $a cmp $b } @$files ];
  589         414  
453             }
454              
455             # RETURN based on selected opts
456              
457             return scalar @$subdirs
458 79 50 66     143 if $opts->{dirs_only} && $opts->{count_only};
459              
460             return scalar @$files
461 79 50 66     126 if $opts->{files_only} && $opts->{count_only};
462              
463             return scalar @$subdirs + scalar @$files
464 79 50       95 if $opts->{count_only};
465              
466             return $subdirs, $files
467 79 100       201 if $opts->{as_ref};
468              
469 31 50       44 $subdirs = [ $subdirs ] if $opts->{dirs_as_ref};
470 31 50       41 $files = [ $files ] if $opts->{files_as_ref};
471              
472 31 100       55 return @$subdirs if $opts->{dirs_only};
473 28 100       139 return @$files if $opts->{files_only};
474              
475 10         76 return @$subdirs, @$files;
476             }
477              
478              
479             # --------------------------------------------------------
480             # File::Util::_list_dir_matching()
481             # --------------------------------------------------------
482             sub _list_dir_matching {
483 51     51   57 my ( $opts, $path, $dirs, $files ) = @_;
484              
485             # COLLECT PATTERN(S) TO BE APPLIED
486              
487             { # memo-ize these patterns
488              
489             # FILES AND
490 51         29 $opts->{_patterns}->{_files_match_and} =
491             [ _gather_and_patterns( $opts->{files_match} ) ]
492 51 100       103 unless defined $opts->{_patterns}->{_files_match_and};
493              
494             # FILES OR
495             $opts->{_patterns}->{_files_match_or} =
496             [ _gather_or_patterns( $opts->{files_match} ) ]
497 51 100       82 unless defined $opts->{_patterns}->{_files_match_or};
498              
499             # DIRS AND
500             $opts->{_patterns}->{_dirs_match_and} =
501             [ _gather_and_patterns( $opts->{dirs_match} ) ]
502 51 100       96 unless defined $opts->{_patterns}->{_dirs_match_and};
503              
504             # DIRS OR
505             $opts->{_patterns}->{_dirs_match_or} =
506             [ _gather_or_patterns( $opts->{dirs_match} ) ]
507 51 100       91 unless defined $opts->{_patterns}->{_dirs_match_or};
508              
509             # PARENT AND
510             $opts->{_patterns}->{_parent_matches_and} =
511             [ _gather_and_patterns( $opts->{parent_matches} ) ]
512 51 100       82 unless defined $opts->{_patterns}->{_parent_matches_and};
513              
514             # PARENT OR
515             $opts->{_patterns}->{_parent_matches_or} =
516             [ _gather_or_patterns( $opts->{parent_matches} ) ]
517 51 100       81 unless defined $opts->{_patterns}->{_parent_matches_or};
518              
519             # PATH AND
520             $opts->{_patterns}->{_path_matches_and} =
521             [ _gather_and_patterns( $opts->{path_matches} ) ]
522 51 100       85 unless defined $opts->{_patterns}->{_path_matches_and};
523              
524             # PATH OR
525             $opts->{_patterns}->{_path_matches_or} =
526             [ _gather_or_patterns( $opts->{path_matches} ) ]
527 51 100       82 unless defined $opts->{_patterns}->{_path_matches_or};
528             }
529              
530             # FILE MATCHING
531              
532 51         40 for my $pattern ( @{ $opts->{_patterns}->{_files_match_and} } ) {
  51         85  
533              
534 39         40 @$files = grep { /$pattern/ } @$files;
  151         292  
535             }
536              
537             @$files = _match_and( $opts->{_patterns}->{_files_match_and}, $files )
538 51 100       34 if @{ $opts->{_patterns}->{_files_match_and} };
  51         101  
539              
540             @$files = _match_or( $opts->{_patterns}->{_files_match_or}, $files )
541 51 100       65 if @{ $opts->{_patterns}->{_files_match_or} };
  51         83  
542              
543             # DIRECTORY MATCHING
544              
545             @$dirs = _match_and( $opts->{_patterns}->{_dirs_match_and}, $dirs )
546 51 100       27 if @{ $opts->{_patterns}->{_dirs_match_and} };
  51         79  
547              
548             @$dirs = _match_or( $opts->{_patterns}->{_dirs_match_or}, $dirs )
549 51 100       27 if @{ $opts->{_patterns}->{_dirs_match_or} };
  51         74  
550              
551             # FILE &'ed DIRECTORY MATCHING
552              
553 51 100 66     101 if ( $opts->{files_match} && $opts->{dirs_match} ) {
554              
555             $files = [ ]
556             unless _match_and
557             (
558             $opts->{_patterns}->{_dirs_match_and},
559 9 100       12 [ strip_path( $path ) ]
560             );
561             }
562              
563             # MATCHING FILES BY PARENT DIR
564              
565 51 100       69 if ( $opts->{parent_matches} ) {
566              
567 15 100       8 if ( @{ $opts->{_patterns}->{_parent_matches_and} } ) {
  15 50       23  
568              
569             $files = [ ]
570             unless _match_and
571             (
572             $opts->{_patterns}->{_parent_matches_and},
573 12 100       18 [ strip_path( $path ) ]
574             );
575             }
576 3         7 elsif ( @{ $opts->{_patterns}->{_parent_matches_or} } ) {
577              
578             $files = [ ]
579             unless _match_or
580             (
581             $opts->{_patterns}->{_parent_matches_or},
582 3 50       4 [ strip_path( $path ) ]
583             );
584             }
585             }
586              
587             # MATCHING FILES BY PATH
588              
589 51 100       67 if ( $opts->{path_matches} ) {
590              
591 15 100       12 if ( @{ $opts->{_patterns}->{_path_matches_and} } ) {
  15 50       19  
592              
593             $files = [ ]
594             unless _match_and
595             (
596 9 100       15 $opts->{_patterns}->{_path_matches_and}, [ $path ]
597             );
598             }
599 6         8 elsif ( @{ $opts->{_patterns}->{_path_matches_or} } ) {
600              
601             $files = [ ]
602             unless _match_or
603             (
604 6 100       14 $opts->{_patterns}->{_path_matches_or}, [ $path ]
605             );
606             }
607             }
608              
609 51         71 return ( $dirs, $files );
610             }
611              
612              
613             # --------------------------------------------------------
614             # File::Util::_list_dir_lastround_dirmatch()
615             # --------------------------------------------------------
616             sub _list_dir_lastround_dirmatch {
617 10     10   8 my ( $opts, $dirs ) = @_;
618              
619 10         7 my @return_dirs;
620              
621             # LAST ROUND MATCHING DIRS BY PARENT DIR
622              
623 10 100       14 if ( $opts->{parent_matches} ) {
624              
625 5         4 my %return_dirs;
626              
627 5 100       6 if ( @{ $opts->{_patterns}->{_parent_matches_and} } ) {
  5 50       7  
628              
629 4         6 for my $qfd_dir ( @$dirs ) {
630              
631 8         9 my ( $root, $in_path ) = atomize_path( $qfd_dir );
632              
633 8 50       19 $in_path = $root . $in_path if $root;
634              
635             $return_dirs{ $in_path } = $in_path
636             if _match_and
637             (
638             $opts->{_patterns}->{_parent_matches_and},
639 8 100       22 [ strip_path( $in_path ) ]
640             );
641             }
642             }
643 1         5 elsif ( @{ $opts->{_patterns}->{_parent_matches_or} } ) {
644              
645 1         2 for my $qfd_dir ( @$dirs ) {
646              
647 2         3 my ( $root, $in_path ) = atomize_path( $qfd_dir );
648              
649 2 50       8 $in_path = $root . $in_path if $root;
650              
651             $return_dirs{ $in_path } = $in_path
652             if _match_or
653             (
654             $opts->{_patterns}->{_parent_matches_or},
655 2 50       4 [ strip_path( $in_path ) ]
656             );
657             }
658             }
659              
660 5         10 push @return_dirs, keys %return_dirs;
661             }
662              
663             # LAST ROUND MATCHING DIRS BY PATH
664              
665 10 100       16 if ( $opts->{path_matches} ) {
666              
667 5         5 my %return_dirs;
668              
669 5 100       3 if ( @{ $opts->{_patterns}->{_path_matches_and} } ) {
  5 50       8  
670              
671 3         4 for my $qfd_dir ( @$dirs ) {
672              
673 6         7 my ( $root, $in_path ) = atomize_path( $qfd_dir );
674              
675 6 50       15 $in_path = $root . $in_path if $root;
676              
677             $return_dirs{ $in_path } = $in_path
678             if _match_and
679             (
680 6 50       11 $opts->{_patterns}->{_path_matches_and}, [ $in_path ]
681             );
682              
683             $return_dirs{ $qfd_dir } = $qfd_dir
684             if _match_and
685             (
686 6 100       12 $opts->{_patterns}->{_path_matches_and}, [ $qfd_dir ]
687             );
688             }
689             }
690 2         4 elsif ( @{ $opts->{_patterns}->{_path_matches_or} } ) {
691              
692 2         3 for my $qfd_dir ( @$dirs ) {
693              
694 4         6 my ( $root, $in_path ) = atomize_path( $qfd_dir );
695              
696 4 50       10 $in_path = $root . $in_path if $root;
697              
698             $return_dirs{ $in_path } = $in_path
699             if _match_or
700             (
701 4 100       9 $opts->{_patterns}->{_path_matches_or}, [ $in_path ]
702             );
703              
704             $return_dirs{ $qfd_dir } = $qfd_dir
705             if _match_or
706             (
707 4 50       5 $opts->{_patterns}->{_path_matches_or}, [ $qfd_dir ]
708             );
709             }
710             }
711              
712 5         13 push @return_dirs, keys %return_dirs;
713             }
714              
715 10         17 return @return_dirs;
716             }
717              
718              
719             # --------------------------------------------------------
720             # File::Util::_gather_and_patterns()
721             # --------------------------------------------------------
722             sub _gather_and_patterns {
723              
724 68     68   66 my $pattern_ref = shift @_;
725              
726             return
727             defined $pattern_ref &&
728             ref $pattern_ref eq 'HASH' &&
729             defined $pattern_ref->{and} &&
730             ref $pattern_ref->{and} eq 'ARRAY'
731 68 100 66     331 ? @{ $pattern_ref->{and} }
  7 100 100     14  
732             : defined $pattern_ref &&
733             ref $pattern_ref eq 'Regexp'
734             ? ( $pattern_ref )
735             : ( );
736             }
737              
738              
739             # --------------------------------------------------------
740             # File::Util::_gather_or_patterns()
741             # --------------------------------------------------------
742             sub _gather_or_patterns {
743              
744 68     68   59 my $pattern_ref = shift @_;
745              
746             return
747             defined $pattern_ref &&
748             ref $pattern_ref eq 'HASH' &&
749             defined $pattern_ref->{or} &&
750             ref $pattern_ref->{or} eq 'ARRAY'
751 68 100 66     222 ? @{ $pattern_ref->{or} }
  6         13  
752             : ( );
753             }
754              
755              
756             # --------------------------------------------------------
757             # File::Util::_match_and()
758             # --------------------------------------------------------
759             sub _match_and {
760              
761 83     83   60 my ( $patterns, $items ) = @_;
762              
763 83         69 for my $pattern ( @$patterns ) {
764              
765 108         90 @$items = grep { /$pattern/ } @$items;
  84         259  
766             }
767              
768 83         142 return @$items;
769             }
770              
771              
772             # --------------------------------------------------------
773             # File::Util::_match_or()
774             # --------------------------------------------------------
775             sub _match_or {
776              
777 28     28   24 my ( $patterns, $items ) = @_;
778              
779 28         16 my $or_pattern;
780              
781 28         24 for my $pattern ( @$patterns ) {
782              
783 56 100       833 $or_pattern = $or_pattern
784             ? qr/$pattern|$or_pattern/
785             : $pattern;
786             }
787              
788 28         28 @$items = grep { /$or_pattern/ } @$items;
  39         135  
789              
790 28         75 return @$items;
791             }
792              
793              
794             # --------------------------------------------------------
795             # File::Util::_as_tree()
796             # --------------------------------------------------------
797             sub _as_tree {
798 0     0   0 my $this = shift @_;
799 0         0 my $opts = $this->_remove_opts( \@_ );
800 0         0 my $dir = shift @_;
801 0         0 my $tree = {};
802              
803             my $treeify = sub
804             {
805 0     0   0 my ( $dirname, $subdirs, $files ) = @_;
806              
807             # find root of tree (if path was absolute)
808 0         0 my ( $root, $branch, $leaf ) = atomize_path( $dirname );
809              
810 0         0 my @path_dirs = split /$DIRSPLIT/o, $branch;
811              
812             # find place in tree
813 0         0 my @lineage = ( @path_dirs, $leaf );
814              
815 0 0       0 unshift @lineage, $root if $root;
816              
817 0         0 my $ancestory = $tree;
818              
819             # recursively create hashref tree
820              
821 0         0 for ( my $i = 0; $i < @lineage; $i++ )
822             {
823 0         0 my $self = $lineage[ $i ];
824              
825 0 0       0 my $parent = $i > 0 ? $i - 1 : undef;
826              
827 0 0       0 if ( defined $parent )
828             {
829 0         0 my @predecessors = @lineage[ 0 .. $parent ];
830              
831             # for abs paths on *nix
832 0 0 0     0 shift @predecessors if
833             @predecessors > 1 &&
834             $predecessors[0] eq SL;
835              
836 0         0 $parent = join SL, @predecessors;
837              
838 0 0 0     0 $parent = $root . $parent if $root && $parent ne $root;
839             }
840              
841 0   0     0 $ancestory->{ $self } ||= { };
842              
843 0 0 0     0 unless (
      0        
844             exists $opts->{dirmeta} &&
845             defined $opts->{dirmeta} &&
846             $opts->{dirmeta} == 0
847             ) {
848 0         0 $ancestory->{ $self }{ _DIR_PARENT_ } = $parent;
849              
850             $ancestory->{ $self }{ _DIR_SELF_ } =
851 0 0       0 !defined $parent
    0          
852             ? $self
853             : $parent eq $root
854             ? $parent . $self
855             : $parent . SL . $self;
856             }
857              
858 0         0 $ancestory = $ancestory->{ $self };
859             }
860              
861             # the next two loops populate the tree
862              
863 0         0 my $parent = $ancestory;
864              
865 0         0 for my $subdir ( @$subdirs )
866             {
867 0   0     0 $parent->{ strip_path( $subdir ) } ||= { };
868             }
869              
870 0         0 for my $file ( @$files )
871             {
872 0         0 $parent->{ strip_path( $file ) } = $file;
873             }
874 0         0 };
875              
876 0         0 $opts->{callback} = $treeify;
877              
878 0         0 delete $opts->{as_tree};
879              
880 0         0 $this->list_dir( $dir => $opts );
881              
882 0         0 return $tree;
883             }
884              
885              
886             # --------------------------------------------------------
887             # File::Util::_dropdots()
888             # --------------------------------------------------------
889             sub _dropdots {
890 1     1   2 my $this = shift @_;
891 1         3 my $opts = $this->_remove_opts( \@_ );
892 1         1 my @copy = @_;
893 1         2 my @out = ();
894 1         2 my @dots = ();
895 1         1 my $gottadot = 0;
896              
897 1         2 while ( @copy ) {
898              
899 3 50       4 if ( $gottadot == 2 ) { push @out, @copy and last }
  1 100       3  
900              
901 2         3 my $dir_item = shift @copy;
902              
903 2 50       8 if ( $dir_item =~ /$FSDOTS/ ) {
904              
905 2         1 ++$gottadot;
906              
907 2         2 push @dots, $dir_item;
908              
909 2         4 next;
910             }
911              
912 0         0 push @out, $dir_item;
913             }
914              
915 1 50       2 return( \@dots, @out ) if $opts->{save_dots};
916              
917 1         4 return @out;
918             }
919              
920              
921             # --------------------------------------------------------
922             # File::Util::load_file()
923             # --------------------------------------------------------
924             sub load_file {
925 56     56 1 1145 my $this = shift @_;
926 56         109 my $in = $this->_parse_in( @_ );
927 56         59 my @dirs = ();
928 56         38 my $blocksize = 1024; # 1.24 kb
929 56         41 my $fh_passed = 0;
930 56         39 my $fh;
931              
932 56         72 my ( $file, $root, $path, $clean_name, $content, $mode ) =
933             ( '', '', '', '', '', 'read' );
934              
935             # all of this logic branching is to cover the possibilities in the way
936             # this method could have been called. we try to support as many methods
937             # as make at least some amount of sense
938              
939             $in->{read_limit} = defined $in->{read_limit}
940             ? $in->{read_limit}
941             : defined $in->{readlimit}
942             ? $in->{readlimit}
943 56 50       121 : undef;
    50          
944              
945 56         50 delete $in->{readlimit};
946 56 50       104 delete $in->{read_limit} if !defined $in->{read_limit};
947              
948             my $read_limit =
949             defined $in->{read_limit}
950             ? $in->{read_limit}
951             : defined $this->{opts}->{read_limit}
952             ? $this->{opts}->{read_limit}
953 56 0       113 : defined $READ_LIMIT
    50          
    50          
954             ? $READ_LIMIT
955             : 0;
956              
957 56 50       129 return $this->_throw(
958             'bad read_limit' => { opts => $in, bad => $read_limit }
959             ) if $read_limit =~ /\D/;
960              
961             # support old-school "FH" option, *and* the new, more sensible "file_handle"
962 56 50       118 $in->{FH} = $in->{file_handle} if defined $in->{file_handle};
963              
964 56 50       71 if ( !defined $in->{FH} ) { # unless we were passed a file handle...
965              
966             $file = defined $in->{file}
967             ? $in->{file}
968             : defined $in->{filename}
969             ? $in->{filename}
970 56 50 50     149 : shift @_ || '';
    50          
971              
972 56 50       77 return $this->_throw(
973             'no input',
974             {
975             meth => 'load_file',
976             missing => 'a file name or file handle reference',
977             opts => $in,
978             }
979             ) unless length $file;
980              
981 56         80 ( $root, $path, $file ) = atomize_path( $file );
982              
983 56         375 @dirs = split /$DIRSPLIT/, $path;
984              
985 56 50       121 unshift @dirs, $root if $root;
986              
987             # cleanup file name - if path is relative, normalize it
988             # - /foo/bar/baz.txt stays as /foo/bar/baz.txt
989             # - foo/bar/baz.txt becomes ./foo/bar/baz.txt
990             # - baz.txt stays as baz.txt
991 56 50 33     109 if ( !length $root && !length $path ) {
992              
993 0         0 $path = '.' . SL;
994             }
995             else { # otherwise path normalized at end
996              
997 56         57 $path .= SL;
998             }
999              
1000             # final clean filename assembled
1001 56         81 $clean_name = $root . $path . $file;
1002             }
1003             else {
1004              
1005             # did we get a filehandle?
1006 0 0       0 if ( ref $in->{FH} eq 'GLOB' ) {
1007              
1008 0         0 $fh_passed++;
1009             }
1010             else {
1011              
1012 0         0 return $this->_throw(
1013             'no input',
1014             {
1015             meth => 'load_file',
1016             missing => 'a true file handle reference (not a string)',
1017             opts => $in,
1018             }
1019             );
1020             }
1021             }
1022              
1023 56 50       82 if ( $fh_passed ) {
1024              
1025 0         0 my $buffer = 0;
1026 0         0 my $bytes_read = 0;
1027 0         0 $fh = $in->{FH};
1028              
1029 0         0 while ( <$fh> ) {
1030              
1031 0 0       0 if ( $buffer < $read_limit ) {
1032              
1033 0         0 $bytes_read = read( $fh, $content, $blocksize );
1034              
1035 0         0 $buffer += $bytes_read;
1036             }
1037             else {
1038              
1039 0         0 return $this->_throw(
1040             'read_limit exceeded',
1041             {
1042             filename => '',
1043             size => qq{[truncated at $bytes_read]},
1044             read_limit => $read_limit,
1045             opts => $in,
1046             }
1047             );
1048             }
1049             }
1050              
1051             # return an array of all lines in the file if the call to this method/
1052             # subroutine asked for an array eg- my @file = load_file('file');
1053             # otherwise, return a scalar value containing all of the file's content
1054             return split /$NL|\r|\n/o, $content
1055 0 0       0 if $in->{as_list};
1056              
1057 0         0 return $content;
1058             }
1059              
1060             # if the file doesn't exist, send back an error
1061 56 50       700 return $this->_throw(
1062             'no such file',
1063             {
1064             filename => $clean_name,
1065             opts => $in,
1066             }
1067             ) unless -e $clean_name;
1068              
1069             # it's good to know beforehand whether or not we have permission to open
1070             # and read from this file allowing us to handle such an exception before
1071             # it handles us.
1072              
1073             # first check the readability of the file's housing dir
1074 56 50       419 return $this->_throw(
1075             'cant dread',
1076             {
1077             filename => $clean_name,
1078             dirname => $root . $path,
1079             opts => $in,
1080             }
1081             ) unless -r $root . $path;
1082              
1083             # now check the readability of the file itself
1084 56 50       390 return $this->_throw(
1085             'cant fread',
1086             {
1087             filename => $clean_name,
1088             dirname => $root . $path,
1089             opts => $in,
1090             }
1091             ) unless -r $clean_name;
1092              
1093             # if the file is a directory it will not be opened
1094 56 50       380 return $this->_throw(
1095             'called open on a dir',
1096             {
1097             filename => $clean_name,
1098             opts => $in,
1099             }
1100             ) if -d $clean_name;
1101              
1102 56         357 my $fsize = -s $clean_name;
1103              
1104 56 50       82 return $this->_throw(
1105             'read_limit exceeded',
1106             {
1107             filename => $clean_name,
1108             size => $fsize,
1109             opts => $in,
1110             read_limit => $read_limit,
1111             }
1112             ) if $fsize > $read_limit;
1113              
1114             # localize the global output record separator so we can slurp it all
1115             # in one quick read. We fail if the filesize exceeds our limit.
1116 56         148 local $/;
1117              
1118             # open the file for reading (note the '<' syntax there) or fail with a
1119             # error message if our attempt to open the file was unsuccessful
1120              
1121             # lock file before I/O on platforms that support it
1122 56 50 33     238 if (
      33        
1123             $in->{no_lock} ||
1124             $this->{opts}->{no_lock} ||
1125             !$this->use_flock()
1126             ) {
1127              
1128             # if you use the 'no_lock' option you are probably inefficient
1129 0 0       0 open $fh, '<', $clean_name or
1130             return $this->_throw(
1131             'bad open',
1132             {
1133             filename => $clean_name,
1134             mode => $mode,
1135             exception => $!,
1136             cmd => qq(< $clean_name),
1137             opts => $in,
1138             }
1139             );
1140             }
1141             else {
1142 56 50       1251 open $fh, '<', $clean_name or
1143             return $this->_throw(
1144             'bad open',
1145             {
1146             filename => $clean_name,
1147             mode => $mode,
1148             exception => $!,
1149             cmd => qq(< $clean_name),
1150             opts => $in,
1151             }
1152             );
1153              
1154 56         103 $this->_seize( $clean_name, $fh, $in );
1155             }
1156              
1157             # call binmode on binary files for portability across platforms such
1158             # as MS flavor OS family
1159              
1160 56 100       1323 binmode $fh if -B $clean_name;
1161              
1162             # call binmode on the filehandle if it was requested or UTF-8
1163 56 100       174 if ( $in->{binmode} )
1164             {
1165 4 50       9 if ( lc $in->{binmode} eq 'utf8' )
    0          
1166             {
1167 4 50       8 if ( $HAVE_UU )
1168             {
1169 4     1   66 binmode $fh, ':unix:encoding(UTF-8)';
  1         8  
  1         1  
  1         7  
1170             }
1171             else
1172             {
1173 0         0 close $fh;
1174              
1175 0         0 return $this->_throw( 'no unicode' => $in );
1176             }
1177             }
1178             elsif ( $in->{binmode} == 1 )
1179             {
1180 0         0 binmode $fh;
1181             }
1182             else
1183             {
1184             binmode $fh, $in->{binmode} # apply user-specified IO layer(s)
1185 0         0 }
1186             }
1187              
1188             # assign the content of the file to this lexically scoped scalar variable
1189             # (memory for *that* variable will be freed when execution leaves this
1190             # method / sub
1191              
1192 56         9015 $content = <$fh>;
1193              
1194 56 50 33     186 if ( $in->{no_lock} || $this->{opts}->{no_lock} ) {
1195              
1196             # if execution gets here, you used the 'no_lock' option, and you
1197             # are probably inefficient
1198              
1199 0 0       0 close $fh or return $this->_throw(
1200             'bad close',
1201             {
1202             filename => $clean_name,
1203             mode => $mode,
1204             exception => $!,
1205             opts => $in,
1206             }
1207             );
1208             }
1209             else {
1210             # release shadow-ed locks on the file
1211 56         95 $this->_release( $fh, $in );
1212              
1213 56 50       240 close $fh or return $this->_throw(
1214             'bad close',
1215             {
1216             filename => $clean_name,
1217             mode => $mode,
1218             exception => $!,
1219             opts => $in,
1220             }
1221             );
1222             }
1223              
1224             # return an array of all lines in the file if the call to this method/
1225             # subroutine asked for an array eg- my @file = load_file('file');
1226             # otherwise, return a scalar value containing all of the file's content
1227             return split /$NL|\r|\n/o, $content
1228 56 50       93 if $in->{as_lines};
1229              
1230 56         374 return $content;
1231             }
1232              
1233              
1234             # --------------------------------------------------------
1235             # File::Util::write_file()
1236             # --------------------------------------------------------
1237             sub write_file {
1238 73     73 1 2521 my $this = shift @_;
1239 73         145 my $in = $this->_parse_in( @_ );
1240 73         63 my $content = '';
1241 73         56 my $raw_name = '';
1242 73         53 my $file = '';
1243 73   100     202 my $mode = $in->{mode} || 'write';
1244 73   50     174 my $bitmask = $in->{bitmask} || oct 777;
1245 73         49 my $write_fh; # will be the lexical file handle local to this block
1246 73         100 my ( $root, $path, $clean_name, @dirs ) =
1247             ( '', '', '', () );
1248              
1249             # get name of file when passed in as a name/value pair...
1250              
1251             $file =
1252             exists $in->{filename} &&
1253             defined $in->{filename} &&
1254             length $in->{filename}
1255             ? $in->{filename}
1256             : exists $in->{file} &&
1257             defined $in->{file} &&
1258             length $in->{file}
1259             ? $in->{file}
1260 73 100 66     358 : '';
    100 66        
1261              
1262             # ...or fall back to support of two-argument form of invocation
1263              
1264 73 50       74 my $maybe_file = shift @_; $maybe_file = '' if !defined $maybe_file;
  73         97  
1265 73 100       55 my $maybe_content = shift @_; $maybe_content = '' if !defined $maybe_content;
  73         92  
1266              
1267 73 100 100     205 $file = $maybe_file if !ref $maybe_file && $file eq '';
1268             $content =
1269             !ref $maybe_content &&
1270             !exists $in->{content}
1271             ? $maybe_content
1272 73 100 66     214 : $in->{content};
1273              
1274 73         420 my ( $winroot ) = $file =~ /^($WINROOT)/;
1275              
1276 73         206 $file =~ s/^($WINROOT)//;
1277 73         642 $file =~ s/$DIRSPLIT{2,}/$SL/o;
1278 73 50       621 $file =~ s/$DIRSPLIT+$//o unless $file eq SL;
1279 73 50       115 $file = $winroot . $file if $winroot;
1280              
1281 73         59 $raw_name = $file; # preserve original filename input before line below:
1282              
1283 73         104 ( $root, $path, $file ) = atomize_path( $file );
1284              
1285 73 50       138 $mode = 'trunc' if $mode eq 'truncate';
1286 73 100       101 $content = '' if $mode eq 'trunc';
1287              
1288             # if the call to this method didn't include a filename to which the caller
1289             # wants us to write, then complain about it
1290 73 50       101 return $this->_throw(
1291             'no input' => {
1292             meth => 'write_file',
1293             missing => 'a file name to create, write, or append',
1294             opts => $in,
1295             }
1296             ) unless length $file;
1297              
1298             # if the call to this method didn't include any data which the caller
1299             # wants us to write or append to the file, then complain about it
1300             return $this->_throw(
1301             'no input' => {
1302             meth => 'write_file',
1303             missing => 'the content you want to write or append',
1304             opts => $in,
1305             }
1306             ) if (
1307             ( !defined $content ||
1308             length $content == 0 )
1309             &&
1310             $mode ne 'trunc'
1311             &&
1312             !$EMPTY_WRITES_OK
1313             &&
1314             !$in->{empty_writes_OK}
1315             &&
1316             !$in->{empty_writes_ok}
1317 73 50 66     418 );
      100        
      66        
      66        
      33        
1318              
1319             # check if file already exists in the form of a directory
1320 73 50       971 return $this->_throw(
1321             'cant write_file on a dir' => {
1322             filename => $raw_name,
1323             opts => $in,
1324             }
1325             ) if -d $raw_name;
1326              
1327             # determine existance of the file path, make directory(ies) for the
1328             # path if the full directory path doesn't exist
1329 73         491 @dirs = split /$DIRSPLIT/, $path;
1330              
1331             # if prospective file name has illegal chars then complain
1332 73         123 foreach ( @dirs ) {
1333              
1334 232 50       282 return $this->_throw(
1335             'bad chars' => {
1336             string => $_,
1337             purpose => 'the name of a file or directory',
1338             opts => $in,
1339             }
1340             ) if !$this->valid_filename( $_ );
1341             }
1342              
1343             # do this AFTER the above check!!
1344 73 50       152 unshift @dirs, $root if $root;
1345              
1346             # make sure that open mode is a valid mode
1347 73 50 100     176 unless ( $mode eq 'write' || $mode eq 'append' || $mode eq 'trunc' ) {
      66        
1348              
1349 0         0 return $this->_throw(
1350             'bad openmode popen' => {
1351             meth => 'write_file',
1352             filename => $raw_name,
1353             badmode => $mode,
1354             opts => $in,
1355             }
1356             )
1357             }
1358              
1359             # cleanup file name - if path is relative, normalize it
1360             # - /foo/bar/baz.txt stays as /foo/bar/baz.txt
1361             # - foo/bar/baz.txt becomes ./foo/bar/baz.txt
1362             # - baz.txt stays as baz.txt
1363 73 50 33     142 if ( !length $root && !length $path ) {
1364              
1365 0         0 $path = '.' . SL;
1366             }
1367             else { # otherwise path normalized at end
1368              
1369 73         75 $path .= SL;
1370             }
1371              
1372             # final clean filename assembled
1373 73         89 $clean_name = $root . $path . $file;
1374              
1375             # create path preceding file if path doesn't exist
1376 73 50       663 if ( !-e $root . $path ) {
1377              
1378 0         0 my $make_dir_ok = 1;
1379              
1380             my $make_dir_return = $this->make_dir(
1381             $root . $path,
1382             exists $in->{dbitmask} &&
1383             defined $in->{dbitmask}
1384             ? $in->{dbitmask}
1385             : oct 777,
1386             {
1387             diag => $in->{diag},
1388             onfail => sub {
1389 0     0   0 my ( $err, $trace ) = @_;
1390              
1391             return $in->{onfail}
1392             if ref $in->{onfail} &&
1393 0 0 0     0 ref $in->{onfail} eq 'CODE';
1394              
1395 0         0 $make_dir_ok = 0;
1396              
1397 0         0 return $err . $trace;
1398             }
1399             }
1400 0 0 0     0 );
1401              
1402 0 0       0 die $make_dir_return unless $make_dir_ok;
1403             }
1404              
1405             # if file already exists, check if we can write to it
1406 73 100       416 if ( -e $clean_name ) {
1407              
1408 22 50       147 return $this->_throw(
1409             'cant fwrite' => {
1410             filename => $clean_name,
1411             dirname => $root . $path,
1412             opts => $in,
1413             }
1414             ) unless -w $clean_name;
1415             }
1416             else {
1417              
1418             # if file doesn't exist, see if we can create it
1419 51 50       365 return $this->_throw(
1420             'cant fcreate' => {
1421             filename => $clean_name,
1422             dirname => $root . $path,
1423             opts => $in,
1424             }
1425             ) unless -w $root . $path;
1426             }
1427              
1428             # if you use the no_lock option, please consider the risks
1429              
1430 73 50 33     241 if ( $in->{no_lock} || !$USE_FLOCK ) {
1431              
1432             # only non-existent files get bitmask arguments
1433 0 0       0 if ( -e $clean_name )
1434             {
1435             # you can't use UTF8 'mode' on system IO, so if a user requests
1436             # UTF8, we have to use PerlIO
1437 0 0 0     0 if ( $in->{binmode} && lc $in->{binmode} eq 'utf8' )
1438             {
1439             open
1440             $write_fh,
1441 0 0       0 $$MODES{popen}{ $mode },
1442             $clean_name
1443             or return $this->_throw(
1444             'bad open' => {
1445             filename => $clean_name,
1446             mode => $mode,
1447             opts => $in,
1448             exception => $!,
1449             cmd => $mode . $clean_name,
1450             }
1451             );
1452             }
1453             else
1454             {
1455             sysopen
1456             $write_fh,
1457             $clean_name,
1458 0 0       0 $$MODES{sysopen}{ $mode }
1459             or return $this->_throw(
1460             'bad open' => {
1461             filename => $clean_name,
1462             mode => $mode,
1463             opts => $in,
1464             exception => $!,
1465             cmd => qq($clean_name, $$MODES{sysopen}{ $mode }),
1466             }
1467             );
1468             }
1469             }
1470             else
1471             {
1472             sysopen
1473             $write_fh,
1474             $clean_name,
1475 0 0       0 $$MODES{sysopen}{ $mode },
1476             $bitmask
1477             or return $this->_throw(
1478             'bad open' => {
1479             filename => $clean_name,
1480             mode => $mode,
1481             exception => $!,
1482             cmd => qq($clean_name, $$MODES{sysopen}{$mode}, $bitmask),
1483             opts => $in,
1484             }
1485             );
1486             }
1487             }
1488             else
1489             {
1490             # open read-only first to safely check if we can get a lock.
1491 73 100       408 if ( -e $clean_name )
1492             {
1493 22 50       441 open $write_fh, '<', $clean_name
1494             or return $this->_throw(
1495             'bad open' => {
1496             filename => $clean_name,
1497             mode => 'read',
1498             exception => $!,
1499             cmd => $mode . $clean_name,
1500             opts => $in,
1501             }
1502             );
1503              
1504             # lock file before I/O on platforms that support it
1505 22         44 my $lockstat = $this->_seize( $clean_name, $write_fh, $in );
1506              
1507 22 50       34 return unless $lockstat;
1508              
1509             # you can't use UTF8 'mode' on system IO, so if a user requests
1510             # UTF8, we have to use PerlIO
1511 22 100 66     56 if ( $in->{binmode} && lc $in->{binmode} eq 'utf8' )
1512             {
1513             open
1514             $write_fh,
1515 2 50       72 $$MODES{popen}{ $mode },
1516             $clean_name
1517             or return $this->_throw(
1518             'bad open' => {
1519             filename => $clean_name,
1520             mode => $mode,
1521             opts => $in,
1522             exception => $!,
1523             cmd => $mode . $clean_name,
1524             }
1525             );
1526             }
1527             else
1528             {
1529             sysopen
1530             $write_fh,
1531             $clean_name,
1532 20 50       442 $$MODES{sysopen}{ $mode }
1533             or return $this->_throw(
1534             'bad open' => {
1535             filename => $clean_name,
1536             mode => $mode,
1537             opts => $in,
1538             exception => $!,
1539             cmd => qq($clean_name, $$MODES{sysopen}{ $mode }),
1540             }
1541             );
1542             }
1543             }
1544             else { # only non-existent files get bitmask arguments
1545             # ...unless doing utf8 business, in which case it's irrelevant
1546              
1547             # you can't use UTF8 'mode' on system IO, so if a user requests
1548             # UTF8, we have to use PerlIO
1549 51 50 33     107 if ( $in->{binmode} && lc $in->{binmode} eq 'utf8' )
1550             {
1551             open
1552             $write_fh,
1553 0 0       0 $$MODES{popen}{ $mode },
1554             $clean_name
1555             or return $this->_throw(
1556             'bad open' => {
1557             filename => $clean_name,
1558             mode => $mode,
1559             opts => $in,
1560             exception => $!,
1561             cmd => $mode . $clean_name,
1562             }
1563             );
1564             }
1565             else
1566             {
1567             sysopen
1568             $write_fh,
1569             $clean_name,
1570 51 50       2337 $$MODES{sysopen}{ $mode },
1571             $bitmask
1572             or return $this->_throw(
1573             'bad open' => {
1574             filename => $clean_name,
1575             mode => $mode,
1576             opts => $in,
1577             exception => $!,
1578             cmd => qq($clean_name, $$MODES{sysopen}{$mode}, $bitmask),
1579             }
1580             );
1581             }
1582              
1583             # lock file before I/O on platforms that support it
1584 51         125 my $lockstat = $this->_seize( $clean_name, $write_fh, $in );
1585              
1586 51 50       78 return unless $lockstat;
1587             }
1588              
1589             # now truncate
1590 73 100       114 if ( $mode ne 'append' ) {
1591              
1592 65 50       1021 truncate( $write_fh, 0 ) or return $this->_throw(
1593             'bad systrunc' => {
1594             filename => $clean_name,
1595             exception => $!,
1596             opts => $in,
1597             }
1598             );
1599             }
1600             }
1601              
1602 73 100       113 if ( $in->{binmode} )
1603             {
1604 2 50       6 if ( lc $in->{binmode} eq 'utf8' )
    0          
1605             {
1606 2 50       3 if ( $HAVE_UU )
1607             {
1608 2         14 binmode $write_fh, ':unix:encoding(UTF-8)';
1609              
1610 2         71 print $write_fh $content; # utf8 filehandles use PerlIO
1611             }
1612             else
1613             {
1614 0         0 close $write_fh;
1615              
1616 0         0 return $this->_throw( 'no unicode' => $in );
1617             }
1618             }
1619             elsif ( $in->{binmode} == 1 )
1620             {
1621 0         0 binmode $write_fh;
1622              
1623 0         0 syswrite( $write_fh, $content );
1624             }
1625             else
1626             {
1627 0         0 binmode $write_fh, $in->{binmode}; # apply user-specified IO layer(s)
1628              
1629 0         0 syswrite( $write_fh, $content );
1630             }
1631             }
1632             else
1633             {
1634 71         885 syswrite( $write_fh, $content );
1635             }
1636              
1637             # release lock on the file
1638              
1639 72 50 33     361 $this->_release( $write_fh, $in ) unless $$in{no_lock} || !$USE_FLOCK;
1640              
1641 72 50       380 close $write_fh or
1642             return $this->_throw(
1643             'bad close' => {
1644             filename => $clean_name,
1645             mode => $mode,
1646             exception => $!,
1647             opts => $in,
1648             }
1649             );
1650              
1651 72         329 return 1;
1652             }
1653              
1654              
1655             # --------------------------------------------------------
1656             # File::Util::_seize()
1657             # --------------------------------------------------------
1658             sub _seize {
1659 134     134   188 my ( $this, $file, $fh, $opts ) = @_;
1660              
1661 134 50       192 return $this->_throw( 'no handle passed to _seize.' => $opts )
1662             unless $fh;
1663              
1664 134 50       176 $file = defined $file ? $file : ''; # yes, even files named "0" are allowed
1665              
1666 134 50       180 return $this->_throw( 'no file name passed to _seize.' => $opts )
1667             unless length $file;
1668              
1669             # forget seizing if system can't flock
1670 134 50       166 return $fh if !$CAN_FLOCK;
1671              
1672 134         217 my @policy = @ONLOCKFAIL;
1673              
1674             # seize filehandle, return it if lock is successful
1675              
1676 134         212 while ( @policy ) {
1677              
1678 135         121 my $fh = &{ $_LOCKS->{ shift @policy } }( $this, $file, $fh, $opts );
  135         365  
1679              
1680 135 100 66     417 return $fh if $fh || !scalar @policy;
1681             }
1682              
1683 0         0 return $fh;
1684             }
1685              
1686              
1687             # --------------------------------------------------------
1688             # File::Util::_release()
1689             # --------------------------------------------------------
1690             sub _release {
1691              
1692 128     128   142 my ( $this, $fh, $opts ) = @_;
1693              
1694 128 50 33     451 return $this->_throw(
1695             'not a filehandle.' => { opts => $opts, argtype => ref $fh } )
1696             unless $fh && ref $fh eq 'GLOB';
1697              
1698 128 50       174 if ( $CAN_FLOCK ) { flock $fh, &Fcntl::LOCK_UN }
  128         477  
1699 128         127 return 1;
1700             }
1701              
1702              
1703             # --------------------------------------------------------
1704             # File::Util::valid_filename()
1705             # --------------------------------------------------------
1706             sub valid_filename {
1707 309     309 1 426 my $f = _myargs( @_ );
1708              
1709 309         589 $f =~ s/$WINROOT//; # windows abs paths would throw this off
1710              
1711 309 100       987 $f !~ /$ILLEGAL_CHR/ ? 1 : undef;
1712             }
1713              
1714              
1715             # --------------------------------------------------------
1716             # File::Util::strip_path()
1717             # --------------------------------------------------------
1718             sub strip_path {
1719 123     123 1 233 my $arg = _myargs( @_ );
1720              
1721 123         451 my ( $stripped ) = $arg =~ /^.*$DIRSPLIT(.+)/o;
1722              
1723 123 50       366 return $stripped if defined $stripped;
1724              
1725 0         0 return $arg;
1726             }
1727              
1728              
1729             # --------------------------------------------------------
1730             # File::Util::atomize_path()
1731             # --------------------------------------------------------
1732             sub atomize_path {
1733 172     172 1 11949 my $fqfn = _myargs( @_ );
1734              
1735 172         669 $fqfn =~ m/$ATOMIZER/o;
1736              
1737             # root = $1
1738             # path = $2
1739             # file = $3
1740              
1741 172   100     1395 return( $1||'', $2||'', $3||'' );
      100        
      100        
1742             }
1743              
1744              
1745             # --------------------------------------------------------
1746             # File::Util::split_path()
1747             # --------------------------------------------------------
1748             sub split_path {
1749 0     0 1 0 my $path = _myargs( @_ );
1750              
1751             # find root of tree (if path was absolute)
1752 0         0 my ( $root, $branch, $leaf ) = atomize_path( $path );
1753              
1754 0         0 my @path_dirs = split /$DIRSPLIT/o, $branch;
1755              
1756 0 0       0 unshift @path_dirs, $root if $root;
1757 0 0       0 push @path_dirs, $leaf if $leaf;
1758              
1759 0         0 return @path_dirs;
1760             }
1761              
1762              
1763             # --------------------------------------------------------
1764             # File::Util::line_count()
1765             # --------------------------------------------------------
1766             sub line_count {
1767 2     2 1 3 my( $this, $file ) = @_;
1768 2         3 my $buff = '';
1769 2         2 my $lines = 0;
1770 2         4 my $cmd = '<' . $file;
1771              
1772 2 50       52 open my $fh, '<', $file or
1773             return $this->_throw(
1774             'bad open',
1775             {
1776             'filename' => $file,
1777             'mode' => 'read',
1778             'exception' => $!,
1779             'cmd' => $cmd,
1780             }
1781             );
1782              
1783 2         14 while ( sysread( $fh, $buff, 4096 ) ) {
1784              
1785 1         2 $lines += $buff =~ tr/\n//;
1786              
1787 1         4 $buff = '';
1788             }
1789              
1790 2         9 close $fh;
1791              
1792 2         9 return $lines;
1793             }
1794              
1795              
1796             # --------------------------------------------------------
1797             # File::Util::bitmask()
1798             # --------------------------------------------------------
1799             sub bitmask {
1800 5     5 1 10 my $f = _myargs( @_ );
1801              
1802 5 50       108 defined $f and -e $f ? sprintf('%04o',(stat($f))[2] & oct 777) : undef
    50          
1803             }
1804              
1805              
1806             # --------------------------------------------------------
1807             # File::Util::can_flock()
1808             # --------------------------------------------------------
1809 1     1 1 18 sub can_flock { $CAN_FLOCK }
1810              
1811              
1812             # --------------------------------------------------------
1813             # File::Util::can_utf8()
1814             # --------------------------------------------------------
1815 0     0 1 0 sub can_utf8 { $HAVE_UU }
1816              
1817              
1818             # File::Util::--------------------------------------------
1819             # is_readable(), is_writable() -- was: can_read(), can_write()
1820             # --------------------------------------------------------
1821 1 50   1 1 15 sub is_readable { my $f = _myargs( @_ ); defined $f ? -r $f : undef }
  1         20  
1822 5 50   5 1 1226 sub is_writable { my $f = _myargs( @_ ); defined $f ? -w $f : undef }
  5         80  
1823              
1824              
1825             # --------------------------------------------------------
1826             # File::Util::created()
1827             # --------------------------------------------------------
1828             sub created {
1829 5     5 1 11 my $f = _myargs( @_ );
1830              
1831 5 50       100 defined $f and -e $f ? $^T - ((-M $f) * 60 * 60 * 24) : undef
    50          
1832             }
1833              
1834              
1835             # --------------------------------------------------------
1836             # File::Util::ebcdic()
1837             # --------------------------------------------------------
1838 1     1 1 4 sub ebcdic { $EBCDIC }
1839              
1840              
1841             # --------------------------------------------------------
1842             # File::Util::escape_filename()
1843             # --------------------------------------------------------
1844             sub escape_filename {
1845 2     2 1 447 my( $file, $escape, $also ) = _myargs( @_ );
1846              
1847 2 50       4 return '' unless defined $file;
1848              
1849 2 100       4 $escape = '_' if !defined $escape;
1850              
1851 2 100       3 if ( $also ) { $file =~ s/\Q$also\E/$escape/g }
  1         18  
1852              
1853 2         13 $file =~ s/$ILLEGAL_CHR/$escape/g;
1854 2         9 $file =~ s/$DIRSPLIT/$escape/g;
1855              
1856 2         7 $file
1857             }
1858              
1859              
1860             # --------------------------------------------------------
1861             # File::Util::existent()
1862             # --------------------------------------------------------
1863 2 50   2 1 5 sub existent { my $f = _myargs( @_ ); defined $f ? -e $f : undef }
  2         26  
1864              
1865              
1866             # --------------------------------------------------------
1867             # File::Util::touch()
1868             # --------------------------------------------------------
1869             sub touch {
1870 26     26 1 5652 my $this = shift @_;
1871 26   50     60 my $file = shift @_ || '';
1872 26         71 my $opts = $this->_remove_opts( \@_ );
1873 26         21 my $path;
1874              
1875 26 50 33     96 return $this->_throw(
1876             'no input',
1877             {
1878             meth => 'touch',
1879             missing => 'a file name or file handle reference',
1880             opts => $opts,
1881             }
1882             ) unless defined $file && length $file;
1883              
1884 26         53 $path = $this->return_path( $file );
1885              
1886             # see if the file exists already and is a directory
1887 26 50 66     487 return $this->_throw(
1888             'cant touch on a dir',
1889             {
1890             filename => $file,
1891             dirname => $path,
1892             opts => $opts,
1893             }
1894             ) if -e $file && -d $file;
1895              
1896             # it's good to know beforehand whether or not we have permission to open
1897             # and read from this file allowing us to handle such an exception before
1898             # it handles us.
1899              
1900             # first check the readability of the file's housing dir
1901 26 50 66     421 return $this->_throw(
1902             'cant dread',
1903             {
1904             filename => $file,
1905             dirname => $path,
1906             opts => $opts,
1907             }
1908             ) if ( -e $path && !-r $path );
1909              
1910 26 100       185 $this->make_dir( $path ) unless -e $path;
1911              
1912             # create the file if it doesn't exist (like the *nix touch command does)
1913             # except we'll create it in binmode or with UTF-8 encoding if requested
1914             $this->write_file(
1915             $file => '' => { empty_writes_OK => 1, binmode => $opts->{binmode} }
1916 26 100       237 ) unless -e $file;
1917              
1918 26         46 my $now = time();
1919              
1920             # return
1921 26         406 return utime $now, $now, $file;
1922             }
1923              
1924              
1925             # --------------------------------------------------------
1926             # File::Util::file_type()
1927             # --------------------------------------------------------
1928             sub file_type {
1929 8     8 1 711 my $f = _myargs( @_ );
1930              
1931 8 50 33     116 return unless defined $f and -e $f;
1932              
1933 8         6 my @ret;
1934              
1935 8 100       37 push @ret, 'PLAIN' if -f $f; push @ret, 'TEXT' if -T $f;
  8 100       204  
1936 8 100       118 push @ret, 'BINARY' if -B $f; push @ret, 'DIRECTORY' if -d $f;
  8 100       41  
1937 8 50       33 push @ret, 'SYMLINK' if -l $f; push @ret, 'PIPE' if -p $f;
  8 50       31  
1938 8 50       30 push @ret, 'SOCKET' if -S $f; push @ret, 'BLOCK' if -b $f;
  8 50       31  
1939 8 50       30 push @ret, 'CHARACTER' if -c $f;
1940              
1941             ## no critic
1942 8 50       17 push @ret, 'TTY' if -t $f;
1943             ## use critic
1944              
1945 8 50       13 push @ret, 'ERROR: Cannot determine file type' unless scalar @ret;
1946              
1947 8         39 return @ret;
1948             }
1949              
1950              
1951             # --------------------------------------------------------
1952             # File::Util::flock_rules()
1953             # --------------------------------------------------------
1954             sub flock_rules {
1955 5     5 1 7 my $this = shift(@_);
1956 5         11 my @rules = _myargs( @_ );
1957              
1958 5 100       19 return @ONLOCKFAIL unless scalar @rules;
1959              
1960 3         14 my %valid = qw/
1961             NOBLOCKEX NOBLOCKEX
1962             NOBLOCKSH NOBLOCKSH
1963             BLOCKEX BLOCKEX
1964             BLOCKSH BLOCKSH
1965             FAIL FAIL
1966             WARN WARN
1967             IGNORE IGNORE
1968             UNDEF UNDEF
1969             ZERO ZERO /;
1970              
1971             map {
1972 3         4 return $this->_throw('bad flock rules', { 'bad' => $_, 'all' => \@rules })
1973 6 50       14 unless exists $valid{ $_ }
1974             } @rules;
1975              
1976 3         7 @ONLOCKFAIL = @rules;
1977              
1978             @ONLOCKFAIL
1979 3         11 }
1980              
1981              
1982             # --------------------------------------------------------
1983             # File::Util::is_bin()
1984             # --------------------------------------------------------
1985 2 50   2 1 5 sub is_bin { my $f = _myargs( @_ ); defined $f ? -B $f : undef }
  2         61  
1986              
1987              
1988             # --------------------------------------------------------
1989             # File::Util::last_access()
1990             # --------------------------------------------------------
1991             sub last_access {
1992 5   50 5 1 12 my $f = _myargs( @_ ); $f ||= '';
  5         9  
1993              
1994 5 50       46 return unless -e $f;
1995              
1996             # return the last accessed time of $f
1997 5         49 $^T - ((-A $f) * 60 * 60 * 24)
1998             }
1999              
2000              
2001             # --------------------------------------------------------
2002             # File::Util::last_modified()
2003             # --------------------------------------------------------
2004             sub last_modified {
2005 5   50 5 1 11 my $f = _myargs( @_ ); $f ||= '';
  5         9  
2006              
2007 5 50       45 return unless -e $f;
2008              
2009             # return the last modified time of $f
2010 5         53 $^T - ((-M $f) * 60 * 60 * 24)
2011             }
2012              
2013              
2014             # --------------------------------------------------------
2015             # File::Util::last_changed()
2016             # --------------------------------------------------------
2017             sub last_changed {
2018 2   50 2 1 6 my $f = _myargs( @_ ); $f ||= '';
  2         4  
2019              
2020 2 50       19 return unless -e $f;
2021              
2022             # return the last changed time of $f
2023 2         19 $^T - ((-C $f) * 60 * 60 * 24)
2024             }
2025              
2026              
2027             # --------------------------------------------------------
2028             # File::Util::load_dir()
2029             # --------------------------------------------------------
2030             sub load_dir {
2031 6     6 1 984 my $this = shift @_;
2032 6         16 my $opts = $this->_remove_opts( \@_ );
2033 6         7 my $dir = shift @_;
2034              
2035 6         9 my @files = ( );
2036 6         8 my $dir_hash = { };
2037 6         8 my $dir_list = [ ];
2038              
2039 6   50     12 $dir ||= '';
2040              
2041 6 50       15 return $this->_throw(
2042             'no input' => {
2043             meth => 'load_dir',
2044             missing => 'a directory name',
2045             opts => $opts,
2046             }
2047             ) unless length $dir;
2048              
2049 6         20 @files = $this->list_dir( $dir => { files_only => 1 } );
2050              
2051             # map the content of each file into a hash key-value element where the
2052             # key name for each file is the name of the file
2053 6 100 100     29 if ( !$opts->{as_list} && !$opts->{as_listref} ) {
2054              
2055 1         3 foreach ( @files ) {
2056              
2057 8         23 $dir_hash->{ $_ } = $this->load_file( $dir . SL . $_ );
2058             }
2059              
2060 1         5 return $dir_hash;
2061             }
2062             else {
2063              
2064 5         7 foreach ( @files ) {
2065              
2066 40         108 push @$dir_list, $this->load_file( $dir . SL . $_ );
2067             }
2068              
2069 5 100       63 return $dir_list if $opts->{as_listref};
2070              
2071 1         8 return @$dir_list;
2072             }
2073              
2074 0         0 return $dir_hash;
2075             }
2076              
2077              
2078             # --------------------------------------------------------
2079             # File::Util::make_dir()
2080             # --------------------------------------------------------
2081             sub make_dir {
2082 6     6 1 1189 my $this = shift @_;
2083 6         21 my $opts = $this->_remove_opts( \@_ );
2084 6         11 my( $dir, $bitmask ) = @_;
2085              
2086 6 50       18 $bitmask = defined $bitmask ? $bitmask : $opts->{bitmask};
2087 6   50     27 $bitmask ||= oct 777;
2088              
2089             # if the call to this method didn't include a directory name to create,
2090             # then complain about it
2091 6 50 33     27 return $this->_throw(
2092             'no input',
2093             {
2094             meth => 'make_dir',
2095             missing => 'a directory name',
2096             opts => $opts,
2097             }
2098             ) unless defined $dir && length $dir;
2099              
2100 6 100       10 if ( $opts->{if_not_exists} ) {
2101              
2102 2 50       38 if ( -e $dir ) {
2103              
2104 0 0       0 return $dir if -d $dir;
2105              
2106 0         0 return $this->_throw(
2107             'called mkdir on a file',
2108             {
2109             filename => $dir,
2110             dirname => join( SL, split /$DIRSPLIT/, $dir ) . SL,
2111             opts => $opts,
2112             }
2113             );
2114             }
2115             }
2116             else {
2117              
2118 4 50       66 if ( -e $dir ) {
2119              
2120 0 0       0 return $this->_throw(
2121             'called mkdir on a file',
2122             {
2123             filename => $dir,
2124             dirname => join( SL, split /$DIRSPLIT/, $dir ) . SL,
2125             opts => $opts,
2126             }
2127             ) unless -d $dir;
2128              
2129 0         0 return $this->_throw(
2130             'make_dir target exists',
2131             {
2132             dirname => $dir,
2133             filetype => [ $this->file_type( $dir ) ],
2134             opts => $opts,
2135             }
2136             );
2137             }
2138             }
2139              
2140 6         167 my ( $winroot ) = $dir =~ /^($WINROOT)/;
2141              
2142 6         67 $dir =~ s/^($WINROOT)//;
2143 6         153 $dir =~ s/$DIRSPLIT{2,}/$SL/o;
2144 6 50       146 $dir =~ s/$DIRSPLIT+$//o unless $dir eq SL;
2145 6 50       20 $dir = $winroot . $dir if $winroot;
2146              
2147 6         26 my ( $root, $path ) = atomize_path( $dir . SL );
2148              
2149 6         53 my @dirs_in_path = split /$DIRSPLIT/, $path;
2150              
2151             # if prospective file name has illegal chars then complain
2152 6         12 foreach ( @dirs_in_path ) {
2153              
2154 30 50       45 return $this->_throw(
2155             'bad chars',
2156             {
2157             string => $_,
2158             purpose => 'the name of a file or directory',
2159             opts => $opts,
2160             }
2161             ) if !$this->valid_filename( $_ );
2162             }
2163              
2164             # do this AFTER the above check!!
2165 6 50       20 unshift @dirs_in_path, $root if $root;
2166              
2167             # qualify each subdir in @dirs_in_path by prepending its preceeding dir
2168             # names to it. Above, "/foo/bar/baz" becomes ("/", "foo", "bar", "baz")
2169             # and below it becomes ("/", "/foo", "/foo/bar", "/foo/bar/baz")
2170              
2171 6 50       13 if ( @dirs_in_path > 1 ) {
2172 6         16 for ( my $depth = 1; $depth < @dirs_in_path; ++$depth ) {
2173              
2174 30 100       39 if ( $dirs_in_path[ $depth-1 ] eq SL ) {
2175              
2176 6         17 $dirs_in_path[ $depth ] = SL . $dirs_in_path[ $depth ]
2177             }
2178             else {
2179              
2180 24         66 $dirs_in_path[ $depth ] =
2181             join SL, @dirs_in_path[ ( $depth - 1 ) .. $depth ]
2182             }
2183             }
2184             }
2185              
2186 6         9 my $i = 0;
2187              
2188 6         11 foreach ( @dirs_in_path ) {
2189 36         33 my $dir = $_;
2190 36 100       59 my $up = ( $i > 0 ) ? $dirs_in_path[ $i - 1 ] : '..';
2191              
2192 36         19 ++$i;
2193              
2194 36 50 66     456 if ( -e $dir && !-d $dir ) {
2195              
2196 0         0 return $this->_throw(
2197             'called mkdir on a file',
2198             {
2199             filename => $dir,
2200             dirname => $up . SL,
2201             opts => $opts,
2202             }
2203             );
2204             }
2205              
2206 36 100       216 next if -e $dir;
2207              
2208             # it's good to know beforehand whether or not we have permission to
2209             # create dirs here, which allows us to handle such an exception
2210             # before it handles us.
2211 14 50       111 return $this->_throw(
2212             'cant dcreate',
2213             {
2214             dirname => $dir,
2215             parentd => $up,
2216             opts => $opts,
2217             }
2218             ) unless -w $up;
2219              
2220 14 50       525 mkdir( $dir, $bitmask ) or
2221             return $this->_throw(
2222             'bad make_dir',
2223             {
2224             exception => $!,
2225             dirname => $dir,
2226             bitmask => $bitmask,
2227             opts => $opts,
2228             }
2229             );
2230             }
2231              
2232 6         42 return $dir;
2233             }
2234              
2235              
2236             # --------------------------------------------------------
2237             # File::Util::abort_depth()
2238             # --------------------------------------------------------
2239             sub abort_depth {
2240 3     3 1 360 my $arg = _myargs( @_ );
2241 3         4 my $this = shift @_;
2242              
2243 3 50       6 if ( defined $arg ) {
2244              
2245 0 0       0 return File::Util->new->_throw( 'bad abort_depth' => { bad => $arg } )
2246             if $arg =~ /\D/;
2247              
2248 0         0 $ABORT_DEPTH = $arg;
2249              
2250             $this->{opts}->{abort_depth} = $arg
2251 0 0 0     0 if blessed $this && $this->{opts};
2252             }
2253              
2254 3         10 return $ABORT_DEPTH;
2255             }
2256              
2257             # --------------------------------------------------------
2258             # File::Util::onfail()
2259             # --------------------------------------------------------
2260             sub onfail {
2261 0     0 1 0 my ( $this, $arg ) = @_;
2262              
2263 0 0       0 return unless blessed $this;
2264              
2265 0 0       0 $this->{opts}->{onfail} = $arg if $arg;
2266              
2267 0         0 return $this->{opts}->{onfail};
2268             }
2269              
2270              
2271             # --------------------------------------------------------
2272             # File::Util::read_limit()
2273             # --------------------------------------------------------
2274             sub read_limit {
2275 5     5 1 12 my $arg = _myargs( @_ );
2276 5         6 my $this = shift @_;
2277              
2278 5 50       9 if ( defined $arg ) {
2279              
2280 0 0       0 return File::Util->new->_throw ( 'bad read_limit' => { bad => $arg } )
2281             if $arg =~ /\D/;
2282              
2283 0         0 $READ_LIMIT = $arg;
2284              
2285             $this->{opts}->{read_limit} = $arg
2286 0 0 0     0 if blessed $this && $this->{opts};
2287             }
2288              
2289 5         16 return $READ_LIMIT;
2290             }
2291              
2292              
2293             # --------------------------------------------------------
2294             # File::Util::diagnostic()
2295             # --------------------------------------------------------
2296             sub diagnostic {
2297 0     0 1 0 my $arg = _myargs( @_ );
2298 0         0 my $this = shift @_;
2299              
2300 0 0       0 if ( defined $arg ) {
2301              
2302 0 0       0 $WANT_DIAGNOSTICS = $arg ? 1 : 0;
2303              
2304             $this->{opts}->{diag} = $arg ? 1 : 0
2305 0 0 0     0 if blessed $this && $this->{opts};
    0          
2306             }
2307              
2308 0         0 return $WANT_DIAGNOSTICS;
2309             }
2310              
2311              
2312             # --------------------------------------------------------
2313             # File::Util::needs_binmode()
2314             # --------------------------------------------------------
2315 1     1 1 5 sub needs_binmode { $NEEDS_BINMODE }
2316              
2317              
2318             # --------------------------------------------------------
2319             # File::Util::open_handle()
2320             # --------------------------------------------------------
2321             sub open_handle {
2322 5     5 1 642 my $this = shift @_;
2323 5         16 my $in = $this->_parse_in( @_ );
2324 5         8 my $file = '';
2325 5         6 my $mode = '';
2326 5   50     23 my $bitmask = $in->{bitmask} || oct 777;
2327 5         6 my $raw_name = $file;
2328 5         3 my $fh; # will be the lexical file handle scoped to this method
2329 5         10 my ( $root, $path, $clean_name, @dirs ) =
2330             ( '', '', '', () );
2331              
2332             # get name of file when passed in as a name/value pair...
2333              
2334             $file =
2335             exists $in->{filename} &&
2336             defined $in->{filename} &&
2337             length $in->{filename}
2338             ? $in->{filename}
2339             : exists $in->{file} &&
2340             defined $in->{file} &&
2341             length $in->{file}
2342             ? $in->{file}
2343 5 100 33     38 : '';
    50 66        
2344              
2345             # ...or fall back to support of two-argument form of invocation
2346              
2347 5 50       8 my $maybe_file = shift @_; $maybe_file = '' if !defined $maybe_file;
  5         16  
2348 5 50       5 my $maybe_mode = shift @_; $maybe_mode = '' if !defined $maybe_mode;
  5         9  
2349              
2350 5 100 66     28 $file = $maybe_file if !ref $maybe_file && $file eq '';
2351             $mode =
2352             !ref $maybe_mode &&
2353             !exists $in->{mode}
2354             ? $maybe_mode
2355 5 100 66     22 : $in->{mode};
2356              
2357 5   50     15 $mode ||= 'read';
2358              
2359              
2360 5         101 my ( $winroot ) = $file =~ /^($WINROOT)/;
2361              
2362 5         54 $file =~ s/^($WINROOT)//;
2363 5         92 $file =~ s/$DIRSPLIT{2,}/$SL/o;
2364 5 50       93 $file =~ s/$DIRSPLIT+$//o unless $file eq SL;
2365 5 50       13 $file = $winroot . $file if $winroot;
2366              
2367 5         6 $raw_name = $file; # preserve original filename input before line below:
2368              
2369 5         12 ( $root, $path, $file ) = atomize_path( $file );
2370              
2371             # begin user input validation/sanitation sequence
2372              
2373             # if the call to this method didn't include a filename to which the caller
2374             # wants us to write, then complain about it
2375 5 50       15 return $this->_throw(
2376             'no input',
2377             {
2378             meth => 'open_handle',
2379             missing => 'a file name to create, write, read/write, or append',
2380             opts => $in,
2381             }
2382             ) unless length $file;
2383              
2384 5 50 66     26 if ( $mode eq 'read' && !-e $raw_name ) {
2385              
2386             # if the file doesn't exist, send back an error
2387 0 0       0 return $this->_throw(
2388             'no such file',
2389             {
2390             filename => $raw_name,
2391             opts => $in,
2392             }
2393             ) unless -e $clean_name;
2394             }
2395              
2396             # if prospective filename contains 2+ dir separators in sequence then
2397             # this is a syntax error we need to whine about
2398             {
2399 5         5 my $try_filename = $raw_name;
  5         6  
2400              
2401 5         16 $try_filename =~ s/$WINROOT//; # windows abs paths would throw this off
2402              
2403 5 50       105 return $this->_throw(
2404             'bad chars',
2405             {
2406             string => $raw_name,
2407             purpose => 'the name of a file or directory',
2408             opts => $in,
2409             }
2410             ) if $try_filename =~ /(?:$DIRSPLIT){2,}/;
2411             }
2412              
2413             # determine existance of the file path, make directory(ies) for the
2414             # path if the full directory path doesn't exist
2415 5         26 @dirs = split /$DIRSPLIT/, $path;
2416              
2417             # if prospective file name has illegal chars then complain
2418 5         11 foreach ( @dirs ) {
2419              
2420 8 50       16 return $this->_throw(
2421             'bad chars',
2422             {
2423             string => $_,
2424             purpose => 'the name of a file or directory',
2425             opts => $in,
2426             }
2427             ) if !$this->valid_filename( $_ );
2428             }
2429              
2430             # do this AFTER the above check!!
2431 5 50       15 unshift @dirs, $root if $root;
2432              
2433             # make sure that open mode is a valid mode
2434 5 50 33     30 if (
2435             !exists $in->{use_sysopen} &&
2436             !defined $in->{use_sysopen}
2437             ) {
2438             # native Perl open modes
2439 5 50 33     29 unless (
2440             exists $$MODES{popen}{ $mode } &&
2441             defined $$MODES{popen}{ $mode }
2442             ) {
2443 0         0 return $this->_throw(
2444             'bad openmode popen',
2445             {
2446             meth => 'open_handle',
2447             filename => $raw_name,
2448             badmode => $mode,
2449             opts => $in,
2450             }
2451             )
2452             }
2453             }
2454             else {
2455             # system open modes
2456 0 0 0     0 unless (
2457             exists $$MODES{sysopen}{ $mode } &&
2458             defined $$MODES{sysopen}{ $mode }
2459             ) {
2460 0         0 return $this->_throw(
2461             'bad openmode sysopen',
2462             {
2463             meth => 'open_handle',
2464             filename => $raw_name,
2465             badmode => $mode,
2466             opts => $in,
2467             }
2468             )
2469             }
2470             }
2471              
2472             # cleanup file name - if path is relative, normalize it
2473             # - /foo/bar/baz.txt stays as /foo/bar/baz.txt
2474             # - foo/bar/baz.txt becomes ./foo/bar/baz.txt
2475             # - baz.txt stays as baz.txt
2476 5 50 33     14 if ( !length $root && !length $path ) {
2477              
2478 0         0 $path = '.' . SL;
2479             }
2480             else { # otherwise path normalized at end
2481              
2482 5         7 $path .= SL;
2483             }
2484              
2485             # final clean filename assembled
2486 5         8 $clean_name = $root . $path . $file;
2487              
2488             # create path preceding file if path doesn't exist and not in read mode
2489 5 50 66     80 if ( $mode ne 'read' && !-e $root . $path ) {
2490              
2491 0         0 my $make_dir_ok = 1;
2492              
2493             my $make_dir_return = $this->make_dir(
2494             $root . $path,
2495             exists $in->{dbitmask} &&
2496             defined $in->{dbitmask}
2497             ? $in->{dbitmask}
2498             : oct 777,
2499             {
2500             diag => $in->{diag},
2501             onfail => sub {
2502 0     0   0 my ( $err, $trace ) = @_;
2503              
2504             return $in->{onfail}
2505             if ref $in->{onfail} &&
2506 0 0 0     0 ref $in->{onfail} eq 'CODE';
2507              
2508 0         0 $make_dir_ok = 0;
2509              
2510 0         0 return $err . $trace;
2511             }
2512             }
2513 0 0 0     0 );
2514              
2515 0 0       0 die $make_dir_return unless $make_dir_ok;
2516             }
2517              
2518             # sanity checks based on requested mode
2519 5 100 100     37 if (
    50 66        
      66        
      33        
      33        
2520             $mode eq 'write' ||
2521             $mode eq 'append' ||
2522             $mode eq 'rwcreate' ||
2523             $mode eq 'rwclobber' ||
2524             $mode eq 'rwappend'
2525             ) {
2526             # Check whether or not we have permission to open and perform writes
2527             # on this file.
2528              
2529 4 100       48 if ( -e $clean_name ) {
2530              
2531 3 50       25 return $this->_throw(
2532             'cant fwrite',
2533             {
2534             filename => $clean_name,
2535             dirname => $root . $path,
2536             opts => $in,
2537             }
2538             ) unless -w $clean_name;
2539             }
2540             else {
2541             # If file doesn't exist and the path isn't writable, the error is
2542             # one of unallowed creation.
2543 1 50       9 return $this->_throw(
2544             'cant fcreate',
2545             {
2546             filename => $clean_name,
2547             dirname => $root . $path,
2548             opts => $in,
2549             }
2550             ) unless -w $root . $path;
2551             }
2552             }
2553             elsif ( $mode eq 'read' || $mode eq 'rwupdate' ) {
2554             # Check whether or not we have permission to open and perform reads
2555             # on this file, starting with file's housing directory.
2556 1 50       10 return $this->_throw(
2557             'cant dread',
2558             {
2559             filename => $clean_name,
2560             dirname => $root . $path,
2561             opts => $in,
2562             }
2563             ) unless -r $root . $path;
2564              
2565             # Seems obvious, but we can't read non-existent files
2566 1 50       8 return $this->_throw(
2567             'cant fread not found',
2568             {
2569             filename => $clean_name,
2570             dirname => $root . $path,
2571             opts => $in,
2572             }
2573             ) unless -e $clean_name;
2574              
2575             # Check the readability of the file itself
2576 1 50       7 return $this->_throw(
2577             'cant fread',
2578             {
2579             filename => $clean_name,
2580             dirname => $root . $path,
2581             opts => $in,
2582             }
2583             ) unless -r $clean_name;
2584             }
2585             else {
2586 0         0 return $this->_throw(
2587             'no input',
2588             {
2589             meth => 'open_handle',
2590             missing => q{a valid IO mode. (eg- 'read', 'write'...)},
2591             opts => $in,
2592             }
2593             );
2594             }
2595              
2596             # Final bit of input validation made necessary by the would-be perils
2597             # of IO encoding while using sys(open,read,write,seek,tell,etc) -
2598             # Basically, using :utf8 encoding with syswrite is deprecated
2599 5 0 33     17 if
      0        
      33        
2600             (
2601             ( exists $in->{use_sysopen} && defined $in->{use_sysopen} ) &&
2602             ( $in->{binmode} && lc $in->{binmode} eq 'utf8' )
2603             )
2604             {
2605 0         0 return $this->_throw(
2606             'bad binmode',
2607             {
2608             meth => 'open_handle',
2609             filename => $clean_name,
2610             dirname => $root . $path,
2611             opts => $in,
2612             }
2613             );
2614             }
2615              
2616             # input validation sequence finished
2617              
2618 5 50 33     21 if ( $$in{no_lock} || !$USE_FLOCK ) {
2619 0 0 0     0 if (
2620             !exists $in->{use_sysopen} &&
2621             !defined $in->{use_sysopen}
2622             ) { # perl open
2623             # get open mode
2624 0         0 $mode = $$MODES{popen}{ $mode };
2625              
2626 0 0       0 open $fh, $mode, $clean_name or
2627             return $this->_throw(
2628             'bad open',
2629             {
2630             filename => $clean_name,
2631             mode => $mode,
2632             exception => $!,
2633             cmd => $mode . $clean_name,
2634             opts => $in,
2635             }
2636             );
2637             }
2638             else { # sysopen
2639             # get open mode
2640 0         0 $mode = $$MODES{sysopen}{ $mode };
2641              
2642 0 0       0 sysopen( $fh, $clean_name, $mode ) or
2643             return $this->_throw(
2644             'bad open',
2645             {
2646             filename => $clean_name,
2647             mode => $mode,
2648             exception => $!,
2649             cmd => qq($clean_name, $mode),
2650             opts => $in,
2651             }
2652             );
2653             }
2654             }
2655             else {
2656 5 50 33     19 if (
2657             !exists $in->{use_sysopen} &&
2658             !defined $in->{use_sysopen}
2659             ) { # perl open
2660             # open read-only first to safely check if we can get a lock.
2661 5 100       35 if ( -e $clean_name ) {
2662              
2663 4 50       86 open $fh, '<', $clean_name or
2664             return $this->_throw(
2665             'bad open',
2666             {
2667             filename => $clean_name,
2668             mode => 'read',
2669             exception => $!,
2670             cmd => $mode . $clean_name,
2671             opts => $in,
2672             }
2673             );
2674              
2675             # lock file before I/O on platforms that support it
2676 4         12 my $lockstat = $this->_seize( $clean_name, $fh, $in );
2677              
2678 4 100 50     50 warn "returning $lockstat" && return $lockstat unless fileno $lockstat;
2679              
2680 3 100       8 if ( $mode ne 'read' ) {
2681              
2682             open $fh, $$MODES{popen}{ $mode }, $clean_name or
2683             return $this->_throw(
2684             'bad open',
2685             {
2686             exception => $!,
2687             filename => $clean_name,
2688             mode => $mode,
2689             opts => $in,
2690 2 50       57 cmd => $$MODES{popen}{ $mode } . $clean_name,
2691             }
2692             );
2693             }
2694             }
2695             else {
2696             open $fh, $$MODES{popen}{ $mode }, $clean_name or
2697             return $this->_throw(
2698             'bad open',
2699             {
2700             exception => $!,
2701             filename => $clean_name,
2702             mode => $mode,
2703             opts => $in,
2704 1 50       75 cmd => $$MODES{popen}{ $mode } . $clean_name,
2705             }
2706             );
2707              
2708             # lock file before I/O on platforms that support it
2709 1         6 my $lockstat = $this->_seize( $clean_name, $fh, $in );
2710              
2711 1 50       2 return $lockstat unless $lockstat;
2712             }
2713             }
2714             else { # sysopen
2715             # open read-only first to safely check if we can get a lock.
2716 0 0       0 if ( -e $clean_name ) {
2717              
2718 0 0       0 open $fh, '<', $clean_name or
2719             return $this->_throw(
2720             'bad open',
2721             {
2722             filename => $clean_name,
2723             mode => 'read',
2724             exception => $!,
2725             cmd => $mode . $clean_name,
2726             opts => $in,
2727             }
2728             );
2729              
2730             # lock file before I/O on platforms that support it
2731 0         0 my $lockstat = $this->_seize( $clean_name, $fh, $in );
2732              
2733 0 0       0 return $lockstat unless $lockstat;
2734              
2735 0 0       0 sysopen( $fh, $clean_name, $$MODES{sysopen}{ $mode } )
2736             or return $this->_throw(
2737             'bad open',
2738             {
2739             filename => $clean_name,
2740             mode => $mode,
2741             opts => $in,
2742             exception => $!,
2743             cmd => qq($clean_name, $$MODES{sysopen}{ $mode }),
2744             }
2745             );
2746             }
2747             else { # only non-existent files get bitmask arguments
2748             sysopen(
2749             $fh,
2750             $clean_name,
2751 0 0       0 $$MODES{sysopen}{ $mode },
2752             $bitmask
2753             ) or return $this->_throw(
2754             'bad open',
2755             {
2756             filename => $clean_name,
2757             mode => $mode,
2758             opts => $in,
2759             exception => $!,
2760             cmd => qq($clean_name, $$MODES{sysopen}{$mode}, $bitmask),
2761             }
2762             );
2763              
2764             # lock file before I/O on platforms that support it
2765 0         0 my $lockstat = $this->_seize( $clean_name, $fh, $in );
2766              
2767 0 0       0 return $lockstat unless $lockstat;
2768             }
2769             }
2770             }
2771              
2772             # call binmode on the filehandle if it was requested or UTF-8
2773 4 100       12 if ( $in->{binmode} )
2774             {
2775 2 50       5 if ( lc $in->{binmode} eq 'utf8' )
    0          
2776             {
2777 2 50       4 if ( $HAVE_UU )
2778             {
2779 2         12 binmode $fh, ':unix:encoding(UTF-8)';
2780             }
2781             else
2782             {
2783 0         0 close $fh;
2784              
2785 0         0 return $this->_throw( 'no unicode' => $in );
2786             }
2787             }
2788             elsif ( $in->{binmode} == 1 )
2789             {
2790 0         0 binmode $fh;
2791             }
2792             else
2793             {
2794             binmode $fh, $in->{binmode} # apply user-specified IO layer(s)
2795 0         0 }
2796             }
2797              
2798             # return file handle reference to the caller
2799 4         72 return $fh;
2800             }
2801              
2802              
2803             # --------------------------------------------------------
2804             # File::Util::unlock_open_handle()
2805             # --------------------------------------------------------
2806             sub unlock_open_handle {
2807 2     2 1 405 my( $this, $fh ) = @_;
2808              
2809 2 50       6 return 1 unless $USE_FLOCK;
2810              
2811 2 50 33     9 return $this->_throw(
2812             'not a filehandle' => {
2813             opts => $this->_remove_opts( \@_ ),
2814             argtype => ref $fh,
2815             }
2816             ) unless $fh && fileno $fh;
2817              
2818 2 50       35 return flock( $fh, &Fcntl::LOCK_UN ) if $CAN_FLOCK;
2819              
2820 0         0 return 0;
2821             }
2822              
2823              
2824             # --------------------------------------------------------
2825             # File::Util::return_path()
2826             # --------------------------------------------------------
2827 28     28 1 1205 sub return_path { my $f = _myargs( @_ ); $f =~ s/(^.*)$DIRSPLIT.*/$1/; $f }
  28         623  
  28         70  
2828              
2829              
2830             # --------------------------------------------------------
2831             # File::Util::strict_path()
2832             # --------------------------------------------------------
2833             sub strict_path
2834             {
2835 0     0 1 0 my $path = _myargs( @_ );
2836 0         0 my $copy = $path;
2837              
2838 0         0 ( $path ) = $path =~ /(^.*$DIRSPLIT)/;
2839              
2840 0 0       0 ( $path ) = $copy =~ /(^\.{1,2}$)/ if !defined $path;
2841              
2842 0 0       0 return unless defined $path;
2843              
2844 0 0       0 $path .= SL unless substr $path, -1, 1 =~ /$DIRSPLIT/;
2845              
2846 0 0       0 return $path =~ /$DIRSPLIT/ ? $path : undef;
2847             }
2848              
2849              
2850             # --------------------------------------------------------
2851             # File::Util::default_path()
2852             # --------------------------------------------------------
2853             sub default_path
2854             {
2855 0     0 1 0 my ( $path, $dflt ) = _myargs( @_ );
2856              
2857 0 0       0 $dflt = defined $dflt ? $dflt : '.' . SL;
2858              
2859 0         0 $path = strict_path( $path );
2860              
2861 0 0       0 return defined $path ? $path : $dflt;
2862             }
2863              
2864              
2865             # --------------------------------------------------------
2866             # File::Util::size()
2867             # --------------------------------------------------------
2868 5 50 50 5 1 1124 sub size { my $f = _myargs( @_ ); $f ||= ''; return unless -e $f; -s $f }
  5         11  
  5         47  
  5         40  
2869              
2870              
2871             # --------------------------------------------------------
2872             # File::Util::trunc()
2873             # --------------------------------------------------------
2874 2     2 1 8 sub trunc { $_[0]->write_file( { mode => trunc => file => $_[1] } ) }
2875              
2876              
2877             # --------------------------------------------------------
2878             # File::Util::use_flock()
2879             # --------------------------------------------------------
2880             sub use_flock {
2881 64     64 1 1710 my $arg = _myargs( @_ );
2882              
2883 64 100       142 $USE_FLOCK = !!$arg if defined $arg;
2884              
2885 64         161 return $USE_FLOCK;
2886             }
2887              
2888             # --------------------------------------------------------
2889             # File::Util::AUTOLOAD()
2890             # --------------------------------------------------------
2891             sub AUTOLOAD {
2892              
2893             # The main purpose of using autoload here is to avoid compiling in
2894             # copious amounts of error handling code at compile time, when in
2895             # the majority of cases and in production code-- such errors should
2896             # have already been debugged and the error handling mechanism will
2897             # end up getting invoked seldom if ever. There's no reason to pay
2898             # the performance penalty when it's not necessary.
2899             # The other purpose is to support legacy method names.
2900              
2901 2     2   401 ( my $name = our $AUTOLOAD ) =~ s/.*:://;
2902              
2903             # These are legacy method names, and their current replacements. In order
2904             # to future-proof things, this hashref is used as a dispatch table further
2905             # down in the code in lieu of potentially-growing if/else block, which
2906             # would ugly to maintain
2907              
2908 2         16 my $redirect_methods = {
2909             can_write => \&is_writable,
2910             can_read => \&is_readable,
2911             isbin => \&is_bin,
2912             readlimit => \&read_limit,
2913             max_dives => \&abort_depth,
2914             };
2915              
2916 2 100       8 if ( $name eq '_throw' )
    50          
2917             {
2918             *_throw = sub
2919             {
2920 1     1   2 my $this = shift @_;
2921 1   50     3 my $in = $this->_parse_in( @_ ) || { };
2922 1         1 my $error_class;
2923              
2924             # direct input can override object-global diag default, otherwise
2925             # the object's "want diagnostics" setting is inherited
2926              
2927             $in->{diag} = defined $in->{diag} && !$in->{diag}
2928             ? 0
2929             : $in->{diag}
2930             ? $in->{diag}
2931 1 50 33     9 : $this->{opts}->{diag};
    50          
2932              
2933 1 50 33     37 if
      33        
      33        
      33        
2934             (
2935             $in->{diag} ||
2936             ( $in->{opts} &&
2937             ref $in->{opts} &&
2938             ref $in->{opts} eq 'HASH' &&
2939             $in->{opts}->{diag}
2940             )
2941             )
2942             {
2943 0         0 require File::Util::Exception::Diagnostic;
2944              
2945 0         0 $error_class = 'File::Util::Exception::Diagnostic';
2946              
2947 0         0 unshift @_, $this, $error_class;
2948              
2949 0         0 goto \&File::Util::Exception::Diagnostic::_throw;
2950             }
2951             else
2952             {
2953 1         493 require File::Util::Exception::Standard;
2954              
2955 1         3 $error_class = 'File::Util::Exception::Standard';
2956              
2957 1         3 unshift @_, $this, $error_class;
2958              
2959 1         5 goto \&File::Util::Exception::Standard::_throw;
2960              
2961             }
2962 1         6 };
2963              
2964 1         4 goto \&_throw;
2965             }
2966             elsif ( exists $redirect_methods->{ $name } ) {
2967              
2968 20     20   153370 { no strict 'refs'; *{ $name } = $redirect_methods->{ $name } }
  20         27  
  20         2225  
  1         2  
  1         1  
  1         7  
2969              
2970 1         4 goto \&$name;
2971             }
2972              
2973 0         0 die qq(Unknown method: File::Util::$name\n);
2974             }
2975              
2976              
2977             # --------------------------------------------------------
2978             # File::Util::DESTROY()
2979             # --------------------------------------------------------
2980       1     sub DESTROY { }
2981              
2982             1;
2983              
2984              
2985             __END__