1package User::pwent; 2 3use 5.006; 4our $VERSION = '1.00'; 5 6use strict; 7use warnings; 8 9use Config; 10use Carp; 11 12our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); 13BEGIN { 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} 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]"; 39 40# Class::Struct forbids use of @ISA 41sub import { goto &Exporter::import } 42 43use Class::Struct qw(struct); 44struct '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. 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 (@) { 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 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(); 178 1791; 180__END__ 181 182=head1 NAME 183 184User::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 217This module's default exports override the core getpwent(), getpwuid(), 218and getpwnam() functions, replacing them with versions that return 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>, 224C<gecos>, and C<shell> fields are tainted when running in taint mode. 225 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. 232 233The getpw() function is a simple front-end that forwards 234a numeric argument to getpwuid() and the rest to getpwnam(). 235 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 254an exception if you asked about a field that Perl never knows how 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. 278 279=head1 NOTE 280 281While this class is currently implemented using the Class::Struct 282module to build a struct-like class, you shouldn't rely upon this. 283 284=head1 AUTHOR 285 286Tom Christiansen 287 288=head1 HISTORY 289 290=over 4 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 299