1 | package User::pwent;
|
---|
2 |
|
---|
3 | use 5.006;
|
---|
4 | our $VERSION = '1.00';
|
---|
5 |
|
---|
6 | use strict;
|
---|
7 | use warnings;
|
---|
8 |
|
---|
9 | use Config;
|
---|
10 | use Carp;
|
---|
11 |
|
---|
12 | our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
|
---|
13 | BEGIN {
|
---|
14 | use Exporter ();
|
---|
15 | @EXPORT = qw(getpwent getpwuid getpwnam getpw);
|
---|
16 | @EXPORT_OK = qw(
|
---|
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 | );
|
---|
31 | }
|
---|
32 | use vars grep /^\$pw_/, @EXPORT_OK;
|
---|
33 |
|
---|
34 | #
|
---|
35 | # XXX: these mean somebody hacked this module's source
|
---|
36 | # without understanding the underlying assumptions.
|
---|
37 | #
|
---|
38 | my $IE = "[INTERNAL ERROR]";
|
---|
39 |
|
---|
40 | # Class::Struct forbids use of @ISA
|
---|
41 | sub import { goto &Exporter::import }
|
---|
42 |
|
---|
43 | use Class::Struct qw(struct);
|
---|
44 | struct 'User::pwent' => [
|
---|
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 |
|
---|
68 | ];
|
---|
69 |
|
---|
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.
|
---|
74 | sub _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 | #
|
---|
113 | sub 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 |
|
---|
131 | sub _populate (@) {
|
---|
132 | return unless @_;
|
---|
133 | my $pwob = new();
|
---|
134 |
|
---|
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");
|
---|
168 |
|
---|
169 | return $pwob;
|
---|
170 | }
|
---|
171 |
|
---|
172 | sub getpwent ( ) { _populate(CORE::getpwent()) }
|
---|
173 | sub getpwnam ($) { _populate(CORE::getpwnam(shift)) }
|
---|
174 | sub getpwuid ($) { _populate(CORE::getpwuid(shift)) }
|
---|
175 | sub getpw ($) { ($_[0] =~ /^\d+\z/s) ? &getpwuid : &getpwnam }
|
---|
176 |
|
---|
177 | _feature_init();
|
---|
178 |
|
---|
179 | 1;
|
---|
180 | __END__
|
---|
181 |
|
---|
182 | =head1 NAME
|
---|
183 |
|
---|
184 | User::pwent - by-name interface to Perl's built-in getpw*() functions
|
---|
185 |
|
---|
186 | =head1 SYNOPSIS
|
---|
187 |
|
---|
188 | use User::pwent;
|
---|
189 | $pw = getpwnam('daemon') || die "No daemon user";
|
---|
190 | if ( $pw->uid == 1 && $pw->dir =~ m#^/(bin|tmp)?\z#s ) {
|
---|
191 | print "gid 1 on root dir";
|
---|
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 | }
|
---|
201 |
|
---|
202 | use User::pwent qw(:FIELDS);
|
---|
203 | getpwnam('daemon') || die "No daemon user";
|
---|
204 | if ( $pw_uid == 1 && $pw_dir =~ m#^/(bin|tmp)?\z#s ) {
|
---|
205 | print "gid 1 on root dir";
|
---|
206 | }
|
---|
207 |
|
---|
208 | $pw = getpw($whoever);
|
---|
209 |
|
---|
210 | use User::pwent qw/:DEFAULT pw_has/;
|
---|
211 | if (pw_has(qw[gecos expire quota])) { .... }
|
---|
212 | if (pw_has("name uid gid passwd")) { .... }
|
---|
213 | print "Your struct pwd has: ", scalar pw_has(), "\n";
|
---|
214 |
|
---|
215 | =head1 DESCRIPTION
|
---|
216 |
|
---|
217 | This module's default exports override the core getpwent(), getpwuid(),
|
---|
218 | and getpwnam() functions, replacing them with versions that return
|
---|
219 | C<User::pwent> objects. This object has methods that return the
|
---|
220 | similarly named structure field name from the C's passwd structure
|
---|
221 | from F<pwd.h>, stripped of their leading "pw_" parts, namely C<name>,
|
---|
222 | C<passwd>, C<uid>, C<gid>, C<change>, C<age>, C<quota>, C<comment>,
|
---|
223 | C<class>, C<gecos>, C<dir>, C<shell>, and C<expire>. The C<passwd>,
|
---|
224 | C<gecos>, and C<shell> fields are tainted when running in taint mode.
|
---|
225 |
|
---|
226 | You may also import all the structure fields directly into your
|
---|
227 | namespace as regular variables using the :FIELDS import tag. (Note
|
---|
228 | that this still overrides your core functions.) Access these fields
|
---|
229 | as variables named with a preceding C<pw_> in front their method
|
---|
230 | names. Thus, C<< $passwd_obj->shell >> corresponds to $pw_shell
|
---|
231 | if you import the fields.
|
---|
232 |
|
---|
233 | The getpw() function is a simple front-end that forwards
|
---|
234 | a numeric argument to getpwuid() and the rest to getpwnam().
|
---|
235 |
|
---|
236 | To access this functionality without the core overrides, pass the
|
---|
237 | C<use> an empty import list, and then access function functions
|
---|
238 | with their full qualified names. The built-ins are always still
|
---|
239 | available via the C<CORE::> pseudo-package.
|
---|
240 |
|
---|
241 | =head2 System Specifics
|
---|
242 |
|
---|
243 | Perl believes that no machine ever has more than one of C<change>,
|
---|
244 | C<age>, or C<quota> implemented, nor more than one of either
|
---|
245 | C<comment> or C<class>. Some machines do not support C<expire>,
|
---|
246 | C<gecos>, or allegedly, C<passwd>. You may call these methods
|
---|
247 | no matter what machine you're on, but they return C<undef> if
|
---|
248 | unimplemented.
|
---|
249 |
|
---|
250 | You may ask whether one of these was implemented on the system Perl
|
---|
251 | was built on by asking the importable C<pw_has> function about them.
|
---|
252 | This function returns true if all parameters are supported fields
|
---|
253 | on the build platform, false if one or more were not, and raises
|
---|
254 | an exception if you asked about a field that Perl never knows how
|
---|
255 | to provide. Parameters may be in a space-separated string, or as
|
---|
256 | separate arguments. If you pass no parameters, the function returns
|
---|
257 | the list of C<struct pwd> fields supported by your build platform's
|
---|
258 | C library, as a list in list context, or a space-separated string
|
---|
259 | in scalar context. Note that just because your C library had
|
---|
260 | a field doesn't necessarily mean that it's fully implemented on
|
---|
261 | that system.
|
---|
262 |
|
---|
263 | Interpretation of the C<gecos> field varies between systems, but
|
---|
264 | traditionally holds 4 comma-separated fields containing the user's
|
---|
265 | full name, office location, work phone number, and home phone number.
|
---|
266 | An C<&> in the gecos field should be replaced by the user's properly
|
---|
267 | capitalized login C<name>. The C<shell> field, if blank, must be
|
---|
268 | assumed to be F</bin/sh>. Perl does not do this for you. The
|
---|
269 | C<passwd> is one-way hashed garble, not clear text, and may not be
|
---|
270 | unhashed save by brute-force guessing. Secure systems use more a
|
---|
271 | more secure hashing than DES. On systems supporting shadow password
|
---|
272 | systems, Perl automatically returns the shadow password entry when
|
---|
273 | called by a suitably empowered user, even if your underlying
|
---|
274 | vendor-provided C library was too short-sighted to realize it should
|
---|
275 | do this.
|
---|
276 |
|
---|
277 | See passwd(5) and getpwent(3) for details.
|
---|
278 |
|
---|
279 | =head1 NOTE
|
---|
280 |
|
---|
281 | While this class is currently implemented using the Class::Struct
|
---|
282 | module to build a struct-like class, you shouldn't rely upon this.
|
---|
283 |
|
---|
284 | =head1 AUTHOR
|
---|
285 |
|
---|
286 | Tom Christiansen
|
---|
287 |
|
---|
288 | =head1 HISTORY
|
---|
289 |
|
---|
290 | =over 4
|
---|
291 |
|
---|
292 | =item March 18th, 2000
|
---|
293 |
|
---|
294 | Reworked internals to support better interface to dodgey fields
|
---|
295 | than normal Perl function provides. Added pw_has() field. Improved
|
---|
296 | documentation.
|
---|
297 |
|
---|
298 | =back
|
---|