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