xref: /openbsd-src/gnu/usr.bin/perl/cpan/File-Path/lib/File/Path.pm (revision eac174f2741a08d8deb8aae59a7f778ef9b5d770)
1b39c5158Smillertpackage File::Path;
2b39c5158Smillert
3b39c5158Smillertuse 5.005_04;
4b39c5158Smillertuse strict;
5b39c5158Smillert
6b39c5158Smillertuse Cwd 'getcwd';
7b39c5158Smillertuse File::Basename ();
8b39c5158Smillertuse File::Spec     ();
9b39c5158Smillert
10b39c5158SmillertBEGIN {
11b39c5158Smillert    if ( $] < 5.006 ) {
12b8851fccSafresh1
13b39c5158Smillert        # can't say 'opendir my $dh, $dirname'
14b39c5158Smillert        # need to initialise $dh
15b8851fccSafresh1        eval 'use Symbol';
16b39c5158Smillert    }
17b39c5158Smillert}
18b39c5158Smillert
19b39c5158Smillertuse Exporter ();
20b39c5158Smillertuse vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
21*eac174f2Safresh1$VERSION   = '2.18';
22b8851fccSafresh1$VERSION   = eval $VERSION;
23b39c5158Smillert@ISA       = qw(Exporter);
24b39c5158Smillert@EXPORT    = qw(mkpath rmtree);
25b39c5158Smillert@EXPORT_OK = qw(make_path remove_tree);
26b39c5158Smillert
27b8851fccSafresh1BEGIN {
28b8851fccSafresh1  for (qw(VMS MacOS MSWin32 os2)) {
29b8851fccSafresh1    no strict 'refs';
30b8851fccSafresh1    *{"_IS_\U$_"} = $^O eq $_ ? sub () { 1 } : sub () { 0 };
31b8851fccSafresh1  }
32b39c5158Smillert
33b39c5158Smillert  # These OSes complain if you want to remove a file that you have no
34b39c5158Smillert  # write permission to:
35b8851fccSafresh1  *_FORCE_WRITABLE = (
36b8851fccSafresh1    grep { $^O eq $_ } qw(amigaos dos epoc MSWin32 MacOS os2)
37b8851fccSafresh1  ) ? sub () { 1 } : sub () { 0 };
38b39c5158Smillert
39b39c5158Smillert  # Unix-like systems need to stat each directory in order to detect
40b39c5158Smillert  # race condition. MS-Windows is immune to this particular attack.
41b8851fccSafresh1  *_NEED_STAT_CHECK = !(_IS_MSWIN32()) ? sub () { 1 } : sub () { 0 };
42b8851fccSafresh1}
43b39c5158Smillert
44b39c5158Smillertsub _carp {
45b39c5158Smillert    require Carp;
46b39c5158Smillert    goto &Carp::carp;
47b39c5158Smillert}
48b39c5158Smillert
49b39c5158Smillertsub _croak {
50b39c5158Smillert    require Carp;
51b39c5158Smillert    goto &Carp::croak;
52b39c5158Smillert}
53b39c5158Smillert
54b39c5158Smillertsub _error {
55b39c5158Smillert    my $arg     = shift;
56b39c5158Smillert    my $message = shift;
57b39c5158Smillert    my $object  = shift;
58b39c5158Smillert
59b39c5158Smillert    if ( $arg->{error} ) {
60b39c5158Smillert        $object = '' unless defined $object;
61b39c5158Smillert        $message .= ": $!" if $!;
62b39c5158Smillert        push @{ ${ $arg->{error} } }, { $object => $message };
63b39c5158Smillert    }
64b39c5158Smillert    else {
65b39c5158Smillert        _carp( defined($object) ? "$message for $object: $!" : "$message: $!" );
66b39c5158Smillert    }
67b39c5158Smillert}
68b39c5158Smillert
69b8851fccSafresh1sub __is_arg {
70b8851fccSafresh1    my ($arg) = @_;
71b8851fccSafresh1
72b8851fccSafresh1    # If client code blessed an array ref to HASH, this will not work
73b8851fccSafresh1    # properly. We could have done $arg->isa() wrapped in eval, but
74b8851fccSafresh1    # that would be expensive. This implementation should suffice.
75b8851fccSafresh1    # We could have also used Scalar::Util:blessed, but we choose not
76b8851fccSafresh1    # to add this dependency
77b8851fccSafresh1    return ( ref $arg eq 'HASH' );
78b8851fccSafresh1}
79b8851fccSafresh1
80b39c5158Smillertsub make_path {
81b8851fccSafresh1    push @_, {} unless @_ and __is_arg( $_[-1] );
82b39c5158Smillert    goto &mkpath;
83b39c5158Smillert}
84b39c5158Smillert
85b39c5158Smillertsub mkpath {
86b8851fccSafresh1    my $old_style = !( @_ and __is_arg( $_[-1] ) );
87b39c5158Smillert
882e109fb9Safresh1    my $data;
89b39c5158Smillert    my $paths;
90b39c5158Smillert
91b39c5158Smillert    if ($old_style) {
92b39c5158Smillert        my ( $verbose, $mode );
93b39c5158Smillert        ( $paths, $verbose, $mode ) = @_;
94b39c5158Smillert        $paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' );
952e109fb9Safresh1        $data->{verbose} = $verbose;
962e109fb9Safresh1        $data->{mode} = defined $mode ? $mode : oct '777';
97b39c5158Smillert    }
98b39c5158Smillert    else {
99b8851fccSafresh1        my %args_permitted = map { $_ => 1 } ( qw|
100b8851fccSafresh1            chmod
101b8851fccSafresh1            error
102b8851fccSafresh1            group
103b8851fccSafresh1            mask
104b8851fccSafresh1            mode
105b8851fccSafresh1            owner
106b8851fccSafresh1            uid
107b8851fccSafresh1            user
108b8851fccSafresh1            verbose
109b8851fccSafresh1        | );
1102e109fb9Safresh1        my %not_on_win32_args = map { $_ => 1 } ( qw|
1112e109fb9Safresh1            group
1122e109fb9Safresh1            owner
1132e109fb9Safresh1            uid
1142e109fb9Safresh1            user
1152e109fb9Safresh1        | );
116b8851fccSafresh1        my @bad_args = ();
1172e109fb9Safresh1        my @win32_implausible_args = ();
1182e109fb9Safresh1        my $arg = pop @_;
119b8851fccSafresh1        for my $k (sort keys %{$arg}) {
1202e109fb9Safresh1            if (! $args_permitted{$k}) {
1212e109fb9Safresh1                push @bad_args, $k;
122b8851fccSafresh1            }
1232e109fb9Safresh1            elsif ($not_on_win32_args{$k} and _IS_MSWIN32) {
1242e109fb9Safresh1                push @win32_implausible_args, $k;
1252e109fb9Safresh1            }
1262e109fb9Safresh1            else {
1272e109fb9Safresh1                $data->{$k} = $arg->{$k};
1282e109fb9Safresh1            }
1292e109fb9Safresh1        }
1302e109fb9Safresh1        _carp("Unrecognized option(s) passed to mkpath() or make_path(): @bad_args")
131b8851fccSafresh1            if @bad_args;
1322e109fb9Safresh1        _carp("Option(s) implausible on Win32 passed to mkpath() or make_path(): @win32_implausible_args")
1332e109fb9Safresh1            if @win32_implausible_args;
1342e109fb9Safresh1        $data->{mode} = delete $data->{mask} if exists $data->{mask};
1352e109fb9Safresh1        $data->{mode} = oct '777' unless exists $data->{mode};
1362e109fb9Safresh1        ${ $data->{error} } = [] if exists $data->{error};
1372e109fb9Safresh1        unless (@win32_implausible_args) {
1382e109fb9Safresh1            $data->{owner} = delete $data->{user} if exists $data->{user};
1392e109fb9Safresh1            $data->{owner} = delete $data->{uid}  if exists $data->{uid};
1402e109fb9Safresh1            if ( exists $data->{owner} and $data->{owner} =~ /\D/ ) {
1412e109fb9Safresh1                my $uid = ( getpwnam $data->{owner} )[2];
142b39c5158Smillert                if ( defined $uid ) {
1432e109fb9Safresh1                    $data->{owner} = $uid;
144b39c5158Smillert                }
145b39c5158Smillert                else {
1462e109fb9Safresh1                    _error( $data,
1472e109fb9Safresh1                            "unable to map $data->{owner} to a uid, ownership not changed"
148b8851fccSafresh1                          );
1492e109fb9Safresh1                    delete $data->{owner};
150b39c5158Smillert                }
151b39c5158Smillert            }
1522e109fb9Safresh1            if ( exists $data->{group} and $data->{group} =~ /\D/ ) {
1532e109fb9Safresh1                my $gid = ( getgrnam $data->{group} )[2];
154b39c5158Smillert                if ( defined $gid ) {
1552e109fb9Safresh1                    $data->{group} = $gid;
156b39c5158Smillert                }
157b39c5158Smillert                else {
1582e109fb9Safresh1                    _error( $data,
1592e109fb9Safresh1                            "unable to map $data->{group} to a gid, group ownership not changed"
160b8851fccSafresh1                    );
1612e109fb9Safresh1                    delete $data->{group};
162b39c5158Smillert                }
163b39c5158Smillert            }
1642e109fb9Safresh1            if ( exists $data->{owner} and not exists $data->{group} ) {
1652e109fb9Safresh1                $data->{group} = -1;    # chown will leave group unchanged
166b39c5158Smillert            }
1672e109fb9Safresh1            if ( exists $data->{group} and not exists $data->{owner} ) {
1682e109fb9Safresh1                $data->{owner} = -1;    # chown will leave owner unchanged
1692e109fb9Safresh1            }
170b39c5158Smillert        }
171b39c5158Smillert        $paths = [@_];
172b39c5158Smillert    }
1732e109fb9Safresh1    return _mkpath( $data, $paths );
174b39c5158Smillert}
175b39c5158Smillert
176b39c5158Smillertsub _mkpath {
1772e109fb9Safresh1    my $data   = shift;
178b39c5158Smillert    my $paths = shift;
179b39c5158Smillert
180b8851fccSafresh1    my ( @created );
181b8851fccSafresh1    foreach my $path ( @{$paths} ) {
182b39c5158Smillert        next unless defined($path) and length($path);
183b8851fccSafresh1        $path .= '/' if _IS_OS2 and $path =~ /^\w:\z/s; # feature of CRT
184b8851fccSafresh1
185b39c5158Smillert        # Logic wants Unix paths, so go with the flow.
186b8851fccSafresh1        if (_IS_VMS) {
187b39c5158Smillert            next if $path eq '/';
188b39c5158Smillert            $path = VMS::Filespec::unixify($path);
189b39c5158Smillert        }
190b39c5158Smillert        next if -d $path;
191b39c5158Smillert        my $parent = File::Basename::dirname($path);
1922e109fb9Safresh1        # Coverage note:  It's not clear how we would test the condition:
1932e109fb9Safresh1        # '-d $parent or $path eq $parent'
194b39c5158Smillert        unless ( -d $parent or $path eq $parent ) {
1952e109fb9Safresh1            push( @created, _mkpath( $data, [$parent] ) );
196b39c5158Smillert        }
1972e109fb9Safresh1        print "mkdir $path\n" if $data->{verbose};
1982e109fb9Safresh1        if ( mkdir( $path, $data->{mode} ) ) {
199b39c5158Smillert            push( @created, $path );
2002e109fb9Safresh1            if ( exists $data->{owner} ) {
201b8851fccSafresh1
2022e109fb9Safresh1                # NB: $data->{group} guaranteed to be set during initialisation
2032e109fb9Safresh1                if ( !chown $data->{owner}, $data->{group}, $path ) {
2042e109fb9Safresh1                    _error( $data,
2052e109fb9Safresh1                        "Cannot change ownership of $path to $data->{owner}:$data->{group}"
206b8851fccSafresh1                    );
207b8851fccSafresh1                }
208b8851fccSafresh1            }
2092e109fb9Safresh1            if ( exists $data->{chmod} ) {
2102e109fb9Safresh1                # Coverage note:  It's not clear how we would trigger the next
2112e109fb9Safresh1                # 'if' block.  Failure of 'chmod' might first result in a
2122e109fb9Safresh1                # system error: "Permission denied".
2132e109fb9Safresh1                if ( !chmod $data->{chmod}, $path ) {
2142e109fb9Safresh1                    _error( $data,
2152e109fb9Safresh1                        "Cannot change permissions of $path to $data->{chmod}" );
216b39c5158Smillert                }
217b39c5158Smillert            }
218b39c5158Smillert        }
219b39c5158Smillert        else {
220b39c5158Smillert            my $save_bang = $!;
2212e109fb9Safresh1
2222e109fb9Safresh1            # From 'perldoc perlvar': $EXTENDED_OS_ERROR ($^E) is documented
2232e109fb9Safresh1            # as:
2242e109fb9Safresh1            # Error information specific to the current operating system. At the
2252e109fb9Safresh1            # moment, this differs from "$!" under only VMS, OS/2, and Win32
2262e109fb9Safresh1            # (and for MacPerl). On all other platforms, $^E is always just the
2272e109fb9Safresh1            # same as $!.
2282e109fb9Safresh1
229b39c5158Smillert            my ( $e, $e1 ) = ( $save_bang, $^E );
230b39c5158Smillert            $e .= "; $e1" if $e ne $e1;
231b8851fccSafresh1
232b39c5158Smillert            # allow for another process to have created it meanwhile
233b39c5158Smillert            if ( ! -d $path ) {
234b39c5158Smillert                $! = $save_bang;
2352e109fb9Safresh1                if ( $data->{error} ) {
2362e109fb9Safresh1                    push @{ ${ $data->{error} } }, { $path => $e };
237b39c5158Smillert                }
238b39c5158Smillert                else {
239b39c5158Smillert                    _croak("mkdir $path: $e");
240b39c5158Smillert                }
241b39c5158Smillert            }
242b39c5158Smillert        }
243b39c5158Smillert    }
244b39c5158Smillert    return @created;
245b39c5158Smillert}
246b39c5158Smillert
247b39c5158Smillertsub remove_tree {
248b8851fccSafresh1    push @_, {} unless @_ and __is_arg( $_[-1] );
249b39c5158Smillert    goto &rmtree;
250b39c5158Smillert}
251b39c5158Smillert
252b39c5158Smillertsub _is_subdir {
253b39c5158Smillert    my ( $dir, $test ) = @_;
254b39c5158Smillert
255b39c5158Smillert    my ( $dv, $dd ) = File::Spec->splitpath( $dir,  1 );
256b39c5158Smillert    my ( $tv, $td ) = File::Spec->splitpath( $test, 1 );
257b39c5158Smillert
258b39c5158Smillert    # not on same volume
259b39c5158Smillert    return 0 if $dv ne $tv;
260b39c5158Smillert
261b39c5158Smillert    my @d = File::Spec->splitdir($dd);
262b39c5158Smillert    my @t = File::Spec->splitdir($td);
263b39c5158Smillert
264b39c5158Smillert    # @t can't be a subdir if it's shorter than @d
265b39c5158Smillert    return 0 if @t < @d;
266b39c5158Smillert
267b39c5158Smillert    return join( '/', @d ) eq join( '/', splice @t, 0, +@d );
268b39c5158Smillert}
269b39c5158Smillert
270b39c5158Smillertsub rmtree {
271b8851fccSafresh1    my $old_style = !( @_ and __is_arg( $_[-1] ) );
272b39c5158Smillert
2732e109fb9Safresh1    my ($arg, $data, $paths);
274b39c5158Smillert
275b39c5158Smillert    if ($old_style) {
276b39c5158Smillert        my ( $verbose, $safe );
277b39c5158Smillert        ( $paths, $verbose, $safe ) = @_;
2782e109fb9Safresh1        $data->{verbose} = $verbose;
2792e109fb9Safresh1        $data->{safe} = defined $safe ? $safe : 0;
280b39c5158Smillert
281b39c5158Smillert        if ( defined($paths) and length($paths) ) {
282b39c5158Smillert            $paths = [$paths] unless UNIVERSAL::isa( $paths, 'ARRAY' );
283b39c5158Smillert        }
284b39c5158Smillert        else {
285b39c5158Smillert            _carp("No root path(s) specified\n");
286b39c5158Smillert            return 0;
287b39c5158Smillert        }
288b39c5158Smillert    }
289b39c5158Smillert    else {
290b8851fccSafresh1        my %args_permitted = map { $_ => 1 } ( qw|
291b8851fccSafresh1            error
292b8851fccSafresh1            keep_root
293b8851fccSafresh1            result
294b8851fccSafresh1            safe
295b8851fccSafresh1            verbose
296b8851fccSafresh1        | );
297b8851fccSafresh1        my @bad_args = ();
2982e109fb9Safresh1        my $arg = pop @_;
299b8851fccSafresh1        for my $k (sort keys %{$arg}) {
3002e109fb9Safresh1            if (! $args_permitted{$k}) {
3012e109fb9Safresh1                push @bad_args, $k;
3022e109fb9Safresh1            }
3032e109fb9Safresh1            else {
3042e109fb9Safresh1                $data->{$k} = $arg->{$k};
3052e109fb9Safresh1            }
306b8851fccSafresh1        }
307b8851fccSafresh1        _carp("Unrecognized option(s) passed to remove_tree(): @bad_args")
308b8851fccSafresh1            if @bad_args;
3092e109fb9Safresh1        ${ $data->{error} }  = [] if exists $data->{error};
3102e109fb9Safresh1        ${ $data->{result} } = [] if exists $data->{result};
3112e109fb9Safresh1
3122e109fb9Safresh1        # Wouldn't it make sense to do some validation on @_ before assigning
3132e109fb9Safresh1        # to $paths here?
3142e109fb9Safresh1        # In the $old_style case we guarantee that each path is both defined
3152e109fb9Safresh1        # and non-empty.  We don't check that here, which means we have to
3162e109fb9Safresh1        # check it later in the first condition in this line:
3172e109fb9Safresh1        #     if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) {
3182e109fb9Safresh1        # Granted, that would be a change in behavior for the two
3192e109fb9Safresh1        # non-old-style interfaces.
3202e109fb9Safresh1
321b39c5158Smillert        $paths = [@_];
322b39c5158Smillert    }
323b39c5158Smillert
3242e109fb9Safresh1    $data->{prefix} = '';
3252e109fb9Safresh1    $data->{depth}  = 0;
326b39c5158Smillert
327b39c5158Smillert    my @clean_path;
3282e109fb9Safresh1    $data->{cwd} = getcwd() or do {
3292e109fb9Safresh1        _error( $data, "cannot fetch initial working directory" );
330b39c5158Smillert        return 0;
331b39c5158Smillert    };
3322e109fb9Safresh1    for ( $data->{cwd} ) { /\A(.*)\Z/s; $_ = $1 }    # untaint
333b39c5158Smillert
334b39c5158Smillert    for my $p (@$paths) {
335b8851fccSafresh1
336b39c5158Smillert        # need to fixup case and map \ to / on Windows
337b8851fccSafresh1        my $ortho_root = _IS_MSWIN32 ? _slash_lc($p) : $p;
338b8851fccSafresh1        my $ortho_cwd =
3392e109fb9Safresh1          _IS_MSWIN32 ? _slash_lc( $data->{cwd} ) : $data->{cwd};
340b39c5158Smillert        my $ortho_root_length = length($ortho_root);
341b8851fccSafresh1        $ortho_root_length-- if _IS_VMS;   # don't compare '.' with ']'
342b39c5158Smillert        if ( $ortho_root_length && _is_subdir( $ortho_root, $ortho_cwd ) ) {
343b39c5158Smillert            local $! = 0;
3442e109fb9Safresh1            _error( $data, "cannot remove path when cwd is $data->{cwd}", $p );
345b39c5158Smillert            next;
346b39c5158Smillert        }
347b39c5158Smillert
348b8851fccSafresh1        if (_IS_MACOS) {
349b39c5158Smillert            $p = ":$p" unless $p =~ /:/;
350b39c5158Smillert            $p .= ":" unless $p =~ /:\z/;
351b39c5158Smillert        }
352b8851fccSafresh1        elsif ( _IS_MSWIN32 ) {
353b39c5158Smillert            $p =~ s{[/\\]\z}{};
354b39c5158Smillert        }
355b39c5158Smillert        else {
356b39c5158Smillert            $p =~ s{/\z}{};
357b39c5158Smillert        }
358b39c5158Smillert        push @clean_path, $p;
359b39c5158Smillert    }
360b39c5158Smillert
3612e109fb9Safresh1    @{$data}{qw(device inode)} = ( lstat $data->{cwd} )[ 0, 1 ] or do {
3622e109fb9Safresh1        _error( $data, "cannot stat initial working directory", $data->{cwd} );
363b39c5158Smillert        return 0;
364b39c5158Smillert    };
365b39c5158Smillert
3662e109fb9Safresh1    return _rmtree( $data, \@clean_path );
367b39c5158Smillert}
368b39c5158Smillert
369b39c5158Smillertsub _rmtree {
3702e109fb9Safresh1    my $data   = shift;
371b39c5158Smillert    my $paths = shift;
372b39c5158Smillert
373b39c5158Smillert    my $count  = 0;
374b39c5158Smillert    my $curdir = File::Spec->curdir();
375b39c5158Smillert    my $updir  = File::Spec->updir();
376b39c5158Smillert
377b39c5158Smillert    my ( @files, $root );
378b39c5158Smillert  ROOT_DIR:
379b8851fccSafresh1    foreach my $root (@$paths) {
380b8851fccSafresh1
381b39c5158Smillert        # since we chdir into each directory, it may not be obvious
382b39c5158Smillert        # to figure out where we are if we generate a message about
383b39c5158Smillert        # a file name. We therefore construct a semi-canonical
384b39c5158Smillert        # filename, anchored from the directory being unlinked (as
385b39c5158Smillert        # opposed to being truly canonical, anchored from the root (/).
386b39c5158Smillert
387b8851fccSafresh1        my $canon =
3882e109fb9Safresh1          $data->{prefix}
3892e109fb9Safresh1          ? File::Spec->catfile( $data->{prefix}, $root )
390b8851fccSafresh1          : $root;
391b39c5158Smillert
392b8851fccSafresh1        my ( $ldev, $lino, $perm ) = ( lstat $root )[ 0, 1, 2 ]
393b8851fccSafresh1          or next ROOT_DIR;
394b39c5158Smillert
395b39c5158Smillert        if ( -d _ ) {
396b8851fccSafresh1            $root = VMS::Filespec::vmspath( VMS::Filespec::pathify($root) )
397b8851fccSafresh1              if _IS_VMS;
398b39c5158Smillert
399b39c5158Smillert            if ( !chdir($root) ) {
400b8851fccSafresh1
401b39c5158Smillert                # see if we can escalate privileges to get in
402b39c5158Smillert                # (e.g. funny protection mask such as -w- instead of rwx)
4032e109fb9Safresh1                # This uses fchmod to avoid traversing outside of the proper
4042e109fb9Safresh1                # location (CVE-2017-6512)
4052e109fb9Safresh1                my $root_fh;
4062e109fb9Safresh1                if (open($root_fh, '<', $root)) {
4072e109fb9Safresh1                    my ($fh_dev, $fh_inode) = (stat $root_fh )[0,1];
408b8851fccSafresh1                    $perm &= oct '7777';
409b8851fccSafresh1                    my $nperm = $perm | oct '700';
4102e109fb9Safresh1                    local $@;
411b8851fccSafresh1                    if (
412b8851fccSafresh1                        !(
4132e109fb9Safresh1                            $data->{safe}
414b8851fccSafresh1                           or $nperm == $perm
4152e109fb9Safresh1                           or !-d _
4162e109fb9Safresh1                           or $fh_dev ne $ldev
4172e109fb9Safresh1                           or $fh_inode ne $lino
4182e109fb9Safresh1                           or eval { chmod( $nperm, $root_fh ) }
419b8851fccSafresh1                        )
420b8851fccSafresh1                      )
421b8851fccSafresh1                    {
4222e109fb9Safresh1                        _error( $data,
423b8851fccSafresh1                            "cannot make child directory read-write-exec", $canon );
424b39c5158Smillert                        next ROOT_DIR;
425b39c5158Smillert                    }
4262e109fb9Safresh1                    close $root_fh;
4272e109fb9Safresh1                }
4282e109fb9Safresh1                if ( !chdir($root) ) {
4292e109fb9Safresh1                    _error( $data, "cannot chdir to child", $canon );
430b39c5158Smillert                    next ROOT_DIR;
431b39c5158Smillert                }
432b39c5158Smillert            }
433b39c5158Smillert
434b8851fccSafresh1            my ( $cur_dev, $cur_inode, $perm ) = ( stat $curdir )[ 0, 1, 2 ]
435b8851fccSafresh1              or do {
4362e109fb9Safresh1                _error( $data, "cannot stat current working directory", $canon );
437b39c5158Smillert                next ROOT_DIR;
438b39c5158Smillert              };
439b39c5158Smillert
440b8851fccSafresh1            if (_NEED_STAT_CHECK) {
441b39c5158Smillert                ( $ldev eq $cur_dev and $lino eq $cur_inode )
442b8851fccSafresh1                  or _croak(
443b8851fccSafresh1"directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting."
444b8851fccSafresh1                  );
445b39c5158Smillert            }
446b39c5158Smillert
447b8851fccSafresh1            $perm &= oct '7777';    # don't forget setuid, setgid, sticky bits
448b8851fccSafresh1            my $nperm = $perm | oct '700';
449b39c5158Smillert
450b39c5158Smillert            # notabene: 0700 is for making readable in the first place,
451b39c5158Smillert            # it's also intended to change it to writable in case we have
452b39c5158Smillert            # to recurse in which case we are better than rm -rf for
453b39c5158Smillert            # subtrees with strange permissions
454b39c5158Smillert
455b8851fccSafresh1            if (
456b8851fccSafresh1                !(
4572e109fb9Safresh1                       $data->{safe}
458b8851fccSafresh1                    or $nperm == $perm
459b8851fccSafresh1                    or chmod( $nperm, $curdir )
460b8851fccSafresh1                )
461b8851fccSafresh1              )
462b8851fccSafresh1            {
4632e109fb9Safresh1                _error( $data, "cannot make directory read+writeable", $canon );
464b39c5158Smillert                $nperm = $perm;
465b39c5158Smillert            }
466b39c5158Smillert
467b39c5158Smillert            my $d;
468b39c5158Smillert            $d = gensym() if $] < 5.006;
469b39c5158Smillert            if ( !opendir $d, $curdir ) {
4702e109fb9Safresh1                _error( $data, "cannot opendir", $canon );
471b39c5158Smillert                @files = ();
472b39c5158Smillert            }
473b39c5158Smillert            else {
474b8851fccSafresh1                if ( !defined ${^TAINT} or ${^TAINT} ) {
475b8851fccSafresh1                    # Blindly untaint dir names if taint mode is active
476b39c5158Smillert                    @files = map { /\A(.*)\z/s; $1 } readdir $d;
477b39c5158Smillert                }
478b39c5158Smillert                else {
479b39c5158Smillert                    @files = readdir $d;
480b39c5158Smillert                }
481b39c5158Smillert                closedir $d;
482b39c5158Smillert            }
483b39c5158Smillert
484b8851fccSafresh1            if (_IS_VMS) {
485b8851fccSafresh1
486b39c5158Smillert                # Deleting large numbers of files from VMS Files-11
487b39c5158Smillert                # filesystems is faster if done in reverse ASCIIbetical order.
488b39c5158Smillert                # include '.' to '.;' from blead patch #31775
489b39c5158Smillert                @files = map { $_ eq '.' ? '.;' : $_ } reverse @files;
490b39c5158Smillert            }
491b39c5158Smillert
492b39c5158Smillert            @files = grep { $_ ne $updir and $_ ne $curdir } @files;
493b39c5158Smillert
494b39c5158Smillert            if (@files) {
495b8851fccSafresh1
496b39c5158Smillert                # remove the contained files before the directory itself
4972e109fb9Safresh1                my $narg = {%$data};
498b8851fccSafresh1                @{$narg}{qw(device inode cwd prefix depth)} =
4992e109fb9Safresh1                  ( $cur_dev, $cur_inode, $updir, $canon, $data->{depth} + 1 );
500b39c5158Smillert                $count += _rmtree( $narg, \@files );
501b39c5158Smillert            }
502b39c5158Smillert
503b39c5158Smillert            # restore directory permissions of required now (in case the rmdir
504b39c5158Smillert            # below fails), while we are still in the directory and may do so
505b39c5158Smillert            # without a race via '.'
506b39c5158Smillert            if ( $nperm != $perm and not chmod( $perm, $curdir ) ) {
5072e109fb9Safresh1                _error( $data, "cannot reset chmod", $canon );
508b39c5158Smillert            }
509b39c5158Smillert
510b39c5158Smillert            # don't leave the client code in an unexpected directory
5112e109fb9Safresh1            chdir( $data->{cwd} )
512b8851fccSafresh1              or
5132e109fb9Safresh1              _croak("cannot chdir to $data->{cwd} from $canon: $!, aborting.");
514b39c5158Smillert
515b39c5158Smillert            # ensure that a chdir upwards didn't take us somewhere other
516b39c5158Smillert            # than we expected (see CVE-2002-0435)
517b39c5158Smillert            ( $cur_dev, $cur_inode ) = ( stat $curdir )[ 0, 1 ]
518b8851fccSafresh1              or _croak(
5192e109fb9Safresh1                "cannot stat prior working directory $data->{cwd}: $!, aborting."
520b8851fccSafresh1              );
521b39c5158Smillert
522b8851fccSafresh1            if (_NEED_STAT_CHECK) {
5232e109fb9Safresh1                ( $data->{device} eq $cur_dev and $data->{inode} eq $cur_inode )
5242e109fb9Safresh1                  or _croak(  "previous directory $data->{cwd} "
525b8851fccSafresh1                            . "changed before entering $canon, "
526b8851fccSafresh1                            . "expected dev=$ldev ino=$lino, "
527b8851fccSafresh1                            . "actual dev=$cur_dev ino=$cur_inode, aborting."
528b8851fccSafresh1                  );
529b39c5158Smillert            }
530b39c5158Smillert
5312e109fb9Safresh1            if ( $data->{depth} or !$data->{keep_root} ) {
5322e109fb9Safresh1                if ( $data->{safe}
533b8851fccSafresh1                    && ( _IS_VMS
534b8851fccSafresh1                        ? !&VMS::Filespec::candelete($root)
535b8851fccSafresh1                        : !-w $root ) )
536b8851fccSafresh1                {
5372e109fb9Safresh1                    print "skipped $root\n" if $data->{verbose};
538b39c5158Smillert                    next ROOT_DIR;
539b39c5158Smillert                }
540b8851fccSafresh1                if ( _FORCE_WRITABLE and !chmod $perm | oct '700', $root ) {
5412e109fb9Safresh1                    _error( $data, "cannot make directory writeable", $canon );
542b39c5158Smillert                }
5432e109fb9Safresh1                print "rmdir $root\n" if $data->{verbose};
544b39c5158Smillert                if ( rmdir $root ) {
5452e109fb9Safresh1                    push @{ ${ $data->{result} } }, $root if $data->{result};
546b39c5158Smillert                    ++$count;
547b39c5158Smillert                }
548b39c5158Smillert                else {
5492e109fb9Safresh1                    _error( $data, "cannot remove directory", $canon );
550b8851fccSafresh1                    if (
551b8851fccSafresh1                        _FORCE_WRITABLE
552b8851fccSafresh1                        && !chmod( $perm,
553b8851fccSafresh1                            ( _IS_VMS ? VMS::Filespec::fileify($root) : $root )
554b8851fccSafresh1                        )
555b8851fccSafresh1                      )
556b8851fccSafresh1                    {
557b8851fccSafresh1                        _error(
5582e109fb9Safresh1                            $data,
559b8851fccSafresh1                            sprintf( "cannot restore permissions to 0%o",
560b8851fccSafresh1                                $perm ),
561b8851fccSafresh1                            $canon
562b8851fccSafresh1                        );
563b39c5158Smillert                    }
564b39c5158Smillert                }
565b39c5158Smillert            }
566b39c5158Smillert        }
567b39c5158Smillert        else {
568b39c5158Smillert            # not a directory
569b39c5158Smillert            $root = VMS::Filespec::vmsify("./$root")
570b8851fccSafresh1              if _IS_VMS
571b39c5158Smillert              && !File::Spec->file_name_is_absolute($root)
572b39c5158Smillert              && ( $root !~ m/(?<!\^)[\]>]+/ );    # not already in VMS syntax
573b39c5158Smillert
574b8851fccSafresh1            if (
5752e109fb9Safresh1                $data->{safe}
576b8851fccSafresh1                && (
577b8851fccSafresh1                    _IS_VMS
578b8851fccSafresh1                    ? !&VMS::Filespec::candelete($root)
579b8851fccSafresh1                    : !( -l $root || -w $root )
580b8851fccSafresh1                )
581b8851fccSafresh1              )
582b39c5158Smillert            {
5832e109fb9Safresh1                print "skipped $root\n" if $data->{verbose};
584b39c5158Smillert                next ROOT_DIR;
585b39c5158Smillert            }
586b39c5158Smillert
587b8851fccSafresh1            my $nperm = $perm & oct '7777' | oct '600';
588b8851fccSafresh1            if (    _FORCE_WRITABLE
589b8851fccSafresh1                and $nperm != $perm
590b8851fccSafresh1                and not chmod $nperm, $root )
591b8851fccSafresh1            {
5922e109fb9Safresh1                _error( $data, "cannot make file writeable", $canon );
593b39c5158Smillert            }
5942e109fb9Safresh1            print "unlink $canon\n" if $data->{verbose};
595b8851fccSafresh1
596b39c5158Smillert            # delete all versions under VMS
597b39c5158Smillert            for ( ; ; ) {
598b39c5158Smillert                if ( unlink $root ) {
5992e109fb9Safresh1                    push @{ ${ $data->{result} } }, $root if $data->{result};
600b39c5158Smillert                }
601b39c5158Smillert                else {
6022e109fb9Safresh1                    _error( $data, "cannot unlink file", $canon );
603b8851fccSafresh1                    _FORCE_WRITABLE and chmod( $perm, $root )
6042e109fb9Safresh1                      or _error( $data,
605b8851fccSafresh1                        sprintf( "cannot restore permissions to 0%o", $perm ),
606b8851fccSafresh1                        $canon );
607b39c5158Smillert                    last;
608b39c5158Smillert                }
609b39c5158Smillert                ++$count;
610b8851fccSafresh1                last unless _IS_VMS && lstat $root;
611b39c5158Smillert            }
612b39c5158Smillert        }
613b39c5158Smillert    }
614b39c5158Smillert    return $count;
615b39c5158Smillert}
616b39c5158Smillert
617b39c5158Smillertsub _slash_lc {
618b8851fccSafresh1
619b39c5158Smillert    # fix up slashes and case on MSWin32 so that we can determine that
620b39c5158Smillert    # c:\path\to\dir is underneath C:/Path/To
621b39c5158Smillert    my $path = shift;
622b39c5158Smillert    $path =~ tr{\\}{/};
623b39c5158Smillert    return lc($path);
624b39c5158Smillert}
625b39c5158Smillert
626b39c5158Smillert1;
627b8851fccSafresh1
628b39c5158Smillert__END__
629b39c5158Smillert
630b39c5158Smillert=head1 NAME
631b39c5158Smillert
632b39c5158SmillertFile::Path - Create or remove directory trees
633b39c5158Smillert
634b39c5158Smillert=head1 VERSION
635b39c5158Smillert
636*eac174f2Safresh12.18 - released November 4 2020.
637b39c5158Smillert
638b39c5158Smillert=head1 SYNOPSIS
639b39c5158Smillert
640b39c5158Smillert    use File::Path qw(make_path remove_tree);
641b39c5158Smillert
642b8851fccSafresh1    @created = make_path('foo/bar/baz', '/zug/zwang');
643b8851fccSafresh1    @created = make_path('foo/bar/baz', '/zug/zwang', {
644b39c5158Smillert        verbose => 1,
645b39c5158Smillert        mode => 0711,
646b39c5158Smillert    });
647b8851fccSafresh1    make_path('foo/bar/baz', '/zug/zwang', {
648b8851fccSafresh1        chmod => 0777,
649b8851fccSafresh1    });
650b39c5158Smillert
651b8851fccSafresh1    $removed_count = remove_tree('foo/bar/baz', '/zug/zwang', {
652b39c5158Smillert        verbose => 1,
653b39c5158Smillert        error  => \my $err_list,
6542e109fb9Safresh1        safe => 1,
655b39c5158Smillert    });
656b39c5158Smillert
657b39c5158Smillert    # legacy (interface promoted before v2.00)
658b8851fccSafresh1    @created = mkpath('/foo/bar/baz');
659b8851fccSafresh1    @created = mkpath('/foo/bar/baz', 1, 0711);
660b8851fccSafresh1    @created = mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);
661b8851fccSafresh1    $removed_count = rmtree('foo/bar/baz', 1, 1);
662b8851fccSafresh1    $removed_count = rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);
663b39c5158Smillert
664b39c5158Smillert    # legacy (interface promoted before v2.06)
665b8851fccSafresh1    @created = mkpath('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 });
666b8851fccSafresh1    $removed_count = rmtree('foo/bar/baz', '/zug/zwang', { verbose => 1, mode => 0711 });
667b39c5158Smillert
668b39c5158Smillert=head1 DESCRIPTION
669b39c5158Smillert
6702e109fb9Safresh1This module provides a convenient way to create directories of
671b39c5158Smillertarbitrary depth and to delete an entire directory subtree from the
672b39c5158Smillertfilesystem.
673b39c5158Smillert
674b39c5158SmillertThe following functions are provided:
675b39c5158Smillert
676b39c5158Smillert=over
677b39c5158Smillert
678b39c5158Smillert=item make_path( $dir1, $dir2, .... )
679b39c5158Smillert
680b39c5158Smillert=item make_path( $dir1, $dir2, ...., \%opts )
681b39c5158Smillert
682b39c5158SmillertThe C<make_path> function creates the given directories if they don't
6832e109fb9Safresh1exist before, much like the Unix command C<mkdir -p>.
684b39c5158Smillert
685b39c5158SmillertThe function accepts a list of directories to be created. Its
686b39c5158Smillertbehaviour may be tuned by an optional hashref appearing as the last
687b39c5158Smillertparameter on the call.
688b39c5158Smillert
689b39c5158SmillertThe function returns the list of directories actually created during
690b39c5158Smillertthe call; in scalar context the number of directories created.
691b39c5158Smillert
692b39c5158SmillertThe following keys are recognised in the option hash:
693b39c5158Smillert
694b39c5158Smillert=over
695b39c5158Smillert
696b39c5158Smillert=item mode => $num
697b39c5158Smillert
698b39c5158SmillertThe numeric permissions mode to apply to each created directory
6992e109fb9Safresh1(defaults to C<0777>), to be modified by the current C<umask>. If the
700b39c5158Smillertdirectory already exists (and thus does not need to be created),
701b39c5158Smillertthe permissions will not be modified.
702b39c5158Smillert
703b39c5158SmillertC<mask> is recognised as an alias for this parameter.
704b39c5158Smillert
705b8851fccSafresh1=item chmod => $num
706b8851fccSafresh1
707b8851fccSafresh1Takes a numeric mode to apply to each created directory (not
708b8851fccSafresh1modified by the current C<umask>). If the directory already exists
709b8851fccSafresh1(and thus does not need to be created), the permissions will
710b8851fccSafresh1not be modified.
711b8851fccSafresh1
712b39c5158Smillert=item verbose => $bool
713b39c5158Smillert
714b39c5158SmillertIf present, will cause C<make_path> to print the name of each directory
715b39c5158Smillertas it is created. By default nothing is printed.
716b39c5158Smillert
717b39c5158Smillert=item error => \$err
718b39c5158Smillert
719b39c5158SmillertIf present, it should be a reference to a scalar.
720b39c5158SmillertThis scalar will be made to reference an array, which will
721b39c5158Smillertbe used to store any errors that are encountered.  See the L</"ERROR
722b39c5158SmillertHANDLING"> section for more information.
723b39c5158Smillert
724b39c5158SmillertIf this parameter is not used, certain error conditions may raise
725b8851fccSafresh1a fatal error that will cause the program to halt, unless trapped
726b39c5158Smillertin an C<eval> block.
727b39c5158Smillert
728b39c5158Smillert=item owner => $owner
729b39c5158Smillert
730b39c5158Smillert=item user => $owner
731b39c5158Smillert
732b39c5158Smillert=item uid => $owner
733b39c5158Smillert
734b39c5158SmillertIf present, will cause any created directory to be owned by C<$owner>.
7352e109fb9Safresh1If the value is numeric, it will be interpreted as a uid; otherwise a
7362e109fb9Safresh1username is assumed. An error will be issued if the username cannot be
7372e109fb9Safresh1mapped to a uid, the uid does not exist or the process lacks the
738b39c5158Smillertprivileges to change ownership.
739b39c5158Smillert
740b8851fccSafresh1Ownership of directories that already exist will not be changed.
741b39c5158Smillert
742b39c5158SmillertC<user> and C<uid> are aliases of C<owner>.
743b39c5158Smillert
744b39c5158Smillert=item group => $group
745b39c5158Smillert
7462e109fb9Safresh1If present, will cause any created directory to be owned by the group
7472e109fb9Safresh1C<$group>.  If the value is numeric, it will be interpreted as a gid;
7482e109fb9Safresh1otherwise a group name is assumed. An error will be issued if the
7492e109fb9Safresh1group name cannot be mapped to a gid, the gid does not exist or the
7502e109fb9Safresh1process lacks the privileges to change group ownership.
751b39c5158Smillert
752b8851fccSafresh1Group ownership of directories that already exist will not be changed.
753b39c5158Smillert
754b39c5158Smillert    make_path '/var/tmp/webcache', {owner=>'nobody', group=>'nogroup'};
755b39c5158Smillert
756b39c5158Smillert=back
757b39c5158Smillert
758b39c5158Smillert=item mkpath( $dir )
759b39c5158Smillert
760b39c5158Smillert=item mkpath( $dir, $verbose, $mode )
761b39c5158Smillert
762b39c5158Smillert=item mkpath( [$dir1, $dir2,...], $verbose, $mode )
763b39c5158Smillert
764b39c5158Smillert=item mkpath( $dir1, $dir2,..., \%opt )
765b39c5158Smillert
7662e109fb9Safresh1The C<mkpath()> function provide the legacy interface of
7672e109fb9Safresh1C<make_path()> with a different interpretation of the arguments
7682e109fb9Safresh1passed.  The behaviour and return value of the function is otherwise
7692e109fb9Safresh1identical to C<make_path()>.
770b39c5158Smillert
771b39c5158Smillert=item remove_tree( $dir1, $dir2, .... )
772b39c5158Smillert
773b39c5158Smillert=item remove_tree( $dir1, $dir2, ...., \%opts )
774b39c5158Smillert
775b39c5158SmillertThe C<remove_tree> function deletes the given directories and any
776b39c5158Smillertfiles and subdirectories they might contain, much like the Unix
7779f11ffb7Safresh1command C<rm -rf> or the Windows commands C<rmdir /s> and C<rd /s>.
778b39c5158Smillert
7799f11ffb7Safresh1The function accepts a list of directories to be removed. (In point of fact,
7809f11ffb7Safresh1it will also accept filesystem entries which are not directories, such as
7819f11ffb7Safresh1regular files and symlinks.  But, as its name suggests, its intent is to
7829f11ffb7Safresh1remove trees rather than individual files.)
7839f11ffb7Safresh1
7849f11ffb7Safresh1C<remove_tree()>'s behaviour may be tuned by an optional hashref
785b8851fccSafresh1appearing as the last parameter on the call.  If an empty string is
786b8851fccSafresh1passed to C<remove_tree>, an error will occur.
787b39c5158Smillert
7882e109fb9Safresh1B<NOTE:>  For security reasons, we strongly advise use of the
7892e109fb9Safresh1hashref-as-final-argument syntax -- specifically, with a setting of the C<safe>
7902e109fb9Safresh1element to a true value.
7912e109fb9Safresh1
7922e109fb9Safresh1    remove_tree( $dir1, $dir2, ....,
7932e109fb9Safresh1        {
7942e109fb9Safresh1            safe => 1,
7952e109fb9Safresh1            ...         # other key-value pairs
7962e109fb9Safresh1        },
7972e109fb9Safresh1    );
7982e109fb9Safresh1
7992e109fb9Safresh1The function returns the number of files successfully deleted.
800b39c5158Smillert
801b39c5158SmillertThe following keys are recognised in the option hash:
802b39c5158Smillert
803b39c5158Smillert=over
804b39c5158Smillert
805b39c5158Smillert=item verbose => $bool
806b39c5158Smillert
807b39c5158SmillertIf present, will cause C<remove_tree> to print the name of each file as
808b39c5158Smillertit is unlinked. By default nothing is printed.
809b39c5158Smillert
810b39c5158Smillert=item safe => $bool
811b39c5158Smillert
812b39c5158SmillertWhen set to a true value, will cause C<remove_tree> to skip the files
813b39c5158Smillertfor which the process lacks the required privileges needed to delete
814b39c5158Smillertfiles, such as delete privileges on VMS. In other words, the code
815b39c5158Smillertwill make no attempt to alter file permissions. Thus, if the process
816b39c5158Smillertis interrupted, no filesystem object will be left in a more
817b39c5158Smillertpermissive mode.
818b39c5158Smillert
819b39c5158Smillert=item keep_root => $bool
820b39c5158Smillert
821b39c5158SmillertWhen set to a true value, will cause all files and subdirectories
822b39c5158Smillertto be removed, except the initially specified directories. This comes
823b39c5158Smillertin handy when cleaning out an application's scratch directory.
824b39c5158Smillert
825b39c5158Smillert    remove_tree( '/tmp', {keep_root => 1} );
826b39c5158Smillert
827b39c5158Smillert=item result => \$res
828b39c5158Smillert
829b39c5158SmillertIf present, it should be a reference to a scalar.
830b39c5158SmillertThis scalar will be made to reference an array, which will
831b39c5158Smillertbe used to store all files and directories unlinked
832b39c5158Smillertduring the call. If nothing is unlinked, the array will be empty.
833b39c5158Smillert
834b39c5158Smillert    remove_tree( '/tmp', {result => \my $list} );
835b39c5158Smillert    print "unlinked $_\n" for @$list;
836b39c5158Smillert
837b39c5158SmillertThis is a useful alternative to the C<verbose> key.
838b39c5158Smillert
839b39c5158Smillert=item error => \$err
840b39c5158Smillert
841b39c5158SmillertIf present, it should be a reference to a scalar.
842b39c5158SmillertThis scalar will be made to reference an array, which will
843b39c5158Smillertbe used to store any errors that are encountered.  See the L</"ERROR
844b39c5158SmillertHANDLING"> section for more information.
845b39c5158Smillert
846b39c5158SmillertRemoving things is a much more dangerous proposition than
847b39c5158Smillertcreating things. As such, there are certain conditions that
848b39c5158SmillertC<remove_tree> may encounter that are so dangerous that the only
849b39c5158Smillertsane action left is to kill the program.
850b39c5158Smillert
851b39c5158SmillertUse C<error> to trap all that is reasonable (problems with
852b39c5158Smillertpermissions and the like), and let it die if things get out
853b39c5158Smillertof hand. This is the safest course of action.
854b39c5158Smillert
855b39c5158Smillert=back
856b39c5158Smillert
857b39c5158Smillert=item rmtree( $dir )
858b39c5158Smillert
859b39c5158Smillert=item rmtree( $dir, $verbose, $safe )
860b39c5158Smillert
861b39c5158Smillert=item rmtree( [$dir1, $dir2,...], $verbose, $safe )
862b39c5158Smillert
863b39c5158Smillert=item rmtree( $dir1, $dir2,..., \%opt )
864b39c5158Smillert
8652e109fb9Safresh1The C<rmtree()> function provide the legacy interface of
8662e109fb9Safresh1C<remove_tree()> with a different interpretation of the arguments
8672e109fb9Safresh1passed. The behaviour and return value of the function is otherwise
8682e109fb9Safresh1identical to C<remove_tree()>.
8692e109fb9Safresh1
8702e109fb9Safresh1B<NOTE:>  For security reasons, we strongly advise use of the
8712e109fb9Safresh1hashref-as-final-argument syntax, specifically with a setting of the C<safe>
8722e109fb9Safresh1element to a true value.
8732e109fb9Safresh1
8742e109fb9Safresh1    rmtree( $dir1, $dir2, ....,
8752e109fb9Safresh1        {
8762e109fb9Safresh1            safe => 1,
8772e109fb9Safresh1            ...         # other key-value pairs
8782e109fb9Safresh1        },
8792e109fb9Safresh1    );
880b39c5158Smillert
881b39c5158Smillert=back
882b39c5158Smillert
883b39c5158Smillert=head2 ERROR HANDLING
884b39c5158Smillert
885b39c5158Smillert=over 4
886b39c5158Smillert
887b39c5158Smillert=item B<NOTE:>
888b39c5158Smillert
889b8851fccSafresh1The following error handling mechanism is consistent throughout all
890b8851fccSafresh1code paths EXCEPT in cases where the ROOT node is nonexistent.  In
891b8851fccSafresh1version 2.11 the maintainers attempted to rectify this inconsistency
892b8851fccSafresh1but too many downstream modules encountered problems.  In such case,
893b8851fccSafresh1if you require root node evaluation or error checking prior to calling
894b8851fccSafresh1C<make_path> or C<remove_tree>, you should take additional precautions.
895b39c5158Smillert
896b39c5158Smillert=back
897b39c5158Smillert
8982e109fb9Safresh1If C<make_path> or C<remove_tree> encounters an error, a diagnostic
899b39c5158Smillertmessage will be printed to C<STDERR> via C<carp> (for non-fatal
9002e109fb9Safresh1errors) or via C<croak> (for fatal errors).
901b39c5158Smillert
902b39c5158SmillertIf this behaviour is not desirable, the C<error> attribute may be
903b39c5158Smillertused to hold a reference to a variable, which will be used to store
904b39c5158Smillertthe diagnostics. The variable is made a reference to an array of hash
905b39c5158Smillertreferences.  Each hash contain a single key/value pair where the key
906b39c5158Smillertis the name of the file, and the value is the error message (including
907b39c5158Smillertthe contents of C<$!> when appropriate).  If a general error is
908b39c5158Smillertencountered the diagnostic key will be empty.
909b39c5158Smillert
910b39c5158SmillertAn example usage looks like:
911b39c5158Smillert
912b39c5158Smillert  remove_tree( 'foo/bar', 'bar/rat', {error => \my $err} );
9132e109fb9Safresh1  if ($err && @$err) {
914b39c5158Smillert      for my $diag (@$err) {
915b39c5158Smillert          my ($file, $message) = %$diag;
916b39c5158Smillert          if ($file eq '') {
917b39c5158Smillert              print "general error: $message\n";
918b39c5158Smillert          }
919b39c5158Smillert          else {
920b39c5158Smillert              print "problem unlinking $file: $message\n";
921b39c5158Smillert          }
922b39c5158Smillert      }
923b39c5158Smillert  }
924b39c5158Smillert  else {
925b39c5158Smillert      print "No error encountered\n";
926b39c5158Smillert  }
927b39c5158Smillert
928b39c5158SmillertNote that if no errors are encountered, C<$err> will reference an
929b39c5158Smillertempty array.  This means that C<$err> will always end up TRUE; so you
930b8851fccSafresh1need to test C<@$err> to determine if errors occurred.
931b39c5158Smillert
932b39c5158Smillert=head2 NOTES
933b39c5158Smillert
934b39c5158SmillertC<File::Path> blindly exports C<mkpath> and C<rmtree> into the
935b39c5158Smillertcurrent namespace. These days, this is considered bad style, but
936b39c5158Smillertto change it now would break too much code. Nonetheless, you are
937b39c5158Smillertinvited to specify what it is you are expecting to use:
938b39c5158Smillert
939b39c5158Smillert  use File::Path 'rmtree';
940b39c5158Smillert
941b39c5158SmillertThe routines C<make_path> and C<remove_tree> are B<not> exported
942b39c5158Smillertby default. You must specify which ones you want to use.
943b39c5158Smillert
944b39c5158Smillert  use File::Path 'remove_tree';
945b39c5158Smillert
946b39c5158SmillertNote that a side-effect of the above is that C<mkpath> and C<rmtree>
947b39c5158Smillertare no longer exported at all. This is due to the way the C<Exporter>
948b39c5158Smillertmodule works. If you are migrating a codebase to use the new
949b39c5158Smillertinterface, you will have to list everything explicitly. But that's
950b39c5158Smillertjust good practice anyway.
951b39c5158Smillert
952b39c5158Smillert  use File::Path qw(remove_tree rmtree);
953b39c5158Smillert
954b39c5158Smillert=head3 API CHANGES
955b39c5158Smillert
956b39c5158SmillertThe API was changed in the 2.0 branch. For a time, C<mkpath> and
957b39c5158SmillertC<rmtree> tried, unsuccessfully, to deal with the two different
958b39c5158Smillertcalling mechanisms. This approach was considered a failure.
959b39c5158Smillert
960b39c5158SmillertThe new semantics are now only available with C<make_path> and
961b39c5158SmillertC<remove_tree>. The old semantics are only available through
962b39c5158SmillertC<mkpath> and C<rmtree>. Users are strongly encouraged to upgrade
963b39c5158Smillertto at least 2.08 in order to avoid surprises.
964b39c5158Smillert
965b39c5158Smillert=head3 SECURITY CONSIDERATIONS
966b39c5158Smillert
9672e109fb9Safresh1There were race conditions in the 1.x implementations of File::Path's
968b39c5158SmillertC<rmtree> function (although sometimes patched depending on the OS
969b39c5158Smillertdistribution or platform). The 2.0 version contains code to avoid the
970b39c5158Smillertproblem mentioned in CVE-2002-0435.
971b39c5158Smillert
972b39c5158SmillertSee the following pages for more information:
973b39c5158Smillert
974b39c5158Smillert    http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=286905
975b39c5158Smillert    http://www.nntp.perl.org/group/perl.perl5.porters/2005/01/msg97623.html
976b39c5158Smillert    http://www.debian.org/security/2005/dsa-696
977b39c5158Smillert
978b39c5158SmillertAdditionally, unless the C<safe> parameter is set (or the
979b39c5158Smillertthird parameter in the traditional interface is TRUE), should a
980b39c5158SmillertC<remove_tree> be interrupted, files that were originally in read-only
981b39c5158Smillertmode may now have their permissions set to a read-write (or "delete
982b39c5158SmillertOK") mode.
983b39c5158Smillert
9842e109fb9Safresh1The following CVE reports were previously filed against File-Path and are
9852e109fb9Safresh1believed to have been addressed:
9862e109fb9Safresh1
9872e109fb9Safresh1=over 4
9882e109fb9Safresh1
9892e109fb9Safresh1=item * L<http://cve.circl.lu/cve/CVE-2004-0452>
9902e109fb9Safresh1
9912e109fb9Safresh1=item * L<http://cve.circl.lu/cve/CVE-2005-0448>
9922e109fb9Safresh1
9932e109fb9Safresh1=back
9942e109fb9Safresh1
9952e109fb9Safresh1In February 2017 the cPanel Security Team reported an additional vulnerability
9962e109fb9Safresh1in File-Path.  The C<chmod()> logic to make directories traversable can be
9972e109fb9Safresh1abused to set the mode on an attacker-chosen file to an attacker-chosen value.
9982e109fb9Safresh1This is due to the time-of-check-to-time-of-use (TOCTTOU) race condition
9992e109fb9Safresh1(L<https://en.wikipedia.org/wiki/Time_of_check_to_time_of_use>) between the
10002e109fb9Safresh1C<stat()> that decides the inode is a directory and the C<chmod()> that tries
10012e109fb9Safresh1to make it user-rwx.  CPAN versions 2.13 and later incorporate a patch
10022e109fb9Safresh1provided by John Lightsey to address this problem.  This vulnerability has
10032e109fb9Safresh1been reported as CVE-2017-6512.
10042e109fb9Safresh1
1005b39c5158Smillert=head1 DIAGNOSTICS
1006b39c5158Smillert
1007b39c5158SmillertFATAL errors will cause the program to halt (C<croak>), since the
1008b39c5158Smillertproblem is so severe that it would be dangerous to continue. (This
1009b39c5158Smillertcan always be trapped with C<eval>, but it's not a good idea. Under
1010b39c5158Smillertthe circumstances, dying is the best thing to do).
1011b39c5158Smillert
1012b39c5158SmillertSEVERE errors may be trapped using the modern interface. If the
10132e109fb9Safresh1they are not trapped, or if the old interface is used, such an error
1014b39c5158Smillertwill cause the program will halt.
1015b39c5158Smillert
1016b39c5158SmillertAll other errors may be trapped using the modern interface, otherwise
1017b39c5158Smillertthey will be C<carp>ed about. Program execution will not be halted.
1018b39c5158Smillert
1019b39c5158Smillert=over 4
1020b39c5158Smillert
1021b39c5158Smillert=item mkdir [path]: [errmsg] (SEVERE)
1022b39c5158Smillert
1023b39c5158SmillertC<make_path> was unable to create the path. Probably some sort of
10242e109fb9Safresh1permissions error at the point of departure or insufficient resources
1025b39c5158Smillert(such as free inodes on Unix).
1026b39c5158Smillert
1027b39c5158Smillert=item No root path(s) specified
1028b39c5158Smillert
1029b39c5158SmillertC<make_path> was not given any paths to create. This message is only
1030b39c5158Smillertemitted if the routine is called with the traditional interface.
1031b39c5158SmillertThe modern interface will remain silent if given nothing to do.
1032b39c5158Smillert
1033b39c5158Smillert=item No such file or directory
1034b39c5158Smillert
1035b39c5158SmillertOn Windows, if C<make_path> gives you this warning, it may mean that
1036b39c5158Smillertyou have exceeded your filesystem's maximum path length.
1037b39c5158Smillert
1038b39c5158Smillert=item cannot fetch initial working directory: [errmsg]
1039b39c5158Smillert
1040b39c5158SmillertC<remove_tree> attempted to determine the initial directory by calling
1041b39c5158SmillertC<Cwd::getcwd>, but the call failed for some reason. No attempt
1042b39c5158Smillertwill be made to delete anything.
1043b39c5158Smillert
1044b39c5158Smillert=item cannot stat initial working directory: [errmsg]
1045b39c5158Smillert
1046b39c5158SmillertC<remove_tree> attempted to stat the initial directory (after having
1047b39c5158Smillertsuccessfully obtained its name via C<getcwd>), however, the call
1048b39c5158Smillertfailed for some reason. No attempt will be made to delete anything.
1049b39c5158Smillert
1050b39c5158Smillert=item cannot chdir to [dir]: [errmsg]
1051b39c5158Smillert
1052b39c5158SmillertC<remove_tree> attempted to set the working directory in order to
1053b39c5158Smillertbegin deleting the objects therein, but was unsuccessful. This is
1054b39c5158Smillertusually a permissions issue. The routine will continue to delete
1055b39c5158Smillertother things, but this directory will be left intact.
1056b39c5158Smillert
1057b39c5158Smillert=item directory [dir] changed before chdir, expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL)
1058b39c5158Smillert
1059b39c5158SmillertC<remove_tree> recorded the device and inode of a directory, and then
1060b39c5158Smillertmoved into it. It then performed a C<stat> on the current directory
1061b39c5158Smillertand detected that the device and inode were no longer the same. As
1062b39c5158Smillertthis is at the heart of the race condition problem, the program
1063b39c5158Smillertwill die at this point.
1064b39c5158Smillert
1065b39c5158Smillert=item cannot make directory [dir] read+writeable: [errmsg]
1066b39c5158Smillert
1067b39c5158SmillertC<remove_tree> attempted to change the permissions on the current directory
1068b39c5158Smillertto ensure that subsequent unlinkings would not run into problems,
1069b39c5158Smillertbut was unable to do so. The permissions remain as they were, and
1070b39c5158Smillertthe program will carry on, doing the best it can.
1071b39c5158Smillert
1072b39c5158Smillert=item cannot read [dir]: [errmsg]
1073b39c5158Smillert
1074b39c5158SmillertC<remove_tree> tried to read the contents of the directory in order
1075b39c5158Smillertto acquire the names of the directory entries to be unlinked, but
1076b39c5158Smillertwas unsuccessful. This is usually a permissions issue. The
1077b39c5158Smillertprogram will continue, but the files in this directory will remain
1078b39c5158Smillertafter the call.
1079b39c5158Smillert
1080b39c5158Smillert=item cannot reset chmod [dir]: [errmsg]
1081b39c5158Smillert
1082b39c5158SmillertC<remove_tree>, after having deleted everything in a directory, attempted
1083b39c5158Smillertto restore its permissions to the original state but failed. The
1084b39c5158Smillertdirectory may wind up being left behind.
1085b39c5158Smillert
1086b39c5158Smillert=item cannot remove [dir] when cwd is [dir]
1087b39c5158Smillert
1088b39c5158SmillertThe current working directory of the program is F</some/path/to/here>
1089b39c5158Smillertand you are attempting to remove an ancestor, such as F</some/path>.
1090b39c5158SmillertThe directory tree is left untouched.
1091b39c5158Smillert
1092b39c5158SmillertThe solution is to C<chdir> out of the child directory to a place
1093b39c5158Smillertoutside the directory tree to be removed.
1094b39c5158Smillert
1095b39c5158Smillert=item cannot chdir to [parent-dir] from [child-dir]: [errmsg], aborting. (FATAL)
1096b39c5158Smillert
1097b39c5158SmillertC<remove_tree>, after having deleted everything and restored the permissions
1098b39c5158Smillertof a directory, was unable to chdir back to the parent. The program
1099b39c5158Smillerthalts to avoid a race condition from occurring.
1100b39c5158Smillert
1101b39c5158Smillert=item cannot stat prior working directory [dir]: [errmsg], aborting. (FATAL)
1102b39c5158Smillert
11032e109fb9Safresh1C<remove_tree> was unable to stat the parent directory after having returned
1104b39c5158Smillertfrom the child. Since there is no way of knowing if we returned to
1105b39c5158Smillertwhere we think we should be (by comparing device and inode) the only
1106b39c5158Smillertway out is to C<croak>.
1107b39c5158Smillert
1108b39c5158Smillert=item previous directory [parent-dir] changed before entering [child-dir], expected dev=[n] ino=[n], actual dev=[n] ino=[n], aborting. (FATAL)
1109b39c5158Smillert
1110b39c5158SmillertWhen C<remove_tree> returned from deleting files in a child directory, a
1111b39c5158Smillertcheck revealed that the parent directory it returned to wasn't the one
1112b39c5158Smillertit started out from. This is considered a sign of malicious activity.
1113b39c5158Smillert
1114b39c5158Smillert=item cannot make directory [dir] writeable: [errmsg]
1115b39c5158Smillert
1116b39c5158SmillertJust before removing a directory (after having successfully removed
1117b39c5158Smillerteverything it contained), C<remove_tree> attempted to set the permissions
1118b39c5158Smillerton the directory to ensure it could be removed and failed. Program
1119b39c5158Smillertexecution continues, but the directory may possibly not be deleted.
1120b39c5158Smillert
1121b39c5158Smillert=item cannot remove directory [dir]: [errmsg]
1122b39c5158Smillert
11232e109fb9Safresh1C<remove_tree> attempted to remove a directory, but failed. This may be because
1124b39c5158Smillertsome objects that were unable to be removed remain in the directory, or
11252e109fb9Safresh1it could be a permissions issue. The directory will be left behind.
1126b39c5158Smillert
1127b39c5158Smillert=item cannot restore permissions of [dir] to [0nnn]: [errmsg]
1128b39c5158Smillert
1129b39c5158SmillertAfter having failed to remove a directory, C<remove_tree> was unable to
1130b39c5158Smillertrestore its permissions from a permissive state back to a possibly
1131b39c5158Smillertmore restrictive setting. (Permissions given in octal).
1132b39c5158Smillert
1133b39c5158Smillert=item cannot make file [file] writeable: [errmsg]
1134b39c5158Smillert
1135b39c5158SmillertC<remove_tree> attempted to force the permissions of a file to ensure it
1136b39c5158Smillertcould be deleted, but failed to do so. It will, however, still attempt
1137b39c5158Smillertto unlink the file.
1138b39c5158Smillert
1139b39c5158Smillert=item cannot unlink file [file]: [errmsg]
1140b39c5158Smillert
1141b39c5158SmillertC<remove_tree> failed to remove a file. Probably a permissions issue.
1142b39c5158Smillert
1143b39c5158Smillert=item cannot restore permissions of [file] to [0nnn]: [errmsg]
1144b39c5158Smillert
1145b39c5158SmillertAfter having failed to remove a file, C<remove_tree> was also unable
1146b39c5158Smillertto restore the permissions on the file to a possibly less permissive
1147b39c5158Smillertsetting. (Permissions given in octal).
1148b39c5158Smillert
1149b39c5158Smillert=item unable to map [owner] to a uid, ownership not changed");
1150b39c5158Smillert
1151b39c5158SmillertC<make_path> was instructed to give the ownership of created
1152b39c5158Smillertdirectories to the symbolic name [owner], but C<getpwnam> did
1153b39c5158Smillertnot return the corresponding numeric uid. The directory will
1154b39c5158Smillertbe created, but ownership will not be changed.
1155b39c5158Smillert
1156b39c5158Smillert=item unable to map [group] to a gid, group ownership not changed
1157b39c5158Smillert
1158b39c5158SmillertC<make_path> was instructed to give the group ownership of created
1159b39c5158Smillertdirectories to the symbolic name [group], but C<getgrnam> did
1160b39c5158Smillertnot return the corresponding numeric gid. The directory will
1161b39c5158Smillertbe created, but group ownership will not be changed.
1162b39c5158Smillert
1163b39c5158Smillert=back
1164b39c5158Smillert
1165b39c5158Smillert=head1 SEE ALSO
1166b39c5158Smillert
1167b39c5158Smillert=over 4
1168b39c5158Smillert
1169b39c5158Smillert=item *
1170b39c5158Smillert
1171b39c5158SmillertL<File::Remove>
1172b39c5158Smillert
1173b39c5158SmillertAllows files and directories to be moved to the Trashcan/Recycle
1174b39c5158SmillertBin (where they may later be restored if necessary) if the operating
1175b39c5158Smillertsystem supports such functionality. This feature may one day be
1176b39c5158Smillertmade available directly in C<File::Path>.
1177b39c5158Smillert
1178b39c5158Smillert=item *
1179b39c5158Smillert
1180b39c5158SmillertL<File::Find::Rule>
1181b39c5158Smillert
1182b39c5158SmillertWhen removing directory trees, if you want to examine each file to
1183b39c5158Smillertdecide whether to delete it (and possibly leaving large swathes
1184b39c5158Smillertalone), F<File::Find::Rule> offers a convenient and flexible approach
1185b39c5158Smillertto examining directory trees.
1186b39c5158Smillert
1187b39c5158Smillert=back
1188b39c5158Smillert
1189b8851fccSafresh1=head1 BUGS AND LIMITATIONS
1190b39c5158Smillert
1191b8851fccSafresh1The following describes F<File::Path> limitations and how to report bugs.
1192b8851fccSafresh1
11932e109fb9Safresh1=head2 MULTITHREADED APPLICATIONS
1194b8851fccSafresh1
11952e109fb9Safresh1F<File::Path> C<rmtree> and C<remove_tree> will not work with
11962e109fb9Safresh1multithreaded applications due to its use of C<chdir>.  At this time,
11972e109fb9Safresh1no warning or error is generated in this situation.  You will
11982e109fb9Safresh1certainly encounter unexpected results.
1199b8851fccSafresh1
12002e109fb9Safresh1The implementation that surfaces this limitation will not be changed. See the
12012e109fb9Safresh1F<File::Path::Tiny> module for functionality similar to F<File::Path> but which does
12022e109fb9Safresh1not C<chdir>.
1203b8851fccSafresh1
1204b8851fccSafresh1=head2 NFS Mount Points
1205b8851fccSafresh1
1206b8851fccSafresh1F<File::Path> is not responsible for triggering the automounts, mirror mounts,
1207b8851fccSafresh1and the contents of network mounted filesystems.  If your NFS implementation
1208b8851fccSafresh1requires an action to be performed on the filesystem in order for
1209b8851fccSafresh1F<File::Path> to perform operations, it is strongly suggested you assure
1210b8851fccSafresh1filesystem availability by reading the root of the mounted filesystem.
1211b8851fccSafresh1
1212b8851fccSafresh1=head2 REPORTING BUGS
1213b8851fccSafresh1
1214b8851fccSafresh1Please report all bugs on the RT queue, either via the web interface:
1215b39c5158Smillert
1216b39c5158SmillertL<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Path>
1217b39c5158Smillert
1218b8851fccSafresh1or by email:
1219b8851fccSafresh1
1220b8851fccSafresh1    bug-File-Path@rt.cpan.org
1221b8851fccSafresh1
1222b8851fccSafresh1In either case, please B<attach> patches to the bug report rather than
1223b8851fccSafresh1including them inline in the web post or the body of the email.
1224b8851fccSafresh1
122591f110e0Safresh1You can also send pull requests to the Github repository:
122691f110e0Safresh1
1227b8851fccSafresh1L<https://github.com/rpcme/File-Path>
122891f110e0Safresh1
1229b39c5158Smillert=head1 ACKNOWLEDGEMENTS
1230b39c5158Smillert
1231b39c5158SmillertPaul Szabo identified the race condition originally, and Brendan
1232b39c5158SmillertO'Dea wrote an implementation for Debian that addressed the problem.
1233b39c5158SmillertThat code was used as a basis for the current code. Their efforts
1234b39c5158Smillertare greatly appreciated.
1235b39c5158Smillert
1236b39c5158SmillertGisle Aas made a number of improvements to the documentation for
1237b39c5158Smillert2.07 and his advice and assistance is also greatly appreciated.
1238b39c5158Smillert
1239b39c5158Smillert=head1 AUTHORS
1240b39c5158Smillert
1241b8851fccSafresh1Prior authors and maintainers: Tim Bunce, Charles Bailey, and
1242b8851fccSafresh1David Landgren <F<david@landgren.net>>.
1243b8851fccSafresh1
1244b8851fccSafresh1Current maintainers are Richard Elberger <F<riche@cpan.org>> and
1245b8851fccSafresh1James (Jim) Keenan <F<jkeenan@cpan.org>>.
1246b8851fccSafresh1
1247b8851fccSafresh1=head1 CONTRIBUTORS
1248b8851fccSafresh1
12499f11ffb7Safresh1Contributors to File::Path, in alphabetical order by first name.
1250b8851fccSafresh1
1251b8851fccSafresh1=over 1
1252b8851fccSafresh1
1253b8851fccSafresh1=item <F<bulkdd@cpan.org>>
1254b8851fccSafresh1
12552e109fb9Safresh1=item Charlie Gonzalez <F<itcharlie@cpan.org>>
12562e109fb9Safresh1
1257b8851fccSafresh1=item Craig A. Berry <F<craigberry@mac.com>>
1258b8851fccSafresh1
12592e109fb9Safresh1=item James E Keenan <F<jkeenan@cpan.org>>
12602e109fb9Safresh1
12612e109fb9Safresh1=item John Lightsey <F<john@perlsec.org>>
12622e109fb9Safresh1
12639f11ffb7Safresh1=item Nigel Horne <F<njh@bandsman.co.uk>>
12649f11ffb7Safresh1
1265b8851fccSafresh1=item Richard Elberger <F<riche@cpan.org>>
1266b8851fccSafresh1
1267b8851fccSafresh1=item Ryan Yee <F<ryee@cpan.org>>
1268b8851fccSafresh1
1269b8851fccSafresh1=item Skye Shaw <F<shaw@cpan.org>>
1270b8851fccSafresh1
1271b8851fccSafresh1=item Tom Lutz <F<tommylutz@gmail.com>>
1272b8851fccSafresh1
12732e109fb9Safresh1=item Will Sheppard <F<willsheppard@github>>
12742e109fb9Safresh1
1275b8851fccSafresh1=back
1276b39c5158Smillert
1277b39c5158Smillert=head1 COPYRIGHT
1278b39c5158Smillert
1279b8851fccSafresh1This module is copyright (C) Charles Bailey, Tim Bunce, David Landgren,
1280*eac174f2Safresh1James Keenan and Richard Elberger 1995-2020. All rights reserved.
1281b39c5158Smillert
1282b39c5158Smillert=head1 LICENSE
1283b39c5158Smillert
1284b39c5158SmillertThis library is free software; you can redistribute it and/or modify
1285b39c5158Smillertit under the same terms as Perl itself.
1286b39c5158Smillert
1287b39c5158Smillert=cut
1288