home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume30 / mserv-3.0 / part02 / dorequest.pl < prev    next >
Encoding:
Perl Script  |  1992-06-19  |  8.3 KB  |  334 lines
  1. #!/usr/local/bin/perl
  2. # dorequest.pl -- 
  3. # SCCS Status     : @(#)@ dorequest    3.17
  4. # Author          : Johan Vromans
  5. # Created On      : ***
  6. # Last Modified By: Johan Vromans
  7. # Last Modified On: Sat Jun  6 21:11:24 1992
  8. # Update Count    : 135
  9. # Status          : Going steady
  10.  
  11. # Usage: dorequest [options] -- to run the queue
  12. #
  13. #     dorequest [options] address file [ encoding [ limit [ list ] ] ]
  14. #        -- to send a file 'by hand'.
  15. #
  16. #   address : where to send the information to.
  17. #          If left empty, no splitting is done, and the result
  18. #          is written to stdout.
  19. #
  20. #   file    : the file to send.
  21. #
  22. #   encoding: how to encode it: U (uuencode), B (btoa), D (Dumas uue)
  23. #          or A (plain).
  24. #             Default is btoa.
  25. #
  26. #   limit   : how many bytes per transmission.
  27. #             Default is 32768
  28. #
  29. #   parts   : comma-separated list of part numbers.
  30. #             When used, only these parts are sent.
  31. #
  32. $my_name = "dorequest";
  33. $my_version = "3.17";
  34. #
  35. ################ Common stuff ################
  36.  
  37. $libdir = $ENV{"MSERVLIB"} || "/usr/local/lib/mserv";
  38. unshift (@INC, $libdir);
  39. require "mserv_common.pl";
  40.  
  41. ################ Options handling ################
  42.  
  43. &options if @ARGV > 0 && $ARGV[0] =~ /^-+[^-]+/;
  44. undef $mailer_delay if $opt_debug;
  45.  
  46. ################ Setting up ################
  47.  
  48. if ( @ARGV > 0 ) {
  49.     &usage unless @ARGV > 1;
  50.     local ($rcpt, $address, $request, $file, $encoding, $limit, $parts);
  51.     ($rcpt, $file, $encoding, $limit, $parts) = @ARGV;
  52.     $request = $file;
  53.     $address = $rcpt;
  54.     require "$libdir/dr_mail.pl";
  55.     &mail_request ($rcpt, $address, $request, $file, $encoding, $limit, $parts);
  56. }
  57. else {
  58.     &synchronize;
  59.     &seize_queue;
  60.     while ( @queue > 0 ) {
  61.     local ($current_queue_entry) = &shift_queue;
  62.     local (@arg) = split (/[ \t\n]/, $current_queue_entry);
  63.     $current_queue_entry = join (" ", @arg);
  64.     local ($cmd) = shift (@arg);
  65.  
  66.     if ( $cmd eq "M" ) {
  67.         require "$libdir/dr_mail.pl";
  68.         eval { &mail_request (@arg); };
  69.     }
  70.     elsif ( $cmd eq "U" ) {
  71.         require "$libdir/dr_uucp.pl";
  72.         eval { &uucp_request (@arg); };
  73.     }
  74.     elsif ( $cmd eq "MP" ) {
  75.         require "$libdir/dr_pack.pl";
  76.         eval { &pack_mail_request (@arg); };
  77.     }
  78.     elsif ( $cmd eq "UP" ) {
  79.         require "$libdir/dr_pack.pl";
  80.         eval { &pack_uucp_request (@arg); };
  81.     }
  82.     else {
  83.         # This is fatal!
  84.         &die ("Illegal request in queue: $cmd @arg");
  85.     }
  86.     }
  87.     # Get rid of queue backup file.
  88.     unlink ("$queue~");
  89. }
  90.  
  91. exit (0);
  92.  
  93. ################ Subroutines ################
  94.  
  95. sub synchronize {
  96.  
  97.     # NOTE: It is very important to prevent multiple copies
  98.     #        of this program to run at the same time!
  99.  
  100.     # Proceed at your own risk here...
  101.     return unless defined $lockfile;
  102.  
  103.     # Create lockfile if it does not exists.
  104.     if ( ! -e $lockfile ) {
  105.     open (LF, ">$lockfile");
  106.     close (LF);
  107.     }
  108.  
  109.     # Open it, and get exclusive access.
  110.     open (LF, "+<$lockfile")
  111.     || &die ("Cannot gain lock [$!]");
  112.     local ($ret) = &locking (*LF, 0);
  113.     # Exit gracefully if some other invocation has the lock.
  114.     exit (0) if $ret == 0;
  115.     &die ("Cannot lock lockfile [$!]") unless $ret == 1;
  116.  
  117.     # We keep it locked until process termination.
  118. }
  119.  
  120. sub seize_queue {
  121.  
  122.     local ($queuecnt);
  123.  
  124.     # First, check the queue backup. This file can exists only
  125.     # if a previous run failed to terminate normally.
  126.     if (open (QUEUE, "$queue~")) {
  127.     @queue = <QUEUE>;    # Slurp.
  128.     close (QUEUE);
  129.     unlink ("$queue~")
  130.         || &die ("Cannot unlink queue~ [$!]");
  131.     $queuecnt = @queue;
  132.     print STDERR ("Got $queuecnt entries from $queue~\n")
  133.         if $opt_debug;
  134.     }
  135.     else {
  136.     @queue = ();
  137.     $queuecnt = 0;
  138.     }
  139.  
  140.     # Now check the current queue. We use exclusive access to make
  141.     # sure no other process is updating it.
  142.     # Again, proceed at your own risk if you're not using locks.
  143.     if (open (QUEUE, "+<$queue" )) {
  144.     # We cannot use rename queue -> queue~, since some other process
  145.     # may already be waiting for the queue to become free.
  146.     # Therefore slurp + truncate it.
  147.     if ( &locking (*QUEUE, 1) ) {
  148.         push (@queue, <QUEUE>); # Slurp.
  149.         truncate ($queue, 0)
  150.         || &die ("Cannot truncate queue [$!]");
  151.         close (QUEUE);
  152.     }
  153.     else {
  154.         &die ("Cannot seize queue [$!]");
  155.     }
  156.     print STDERR ("Got ",  @queue-$queuecnt, " entries from $queue\n")
  157.         if $opt_debug;
  158.     }
  159.     # 'No queue' is a normal situation....
  160. }
  161.  
  162. sub shift_queue {
  163.     # Sync the memory copy of the queue to disk (in the queue backup
  164.     # file), and extract the first entry of it.
  165.  
  166.     open (QUEUE, ">$queue~")
  167.     || &die ("Cannot sync queue [$!]");
  168.     print QUEUE @queue;        # Blurb.
  169.     close (QUEUE);
  170.  
  171.     # Get entry from queue and return it.
  172.     shift (@queue);
  173. }
  174.  
  175. sub check_file {
  176.     local ($file, $dir) = @_;
  177.  
  178.     # Check if a given file still exists. Non-existent files are
  179.     # trapped anyway, but this gives a better error message.
  180.  
  181.     return 1 if -r $file && ( $dir ? ( -d _ && -x _ ) : -f _ );
  182.     &die (($dir ? "Directory" : "File") . 
  183.       " \"$file\" is no longer available");
  184. }
  185.  
  186. ################ subroutines ################
  187.  
  188. sub fnsplit {
  189.     local ($file) = @_;
  190.     # Normalize $file -> ($dir, $basename)
  191.     local (@path) = split (/\/+/, $file);
  192.     (join ("/", @path[0..$#path-1]), $path[$#path]);
  193. }
  194.  
  195. sub system {
  196.     local ($cmd) = (@_);
  197.     local ($ret);
  198.     local ($opt_nolog) = 0;
  199.     print STDERR ("+ $cmd\n") if $opt_trace;
  200.     $ret = system ($cmd);
  201.     &die (sprintf ("Return 0x%x from \"$cmd\"", $ret))
  202.     unless $ret == 0;
  203.     $ret;
  204. }
  205.  
  206. sub symlink {
  207.     local ($old, $new) = @_;
  208.     print STDERR ("+ symlink $old $new\n") if $opt_trace;
  209.     symlink ($old, $new)
  210.     || &die ("Cannot symlink $old to $new [$!]\n");
  211. }
  212.  
  213. sub die {
  214.     local ($msg) = (@_);
  215.     local ($opt_nolog) = 0;    # Will force logging
  216.     local ($opt_debug) = 1;    # Will force msg to STDERR
  217.     &writelog ("F $msg");
  218.     if ( defined $current_queue_entry ) {
  219.     &writelog ("Q $current_queue_entry");
  220.     &feedback ($current_queue_entry, $msg);
  221.     }
  222.     die ("Aborted\n");
  223. }
  224.  
  225. sub writelog {
  226.  
  227.     # Write message to logfile, if possible, Otherwise use STDERR.
  228.  
  229.     local (@tm) = localtime (time);
  230.     local ($msg) = sprintf ("%02d%02d%02d %02d:%02d %s\n", 
  231.                 $tm[5], $tm[4]+1, $tm[3], $tm[2], $tm[1], $_[0]);
  232.  
  233.     if ( !$opt_nolog && defined $logfile && ( -w $logfile ) && 
  234.     open (LOG, ">>" . $logfile) ) {
  235.     if ( &locking (*LOG, 1) ) {
  236.         seek (LOG, 0, 2);
  237.         print LOG $msg;
  238.         close LOG;
  239.         return unless $opt_debug;
  240.     }
  241.     }
  242.  
  243.     print STDERR $msg;
  244. }
  245.  
  246. sub feedback {
  247.     local ($q, $msg) = @_;
  248.  
  249.     # Try to send a message to the requestor indicating
  250.     # something went wrong.
  251.  
  252.     local ($type, $rcpt, @q) = split (/ /, $q);
  253.     local ($file, $req, $method);
  254.     if ( $type =~ /^U/ ) {
  255.     ($req, $file) = @q[2,3];
  256.     $method = "via UUCP to \"$q[0]\"";
  257.     }
  258.     else {
  259.     ($req, $file) = @q[1,2];
  260.     $method = "via email to \"$q[0]\"";
  261.     }
  262.  
  263.     local ($cmd) = "$sendmail '" . $rcpt . "'";
  264.  
  265.     print STDERR ("+ |", $cmd, "\n") if $opt_trace;
  266.  
  267.     return unless open (MAIL, "|" . $cmd);
  268.     print MAIL <<EOD;
  269. To: $rcpt
  270. Subject: Mail Server error
  271. X-Server: $my_package [$my_name $my_version]
  272. X-Oops: I am sorry for the inconvenience
  273.  
  274. Dear user,
  275.  
  276. EOD
  277.     $message = "A mail server error has occurred while trying to transfer ".
  278.     "\"$file\" $method in response to your request for \"$req\".";
  279.     select (MAIL); 
  280.     $~ = "fill";
  281.     write;
  282.     print MAIL <<EOD;
  283.  
  284. The error message was:
  285.    $msg
  286.  
  287. You may wish to resubmit your request, or consult the mail server 
  288. maintainer. 
  289. (He knows about the error already, no need to inform him.)
  290.  
  291. EOD
  292.     close (MAIL);
  293.     select (STDOUT);
  294. }
  295.  
  296. format fill =
  297. ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~
  298. $message
  299. .
  300.  
  301. sub options {
  302.     require "newgetopt.pl";
  303.     if ( !&NGetOpt ("nomail", "keep=s",
  304.             "debug", "trace", "help")
  305.     || defined $opt_help ) {
  306.     &usage;
  307.     }
  308.     $opt_trace |= $opt_debug;
  309. }
  310.  
  311. sub usage {
  312.     print STDERR <<EndOfUsage;
  313. $my_package [$my_name $my_version]
  314.  
  315. Usage: $my_name [options] [address file [coding [size [parts]]]]
  316.  
  317. Options:
  318.     -nomail    do not deliver
  319.     -keep XXX    keep temporary files, using prefix XXX (for debugging)
  320.     -help    this message
  321.     -trace    show commands
  322.     -debug    for debugging
  323.  
  324. address        destination for this request.
  325.         If empty: do not split and write to STDOUT.
  326. file        the file to send.
  327. coding        encoding (Btoa, Uuencode, Dumas uue or Plain, def Btoa).
  328. size        max. size per chunk, def 32K.
  329. parts        comma-separated list of parts to re-send.
  330.         If omitted: send all parts
  331. EndOfUsage
  332.     exit (!defined $opt_help);
  333. }
  334.