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