[Summary view] [Print] [Text view]

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