Update File-Path to 2.00
David Landgren [Wed, 30 May 2007 19:50:38 +0000 (21:50 +0200)]
Message-ID: <465DB96E.1020106@landgren.net>

p4raw-id: //depot/perl@31315

lib/File/Path.pm
lib/File/Path.t

index 002b9ef..9a0e48c 100644 (file)
@@ -2,26 +2,153 @@ package File::Path;
 
 =head1 NAME
 
-File::Path - create or remove directory trees
+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, errors  => \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.  C<mkpath> takes three arguments:
+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
+The name of the path to create, or a reference
 to a list of paths to create,
 
 =item *
@@ -50,9 +177,7 @@ can be trapped with an C<eval> block:
     print "Couldn't create $dir: $@";
   }
 
-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>.
-C<rmtree> takes three arguments:
+In the traditional form, C<rmtree> takes three arguments:
 
 =over 4
 
@@ -85,20 +210,99 @@ than VMS is settled.  (defaults to FALSE)
 It returns the number of files, directories and symlinks successfully
 deleted.  Symlinks are simply deleted and not followed.
 
-B<NOTE:> 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.
+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.
 
-Additionally, if the third parameter is not TRUE and C<rmtree> is
-interrupted, it may leave files and directories with permissions altered
-to allow deletion (and older versions of this module would even set
-files and directories to world-read/writable!)
+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:
 
-Note also that the occurrence of errors in C<rmtree> can be determined I<only>
-by trapping diagnostic messages using C<$SIG{__WARN__}>; it is not apparent
-from the return value.
+    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
 
@@ -112,51 +316,126 @@ 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>>
+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.006;
-use File::Basename ();
-use Exporter ();
+use 5.005_04;
 use strict;
-use warnings;
 
-our $VERSION = "1.09";
-our @ISA = qw( Exporter );
-our @EXPORT = qw( mkpath rmtree );
+use File::Basename ();
+use File::Spec     ();
+BEGIN {
+    if ($] >= 5.006) {
+        eval "use warnings";
+    }
+    else {
+        # 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' ||
+my $Force_Writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32' ||
                       $^O eq 'amigaos' || $^O eq 'MacOS' || $^O eq 'epoc');
 
-sub carp {
+sub _carp {
     require Carp;
     goto &Carp::carp;
 }
 
-sub croak {
+sub _croak {
     require Carp;
     goto &Carp::croak;
 }
 
 sub mkpath {
-    my($paths, $verbose, $mode) = @_;
-    # $paths   -- either a path string or ref to list of paths
-    # $verbose -- optional print "mkdir $path" for each directory created
-    # $mode    -- optional permissions, defaults to 0777
+    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 ? ":" : "/";
-    $mode = 0777 unless defined($mode);
-    $paths = [$paths] unless ref $paths;
     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) {
@@ -166,68 +445,130 @@ sub mkpath {
        next if -d $path;
        my $parent = File::Basename::dirname($path);
        unless (-d $parent or $path eq $parent) {
-           push(@created,mkpath($parent, $verbose, $mode));
+            push(@created,_mkpath($arg, [$parent]));
+        }
+        print "mkdir $path\n" if $arg->{verbose};
+        if (mkdir($path,$arg->{mode})) {
+            push(@created, $path);
        }
-       print "mkdir $path\n" if $verbose;
-       unless (mkdir($path,$mode)) {
-           my ($e, $e1) = ($!, $^E);
+        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
-           $! = $e, croak ("mkdir $path: $e") unless -d $path;
+            if (!-d $path) {
+                $! = $save_bang;
+                if ($arg->{error}) {
+                    push @{${$arg->{error}}}, {$path => $e};
+                }
+                else {
+                    _croak("mkdir $path: $e");
+                }
        }
-       push(@created, $path);
     }
-    @created;
+    }
+    return @created;
 }
 
 sub rmtree {
-    my($roots, $verbose, $safe) = @_;
-    my(@files);
-    my($count) = 0;
-    $verbose ||= 0;
-    $safe ||= 0;
+    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 ( defined($roots) && length($roots) ) {
-      $roots = [$roots] unless ref $roots;
+    if (@$paths < 1) {
+        if ($arg->{error}) {
+            push @{${$arg->{error}}}, {'' => "No root path(s) specified"};
     }
     else {
-      carp ("No root path(s) specified\n");
+            _carp ("No root path(s) specified\n");
+        }
       return 0;
     }
+    return _rmtree($arg, $paths);
+}
 
-    my($root);
-    foreach $root (@{$roots}) {
+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/$1:/;
+        }
+        else {
            $root =~ s#/\z##;
        }
-       (undef, undef, my $rp) = lstat $root or next;
+        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
-           chmod($rp | 0700, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
-             or carp ("Can't make directory $root read+writeable: $!")
-               unless $safe;
-
-           if (opendir my $d, $root) {
+            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
-                   @files = map { /^(.*)$/s ; $1 } readdir $d;
-               } else {
+                    # 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;
            }
-           else {
-               carp ("Can't read $root: $!");
-               @files = ();
-           }
 
            # Deleting large numbers of files from VMS Files-11 filesystems
            # is faster if done in reverse ASCIIbetical order 
@@ -235,49 +576,104 @@ sub rmtree {
            ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS;
            if ($Is_MacOS) {
                @files = map("$root$_", @files);
-           } else {
-               @files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files);
            }
-           $count += rmtree(\@files,$verbose,$safe);
-           if ($safe &&
+            else {
+                my $updir  = File::Spec->updir();
+                my $curdir = File::Spec->curdir();
+                @files = map(File::Spec->catdir($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 $verbose;
+                    print "skipped $root\n" if $arg->{verbose};
                next;
            }
-           chmod $rp | 0700, $root
-             or carp ("Can't make directory $root writeable: $!")
-               if $force_writeable;
-           print "rmdir $root\n" if $verbose;
+                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 {
-               carp ("Can't remove directory $root: $!");
-               chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
-                   or carp("and can't restore permissions to "
-                           . sprintf("0%o",$rp) . "\n");
+                    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 { 
-           if ($safe &&
+                            _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 $verbose;
+                print "skipped $root\n" if $arg->{verbose};
                next;
            }
-           chmod $rp | 0600, $root
-             or carp ("Can't make file $root writeable: $!")
-               if $force_writeable;
-           print "unlink $root\n" if $verbose;
+            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 (;;) {
-               unless (unlink $root) {
-                   carp ("Can't unlink file $root: $!");
-                   if ($force_writeable) {
-                       chmod $rp, $root
-                           or carp("and can't restore permissions to "
-                                   . sprintf("0%o",$rp) . "\n");
+                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;
                }
@@ -287,7 +683,7 @@ sub rmtree {
        }
     }
 
-    $count;
+    return $count;
 }
 
 1;
index 84575d7..6162cba 100755 (executable)
@@ -1,18 +1,16 @@
-#!./perl -wT
+# Path.t -- tests for module File::Path
 
-BEGIN {
-    chdir 't' if -d 't';
-    @INC = '../lib';
-}
-
-use File::Path;
-use File::Spec::Functions;
 use strict;
 
-my $count = 0;
-use warnings;
+use Test::More tests => 72;
 
-print "1..4\n";
+BEGIN {
+    use_ok('File::Path');
+    use_ok('File::Spec::Functions');
+}
+
+eval "use Test::Output";
+my $has_Test_Output = $@ ? 0 : 1;
 
 # first check for stupid permissions second for full, so we clean up
 # behind ourselves
@@ -21,10 +19,311 @@ for my $perm (0111,0777) {
     mkpath($path);
     chmod $perm, "mhx", $path;
 
-    print "not " unless -d "mhx" && -d $path;
-    print "ok ", ++$count, "\n";
+    my $oct = sprintf('0%o', $perm);
+    ok(-d "mhx", "mkdir parent dir $oct");
+    ok(-d $path, "mkdir child dir $oct");
 
     rmtree("mhx");
-    print "not " if -e "mhx";
-    print "ok ", ++$count, "\n";
+    ok(! -e "mhx", "mhx does not exist $oct");
+}
+
+# find a place to work
+my ($error, $list, $file, $message);
+my $tmp_base = catdir(
+    curdir(),
+    sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ),
+);
+
+# invent some names
+my @dir = (
+    catdir($tmp_base, qw(a b)),
+    catdir($tmp_base, qw(a c)),
+    catdir($tmp_base, qw(z b)),
+    catdir($tmp_base, qw(z c)),
+);
+
+# create them
+my @created = mkpath(@dir);
+
+is(scalar(@created), 7, "created list of directories");
+
+# pray for no race conditions blowing them out from under us
+@created = mkpath([$tmp_base]);
+is(scalar(@created), 0, "skipped making existing directory")
+    or diag("unexpectedly recreated @created");
+
+@created = mkpath('');
+is(scalar(@created), 0, "Can't create a directory named ''");
+
+my $dir;
+my $dir2;
+
+SKIP: {
+    $dir = catdir($tmp_base, 'B');
+    $dir2 = catdir($dir, updir());
+    # IOW: File::Spec->catdir( qw(foo bar), File::Spec->updir ) eq 'foo'
+    # rather than foo/bar/..    
+    skip "updir() canonicalises path on this platform", 2
+        if $dir2 eq $tmp_base;
+        
+    @created = mkpath($dir2, {mask => 0700});
+    is(scalar(@created), 1, "make directory with trailing parent segment");
+    is($created[0], $dir, "made parent");
+};
+
+my $count = rmtree({error => \$error});
+is( $count, 0, 'rmtree of nothing, count of zero' );
+is( scalar(@$error), 1, 'one diagnostic captureed' );
+eval { ($file, $message) = each %{$error->[0]} }; # too early to die, just in case
+is( $@, '', 'decoded diagnostic' );
+is( $file, '', 'general diagnostic' );
+is( $message, 'No root path(s) specified', 'expected diagnostic received' );
+
+@created = mkpath($tmp_base, 0);
+is(scalar(@created), 0, "skipped making existing directories (old style 1)")
+    or diag("unexpectedly recreated @created");
+
+$dir = catdir($tmp_base,'C');
+@created = mkpath($tmp_base, $dir);
+is(scalar(@created), 1, "created directory (new style 1)");
+is($created[0], $dir, "created directory (new style 1) cross-check");
+
+@created = mkpath($tmp_base, 0, 0700);
+is(scalar(@created), 0, "skipped making existing directories (old style 2)")
+    or diag("unexpectedly recreated @created");
+
+$dir2 = catdir($tmp_base,'D');
+@created = mkpath($tmp_base, $dir, $dir2);
+is(scalar(@created), 1, "created directory (new style 2)");
+is($created[0], $dir2, "created directory (new style 2) cross-check");
+
+$count = rmtree($dir, 0);
+is($count, 1, "removed directory (old style 1)");
+
+$count = rmtree($dir2, 0, 1);
+is($count, 1, "removed directory (old style 2)");
+
+# mkdir foo ./E/../Y
+# Y should exist
+# existence of E is neither here nor there
+$dir = catdir($tmp_base, 'E', updir(), 'Y');
+@created =mkpath($dir);
+cmp_ok(scalar(@created), '>=', 1, "made one or more dirs because of ..");
+cmp_ok(scalar(@created), '<=', 2, "made less than two dirs because of ..");
+ok( -d catdir($tmp_base, 'Y'), "directory after parent" );
+
+@created = mkpath(catdir(curdir(), $tmp_base));
+is(scalar(@created), 0, "nothing created")
+    or diag(@created);
+
+$dir  = catdir($tmp_base, 'a');
+$dir2 = catdir($tmp_base, 'z');
+
+rmtree( $dir, $dir2,
+    {
+        error     => \$error,
+        result    => \$list,
+        keep_root => 1,
+    }
+);
+
+is(scalar(@$error), 0, "no errors unlinking a and z");
+is(scalar(@$list),  4, "list contains 4 elements")
+    or diag("@$list");
+
+ok(-d $dir,  "dir a still exists");
+ok(-d $dir2, "dir z still exists");
+
+# borderline new-style heuristics
+if (chdir $tmp_base) {
+    pass("chdir to temp dir");
+}
+else {
+    fail("chdir to temp dir: $!");
 }
+
+$dir   = catdir('a', 'd1');
+$dir2  = catdir('a', 'd2');
+
+@created = mkpath( $dir, 0, $dir2 );
+is(scalar @created, 3, 'new-style 3 dirs created');
+
+$count = rmtree( $dir, 0, $dir2, );
+is($count, 3, 'new-style 3 dirs removed');
+
+@created = mkpath( $dir, $dir2, 1 );
+is(scalar @created, 3, 'new-style 3 dirs created (redux)');
+
+$count = rmtree( $dir, $dir2, 1 );
+is($count, 3, 'new-style 3 dirs removed (redux)');
+
+@created = mkpath( $dir, $dir2 );
+is(scalar @created, 2, 'new-style 2 dirs created');
+
+$count = rmtree( $dir, $dir2 );
+is($count, 2, 'new-style 2 dirs removed');
+
+if (chdir updir()) {
+    pass("chdir parent");
+}
+else {
+    fail("chdir parent: $!");
+}
+
+# see what happens if a file exists where we want a directory
+SKIP: {
+    my $entry = catdir($tmp_base, "file");
+    skip "Cannot create $entry", 4 unless open OUT, "> $entry";
+    print OUT "test file, safe to delete\n", scalar(localtime), "\n";
+    close OUT;
+    ok(-e $entry, "file exists in place of directory");
+
+    mkpath( $entry, {error => \$error} );
+    is( scalar(@$error), 1, "caught error condition" );
+    ($file, $message) = each %{$error->[0]};
+    is( $entry, $file, "and the message is: $message");
+
+    eval {@created = mkpath($entry, 0, 0700)};
+    $error = $@;
+    chomp $error; # just to remove silly # in TAP output
+    cmp_ok( $error, 'ne', "", "no directory created (old-style) err=$error" )
+        or diag(@created);
+}
+
+my $extra =  catdir(curdir(), qw(EXTRA 1 a));
+
+SKIP: {
+    skip "extra scenarios not set up, see eg/setup-extra-tests", 8
+        unless -e $extra;
+
+    my ($list, $err);
+    $dir = catdir( 'EXTRA', '1' );
+    rmtree( $dir, {result => \$list, error => \$err} );
+    is(scalar(@$list), 2, "extra dir $dir removed");
+    is(scalar(@$err), 1, "one error encountered");
+
+    $dir = catdir( 'EXTRA', '3', 'N' );
+    rmtree( $dir, {result => \$list, error => \$err} );
+    is( @$list, 1, q{remove a symlinked dir} );
+    is( @$err,  0, q{with no errors} );
+
+    $dir = catdir('EXTRA', '3', 'S');
+    rmtree($dir, {error => \$error});
+    is( scalar(@$error), 2, 'two errors for an unreadable dir' );
+
+    $dir = catdir( 'EXTRA', '4' );
+    rmtree($dir,  {result => \$list, error => \$err} );
+    is( @$list, 0, q{don't follow a symlinked dir} );
+    is( @$err,  1, q{one error when removing a symlink in r/o dir} );
+    eval { ($file, $message) = each %{$err->[0]} };
+    is( $file, $dir, 'symlink reported in error' );
+}
+
+SKIP: {
+    skip 'Test::Output not available', 10
+        unless $has_Test_Output;
+
+    SKIP: {
+        $dir = catdir('EXTRA', '3');
+        skip "extra scenarios not set up, see eg/setup-extra-tests", 2
+            unless -e $dir;
+
+        stderr_like( 
+            sub {rmtree($dir, {})},
+            qr{\ACan't remove directory \S+: .*? at \S+ line \d+\n},
+            'rmtree with file owned by root'
+        );
+
+        stderr_like( 
+            sub {rmtree('EXTRA', {})},
+            qr{\ACan't make directory EXTRA read\+writeable: .*? at \S+ line \d+
+(?:Can't remove directory EXTRA/\d: .*? at \S+ line \d+
+)+Can't unlink file [^:]+: .*? at \S+ line \d+
+Can't remove directory EXTRA: .*? at \S+ line \d+
+and can't restore permissions to \d+
+ at \S+ line \d+},
+            'rmtree with insufficient privileges'
+        );
+    }
+
+    my $base = catdir($tmp_base,'output');
+    $dir  = catdir($base,'A');
+    $dir2 = catdir($base,'B');
+
+    stderr_like(
+        \&rmtree,
+        qr/\ANo root path\(s\) specified\b/,
+        "rmtree of nothing carps sensibly"
+    );
+
+    stdout_is(
+        sub {@created = mkpath($dir, 1)},
+        "mkdir $base\nmkdir $dir\n",
+        'mkpath verbose (old style 1)'
+    );
+
+    stdout_is(
+        sub {@created = mkpath([$dir2], 1)},
+        "mkdir $dir2\n",
+        'mkpath verbose (old style 2)'
+    );
+
+    stdout_is(
+        sub {$count = rmtree([$dir, $dir2], 1, 1)},
+        "rmdir $dir\nrmdir $dir2\n",
+        'rmtree verbose (old style)'
+    );
+
+    stdout_is(
+        sub {@created = mkpath($dir, {verbose => 1, mask => 0750})},
+        "mkdir $dir\n",
+        'mkpath verbose (new style 1)'
+    );
+
+    stdout_is(
+        sub {@created = mkpath($dir2, 1, 0771)},
+        "mkdir $dir2\n",
+        'mkpath verbose (new style 2)'
+    );
+
+    SKIP: {
+        $file = catdir($dir2, "file");
+        skip "Cannot create $file", 2 unless open OUT, "> $file";
+        print OUT "test file, safe to delete\n", scalar(localtime), "\n";
+        close OUT;
+
+        ok(-e $file, "file created in directory");
+
+        stdout_is(
+            sub {$count = rmtree($dir, $dir2, {verbose => 1, safe => 1})},
+            "rmdir $dir\nunlink $file\nrmdir $dir2\n",
+            'rmtree safe verbose (new style)'
+        );
+    }
+}
+
+SKIP: {
+    skip "extra scenarios not set up, see eg/setup-extra-tests", 6
+        unless -d catdir(qw(EXTRA 1));
+
+    rmtree 'EXTRA', {safe => 0, error => \$error};
+    is( scalar(@$error), 7, 'seven deadly sins' );
+
+    rmtree 'EXTRA', {safe => 1, error => \$error};
+    is( scalar(@$error), 4, 'safe is better' );
+    for (@$error) {
+        ($file, $message) = each %$_;
+        if ($file =~  /[123]\z/) {
+            is(index($message, 'rmdir: '), 0, "failed to remove $file with rmdir")
+                or diag($message);
+        }
+        else {
+            is(index($message, 'unlink: '), 0, "failed to remove $file with unlink")
+                or diag($message);
+        }
+    }
+}
+
+rmtree($tmp_base, {result => \$list} );
+is(ref($list), 'ARRAY', "received a final list of results");
+ok( !(-d $tmp_base), "test base directory gone" );