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