home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume43 / ftpmail / part02 / dq.pl < prev    next >
Perl Script  |  1994-07-07  |  25KB  |  1,082 lines
  1. #!/usr/bin/perl -s
  2. # Very simple ftpmail system
  3. # De-Queue a transfer and do it
  4. # By Lee McLoughlin <lmjm@doc.ic.ac.uk>
  5. #  You can do what you like with this except claim that you wrote it or
  6. #  give copies with changes not approved by Lee.  Neither Lee nor any other
  7. #  organisation can be held liable for any problems caused by the use or
  8. #  storage of this package.
  9. #
  10. # $Header: /a/swan/home/swan/staff/csg/lmjm/src/perl/mirror/src/ftpmail/RCS/dq.pl,v 1.24 1994/07/06 14:56:35 lmjm Exp lmjm $
  11. # $Log: dq.pl,v $
  12. # Revision 1.24  1994/07/06  14:56:35  lmjm
  13. # Added multiple dq processes.
  14. # Do test work in /usr/tmp as sun's tmpfs doesn't implement locks!
  15. # Added vvencodeing.
  16. #
  17. # Revision 1.23  1994/05/02  18:10:47  lmjm
  18. # Switched to lchat.
  19. #
  20. # Revision 1.22  1993/06/17  18:18:05  lmjm
  21. # Use new internal buffer name for ftp'ftpbuf
  22. #
  23. # Revision 1.21  1993/06/17  09:58:17  lmjm
  24. # Make sure that the target file the a command is trying to generate
  25. # doesn't already exist.
  26. # Allow for spaces in the command to run.
  27. #
  28. # Revision 1.20  1993/06/16  20:45:21  lmjm
  29. # Fixup subject in case they contain 's
  30. #
  31. # Revision 1.19  1993/06/16  20:13:27  lmjm
  32. # Don't use system so that filenames containing single quotes can be
  33. # handled correctly.
  34. #
  35. # Revision 1.18  1993/05/13  21:23:03  lmjm
  36. # Change all atob to be btoa
  37. #
  38. # Revision 1.17  1993/05/11  20:07:56  lmjm
  39. # Init right variable for btoa!
  40. #
  41. # Revision 1.16  1993/04/28  18:19:19  lmjm
  42. # From chris, corrected filename in mime message.
  43. #
  44. # Revision 1.15  1993/04/25  20:27:49  lmjm
  45. # Use own split routine to implement size paramater.
  46. #
  47. # Revision 1.14  1993/04/25  14:38:52  lmjm
  48. # Dont requeue jobs that have been tried too many times.
  49. #
  50. # Revision 1.13  1993/04/25  14:14:59  lmjm
  51. # Conform to mime rules on filenames.
  52. #
  53. # Revision 1.12  1993/04/25  13:18:01  lmjm
  54. # Moved signal handling into ftp'pl.
  55. #
  56. # Revision 1.11  1993/04/23  23:27:04  lmjm
  57. # Massive renaming for sys5.
  58. #
  59. # Revision 1.10  1993/04/23  20:03:16  lmjm
  60. # Don't use STDIN, STDOUT or STDERR.
  61. # Use own verion of library routines before any others.
  62. # Log the pid when sleeping to make it easier to kill.
  63. #
  64. # Revision 1.9  1993/04/23  17:23:37  lmjm
  65. # Renamed ftpmail-local-config.pl to ftpmail-config.pl
  66. # Made pathnames relative to $ftpmail_dir.
  67. # Moved the check_tries handle to the start of the job.
  68. #
  69. # Revision 1.8  1993/04/21  10:58:38  lmjm
  70. # Added jobid to response.
  71. #
  72. # Revision 1.7  1993/04/20  20:15:37  lmjm
  73. # Turned printing job to mail into a library routine.
  74. #
  75. # Revision 1.6  1993/04/15  18:07:14  lmjm
  76. # Scan queue in perl not by calling ls.
  77. # Added more logging.
  78. # Done inplace change the comms variable.
  79. # Dump stdout onto stderr when playing with fd's before mailing.
  80. # Don't send a completed message if job was zapped.
  81. #
  82. # Revision 1.5  1993/04/15  14:17:43  lmjm
  83. # log when quitting.
  84. # Something is adding spaces to the start of job lines - zap them for now.
  85. # Don't requeue overtried jobs.
  86. # Added some patches from  Christophe.
  87. #
  88. # Revision 1.4  1993/04/13  10:34:36  lmjm
  89. # Lots of little cleanups in logging and response messages
  90. #
  91. # Revision 1.3  1993/03/30  20:32:19  lmjm
  92. # Must have an ftpmail account whose home directory everything is in.
  93. # New -test option that uses /tmp/ftpmail-test
  94. # Simplified the parsing of the jobs.
  95. # ftpmail-dq keeps running till shutdown
  96. # Changed the mime code, now handles force better.
  97. # Moved the close( STDOUT ) to where it doesn't cause mail to fail!
  98. #
  99. # Revision 1.2  1993/03/23  21:40:10  lmjm
  100. # Fixed all those little internal problems.
  101. # Rewrote the setup routines.
  102. # Added gzip and btoa support
  103. # Added mime, multipart and all sorts of other good things based on work by
  104. #  Christophe.Wolfhugel@grasp.insa-lyon.fr
  105. #
  106.  
  107. $ftpmail = 'ftpmail';
  108.  
  109. if( $test ){
  110.     $ftpmail_dir = '/usr/tmp/ftpmail-test';
  111. }
  112. else {
  113.     # The ftpmail_dir is the home directory of ftpmail.
  114.     $ftpmail_dir = (getpwnam( $ftpmail ))[ 7 ];
  115. }
  116.  
  117. if( ! $ftpmail_dir ){
  118.     die "No home directory for ftpmail\n";
  119. }
  120.  
  121. if( ! -d $ftpmail_dir ){
  122.     die "no such directory as $ftpmail_dir\n";
  123. }
  124.  
  125. chdir( $ftpmail_dir ) || die "cannot chdir to $ftpmail_dir\n";
  126.  
  127. # All the auxillary scripts come from ftpmail's home dir.
  128. unshift( @INC, '.' );
  129.  
  130. require 'config.pl';
  131. require 'support.pl';
  132. require 'ftp.pl';
  133. require 'lchat.pl';
  134. require 'seize.pl';
  135.  
  136. # Don't leave files around writable
  137. umask( 077 );
  138.  
  139. # It is more meaningful for the user to say 1 but in here zero is
  140. # more useful.
  141. $max_dqs--;
  142.  
  143. sub handler {
  144.     local( $sig ) = @_;
  145.     local( $msg ) = "Caught a SIG$sig shutting down";
  146.     warn $msg;
  147.     &log( $msg );
  148.     &empty_slot();
  149.     exit( 0 );
  150. }
  151. $SIG{ 'PIPE' } = 'handler';
  152. # Only allow jobs to be updated.  (In case q.pl has deleted it.)
  153. $updating_only = 1;
  154.  
  155. # Mime types
  156. $partial = 1;
  157. $octets = 2;
  158. $text = 3;
  159.  
  160. # Counters for Mime multiparts;
  161. $partno = 0;
  162. $nparts = 0;
  163. # part id
  164. $id = '';
  165.  
  166.  
  167. # Use when multi dq's are allowed to show which is which.
  168. if( $slot ){
  169.     $slot = shift;
  170. }
  171. else {
  172.     $slot = 0;
  173. }
  174.  
  175. if( $slot ){
  176.     $tmpdir .= $slot;
  177.     # Only create the additional tmpdirs the base one
  178.     # should have been created on installation.
  179.     if( ! -d $tmpdir ){
  180.         mkdir( $tmpdir, 0700 );
  181.     }
  182.     # last_started is checked to see if it is time to
  183.     # try spawning new dq's.  This delays the check in all the
  184.     # secondary dq's till after the main dq has started up the
  185.     # initial batch.
  186.     $last_started = time;
  187. }
  188. $incoming = "$tmpdir/$incoming";
  189. $xferlog = "$tmpdir/$xferlog";
  190. &log( "tmpdir $tmpdir, incoming $incoming, xferlog $xferlog" ) if $verbose;
  191.  
  192. &fill_slot();
  193.  
  194. &log( "starting" );
  195. &trap_signals();
  196. &ftp'set_timeout( 120 );    # Use long timeouts
  197. &ftp'set_signals( "main'log" );    # Beware of SIGPIPES
  198. &ftp'debug( 1 );
  199. while( ! -f $ftpmail_scan_end ){
  200.     &start_dqs();
  201.     &scan_q();
  202.     &process_qfiles();
  203.     if( $between_runs_pause && ! -f $ftpmail_scan_end ){
  204.         &log( "nothing to do - sleeping pid=$$" ) if $verbose;
  205.         sleep( $between_runs_pause );
  206.     }
  207. }
  208. &log( "found $ftpmail_scan_end so quiting" );
  209.  
  210. &empty_slot();
  211. exit( 0 );
  212.  
  213. sub process_qfiles
  214. {
  215.     local( $qf );
  216.     $processed = 0;
  217.     foreach $qf ( @qfiles ){
  218.         if( $processed > $max_per_scan || -f $ftpmail_scan_end ){
  219.             last;
  220.         }
  221.         $qfile = "$quedir/$qf";
  222.         next if ! &lock_qf();
  223.         &process_qfile();
  224.         &unlock_qf();
  225.     }
  226. }
  227.  
  228. sub process_qfile
  229. {
  230.     # Only give up if a serious error occurs - otherwise retry.
  231.     $give_up = 0;
  232.  
  233.     # Force encoding?
  234.     $force = 0;
  235.  
  236.     # filters
  237.     $compress_it = 0;
  238.     $gzip_it = 0;
  239.     $uuencode_it = 0;
  240.     $btoa_it = 0;
  241.     $mime_it = 0;
  242.     $vvencode_it = 0;
  243.  
  244.     # Set the max file size from the local config file.
  245.     $max_file_size = $def_max_size;
  246.  
  247.     # When running in non-interactive mode this is the
  248.     # jobs to do.
  249.     @mailback = ();    # an elem is true if @comms elem needs to be mailed
  250.     @filename = ();    # filename to report in messages
  251.     @filters = ();    # filters to apply to file.
  252.  
  253.     # input lines
  254.     # Strip out the informational lines and stick the rest into @comms
  255.     @comms = ();
  256.     seek( qfile, 0, 0 );
  257.     while( <qfile> ){
  258.         chop;
  259.         # This s/.. is to get around an old bug - shouldn't be needed now
  260.         s/^\s*//;
  261.         last if /^$/;
  262.         if( /^reply-to (.+)$/ ){
  263.             $reply_to = $1;
  264.             next;
  265.         }
  266.         elsif( /^tries (\d+)( (\d+))?$/ ){
  267.             $tries = $1;
  268.             $whenretry = $2;
  269.             next;
  270.         }
  271.         elsif( /^open (\S+)/ ){
  272.             # remember the site.
  273.             $site = $1;
  274.         }
  275.         push( @comms, $_ );
  276.     }
  277.  
  278.     # TODO
  279.     # To avoid flooding a site.
  280. #    if( ! &lock_site( $site ) ){
  281. #        return;
  282. #    }
  283.     
  284.     if( ! &check_tries() ){
  285.         # Too many - job has been dequeued
  286.         return;
  287.     }
  288.     
  289.     if( $whenretry > time() ){
  290.         &log( "too early to process $qfile" ) if $verbose;
  291.         return;
  292.     }
  293.  
  294.     &log( "starting job: $qfile" );
  295.     $processed++;
  296.     
  297.     $tries++;
  298.     # On failure don't retry the job for progressively
  299.     # longer times.
  300.     $whenretry = time() + $retry_pause;
  301.     &update_entry();
  302.     
  303.     # Send all ftp errors into xferlog
  304.     open( out, ">$xferlog" ) || &fatal( "Cannot create $xferlog" );
  305.     $ftp'showfd = "main'out";
  306.     
  307.     $mailing_back = $immediate;
  308.     
  309.     &ftp_to_site();
  310.     close( out );
  311.  
  312.     if( ! $immediate ){
  313.         # mail out all the completed get/dir/ls
  314.         $mailing_back = 1;
  315.         for( $cmdno = 0; $cmdno <= $#comms; $cmdno++ ){
  316.             if( $mailback[ $cmdno ] ){
  317.                 &mail_back();
  318.             }
  319.         }
  320.     }
  321.     &finish_entry();
  322.     
  323.     unlink( $xferlog );
  324. }
  325.  
  326. sub ftp_to_site
  327. {
  328.     local( $mode ) = undef;
  329.     local( $open ) = undef;
  330.     
  331.     # All done?
  332.     $job_done = 0;
  333.  
  334.     # Make sure connection is shut down.
  335.     &chat'close();
  336.  
  337.     &log( "$qfile: tries=$tries [$max_tries] reply_to=$reply_to" );
  338.     # process commands
  339.     $site = $user = $pass = '';
  340.     for( $cmdno = 0; $cmdno <= $#comms; $cmdno++ ){
  341.         $_ = $comm = $comms[ $cmdno ];
  342.         if( /^DONE|FAILED/ ){
  343.             &log( "skipping: $_" );
  344.         }
  345.         elsif( /^open (.+)$/i ){
  346.             $site = $1;
  347.         }
  348.         elsif( /^user (.+)$/i ){
  349.             $user = $1;
  350.         }
  351.         elsif( /^pass (.+)$/i ){
  352.             $pass = $1;
  353.             
  354.             &log( "connecting to $site" );
  355.             $res = &ftp'open( $site, $ftp_port, $retry_call, $retry_attempts );
  356.             if( $res != 1 ){
  357.                 &pralog( "Failed to connect" );
  358.                 last;
  359.             }
  360.             &log( "logging in as $user $pass" );
  361.             if( ! &ftp'login( $user, $pass ) ){
  362.                 &pralog( "Failed to login" );
  363.                 &ftp'close();
  364.                 last;
  365.             }
  366.             $pwd = &ftp'pwd();
  367.             &log( "pwd=$pwd" );
  368.             
  369.             # Default type is binary
  370.             if( ! defined( $mode ) ){
  371.                 $mode = 'I';
  372.             }
  373.             if( ! &ftp'type( $mode ) ){
  374.                 &pralog( "Failed to set type to binary" );
  375.             }
  376.         }
  377.         elsif( /^mode (.+)$/i ){
  378.             $mode = $1 eq 'binary' ? 'I' : 'A';
  379.             if( defined( $open ) ){
  380.                 if( ! &ftp'type( $mode ) ){
  381.                     &pralog( "Failed to set type to $1" );
  382.                 }
  383.             }
  384.         }
  385.         elsif( /^cd (.+)$/i ){
  386.             $dir = $1;
  387.             &log( "cwd $dir" );
  388.             if( ! &ftp'cwd( $dir ) ){
  389.                 &pralog( "Failed to change to remote directory: $dir" );
  390.                 $give_up = 1;
  391.                 last;
  392.             }
  393.             $pwd = &ftp'pwd();
  394.             &log( "pwd=$pwd" );
  395.         }
  396.         elsif( /^(compress|gzip)( no)?$/i ){
  397.             eval "\$$1_it = 1";
  398.             &log( "$1_it set" ) if $verbose;
  399.         }
  400.         elsif( /^(force )?(compress|gzip|uuencode|btoa|mime)( no)?$/i ){
  401.             $force = $1 eq 'force ';
  402.             &log( "force set" ) if $force && $verbose;
  403.             eval "\$$2_it = 1";
  404.             &log( "$2_it set" ) if $verbose;
  405.         }
  406.         elsif( /^size (\d+)/i ){
  407.             $max_file_size = $1;
  408.         }
  409.         elsif( /^(ls|dir) (.*)/i ){
  410.             $path = $2;
  411.             local( $old_mode );
  412.             
  413.             &log( $comm );
  414.             if( $mode ne 'A' ){
  415.                 if( &ftp'type( 'A' ) ){
  416.                     $old_mode = $mode;
  417.                 }
  418.                 else {
  419.                     &pralog( "Cannot set type to ascii for dir listing, trying to carry on" );
  420.                 }
  421.             }
  422.             
  423.             if( ! &ftp'dir_open( $path ) ){
  424.                 &pralog( "Cannot get remote directory listing because: $ftp'response" );
  425.                 $give_up = 1;
  426.             }
  427.             
  428.             local( $in ) = "$incoming.$cmdno";
  429.             open( IN, ">$in" ) || &fail( "cannot create $in" );
  430.  
  431.             # Suck back dir listing output into a temp file
  432.             while( ($len = &ftp'read()) > 0 ){
  433.                 $bytes += $len;
  434.                 if( $mode eq 'A' ){
  435.                     $ftp'ftpbuf =~ s/\r//g;
  436.                 }
  437.                 print IN $ftp'ftpbuf;
  438.             }
  439.             close( IN );
  440.  
  441.             &ftp'dir_close();
  442.             if( defined( $old_mode ) && ! &ftp'type( $old_mode ) ){
  443.                 &pralog( "Cannot reset type after dir" );
  444.             }
  445.  
  446.             if( $len < 0 ){
  447.                 &pralog( "\nTimed out reading data" );
  448.                 last;
  449.             }
  450.  
  451.             $filename = "directory-listing";
  452.             &mail_back();
  453.         }
  454.         elsif( /^get (.+)/i ){
  455.             local( $in ) = "$incoming.$cmdno";
  456.             
  457.             $filename = $1;
  458.  
  459.             &log( $comm );
  460.             if( ! &ftp'get( $filename, $in, 0 ) ){
  461.                 $comms[ $cmdno ] = "FAILED $comms[ $cmdno ]";
  462.                 &pralog( "failed to get $filename" );
  463.             }
  464.             else {
  465.                 &mail_back();
  466.             }
  467.         }
  468.         else {
  469.             &log( "Internal error: found command: $_" );
  470.         }
  471.         
  472.         if( $cmdno == $#comms ){
  473.             $job_done = 1;
  474.         }
  475.     }
  476.     
  477.     &log( "job done" );
  478.     &ftp'quit();
  479. }
  480.  
  481. # Check out the tries counter.  If too many then dequeue job.
  482. # Return 1 if ok.
  483. sub check_tries
  484. {
  485.     # Tries counts from 0
  486.     if( $tries < $max_tries ){
  487.         return 1;
  488.     }
  489.     
  490.     unlink( $qfile );
  491.     &log( "Job $qfile failed and dequeued" );
  492.     &respond( "failed", "Your job failed to be fully processed after too many tries ($tries)" );
  493.     $job_done = 1;
  494.     return 0;
  495. }
  496.  
  497.  
  498. # This should check error status
  499. sub mail_back
  500. {
  501.     if( ! $mailing_back ){
  502.         # Not mailing stuff back yet, just remember it.
  503.         $mailback[ $cmdno ] = 1;
  504.         $filename[ $cmdno ] = $filename;
  505.         $pwd[ $cmdno ] = $pwd;
  506.         local( $f ) = '';
  507.         $f .= 'c' if $compress_it;
  508.         $f .= 'g' if $gzip_it;
  509.         $f .= 'a' if $btoa_it;
  510.         $f .= 'u' if $uuencode_it;
  511.         $f .= 'm' if $mime_it;
  512.         $f .= 'v' if $vvencode_it;
  513.         $f .= 'F' if $force;
  514.         $filters[ $cmdno ] = $f;
  515.         &log( "delayed mail back: $pwd $filename $f" ) if $verbose;
  516.         return;
  517.     }
  518.  
  519.     local( $note, $suff, $infile, $command );
  520.     
  521.     $infile = "$incoming.$cmdno";
  522.     if( ! $immediate ){
  523.         $command = $comms[ $cmdno ];
  524.         $filename = $filename[ $cmdno ];
  525.         $pwd = $pwd[ $cmdno ];
  526.         local( $f ) = $filters[ $cmdno ];
  527.         $compress_it = ($f =~ /c/);
  528.         $gzip_it = ($f =~ /g/);
  529.         $btoa_it = ($f =~ /a/);
  530.         $uuencode_it = ($f =~ /u/);
  531.         $mime_it = ($f =~ /m/);
  532.         $vvencode_it = ($f =~ /v/);
  533.         $force_it = ($f =~ /F/);
  534.         &log( "NOW mailing back: $pwd $filename $f" ) if $verbose;
  535.     }
  536.     
  537.     $partno = 0;
  538.     $nparts = 0;
  539.     $id = '';
  540.     $cte = '';
  541.     
  542.     local( $report ) = "$site:$pwd";
  543.     if( $command =~ /get/ ){
  544.         $report .= "/$filename";
  545.     }
  546.     
  547.     if( $compress_it ){
  548.         &log( "compressing $infile" );
  549.         unlink( "$infile.Z" );
  550.         &runcmd( $compress, $infile, "", "" );
  551.         if( -r "$infile.Z" ){
  552.             $note = ' compressed';
  553.             $infile .= '.Z';
  554.             $suff = '.Z';
  555.         }
  556.     }
  557.     elsif( $gzip_it ){
  558.         &log( "gzip $infile" );
  559.         unlink( "$infile.gz" );
  560.         &runcmd( $gzip, "", $infile, "$infile.gz" );
  561.         if( -r "$infile.gz" ){
  562.             $note = ' gzipped';
  563.             $infile .= '.gz';
  564.             $suff = '.gz';
  565.         }
  566.     }
  567.     
  568.     $is_text = (-T $infile);
  569.     if( $force || $mime_it || ! $is_text ){
  570.         if( !$mime_it && !$uuencode_it && !$btoa_it && !$vvencode_it ){
  571.             &log( "non text but no method, using uuencode" ) if $verbose;
  572.             $uuencode_it = 1;
  573.         }
  574.         # Convert binary file using given filter
  575.         # (Execpt mime, only encode if you have to)
  576.         if( $mime_it && ($force || !$is_text) ){
  577.             &log( "mmencoding $infile" );
  578.             unlink( "$infile.mm" );
  579.             &runcmd( $mmencode, "", $infile, "$infile.mm" );
  580.             unlink( $infile );
  581.             $note .= ' mmencoded';
  582.             $infile .= '.mm';
  583.             $cte = 'base64';
  584.         }
  585.         elsif( $uuencode_it ){
  586.             &log( "uuencoding $infile" );
  587.             unlink( "$infile.uu" );
  588.             &runcmd( $uuencode, "$filename$suff", $infile, "$infile.uu" );
  589.             unlink( $infile );
  590.             $note .= ' uuencoded';
  591.             $infile .= '.uu';
  592.         }
  593.         elsif( $btoa_it ){
  594.             &log( "btoa-ing $infile" );
  595.             unlink( "$infile.btoa" );
  596.             &runcmd( $btoa, "", $infile, "$infile.btoa" );
  597.             unlink( $infile );
  598.             $note .= ' btoa';
  599.             $infile .= '.btoa';
  600.         }
  601.         elsif( $vvencode_it ){
  602.             &log( "vvencoding $infile" );
  603.             unlink( "$infile.vv" );
  604.             &runcmd( $vvencode, "", $infile, "$infile.vv" );
  605.             unlink( $infile );
  606.             $note .= ' vvencode';
  607.             $infile .= '.vv';
  608.         }
  609.     }
  610.  
  611.     $report .= $note . " ($command)";
  612.     
  613.     if( $mime_it ){
  614.         $nparts = 0;
  615.         $partno = 0;
  616.         $id = "ftpmail-" . time . "-$$@$hostname";
  617.     }
  618.  
  619.     local( $file_size ) = &size( $infile );
  620.     if( $file_size > $max_processing_size ){
  621.         local( $msg ) = "file size exceeded max. processing size ($max_processing_size), canceling job";
  622.         &log( $msg );
  623.         &log( $report );
  624.     
  625.         &mailit( 'aborting job: too big', $msg );
  626.     }
  627.     elsif( $file_size >= $max_file_size ){
  628.         # Split the file up and mail back the parts
  629.         # Allow for mail headers.  If you have to pay
  630.         # by size then it is important not to accidentally go over
  631.         # limit.
  632.         $nparts = &tsplit( $infile, $max_file_size - $mail_overhead );
  633.         &log( "tsplit $infile $max_file_size into $nparts" );
  634.         
  635.         for( $partno = 1; $partno <= $nparts; $partno++ ){
  636.             local( $file ) = "$tmpdir/part$partno";
  637.             local( $reppart ) = sprintf( "[%03d of %03d]",
  638.                             $partno, $nparts );
  639.             
  640.             &mailit( "$reppart $report", $file, 1 );
  641.  
  642.             unlink( $file );
  643.         }
  644.     }
  645.     else {
  646.         &mailit( $report, $infile, 1 );
  647.     }
  648.     unlink( $infile );
  649.     
  650.     $comms[ $cmdno ] = "DONE $comms[ $cmdno ]";
  651.     &update_entry();
  652. }
  653.  
  654. sub mime_header
  655. {
  656.     local( $kind, $file  ) = @_;
  657.     print MAIL "Mime-Version: $mime_version\n";
  658.     if( $kind == $text ){
  659.         print MAIL "Content-Type: text/plain; charset=US-ASCII\n";
  660.     }
  661.     elsif( $kind == $partial ){
  662.         print MAIL "Content-Type: message/partial;\n";
  663.         print MAIL " id=\"$id\"; number=$partno; total=$nparts\n";
  664.     }
  665.     elsif( $kind == $octets ){
  666.         print MAIL "Content-Type: application/octet-stream;\n";
  667.         print MAIL "  name=\"$filename$suff\"\n";
  668.     }
  669.     if( $cte ){
  670.         print MAIL "Content-Transfer-Encoding: $cte\n";
  671.     }
  672. }
  673.  
  674. # A Mime message has extra header fields
  675. # and if the message is a (mime) split up message then whole
  676. # mime message is chopped up and sent as a series of message/partial messages
  677. sub mailit
  678. {
  679.     local( $subject, $file, $isfile ) = @_;
  680.     local( $size );
  681.     
  682.     if( $mail_cmd =~ /sendmail/ ){
  683.         open( MAIL, "| $mail_cmd" ) || &fail( "Can't start $mail_cmd" );
  684.         print MAIL "To: $reply_to\n";
  685.         print MAIL "Subject: $subject\n";
  686.         print MAIL "Precedence: bulk\n";
  687.         if( $mime_it ){
  688.             # cte is set if this file was encoded
  689.             local( $kind ) = $cte ? $octets : $text;
  690.             if( $nparts != 0 ){
  691.                 # Don't output the cte except in the
  692.                 # inner message.
  693.                 local( $real_cte ) = $cte;
  694.                 $cte = '';
  695.                 &mime_header( $partial, $file );
  696.                 $cte = $real_cte;
  697.                 if( $partno == 1 ){
  698.                     # Output the header for the
  699.                     # inner message.
  700.                     print MAIL "\n";
  701.                     &mime_header( $kind, $file );
  702.                 }
  703.             }
  704.             else {
  705.                 &mime_header( $kind, $file );
  706.             }
  707.         }
  708.         print MAIL "\n";
  709.     }
  710.     else {
  711.         local( $subj ) = $subject;
  712.         $subj =~ s/'/_/g;
  713.         open( MAIL, "| $mail_cmd -s '$subj' '$reply_to' >/dev/null 2>&1" ) ||
  714.              &fail( "Can't start $mail_cmd" );
  715.     }
  716.     
  717.     if( ! $isfile ){
  718.         # $file is the string to send
  719.         print MAIL $file;
  720.         $size = length( $file );
  721.     }
  722.     else {
  723.         open( IN, $file ) || &fail( "Can't reopen $file" );
  724.         while( <IN> ){
  725.             print MAIL;
  726.         }
  727.         close( IN );
  728.         $size = -s $file;
  729.     }
  730.     close( MAIL );
  731.     
  732.     &log( "mailit $size $reply_to $subject" );
  733.  
  734.     sleep( $mail_pause ) if $mail_pause;
  735. }
  736.  
  737. sub size
  738. {
  739.     local( $file ) = @_;
  740.     
  741.     local( $dev,$ino,$fmode,$nlink,$uid,$gid,$rdev,$ssize,
  742.           $atime,$mtime,$ctime,$blksize,$blocks ) =
  743.               stat( $file );
  744.     return( $ssize );
  745. }
  746.  
  747. # Output a standard lump of messages
  748. sub respond
  749. {
  750.     local( $status, $msg ) = @_;
  751.     local( $c );
  752.     local( $subject ) = "ftpmail job $status";
  753.     
  754.     &log( "respond $reply_to $subject" );
  755.     
  756.     if( $mail_cmd =~ /sendmail/ ){
  757.         open( MAIL, "| $mail_cmd" ) || &fail( "Can't start $mail_cmd" );
  758.         print MAIL "To: $reply_to\n";
  759.         print MAIL "Subject: $subject\n\n";
  760.     }
  761.     else {
  762.         local( $subj ) = $subject;
  763.         $subj =~ s/'/_/g;
  764.         open( MAIL, "| $mail_cmd -s '$subj' '$reply_to' >/dev/null 2>&1" ) ||
  765.              &fail( "Can't start $mail_cmd" );
  766.     }
  767.     print MAIL "$ftpmail_response\n";
  768.     if( -f $xferlog ){
  769.         print MAIL "$msg\nYour job was (lines beginning DONE show completed transfers):\n";
  770.         &mail_comms();
  771.         print MAIL "\nThe ftp log contains:\n";
  772.         open( LOG, $xferlog ) || &fail( "cannot reopen $xferlog" );
  773.         local( @log ) = <LOG>;
  774.         close( LOG );
  775.         print MAIL join( "\n", "@log" );
  776.         print MAIL "\n";
  777.     }
  778.     close MAIL;
  779.     
  780.     sleep( $mail_pause ) if $mail_pause;
  781. }
  782.  
  783. sub finish_entry
  784. {
  785.     if( $job_done ){
  786.         if( -f $qfile ){
  787.         # The job is done and hasn't been deleted due to too many tries
  788.             unlink( $qfile );
  789.             &log( "deleting $qfile" );
  790.             &respond( "completed", "" );
  791.         }
  792.     }
  793.     elsif( $give_up ){
  794.         unlink( $qfile );
  795.         &log( "Job $qfile failed when a serious error occured" );
  796.         &respond( "failed", "An unrecoverable error occured so your job was aborted" );
  797.     }
  798.     else {
  799.         if( ! &check_tries() ){
  800.             return;
  801.         }
  802.         &log( "Requeing job: $qfile" );
  803.         &respond( "queueing for retry $qfile", "" );
  804.         &update_entry();
  805.     }
  806. }
  807.  
  808. sub start_dqs
  809. {
  810.     local( $now ) = time;
  811.     local( @empty );
  812.     local( $min_restart ) = 5 * 60;  # Only recheck once every 5 mins.
  813.  
  814.     return if ($now - $min_restart) <= $last_started;
  815.  
  816.     $last_started = $now;
  817.  
  818.     &slots_lock_read();
  819.     local( $i );
  820.     for( $i = 0; $i <= $max_dqs; $i++ ){
  821.         $empty[ $i ] = ($pid[ $i ] == 0 || kill( 0, $pid[ $i ] ) <= 0);
  822.     }
  823.     for( $i = 0; $i <= $max_dqs; $i++ ){
  824.         next unless $empty[ $i ];
  825.         # Hmm an empty slot or one where the process has died.
  826.         # Better fill it in!
  827.         &log( "proc $$ slot $slot spawning $dq_path -slot $i" );
  828.         local( $flags ) = '';
  829.         $flags = ' -test' if $test;
  830.         $flags .= ' -verbose' if $verbose;
  831.         system( "$dq_path $flags -slot $i &" );
  832.     }
  833.     &slots_write_unlock();
  834. }
  835.  
  836.  
  837. sub fill_slot
  838. { 
  839.     &slots_lock_read();
  840.     if( $pid[ $slot ] != 0 ){
  841.         # Maybe the proc in that slot has died?
  842.         if( kill( 0, $pid[ $slot ] ) == 1 ){
  843.             if( $max_dqs == 0 ){
  844.                 &log( "queue already locked by $pid[ $slot ]" );
  845.             }
  846.             else {
  847.                 &log( "slot $slot is already filled by $pid[ $slot ]" );
  848.             }
  849.             exit( 0 );
  850.         }
  851.     }
  852.     $pid[ $slot ] = $$;
  853.     $time[ $slot ] = time;
  854.     &slots_write_unlock();
  855. }
  856.  
  857. sub empty_slot
  858. {
  859.     &slots_lock_read();
  860.     $pid[ $slot ] = 0;
  861.     $time[ $slot ] = time;
  862.     $site[ $slot ] = '';
  863.     &slots_write_unlock();
  864. }
  865.  
  866. sub slots_lock_read
  867. {
  868.     local( $mode, $msg );
  869.     if( ! -r $dq_stats ){
  870.         $mode = "+>>";
  871.         $msg = "create";
  872.     }
  873.     else {
  874.         $mode = "+<";
  875.         $msg = "open";
  876.     }
  877.     if( ! open( dqs, "$mode$dq_stats" ) ){
  878.         &log( "Cannot $msg $dq_stats, aborting" );
  879.         exit( 0 );
  880.     }
  881.     if( &seize( dqs, &LOCK_EX ) !~ /^0/ ){
  882.         &log( "Cannot lock $dq_stats, aborting" );
  883.         exit( 0 );
  884.     }
  885.  
  886.     local( $i ) = 0;
  887.     for( $i = 0; $i <= $max_dqs; $i++ ){
  888.         $pid[ $i ] =  $time[ $i ] = 0;
  889.         $site[ $i ] = '';
  890.     }
  891.     seek( dqs, 0, 0 );
  892.     $i = 0;
  893.     while( <dqs> ){
  894.         last if /^$/;
  895.         chop;
  896.         ($pid[ $i ], $time[ $i ], $site[ $i ]) = split(/:/);
  897.         last if $i++ > $max_dqs;
  898.     }
  899. }
  900.  
  901. sub slots_write_unlock
  902. {
  903.     local( $i, $len );
  904.     seek( dqs, 0, 0 );
  905.     for( $i = 0; $i <= $max_dqs; $i++ ){
  906.         local( $line ) = "$pid[ $i ]:$time[ $i ]:$site[ $i ]\n";
  907.         print dqs $line;
  908.         $len += length( $line );
  909.     }
  910.     print dqs "\n";
  911.     eval "truncate( dqs, $len )";
  912.     # closing will also unlock.
  913.     close( dqs );
  914. }
  915.  
  916. sub lock_qf
  917. {
  918.     if( ! open( qfile, "+<$qfile" ) ){
  919.         return 0;
  920.     }
  921. #    return (&seize( qfile, &LOCK_EX | &LOCK_NB ) =~ /^0/);
  922.     $ret = &seize( qfile, &LOCK_EX | &LOCK_NB );
  923.     $r = ($ret =~ /^0/);
  924.     return $r;
  925. }
  926.  
  927. sub unlock_qf
  928. {
  929.     # TODO: unlock the site
  930.     # closing will also unlock.
  931.     close( qfile );
  932. }
  933.  
  934. sub lock_retry
  935. {
  936.     local( $fh ) = @_;
  937.     local( $max_tries ) = 5;
  938.     local( $pause ) = 1;
  939.  
  940.     local( $tries ) = 0;
  941.     local( $lk );
  942.     while( ($lk = &seize( $fh, &LOCK_EX | &LOCK_NB )) !~ /^0/ ){
  943.         if( $tries++ < $max_tries ){
  944.             sleep( $pause );
  945.         }
  946.         else {
  947.             $lk = -1;
  948.             last;
  949.         }
  950.     }
  951.     return $lk >= 0;
  952. }
  953.  
  954. sub shutdown
  955. {
  956.     &log( "Received HUP so shutting down" );
  957.     &empty_slot();
  958.     exit( 0 );
  959. }
  960.  
  961. sub trap_signals
  962. {
  963.     $SIG{ 'HUP' } = "main\'shutdown";
  964. }
  965.  
  966. # print to out and log it.
  967. sub pralog
  968. {
  969.     local( $msg ) = @_;
  970.     print out "$msg\n";
  971.     &log( $msg );
  972. }
  973.  
  974. # Split the file up into chunks size big, remove the
  975. # original and return the number of parts
  976. sub tsplit
  977. {
  978.     local( $file, $size ) = @_;
  979.     local( $buffer, $in, $sofar );
  980.     local( $index ) = 0;
  981.     local( $part );
  982.  
  983.     open( f, $file ) || &fatal( "Cannot open $file to split" );
  984.     $sofar = $size;
  985.     while( <f> ){
  986.         $in = length( $_ );
  987.         if( $sofar >= $size ){
  988.             if( $part ){
  989.                 close( part );
  990.             }
  991.             $index++;
  992.             $part = "$tmpdir/part$index";
  993.             unlink( $part );
  994.             open( part, ">$part" ) || &fatal( "cannot create $part" );
  995.             $sofar = 0;
  996.         }
  997.         print part;
  998.         $sofar += $in;
  999.     }
  1000.     close( part );
  1001.     close( f );
  1002.  
  1003.     return $index;
  1004. }
  1005.  
  1006. # Split the file up into chunks size big, remove the
  1007. # original and return the number of parts
  1008. sub binsplit
  1009. {
  1010.     local( $file, $size ) = @_;
  1011.     local( $bufsiz ) = 512;
  1012.     local( $buffer, $in, $sofar );
  1013.     local( $index ) = 0;
  1014.     local( $part );
  1015.  
  1016.     open( f, $file ) || &fatal( "Cannot open $file to split" );
  1017.     $sofar = $size; # Force a new file
  1018.     while( ($in = sysread( f, $buffer, $bufsiz )) > 0 ){
  1019.         if( $sofar >= $size ){
  1020.             if( $part ){
  1021.                 close( part );
  1022.             }
  1023.             $index++;
  1024.             $part = "$tmpdir/part$index";
  1025.             unlink( $part );
  1026.             open( part, ">$part" ) || &fatal( "cannot create $part" );
  1027.             $sofar = 0;
  1028.         }
  1029.         if( ($out = syswrite( part, $buffer, $in )) != $in ){
  1030.             &fatal( "Failed to write data to $part" );
  1031.         }
  1032.         $sofar += $in;
  1033.     }
  1034.     close( part );
  1035.     close( f );
  1036.  
  1037.     return $index;
  1038. }
  1039.  
  1040. # Run a command 
  1041. # like system( "$cmd $cmdargs < $infile > $outfile" ) but without
  1042. # shell expansion happening.
  1043. # Each space seperated part of $cmd is passed as a seperate arg but
  1044. # otherwise spaces are preserved.
  1045. sub runcmd
  1046. {
  1047.     local( $cmd, $cmdargs, $infile, $outfile ) = @_;
  1048.     local( $child_pid, $dying );
  1049.     local( @cmd);
  1050.  
  1051.     @cmd = split( /\s+/, $cmd );
  1052.     if( $cmdargs ){
  1053.         push( @cmd, $cmdargs );
  1054.     }
  1055.  
  1056.     if( ($child_pid = fork()) < 0 ){
  1057.         &fail( "Couldn't fork: $!" );
  1058.     }
  1059.     elsif( $child_pid == 0 ){
  1060.         if( $infile ){
  1061.             open( STDIN, $infile ) ||
  1062.                 &fail( "Cannot open $infile: $!" );
  1063.         }
  1064.         else {
  1065.             close( STDIN );
  1066.         }
  1067.         if( $outfile ){
  1068.             open( STDOUT, ">$outfile" ) ||
  1069.                 &fail( "Cannot write to $outfile: $!" );
  1070.         }
  1071.         else {
  1072.             close( STDOUT );
  1073.         }
  1074.         exec @cmd;
  1075.         &fail( "failed to exec @cmd: $!" );
  1076.     }
  1077.     # Wait for the child to terminate.
  1078.     while( ($dying = wait()) != -1 && ($dying != $child_pid) ){
  1079.         ;
  1080.     }
  1081. }
  1082.