Telecom/1996-04-telecom-walnutcreek.iso/technical/ixo.program.scripts/tpaged.pl

Perl Script | 1993-02-15 | 11.9 KB | 420 lines

#! /usr/local/bin/perl4.019

# tpaged -- back-end to tpage system.
#   by Tom Limoncelli, [e-mail]
#   Copyright (c) 1992, Tom Limoncelli
#   The sources can be freely copied for non-commercial use only
#   and only if they are unmodified.

# Version 2.0 -- See file HISTORY for details.


####################################################################
#
# Parameters that the user can set:
#
####################################################################

$debug = 0;
# $| = 1; open( STDOUT, ">/home/adm/lib/tpage/log.txt" ) if $debug; $| = 1;
$QUEUE_DIR = '/home/adm/lib/tpage/pqueue/';        # same as in tpage.pl
#$IXOCICO = '/home/tal/work/beep2/ixocico';        # where is ixocico?
$IXOCICO  = '/home/adm/lib/tpage/ixocico';        # where is ixocico?
$MAIL = '/usr/ucb/mail';                        # which
mail to use?
     # Recommended mailers:  SunOS & BSD's:  /usr/ucb/mail, AT&T Unix's xmail
     # Not recommended mailers:  /bin/mail

# list of devices to rotate through.
@DEVICES = ( "/dev/ttyz4" );    # currently they are all spoken
# to at the same speed and same parameters.  Some day I'll set up
# a modemtab system, but I don't think more than one modem is
# really needed for this system.

# amount of time to sleep between scans of the queue
$SLEEP_TIME =  150;    # 2.5 minutes
$SLEEP_TIME =  10 if $debug;    # smaller when I'm debugging
# Small amount of time to wait between finding anything in the queue
# and doing a real scan of the queue.
$MULT_SLEEP_TIME =  10;

####################################################################
# QUEUE FILES FORMAT:
#
# Files in the queue have the name of the format in the
# first line.  Currently there is only one format and it
# is named "A".  The first line marks it as the "A" format.
# a subroutine called read_format_A reads this format.  Other
# formats can be written (see comments by read_format_A)
#
# The "A" format:
# line  contents
#    1: A\n
#    2: number to dial\n
#    3: pin\n
#    4: entire message\n
#    5: X\n

# read_format_*  -- modules that read various data formats.
#                   Currently implemented: The "A" format.
# do_proto_*     -- modules that do various beeper protocols.
#                   Currently implmented: the ixo protocol.
#                   Future protocols:     numeric-only pagers.

####################################################################
# Here's the actual program

# define some globals

local(%protocols);

while (1) {
    local ($first, @allfiles, @anyfiles);

    # We could scoop up all the files and process them, but chances
    # are if one file is found, more are on the way.  So, instead
    # we scoop, if any are found we sleep 5 seconds and re-scoop.

    # wait for any files to appear.
    while (1) {
        @anyfiles = &scan_queue;
        print "DEBUG: anyfiles= ", join(' ', @anyfiles), "\n" if $debug;

        if ($#anyfiles!=-1) {    # files?  take a rest and then process.
            sleep $MULT_SLEEP_TIME unless $debug;
            last;
        } else {            # no files?  hibernate.
            sleep $SLEEP_TIME;
            next;
        }
    }

    # re-get the files in the queue
    @allfiles = &scan_queue;
    print "DEBUG: allfiles= ", join(' ', @allfiles), "\n" if $debug;

    # get all the data out of the queue'd files.
    foreach $file (@allfiles) {
        print "DEBUG: Doing $file\n" if $debug;
        open(DATA, "<" . $QUEUE_DIR . $file) || print "Can't open $file:
$!";
        chop( $first = <DATA> );
print "DEBUG: first=$first\n" if $debug;
        eval "do read_format_$first()";
    }

    # process all the extracted data (do_protocol_* should delete the files)
    foreach $proto (keys %protocols) {
        eval "do do_protocol_$proto()";
        delete $protocols{ $proto };
        sleep $SLEEP_TIME;
    }
}

# scan the queue for entries (avoid "blacklisted" files)
sub scan_queue {
    local(@files);
    # scan the directory for "P files (pager files)
    opendir(QDIR, $QUEUE_DIR) || die "$0: Can't open $QUEUE_DIR: $!";
    @files = grep( /^P/, readdir(QDIR) );
    closedir(QDIR);
    print "DEBUG: filescan= ", join(' ', @files), "\n" if $debug;
    # remove the blacklisted files
    @files = grep( ! defined $blacklist_data{ $_ }, @files);
    print "DEBUG: goodfiles= ", join(' ', @files), "\n" if $debug;
    # return the files
    @files;
}

# blacklist a file in the queue (couldn't delete it for some reason
# and we don't want to repeat it)
sub blacklist {
    local($file) = @_;
    $blacklist_data{ $file } = 1;
}

# Each read_format_ must:
#  read from <DATA> and then close(DATA).
#  %protocols{ protocol name } = 1 (for the protocol to use)
#  and stuff the right data into the right variables for that protocol
#  to use.

sub read_format_A
{
    local($dial,$pin,$error,$mess,$X);    # $file is by sideeffect
    print "DEBUG: reading format A\n" if $debug;
    chop( $dial = <DATA> );
    chop( $pin = <DATA> );

    chop( $error = <DATA> );
    chop( $mess = <DATA> );
    chop( $X = <DATA> );

    return if $X ne "X";  # file isn't in correct format or isn't done.
    return if $dial eq "";
    return if $pin eq "";
    return if $mess eq "";

    $protocols{ 'ixo' } = 1;
    &ixo_mesg_append( $dial, $pin, $error, $mess, $file );
}

# Each do_protocol_ must:
#  delete files out of the queue that are successful.
#  delete files out of the queue that are aged.
#  clean up so that the routine can be called again.

sub do_protocol_ixo {
    print "DEBUG: doing protocol IXO\n" if $debug;
    local($pin, $error, $mess, $file, $cmd, $status, $index);
    local($general_reject, $general_error_message);
    # build the temp file and the command line
    local($tmpfile) = "/tmp/tpaged.$$";
    foreach $dial ( &ixo_listphones ) {
        print "DEBUG: Number to dial is $dial\n" if $debug;

        # fill the data file
        open(IX, ">$tmpfile" ) || die "$0: Can't create $tmpfile: $!";
        foreach $index ( &ixo_listindexes( $dial ) ) {
            ($pin, $error, $mess, $file) = &ixo_mesg_get( $dial, $index
);
            # put it in the file for ixocico to use
            print IX "$pin\n$mess\n";
        }
        close IX;

        print "DEBUG: messages to send", &ixo_listindexes( $dial ), "\n" if
$debug;

        $general_reject = 1;    # when done, 1=cancel remaining; 0=retry
remaining
        $general_error_message = "SHOULD NOT HAPPEN";    # if all messages
are cancelled

        $cmd = $IXOCICO . " <" . $tmpfile . " "
            . push(@DEVICES, shift @DEVICES) . " " . $dial;
        print "DEBUG: About to execute: $cmd\n" if $debug;
        open(IX, $cmd . "|") || die "$0: Can't execute ixocico: $!";

        while (<IX>) {
            print if $debug;
            next unless /^#/;

            print unless $debug;

            /^#WRONGARGS / &&
                die("$0: Major program bug: $!");
            /^#NOCONN / && do {
                printf("$0: Nobody answered the phone!\n") if
$debug;
                $general_reject = 0;
                last;
            };
            /^#UNKNOWNPROTO / && do {
                print "$0: Uhhh, are you sure that's a pager
service?\n" if $debug;
                $general_reject = 1;
                $general_error_message = "other end using different
protocol";
                last;
            };
            /^\#MESOK (\d) / && do {
                $index = $1;
                print "DEBUG: message $index done.\n" if $debug;

                ($pin, $error, $mess, $file) = &ixo_mesg_get(
$dial, $index );
                print "DEBUG: ERROR=$error; FILE=$file\n" if
$debug;

                print "DEBUG: unlinking " . $QUEUE_DIR . $file .
"\n" if $debug;
                $status = unlink $QUEUE_DIR . $file;
                print "DEBUG: unlink status=$status; $!\n" if
$debug;
                &blacklist( $file) unless $status;

                # remove from queue
                &ixo_mesg_delete( $dial, $index );
            };
            /^#MESREJECT (\d) / && do {        # very similar to
#MESOK
                $index = $1;
                print "DEBUG: message $index rejected.\n" if
$debug;

                ($pin, $error, $mess, $file) = &ixo_mesg_get(
$dial, $index );
                print "DEBUG: ERROR=$error; FILE=$file\n" if
$debug;

                # notify anyone that wants to know about failures
                if ($error + 0) {
                     $cmd = "$MAIL <"
                     . $QUEUE_DIR . $file
                     . " -s 'TPAGE_MESSAGE: request rejected by service' "
                     . $error;
                    print "DEBUG: About to execute $cmd\n" if
$debug;
                    system $cmd;
                }

                print "DEBUG: unlinking " . $QUEUE_DIR . $file .
"\n" if $debug;
                $status = unlink $QUEUE_DIR . $file;
                print "DEBUG: unlink status=$status; $!\n" if
$debug;
                &blacklist( $file) unless $status;

                # remove from queue
                &ixo_mesg_delete( $dial, $index );
            };
            /^#FORDIS / && do {
                print "Forced disconnect from server.\n" if $debug;
                $general_reject = 1;
                $general_error_message = "other end requesting
disconnect";
                last;
            };
            /^#PROTERR / && do {
                print "Server not following protocol.\n" if $debug;
                $general_reject = 1;
                $general_error_message = "other end having a
protocol error";
                last;
            };
            ( /^#DONE / || /#BYE / ) && do {
                print "Done with sending batch.  Waiting BYE.\n" if
$debug;
                $general_reject = 0;
                $general_error_message = "been told we're done but
weren't".
                next;
            };
            /^#WRONGANY / && do {
                print "We've been notified that one of the batch
may have been not xmited.\n(great protocol, eh?)\n" if $debug;
                next;
            };
            /^#BADQUEUE / && do {
                die "$0: Programmer error.  Data in queue is bad:
$_\n";
            };
            /^#MODOPEN / && do {
                print "Modem can't be opened\n" if $debug;
                $general_reject = 0;
                last;
            };
            /^#PACKLEN / && do {
                die "$0: Protocol error.  Should never happen:
$_\n";
            };
            /^#GOTMESSEQ / && do {
                print "MESSAGE: $_\n" if $debug;
            };
            /^#LONELY / && do {
                print "Hello?  Hello?  Either I'm getting the
silent treatment or the server is dead." if $debug;
                $general_reject = 0;
                last;
            };
        }
        close IX;
        unlink $tmpfile;

        print "DEBUG: rejecting remaining messages\n" if $debug;
        # now reject remaining messages
        foreach $index ( &ixo_listindexes( $dial) ) {
            # if general_reject then we have work to do
            if ($general_reject) {
                print "DEBUG: removing $dial:$index\n" if $debug;
                ($pin, $error, $mess, $file) = &ixo_mesg_get(
$dial, $index );
                ###### mail a warning
                if ($error + 0) {
                     $cmd = "$MAIL <"
                     . $QUEUE_DIR . $file
                     . " -s 'TPAGE_MESSAGE: unprocessed message deleted due to "
                     . $general_error_message . "' "
                     . $error;
                    print "DEBUG: About to execute $cmd\n" if
$debug;
                    system $cmd;
                }
                ###### make sure it gets deleted
                print "DEBUG: unlinking (leftover) " . $QUEUE_DIR .
$file . "\n" if $debug;
                $status = unlink $QUEUE_DIR . $file;
                print "DEBUG: unlink status=$status; $!\n" if
$debug;
                &blacklist( $file) unless $status;
            }
            print "DEBUG: deleting from memory $dial:$index\n" if
$debug;
            # delete it from the ixo list
            &ixo_mesg_delete( $dial, $index );
        }
        # at this point %ixo_data should be empty
        &ixo_end_asserts;


    # now do the next phone number
    }
}

sub ixo_end_asserts {
    # test a couple assertions
    print "DEBUG: testing assertions\n" if $debug;

    # $ixo_count{ $dial } should be zero
    die "$0: bug1\n" if $ixo_count{ $dial };

    # %ixo_data should be empty at this point
    die "$0: bug2\n" if grep(1,keys %ixo_data);    # fast key counter
}

sub ixo_mesg_append {
    local($dial, $pin, $error, $mess, $file, $count) = @_;
    print "APPEND: dial=$dial pin=$pin error=$error file=$file mess=$mess\n" if
$debug;
    $count = 0 + $ixo_count{ $dial }++;
    $ixo_data{ "$dial:$count" } = "$pin\n$error\n$mess\n$file";
    print "APPEND: data=", $ixo_data{ "$dial:$count" }, "\n" if $debug;
}

sub ixo_mesg_get {
    local($dial, $index) = @_;
    local($pin, $error, $mess, $file, @list);
    print "GET: dial=$dial index=$index\n" if $debug;
    @list = split( '\n', $ixo_data{ "$dial:$index" } );
    ($pin, $error, $mess, $file) = @list;
    print "GET: pin=$pin error=$error file=$file mess=$mess\n" if $debug;
    @list;
}

sub ixo_mesg_delete {
    local($dial, $index) = @_;
    print "DELETE: dial=$dial, index=$index\n" if $debug;
    delete $ixo_data{ "$dial:$index" };
    $ixo_count{ $dial }--;
}

sub ixo_listindexes {
    local($dial) = @_;

    # gather and sort the second field
    sort grep( s/^$dial:(.+)/$1/, keys %ixo_data );
}

sub ixo_listphones {
    local(@list);
    local($l) = undef;

    # gather and sort the first field.
    @list = sort grep( s/^(.+):.+$/$1/, keys %ixo_data );
    # uniq them
    @list = grep (!($_ eq $l || ($l = $_, 0)), @list );
    # return them
    @list;
}