This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
File-Path: sync in CPAN version 2.17
[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     if ($max_gid < $g[2]) {
116       $max_gid = $g[2];
117       $max_group = $g[0];
118     }
119   }
120   setgrent(); # in case we want to run again later
121   return [ $max_gid, $max_group ];
122 }
123
124 sub prereq {
125   return "getpwent() not implemented on $^O" unless $Config{d_getpwent};
126   return "getgrent() not implemented on $^O" unless $Config{d_getgrent};
127   return "not running as root" unless $< == 0;
128   return "darwin's nobody and nogroup are -1 or -2" if $^O eq 'darwin';
129
130   my $pwent = max_u();
131   my $grent = max_g();
132   my ( $max_uid, $max_user ) = @{ $pwent };
133   my ( $max_gid, $max_group ) = @{ $grent };
134
135   return "getpwent() appears to be insane" unless $max_uid > 0;
136   return "getgrent() appears to be insane" unless $max_gid > 0;
137   return undef;
138 }
139
140 sub get_phony_user {
141     return "getpwent() not implemented on $^O" unless $Config{d_getpwent};
142     return "not running as root" unless $< == 0;
143     my %real_users = ();
144     while(my @a=getpwent()) {
145         $real_users{$a[0]}++;
146     }
147     my $phony_stem = 'phonyuser';
148     my $phony = '';
149     do { $phony = $phony_stem . int(rand(10000)); } until (! $real_users{$phony});
150     return $phony;
151 }
152
153 sub get_phony_group {
154     return "getgrent() not implemented on $^O" unless $Config{d_getgrent};
155     return "not running as root" unless $< == 0;
156     my %real_groups = ();
157     while(my @a=getgrent()) {
158         $real_groups{$a[0]}++;
159     }
160     my $phony_stem = 'phonygroup';
161     my $phony = '';
162     do { $phony = $phony_stem . int(rand(10000)); } until (! $real_groups{$phony});
163     return $phony;
164 }
165