home *** CD-ROM | disk | FTP | other *** search
/ Telecom / 1996-04-telecom-walnutcreek.iso / technical / ixo.program.scripts / tpaged.pl < prev   
Perl Script  |  1993-02-14  |  12KB  |  420 lines
  1. #! /usr/local/bin/perl4.019
  2.  
  3. # tpaged -- back-end to tpage system.
  4. #   by Tom Limoncelli, tal@warren.mentorg.com
  5. #   Copyright (c) 1992, Tom Limoncelli
  6. #   The sources can be freely copied for non-commercial use only
  7. #   and only if they are unmodified.
  8.  
  9. # Version 2.0 -- See file HISTORY for details. 
  10.  
  11.  
  12. ####################################################################
  13. #
  14. # Parameters that the user can set:
  15. #
  16. ####################################################################
  17.  
  18. $debug = 0;
  19. # $| = 1; open( STDOUT, ">/home/adm/lib/tpage/log.txt" ) if $debug; $| = 1;
  20. $QUEUE_DIR = '/home/adm/lib/tpage/pqueue/';        # same as in tpage.pl
  21. #$IXOCICO = '/home/tal/work/beep2/ixocico';        # where is ixocico?
  22. $IXOCICO  = '/home/adm/lib/tpage/ixocico';        # where is ixocico?
  23. $MAIL = '/usr/ucb/mail';                        # which  
  24. mail to use?
  25.      # Recommended mailers:  SunOS & BSD's:  /usr/ucb/mail, AT&T Unix's xmail
  26.      # Not recommended mailers:  /bin/mail
  27.  
  28. # list of devices to rotate through.
  29. @DEVICES = ( "/dev/ttyz4" );    # currently they are all spoken
  30. # to at the same speed and same parameters.  Some day I'll set up
  31. # a modemtab system, but I don't think more than one modem is
  32. # really needed for this system.
  33.  
  34. # amount of time to sleep between scans of the queue
  35. $SLEEP_TIME =  150;    # 2.5 minutes
  36. $SLEEP_TIME =  10 if $debug;    # smaller when I'm debugging
  37. # Small amount of time to wait between finding anything in the queue
  38. # and doing a real scan of the queue.
  39. $MULT_SLEEP_TIME =  10;
  40.  
  41. ####################################################################
  42. # QUEUE FILES FORMAT:
  43. #
  44. # Files in the queue have the name of the format in the
  45. # first line.  Currently there is only one format and it
  46. # is named "A".  The first line marks it as the "A" format.
  47. # a subroutine called read_format_A reads this format.  Other
  48. # formats can be written (see comments by read_format_A)
  49. #
  50. # The "A" format:
  51. # line  contents
  52. #    1: A\n
  53. #    2: number to dial\n
  54. #    3: pin\n
  55. #    4: entire message\n
  56. #    5: X\n
  57.  
  58. # read_format_*  -- modules that read various data formats.
  59. #                   Currently implemented: The "A" format.
  60. # do_proto_*     -- modules that do various beeper protocols.
  61. #                   Currently implmented: the ixo protocol.
  62. #                   Future protocols:     numeric-only pagers.
  63.  
  64. ####################################################################
  65. # Here's the actual program
  66.  
  67. # define some globals
  68.  
  69. local(%protocols);
  70.  
  71. while (1) {
  72.     local ($first, @allfiles, @anyfiles);
  73.  
  74.     # We could scoop up all the files and process them, but chances
  75.     # are if one file is found, more are on the way.  So, instead
  76.     # we scoop, if any are found we sleep 5 seconds and re-scoop.
  77.  
  78.     # wait for any files to appear.
  79.     while (1) {
  80.         @anyfiles = &scan_queue;
  81.         print "DEBUG: anyfiles= ", join(' ', @anyfiles), "\n" if $debug;
  82.  
  83.         if ($#anyfiles!=-1) {    # files?  take a rest and then process.
  84.             sleep $MULT_SLEEP_TIME unless $debug;
  85.             last;
  86.         } else {            # no files?  hibernate.
  87.             sleep $SLEEP_TIME;
  88.             next;
  89.         }
  90.     }
  91.  
  92.     # re-get the files in the queue
  93.     @allfiles = &scan_queue;
  94.     print "DEBUG: allfiles= ", join(' ', @allfiles), "\n" if $debug;
  95.  
  96.     # get all the data out of the queue'd files.
  97.     foreach $file (@allfiles) {
  98.         print "DEBUG: Doing $file\n" if $debug;
  99.         open(DATA, "<" . $QUEUE_DIR . $file) || print "Can't open $file:  
  100. $!";
  101.         chop( $first = <DATA> );
  102. print "DEBUG: first=$first\n" if $debug;
  103.         eval "do read_format_$first()";
  104.     }
  105.  
  106.     # process all the extracted data (do_protocol_* should delete the files)
  107.     foreach $proto (keys %protocols) {
  108.         eval "do do_protocol_$proto()";
  109.         delete $protocols{ $proto };
  110.         sleep $SLEEP_TIME;
  111.     }
  112. }
  113.  
  114. # scan the queue for entries (avoid "blacklisted" files)
  115. sub scan_queue {
  116.     local(@files);
  117.     # scan the directory for "P files (pager files)
  118.     opendir(QDIR, $QUEUE_DIR) || die "$0: Can't open $QUEUE_DIR: $!";
  119.     @files = grep( /^P/, readdir(QDIR) );
  120.     closedir(QDIR);
  121.     print "DEBUG: filescan= ", join(' ', @files), "\n" if $debug;
  122.     # remove the blacklisted files
  123.     @files = grep( ! defined $blacklist_data{ $_ }, @files);
  124.     print "DEBUG: goodfiles= ", join(' ', @files), "\n" if $debug;
  125.     # return the files
  126.     @files;
  127. }
  128.  
  129. # blacklist a file in the queue (couldn't delete it for some reason
  130. # and we don't want to repeat it)
  131. sub blacklist {
  132.     local($file) = @_;
  133.     $blacklist_data{ $file } = 1;
  134. }
  135.  
  136. # Each read_format_ must:
  137. #  read from <DATA> and then close(DATA).
  138. #  %protocols{ protocol name } = 1 (for the protocol to use)
  139. #  and stuff the right data into the right variables for that protocol
  140. #  to use.
  141.  
  142. sub read_format_A
  143. {
  144.     local($dial,$pin,$error,$mess,$X);    # $file is by sideeffect
  145.     print "DEBUG: reading format A\n" if $debug;
  146.     chop( $dial = <DATA> );
  147.     chop( $pin = <DATA> ); 
  148.  
  149.     chop( $error = <DATA> );
  150.     chop( $mess = <DATA> );
  151.     chop( $X = <DATA> );
  152.  
  153.     return if $X ne "X";  # file isn't in correct format or isn't done.
  154.     return if $dial eq "";
  155.     return if $pin eq "";
  156.     return if $mess eq "";
  157.  
  158.     $protocols{ 'ixo' } = 1;
  159.     &ixo_mesg_append( $dial, $pin, $error, $mess, $file );
  160. }
  161.  
  162. # Each do_protocol_ must:
  163. #  delete files out of the queue that are successful.
  164. #  delete files out of the queue that are aged.
  165. #  clean up so that the routine can be called again.
  166.  
  167. sub do_protocol_ixo {
  168.     print "DEBUG: doing protocol IXO\n" if $debug;
  169.     local($pin, $error, $mess, $file, $cmd, $status, $index);
  170.     local($general_reject, $general_error_message);
  171.     # build the temp file and the command line
  172.     local($tmpfile) = "/tmp/tpaged.$$";
  173.     foreach $dial ( &ixo_listphones ) {
  174.         print "DEBUG: Number to dial is $dial\n" if $debug;
  175.  
  176.         # fill the data file
  177.         open(IX, ">$tmpfile" ) || die "$0: Can't create $tmpfile: $!";
  178.         foreach $index ( &ixo_listindexes( $dial ) ) {
  179.             ($pin, $error, $mess, $file) = &ixo_mesg_get( $dial, $index  
  180. );
  181.             # put it in the file for ixocico to use
  182.             print IX "$pin\n$mess\n";
  183.         }
  184.         close IX;
  185.  
  186.         print "DEBUG: messages to send", &ixo_listindexes( $dial ), "\n" if  
  187. $debug;
  188.  
  189.         $general_reject = 1;    # when done, 1=cancel remaining; 0=retry  
  190. remaining
  191.         $general_error_message = "SHOULD NOT HAPPEN";    # if all messages  
  192. are cancelled
  193.  
  194.         $cmd = $IXOCICO . " <" . $tmpfile . " "
  195.             . push(@DEVICES, shift @DEVICES) . " " . $dial;
  196.         print "DEBUG: About to execute: $cmd\n" if $debug;
  197.         open(IX, $cmd . "|") || die "$0: Can't execute ixocico: $!";
  198.  
  199.         while (<IX>) {
  200.             print if $debug;
  201.             next unless /^#/;
  202.  
  203.             print unless $debug;
  204.  
  205.             /^#WRONGARGS / &&
  206.                 die("$0: Major program bug: $!");
  207.             /^#NOCONN / && do {
  208.                 printf("$0: Nobody answered the phone!\n") if  
  209. $debug;
  210.                 $general_reject = 0;
  211.                 last;
  212.             };
  213.             /^#UNKNOWNPROTO / && do {
  214.                 print "$0: Uhhh, are you sure that's a pager  
  215. service?\n" if $debug;
  216.                 $general_reject = 1;
  217.                 $general_error_message = "other end using different  
  218. protocol";
  219.                 last;
  220.             };
  221.             /^\#MESOK (\d) / && do {
  222.                 $index = $1;
  223.                 print "DEBUG: message $index done.\n" if $debug;
  224.  
  225.                 ($pin, $error, $mess, $file) = &ixo_mesg_get(  
  226. $dial, $index );
  227.                 print "DEBUG: ERROR=$error; FILE=$file\n" if  
  228. $debug;
  229.  
  230.                 print "DEBUG: unlinking " . $QUEUE_DIR . $file .  
  231. "\n" if $debug;
  232.                 $status = unlink $QUEUE_DIR . $file;
  233.                 print "DEBUG: unlink status=$status; $!\n" if  
  234. $debug;
  235.                 &blacklist( $file) unless $status;
  236.  
  237.                 # remove from queue
  238.                 &ixo_mesg_delete( $dial, $index );
  239.             };
  240.             /^#MESREJECT (\d) / && do {        # very similar to  
  241. #MESOK
  242.                 $index = $1;
  243.                 print "DEBUG: message $index rejected.\n" if  
  244. $debug;
  245.  
  246.                 ($pin, $error, $mess, $file) = &ixo_mesg_get(  
  247. $dial, $index );
  248.                 print "DEBUG: ERROR=$error; FILE=$file\n" if  
  249. $debug;
  250.  
  251.                 # notify anyone that wants to know about failures
  252.                 if ($error + 0) {
  253.                      $cmd = "$MAIL <"
  254.                      . $QUEUE_DIR . $file
  255.                      . " -s 'TPAGE_MESSAGE: request rejected by service' "
  256.                      . $error;
  257.                     print "DEBUG: About to execute $cmd\n" if  
  258. $debug;
  259.                     system $cmd;
  260.                 }
  261.  
  262.                 print "DEBUG: unlinking " . $QUEUE_DIR . $file .  
  263. "\n" if $debug;
  264.                 $status = unlink $QUEUE_DIR . $file;
  265.                 print "DEBUG: unlink status=$status; $!\n" if  
  266. $debug;
  267.                 &blacklist( $file) unless $status;
  268.  
  269.                 # remove from queue
  270.                 &ixo_mesg_delete( $dial, $index );
  271.             };
  272.             /^#FORDIS / && do {
  273.                 print "Forced disconnect from server.\n" if $debug;
  274.                 $general_reject = 1;
  275.                 $general_error_message = "other end requesting  
  276. disconnect";
  277.                 last;
  278.             };
  279.             /^#PROTERR / && do {
  280.                 print "Server not following protocol.\n" if $debug;
  281.                 $general_reject = 1;
  282.                 $general_error_message = "other end having a  
  283. protocol error";
  284.                 last;
  285.             };
  286.             ( /^#DONE / || /#BYE / ) && do {
  287.                 print "Done with sending batch.  Waiting BYE.\n" if  
  288. $debug;
  289.                 $general_reject = 0;
  290.                 $general_error_message = "been told we're done but  
  291. weren't".
  292.                 next;
  293.             };
  294.             /^#WRONGANY / && do {
  295.                 print "We've been notified that one of the batch  
  296. may have been not xmited.\n(great protocol, eh?)\n" if $debug;
  297.                 next;
  298.             };
  299.             /^#BADQUEUE / && do {
  300.                 die "$0: Programmer error.  Data in queue is bad:  
  301. $_\n";
  302.             };
  303.             /^#MODOPEN / && do {
  304.                 print "Modem can't be opened\n" if $debug;
  305.                 $general_reject = 0;
  306.                 last;
  307.             };
  308.             /^#PACKLEN / && do {
  309.                 die "$0: Protocol error.  Should never happen:  
  310. $_\n";
  311.             };
  312.             /^#GOTMESSEQ / && do {
  313.                 print "MESSAGE: $_\n" if $debug;
  314.             };
  315.             /^#LONELY / && do {
  316.                 print "Hello?  Hello?  Either I'm getting the  
  317. silent treatment or the server is dead." if $debug;
  318.                 $general_reject = 0;
  319.                 last;
  320.             };
  321.         }
  322.         close IX;
  323.         unlink $tmpfile;
  324.  
  325.         print "DEBUG: rejecting remaining messages\n" if $debug;
  326.         # now reject remaining messages
  327.         foreach $index ( &ixo_listindexes( $dial) ) {
  328.             # if general_reject then we have work to do
  329.             if ($general_reject) {
  330.                 print "DEBUG: removing $dial:$index\n" if $debug;
  331.                 ($pin, $error, $mess, $file) = &ixo_mesg_get(  
  332. $dial, $index );
  333.                 ###### mail a warning
  334.                 if ($error + 0) {
  335.                      $cmd = "$MAIL <"
  336.                      . $QUEUE_DIR . $file
  337.                      . " -s 'TPAGE_MESSAGE: unprocessed message deleted due to "
  338.                      . $general_error_message . "' "
  339.                      . $error;
  340.                     print "DEBUG: About to execute $cmd\n" if  
  341. $debug;
  342.                     system $cmd;
  343.                 }
  344.                 ###### make sure it gets deleted
  345.                 print "DEBUG: unlinking (leftover) " . $QUEUE_DIR .  
  346. $file . "\n" if $debug;
  347.                 $status = unlink $QUEUE_DIR . $file;
  348.                 print "DEBUG: unlink status=$status; $!\n" if  
  349. $debug;
  350.                 &blacklist( $file) unless $status;
  351.             }
  352.             print "DEBUG: deleting from memory $dial:$index\n" if  
  353. $debug;
  354.             # delete it from the ixo list
  355.             &ixo_mesg_delete( $dial, $index );
  356.         }
  357.         # at this point %ixo_data should be empty
  358.         &ixo_end_asserts;
  359.  
  360.  
  361.     # now do the next phone number
  362.     }
  363. }
  364.  
  365. sub ixo_end_asserts {
  366.     # test a couple assertions
  367.     print "DEBUG: testing assertions\n" if $debug;
  368.  
  369.     # $ixo_count{ $dial } should be zero
  370.     die "$0: bug1\n" if $ixo_count{ $dial };
  371.  
  372.     # %ixo_data should be empty at this point
  373.     die "$0: bug2\n" if grep(1,keys %ixo_data);    # fast key counter
  374. }
  375.  
  376. sub ixo_mesg_append {
  377.     local($dial, $pin, $error, $mess, $file, $count) = @_;
  378.     print "APPEND: dial=$dial pin=$pin error=$error file=$file mess=$mess\n" if  
  379. $debug;
  380.     $count = 0 + $ixo_count{ $dial }++;
  381.     $ixo_data{ "$dial:$count" } = "$pin\n$error\n$mess\n$file";
  382.     print "APPEND: data=", $ixo_data{ "$dial:$count" }, "\n" if $debug;
  383. }
  384.  
  385. sub ixo_mesg_get {
  386.     local($dial, $index) = @_;
  387.     local($pin, $error, $mess, $file, @list);
  388.     print "GET: dial=$dial index=$index\n" if $debug;
  389.     @list = split( '\n', $ixo_data{ "$dial:$index" } );
  390.     ($pin, $error, $mess, $file) = @list;
  391.     print "GET: pin=$pin error=$error file=$file mess=$mess\n" if $debug;
  392.     @list;
  393. }
  394.  
  395. sub ixo_mesg_delete {
  396.     local($dial, $index) = @_;
  397.     print "DELETE: dial=$dial, index=$index\n" if $debug;
  398.     delete $ixo_data{ "$dial:$index" };
  399.     $ixo_count{ $dial }--;
  400. }
  401.  
  402. sub ixo_listindexes {
  403.     local($dial) = @_;
  404.  
  405.     # gather and sort the second field
  406.     sort grep( s/^$dial:(.+)/$1/, keys %ixo_data );
  407. }
  408.  
  409. sub ixo_listphones {
  410.     local(@list);
  411.     local($l) = undef;
  412.  
  413.     # gather and sort the first field.
  414.     @list = sort grep( s/^(.+):.+$/$1/, keys %ixo_data );
  415.     # uniq them
  416.     @list = grep (!($_ eq $l || ($l = $_, 0)), @list );
  417.     # return them
  418.     @list;
  419. }
  420.