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');
}