#!/usr/bin/perl -w

use strict;
use IO::File;
use IO::Socket;
use IO::Select;
use Queue;

my ($svr_shutdown, $verbose, $debug);
my ($select, $log);
my %conn_info;

my $msg_id;
my ($msg, @addr_list, $list_pos);
my $qdir = "queue";
my $q = Queue->new($qdir);

sub printlog;
sub close_client;

#########################################################
#
# The %cmds hash keeps the protocol commands and their
#    associated subrefs. To add functionality, just
#    declare the sub and add a key to the hash.
#
#########################################################

my %cmds;

sub next_addr();
sub succ_addr();
sub fail_addr();
sub get_msg();
sub svr_stat();
sub svr_down();

%cmds = (
'next_addr'    => \&next_addr,
'succ_addr' => \&succ_addr,
'fail_addr'    => \&fail_addr,
'get_msg'    => \&get_msg,
'quit'        => \&close_client,
'stat'        => \&svr_stat,
'svr_down'    => \&svr_down,
'hup_log'    => \&hup_log,
);

#########################################################
#
# The protocol handlers actually live here - don't forget
#    to map the sub to a command in the %cmds hash.
#
#########################################################

sub next_addr()
{
    my ($clt) = @_;

    if (defined $msg && defined($conn_info{$clt->fileno}{"msg_id"}) &&
+ $msg_id eq $conn_info{$clt->fileno}{"msg_id"})
    {
        if ($list_pos < @addr_list)
        {
            chomp $addr_list[$list_pos];
            if ($debug) {print("0:  send_addr: $addr_list[$list_pos] "
+ . $clt->fileno . ": listpos: $list_pos : addrlist: " . scalar(@addr_
+list) . "\n")}
            snd($clt,$addr_list[$list_pos]);
            $list_pos++;
        }

        if ($list_pos >= @addr_list)
        {
            if ($debug) {print("0: flush:" . $clt->fileno . ": listpos
+: $list_pos : addrlist: " . scalar(@addr_list) . "\n")}
            printlog("$msg_id.msg finished. flushing.");

            $msg = undef;
            $msg_id = undef;
            @addr_list = undef;
            $list_pos = -1;
        }
    } else {
        if ($debug) {print("0: FIN:" . $clt->fileno . "\n")}
        delete $conn_info{$clt->fileno}{"msg_id"};
        snd($clt,"FIN");
    }
}

sub succ_addr()
{
    my ($clt,$addr) = @_;
    if (defined($addr))
    {
        printlog("succ: $addr");
        snd($clt,"OK");
    } else {
        snd($clt,"ERR:no addr!");
    }
}

sub fail_addr()
{
    my ($clt,$addr) = @_;
    if (defined($addr))
    {
        printlog("fail: $addr");
        snd($clt,"OK");
    } else {
        snd($clt,"ERR:no addr!");
    }
}

sub get_msg()
{
    my ($clt) = @_;

    if (!defined $msg)
    {
        my $msg_file = $q->next_by_ext(".msg");
        if ($msg_file)
        {
            my $list_file = $msg_file;
            $list_file =~ s/\.msg$/\.list/g;

            $_ = $msg_file;
            ($msg_id) = /$qdir\/(.*)?\.msg/;
            if ($debug) { print "Setting msg_id: $msg_id\n" }

            open(MSG, "<$msg_file");
            { local $/ = undef; $msg = <MSG>; }
            close(MSG);

            open(LIST, "<$list_file");
            @addr_list = <LIST>;
            close(LIST);

            $list_pos = 0;

            $q->dequeue($msg_file);
            $q->dequeue($list_file);

            printlog("$msg_id.msg loaded; " . scalar @addr_list . " ad
+dresses");
        } else {
            $msg = undef;
            $msg_id = undef;
        }
    }

    if (defined $msg)
    {
        snd($clt,$msg);
        if ($debug) { print "conn:" . $clt->fileno . ": msg_id=$msg_id
+\n" }
        $conn_info{$clt->fileno}{"msg_id"} = $msg_id;
    } else {
        snd($clt,"FIN");
        if (exists $conn_info{$clt->fileno}{"msg_id"}) { delete $conn_
+info{$clt->fileno}{"msg_id"} }
    }
}

sub svr_stat()
{
    my ($clt) = @_;
    if ($list_pos >= @addr_list)
    {
        snd($clt,"List finished - $list_pos addresses processed");
    } elsif ($list_pos == 0) {
        snd($clt,"List ready. Waiting for client.");
    } else {
        snd($clt,$list_pos . " of " . (@addr_list));
    }
}

sub svr_down()
{
    my ($clt) = @_;
    $svr_shutdown = 1;
    snd($clt,"Bye!");
}

sub hup_log()
{
    my ($clt) = @_;
    $log->close();
    $log = IO::File->new(">>log/ds2.log");
    snd($clt,"log released");
}
################################
#
#
################################

sub snd
{
    my $sock = shift;
    my $msg = shift;

    my $len = length($msg);
    if ($debug) {print $sock->fileno . ": > $len : $msg\n"}
    $msg = pack('N', $len) . $msg;
    syswrite($sock, $msg, length($msg));
}

sub rcv
{
    my $sock = shift;
    my $buf;
    my ($bytes_read, $total_read, $bytes_to_read);
    
    $bytes_read = sysread($sock, $buf, 4);
    if ($! || ($bytes_read != 4))
    {
        return undef;
    } else {
        $bytes_to_read = unpack('N',$buf);
        #if ($debug) { print "Read count: $bytes_to_read\n" }

        # Quick sanity check on our packet length
        # Bob help you if you're trying to read over 1MB packets :-)
        return undef if ($bytes_to_read <= 0 || $bytes_to_read > 10000
+00);
        
        $total_read = 0;
        my $buf2 = $buf = undef;
        while ($total_read < $bytes_to_read)
        {
            $bytes_read = sysread($sock, $buf, $bytes_to_read - $total
+_read);
            $buf2 .= $buf;
            $total_read += $bytes_read;
        }
        $buf = $buf2;
    }
    return $buf;
}

sub printlog
{
    my @date = localtime(time);
    my $timestamp = sprintf("%02d/%02d/%04d %02d:%02d:%02d", $date[4] 
++ 1, $date[3], $date[5] + 1900, $date[2],$date[1], $date[0]);
    print $log "$timestamp: @_\n";
    $log->flush();
}

sub close_client
{
    my $socket = shift;
    if ($debug) {print($socket->fileno . ": disconnected\n")}
    if (defined $conn_info{$socket->fileno}) { delete($conn_info{$sock
+et->fileno}) }
    $select->remove($socket);
    $socket->close;
}

#########################################################
#
# start_server - Sets up the server socket and handles
#    all I/O and command dispatching.
#
#########################################################

#########################################################
#
# Start things running...
#
#########################################################


$| = 1;
$list_pos = 0;
$verbose = 0;
$debug = 0;

while (defined($_ = shift))
{
    if    ($_ eq '-v' || $_ eq '--verbose') {$verbose = 1}
    elsif ($_ eq '-d' || $_ eq '--debug')   {$debug = 1}
}

$svr_shutdown = 0;

my $server = IO::Socket::INET->new(
    Proto        => 'tcp',
    LocalPort    => 6900,
    Listen        => SOMAXCONN,
    Reuse        => 1);

$select = IO::Select->new($server);

$log = IO::File->new(">>log/ds2.log");
    
my @ready;

while (!$svr_shutdown && (@ready = $select->can_read))
{
    my $socket;
    
    for $socket (@ready)
    {
        if ($socket == $server)
        {
            my $new_clt = $server->accept();
            $new_clt->autoflush(1);
            $select->add($new_clt);
            if ($debug) {print($new_clt->fileno . ": connected\n")}
            snd($new_clt,"HELO " . $new_clt->fileno);
        } else {
            my $msg;
            if (defined($msg = rcv($socket)))
            {
                chomp $msg;
                if ($debug) {print($socket->fileno . ": $msg\n")}
                $_ = $msg;
                my ($clt_cmd, $clt_args) = /^\s*(\w*)\s*(.*)/;
                if (exists($cmds{"$clt_cmd"}))
                {
                    my $subref = $cmds{"$clt_cmd"};
                    &$subref($socket, $clt_args);
                } else {
                    snd($socket,"Invalid command: $clt_cmd");
                }
            } else {
                close_client($socket);
            }
        }
    }
}
$log->close();
[download]