summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/User
diff options
context:
space:
mode:
authorSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 17:57:31 +0000
committerSiep Kroonenberg <siepo@cybercomm.nl>2011-02-17 17:57:31 +0000
commit320d8694fec25ed148613684543b5a0504a046ae (patch)
tree0ddcf933d3acd3c98a387fa2bf73d0554ca6e50d /Master/tlpkg/tlperl/lib/User
parent779e71f16ca01a6244b632b95bdb461fec163b34 (diff)
New tlperl part XIV
git-svn-id: svn://tug.org/texlive/trunk@21436 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/User')
-rw-r--r--Master/tlpkg/tlperl/lib/User/grent.pm95
-rw-r--r--Master/tlpkg/tlperl/lib/User/pwent.pm298
2 files changed, 393 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/User/grent.pm b/Master/tlpkg/tlperl/lib/User/grent.pm
new file mode 100644
index 00000000000..ce6ee5ea447
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/User/grent.pm
@@ -0,0 +1,95 @@
+package User::grent;
+use strict;
+
+use 5.006_001;
+our $VERSION = '1.01';
+our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+BEGIN {
+ use Exporter ();
+ @EXPORT = qw(getgrent getgrgid getgrnam getgr);
+ @EXPORT_OK = qw($gr_name $gr_gid $gr_passwd $gr_mem @gr_members);
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+}
+use vars @EXPORT_OK;
+
+# 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(), getgruid(),
+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 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.
+
+=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
diff --git a/Master/tlpkg/tlperl/lib/User/pwent.pm b/Master/tlpkg/tlperl/lib/User/pwent.pm
new file mode 100644
index 00000000000..91d23bd3f68
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/User/pwent.pm
@@ -0,0 +1,298 @@
+package User::pwent;
+
+use 5.006;
+our $VERSION = '1.00';
+
+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 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