File Coverage

blib/lib/Passwd/DB.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

package Passwd::DB;

use DB_File;
use strict;
use Carp;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

require Exporter;
require AutoLoader;

@ISA = qw(Exporter AutoLoader);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT = qw(getpwnam getpwuid);

@EXPORT_OK = qw(mgetpwnam setpwinfo rmpwnam init_db modpwinfo);

$VERSION = '1.04';

my %_Create_Flags = (
		     'freebsd' => 0x200,
		     'linux' => 0100,
		     'solaris' => 0x100,
		     'hpux' => => 0400, # same as 0x100
		     );
my %_DB_Global = ();
$_DB_Global{'Database'} = $ENV{'PWDDatabase'};

if (defined($_Create_Flags{$^O})) {
    $_DB_Global{'CFlags'} = $_Create_Flags{$^O};
} else {
    $_DB_Global{'CFlags'} = 0x100;
}

# Preloaded methods go here.

sub new {
    my $class = shift;
    my $self = {};

    bless $self, $class;
    if ((scalar(@_) >= 3) || (scalar(@_) < 1)) {
        croak "$class: $class->new('/path/to/database_file' [, 'create'])";
    }
    $self->{'CLASS'} = $class;
    $self->init_db(@_);
    return $self;
}

sub init_db ($;$) {
    my ($self, $db, $create) = @_;
    if (ref($self)) {
	$self->{'Database'} = $db;
    } else {
	if ($self eq 'Passwd::DB') {
	    $_DB_Global{'Database'} = $db;
	} else {
	    $_DB_Global{'Database'} = $self;
	    $create = $db;
	    $db = $self;
	}
    }
    $create =~ tr/A-Z/-z/;
    if ($create eq 'create' || $create == 1) {
        _create_db($db);
    }
#    print "Using PasswordDB functions on $Database\n";
}

sub _create_db ($) {
    my ($db) = @_;
    my (%dbm);

    tie (%dbm, 'DB_File', $db, $_DB_Global{'CFlags'}|2, 0640, $DB_HASH) or do {
	croak "Couldn't create $db : $!";
    };
    untie (%dbm);
}

sub getpwnam ($) {
    my ($self, $login) = @_;
    my (%dbm, @info, $db);

    if (ref($self)) {
	$db = $self->{'Database'};
    } else {
	$login = $self;
	$db = $_DB_Global{'Database'};
    }

    tie (%dbm, 'DB_File', $db, 0, 0400, $DB_HASH) or do {
	croak "Couldn't access $db : $!";
    };
    if (!defined($dbm{$login})) {
        untie %dbm;
        return;
    }
    @info = (split(':',$dbm{$login}));
    if (scalar(@info) == 7) {
        splice (@info,4,0, "");
        splice (@info,4,0, "");
        untie %dbm;
        return @info;
    }
    untie %dbm;
    return;
}

sub getpwuid ($) {
    my ($self, $uid) = @_;
    my (%dbm, @info, $key, $db);

    if (ref($self)) {
	$db = $self->{'Database'};
    } else {
	$uid = $self;
	$db = $_DB_Global{'Database'};
    }

    tie (%dbm, 'DB_File', $db, 0, 0400, $DB_HASH) or do {
        croak "Couldn't access $db : $!";
    };
    foreach $key (keys %dbm) {
        @info = (split(':',$dbm{$key}));
        if ($info[2] == $uid) {
            if (scalar(@info) == 7) {
                splice (@info,4,0, qw(0 0));
            }
            untie %dbm;
            return (@info);
        }
    }
    untie %dbm;
    return;
}

sub mgetpwnam ($) { # same as getpwnam without quota and comment
    my ($self, $login) = @_;
    my (%dbm, @info, $db);

    if (ref($self)) {
	$db = $self->{'Database'};
    } else {
	$login = $self;
	$db = $_DB_Global{'Database'};
    }

    tie (%dbm, 'DB_File', $db, 0, 0400, $DB_HASH) or do {
        croak "Couldn't access $db : $!";
    };
    if (!defined($dbm{$login})) {
        untie %dbm;
        return;
    }
    @info = (split(':',$dbm{$login}));
    untie %dbm;
    if (scalar(@info) == 7) {
        return (@info);
    }
    return;
}
sub modpwinfo (@) {
    my ($self, @info) = @_;
    my (%dbm, $loginfo, $db, $size, $err);

    if (ref($self)) {
	$db = $self->{'Database'};
	$size = scalar(@info);
    } else {
	$size = unshift @info, $self;
	$db = $_DB_Global{'Database'};
    }

    if ($size != 7) {
        croak "Incorrect number of arguments for modpwinfo";
    }
    tie (%dbm, 'DB_File', $db, 2, 0600, $DB_HASH) or do {
        croak "Couldn't access $db : $!";
    };
    if (!defined($dbm{$info[0]})) {
	return 2;
    }
    $loginfo = join(':',@info);
    $dbm{$info[0]} = $loginfo;
    $err = (!defined($dbm{$info[0]}));
    untie %dbm;

    return $err;
}

sub setpwinfo (@) {
    my ($self, @info) = @_;
    my (%dbm, $loginfo, $db, $size, $err);

    if (ref($self)) {
	$db = $self->{'Database'};
	$size = scalar(@info);
    } else {
	$size = unshift @info, $self;
	$db = $_DB_Global{'Database'};
    }

    if ($size != 7) {
        croak "Incorrect number of arguments for setpwinfo";
    }
    tie (%dbm, 'DB_File', $db, 2, 0600, $DB_HASH) or do {
        croak "Couldn't access $db : $!";
    };
    $loginfo = join(':',@info);
    $dbm{$info[0]} = $loginfo;
    $err = (!defined($dbm{$info[0]}));
    untie %dbm;

    return $err;
}

sub rmpwnam ($) {
    my ($self, $login) = @_;
    my (%dbm, $db);

    if (ref($self)) {
	$db = $self->{'Database'};
    } else {
	$login = $self;
	$db = $_DB_Global{'Database'};
    }

    tie (%dbm, 'DB_File', $db, 2, 0600, $DB_HASH) or do {
        croak "Couldn't access $db : $!";
    };
    my $err = delete $dbm{$login};
    untie %dbm;

    if (!defined($err)) {
        return 1;
    }
    return 0;
}


# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__