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