File-Path-2.08

diff -urN perl-5.10.1.orig/lib/File/Path.pm perl-5.10.1/lib/File/Path.pm
--- perl-5.10.1.orig/lib/File/Path.pm	2009-06-27 18:14:41.000000000 +0200
+++ perl-5.10.1/lib/File/Path.pm	2009-12-01 11:43:31.000000000 +0100
@@ -17,7 +17,7 @@
 
 use Exporter ();
 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
-$VERSION   = '2.07_03';
+$VERSION   = '2.08';
 @ISA       = qw(Exporter);
 @EXPORT    = qw(mkpath rmtree);
 @EXPORT_OK = qw(make_path remove_tree);
@@ -81,6 +81,34 @@
         $arg->{mode}      = delete $arg->{mask} if exists $arg->{mask};
         $arg->{mode}      = 0777 unless exists $arg->{mode};
         ${$arg->{error}}  = [] if exists $arg->{error};
+        $arg->{owner}     = delete $arg->{user} if exists $arg->{user};
+        $arg->{owner}     = delete $arg->{uid}  if exists $arg->{uid};
+        if (exists $arg->{owner} and $arg->{owner} =~ /\D/) {
+            my $uid = (getpwnam $arg->{owner})[2];
+            if (defined $uid) {
+                $arg->{owner} = $uid;
+            }
+            else {
+                _error($arg, "unable to map $arg->{owner} to a uid, ownership not changed");
+                delete $arg->{owner};
+            }
+        }
+        if (exists $arg->{group} and $arg->{group} =~ /\D/) {
+            my $gid = (getgrnam $arg->{group})[2];
+            if (defined $gid) {
+                $arg->{group} = $gid;
+            }
+            else {
+                _error($arg, "unable to map $arg->{group} to a gid, group ownership not changed");
+                delete $arg->{group};
+            }
+        }
+        if (exists $arg->{owner} and not exists $arg->{group}) {
+            $arg->{group} = -1; # chown will leave group unchanged
+        }
+        if (exists $arg->{group} and not exists $arg->{owner}) {
+            $arg->{owner} = -1; # chown will leave owner unchanged
+        }
         $paths = [@_];
     }
     return _mkpath($arg, $paths);
@@ -107,6 +135,12 @@
         print "mkdir $path\n" if $arg->{verbose};
         if (mkdir($path,$arg->{mode})) {
             push(@created, $path);
+            if (exists $arg->{owner}) {
+				# NB: $arg->{group} guaranteed to be set during initialisation
+                if (!chown $arg->{owner}, $arg->{group}, $path) {
+                    _error($arg, "Cannot change ownership of $path to $arg->{owner}:$arg->{group}");
+                }
+            }
         }
         else {
             my $save_bang = $!;
@@ -422,8 +456,8 @@
 
 =head1 VERSION
 
-This document describes version 2.07 of File::Path, released
-2008-11-09.
+This document describes version 2.08 of File::Path, released
+2009-10-04.
 
 =head1 SYNOPSIS
 
@@ -505,6 +539,34 @@
 a fatal error that will cause the program will halt, unless trapped
 in an C<eval> block.
 
+=item owner => $owner
+
+=item user => $owner
+
+=item uid => $owner
+
+If present, will cause any created directory to be owned by C<$owner>.
+If the value is numeric, it will be interpreted as a uid, otherwise
+as username is assumed. An error will be issued if the username cannot be
+mapped to a uid, or the uid does not exist, or the process lacks the
+privileges to change ownership.
+
+Ownwership of directories that already exist will not be changed.
+
+C<user> and C<uid> are aliases of C<owner>.
+
+=item group => $group
+
+If present, will cause any created directory to be owned by the group C<$group>.
+If the value is numeric, it will be interpreted as a gid, otherwise
+as group name is assumed. An error will be issued if the group name cannot be
+mapped to a gid, or the gid does not exist, or the process lacks the
+privileges to change group ownership.
+
+Group ownwership of directories that already exist will not be changed.
+
+    make_path '/var/tmp/webcache', {owner=>'nobody', group=>'nogroup'};
+
 =back
 
 =item mkpath( $dir )
@@ -672,6 +734,17 @@
 
   use File::Path qw(remove_tree rmtree);
 
+=head3 API CHANGES
+
+The API was changed in the 2.0 branch. For a time, C<mkpath> and
+C<rmtree> tried, unsuccessfully, to deal with the two different
+calling mechanisms. This approach was considered a failure.
+
+The new semantics are now only available with C<make_path> and
+C<remove_tree>. The old semantics are only available through
+C<mkpath> and C<rmtree>. Users are strongly encouraged to upgrade
+to at least 2.08 in order to avoid surprises.
+
 =head3 SECURITY CONSIDERATIONS
 
 There were race conditions 1.x implementations of File::Path's
@@ -835,6 +908,20 @@
 to restore the permissions on the file to a possibly less permissive
 setting. (Permissions given in octal).
 
+=item unable to map [owner] to a uid, ownership not changed");
+
+C<make_path> was instructed to give the ownership of created
+directories to the symbolic name [owner], but C<getpwnam> did
+not return the corresponding numeric uid. The directory will
+be created, but ownership will not be changed.
+
+=item unable to map [group] to a gid, group ownership not changed
+
+C<make_path> was instructed to give the group ownership of created
+directories to the symbolic name [group], but C<getgrnam> did
+not return the corresponding numeric gid. The directory will
+be created, but group ownership will not be changed.
+
 =back
 
 =head1 SEE ALSO
@@ -885,7 +972,7 @@
 =head1 COPYRIGHT
 
 This module is copyright (C) Charles Bailey, Tim Bunce and
-David Landgren 1995-2008. All rights reserved.
+David Landgren 1995-2009. All rights reserved.
 
 =head1 LICENSE
 
diff -urN perl-5.10.1.orig/lib/File/Path.t perl-5.10.1/lib/File/Path.t
--- perl-5.10.1.orig/lib/File/Path.t	2009-06-27 18:14:41.000000000 +0200
+++ perl-5.10.1/lib/File/Path.t	2009-12-01 11:43:48.000000000 +0100
@@ -2,7 +2,7 @@
 
 use strict;
 
-use Test::More tests => 121;
+use Test::More tests => 129;
 use Config;
 
 BEGIN {
@@ -323,7 +323,7 @@
     # test bug http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=487319
     skip "Don't need Force_Writeable semantics on $^O", 4
         if grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2);
-    skip "Symlinks not available", 4 unless $Config{'d_symlink'};
+    skip "Symlinks not available", 4 unless $Config{d_symlink};
     $dir  = 'bug487319';
     $dir2 = 'bug487319-symlink';
     @created = make_path($dir, {mask => 0700});
@@ -381,7 +381,7 @@
 SKIP: {
     skip "extra scenarios not set up, see eg/setup-extra-tests", 14
         unless -e $extra;
-    skip "Symlinks not available", 14 unless $Config{'d_symlink'};
+    skip "Symlinks not available", 14 unless $Config{d_symlink};
 
     my ($list, $err);
     $dir = catdir( 'EXTRA', '1' );
@@ -434,6 +434,78 @@
 }
 
 SKIP: {
+    my $skip_count = 8; # DRY
+    skip "getpwent() not implemented on $^O", $skip_count
+        unless $Config{d_getpwent};
+    skip "getgrent() not implemented on $^O", $skip_count
+        unless $Config{d_getgrent};
+    skip 'not running as root', $skip_count
+        unless $< == 0;
+
+    my $dir_stem = $dir = catdir($tmp_base, 'owned-by');
+
+    # find the highest uid ('nobody' or similar)
+    my $max_uid   = 0;
+    my $max_user = undef;
+    while (my @u = getpwent()) {
+        if ($max_uid < $u[2]) {
+            $max_uid  = $u[2];
+            $max_user = $u[0];
+        }
+    }
+    skip 'getpwent() appears to be insane', $skip_count
+        unless $max_uid > 0;
+
+    # find the highest gid ('nogroup' or similar)
+    my $max_gid   = 0;
+    my $max_group = undef;
+    while (my @g = getgrent()) {
+        if ($max_gid < $g[2]) {
+            $max_gid = $g[2];
+            $max_group = $g[0];
+        }
+    }
+    skip 'getgrent() appears to be insane', $skip_count
+        unless $max_gid > 0;
+
+    $dir = catdir($dir_stem, 'aaa');
+    @created = make_path($dir, {owner => $max_user});
+    is(scalar(@created), 2, "created a directory owned by $max_user...");
+    my $dir_uid = (stat $created[0])[4];
+    is($dir_uid, $max_uid, "... owned by $max_uid");
+
+    $dir = catdir($dir_stem, 'aab');
+    @created = make_path($dir, {group => $max_group});
+    is(scalar(@created), 1, "created a directory owned by group $max_group...");
+    my $dir_gid = (stat $created[0])[5];
+    is($dir_gid, $max_gid, "... owned by group $max_gid");
+
+    $dir = catdir($dir_stem, 'aac');
+    @created = make_path($dir, {user => $max_user, group => $max_group});
+    is(scalar(@created), 1, "created a directory owned by $max_user:$max_group...");
+    ($dir_uid, $dir_gid) = (stat $created[0])[4,5];
+    is($dir_uid, $max_uid, "... owned by $max_uid");
+    is($dir_gid, $max_gid, "... owned by group $max_gid");
+
+    SKIP: {
+        skip 'Test::Output not available', 1
+               unless $has_Test_Output;
+
+        # invent a user and group that don't exist
+        do { ++$max_user  } while (getpwnam($max_user));
+        do { ++$max_group } while (getgrnam($max_group));
+
+        $dir = catdir($dir_stem, 'aad');
+        stderr_like(
+            sub {make_path($dir, {user => $max_user, group => $max_group})},
+            qr{\Aunable to map $max_user to a uid, ownership not changed: .* at \S+ line \d+
+unable to map $max_group to a gid, group ownership not changed: .* at \S+ line \d+\b},
+            "created a directory not owned by $max_user:$max_group..."
+        );
+    }
+}
+
+SKIP: {
     skip 'Test::Output not available', 14
         unless $has_Test_Output;
 
@@ -574,15 +646,15 @@
     my $xx = $x . "x";
     
     # setup
-    ok(mkpath($xx));
-    ok(chdir($xx));
+    ok(mkpath($xx), "make $xx");
+    ok(chdir($xx), "... and chdir $xx");
     END {
-         ok(chdir($p));
-         ok(rmtree($xx));
+         ok(chdir($p), "... now chdir $p");
+         ok(rmtree($xx), "... and finally rmtree $xx");
     }
     
     # create and delete directory
     my $px = catdir($p, $x);
-    ok(mkpath($px));
-    ok(rmtree($px), "rmtree");     # fails in File-Path-2.07
+    ok(mkpath($px), 'create and delete directory 2.07');
+    ok(rmtree($px), '.. rmtree fails in File-Path-2.07');
 }