File Coverage

blib/lib/Mail/vpopmail.pm

Criterion	Covered	Total	%
statement	3	159	1.8
branch	0	126	0.0
condition	0	21	0.0
subroutine	1	8	12.5
pod	4	5	80.0
total	8	319	2.5

# Mail::vpopmail.pm
# $Id: vpopmail.pm,v 0.60b3 2007/04/16 00:32:24 jkister Exp $
# Copyright (c) 2004-2007 Jeremy Kister.
# Released under Perl's Artistic License.

$Mail::vpopmail::VERSION = "0.60b3";

=head1 NAME

Mail::vpopmail - Utility to get information about vpopmail managed email addresses

=head1 SYNOPSIS

use Mail::vpopmail;

my $vchkpw = Mail::vpopmail->new();

my $vchkpw = Mail::vpopmail->new(cache => 1,
                                 debug => 0,
                                 auth_module => 'cdb',
                                 dsn   => 'DBI:mysql:host=localhost;database=vpopmail',
                                 dbun  => 'vpopmailuser',
                                 dbpw  => 'vpoppasswd',
                                );


=head1 DESCRIPTION

C provides serveral functions for interacting with
vpopmail.  This module can be useful especially when hashing is turned
on, as you can not predict the location of the domain's nor the
mailbox's directories.

=head1 CONSTRUCTOR

=over 4

=item new( [OPTIONS] );

C are passed in a hash like fashion, using key and value
pairs.  Possible options are:

B - Cache results of queries (0=Off, 1=On).  Default=On.

B - Print debugging info to STDERR (0=Off, 1=On).  Default=On.

B - cdb or sql.  Default=cdb, but
			        Default=sql if ~vpopmail/etc/vpopmail.mysql exists.

B - SQL DSN.  Default='DBI:mysql:host=localhost;database=vpopmail'
         Autogenerated if ~vpopmail/etc/vpopmail.mysql exists.

B - SQL Username.  Default=vpopmailuser.
          Autogenerated if ~vpopmail/etc/vpopmail.mysql exists.

B - SQL Password.  Default=vpoppasswd.
          Autogenerated if ~vpopmail/etc/vpopmail.mysql exists.

=item userinfo( email => $email, field =>  );

B - the email address to get properties on

B - the field(s) to be returned (may be comma separated):

	dir - return this domain's vpopmail domains directory

	crypt - return the encrypted password

	uid - return the uid

	gid - return the gid

	comment - return the comment, if available

	maildir - return this user's maildir

	quota - return the quota (you have to parse this yourself)

	plain - return the plain text password, if available

=item domaininfo( domain => $domain, field =>  );

B - the domain to get properties on

B - the field to be returned:

   dir - return the vpopmail domain directory

   mailboxes - return an array reference containing all the mailboxes

   all - return an array ref of hash refs of all data for the domain

=item alldomains( field =>  );

B - the field to be returned:

   name - returns an array reference of the names of all domains

   dir - returns an array refrence of all domain directories

   map - returns a hash reference of domain name -> domain directory


=head1 EXAMPLES

	use strict;
	use Mail::vpopmail;

	my $vchkpw = Mail::vpopmail->new(cache=>1, debug=>0);


	# find all domains
	my $domains_aref = $vchkpw->alldomains(field => 'name');
	foreach my $domain (@${domains_aref}){
		print "$domain\n";
	}

	# find all domains directories
	my $dirlist_aref = $vchkpw->alldomains(field => 'dir');
	foreach my $dir (@${dirlist_aref}){
		print "$dir\n";
	}

	# find all domains and their directories
	my $alllist_aref = $vchkpw->alldomains(field => 'map');
	foreach my $href (@${alllist_aref}){
		print "$href->{name} => $href->{dir}\n";
	}

	my $domain = shift;
	unless(defined($domain)){
		print "enter domain: ";
		chop($domain=);
	}


	# find all mailboxes in a given domain
	my $mailboxes_aref = $vchkpw->domaininfo(domain => $domain, field => 'mailboxes');
	foreach my $mailbox (@{$mailboxes_aref}){
		print "found mailbox: $mailbox for domain: $domain\n";
	}

	# find all properties for a given domain
	my $alldata_aref = $vchkpw->domaininfo(domain => $domain, field => 'all');
	foreach my $href (@{$alldata_aref}){
		print "found data for $domain:\n";
		while(my($key,$value) = each %{$href}){
			print " found $key => $value\n";
		}
	}

	# individual user stuff
	my $email = shift;
	unless(defined($email)){
		print "email address: ";
		chop($email=);
	}

	my $dir = $vchkpw->userinfo(email => $email, field => 'dir');
	print "dir: $dir\n";
	my ($crypt,$uid,$gid) = $vchkpw->userinfo(email => $email, field => 'crypt,uid,gid');
	print "crypt/uid/gid: $crypt/$uid/$gid\n";
	my $comment = $vchkpw->userinfo(email => $email, field => 'comment');
	print "comment: $comment\n";
	my $maildir = $vchkpw->userinfo(email => $email, field => 'maildir');
	print "maildir: $maildir\n";
	my $quota = $vchkpw->userinfo(email => $email, field => 'quota');
	print "quota: $quota\n";
	my $plain = $vchkpw->userinfo(email => $email, field => 'plain');
	print "plain: $plain\n";

=head1 CAVEATS

This version is the first that supports SQL auth modules.  It is not
tested and should be used with caution.  Feedback needed.


=head1 AUTHOR

Jeremy Kister - http://jeremy.kister.net/

=cut

package Mail::vpopmail;

use strict;

my $HAVE_DBI;
eval{ require DBI; $HAVE_DBI=1; };

my (%_cache,%_arg);

sub new {
	my $class = shift;
	%_arg = @_;

	$_arg{cache} = 1 unless(defined($_arg{cache}));
	$_arg{debug} = 1 unless(defined($_arg{debug}));

	my $vpopdir = (getpwnam('vpopmail'))[7];
	die "vpopmail home directory ($vpopdir) not found.\n" unless(-d $vpopdir);

	if(open(MYSQL, "${vpopdir}/etc/vpopmail.mysql")){
		chop(my $input=);
		my ($hostname,$dbport,$dbun,$dbpw,$dbname) = split(/\|/, $input);
		close MYSQL;

		my $dsn = "DBI:mysql:hostname=${hostname};database=${dbname}";
		$dsn .= ";port=$dbport" if($dbport);
		$_arg{dsn} = $dsn;
		$_arg{dbname} = $dbname;
		$_arg{dbun} = $dbun;
		$_arg{dbpw} = $dbpw;
		$_arg{auth_module} = 'sql';
	}elsif($_arg{auth_module} eq 'sql'){
		$_arg{dsn} = 'DBI:ldap:host=localhost;database=vpopmail' unless(defined($_arg{dsn}));
		($_arg{dbname}) = $_arg{dsn} =~ /database=([^\=\;\:\s]+)/;
		$_arg{dbun} = 'vpopmailuser' unless(defined($_arg{dbun}));
		$_arg{dbpw} = 'vpoppasswd' unless(defined($_arg{dbpw}));
	}else{
		$_arg{auth_module} = 'cdb';
	}

	if($_arg{auth_module} eq 'sql'){
		unless($HAVE_DBI){
			warn "You're trying to use SQL support, but do not have DBI in \@INC.  (\@INC contains: )";
			foreach(@INC){
				print "$_ ";
			}
			die "\nnew() failed-- ";
		}
	}

	return(bless({},$class));
}

sub Version { $Mail::vpopmail::VERSION }

sub _handle_dbh {
	my $dbh = ($_cache{dbh}) ? $_cache{dbh} : DBI->connect($_arg{dsn}, $_arg{dbun}, $_arg{dbpw}, {RaiseError => 1});

	unless($dbh){
		die "Connect to database failed: $DBI::errstr ";
	}
	if($_arg{cache}){
		$_cache{dbh} = $dbh unless($_cache{dbh});
	}
	return($dbh);
}

sub _dir {
	my $class = shift;
	if(my $domain = shift){
		return($_cache{$domain}{dir}) if($_cache{$domain}{dir});

		# assign is still authoritative when sql in use
		if(open(ASSIGN, '/var/qmail/users/assign')){
			my $dir;
			while(){
				if(/^\+${domain}\-:[^:]+:\d+:\d+:([^:]+):-:/){
					$dir = $1;
					last;
				}
			}
			close ASSIGN;

			if(defined($dir)){
				$_cache{$domain}{dir} = $dir if($_arg{cache});
				return($dir); # this dir is not verified, it's just what vpopmail thinks
			}else{
				warn "could not find directory for domain: $domain\n" if($_arg{debug});
			}
		}else{
			warn "could not open /var/qmail/users/assign: $!\n" if($_arg{debug});
		}
	}else{
		warn "domain not supplied correctly\n" if($_arg{debug});
	}
	return();
}

sub userinfo {
	my $class = shift;
	my %arg = @_;
	unless(exists($arg{email}) && exists($arg{field})){
		if($_arg{debug}){
			warn "syntax error: email: $arg{email} field: $arg{field}\n";
		}
		return();
	}
	my ($user,$domain) = split(/\@/, $arg{email}); # no routing data supported
	warn "arg{email}: $arg{email} - user: $user - domain: $domain\n" if($_arg{debug});

	if(defined($user) && defined($domain)){
		my @return;
		my $dir = Mail::vpopmail->_dir($domain);

		if($arg{field} eq 'dir'){
			push @return, $dir;
		}else{
			if(exists($_cache{$arg{email}}{crypt})){
			warn "cache found for $arg{email}\n" if($_arg{debug});
				foreach my $field (split(/,/, $arg{field})){
					push @return, $_cache{$arg{email}}{$field};
				}
			}else{
				my (%uhash,$found);
				if($_arg{auth_module} eq 'cdb'){
					if(open(VPASSWD, "${dir}/vpasswd")){
						while(){
							chomp;
							if(/^${user}:([^:]+):(\d+):(\d+):([^:]*):([^:]+):([^:]+)(:([^:]+))?/){
								%uhash = (crypt => $1, uid => $2, gid => $3, comment => $4,
								          maildir => $5, quota => $6, plain => $8, dir => $dir);
								$found=1;
								last;
							}
						}
						close VPASSWD;
					}else{
						warn "cannot open ${dir}/vpasswd: $!\n" if($_arg{debug});
					}
				}else{
					# sql
					my $dbh = _handle_dbh();
					my $sql = "SELECT pw_passwd,pw_uid,pw_gid,pw_gecos,pw_dir,pw_shell,pw_clear_passwd FROM $_arg{dbname}";
					$sql .= ' WHERE pw_name = ' . $dbh->quote($user) . ' AND pw_domain = ' . $dbh->quote($domain);
					my $sth = $dbh->prepare($sql);
					$sth->execute;
					my $row = $sth->fetchrow_arrayref;
					%uhash = (crypt => $row->[0], uid => $row->[1], gid => $row->[2], comment => $row->[3],
					          maildir => $row->[4], quota => $row->[5], plain => $row->[6], dir => ${dir});
					$found=1 if(exists($uhash{crypt}));
				}
				if($found){
					if($_arg{cache}){
						while(my($key,$value) = each %uhash){
							$_cache{$arg{email}}{$key} = $value;
						}
					}

					foreach my $field (split(/,/, $arg{field})){
						push @return, $uhash{$field};
					}
				}else{
					warn "cannot find ${user} in ${domain}\n" if($_arg{debug});
				}
			}
		}
		return (@return == 1) ? $return[0] : @return;
	}else{
		warn "email not supplied correctly\n" if($_arg{'debug'});
	}
	return();
}

sub alldomains {
	my $class = shift;
	my %arg = @_;
	unless($arg{field} eq 'name' || $arg{field} eq 'dir' || $arg{field} eq 'map'){
		if($_arg{debug}){
			warn "syntax error: field: $arg{field}\n";
		}
		return();
	}

	# assign is still authoritative when sql in use
	if(open(ASSIGN, '/var/qmail/users/assign')){
		my @array;
		while(){
			if(/^\+([^:]+)\-:[^:]+:\d+:\d+:([^:]+):-:/){
				if($arg{field} eq 'map'){
					push @array, { name => $1, dir => $2 };
				}elsif($arg{field} eq 'dir'){
					push @array, $2;
				}else{
					push @array, $1;
				}
			}
		}
		close ASSIGN;
		return(\@array);
	}else{
		warn "could not open /var/qmail/users/assign: $!\n" if($_arg{debug});
	}
	return();
}

sub domaininfo {
	my $class = shift;
	my %arg = @_;

	if(exists($arg{domain}) && exists($arg{field})){
		unless($arg{field} eq 'mailboxes' || $arg{field} eq 'all' || $arg{field} eq 'dir'){
			warn "syntax error: domain field type may be 'mailboxes' or 'all'\n" if($_arg{debug});
			return();
		}
	}else{
		if($_arg{debug}){
			warn "syntax error: domain: $arg{domain} - field: $arg{field}\n";
		}
		return();
	}

	my %hash = ( dir => (exists($_cache{$arg{domain}}{dir})) ? $_cache{$arg{domain}}{dir} : Mail::vpopmail->_dir($arg{domain}) );
	warn "hash{dir}: $hash{dir}\n" if($_arg{debug});

	if($arg{field} eq 'dir'){
		return($hash{dir});
	}

	my @return;
	if($_arg{auth_module} eq 'cdb'){
		if(open(VPASSWD, "$hash{dir}/vpasswd")){
			while(){
				chomp;
				if(/^([^:]+):([^:]+):(\d+):(\d+):([^:]*):([^:]+):([^:]+)(:([^:]+))?/){
					%hash = (mailbox => $1, crypt => $2, uid => $3, gid => $4,
					         comment => $5, maildir => $6, quota => $7, plain => $9, dir => $hash{dir});

					if($arg{field} eq 'mailboxes'){
						push @return, $hash{mailbox};
					}else{
						push @return, \%hash;
					}

					if($_arg{cache}){
						while(my($key,$value) = each %hash){
							$_cache{$hash{mailbox}}{$key} = $value;
						}
					}
				}
			}
			close VPASSWD;

		}else{
			warn "cannot open $hash{dir}/vpasswd: $!\n" if($_arg{debug});
		}
	}else{
		#sql;
		my $dbh = _handle_dbh();
		my $sql = 'SELECT pw_name';
		$sql .= ',pw_passwd,pw_uid,pw_gid,pw_gecos,pw_dir,pw_shell,pw_clear_passwd' if($arg{field} eq 'all');
		$sql .= " FROM $_arg{dbname} WHERE pw_domain = " . $dbh->quote($arg{domain});
		my $sth = $dbh->prepare($sql);
		$sth->execute;
		while(my $row = $sth->fetchrow_arrayref){
			if($arg{field} eq 'mailboxes'){
				push @return, $row->[0];
			}else{
				push @return, { mailbox => $row->[0], crypt => $row->[1], uid => $row->[2], gid => $row->[3],
				                comment => $row->[4], maildir => $row->[5], quota => $row->[6],
				                plain => $row->[7], dir => $hash{dir} };
			}
		}
	}
	return(\@return);
}

1;