#!/usr/bin/perl -w
#
# relaydbm:
# Insert the address of a connected client into a DBM database, along with
# the time at which the connection was made, for POP-before-SMTP relaying.
#
# This is an example to suggest how you might want to go about implementing
# something of this sort. Obviously a counterpart program is needed to clean
# old entries out of the database.
#
# Copyright (c) 2002 Chris Lightfoot.
# Email: chris@ex-parrot.com; WWW: http://www.ex-parrot.com/~chris/
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2, or (at your option)
# any later version.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software Foundation,
# Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
#

my $rcsid = '$Id$';

package RelayDBM;
use TPOP3D::AuthDriver;
use IO::File;
use GDBM_File;

$client_ip_db = "/var/run/relayers";

@ISA = qw(TPOP3D::AuthDriver);

# Override generic onlogin implementation.
sub onlogin ($$) {
    my ($self, $req) = @_;
    my %table;
    my $file;

    # GDBM databases are always locked when writing.
    tie(%table, 'GDBM_File', $client_ip_db, &GDBM_WRCREAT, 0600)
        or return { logmsg => "tie($client_ip_db): $!" };
    $table{$req->{clienthost}} = time;
    untie(%table);

    return { logmsg => "saved $req->{clienthost} in $client_ip_db" };
}

package main;

my $auth = new RelayDBM;

# Subroutine for auth-perl compatibility.
sub onlogin ($) {
    return $auth->onlogin(@_);
}

if (defined($ENV{TPOP3D_CONTEXT}) and $ENV{TPOP3D_CONTEXT} eq 'auth_other') {
    $auth->run();
    exit 0;
}

1;
