# Mail::vpopmail.pm
# $Id: vpopmail.pm,v 0.9 2010/04/11 02:47:44 jkister Exp $
# Copyright (c) 2004-2010 Jeremy Kister.
# Released under Perl's Artistic License.

$Mail::vpopmail::VERSION = "0.90";

=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,
                                     vpopuser    => 'vpopmail',
                                     auth_module => 'cdb',
                                     dsn         => 'DBI:mysql:host=localhost;database=vpopmail',
                                     dbun        => 'vpopmailuser',
                                     dbpw        => 'vpoppasswd',
                                    );

    
=head1 DESCRIPTION

C<Mail::vpopmail> 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<OPTIONS> are passed in a hash like fashion, using key and value
pairs.  Possible options are:

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

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

B<vpopuser> - Specify vpopmail user.  Default=vpopmail

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

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

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

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

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

B<email> - the email address to get properties on

B<field> - 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 => <field> );

B<domain> - the domain to get properties on

B<field> - 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 => <field> );

B<field> - 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=<STDIN>);
    }


    # 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=<STDIN>);
    }

    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;

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

    $args{cache}    = 1 unless(defined($args{cache}));
    $args{debug}    = 1 unless(defined($args{debug}));
    $args{vpopuser} = 'vpopmail' unless(defined($args{vpopuser}));

    my $vpopdir = (getpwnam($args{vpopuser}))[7]; # no need to cache, only called once
    die "vpopmail home directory ($vpopdir) not found.\n" unless(-d $vpopdir);

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

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

    my $self = bless(\%args, $class);

    $self->{class} = $class;


    return($self);
        
}

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

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

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

sub _dir {
    my $self = 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(<ASSIGN>){
                if(/^\+${domain}\-:[^:]+:\d+:\d+:([^:]+):-:/){
                    $dir = $1;
                    last;
                }
            }
            close ASSIGN;

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

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

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

        if($arg{field} eq 'dir'){
            push @return, $dir;
        }else{
            if(exists($_cache{$arg{email}}{crypt})){
            debug( "cache found for $arg{email}" );
                foreach my $field (split(/,/, $arg{field})){
                    push @return, $_cache{$arg{email}}{$field};
                }
            }else{
                my (%uhash,$found);
                if($self->{auth_module} eq 'cdb'){
                    if(open(VPASSWD, "${dir}/vpasswd")){
                        while(<VPASSWD>){
                            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{
                        die "cannot open ${dir}/vpasswd: $!\n";
                    }
                }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 $self->{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($self->{cache}){
                        while(my($key,$value) = each %uhash){
                            $_cache{$arg{email}}{$key} = $value;
                        }
                    }
    
                    foreach my $field (split(/,/, $arg{field})){
                        push @return, $uhash{$field};
                    }
                }else{
                    debug( "cannot find ${user} in ${domain}" );
                }
            }
        }
        return (@return == 1) ? $return[0] : @return;
    }else{
        debug( "email not supplied correctly" );
    }
    return();
}

sub alldomains {
    my $self = shift;
    my %arg = @_;
    unless($arg{field} eq 'name' || $arg{field} eq 'dir' || $arg{field} eq 'map'){
        die "syntax error: field: $arg{field}\n";
    }

    # assign is still authoritative when sql in use
    open(ASSIGN, '/var/qmail/users/assign') || die "cannot open /var/qmail/users/assign: $!\n";
    my @array;
    while(<ASSIGN>){
        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);
}

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

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

    my %hash = ( dir => (exists($_cache{$arg{domain}}{dir})) ? $_cache{$arg{domain}}{dir} : $self->_dir($arg{domain}) );
    $self->_debug( "hash{dir}: $hash{dir}" );

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

    my @return;
    if($self->{auth_module} eq 'cdb'){
        open(VPASSWD, "$hash{dir}/vpasswd") || die "cannot open $hash{dir}/vpasswd: $!\n";
        while(<VPASSWD>){
            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($self->{cache}){
                    while(my($key,$value) = each %hash){
                        $_cache{$hash{mailbox}}{$key} = $value;
                    }
                }
           }
        }
        close VPASSWD;
    }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 $self->{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);
}

sub _debug {
    my $self = shift;
    my $msg = join(' ', @_);
    
    warn "$msg\n" if($self->{debug});
}
    
1;