User::pwent fixups for additional fields (from Tom Christiansen);

fix bug in pw_has(); tolerate absense of pw{change,age,quota}
and pw{comment,class} (Debian 2.1 doesn't have either of these)

p4raw-id: //depot/perl@5824

1 files changed, 239 insertions, 46 deletions

diff --git a/lib/User/pwent.pm b/lib/User/pwent.pm
index 39bfea4fe0..31cf74227c 100644
--- a/lib/User/pwent.pm
+++ b/lib/User/pwent.pm
@@ -1,51 +1,179 @@
 package User::pwent;
+
+use 5.006;
+
 use strict;
+use warnings;
+
+use Config;
+use Carp;
 
-use 5.005_64;
 our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-BEGIN { 
+BEGIN {
     use Exporter   ();
     @EXPORT      = qw(getpwent getpwuid getpwnam getpw);
     @EXPORT_OK   = qw(
-			$pw_name   $pw_passwd 	$pw_uid	 
-			$pw_gid	   $pw_quota    $pw_comment
-			$pw_gecos  $pw_dir	$pw_shell
-		   );
-    %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+                        pw_has
+
+                        $pw_name    $pw_passwd  $pw_uid  $pw_gid
+                        $pw_gecos   $pw_dir     $pw_shell
+                        $pw_expire  $pw_change  $pw_class
+                        $pw_age
+                        $pw_quota   $pw_comment
+                        $pw_expire
+
+                   );
+    %EXPORT_TAGS = (
+        FIELDS => [ grep(/^\$pw_/, @EXPORT_OK), @EXPORT ],
+        ALL    => [ @EXPORT, @EXPORT_OK ],
+    );
 }
-use vars      @EXPORT_OK;
+use vars grep /^\$pw_/, @EXPORT_OK;
+
+#
+# XXX: these mean somebody hacked this module's source
+#      without understanding the underlying assumptions.
+#
+my $IE = "[INTERNAL ERROR]";
 
 # Class::Struct forbids use of @ISA
 sub import { goto &Exporter::import }
 
 use Class::Struct qw(struct);
 struct 'User::pwent' => [
-    name    => '$',
-    passwd  => '$',
-    uid	    => '$',
-    gid	    => '$',
-    quota   => '$',
-    comment => '$',
-    gecos   => '$',
-    dir	    => '$',
-    shell   => '$',
+    name    => '$',         # pwent[0]
+    passwd  => '$',         # pwent[1]
+    uid     => '$',         # pwent[2]
+    gid     => '$',         # pwent[3]
+
+    # you'll only have one/none of these three
+    change  => '$',         # pwent[4]
+    age     => '$',         # pwent[4]
+    quota   => '$',         # pwent[4]
+
+    # you'll only have one/none of these two
+    comment => '$',         # pwent[5]
+    class   => '$',         # pwent[5]
+
+    # you might not have this one
+    gecos   => '$',         # pwent[6]
+
+    dir     => '$',         # pwent[7]
+    shell   => '$',         # pwent[8]
+
+    # you might not have this one
+    expire  => '$',         # pwent[9]
+
 ];
 
-sub populate (@) {
+
+# init our groks hash to be true if the built platform knew how
+# to do each struct pwd field that perl can ever under any circumstances
+# know about.  we do not use /^pw_?/, but just the tails.
+sub _feature_init {
+    our %Groks;         # whether build system knew how to do this feature
+    for my $feep ( qw{
+                         pwage      pwchange   pwclass    pwcomment
+                         pwexpire   pwgecos    pwpasswd   pwquota
+                     }
+                 )
+    {
+        my $short = $feep =~ /^pw(.*)/
+                  ? $1
+                  : do {
+                        # not cluck, as we know we called ourselves,
+                        # and a confession is probably imminent anyway
+                        warn("$IE $feep is a funny struct pwd field");
+                        $feep;
+                    };
+
+        exists $Config{ "d_" . $feep }
+            || confess("$IE Configure doesn't d_$feep");
+        $Groks{$short} = defined $Config{ "d_" . $feep };
+    }
+    # assume that any that are left are always there
+    for my $feep (grep /^\$pw_/s, @EXPORT_OK) {
+        $feep =~ /^\$pw_(.*)/;
+        $Groks{$1} = 1 unless defined $Groks{$1};
+    }
+}
+
+# With arguments, reports whether one or more fields are all implemented
+# in the build machine's struct pwd pw_*.  May be whitespace separated.
+# We do not use /^pw_?/, just the tails.
+#
+# Without arguments, returns the list of fields implemented on build
+# machine, space separated in scalar context.
+#
+# Takes exception to being asked whether this machine's struct pwd has
+# a field that Perl never knows how to provide under any circumstances.
+# If the module does this idiocy to itself, the explosion is noisier.
+#
+sub pw_has {
+    our %Groks;         # whether build system knew how to do this feature
+    my $cando = 1;
+    my $sploder = caller() ne __PACKAGE__
+                    ? \&croak
+                    : sub { confess("$IE @_") };
+    if (@_ == 0) {
+        my @valid = sort grep { $Groks{$_} } keys %Groks;
+        return wantarray ? @valid : "@valid";
+    }
+    for my $feep (map { split } @_) {
+        defined $Groks{$feep}
+            || $sploder->("$feep is never a valid struct pwd field");
+        $cando &&= $Groks{$feep};
+    }
+    return $cando;
+}
+
+sub _populate (@) {
     return unless @_;
     my $pwob = new();
 
-    ( $pw_name,   $pw_passwd,   $pw_uid,  
-      $pw_gid,    $pw_quota,    $pw_comment,
-      $pw_gecos,  $pw_dir,      $pw_shell,   ) 	= @$pwob = @_;
+    # Any that haven't been pw_had are assumed on "all" platforms of
+    # course, this may not be so, but you can't get here otherwise,
+    # since the underlying core call already took exception to your
+    # impudence.
+
+    $pw_name    = $pwob->name   ( $_[0] );
+    $pw_passwd  = $pwob->passwd ( $_[1] )   if pw_has("passwd");
+    $pw_uid     = $pwob->uid    ( $_[2] );
+    $pw_gid     = $pwob->gid    ( $_[3] );
+
+    if (pw_has("change")) {
+        $pw_change      = $pwob->change ( $_[4] );
+    }
+    elsif (pw_has("age")) {
+        $pw_age         = $pwob->age    ( $_[4] );
+    }
+    elsif (pw_has("quota")) {
+        $pw_quota       = $pwob->quota  ( $_[4] );
+    }
+
+    if (pw_has("class")) {
+        $pw_class       = $pwob->class  ( $_[5] );
+    }
+    elsif (pw_has("comment")) {
+        $pw_comment     = $pwob->comment( $_[5] );
+    }
+
+    $pw_gecos   = $pwob->gecos  ( $_[6] ) if pw_has("gecos");
+
+    $pw_dir     = $pwob->dir    ( $_[7] );
+    $pw_shell   = $pwob->shell  ( $_[8] );
+
+    $pw_expire  = $pwob->expire ( $_[9] ) if pw_has("expire");
 
     return $pwob;
-} 
+}
 
-sub getpwent ( ) { populate(CORE::getpwent()) } 
-sub getpwnam ($) { populate(CORE::getpwnam(shift)) } 
-sub getpwuid ($) { populate(CORE::getpwuid(shift)) } 
-sub getpw    ($) { ($_[0] =~ /^\d+/) ? &getpwuid : &getpwnam } 
+sub getpwent ( ) { _populate(CORE::getpwent()) }
+sub getpwnam ($) { _populate(CORE::getpwnam(shift)) }
+sub getpwuid ($) { _populate(CORE::getpwuid(shift)) }
+sub getpw    ($) { ($_[0] =~ /^\d+\z/s) ? &getpwuid : &getpwnam }
+
+_feature_init();
 
 1;
 __END__
@@ -57,42 +185,95 @@ User::pwent - by-name interface to Perl's built-in getpw*() functions
 =head1 SYNOPSIS
 
  use User::pwent;
- $pw = getpwnam('daemon') or die "No daemon user";
- if ( $pw->uid == 1 && $pw->dir =~ m#^/(bin|tmp)?$# ) {
+ $pw = getpwnam('daemon')       || die "No daemon user";
+ if ( $pw->uid == 1 && $pw->dir =~ m#^/(bin|tmp)?\z#s ) {
      print "gid 1 on root dir";
- } 
+ }
+
+ $real_shell = $pw->shell || '/bin/sh';
+
+ for (($fullname, $office, $workphone, $homephone) =
+        split /\s*,\s*/, $pw->gecos)
+ {
+    s/&/ucfirst(lc($pw->name))/ge;
+ }
 
  use User::pwent qw(:FIELDS);
- getpwnam('daemon') or die "No daemon user";
- if ( $pw_uid == 1 && $pw_dir =~ m#^/(bin|tmp)?$# ) {
+ getpwnam('daemon')             || die "No daemon user";
+ if ( $pw_uid == 1 && $pw_dir =~ m#^/(bin|tmp)?\z#s ) {
      print "gid 1 on root dir";
- } 
+ }
 
  $pw = getpw($whoever);
 
+ use User::pwent qw/:DEFAULT pw_has/;
+ if (pw_has(qw[gecos expire quota])) { .... }
+ if (pw_has("name uid gid passwd"))  { .... }
+ print "Your struct pwd has: ", pw_has(), "\n";
+
 =head1 DESCRIPTION
 
 This module's default exports override the core getpwent(), getpwuid(),
 and getpwnam() functions, replacing them with versions that return
-"User::pwent" objects.  This object has methods that return the similarly
-named structure field name from the C's passwd structure from F<pwd.h>; 
-namely name, passwd, uid, gid, quota, comment, gecos, dir, and shell.
+C<User::pwent> objects.  This object has methods that return the
+similarly named structure field name from the C's passwd structure
+from F<pwd.h>, stripped of their leading "pw_" parts, namely C<name>,
+C<passwd>, C<uid>, C<gid>, C<change>, C<age>, C<quota>, C<comment>,
+C<class>, C<gecos>, C<dir>, C<shell>, and C<expire>.  The C<passwd>,
+C<gecos>, and C<shell> fields should be considered tainted.
 
-You may also import all the structure fields directly into your namespace
-as regular variables using the :FIELDS import tag.  (Note that this still
-overrides your core functions.)  Access these fields as
-variables named with a preceding C<pw_> in front their method names.
-Thus, C<$passwd_obj-E<gt>shell()> corresponds to $pw_shell if you import
-the fields.
+You may also import all the structure fields directly into your
+namespace as regular variables using the :FIELDS import tag.  (Note
+that this still overrides your core functions.)  Access these fields
+as variables named with a preceding C<pw_> in front their method
+names.  Thus, C<< $passwd_obj->shell >> corresponds to $pw_shell
+if you import the fields.
 
 The getpw() function is a simple front-end that forwards
 a numeric argument to getpwuid() and the rest to getpwnam().
 
-To access this functionality without the core overrides,
-pass the C<use> an empty import list, and then access
-function functions with their full qualified names.
-On the other hand, the built-ins are still available
-via the C<CORE::> pseudo-package.
+To access this functionality without the core overrides, pass the
+C<use> an empty import list, and then access function functions
+with their full qualified names.  The built-ins are always still
+available via the C<CORE::> pseudo-package.
+
+=head2 System Specifics
+
+Perl believes that no machine ever has more than one of C<change>,
+C<age>, or C<quota> implemented, nor more than one of either
+C<comment> or C<class>.  Some machines do not support C<expire>,
+C<gecos>, or allegedly, C<passwd>.  You may call these methods
+no matter what machine you're on, but they return C<undef> if
+unimplemented.
+
+You may ask whether one of these was implemented on the system Perl
+was built on by asking the importable C<pw_has> function about them.
+This function returns true if all parameters are supported fields
+on the build platform, false if one or more were not, and raises
+and exception if you asked about a field that Perl never knows how
+to provide.  Parameters may be in a space-separated string, or as
+separate arguments.  If you pass no parameters, the function returns
+the list of C<struct pwd> fields supported by your build platform's
+C library, as a list in list context, or a space-separated string
+in scalar context.  Note that just because your C library had
+a field doesn't necessarily mean that it's fully implemented on
+that system.
+
+Interpretation of the C<gecos> field varies between systems, but
+traditionally holds 4 comma-separated fields containing the user's
+full name, office location, work phone number, and home phone number.
+An C<&> in the gecos field should be replaced by the user's properly
+capitalized login C<name>.  The C<shell> field, if blank, must be
+assumed to be F</bin/sh>.  Perl does not do this for you.  The
+C<passwd> is one-way hashed garble, not clear text, and may not be
+unhashed save by brute-force guessing.  Secure systems use more a
+more secure hashing than DES.  On systems supporting shadow password
+systems, Perl automatically returns the shadow password entry when
+called by a suitably empowered user, even if your underlying
+vendor-provided C library was too short-sighted to realize it should
+do this.
+
+See passwd(5) and getpwent(3) for details.
 
 =head1 NOTE
 
@@ -102,3 +283,15 @@ module to build a struct-like class, you shouldn't rely upon this.
 =head1 AUTHOR
 
 Tom Christiansen
+
+=head1 HISTORY
+
+=over
+
+=item March 18th, 2000
+
+Reworked internals to support better interface to dodgey fields
+than normal Perl function provides.  Added pw_has() field.  Improved
+documentation.
+
+=back