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