diff options
Diffstat (limited to 'contrib/perl5/lib/User/pwent.pm')
| -rw-r--r-- | contrib/perl5/lib/User/pwent.pm | 297 |
1 files changed, 0 insertions, 297 deletions
diff --git a/contrib/perl5/lib/User/pwent.pm b/contrib/perl5/lib/User/pwent.pm deleted file mode 100644 index 8c05926..0000000 --- a/contrib/perl5/lib/User/pwent.pm +++ /dev/null @@ -1,297 +0,0 @@ -package User::pwent; - -use 5.006; - -use strict; -use warnings; - -use Config; -use Carp; - -our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); -BEGIN { - use Exporter (); - @EXPORT = qw(getpwent getpwuid getpwnam getpw); - @EXPORT_OK = qw( - 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 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 => '$', # 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] - -]; - - -# 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(); - - # 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+\z/s) ? &getpwuid : &getpwnam } - -_feature_init(); - -1; -__END__ - -=head1 NAME - -User::pwent - by-name interface to Perl's built-in getpw*() functions - -=head1 SYNOPSIS - - use User::pwent; - $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') || 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: ", scalar pw_has(), "\n"; - -=head1 DESCRIPTION - -This module's default exports override the core getpwent(), getpwuid(), -and getpwnam() functions, replacing them with versions that return -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 are tainted when running in taint mode. - -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. 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 -an 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 - -While this class is currently implemented using the Class::Struct -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 |
