This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Convert t/op/pwent.t to test.pl, strict and warnings.
[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                     push @lines, join (':', @rec) . "\n";
78                     @rec = ();
79                 }
80                 next;
81             }
82             my ($name, $value) = split ':\s+', $_, 2;
83             unless (defined $value) {
84                 s/:$//;
85                 $name = $_;
86                 $value = <$fh>;
87                 chomp $value;
88                 $value =~ s/^\s+//;
89             }
90             if (defined (my $info = $want{$name})) {
91                 $rec[$info->{inx}] = $info->{mung}->($value);
92             }
93         }
94         if (@rec) {
95             push @lines, join (':', @rec) . "\n";
96         }
97         my $data = join '', @lines;
98         if (open PW, '<', \$data) {
99             $where = "dscl . -readall /Users";
100             last;
101         }
102     }
103 }
104
105 if (not defined $where) {
106     # Try local.
107     my $no_i_pwd = !$Config::Config{i_pwd} && '$Config{i_pwd} undefined';
108
109     my $PW = "/etc/passwd";
110     if (!-f $PW) {
111         skip_all($no_i_pwd) if $no_i_pwd;
112         skip_all("no $PW file");
113     } elsif (open PW, '<', $PW) {
114         if(defined <PW>) {
115             $where = $PW;
116         } else {
117             skip_all($no_i_pwd) if $no_i_pwd;
118             die "\$Config{i_pwd} is defined, $PW exists but has no entries, all other approaches failed, giving up";
119         }
120     } else {
121         die "Can't open $PW: $!";
122     }
123 }
124
125 # By now the PW filehandle should be open and full of juicy password entries.
126
127 plan(tests => 2);
128
129 # Go through at most this many users.
130 # (note that the first entry has been read away by now)
131 my $max = 25;
132
133 my $n = 0;
134 my %perfect;
135 my %seen;
136
137 print "# where $where\n";
138
139 setpwent();
140
141 while (<PW>) {
142     chomp;
143     # LIMIT -1 so that users with empty shells don't fall off
144     my @s = split /:/, $_, -1;
145     my ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s);
146     (my $v) = $Config::Config{osvers} =~ /^(\d+)/;
147     if ($^O eq 'darwin' && $v < 9) {
148        ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s[0,1,2,3,7,8,9];
149     } else {
150        ($name_s, $passwd_s, $uid_s, $gid_s, $gcos_s, $home_s, $shell_s) = @s;
151     }
152     next if /^\+/; # ignore NIS includes
153     if (@s) {
154         push @{ $seen{$name_s} }, $.;
155     } else {
156         warn "# Your $where line $. is empty.\n";
157         next;
158     }
159     if ($n == $max) {
160         local $/;
161         my $junk = <PW>;
162         last;
163     }
164     # In principle we could whine if @s != 7 but do we know enough
165     # of passwd file formats everywhere?
166     if (@s == 7 || ($^O eq 'darwin' && @s == 10)) {
167         my @n = getpwuid($uid_s);
168         # 'nobody' et al.
169         next unless @n;
170         my ($name,$passwd,$uid,$gid,$quota,$comment,$gcos,$home,$shell) = @n;
171         # Protect against one-to-many and many-to-one mappings.
172         if ($name_s ne $name) {
173             @n = getpwnam($name_s);
174             ($name,$passwd,$uid,$gid,$quota,$comment,$gcos,$home,$shell) = @n;
175             next if $name_s ne $name;
176         }
177         $perfect{$name_s}++
178             if $name    eq $name_s    and
179                $uid     eq $uid_s     and
180 # Do not compare passwords: think shadow passwords.
181                $gid     eq $gid_s     and
182                $gcos    eq $gcos_s    and
183                $home    eq $home_s    and
184                $shell   eq $shell_s;
185     }
186     $n++;
187 }
188
189 endpwent();
190
191 print "# max = $max, n = $n, perfect = ", scalar keys %perfect, "\n";
192
193 SKIP: {
194     skip("Found no password entries", 1) unless $n;
195
196     if (keys %perfect == 0) {
197         $max++;
198         print <<EOEX;
199 #
200 # The failure of op/pwent test is not necessarily serious.
201 # It may fail due to local password administration conventions.
202 # If you are for example using both NIS and local passwords,
203 # test failure is possible.  Any distributed password scheme
204 # can cause such failures.
205 #
206 # What the pwent test is doing is that it compares the $max first
207 # entries of $where
208 # with the results of getpwuid() and getpwnam() call.  If it finds no
209 # matches at all, it suspects something is wrong.
210
211 EOEX
212     }
213
214     cmp_ok(keys %perfect, '>', 0)
215         or note("(not necessarily serious: run t/op/pwent.t by itself)");
216 }
217
218 # Test both the scalar and list contexts.
219
220 my @pw1;
221
222 setpwent();
223 for (1..$max) {
224     my $pw = scalar getpwent();
225     last unless defined $pw;
226     push @pw1, $pw;
227 }
228 endpwent();
229
230 my @pw2;
231
232 setpwent();
233 for (1..$max) {
234     my ($pw) = (getpwent());
235     last unless defined $pw;
236     push @pw2, $pw;
237 }
238 endpwent();
239
240 is("@pw1", "@pw2");
241
242 close(PW);