File Coverage

blib/lib/File/Path.pm
Criterion Covered Total %
statement 0 255 0.0
branch 0 160 0.0
condition 0 83 0.0
subroutine 0 12 0.0
pod 4 4 100.0
total 4 514 0.7


line stmt bran cond sub pod time code
1             package File::Path;
2              
3             use 5.005_04;
4             use strict;
5              
6             use Cwd 'getcwd';
7             use File::Basename ();
8             use File::Spec ();
9              
10             BEGIN {
11             if ( $] < 5.006 ) {
12              
13             # can't say 'opendir my $dh, $dirname'
14             # need to initialise $dh
15             eval 'use Symbol';
16             }
17             }
18              
19             use Exporter ();
20             use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
21             $VERSION = '2.17';
22             $VERSION = eval $VERSION;
23             @ISA = qw(Exporter);
24             @EXPORT = qw(mkpath rmtree);
25             @EXPORT_OK = qw(make_path remove_tree);
26              
27             BEGIN {
28             for (qw(VMS MacOS MSWin32 os2)) {
29             no strict 'refs';
30             *{"_IS_\U$_"} = $^O eq $_ ? sub () { 1 } : sub () { 0 };
31             }
32              
33             # These OSes complain if you want to remove a file that you have no
34             # write permission to:
35             *_FORCE_WRITABLE = (
36             grep { $^O eq $_ } qw(amigaos dos epoc MSWin32 MacOS os2)
37             ) ? sub () { 1 } : sub () { 0 };
38              
39             # Unix-like systems need to stat each directory in order to detect
40             # race condition. MS-Windows is immune to this particular attack.
41             *_NEED_STAT_CHECK = !(_IS_MSWIN32()) ? sub () { 1 } : sub () { 0 };
42             }
43              
44             sub _carp {
45 0     0     require Carp;
46 0           goto &Carp::carp;
47             }
48              
49             sub _croak {
50 0     0     require Carp;
51 0           goto &Carp::croak;
52             }
53              
54             sub _error {
55 0     0     my $arg = shift;
56 0           my $message = shift;
57 0           my $object = shift;
58              
59 0 0         if ( $arg->{error} ) {
60 0 0         $object = '' unless defined $object;
61 0 0         $message .= ": $!" if $!;
62 0           push @{ ${ $arg->{error} } }, { $object => $message };
  0            
  0            
63             }
64             else {
65 0 0         _carp( defined($object) ? "$message for $object: $!" : "$message: $!" );
66             }
67             }
68              
69             sub __is_arg {
70 0     0     my ($arg) = @_;
71              
72             # If client code blessed an array ref to HASH, this will not work
73             # properly. We could have done $arg->isa() wrapped in eval, but
74             # that would be expensive. This implementation should suffice.
75             # We could have also used Scalar::Util:blessed, but we choose not
76             # to add this dependency
77 0           return ( ref $arg eq 'HASH' );
78             }
79              
80             sub make_path {
81 0 0 0 0 1   push @_, {} unless @_ and __is_arg( $_[-1] );
82 0           goto &mkpath;
83             }
84              
85             sub mkpath {
86 0   0 0 1   my $old_style = !( @_ and __is_arg( $_[-1] ) );
87              
88 0           my $data;
89             my $paths;
90              
91 0 0         if ($old_style) {
92 0           my ( $verbose, $mode );
93 0           ( $paths, $verbose, $mode ) = @_;
94 0 0         $paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' );
95 0           $data->{verbose} = $verbose;
96 0 0         $data->{mode} = defined $mode ? $mode : oct '777';
97             }
98             else {
99 0           my %args_permitted = map { $_ => 1 } ( qw|
  0            
100             chmod
101             error
102             group
103             mask
104             mode
105             owner
106             uid
107             user
108             verbose
109             | );
110 0           my %not_on_win32_args = map { $_ => 1 } ( qw|
  0            
111             group
112             owner
113             uid
114             user
115             | );
116 0           my @bad_args = ();
117 0           my @win32_implausible_args = ();
118 0           my $arg = pop @_;
119 0           for my $k (sort keys %{$arg}) {
  0            
120 0 0 0       if (! $args_permitted{$k}) {
    0          
121 0           push @bad_args, $k;
122             }
123             elsif ($not_on_win32_args{$k} and _IS_MSWIN32) {
124 0           push @win32_implausible_args, $k;
125             }
126             else {
127 0           $data->{$k} = $arg->{$k};
128             }
129             }
130 0 0         _carp("Unrecognized option(s) passed to mkpath() or make_path(): @bad_args")
131             if @bad_args;
132 0 0         _carp("Option(s) implausible on Win32 passed to mkpath() or make_path(): @win32_implausible_args")
133             if @win32_implausible_args;
134 0 0         $data->{mode} = delete $data->{mask} if exists $data->{mask};
135 0 0         $data->{mode} = oct '777' unless exists $data->{mode};
136 0 0         ${ $data->{error} } = [] if exists $data->{error};
  0            
137 0 0         unless (@win32_implausible_args) {
138 0 0         $data->{owner} = delete $data->{user} if exists $data->{user};
139 0 0         $data->{owner} = delete $data->{uid} if exists $data->{uid};
140 0 0 0       if ( exists $data->{owner} and $data->{owner} =~ /\D/ ) {
141 0           my $uid = ( getpwnam $data->{owner} )[2];
142 0 0         if ( defined $uid ) {
143 0           $data->{owner} = $uid;
144             }
145             else {
146 0           _error( $data,
147             "unable to map $data->{owner} to a uid, ownership not changed"
148             );
149 0           delete $data->{owner};
150             }
151             }
152 0 0 0       if ( exists $data->{group} and $data->{group} =~ /\D/ ) {
153 0           my $gid = ( getgrnam $data->{group} )[2];
154 0 0         if ( defined $gid ) {
155 0           $data->{group} = $gid;
156             }
157             else {
158 0           _error( $data,
159             "unable to map $data->{group} to a gid, group ownership not changed"
160             );
161 0           delete $data->{group};
162             }
163             }
164 0 0 0       if ( exists $data->{owner} and not exists $data->{group} ) {
165 0           $data->{group} = -1; # chown will leave group unchanged
166             }
167 0 0 0       if ( exists $data->{group} and not exists $data->{owner} ) {
168 0           $data->{owner} = -1; # chown will leave owner unchanged
169             }
170             }
171 0           $paths = [@_];
172             }
173 0           return _mkpath( $data, $paths );
174             }
175              
176             sub _mkpath {
177 0     0     my $data = shift;
178 0           my $paths = shift;
179              
180 0           my ( @created );
181 0           foreach my $path ( @{$paths} ) {
  0            
182 0 0 0       next unless defined($path) and length($path);
183 0           $path .= '/' if _IS_OS2 and $path =~ /^\w:\z/s; # feature of CRT
184              
185             # Logic wants Unix paths, so go with the flow.
186 0           if (_IS_VMS) {
187             next if $path eq '/';
188             $path = VMS::Filespec::unixify($path);
189             }
190 0 0         next if -d $path;
191 0           my $parent = File::Basename::dirname($path);
192             # Coverage note: It's not clear how we would test the condition:
193             # '-d $parent or $path eq $parent'
194 0 0 0       unless ( -d $parent or $path eq $parent ) {
195 0           push( @created, _mkpath( $data, [$parent] ) );
196             }
197 0 0         print "mkdir $path\n" if $data->{verbose};
198 0 0         if ( mkdir( $path, $data->{mode} ) ) {
199 0           push( @created, $path );
200 0 0         if ( exists $data->{owner} ) {
201              
202             # NB: $data->{group} guaranteed to be set during initialisation
203 0 0         if ( !chown $data->{owner}, $data->{group}, $path ) {
204 0           _error( $data,
205             "Cannot change ownership of $path to $data->{owner}:$data->{group}"
206             );
207             }
208             }
209 0 0         if ( exists $data->{chmod} ) {
210             # Coverage note: It's not clear how we would trigger the next
211             # 'if' block. Failure of 'chmod' might first result in a
212             # system error: "Permission denied".
213 0 0         if ( !chmod $data->{chmod}, $path ) {
214 0           _error( $data,
215             "Cannot change permissions of $path to $data->{chmod}" );
216             }
217             }
218             }
219             else {
220 0           my $save_bang = $!;
221              
222             # From 'perldoc perlvar': $EXTENDED_OS_ERROR ($^E) is documented
223             # as:
224             # Error information specific to the current operating system. At the
225             # moment, this differs from "$!" under only VMS, OS/2, and Win32
226             # (and for MacPerl). On all other platforms, $^E is always just the
227             # same as $!.
228              
229 0           my ( $e, $e1 ) = ( $save_bang, $^E );
230 0 0         $e .= "; $e1" if $e ne $e1;
231              
232             # allow for another process to have created it meanwhile
233 0 0         if ( ! -d $path ) {
234 0           $! = $save_bang;
235 0 0         if ( $data->{error} ) {
236 0           push @{ ${ $data->{error} } }, { $path => $e };
  0            
  0            
237             }
238             else {
239 0           _croak("mkdir $path: $e");
240             }
241             }
242             }
243             }
244 0           return @created;
245             }
246              
247             sub remove_tree {
248 0 0 0 0 1   push @_, {} unless @_ and __is_arg( $_[-1] );
249 0           goto &rmtree;
250             }
251              
252             sub _is_subdir {
253 0     0     my ( $dir, $test ) = @_;
254              
255 0           my ( $dv, $dd ) = File::Spec->splitpath( $dir, 1 );
256 0           my ( $tv, $td ) = File::Spec->splitpath( $test, 1 );
257              
258             # not on same volume
259 0 0         return 0 if $dv ne $tv;
260              
261 0           my @d = File::Spec->splitdir($dd);
262 0           my @t = File::Spec->splitdir($td);
263              
264             # @t can't be a subdir if it's shorter than @d
265 0 0         return 0 if @t < @d;
266              
267 0           return join( '/', @d ) eq join( '/', splice @t, 0, +@d );
268             }
269              
270             sub rmtree {
271 0   0 0 1   my $old_style = !( @_ and __is_arg( $_[-1] ) );
272              
273 0           my ($arg, $data, $paths);
274              
275 0 0         if ($old_style) {
276 0           my ( $verbose, $safe );
277 0           ( $paths, $verbose, $safe ) = @_;
278 0           $data->{verbose} = $verbose;
279 0 0         $data->{safe} = defined $safe ? $safe : 0;
280              
281 0 0 0       if ( defined($paths) and length($paths) ) {
282 0 0         $paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' );
283             }
284             else {
285 0           _carp("No root path(s) specified\n");
286 0           return 0;
287             }
288             }
289             else {
290 0           my %args_permitted = map { $_ => 1 } ( qw|
  0            
291             error
292             keep_root
293             result
294             safe
295             verbose
296             | );
297 0           my @bad_args = ();
298 0           my $arg = pop @_;
299 0           for my $k (sort keys %{$arg}) {
  0            
300 0 0         if (! $args_permitted{$k}) {
301 0           push @bad_args, $k;
302             }
303             else {
304 0           $data->{$k} = $arg->{$k};
305             }
306             }
307 0 0         _carp("Unrecognized option(s) passed to remove_tree(): @bad_args")
308             if @bad_args;
309 0 0         ${ $data->{error} } = [] if exists $data->{error};
  0            
310 0 0         ${ $data->{result} } = [] if exists $data->{result};
  0            
311              
312             # Wouldn't it make sense to do some validation on @_ before assigning
313             # to $paths here?
314             # In the $old_style case we guarantee that each path is both defined
315             # and non-empty. We don't check that here, which means we have to
316             # check it later in the first condition in this line:
317             # if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) {
318             # Granted, that would be a change in behavior for the two
319             # non-old-style interfaces.
320              
321 0           $paths = [@_];
322             }
323              
324 0           $data->{prefix} = '';
325 0           $data->{depth} = 0;
326              
327 0           my @clean_path;
328 0 0         $data->{cwd} = getcwd() or do {
329 0           _error( $data, "cannot fetch initial working directory" );
330 0           return 0;
331             };
332 0           for ( $data->{cwd} ) { /\A(.*)\Z/s; $_ = $1 } # untaint
  0            
  0            
333              
334 0           for my $p (@$paths) {
335              
336             # need to fixup case and map \ to / on Windows
337 0           my $ortho_root = _IS_MSWIN32 ? _slash_lc($p) : $p;
338             my $ortho_cwd =
339 0           _IS_MSWIN32 ? _slash_lc( $data->{cwd} ) : $data->{cwd};
340 0           my $ortho_root_length = length($ortho_root);
341 0           $ortho_root_length-- if _IS_VMS; # don't compare '.' with ']'
342 0 0 0       if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) {
343 0           local $! = 0;
344 0           _error( $data, "cannot remove path when cwd is $data->{cwd}", $p );
345 0           next;
346             }
347              
348 0           if (_IS_MACOS) {
349             $p = ":$p" unless $p =~ /:/;
350             $p .= ":" unless $p =~ /:\z/;
351             }
352             elsif ( _IS_MSWIN32 ) {
353             $p =~ s{[/\\]\z}{};
354             }
355             else {
356 0           $p =~ s{/\z}{};
357             }
358 0           push @clean_path, $p;
359             }
360              
361 0 0         @{$data}{qw(device inode)} = ( lstat $data->{cwd} )[ 0, 1 ] or do {
  0            
362 0           _error( $data, "cannot stat initial working directory", $data->{cwd} );
363 0           return 0;
364             };
365              
366 0           return _rmtree( $data, \@clean_path );
367             }
368              
369             sub _rmtree {
370 0     0     my $data = shift;
371 0           my $paths = shift;
372              
373 0           my $count = 0;
374 0           my $curdir = File::Spec->curdir();
375 0           my $updir = File::Spec->updir();
376              
377 0           my ( @files, $root );
378             ROOT_DIR:
379 0           foreach my $root (@$paths) {
380              
381             # since we chdir into each directory, it may not be obvious
382             # to figure out where we are if we generate a message about
383             # a file name. We therefore construct a semi-canonical
384             # filename, anchored from the directory being unlinked (as
385             # opposed to being truly canonical, anchored from the root (/).
386              
387             my $canon =
388             $data->{prefix}
389 0 0         ? File::Spec->catfile( $data->{prefix}, $root )
390             : $root;
391              
392 0 0         my ( $ldev, $lino, $perm ) = ( lstat $root )[ 0, 1, 2 ]
393             or next ROOT_DIR;
394              
395 0 0         if ( -d _ ) {
396 0           $root = VMS::Filespec::vmspath( VMS::Filespec::pathify($root) )
397             if _IS_VMS;
398              
399 0 0         if ( !chdir($root) ) {
400              
401             # see if we can escalate privileges to get in
402             # (e.g. funny protection mask such as -w- instead of rwx)
403             # This uses fchmod to avoid traversing outside of the proper
404             # location (CVE-2017-6512)
405 0           my $root_fh;
406 0 0         if (open($root_fh, '<', $root)) {
407 0           my ($fh_dev, $fh_inode) = (stat $root_fh )[0,1];
408 0           $perm &= oct '7777';
409 0           my $nperm = $perm | oct '700';
410 0           local $@;
411 0 0 0       if (
      0        
      0        
      0        
      0        
412             !(
413             $data->{safe}
414             or $nperm == $perm
415             or !-d _
416             or $fh_dev ne $ldev
417             or $fh_inode ne $lino
418 0           or eval { chmod( $nperm, $root_fh ) }
419             )
420             )
421             {
422 0           _error( $data,
423             "cannot make child directory read-write-exec", $canon );
424 0           next ROOT_DIR;
425             }
426 0           close $root_fh;
427             }
428 0 0         if ( !chdir($root) ) {
429 0           _error( $data, "cannot chdir to child", $canon );
430 0           next ROOT_DIR;
431             }
432             }
433              
434             my ( $cur_dev, $cur_inode, $perm ) = ( stat $curdir )[ 0, 1, 2 ]
435 0 0         or do {
436 0           _error( $data, "cannot stat current working directory", $canon );
437 0           next ROOT_DIR;
438             };
439              
440 0           if (_NEED_STAT_CHECK) {
441 0 0 0       ( $ldev eq $cur_dev and $lino eq $cur_inode )
442             or _croak(
443             "directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting."
444             );
445             }
446              
447 0           $perm &= oct '7777'; # don't forget setuid, setgid, sticky bits
448 0           my $nperm = $perm | oct '700';
449              
450             # notabene: 0700 is for making readable in the first place,
451             # it's also intended to change it to writable in case we have
452             # to recurse in which case we are better than rm -rf for
453             # subtrees with strange permissions
454              
455 0 0 0       if (
      0        
456             !(
457             $data->{safe}
458             or $nperm == $perm
459             or chmod( $nperm, $curdir )
460             )
461             )
462             {
463 0           _error( $data, "cannot make directory read+writeable", $canon );
464 0           $nperm = $perm;
465             }
466              
467 0           my $d;
468 0 0         $d = gensym() if $] < 5.006;
469 0 0         if ( !opendir $d, $curdir ) {
470 0           _error( $data, "cannot opendir", $canon );
471 0           @files = ();
472             }
473             else {
474 0 0 0       if ( !defined ${^TAINT} or ${^TAINT} ) {
475             # Blindly untaint dir names if taint mode is active
476 0           @files = map { /\A(.*)\z/s; $1 } readdir $d;
  0            
  0            
477             }
478             else {
479 0           @files = readdir $d;
480             }
481 0           closedir $d;
482             }
483              
484 0           if (_IS_VMS) {
485              
486             # Deleting large numbers of files from VMS Files-11
487             # filesystems is faster if done in reverse ASCIIbetical order.
488             # include '.' to '.;' from blead patch #31775
489             @files = map { $_ eq '.' ? '.;' : $_ } reverse @files;
490             }
491              
492 0 0         @files = grep { $_ ne $updir and $_ ne $curdir } @files;
  0            
493              
494 0 0         if (@files) {
495              
496             # remove the contained files before the directory itself
497 0           my $narg = {%$data};
498 0           @{$narg}{qw(device inode cwd prefix depth)} =
499 0           ( $cur_dev, $cur_inode, $updir, $canon, $data->{depth} + 1 );
500 0           $count += _rmtree( $narg, \@files );
501             }
502              
503             # restore directory permissions of required now (in case the rmdir
504             # below fails), while we are still in the directory and may do so
505             # without a race via '.'
506 0 0 0       if ( $nperm != $perm and not chmod( $perm, $curdir ) ) {
507 0           _error( $data, "cannot reset chmod", $canon );
508             }
509              
510             # don't leave the client code in an unexpected directory
511             chdir( $data->{cwd} )
512 0 0         or
513             _croak("cannot chdir to $data->{cwd} from $canon: $!, aborting.");
514              
515             # ensure that a chdir upwards didn't take us somewhere other
516             # than we expected (see CVE-2002-0435)
517 0 0         ( $cur_dev, $cur_inode ) = ( stat $curdir )[ 0, 1 ]
518             or _croak(
519             "cannot stat prior working directory $data->{cwd}: $!, aborting."
520             );
521              
522 0           if (_NEED_STAT_CHECK) {
523 0 0 0       ( $data->{device} eq $cur_dev and $data->{inode} eq $cur_inode )
524             or _croak( "previous directory $data->{cwd} "
525             . "changed before entering $canon, "
526             . "expected dev=$ldev ino=$lino, "
527             . "actual dev=$cur_dev ino=$cur_inode, aborting."
528             );
529             }
530              
531 0 0 0       if ( $data->{depth} or !$data->{keep_root} ) {
532 0 0 0       if ( $data->{safe}
533             && ( _IS_VMS
534             ? !&VMS::Filespec::candelete($root)
535             : !-w $root ) )
536             {
537 0 0         print "skipped $root\n" if $data->{verbose};
538 0           next ROOT_DIR;
539             }
540 0           if ( _FORCE_WRITABLE and !chmod $perm | oct '700', $root ) {
541             _error( $data, "cannot make directory writeable", $canon );
542             }
543 0 0         print "rmdir $root\n" if $data->{verbose};
544 0 0         if ( rmdir $root ) {
545 0 0         push @{ ${ $data->{result} } }, $root if $data->{result};
  0            
  0            
546 0           ++$count;
547             }
548             else {
549 0           _error( $data, "cannot remove directory", $canon );
550 0           if (
551             _FORCE_WRITABLE
552             && !chmod( $perm,
553             ( _IS_VMS ? VMS::Filespec::fileify($root) : $root )
554             )
555             )
556             {
557             _error(
558             $data,
559             sprintf( "cannot restore permissions to 0%o",
560             $perm ),
561             $canon
562             );
563             }
564             }
565             }
566             }
567             else {
568             # not a directory
569 0           $root = VMS::Filespec::vmsify("./$root")
570             if _IS_VMS
571             && !File::Spec->file_name_is_absolute($root)
572             && ( $root !~ m/(?]+/ ); # not already in VMS syntax
573              
574 0 0 0       if (
      0        
575             $data->{safe}
576             && (
577             _IS_VMS
578             ? !&VMS::Filespec::candelete($root)
579             : !( -l $root || -w $root )
580             )
581             )
582             {
583 0 0         print "skipped $root\n" if $data->{verbose};
584 0           next ROOT_DIR;
585             }
586              
587 0           my $nperm = $perm & oct '7777' | oct '600';
588 0           if ( _FORCE_WRITABLE
589             and $nperm != $perm
590             and not chmod $nperm, $root )
591             {
592             _error( $data, "cannot make file writeable", $canon );
593             }
594 0 0         print "unlink $canon\n" if $data->{verbose};
595              
596             # delete all versions under VMS
597 0           for ( ; ; ) {
598 0 0         if ( unlink $root ) {
599 0 0         push @{ ${ $data->{result} } }, $root if $data->{result};
  0            
  0            
600             }
601             else {
602 0           _error( $data, "cannot unlink file", $canon );
603 0           _FORCE_WRITABLE and chmod( $perm, $root )
604             or _error( $data,
605             sprintf( "cannot restore permissions to 0%o", $perm ),
606             $canon );
607 0           last;
608             }
609 0           ++$count;
610 0           last unless _IS_VMS && lstat $root;
611             }
612             }
613             }
614 0           return $count;
615             }
616              
617             sub _slash_lc {
618              
619             # fix up slashes and case on MSWin32 so that we can determine that
620             # c:\path\to\dir is underneath C:/Path/To
621 0     0     my $path = shift;
622 0           $path =~ tr{\\}{/};
623 0           return lc($path);
624             }
625              
626             1;
627              
628             __END__