Only 21 tests, skipping or not.
[p5sagit/p5-mst-13.2.git] / lib / User / pwent.pm
CommitLineData
36477c24 1package User::pwent;
c92c3155 2
3use 5.006;
b75c8c73 4our $VERSION = '1.00';
c92c3155 5
36477c24 6use strict;
c92c3155 7use warnings;
8
9use Config;
10use Carp;
36477c24 11
17f410f9 12our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
c92c3155 13BEGIN {
36477c24 14 use Exporter ();
36477c24 15 @EXPORT = qw(getpwent getpwuid getpwnam getpw);
16 @EXPORT_OK = qw(
c92c3155 17 pw_has
18
19 $pw_name $pw_passwd $pw_uid $pw_gid
20 $pw_gecos $pw_dir $pw_shell
21 $pw_expire $pw_change $pw_class
22 $pw_age
23 $pw_quota $pw_comment
24 $pw_expire
25
26 );
27 %EXPORT_TAGS = (
28 FIELDS => [ grep(/^\$pw_/, @EXPORT_OK), @EXPORT ],
29 ALL => [ @EXPORT, @EXPORT_OK ],
30 );
36477c24 31}
c92c3155 32use vars grep /^\$pw_/, @EXPORT_OK;
33
34#
35# XXX: these mean somebody hacked this module's source
36# without understanding the underlying assumptions.
37#
38my $IE = "[INTERNAL ERROR]";
36477c24 39
8cc95fdb 40# Class::Struct forbids use of @ISA
41sub import { goto &Exporter::import }
42
43use Class::Struct qw(struct);
36477c24 44struct 'User::pwent' => [
c92c3155 45 name => '$', # pwent[0]
46 passwd => '$', # pwent[1]
47 uid => '$', # pwent[2]
48 gid => '$', # pwent[3]
49
50 # you'll only have one/none of these three
51 change => '$', # pwent[4]
52 age => '$', # pwent[4]
53 quota => '$', # pwent[4]
54
55 # you'll only have one/none of these two
56 comment => '$', # pwent[5]
57 class => '$', # pwent[5]
58
59 # you might not have this one
60 gecos => '$', # pwent[6]
61
62 dir => '$', # pwent[7]
63 shell => '$', # pwent[8]
64
65 # you might not have this one
66 expire => '$', # pwent[9]
67
36477c24 68];
69
c92c3155 70
71# init our groks hash to be true if the built platform knew how
72# to do each struct pwd field that perl can ever under any circumstances
73# know about. we do not use /^pw_?/, but just the tails.
74sub _feature_init {
75 our %Groks; # whether build system knew how to do this feature
76 for my $feep ( qw{
77 pwage pwchange pwclass pwcomment
78 pwexpire pwgecos pwpasswd pwquota
79 }
80 )
81 {
82 my $short = $feep =~ /^pw(.*)/
83 ? $1
84 : do {
85 # not cluck, as we know we called ourselves,
86 # and a confession is probably imminent anyway
87 warn("$IE $feep is a funny struct pwd field");
88 $feep;
89 };
90
91 exists $Config{ "d_" . $feep }
92 || confess("$IE Configure doesn't d_$feep");
93 $Groks{$short} = defined $Config{ "d_" . $feep };
94 }
95 # assume that any that are left are always there
96 for my $feep (grep /^\$pw_/s, @EXPORT_OK) {
97 $feep =~ /^\$pw_(.*)/;
98 $Groks{$1} = 1 unless defined $Groks{$1};
99 }
100}
101
102# With arguments, reports whether one or more fields are all implemented
103# in the build machine's struct pwd pw_*. May be whitespace separated.
104# We do not use /^pw_?/, just the tails.
105#
106# Without arguments, returns the list of fields implemented on build
107# machine, space separated in scalar context.
108#
109# Takes exception to being asked whether this machine's struct pwd has
110# a field that Perl never knows how to provide under any circumstances.
111# If the module does this idiocy to itself, the explosion is noisier.
112#
113sub pw_has {
114 our %Groks; # whether build system knew how to do this feature
115 my $cando = 1;
116 my $sploder = caller() ne __PACKAGE__
117 ? \&croak
118 : sub { confess("$IE @_") };
119 if (@_ == 0) {
120 my @valid = sort grep { $Groks{$_} } keys %Groks;
121 return wantarray ? @valid : "@valid";
122 }
123 for my $feep (map { split } @_) {
124 defined $Groks{$feep}
125 || $sploder->("$feep is never a valid struct pwd field");
126 $cando &&= $Groks{$feep};
127 }
128 return $cando;
129}
130
131sub _populate (@) {
36477c24 132 return unless @_;
133 my $pwob = new();
134
c92c3155 135 # Any that haven't been pw_had are assumed on "all" platforms of
136 # course, this may not be so, but you can't get here otherwise,
137 # since the underlying core call already took exception to your
138 # impudence.
139
140 $pw_name = $pwob->name ( $_[0] );
141 $pw_passwd = $pwob->passwd ( $_[1] ) if pw_has("passwd");
142 $pw_uid = $pwob->uid ( $_[2] );
143 $pw_gid = $pwob->gid ( $_[3] );
144
145 if (pw_has("change")) {
146 $pw_change = $pwob->change ( $_[4] );
147 }
148 elsif (pw_has("age")) {
149 $pw_age = $pwob->age ( $_[4] );
150 }
151 elsif (pw_has("quota")) {
152 $pw_quota = $pwob->quota ( $_[4] );
153 }
154
155 if (pw_has("class")) {
156 $pw_class = $pwob->class ( $_[5] );
157 }
158 elsif (pw_has("comment")) {
159 $pw_comment = $pwob->comment( $_[5] );
160 }
161
162 $pw_gecos = $pwob->gecos ( $_[6] ) if pw_has("gecos");
163
164 $pw_dir = $pwob->dir ( $_[7] );
165 $pw_shell = $pwob->shell ( $_[8] );
166
167 $pw_expire = $pwob->expire ( $_[9] ) if pw_has("expire");
36477c24 168
169 return $pwob;
c92c3155 170}
36477c24 171
c92c3155 172sub getpwent ( ) { _populate(CORE::getpwent()) }
173sub getpwnam ($) { _populate(CORE::getpwnam(shift)) }
174sub getpwuid ($) { _populate(CORE::getpwuid(shift)) }
175sub getpw ($) { ($_[0] =~ /^\d+\z/s) ? &getpwuid : &getpwnam }
176
177_feature_init();
36477c24 178
1791;
180__END__
181
182=head1 NAME
183
2ae324a7 184User::pwent - by-name interface to Perl's built-in getpw*() functions
36477c24 185
186=head1 SYNOPSIS
187
188 use User::pwent;
c92c3155 189 $pw = getpwnam('daemon') || die "No daemon user";
190 if ( $pw->uid == 1 && $pw->dir =~ m#^/(bin|tmp)?\z#s ) {
36477c24 191 print "gid 1 on root dir";
c92c3155 192 }
193
194 $real_shell = $pw->shell || '/bin/sh';
195
196 for (($fullname, $office, $workphone, $homephone) =
197 split /\s*,\s*/, $pw->gecos)
198 {
199 s/&/ucfirst(lc($pw->name))/ge;
200 }
36477c24 201
202 use User::pwent qw(:FIELDS);
c92c3155 203 getpwnam('daemon') || die "No daemon user";
204 if ( $pw_uid == 1 && $pw_dir =~ m#^/(bin|tmp)?\z#s ) {
36477c24 205 print "gid 1 on root dir";
c92c3155 206 }
36477c24 207
208 $pw = getpw($whoever);
209
c92c3155 210 use User::pwent qw/:DEFAULT pw_has/;
211 if (pw_has(qw[gecos expire quota])) { .... }
212 if (pw_has("name uid gid passwd")) { .... }
2c3c3b7c 213 print "Your struct pwd has: ", scalar pw_has(), "\n";
c92c3155 214
36477c24 215=head1 DESCRIPTION
216
217This module's default exports override the core getpwent(), getpwuid(),
218and getpwnam() functions, replacing them with versions that return
c92c3155 219C<User::pwent> objects. This object has methods that return the
220similarly named structure field name from the C's passwd structure
221from F<pwd.h>, stripped of their leading "pw_" parts, namely C<name>,
222C<passwd>, C<uid>, C<gid>, C<change>, C<age>, C<quota>, C<comment>,
223C<class>, C<gecos>, C<dir>, C<shell>, and C<expire>. The C<passwd>,
2c3c3b7c 224C<gecos>, and C<shell> fields are tainted when running in taint mode.
36477c24 225
c92c3155 226You may also import all the structure fields directly into your
227namespace as regular variables using the :FIELDS import tag. (Note
228that this still overrides your core functions.) Access these fields
229as variables named with a preceding C<pw_> in front their method
230names. Thus, C<< $passwd_obj->shell >> corresponds to $pw_shell
231if you import the fields.
36477c24 232
ae83f377 233The getpw() function is a simple front-end that forwards
36477c24 234a numeric argument to getpwuid() and the rest to getpwnam().
235
c92c3155 236To access this functionality without the core overrides, pass the
237C<use> an empty import list, and then access function functions
238with their full qualified names. The built-ins are always still
239available via the C<CORE::> pseudo-package.
240
241=head2 System Specifics
242
243Perl believes that no machine ever has more than one of C<change>,
244C<age>, or C<quota> implemented, nor more than one of either
245C<comment> or C<class>. Some machines do not support C<expire>,
246C<gecos>, or allegedly, C<passwd>. You may call these methods
247no matter what machine you're on, but they return C<undef> if
248unimplemented.
249
250You may ask whether one of these was implemented on the system Perl
251was built on by asking the importable C<pw_has> function about them.
252This function returns true if all parameters are supported fields
253on the build platform, false if one or more were not, and raises
36392fcf 254an exception if you asked about a field that Perl never knows how
c92c3155 255to provide. Parameters may be in a space-separated string, or as
256separate arguments. If you pass no parameters, the function returns
257the list of C<struct pwd> fields supported by your build platform's
258C library, as a list in list context, or a space-separated string
259in scalar context. Note that just because your C library had
260a field doesn't necessarily mean that it's fully implemented on
261that system.
262
263Interpretation of the C<gecos> field varies between systems, but
264traditionally holds 4 comma-separated fields containing the user's
265full name, office location, work phone number, and home phone number.
266An C<&> in the gecos field should be replaced by the user's properly
267capitalized login C<name>. The C<shell> field, if blank, must be
268assumed to be F</bin/sh>. Perl does not do this for you. The
269C<passwd> is one-way hashed garble, not clear text, and may not be
270unhashed save by brute-force guessing. Secure systems use more a
271more secure hashing than DES. On systems supporting shadow password
272systems, Perl automatically returns the shadow password entry when
273called by a suitably empowered user, even if your underlying
274vendor-provided C library was too short-sighted to realize it should
275do this.
276
277See passwd(5) and getpwent(3) for details.
36477c24 278
279=head1 NOTE
280
8cc95fdb 281While this class is currently implemented using the Class::Struct
36477c24 282module to build a struct-like class, you shouldn't rely upon this.
283
284=head1 AUTHOR
285
286Tom Christiansen
c92c3155 287
288=head1 HISTORY
289
bbc7dcd2 290=over 4
c92c3155 291
292=item March 18th, 2000
293
294Reworked internals to support better interface to dodgey fields
295than normal Perl function provides. Added pw_has() field. Improved
296documentation.
297
298=back