Initial Commit
This commit is contained in:
Riley Schneider
95
database/perl/lib/User/grent.pm
Normal file
95
database/perl/lib/User/grent.pm
Normal file
@@ -0,0 +1,95 @@
|
||||
package User::grent;
|
||||
use strict;
|
||||
|
||||
use 5.006_001;
|
||||
our $VERSION = '1.03';
|
||||
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
|
||||
our ($gr_name, $gr_gid, $gr_passwd, @gr_members);
|
||||
BEGIN {
|
||||
use Exporter ();
|
||||
@EXPORT = qw(getgrent getgrgid getgrnam getgr);
|
||||
@EXPORT_OK = qw($gr_name $gr_gid $gr_passwd @gr_members);
|
||||
%EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
|
||||
}
|
||||
|
||||
# Class::Struct forbids use of @ISA
|
||||
sub import { goto &Exporter::import }
|
||||
|
||||
use Class::Struct qw(struct);
|
||||
struct 'User::grent' => [
|
||||
name => '$',
|
||||
passwd => '$',
|
||||
gid => '$',
|
||||
members => '@',
|
||||
];
|
||||
|
||||
sub populate (@) {
|
||||
return unless @_;
|
||||
my $gob = new();
|
||||
($gr_name, $gr_passwd, $gr_gid) = @$gob[0,1,2] = @_[0,1,2];
|
||||
@gr_members = @{$gob->[3]} = split ' ', $_[3];
|
||||
return $gob;
|
||||
}
|
||||
|
||||
sub getgrent ( ) { populate(CORE::getgrent()) }
|
||||
sub getgrnam ($) { populate(CORE::getgrnam(shift)) }
|
||||
sub getgrgid ($) { populate(CORE::getgrgid(shift)) }
|
||||
sub getgr ($) { ($_[0] =~ /^\d+/) ? &getgrgid : &getgrnam }
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
User::grent - by-name interface to Perl's built-in getgr*() functions
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use User::grent;
|
||||
$gr = getgrgid(0) or die "No group zero";
|
||||
if ( $gr->name eq 'wheel' && @{$gr->members} > 1 ) {
|
||||
print "gid zero name wheel, with other members";
|
||||
}
|
||||
|
||||
use User::grent qw(:FIELDS);
|
||||
getgrgid(0) or die "No group zero";
|
||||
if ( $gr_name eq 'wheel' && @gr_members > 1 ) {
|
||||
print "gid zero name wheel, with other members";
|
||||
}
|
||||
|
||||
$gr = getgr($whoever);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module's default exports override the core getgrent(), getgrgid(),
|
||||
and getgrnam() functions, replacing them with versions that return
|
||||
"User::grent" objects. This object has methods that return the similarly
|
||||
named structure field name from the C's passwd structure from F<grp.h>;
|
||||
namely name, passwd, gid, and members (not mem). The first three
|
||||
return scalars, the last an array reference.
|
||||
|
||||
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<gr_>. Thus, C<$group_obj-E<gt>gid()> corresponds
|
||||
to $gr_gid if you import the fields. Array references are available as
|
||||
regular array variables, so C<@{ $group_obj-E<gt>members() }> would be
|
||||
simply @gr_members.
|
||||
|
||||
The getgr() function is a simple front-end that forwards a numeric
|
||||
argument to getgrgid() and the rest to getgrnam().
|
||||
|
||||
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.
|
||||
|
||||
=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
|
||||
301
database/perl/lib/User/pwent.pm
Normal file
301
database/perl/lib/User/pwent.pm
Normal file
@@ -0,0 +1,301 @@
|
||||
package User::pwent;
|
||||
|
||||
use 5.006;
|
||||
our $VERSION = '1.01';
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Config;
|
||||
use Carp;
|
||||
|
||||
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
|
||||
our ( $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,
|
||||
);
|
||||
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
|
||||
);
|
||||
%EXPORT_TAGS = (
|
||||
FIELDS => [ grep(/^\$pw_/, @EXPORT_OK), @EXPORT ],
|
||||
ALL => [ @EXPORT, @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 4
|
||||
|
||||
=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
|
||||
Reference in New Issue
Block a user