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
CommitLineData
bfcc9519
SH
1use strict;
2use Test::More;
3use Config;
cc744934
CBW
4use lib './t';
5use FilePathTest qw(
6 _run_for_warning
7);
bfcc9519
SH
8use File::Path qw(rmtree mkpath make_path remove_tree);
9use File::Spec::Functions;
10
11
12my $prereq = prereq();
13plan skip_all => $prereq if defined $prereq;
cc744934 14plan tests => 11;
bfcc9519
SH
15
16my $pwent = max_u();
17my $grent = max_g();
18my ( $max_uid, $max_user ) = @{ $pwent };
19my ( $max_gid, $max_group ) = @{ $grent };
20
21my $tmp_base = catdir(
22 curdir(),
23 sprintf( 'test-%x-%x-%x', time, $$, rand(99999) ),
24);
25
26# invent some names
27my @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
35my @created = mkpath([@dir]);
36
37my $dir;
38my $dir2;
39
40my $dir_stem = $dir = catdir($tmp_base, 'owned-by');
41
42$dir = catdir($dir_stem, 'aaa');
43@created = make_path($dir, {owner => $max_user});
44is(scalar(@created), 2, "created a directory owned by $max_user...");
45
46my $dir_uid = (stat $created[0])[4];
47is($dir_uid, $max_uid, "... owned by $max_uid");
48
49$dir = catdir($dir_stem, 'aab');
50@created = make_path($dir, {group => $max_group});
51is(scalar(@created), 1, "created a directory owned by group $max_group...");
52
53my $dir_gid = (stat $created[0])[5];
54is($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});
59is(scalar(@created), 1, "created a directory owned by $max_user:$max_group...");
60
61($dir_uid, $dir_gid) = (stat $created[0])[4,5];
62is($dir_uid, $max_uid, "... owned by $max_uid");
63is($dir_gid, $max_gid, "... owned by group $max_gid");
64
cc744934 65{
bfcc9519 66 # invent a user and group that don't exist
295a484e
JK
67 my $phony_user = get_phony_user();
68 my $phony_group = get_phony_group();
bfcc9519
SH
69
70 $dir = catdir($dir_stem, 'aad');
cc744934
CBW
71 my $rv = _run_for_warning( sub {
72 make_path(
73 $dir,
295a484e 74 { user => $phony_user, group => $phony_group }
cc744934
CBW
75 )
76 } );
77 like( $rv,
295a484e
JK
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...",
cc744934 80 );
bfcc9519 81 like( $rv,
295a484e
JK
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...",
cc744934
CBW
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");
bfcc9519
SH
94}
95
96sub 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
110sub 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() ) {
bfcc9519
SH
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
124sub 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}
295a484e
JK
139
140sub 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
153sub 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