[p5sagit/p5-mst-13.2.git] / lib / File / Path.pm

package File::Path;

=head1 NAME

File::Path - Create or remove directory trees

=head1 VERSION

This document describes version 2.00 of File::Path, released
2007-xx-xx.

=head1 SYNOPSIS

    use File::Path;

    # modern
    mkpath( 'foo/bar/baz', '/zug/zwang', {verbose => 1} );

    rmtree(
        'foo/bar/baz', '/zug/zwang',
        { verbose => 1, error  => \my $err_list }
    );

    # traditional
    mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);
    rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);

=head1 DESCRIPTION

The C<mkpath> function provides a convenient way to create directories,
even if your C<mkdir> kernel call won't create more than one level
of directory at a time. Similarly, the C<rmtree> function provides
a convenient way to delete a subtree from the directory structure,
much like the Unix command C<rm -r>.

Both functions may be called in one of two ways, the traditional,
compatible with code written since the dawn of time, and modern,
that offers a more flexible and readable idiom. New code should use
the modern interface.

=head2 FUNCTIONS

The modern way of calling C<mkpath> and C<rmtree> is with an optional
hash reference at the end of the parameter list that holds various
keys that can be used to control the function's behaviour, following
a plain list of directories upon which to operate.

=head3 C<mkpath>

The following keys are recognised as as parameters to C<mkpath>.
It returns the list of files actually created during the call.

  my @created = mkpath(
    qw(/tmp /flub /home/nobody),
    {verbose => 1, mode => 0750},
  );
  print "created $_\n" for @created;

=over 4

=item mode

The numeric mode to use when creating the directories (defaults
to 07777), to be modified by the current C<umask>. (C<mask> is
recognised as an alias for this parameter).

=item verbose

If present, will cause C<mkpath> to print the name of each directory
as it is created. By default nothing is printed.

=item error

If present, will be interpreted as a reference to a list, and will
be used to store any errors that are encountered.  See the ERROR
HANDLING section below to find out more.

If this parameter is not used, any errors encountered will raise a
fatal error that need to be trapped in an C<eval> block, or the
program will halt.

=back

=head3 C<rmtree>

=over 4

=item verbose

If present, will cause C<rmtree> to print the name of each file as
it is unlinked. By default nothing is printed.

=item skip_others

When set to a true value, will cause C<rmtree> to skip any files
to which you do not have delete access (if running under VMS) or
write access (if running under another OS). This will change in
the future when a criterion for 'delete permission' under OSs other
than VMS is settled.

=item keep_root

When set to a true value, will cause everything except the specified
base directories to be unlinked. This comes in handy when cleaning
out an application's scratch directory.

  rmtree( '/tmp', {keep_root => 1} );

=item result

If present, will be interpreted as a reference to a list, and will
be used to store the list of all files and directories unlinked
during the call. If nothing is unlinked, a reference to an empty
list is returned (rather than C<undef>).

  rmtree( '/tmp', {result => \my $list} );
  print "unlinked $_\n" for @$list;

=item error

If present, will be interpreted as a reference to a list,
and will be used to store any errors that are encountered.
See the ERROR HANDLING section below to find out more.

If this parameter is not used, any errors encountered will
raise a fatal error that need to be trapped in an C<eval>
block, or the program will halt.

=back

=head2 TRADITIONAL INTERFACE

The old interface for C<mkpath> and C<rmtree> take a
reference to a list of directories (to create or remove),
followed by a series of positional numeric modal parameters that
control their behaviour.

This design made it difficult to add
additional functionality, as well as posed the problem
of what to do when you don't care how the initial
positional parameters are specified but only the last
one needs to be specified. The calls themselves are also
less self-documenting.

C<mkpath> takes three arguments:

=over 4

=item *

The name of the path to create, or a reference
to a list of paths to create,

=item *

a boolean value, which if TRUE will cause C<mkpath>
to print the name of each directory as it is created
(defaults to FALSE), and

=item *

the numeric mode to use when creating the directories
(defaults to 0777), to be modified by the current umask.

=back

It returns a list of all directories (including intermediates, determined
using the Unix '/' separator) created.  In scalar context it returns
the number of directories created.

If a system error prevents a directory from being created, then the
C<mkpath> function throws a fatal error with C<Carp::croak>. This error
can be trapped with an C<eval> block:

  eval { mkpath($dir) };
  if ($@) {
    print "Couldn't create $dir: $@";
  }

In the traditional form, C<rmtree> takes three arguments:

=over 4

=item *

the root of the subtree to delete, or a reference to
a list of roots.  All of the files and directories
below each root, as well as the roots themselves,
will be deleted.

=item *

a boolean value, which if TRUE will cause C<rmtree> to
print a message each time it examines a file, giving the
name of the file, and indicating whether it's using C<rmdir>
or C<unlink> to remove it, or that it's skipping it.
(defaults to FALSE)

=item *

a boolean value, which if TRUE will cause C<rmtree> to
skip any files to which you do not have delete access
(if running under VMS) or write access (if running
under another OS).  This will change in the future when
a criterion for 'delete permission' under OSs other
than VMS is settled.  (defaults to FALSE)

=back

It returns the number of files, directories and symlinks successfully
deleted.  Symlinks are simply deleted and not followed.

Note also that the occurrence of errors in C<rmtree> using the
traditional interface can be determined I<only> by trapping diagnostic
messages using C<$SIG{__WARN__}>; it is not apparent from the return
value. (The modern interface may use the C<error> parameter to
record any problems encountered.

=head2 ERROR HANDLING

If C<mkpath> or C<rmtree> encounter an error, a diagnostic message
will be printed to C<STDERR> via C<carp> (for non-fatal errors),
or via C<croak> (for fatal errors).

If this behaviour is not desirable, the C<error> attribute may be
used to hold a reference to a variable, which will be used to store
the diagnostics. The result is a reference to a list of hash
references. For each hash reference, the key is the name of the
file, and the value is the error message (usually the contents of
C<$!>). An example usage looks like:

  rmpath( 'foo/bar', 'bar/rat', {error => \my $err} );
  for my $diag (@$err) {
    my ($file, $message) = each %$diag;
    print "problem unlinking $file: $message\n";
  }

If no errors are encountered, C<$err> will point to an empty list
(thus there is no need to test for C<undef>). If a general error
is encountered (for instance, C<rmtree> attempts to remove a directory
tree that does not exist), the diagnostic key will be empty, only
the value will be set:

  rmpath( '/no/such/path', {error => \my $err} );
  for my $diag (@$err) {
    my ($file, $message) = each %$diag;
    if ($file eq '') {
      print "general error: $message\n";
    }
  }

=head2 NOTES

=head3 HEURISTICS

The functions detect (as far as possible) which way they are being
called and will act appropriately. It is important to remember that
the heuristic for detecting the old style is either the presence
of an array reference, or two or three parameters total and second
and third parameters are numeric. Hence...

    mkpath '486', '487', '488';

... will not assume the modern style and create three directories, rather
it will create one directory verbosely, setting the permission to
0750 (488 being the decimal equivalent of octal 750). Here, old
style trumps new. It must, for backwards compatibility reasons.

If you want to ensure there is absolutely no ambiguity about which
way the function will behave, make sure the first parameter is a
reference to a one-element list, to force the old style interpretation:

    mkpath ['486'], '487', '488';

and get only one directory created. Or add a reference to an empty
parameter hash, to force the new style:

    mkpath '486', '487', '488', {};

... and hence create the three directories. If the empty hash
reference seems a little strange to your eyes, or you suspect a
subsequent programmer might I<helpfully> optimise it away, you
can add a parameter set to a default value:

    mkpath '486', '487', '488', {verbose => 0};

=head3 RACE CONDITIONS

There are race conditions internal to the implementation of C<rmtree>
making it unsafe to use on directory trees which may be altered or
moved while C<rmtree> is running, and in particular on any directory
trees with any path components or subdirectories potentially writable
by untrusted users.

Additionally, if the C<skip_others> parareter is not set (or the
third parameter in the traditional inferface is not TRUE) and
C<rmtree> is interrupted, it may leave files and directories with
permissions altered to allow deletion.

C<File::Path> blindly exports C<mkpath> and C<rmtree> into the
current namespace. These days, this is considered bad style, but
to change it now would break too much code. Nonetheless, you are
invited to specify what it is you are expecting to use:

  use File::Path 'rmtree';

=head1 DIAGNOSTICS

=over 4

=item *

On Windows, if C<mkpath> gives you the warning: B<No such file or
directory>, this may mean that you've exceeded your filesystem's
maximum path length.

=back

=head1 SEE ALSO

=over 4

=item *

L<Find::File::Rule>

When removing directory trees, if you want to examine each file
before deciding whether to deleting it (and possibly leaving large
swathes alone), F<File::Find::Rule> offers a convenient and flexible
approach.

=back

=head1 BUGS

Please report all bugs on the RT queue:

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Path>

=head1 AUTHORS

Tim Bunce <F<Tim.Bunce@ig.co.uk>> and
Charles Bailey <F<bailey@newman.upenn.edu>>.

Currently maintained by David Landgren <F<david@landgren.net>>.

=head1 COPYRIGHT

This module is copyright (C) Charles Bailey, Tim Bunce and
David Landgren 1995-2007.  All rights reserved.

=head1 LICENSE

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

use 5.005_04;
use strict;

use File::Basename ();
use File::Spec     ();
BEGIN {
    if ($] < 5.006) {
        # can't say 'opendir my $dh, $dirname'
        # need to initialise $dh
        eval "use Symbol";
    }
}

use Exporter ();
use vars qw($VERSION @ISA @EXPORT);
$VERSION = '2.00';
@ISA     = qw(Exporter);
@EXPORT  = qw(mkpath rmtree);

my $Is_VMS = $^O eq 'VMS';
my $Is_MacOS = $^O eq 'MacOS';

# These OSes complain if you want to remove a file that you have no
# write permission to:
my $Force_Writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' ||
		       $^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc');

sub _carp {
    require Carp;
    goto &Carp::carp;
}

sub _croak {
    require Carp;
    goto &Carp::croak;
}

sub mkpath {
    my $new_style = (
        ref($_[0]) eq 'ARRAY'
        or (@_ == 2 and $_[1] =~ /\A\d+\z/)
        or (@_ == 3 and $_[1] =~ /\A\d+\z/ and $_[2] =~ /\A\d+\z/)
    ) ? 0 : 1;

    my $arg;
    my $paths;

    if ($new_style) {
        if (ref $_[-1] eq 'HASH') {
            $arg = pop @_;
            exists $arg->{mask} and $arg->{mode} = delete $arg->{mask};
            $arg->{mode} = 0777 unless exists $arg->{mode};
            ${$arg->{error}} = [] if exists $arg->{error};
        }
        else {
            @{$arg}{qw(verbose mode)} = (0, 0777);
        }
        $paths = [@_];
    }
    else {
        my ($verbose, $mode);
        ($paths, $verbose, $mode) = @_;
        $paths = [$paths] unless ref($paths) eq 'ARRAY';
        $arg->{verbose} = defined $verbose ? $verbose : 0;
        $arg->{mode}    = defined $mode    ? $mode    : 0777;
    }
    return _mkpath($arg, $paths);
}

sub _mkpath {
    my $arg   = shift;
    my $paths = shift;

    local($")=$Is_MacOS ? ":" : "/";
    my(@created,$path);
    foreach $path (@$paths) {
        next unless length($path);
	$path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT 
	# Logic wants Unix paths, so go with the flow.
	if ($Is_VMS) {
	    next if $path eq '/';
	    $path = VMS::Filespec::unixify($path);
	}
	next if -d $path;
	my $parent = File::Basename::dirname($path);
	unless (-d $parent or $path eq $parent) {
            push(@created,_mkpath($arg, [$parent]));
        }
        print "mkdir $path\n" if $arg->{verbose};
        if (mkdir($path,$arg->{mode})) {
            push(@created, $path);
	}
        else {
            my $save_bang = $!;
            my ($e, $e1) = ($save_bang, $^E);
	    $e .= "; $e1" if $e ne $e1;
	    # allow for another process to have created it meanwhile
            if (!-d $path) {
                $! = $save_bang;
                if ($arg->{error}) {
                    push @{${$arg->{error}}}, {$path => $e};
                }
                else {
                    _croak("mkdir $path: $e");
                }
	}
    }
    }
    return @created;
}

sub rmtree {
    my $new_style = (
        ref($_[0]) eq 'ARRAY'
        or (@_ == 2 and $_[1] =~ /\A\d+\z/)
        or (@_ == 3 and $_[1] =~ /\A\d+\z/ and $_[2] =~ /\A\d+\z/)
    ) ? 0 : 1;

    my $arg;
    my $paths;

    if ($new_style) {
        if (ref $_[-1] eq 'HASH') {
            $arg = pop @_;
            ${$arg->{error}}  = [] if exists $arg->{error};
            ${$arg->{result}} = [] if exists $arg->{result};
        }
        else {
            @{$arg}{qw(verbose safe)} = (0, 0);
        }
        $arg->{depth} = 0;
        $paths = [@_];
    }
    else {
        my ($verbose, $safe);
        ($paths, $verbose, $safe) = @_;
        $paths = [$paths] unless ref($paths) eq 'ARRAY';
        $arg->{verbose} = defined $verbose ? $verbose : 0;
        $arg->{safe}    = defined $safe    ? $safe    : 0;
    }

    if (@$paths < 1) {
        if ($arg->{error}) {
            push @{${$arg->{error}}}, {'' => "No root path(s) specified"};
    }
    else {
            $arg->{verbose} and _carp ("No root path(s) specified\n");
        }
      return 0;
    }
    return _rmtree($arg, $paths);
}

sub _rmtree {
    my $arg   = shift;
    my $paths = shift;
    my($count) = 0;
    my (@files, $root);
    foreach $root (@{$paths}) {
    	if ($Is_MacOS) {
	    $root = ":$root" if $root !~ /:/;
            $root =~ s/([^:])\z/$1:/;
        }
        else {
	    $root =~ s#/\z##;
	}
        my $rp = (lstat $root)[2] or next;
	$rp &= 07777;	# don't forget setuid, setgid, sticky bits
	if ( -d _ ) {
	    # notabene: 0700 is for making readable in the first place,
	    # it's also intended to change it to writable in case we have
	    # to recurse in which case we are better than rm -rf for 
	    # subtrees with strange permissions
            if (!chmod($rp | 0700,
                ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
            ) {
                if (!$arg->{safe}) {
                    if ($arg->{error}) {
                          push @{${$arg->{error}}},
                            {$root => "Can't make directory read+writeable: $!"};
                    }
                    else {
                        _carp ("Can't make directory $root read+writeable: $!");
                    }
                }
            }

            my $d;
            $d = gensym() if $] < 5.006;
            if (!opendir $d, $root) {
                if ($arg->{error}) {
                      push @{${$arg->{error}}}, {$root => "opendir: $!"};
                }
                else {
                    _carp ("Can't read $root: $!");
                }
                @files = ();
            }
            else {
		no strict 'refs';
		if (!defined ${"\cTAINT"} or ${"\cTAINT"}) {
                    # Blindly untaint dir names if taint mode is
                    # active, or any perl < 5.006
                    @files = map { /\A(.*)\z/s; $1 } readdir $d;
                }
                else {
		    @files = readdir $d;
		}
		closedir $d;
	    }

	    # Deleting large numbers of files from VMS Files-11 filesystems
	    # is faster if done in reverse ASCIIbetical order 
	    @files = reverse @files if $Is_VMS;
	    ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS;
	    if ($Is_MacOS) {
		@files = map("$root$_", @files);
	    }
            else {
                my $updir  = File::Spec->updir();
                my $curdir = File::Spec->curdir();
                @files = map(File::Spec->catfile($root,$_),
                    grep {$_ ne $updir and $_ ne $curdir}
                    @files
                );
            }
            $arg->{depth}++;
            $count += _rmtree($arg, \@files);
            $arg->{depth}--;
            if ($arg->{depth} or !$arg->{keep_root}) {
                if ($arg->{safe} &&
		($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
                    print "skipped $root\n" if $arg->{verbose};
		next;
	    }
                if (!chmod $rp | 0700, $root) {
                    if ($Force_Writeable) {
                        if ($arg->{error}) {
                            push @{${$arg->{error}}},
                                {$root => "Can't make directory writeable: $!"};
                        }
                        else {
                            _carp ("Can't make directory $root writeable: $!")
                        }
                    }
                }
                print "rmdir $root\n" if $arg->{verbose};
	    if (rmdir $root) {
                    push @{${$arg->{result}}}, $root if $arg->{result};
		++$count;
	    }
	    else {
                    if ($arg->{error}) {
                        push @{${$arg->{error}}}, {$root => "rmdir: $!"};
                    }
                    else {
                        _carp ("Can't remove directory $root: $!");
	    }
                    if (!chmod($rp,
                        ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
                    ) {
                        my $mask = sprintf("0%o",$rp);
                        if ($arg->{error}) {
                            push @{${$arg->{error}}}, {$root => "restore chmod: $!"};
	}
	else { 
                            _carp("and can't restore permissions to $mask\n");
                        }
                    }
                }
            }
        }
        else {
            if ($arg->{safe} &&
		($Is_VMS ? !&VMS::Filespec::candelete($root)
		         : !(-l $root || -w $root)))
	    {
                print "skipped $root\n" if $arg->{verbose};
		next;
	    }
            if (!chmod $rp | 0600, $root) {
                if ($Force_Writeable) {
                    if ($arg->{error}) {
                        push @{${$arg->{error}}},
                            {$root => "Can't make file writeable: $!"};
                    }
                    else {
                        _carp ("Can't make file $root writeable: $!")
                    }
                }
            }
            print "unlink $root\n" if $arg->{verbose};
	    # delete all versions under VMS
	    for (;;) {
                if (unlink $root) {
                    push @{${$arg->{result}}}, $root if $arg->{result};
                }
                else {
                    if ($arg->{error}) {
                        push @{${$arg->{error}}},
                            {$root => "unlink: $!"};
                    }
                    else {
                        _carp ("Can't unlink file $root: $!");
                    }
                    if ($Force_Writeable) {
                        if (!chmod $rp, $root) {
                            my $mask = sprintf("0%o",$rp);
                            if ($arg->{error}) {
                                push @{${$arg->{error}}}, {$root => "restore chmod: $!"};
                            }
                            else {
                                _carp("and can't restore permissions to $mask\n");
                            }
                        }
		    }
		    last;
		}
		++$count;
		last unless $Is_VMS && lstat $root;
	    }
	}
    }

    return $count;
}

1;
Commit	Line	Data
1fc4cb55	1	package File::Path;
fed7345c	2
	3	=head1 NAME
	4
12c2e016	5	File::Path - Create or remove directory trees
	6
	7	=head1 VERSION
	8
	9	This document describes version 2.00 of File::Path, released
	10	2007-xx-xx.
fed7345c	11
	12	=head1 SYNOPSIS
	13
8b87c192	14	use File::Path;
fed7345c	15
12c2e016	16	# modern
	17	mkpath( 'foo/bar/baz', '/zug/zwang', {verbose => 1} );
	18
	19	rmtree(
	20	'foo/bar/baz', '/zug/zwang',
91c4f65e	21	{ verbose => 1, error => \my $err_list }
12c2e016	22	);
	23
	24	# traditional
8b87c192	25	mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);
8b87c192	26	rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);
fed7345c	27
	28	=head1 DESCRIPTION
	29
12c2e016	30	The C<mkpath> function provides a convenient way to create directories,
	31	even if your C<mkdir> kernel call won't create more than one level
	32	of directory at a time. Similarly, the C<rmtree> function provides
	33	a convenient way to delete a subtree from the directory structure,
	34	much like the Unix command C<rm -r>.
	35
	36	Both functions may be called in one of two ways, the traditional,
	37	compatible with code written since the dawn of time, and modern,
	38	that offers a more flexible and readable idiom. New code should use
	39	the modern interface.
	40
	41	=head2 FUNCTIONS
	42
	43	The modern way of calling C<mkpath> and C<rmtree> is with an optional
	44	hash reference at the end of the parameter list that holds various
	45	keys that can be used to control the function's behaviour, following
	46	a plain list of directories upon which to operate.
	47
	48	=head3 C<mkpath>
	49
	50	The following keys are recognised as as parameters to C<mkpath>.
	51	It returns the list of files actually created during the call.
	52
	53	my @created = mkpath(
	54	qw(/tmp /flub /home/nobody),
	55	{verbose => 1, mode => 0750},
	56	);
	57	print "created $_\n" for @created;
	58
	59	=over 4
	60
	61	=item mode
	62
	63	The numeric mode to use when creating the directories (defaults
	64	to 07777), to be modified by the current C<umask>. (C<mask> is
	65	recognised as an alias for this parameter).
	66
	67	=item verbose
	68
	69	If present, will cause C<mkpath> to print the name of each directory
	70	as it is created. By default nothing is printed.
	71
	72	=item error
	73
	74	If present, will be interpreted as a reference to a list, and will
	75	be used to store any errors that are encountered. See the ERROR
	76	HANDLING section below to find out more.
	77
	78	If this parameter is not used, any errors encountered will raise a
	79	fatal error that need to be trapped in an C<eval> block, or the
	80	program will halt.
	81
	82	=back
	83
	84	=head3 C<rmtree>
	85
	86	=over 4
	87
	88	=item verbose
	89
	90	If present, will cause C<rmtree> to print the name of each file as
	91	it is unlinked. By default nothing is printed.
	92
	93	=item skip_others
94
95	When set to a true value, will cause C<rmtree> to skip any files
96	to which you do not have delete access (if running under VMS) or
97	write access (if running under another OS). This will change in
98	the future when a criterion for 'delete permission' under OSs other
99	than VMS is settled.
100
101	=item keep_root
102
103	When set to a true value, will cause everything except the specified
104	base directories to be unlinked. This comes in handy when cleaning
105	out an application's scratch directory.
106
107	rmtree( '/tmp', {keep_root => 1} );
108
109	=item result
110
111	If present, will be interpreted as a reference to a list, and will
112	be used to store the list of all files and directories unlinked
113	during the call. If nothing is unlinked, a reference to an empty
114	list is returned (rather than C<undef>).
115
116	rmtree( '/tmp', {result => \my $list} );
117	print "unlinked $_\n" for @$list;
118
119	=item error
120
121	If present, will be interpreted as a reference to a list,
122	and will be used to store any errors that are encountered.
123	See the ERROR HANDLING section below to find out more.
124
125	If this parameter is not used, any errors encountered will
126	raise a fatal error that need to be trapped in an C<eval>
127	block, or the program will halt.
128
129	=back
130
131	=head2 TRADITIONAL INTERFACE
132
133	The old interface for C<mkpath> and C<rmtree> take a
134	reference to a list of directories (to create or remove),
135	followed by a series of positional numeric modal parameters that
136	control their behaviour.
137
138	This design made it difficult to add
139	additional functionality, as well as posed the problem
140	of what to do when you don't care how the initial
141	positional parameters are specified but only the last
142	one needs to be specified. The calls themselves are also
143	less self-documenting.
144
145	C<mkpath> takes three arguments:
fed7345c	146
	147	=over 4
	148
	149	=item *
	150
12c2e016	151	The name of the path to create, or a reference
fed7345c	152	to a list of paths to create,
	153
	154	=item *
	155
	156	a boolean value, which if TRUE will cause C<mkpath>
	157	to print the name of each directory as it is created
	158	(defaults to FALSE), and
	159
	160	=item *
	161
	162	the numeric mode to use when creating the directories
e2ba98a1	163	(defaults to 0777), to be modified by the current umask.
fed7345c	164
	165	=back
	166
037c8c09	167	It returns a list of all directories (including intermediates, determined
cc61921f	168	using the Unix '/' separator) created. In scalar context it returns
cc61921f	169	the number of directories created.
fed7345c	170
070ed461	171	If a system error prevents a directory from being created, then the
99c4c5e8	172	C<mkpath> function throws a fatal error with C<Carp::croak>. This error
99c4c5e8	173	can be trapped with an C<eval> block:
070ed461	174
	175	eval { mkpath($dir) };
	176	if ($@) {
	177	print "Couldn't create $dir: $@";
	178	}
	179
12c2e016	180	In the traditional form, C<rmtree> takes three arguments:
fed7345c	181
	182	=over 4
	183
	184	=item *
	185
	186	the root of the subtree to delete, or a reference to
	187	a list of roots. All of the files and directories
	188	below each root, as well as the roots themselves,
567d72c2	189	will be deleted.
fed7345c	190
	191	=item *
	192
	193	a boolean value, which if TRUE will cause C<rmtree> to
748a9306	194	print a message each time it examines a file, giving the
	195	name of the file, and indicating whether it's using C<rmdir>
	196	or C<unlink> to remove it, or that it's skipping it.
fed7345c	197	(defaults to FALSE)
	198
	199	=item *
	200
	201	a boolean value, which if TRUE will cause C<rmtree> to
748a9306	202	skip any files to which you do not have delete access
	203	(if running under VMS) or write access (if running
	204	under another OS). This will change in the future when
	205	a criterion for 'delete permission' under OSs other
96e4d5b1	206	than VMS is settled. (defaults to FALSE)
fed7345c	207
	208	=back
	209
cc61921f	210	It returns the number of files, directories and symlinks successfully
cc61921f	211	deleted. Symlinks are simply deleted and not followed.
fed7345c	212
12c2e016	213	Note also that the occurrence of errors in C<rmtree> using the
	214	traditional interface can be determined I<only> by trapping diagnostic
	215	messages using C<$SIG{__WARN__}>; it is not apparent from the return
	216	value. (The modern interface may use the C<error> parameter to
	217	record any problems encountered.
	218
	219	=head2 ERROR HANDLING
	220
	221	If C<mkpath> or C<rmtree> encounter an error, a diagnostic message
	222	will be printed to C<STDERR> via C<carp> (for non-fatal errors),
	223	or via C<croak> (for fatal errors).
	224
	225	If this behaviour is not desirable, the C<error> attribute may be
	226	used to hold a reference to a variable, which will be used to store
	227	the diagnostics. The result is a reference to a list of hash
	228	references. For each hash reference, the key is the name of the
	229	file, and the value is the error message (usually the contents of
	230	C<$!>). An example usage looks like:
	231
	232	rmpath( 'foo/bar', 'bar/rat', {error => \my $err} );
	233	for my $diag (@$err) {
	234	my ($file, $message) = each %$diag;
	235	print "problem unlinking $file: $message\n";
	236	}
	237
	238	If no errors are encountered, C<$err> will point to an empty list
	239	(thus there is no need to test for C<undef>). If a general error
	240	is encountered (for instance, C<rmtree> attempts to remove a directory
	241	tree that does not exist), the diagnostic key will be empty, only
	242	the value will be set:
	243
	244	rmpath( '/no/such/path', {error => \my $err} );
	245	for my $diag (@$err) {
	246	my ($file, $message) = each %$diag;
	247	if ($file eq '') {
	248	print "general error: $message\n";
	249	}
	250	}
	251
	252	=head2 NOTES
	253
	254	=head3 HEURISTICS
	255
	256	The functions detect (as far as possible) which way they are being
	257	called and will act appropriately. It is important to remember that
	258	the heuristic for detecting the old style is either the presence
	259	of an array reference, or two or three parameters total and second
	260	and third parameters are numeric. Hence...
	261
	262	mkpath '486', '487', '488';
	263
	264	... will not assume the modern style and create three directories, rather
	265	it will create one directory verbosely, setting the permission to
	266	0750 (488 being the decimal equivalent of octal 750). Here, old
	267	style trumps new. It must, for backwards compatibility reasons.
e2ba98a1	268
12c2e016	269	If you want to ensure there is absolutely no ambiguity about which
	270	way the function will behave, make sure the first parameter is a
	271	reference to a one-element list, to force the old style interpretation:
e2ba98a1	272
12c2e016	273	mkpath ['486'], '487', '488';
	274
	275	and get only one directory created. Or add a reference to an empty
	276	parameter hash, to force the new style:
	277
	278	mkpath '486', '487', '488', {};
	279
	280	... and hence create the three directories. If the empty hash
	281	reference seems a little strange to your eyes, or you suspect a
	282	subsequent programmer might I<helpfully> optimise it away, you
	283	can add a parameter set to a default value:
	284
	285	mkpath '486', '487', '488', {verbose => 0};
	286
	287	=head3 RACE CONDITIONS
	288
	289	There are race conditions internal to the implementation of C<rmtree>
	290	making it unsafe to use on directory trees which may be altered or
	291	moved while C<rmtree> is running, and in particular on any directory
	292	trees with any path components or subdirectories potentially writable
	293	by untrusted users.
	294
	295	Additionally, if the C<skip_others> parareter is not set (or the
	296	third parameter in the traditional inferface is not TRUE) and
	297	C<rmtree> is interrupted, it may leave files and directories with
	298	permissions altered to allow deletion.
	299
	300	C<File::Path> blindly exports C<mkpath> and C<rmtree> into the
	301	current namespace. These days, this is considered bad style, but
	302	to change it now would break too much code. Nonetheless, you are
	303	invited to specify what it is you are expecting to use:
	304
	305	use File::Path 'rmtree';
96e4d5b1	306
b8d5f521	307	=head1 DIAGNOSTICS
	308
	309	=over 4
	310
	311	=item *
	312
	313	On Windows, if C<mkpath> gives you the warning: B<No such file or
	314	directory>, this may mean that you've exceeded your filesystem's
	315	maximum path length.
	316
	317	=back
	318
12c2e016	319	=head1 SEE ALSO
	320
	321	=over 4
	322
	323	=item *
	324
	325	L<Find::File::Rule>
	326
	327	When removing directory trees, if you want to examine each file
	328	before deciding whether to deleting it (and possibly leaving large
	329	swathes alone), F<File::Find::Rule> offers a convenient and flexible
	330	approach.
	331
	332	=back
	333
	334	=head1 BUGS
	335
	336	Please report all bugs on the RT queue:
	337
	338	L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Path>
	339
fed7345c	340	=head1 AUTHORS
fed7345c	341
96e4d5b1	342	Tim Bunce <F<Tim.Bunce@ig.co.uk>> and
12c2e016	343	Charles Bailey <F<bailey@newman.upenn.edu>>.
	344
	345	Currently maintained by David Landgren <F<david@landgren.net>>.
	346
	347	=head1 COPYRIGHT
	348
	349	This module is copyright (C) Charles Bailey, Tim Bunce and
	350	David Landgren 1995-2007. All rights reserved.
	351
	352	=head1 LICENSE
	353
	354	This library is free software; you can redistribute it and/or modify
	355	it under the same terms as Perl itself.
fed7345c	356
fed7345c	357	=cut
fed7345c	358
12c2e016	359	use 5.005_04;
037c8c09	360	use strict;
68dc0745	361
12c2e016	362	use File::Basename ();
	363	use File::Spec ();
	364	BEGIN {
91c4f65e	365	if ($] < 5.006) {
12c2e016	366	# can't say 'opendir my $dh, $dirname'
	367	# need to initialise $dh
	368	eval "use Symbol";
	369	}
	370	}
	371
	372	use Exporter ();
	373	use vars qw($VERSION @ISA @EXPORT);
	374	$VERSION = '2.00';
	375	@ISA = qw(Exporter);
	376	@EXPORT = qw(mkpath rmtree);
fed7345c	377
68dc0745	378	my $Is_VMS = $^O eq 'VMS';
ffb9ee5f	379	my $Is_MacOS = $^O eq 'MacOS';
037c8c09	380
	381	# These OSes complain if you want to remove a file that you have no
	382	# write permission to:
12c2e016	383	my $Force_Writeable = ($^O eq 'os2' \|\| $^O eq 'dos' \|\| $^O eq 'MSWin32' \|\|
fa6a1c44	384	$^O eq 'amigaos' \|\| $^O eq 'MacOS' \|\| $^O eq 'epoc');
748a9306	385
12c2e016	386	sub _carp {
8878f897	387	require Carp;
	388	goto &Carp::carp;
	389	}
	390
12c2e016	391	sub _croak {
8878f897	392	require Carp;
	393	goto &Carp::croak;
	394	}
	395
a5f75d66	396	sub mkpath {
12c2e016	397	my $new_style = (
	398	ref($_[0]) eq 'ARRAY'
	399	or (@_ == 2 and $_[1] =~ /\A\d+\z/)
	400	or (@_ == 3 and $_[1] =~ /\A\d+\z/ and $_[2] =~ /\A\d+\z/)
	401	) ? 0 : 1;
	402
	403	my $arg;
	404	my $paths;
	405
	406	if ($new_style) {
	407	if (ref $_[-1] eq 'HASH') {
	408	$arg = pop @_;
	409	exists $arg->{mask} and $arg->{mode} = delete $arg->{mask};
	410	$arg->{mode} = 0777 unless exists $arg->{mode};
	411	${$arg->{error}} = [] if exists $arg->{error};
	412	}
	413	else {
	414	@{$arg}{qw(verbose mode)} = (0, 0777);
	415	}
	416	$paths = [@_];
	417	}
	418	else {
	419	my ($verbose, $mode);
	420	($paths, $verbose, $mode) = @_;
	421	$paths = [$paths] unless ref($paths) eq 'ARRAY';
	422	$arg->{verbose} = defined $verbose ? $verbose : 0;
	423	$arg->{mode} = defined $mode ? $mode : 0777;
	424	}
	425	return _mkpath($arg, $paths);
	426	}
	427
	428	sub _mkpath {
	429	my $arg = shift;
	430	my $paths = shift;
	431
ffb9ee5f	432	local($")=$Is_MacOS ? ":" : "/";
037c8c09	433	my(@created,$path);
68dc0745	434	foreach $path (@$paths) {
12c2e016	435	next unless length($path);
1b1e14d3	436	$path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT
037c8c09	437	# Logic wants Unix paths, so go with the flow.
e3830a4e	438	if ($Is_VMS) {
	439	next if $path eq '/';
	440	$path = VMS::Filespec::unixify($path);
491527d0	441	}
e3830a4e	442	next if -d $path;
	443	my $parent = File::Basename::dirname($path);
	444	unless (-d $parent or $path eq $parent) {
12c2e016	445	push(@created,_mkpath($arg, [$parent]));
	446	}
	447	print "mkdir $path\n" if $arg->{verbose};
	448	if (mkdir($path,$arg->{mode})) {
	449	push(@created, $path);
dde45d8e	450	}
12c2e016	451	else {
	452	my $save_bang = $!;
	453	my ($e, $e1) = ($save_bang, $^E);
dde45d8e	454	$e .= "; $e1" if $e ne $e1;
c3420933	455	# allow for another process to have created it meanwhile
12c2e016	456	if (!-d $path) {
	457	$! = $save_bang;
	458	if ($arg->{error}) {
	459	push @{${$arg->{error}}}, {$path => $e};
	460	}
	461	else {
	462	_croak("mkdir $path: $e");
	463	}
67e4c828	464	}
fed7345c	465	}
12c2e016	466	}
12c2e016	467	return @created;
fed7345c	468	}
	469
	470	sub rmtree {
12c2e016	471	my $new_style = (
	472	ref($_[0]) eq 'ARRAY'
	473	or (@_ == 2 and $_[1] =~ /\A\d+\z/)
	474	or (@_ == 3 and $_[1] =~ /\A\d+\z/ and $_[2] =~ /\A\d+\z/)
	475	) ? 0 : 1;
	476
	477	my $arg;
	478	my $paths;
	479
	480	if ($new_style) {
	481	if (ref $_[-1] eq 'HASH') {
	482	$arg = pop @_;
	483	${$arg->{error}} = [] if exists $arg->{error};
	484	${$arg->{result}} = [] if exists $arg->{result};
	485	}
	486	else {
	487	@{$arg}{qw(verbose safe)} = (0, 0);
	488	}
	489	$arg->{depth} = 0;
	490	$paths = [@_];
	491	}
	492	else {
	493	my ($verbose, $safe);
	494	($paths, $verbose, $safe) = @_;
	495	$paths = [$paths] unless ref($paths) eq 'ARRAY';
	496	$arg->{verbose} = defined $verbose ? $verbose : 0;
	497	$arg->{safe} = defined $safe ? $safe : 0;
	498	}
fed7345c	499
12c2e016	500	if (@$paths < 1) {
	501	if ($arg->{error}) {
	502	push @{${$arg->{error}}}, {'' => "No root path(s) specified"};
ee79a11f	503	}
ee79a11f	504	else {
1158ce34	505	$arg->{verbose} and _carp ("No root path(s) specified\n");
12c2e016	506	}
ee79a11f	507	return 0;
ee79a11f	508	}
12c2e016	509	return _rmtree($arg, $paths);
12c2e016	510	}
ee79a11f	511
12c2e016	512	sub _rmtree {
	513	my $arg = shift;
	514	my $paths = shift;
	515	my($count) = 0;
	516	my (@files, $root);
	517	foreach $root (@{$paths}) {
ffb9ee5f	518	if ($Is_MacOS) {
ffb9ee5f	519	$root = ":$root" if $root !~ /:/;
12c2e016	520	$root =~ s/([^:])\z/$1:/;
	521	}
	522	else {
ffb9ee5f	523	$root =~ s#/\z##;
ffb9ee5f	524	}
12c2e016	525	my $rp = (lstat $root)[2] or next;
7025f710	526	$rp &= 07777; # don't forget setuid, setgid, sticky bits
7025f710	527	if ( -d _ ) {
e2ba98a1	528	# notabene: 0700 is for making readable in the first place,
037c8c09	529	# it's also intended to change it to writable in case we have
	530	# to recurse in which case we are better than rm -rf for
	531	# subtrees with strange permissions
12c2e016	532	if (!chmod($rp \| 0700,
	533	($Is_VMS ? VMS::Filespec::fileify($root) : $root))
	534	) {
	535	if (!$arg->{safe}) {
	536	if ($arg->{error}) {
	537	push @{${$arg->{error}}},
	538	{$root => "Can't make directory read+writeable: $!"};
	539	}
	540	else {
	541	_carp ("Can't make directory $root read+writeable: $!");
	542	}
	543	}
	544	}
	545
	546	my $d;
	547	$d = gensym() if $] < 5.006;
	548	if (!opendir $d, $root) {
	549	if ($arg->{error}) {
	550	push @{${$arg->{error}}}, {$root => "opendir: $!"};
	551	}
	552	else {
	553	_carp ("Can't read $root: $!");
	554	}
	555	@files = ();
	556	}
	557	else {
7068481f	558	no strict 'refs';
7068481f	559	if (!defined ${"\cTAINT"} or ${"\cTAINT"}) {
12c2e016	560	# Blindly untaint dir names if taint mode is
	561	# active, or any perl < 5.006
	562	@files = map { /\A(.*)\z/s; $1 } readdir $d;
	563	}
	564	else {
7068481f	565	@files = readdir $d;
7068481f	566	}
ff21075d	567	closedir $d;
ff21075d	568	}
037c8c09	569
	570	# Deleting large numbers of files from VMS Files-11 filesystems
	571	# is faster if done in reverse ASCIIbetical order
	572	@files = reverse @files if $Is_VMS;
1b1e14d3	573	($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS;
ffb9ee5f	574	if ($Is_MacOS) {
ffb9ee5f	575	@files = map("$root$_", @files);
ffb9ee5f	576	}
12c2e016	577	else {
	578	my $updir = File::Spec->updir();
	579	my $curdir = File::Spec->curdir();
bfbf02a1	580	@files = map(File::Spec->catfile($root,$_),
12c2e016	581	grep {$_ ne $updir and $_ ne $curdir}
	582	@files
	583	);
	584	}
	585	$arg->{depth}++;
	586	$count += _rmtree($arg, \@files);
	587	$arg->{depth}--;
	588	if ($arg->{depth} or !$arg->{keep_root}) {
	589	if ($arg->{safe} &&
037c8c09	590	($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
12c2e016	591	print "skipped $root\n" if $arg->{verbose};
037c8c09	592	next;
037c8c09	593	}
12c2e016	594	if (!chmod $rp \| 0700, $root) {
	595	if ($Force_Writeable) {
	596	if ($arg->{error}) {
	597	push @{${$arg->{error}}},
	598	{$root => "Can't make directory writeable: $!"};
	599	}
	600	else {
	601	_carp ("Can't make directory $root writeable: $!")
	602	}
	603	}
	604	}
	605	print "rmdir $root\n" if $arg->{verbose};
96e4d5b1	606	if (rmdir $root) {
12c2e016	607	push @{${$arg->{result}}}, $root if $arg->{result};
96e4d5b1	608	++$count;
	609	}
	610	else {
12c2e016	611	if ($arg->{error}) {
	612	push @{${$arg->{error}}}, {$root => "rmdir: $!"};
	613	}
	614	else {
	615	_carp ("Can't remove directory $root: $!");
96e4d5b1	616	}
12c2e016	617	if (!chmod($rp,
	618	($Is_VMS ? VMS::Filespec::fileify($root) : $root))
	619	) {
	620	my $mask = sprintf("0%o",$rp);
	621	if ($arg->{error}) {
	622	push @{${$arg->{error}}}, {$root => "restore chmod: $!"};
037c8c09	623	}
037c8c09	624	else {
12c2e016	625	_carp("and can't restore permissions to $mask\n");
	626	}
	627	}
	628	}
	629	}
	630	}
	631	else {
	632	if ($arg->{safe} &&
64f6ddac	633	($Is_VMS ? !&VMS::Filespec::candelete($root)
	634	: !(-l $root \|\| -w $root)))
	635	{
12c2e016	636	print "skipped $root\n" if $arg->{verbose};
037c8c09	637	next;
037c8c09	638	}
12c2e016	639	if (!chmod $rp \| 0600, $root) {
	640	if ($Force_Writeable) {
	641	if ($arg->{error}) {
	642	push @{${$arg->{error}}},
	643	{$root => "Can't make file writeable: $!"};
	644	}
	645	else {
	646	_carp ("Can't make file $root writeable: $!")
	647	}
	648	}
	649	}
	650	print "unlink $root\n" if $arg->{verbose};
037c8c09	651	# delete all versions under VMS
94d4f21c	652	for (;;) {
12c2e016	653	if (unlink $root) {
	654	push @{${$arg->{result}}}, $root if $arg->{result};
	655	}
	656	else {
	657	if ($arg->{error}) {
	658	push @{${$arg->{error}}},
	659	{$root => "unlink: $!"};
	660	}
	661	else {
	662	_carp ("Can't unlink file $root: $!");
	663	}
	664	if ($Force_Writeable) {
	665	if (!chmod $rp, $root) {
	666	my $mask = sprintf("0%o",$rp);
	667	if ($arg->{error}) {
	668	push @{${$arg->{error}}}, {$root => "restore chmod: $!"};
	669	}
	670	else {
	671	_carp("and can't restore permissions to $mask\n");
	672	}
	673	}
96e4d5b1	674	}
94d4f21c	675	last;
96e4d5b1	676	}
94d4f21c	677	++$count;
94d4f21c	678	last unless $Is_VMS && lstat $root;
037c8c09	679	}
037c8c09	680	}
fed7345c	681	}
fed7345c	682
12c2e016	683	return $count;
fed7345c	684	}
	685
	686	1;