r45366 - in /branches/upstream/libfile-path-perl/current: Changes META.yml Path.pm README t/Path.t
angelabad-guest at users.alioth.debian.org
angelabad-guest at users.alioth.debian.org
Sun Oct 4 23:11:32 UTC 2009
Author: angelabad-guest
Date: Sun Oct 4 23:11:26 2009
New Revision: 45366
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=45366
Log:
[svn-upgrade] Integrating new upstream version, libfile-path-perl (2.08)
Modified:
branches/upstream/libfile-path-perl/current/Changes
branches/upstream/libfile-path-perl/current/META.yml
branches/upstream/libfile-path-perl/current/Path.pm
branches/upstream/libfile-path-perl/current/README
branches/upstream/libfile-path-perl/current/t/Path.t
Modified: branches/upstream/libfile-path-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-path-perl/current/Changes?rev=45366&op=diff
==============================================================================
--- branches/upstream/libfile-path-perl/current/Changes (original)
+++ branches/upstream/libfile-path-perl/current/Changes Sun Oct 4 23:11:26 2009
@@ -1,4 +1,15 @@
Revision history for Perl extension File::Path.
+
+2.08 2009-10-04 10:14:36 UTC
+ - make_path() can now set user- and group-ownership
+ on created directories. (Suggested by Jens Rehsack,
+ CPAN #47558).
+
+2.07_03 2009-06-21 13:11:30 UTC
+ - Merged 2.07_02 patches from blead
+ - Remove stat checks on Windows platform (inhibits
+ UNC path removals from working, and Windows is
+ immune to this particular attack). CPAN #34701
2.07 2008-11-09 13:05:50 UTC
- Another VMS test tweak from Craig and additional
Modified: branches/upstream/libfile-path-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-path-perl/current/META.yml?rev=45366&op=diff
==============================================================================
--- branches/upstream/libfile-path-perl/current/META.yml (original)
+++ branches/upstream/libfile-path-perl/current/META.yml Sun Oct 4 23:11:26 2009
@@ -1,17 +1,25 @@
--- #YAML:1.0
-name: File-Path
-version: 2.07
-abstract: Create or remove directory trees
-license: perl
-author:
+name: File-Path
+version: 2.08
+abstract: Create or remove directory trees
+author:
- David Landgren
-generated_by: ExtUtils::MakeMaker version 6.44
-distribution_type: module
-requires:
- Carp: 0
- Cwd: 0
- File::Basename: 0
- File::Spec: 0
+license: perl
+distribution_type: module
+configure_requires:
+ ExtUtils::MakeMaker: 0
+build_requires:
+ ExtUtils::MakeMaker: 0
+requires:
+ Carp: 0
+ Cwd: 0
+ File::Basename: 0
+ File::Spec: 0
+no_index:
+ directory:
+ - t
+ - inc
+generated_by: ExtUtils::MakeMaker version 6.54
meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.3.html
- version: 1.3
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
Modified: branches/upstream/libfile-path-perl/current/Path.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-path-perl/current/Path.pm?rev=45366&op=diff
==============================================================================
--- branches/upstream/libfile-path-perl/current/Path.pm (original)
+++ branches/upstream/libfile-path-perl/current/Path.pm Sun Oct 4 23:11:26 2009
@@ -17,7 +17,7 @@
use Exporter ();
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
-$VERSION = '2.07';
+$VERSION = '2.08';
@ISA = qw(Exporter);
@EXPORT = qw(mkpath rmtree);
@EXPORT_OK = qw(make_path remove_tree);
@@ -28,6 +28,10 @@
# These OSes complain if you want to remove a file that you have no
# write permission to:
my $Force_Writeable = grep {$^O eq $_} qw(amigaos dos epoc MSWin32 MacOS os2);
+
+# Unix-like systems need to stat each directory in order to detect
+# race condition. MS-Windows is immune to this particular attack.
+my $Need_Stat_Check = !($^O eq 'MSWin32');
sub _carp {
require Carp;
@@ -77,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);
@@ -103,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 = $!;
@@ -128,6 +166,24 @@
goto &rmtree;
}
+sub _is_subdir {
+ my($dir, $test) = @_;
+
+ my($dv, $dd) = File::Spec->splitpath($dir, 1);
+ my($tv, $td) = File::Spec->splitpath($test, 1);
+
+ # not on same volume
+ return 0 if $dv ne $tv;
+
+ my @d = File::Spec->splitdir($dd);
+ my @t = File::Spec->splitdir($td);
+
+ # @t can't be a subdir if it's shorter than @d
+ return 0 if @t < @d;
+
+ return join('/', @d) eq join('/', splice @t, 0, + at d);
+}
+
sub rmtree {
my $old_style = !(@_ and UNIVERSAL::isa($_[-1],'HASH'));
@@ -171,9 +227,7 @@
my $ortho_cwd = $^O eq 'MSWin32' ? _slash_lc($arg->{cwd}) : $arg->{cwd};
my $ortho_root_length = length($ortho_root);
$ortho_root_length-- if $^O eq 'VMS'; # don't compare '.' with ']'
- if ($ortho_root_length
- && (substr($ortho_root, 0, $ortho_root_length)
- eq substr($ortho_cwd, 0, $ortho_root_length))) {
+ if ($ortho_root_length && _is_subdir($ortho_root, $ortho_cwd)) {
local $! = 0;
_error($arg, "cannot remove path when cwd is $arg->{cwd}", $p);
next;
@@ -226,6 +280,7 @@
if ( -d _ ) {
$root = VMS::Filespec::pathify($root) if $Is_VMS;
+
if (!chdir($root)) {
# see if we can escalate privileges to get in
# (e.g. funny protection mask such as -w- instead of rwx)
@@ -246,8 +301,10 @@
next ROOT_DIR;
};
- ($ldev eq $cur_dev and $lino eq $cur_inode)
- or _croak("directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting.");
+ if ($Need_Stat_Check) {
+ ($ldev eq $cur_dev and $lino eq $cur_inode)
+ or _croak("directory $canon changed before chdir, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting.");
+ }
$perm &= 07777; # don't forget setuid, setgid, sticky bits
my $nperm = $perm | 0700;
@@ -288,6 +345,7 @@
@files = map {$_ eq '.' ? '.;' : $_} reverse @files;
($root = VMS::Filespec::unixify($root)) =~ s/\.dir\z//;
}
+
@files = grep {$_ ne $updir and $_ ne $curdir} @files;
if (@files) {
@@ -314,8 +372,10 @@
($cur_dev, $cur_inode) = (stat $curdir)[0,1]
or _croak("cannot stat prior working directory $arg->{cwd}: $!, aborting.");
- ($arg->{device} eq $cur_dev and $arg->{inode} eq $cur_inode)
- or _croak("previous directory $arg->{cwd} changed before entering $canon, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting.");
+ if ($Need_Stat_Check) {
+ ($arg->{device} eq $cur_dev and $arg->{inode} eq $cur_inode)
+ or _croak("previous directory $arg->{cwd} changed before entering $canon, expected dev=$ldev ino=$lino, actual dev=$cur_dev ino=$cur_inode, aborting.");
+ }
if ($arg->{depth} or !$arg->{keep_root}) {
if ($arg->{safe} &&
@@ -333,7 +393,7 @@
}
else {
_error($arg, "cannot remove directory", $canon);
- if (!chmod($perm, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
+ if ($Force_Writeable && !chmod($perm, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
) {
_error($arg, sprintf("cannot restore permissions to 0%o",$perm), $canon);
}
@@ -396,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
@@ -478,6 +538,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
@@ -646,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
@@ -809,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
@@ -859,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
Modified: branches/upstream/libfile-path-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-path-perl/current/README?rev=45366&op=diff
==============================================================================
--- branches/upstream/libfile-path-perl/current/README (original)
+++ branches/upstream/libfile-path-perl/current/README Sun Oct 4 23:11:26 2009
@@ -1,4 +1,4 @@
-This file is the README for File::Path version 2.07
+This file is the README for File::Path version 2.08
INSTALLATION
Modified: branches/upstream/libfile-path-perl/current/t/Path.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libfile-path-perl/current/t/Path.t?rev=45366&op=diff
==============================================================================
--- branches/upstream/libfile-path-perl/current/t/Path.t (original)
+++ branches/upstream/libfile-path-perl/current/t/Path.t Sun Oct 4 23:11:26 2009
@@ -2,7 +2,7 @@
use strict;
-use Test::More tests => 114;
+use Test::More tests => 129;
use Config;
BEGIN {
@@ -205,7 +205,8 @@
is($count, 1, "removed directory unsafe mode");
$count = rmtree($dir2, 0, 1);
-is($count, 1, "removed directory safe mode");
+my $removed = $Is_VMS ? 0 : 1;
+is($count, $removed, "removed directory safe mode");
# mkdir foo ./E/../Y
# Y should exist
@@ -302,10 +303,27 @@
}
SKIP: {
+ skip "This is not a MSWin32 platform", 1
+ unless $^O eq 'MSWin32';
+
+ my $UNC_path_taint = $ENV{PERL_FILE_PATH_UNC_TESTDIR};
+ skip "PERL_FILE_PATH_UNC_TESTDIR environment variable not set", 1
+ unless defined($UNC_path_taint);
+
+ my ($UNC_path) = ($UNC_path_taint =~ m{^([/\\]{2}\w+[/\\]\w+[/\\]\w+)$});
+
+ skip "PERL_FILE_PATH_UNC_TESTDIR environment variable does not point to a directory", 1
+ unless -d $UNC_path;
+
+ my $removed = rmtree($UNC_path);
+ cmp_ok($removed, '>', 0, "removed $removed entries from $UNC_path");
+}
+
+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});
@@ -363,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' );
@@ -413,6 +431,78 @@
local @ARGV = ($dir);
rmtree( [grep -e $_, @ARGV], 0, 0 );
ok(!-e $dir, "blow it away via \@ARGV");
+}
+
+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: {
@@ -452,8 +542,7 @@
cannot unlink file for [^:]+: .* at \1 line \2
cannot restore permissions to \d+ for [^:]+: .* at \1 line \2
cannot make child directory read-write-exec for [^:]+: .* at \1 line \2
-cannot remove directory for [^:]+: .* at \1 line \2
-cannot restore permissions to \d+ for [^:]+: .* at \1 line \2},
+cannot remove directory for [^:]+: .* at \1 line \2},
'rmtree with insufficient privileges'
);
}
@@ -528,7 +617,7 @@
unless -d catdir(qw(EXTRA 1));
rmtree 'EXTRA', {safe => 0, error => \$error};
- is( scalar(@$error), 11, 'seven deadly sins' ); # well there used to be 7
+ is( scalar(@$error), 10, 'seven deadly sins' ); # well there used to be 7
rmtree 'EXTRA', {safe => 1, error => \$error};
is( scalar(@$error), 9, 'safe is better' );
@@ -545,6 +634,27 @@
}
}
-rmtree($tmp_base, {result => \$list} );
-is(ref($list), 'ARRAY', "received a final list of results");
-ok( !(-d $tmp_base), "test base directory gone" );
+SKIP: {
+ my $nr_tests = 6;
+ my $cwd = getcwd() or skip "failed to getcwd: $!", $nr_tests;
+ rmtree($tmp_base, {result => \$list} );
+ is(ref($list), 'ARRAY', "received a final list of results");
+ ok( !(-d $tmp_base), "test base directory gone" );
+
+ my $p = getcwd();
+ my $x = "x$$";
+ my $xx = $x . "x";
+
+ # setup
+ ok(mkpath($xx), "make $xx");
+ ok(chdir($xx), "... and chdir $xx");
+ END {
+ 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), 'create and delete directory 2.07');
+ ok(rmtree($px), '.. rmtree fails in File-Path-2.07');
+}
More information about the Pkg-perl-cvs-commits
mailing list