This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
t/op/pwent.t: Add descriptions for all tests.
[perl5.git] / t / op / pwent.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib';
6     require './test.pl';
7 }
8
9 use strict;
10 use warnings;
11
12 eval {my @n = getpwuid 0; setpwent()};
13 skip_all($1) if $@ && $@ =~ /(The \w+ function is unimplemented)/;
14
15 eval { require Config; };
16
17 sub try_prog {
18     my ($where, $args, @pathnames) = @_;
19     foreach my $prog (@pathnames) {
20         next unless -x $prog;
21         next unless open PW, '-|', "$prog $args 2>/dev/null";
22         next unless defined <PW>;
23         return $where;
24     }
25     return;
26 }
27
28 # Try NIS.
29 my $where = try_prog('NIS passwd', 'passwd',
30                      qw(/usr/bin/ypcat /bin/ypcat /etc/ypcat));
31
32 # Try NetInfo.
33 $where //= try_prog('NetInfo passwd', 'passwd .', '/usr/bin/nidump');
34
35 # Try NIS+.
36 $where //= try_prog('NIS+', 'passwd.org_dir', '/bin/niscat');
37
38 # Try dscl
39 if (!defined $where && $Config::Config{useperlio}) {
40     # Map dscl items to passwd fields, and provide support for
41     # mucking with the dscl output if we need to (and we do).
42     my %want = do {
43         my $inx = 0;
44         map {$_ => {inx => $inx++, mung => sub {$_[0]}}}
45             qw{RecordName Password UniqueID PrimaryGroupID
46                RealName NFSHomeDirectory UserShell};
47     };
48
49     # The RecordName for a /User record is the username. In some
50     # cases there are synonyms (e.g. _www and www), in which case we
51     # get a blank-delimited list. We prefer the first entry in the
52     # list because getpwnam() does.
53     $want{RecordName}{mung} = sub {(split '\s+', $_[0], 2)[0]};
54
55     # The UniqueID and PrimaryGroupID for a /User record are the
56     # user ID and the primary group ID respectively. In cases where
57     # the high bit is set, 'dscl' returns a negative number, whereas
58     # getpwnam() returns its twos complement. This mungs the dscl
59     # output to agree with what getpwnam() produces. Interestingly
60     # enough, getpwuid(-2) returns the right record ('nobody'), even
61     # though it returns the uid as 4294967294. If you track uid_t
62     # on an i386, you find it is an unsigned int, which makes the
63     # unsigned version the right one; but both /etc/passwd and
64     # /etc/master.passwd contain negative numbers.
65     $want{UniqueID}{mung} = $want{PrimaryGroupID}{mung} = sub {
66         unpack 'L', pack 'l', $_[0]};
67
68     foreach my $dscl (qw(/usr/bin/dscl)) {
69         next unless -x $dscl;
70         next unless open my $fh, '-|', "$dscl . -readall /Users @{[keys %want]} 2>/dev/null";
71         my @lines;
72         my @rec;
73         while (<$fh>) {
74             chomp;
75             if ($_ eq '-') {
76                 if (@rec) {
77                     # Some records do not have all items. In particular,
78                     # the macports user has no real name. Here it's an undef,
79                     # in the password file it becomes an empty string.
80                     no warnings 'uninitialized';
81                     push @lines, join (':', @rec) . "\n";
82                     @rec = ();
83                 }
84                 next;
85             }
86             my ($name, $value) = split ':\s+', $_, 2;
87             unless (defined $value) {
88                 s/:$//;
89                 $name = $_;
90                 $value = <$fh>;
91                 chomp $value;
92                 $value =~ s/^\s+//;
93             }
94             if (defined (my $info = $want{$name})) {
95                 $rec[$info->{inx}] = $info->{mung}->($value);
96             }
97         }
98         if (@rec) {
99         # see above
100         no warnings 'uninitialized';
101             push @lines, join (':', @rec) . "\n";
102         }
103         my $data = join '', @lines;
104         if (open PW, '<', \$data) {
105             $where = "dscl . -readall /Users";
106             last;
107         }
108     }
109 }
110
111 if (not defined $where) {
112     # Try local.
113     my $no_i_pwd = !$Config::Config{i_pwd} && '$Config{i_pwd} undefined';
114
115     my $PW = "/etc/passwd";
116     if (!-f $PW) {
117         skip_all($no_i_pwd) if $no_i_pwd;
118         skip_all("no $PW file");
119     } elsif (open PW, '<', $PW) {
120         if(defined <PW>) {
121             $where = $PW;
122         } else {
123             skip_all($no_i_pwd) if $no_i_pwd;
124             die "\$Config{i_pwd} is defined, $PW exists but has no entries, all other approaches failed, giving up";
125         }
126     } else {
127         die "Can't open $PW: $!";
128     }
129 }
130
131 # By now the PW filehandle should be open and full of juicy password entries.
132
133 plan(tests => 2);
134
135 # Go through at most this many users.
136 # (note that the first entry has been read away by now)
137 my $max = 25;
138
139 my $n = 0;
140 my %perfect;
141 my %seen;
142
143 print "# where $where\n";
144
145 setpwent();
146
147 while (<PW>) {
148     chomp;
149     # LIMIT -1 so that users with empty shells don't fall off
150     my @s = split /:/, $_, -1;
151     my ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s);
152     (my $v) = $Config::Config{osvers} =~ /^(\d+)/;
153     if ($^O eq 'darwin' && $v < 9) {
154        ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s[0,1,2,3,7,8,9];
155     } else {
156        ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s;
157     }
158     next if /^\+/; # ignore NIS includes
159     if (@s) {
160         push @{ $seen{$name_s} }, $.;
161     } else {
162         warn "# Your $where line $. is empty.\n";
163         next;
164     }
165     if ($n == $max) {
166         local $/;
167         my $junk = <PW>;
168         last;
169     }
170     # In principle we could whine if @s != 7 but do we know enough
171     # of passwd file formats everywhere?
172     if (@s == 7 || ($^O eq 'darwin' && @s == 10)) {
173         my @n = getpwuid($uid_s);
174         # 'nobody' et al.
175         next unless @n;
176         my ($name,$passwd,$uid,$gid,$quota,$comment,$gcos,$home,$shell) = @n;
177         # Protect against one-to-many and many-to-one mappings.
178         if ($name_s ne $name) {
179             @n = getpwnam($name_s);
180             ($name,$passwd,$uid,$gid,$quota,$comment,$gcos,$home,$shell) = @n;
181             next if $name_s ne $name;
182         }
183         $perfect{$name_s}++
184             if $name    eq $name_s    and
185                $uid     eq $uid_s     and
186 # Do not compare passwords: think shadow passwords.
187                $gid     eq $gid_s     and
188                $gcos    eq $gcos_s    and
189                $home    eq $home_s    and
190                $shell   eq $shell_s;
191     }
192     $n++;
193 }
194
195 endpwent();
196
197 print "# max = $max, n = $n, perfect = ", scalar keys %perfect, "\n";
198
199 SKIP: {
200     skip("Found no password entries", 1) unless $n;
201
202     if (keys %perfect == 0) {
203         $max++;
204         print <<EOEX;
205 #
206 # The failure of op/pwent test is not necessarily serious.
207 # It may fail due to local password administration conventions.
208 # If you are for example using both NIS and local passwords,
209 # test failure is possible.  Any distributed password scheme
210 # can cause such failures.
211 #
212 # What the pwent test is doing is that it compares the $max first
213 # entries of $where
214 # with the results of getpwuid() and getpwnam() call.  If it finds no
215 # matches at all, it suspects something is wrong.
216
217 EOEX
218     }
219
220     cmp_ok(keys %perfect, '>', 0, "pwent test satisfactory")
221         or note("(not necessarily serious: run t/op/pwent.t by itself)");
222 }
223
224 # Test both the scalar and list contexts.
225
226 my @pw1;
227
228 setpwent();
229 for (1..$max) {
230     my $pw = scalar getpwent();
231     last unless defined $pw;
232     push @pw1, $pw;
233 }
234 endpwent();
235
236 my @pw2;
237
238 setpwent();
239 for (1..$max) {
240     my ($pw) = (getpwent());
241     last unless defined $pw;
242     push @pw2, $pw;
243 }
244 endpwent();
245
246 is("@pw1", "@pw2",
247     "getpwent() produced identical results in list and scalar contexts");
248
249 close(PW);