This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
8af39f791b8113be74ec85afd42d8834bd8c8e55
[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 qw(
6     _run_for_warning
7 );
8 use File::Path qw(rmtree mkpath make_path remove_tree);
9 use File::Spec::Functions;
10
11
12 my $prereq = prereq();
13 plan skip_all  => $prereq if defined $prereq;
14 plan tests     => 11;
15
16 my $pwent = max_u();
17 my $grent = max_g();
18 my ( $max_uid, $max_user ) = @{ $pwent };
19 my ( $max_gid, $max_group ) = @{ $grent };
20
21 my $tmp_base = catdir(
22     curdir(),
23     sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ),
24 );
25
26 # invent some names
27 my @dir = (
28     catdir($tmp_base, qw(a b)),
29     catdir($tmp_base, qw(a c)),
30     catdir($tmp_base, qw(z b)),
31     catdir($tmp_base, qw(z c)),
32 );
33
34 # create them
35 my @created = mkpath([@dir]);
36
37 my $dir;
38 my $dir2;
39
40 my $dir_stem = $dir = catdir($tmp_base, 'owned-by');
41
42 $dir = catdir($dir_stem, 'aaa');
43 @created = make_path($dir, {owner => $max_user});
44 is(scalar(@created), 2, "created a directory owned by $max_user...");
45
46 my $dir_uid = (stat $created[0])[4];
47 is($dir_uid, $max_uid, "... owned by $max_uid");
48
49 $dir = catdir($dir_stem, 'aab');
50 @created = make_path($dir, {group => $max_group});
51 is(scalar(@created), 1, "created a directory owned by group $max_group...");
52
53 my $dir_gid = (stat $created[0])[5];
54 is($dir_gid, $max_gid, "... owned by group $max_gid");
55
56 $dir = catdir($dir_stem, 'aac');
57 @created = make_path( $dir, { user => $max_user,
58                               group => $max_group});
59 is(scalar(@created), 1, "created a directory owned by $max_user:$max_group...");
60
61 ($dir_uid, $dir_gid) = (stat $created[0])[4,5];
62 is($dir_uid, $max_uid, "... owned by $max_uid");
63 is($dir_gid, $max_gid, "... owned by group $max_gid");
64
65 {
66   # invent a user and group that don't exist
67   my $phony_user = get_phony_user();
68   my $phony_group = get_phony_group();
69
70   $dir = catdir($dir_stem, 'aad');
71   my $rv = _run_for_warning( sub {
72       make_path(
73           $dir,
74           { user => $phony_user, group => $phony_group }
75       )
76   } );
77   like( $rv,
78     qr{unable to map $phony_user to a uid, ownership not changed:}s,
79     "created a directory not owned by $phony_user:$phony_group...",
80   );
81   like( $rv,
82     qr{unable to map $phony_group to a gid, group ownership not changed:}s,
83     "created a directory not owned by $phony_user:$phony_group...",
84   );
85 }
86
87 {
88     # cleanup
89     my $x;
90     my $opts = { error => \$x };
91     remove_tree($tmp_base, $opts);
92     ok(! -d $tmp_base, "directory '$tmp_base' removed, as expected");
93     is(scalar(@{$x}), 0, "no error messages using remove_tree() with \$opts");
94 }
95
96 sub max_u {
97   # find the highest uid ('nobody' or similar)
98   my $max_uid   = 0;
99   my $max_user = undef;
100   while (my @u = getpwent()) {
101     if ($max_uid < $u[2]) {
102       $max_uid  = $u[2];
103       $max_user = $u[0];
104     }
105   }
106   setpwent(); # in case we want to run again later
107   return [ $max_uid, $max_user ];
108 }
109
110 sub max_g {
111   # find the highest gid ('nogroup' or similar)
112   my $max_gid   = 0;
113   my $max_group = undef;
114   while ( my @g = getgrent() ) {
115     print Dumper @g;
116     if ($max_gid < $g[2]) {
117       $max_gid = $g[2];
118       $max_group = $g[0];
119     }
120   }
121   setgrent(); # in case we want to run again later
122   return [ $max_gid, $max_group ];
123 }
124
125 sub prereq {
126   return "getpwent() not implemented on $^O" unless $Config{d_getpwent};
127   return "getgrent() not implemented on $^O" unless $Config{d_getgrent};
128   return "not running as root" unless $< == 0;
129   return "darwin's nobody and nogroup are -1 or -2" if $^O eq 'darwin';
130
131   my $pwent = max_u();
132   my $grent = max_g();
133   my ( $max_uid, $max_user ) = @{ $pwent };
134   my ( $max_gid, $max_group ) = @{ $grent };
135
136   return "getpwent() appears to be insane" unless $max_uid > 0;
137   return "getgrent() appears to be insane" unless $max_gid > 0;
138   return undef;
139 }
140
141 sub get_phony_user {
142     return "getpwent() not implemented on $^O" unless $Config{d_getpwent};
143     return "not running as root" unless $< == 0;
144     my %real_users = ();
145     while(my @a=getpwent()) {
146         $real_users{$a[0]}++;
147     }
148     my $phony_stem = 'phonyuser';
149     my $phony = '';
150     do { $phony = $phony_stem . int(rand(10000)); } until (! $real_users{$phony});
151     return $phony;
152 }
153
154 sub get_phony_group {
155     return "getgrent() not implemented on $^O" unless $Config{d_getgrent};
156     return "not running as root" unless $< == 0;
157     my %real_groups = ();
158     while(my @a=getgrent()) {
159         $real_groups{$a[0]}++;
160     }
161     my $phony_stem = 'phonygroup';
162     my $phony = '';
163     do { $phony = $phony_stem . int(rand(10000)); } until (! $real_groups{$phony});
164     return $phony;
165 }
166