This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade File::Path from version 2.11 to 2.12
[perl5.git] / cpan / File-Path / t / Path_root.t
1 use strict;
2 use Test::More;
3 use Config;
4 use lib 't/';
5 use FilePathTest;
6 use File::Path qw(rmtree mkpath make_path remove_tree);
7 use File::Spec::Functions;
8
9
10 my $prereq = prereq();
11 plan skip_all  => $prereq if defined $prereq;
12 plan tests     => 8;
13
14 my $pwent = max_u();
15 my $grent = max_g();
16 my ( $max_uid, $max_user ) = @{ $pwent };
17 my ( $max_gid, $max_group ) = @{ $grent };
18
19 my $tmp_base = catdir(
20     curdir(),
21     sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ),
22 );
23
24 # invent some names
25 my @dir = (
26     catdir($tmp_base, qw(a b)),
27     catdir($tmp_base, qw(a c)),
28     catdir($tmp_base, qw(z b)),
29     catdir($tmp_base, qw(z c)),
30 );
31
32 # create them
33 my @created = mkpath([@dir]);
34
35 my $dir;
36 my $dir2;
37
38 my $dir_stem = $dir = catdir($tmp_base, 'owned-by');
39
40 $dir = catdir($dir_stem, 'aaa');
41 @created = make_path($dir, {owner => $max_user});
42 is(scalar(@created), 2, "created a directory owned by $max_user...");
43
44 my $dir_uid = (stat $created[0])[4];
45 is($dir_uid, $max_uid, "... owned by $max_uid");
46
47 $dir = catdir($dir_stem, 'aab');
48 @created = make_path($dir, {group => $max_group});
49 is(scalar(@created), 1, "created a directory owned by group $max_group...");
50
51 my $dir_gid = (stat $created[0])[5];
52 is($dir_gid, $max_gid, "... owned by group $max_gid");
53
54 $dir = catdir($dir_stem, 'aac');
55 @created = make_path( $dir, { user => $max_user,
56                               group => $max_group});
57 is(scalar(@created), 1, "created a directory owned by $max_user:$max_group...");
58
59 ($dir_uid, $dir_gid) = (stat $created[0])[4,5];
60 is($dir_uid, $max_uid, "... owned by $max_uid");
61 is($dir_gid, $max_gid, "... owned by group $max_gid");
62
63 SKIP: {
64   skip('Skip until RT 85878 is fixed', 1);
65   # invent a user and group that don't exist
66   do { ++$max_user  } while ( getpwnam( $max_user ) );
67   do { ++$max_group } while ( getgrnam( $max_group ) );
68
69   $dir = catdir($dir_stem, 'aad');
70   my $rv = _run_for_warning( sub { make_path( $dir,
71                                               { user => $max_user,
72                                                 group => $max_group } ) } );
73   like( $rv,
74         qr{\Aunable to map $max_user to a uid, ownership not changed: .* at \S+ line \d+
75 unable to map $max_group to a gid, group ownership not changed: .* at \S+ line \d+\b},
76         "created a directory not owned by $max_user:$max_group..."
77       );
78 }
79
80 sub max_u {
81   # find the highest uid ('nobody' or similar)
82   my $max_uid   = 0;
83   my $max_user = undef;
84   while (my @u = getpwent()) {
85     if ($max_uid < $u[2]) {
86       $max_uid  = $u[2];
87       $max_user = $u[0];
88     }
89   }
90   setpwent(); # in case we want to run again later
91   return [ $max_uid, $max_user ];
92 }
93
94 sub max_g {
95   # find the highest gid ('nogroup' or similar)
96   my $max_gid   = 0;
97   my $max_group = undef;
98   while ( my @g = getgrent() ) {
99     print Dumper @g;
100     if ($max_gid < $g[2]) {
101       $max_gid = $g[2];
102       $max_group = $g[0];
103     }
104   }
105   setgrent(); # in case we want to run again later
106   return [ $max_gid, $max_group ];
107 }
108
109 sub prereq {
110   return "getpwent() not implemented on $^O" unless $Config{d_getpwent};
111   return "getgrent() not implemented on $^O" unless $Config{d_getgrent};
112   return "not running as root" unless $< == 0;
113   return "darwin's nobody and nogroup are -1 or -2" if $^O eq 'darwin';
114
115   my $pwent = max_u();
116   my $grent = max_g();
117   my ( $max_uid, $max_user ) = @{ $pwent };
118   my ( $max_gid, $max_group ) = @{ $grent };
119
120   return "getpwent() appears to be insane" unless $max_uid > 0;
121   return "getgrent() appears to be insane" unless $max_gid > 0;
122   return undef;
123 }