From: Rafael Garcia-Suarez <rgs@consttype.org>
Date: Mon, 5 Oct 2009 11:53:00 +0000 (+0200)
Subject: Upgrade File::Path to 2.08 (and add taint.t test)
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=30eb83e14adc33b610414ff28fab0f8316c1fba7;p=p5sagit%2Fp5-mst-13.2.git

Upgrade File::Path to 2.08 (and add taint.t test)
---

diff --git a/MANIFEST b/MANIFEST
index 9eaaf67..fb684bf 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1044,6 +1044,7 @@ cpan/File-Fetch/lib/File/Fetch.pm	File::Fetch
 cpan/File-Fetch/t/01_File-Fetch.t	File::Fetch tests
 cpan/File-Path/lib/File/Path.pm		Do things like 'mkdir -p' and 'rm -r'
 cpan/File-Path/t/Path.t			See if File::Path works
+cpan/File-Path/t/taint.t		See if File::Path works with -T
 cpan/File-Temp/t/cmp.t		See if File::Temp works
 cpan/File-Temp/Temp.pm		create safe temporary files and file handles
 cpan/File-Temp/t/fork.t		See if File::Temp works
diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
index 2f1c56b..37c04e3 100755
--- a/Porting/Maintainers.pl
+++ b/Porting/Maintainers.pl
@@ -652,11 +652,10 @@ use File::Glob qw(:case);
     'File::Path' =>
 	{
 	'MAINTAINER'	=> 'dland',
-	'DISTRIBUTION'	=> 'DLAND/File-Path-2.07_03.tar.gz',
+	'DISTRIBUTION'	=> 'DLAND/File-Path-2.08.tar.gz',
 	'FILES'		=> q[cpan/File-Path],
 	'EXCLUDED'	=> [ qw{eg/setup-extra-tests
 				t/pod.t
-				t/taint.t
 			       }
 			   ],
 	'MAP'		=> { ''		=> 'lib/File/',
diff --git a/cpan/File-Path/lib/File/Path.pm b/cpan/File-Path/lib/File/Path.pm
index e31191f..387cdb1 100644
--- a/cpan/File-Path/lib/File/Path.pm
+++ b/cpan/File-Path/lib/File/Path.pm
@@ -17,7 +17,7 @@ BEGIN {
 
 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 @@ sub mkpath {
         $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 @@ sub _mkpath {
         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 @@ File::Path - Create or remove directory trees
 
 =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 @@ If this parameter is not used, certain error conditions may raise
 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 @@ just good practice anyway.
 
   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 @@ After having failed to remove a file, C<remove_tree> was also unable
 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 @@ Tim Bunce and Charles Bailey. Currently maintained by David Landgren
 =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 --git a/cpan/File-Path/t/Path.t b/cpan/File-Path/t/Path.t
index 319c3d0..346f32a 100644
--- a/cpan/File-Path/t/Path.t
+++ b/cpan/File-Path/t/Path.t
@@ -2,7 +2,7 @@
 
 use strict;
 
-use Test::More tests => 121;
+use Test::More tests => 129;
 use Config;
 
 BEGIN {
@@ -323,7 +323,7 @@ SKIP: {
     # 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 @@ my $extra =  catdir(curdir(), qw(EXTRA 1 a));
 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: {
 }
 
 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 @@ SKIP: {
     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');
 }
diff --git a/cpan/File-Path/t/taint.t b/cpan/File-Path/t/taint.t
new file mode 100644
index 0000000..8198600
--- /dev/null
+++ b/cpan/File-Path/t/taint.t
@@ -0,0 +1,35 @@
+#! perl -T
+
+# Taint tests for module File::Path
+
+use strict;
+
+use Test::More tests => 6;
+
+BEGIN {
+    use_ok('File::Path', qw(rmtree mkpath make_path remove_tree));
+    use_ok('File::Spec::Functions');
+}
+
+# find a place to work
+my $tmp_base = catdir(
+    curdir(),
+    sprintf( 'taint-%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 = make_path(@dir);
+is(scalar(@created), 7, "created list of directories");
+
+my $count = rmtree($tmp_base, {error => \(my $err), result => \my $res});
+is( $count, 7, 'rmtree under taint' );
+is( scalar(@$err), 0, 'no errors' );
+is( scalar(@$res), 7, 'seven items' );