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