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
'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/',
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);
$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);
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 = $!;
=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
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 )
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
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
=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
use strict;
-use Test::More tests => 121;
+use Test::More tests => 129;
use Config;
BEGIN {
# 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});
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' );
}
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;
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');
}
--- /dev/null
+#! 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' );
projects / p5sagit/p5-mst-13.2.git / commitdiff