home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume43 / ftpmail / part01 next >
Internet Message Format  |  1994-07-07  |  58KB
  1. From: lmjm@doc.ic.ac.uk (Lee M J McLoughlin)
  2. Newsgroups: comp.sources.misc
  3. Subject: v43i072:  ftpmail - Automatic Email to FTP Gateway, v1.23, Part01/03
  4. Date: 7 Jul 1994 18:06:08 -0500
  5. Organization: Sterling Software
  6. Sender: kent@sparky.sterling.com
  7. Approved: kent@sparky.sterling.com
  8. Message-ID: <csm-v43i072=ftpmail.180556@sparky.sterling.com>
  9. X-Md4-Signature: d257edd0be5c73c3053eba4c2500ba7a
  10.  
  11. Submitted-by: lmjm@doc.ic.ac.uk (Lee M J McLoughlin)
  12. Posting-number: Volume 43, Issue 72
  13. Archive-name: ftpmail/part01
  14. Environment: UNIX, Perl, Sun, Dec, INET
  15. Supersedes: ftpmail: Volume 37, Issue 51-52
  16.  
  17. Ftpmail is an email->ftp gateway.  You mail requests to a user (eg:
  18. ftpmail).  This causes q.pl to be called which checks the request and
  19. sticks it in a queue.  dq.pl then parses the queue and does the ftp
  20. transfers that the job specifies mailing back the files that were
  21. transfers.  As various things happen notes are writen in the
  22. ftpmail log file.  
  23.  
  24. It is all writen in perl and sends responses using either mail or by
  25. directly calling sendmail.  When using sendmail MIME support is
  26. available.
  27.  
  28. If a transfer fails for a fatal reason then it is dequed and the user
  29. is emailed.  If it fails for a non-fatal reason (such as timeout on
  30. connect) then it will be requeued to try later (the next time dq.pl is
  31. called).  Once a transfer (get|dir|ls) has succeeded it is marked as
  32. DONE and will be skipped.  All other commands will still be obeyed.  A
  33. job will only be tried for a fix number of times, then rejected.
  34.  
  35. For user level details read the help file.
  36.  
  37. If the file motd is present then its contents are inserted at
  38. the start of any responses.
  39.  
  40.  WORKERS
  41.  -------
  42. If you want to help develop ftpmail then there is now a mailing list:
  43.     ftpmail-workers@doc.ic.ac.uk
  44. To subscribe email to:    ftpmail-workers-request@doc.ic.ac.uk
  45. a message like:
  46.     Subject: add me
  47.     
  48.     subscribe ftpmail-workers Your Full Name Here
  49.  
  50.  UPGRADING
  51.  ---------
  52. If you are upgrading to 1.23 from an earlier release you may want to make
  53. use of some new features.
  54.  
  55. * You can now have multiple dq processes running in parallel.  This is all
  56.   controlled by the $max_dqs variable in config.pl.  The interface is
  57.   designed to not need any changes to the cron or other startup
  58.   scripts.  The main dq will automatically spawn off the slaves.  All
  59.   dq's will check the status of all dq's every 5 mins, spot any dead
  60.   dq's and restart them.  So you shouldn't need to change and cron or
  61.   other startup scripts.  This *requires* fcntl based locking code.
  62.  
  63.   Unless you have a lot of traffic you should probably not bother setting
  64.   max_dq's to anything other than 1.
  65.  
  66. * Jobs can be given a priority base on the site the user is trying to reach.
  67.   See @site_priorities.  This is based on ideas by Kurt Jaeger 
  68.   <pi@rus.uni-stuttgart.de>.  The first digit of queue items is a priority 
  69.   character.  The max length of a filename is still the same, for old USG 
  70.   filename restrictions.
  71.  
  72.   To rename all the jobs to the new scheme use the command req in the
  73.   home directory of ftpmail.  After that incoming deletes won't work for a 
  74.   while as jobs will have been renamed.  You could just let the old entries 
  75.   alone and let them be processed out of the queue.
  76.  
  77. * The sites that can be accessed via ftpmail can be resticted with the 
  78.   $ftp_permitted pattern.
  79.  
  80. * You can now vrfy addresses before trying to reply to them by using the 
  81.   external vrfy command, courtesy of Christophe.Wolfhugel@hsc-sec.fr
  82.  
  83. * There is now an rfc parser, courtesy of Alan Barrett 
  84.   <barrett@daisy.ee.und.ac.za>.
  85.  
  86. * q.pl is now very much better at handling weird input.  It can now cope 
  87.   with bizzare mailers that insert a second copy of the mail headers and 
  88.   whitespace in front of all the mail body!
  89.  
  90. * The max_tries field is now obeyed correctly.
  91.  
  92. * The delay between tries is now 2 hours.
  93.  
  94. * killfm is a simple program to shutdown all the dq proc's.  It is not meant
  95.   to be used casually.
  96.  
  97.  THANKS
  98.  ------
  99. Thanks to all those who suggested improvements.  Also special thanks
  100. to Christophe.Wolfhugel@hsc-sec.fr for all his work on mime
  101. and the new queing system which formed the basis for some of the new code.
  102. ---------
  103. #! /bin/sh
  104. # This is a shell archive.  Remove anything before this line, then feed it
  105. # into a shell via "sh file" or similar.  To overwrite existing files,
  106. # type "sh file -c".
  107. # Contents:  README README.upgrade ftp.pl pp_mailfilter q.pl
  108. # Wrapped by kent@sparky on Thu Jul  7 17:54:04 1994
  109. PATH=/bin:/usr/bin:/usr/ucb:/usr/local/bin:/usr/lbin:$PATH ; export PATH
  110. echo If this archive is complete, you will see the following message:
  111. echo '          "shar: End of archive 1 (of 3)."'
  112. if test -f 'README' -a "${1}" != "-c" ; then 
  113.   echo shar: Will not clobber existing file \"'README'\"
  114. else
  115.   echo shar: Extracting \"'README'\" \(4550 characters\)
  116.   sed "s/^X//" >'README' <<'END_OF_FILE'
  117. XFtpmail is an email->ftp gateway.  You mail requests to a user (eg:
  118. Xftpmail).  This causes q.pl to be called which checks the request and
  119. Xsticks it in a queue.  dq.pl then parses the queue and does the ftp
  120. Xtransfers that the job specifies mailing back the files that were
  121. Xtransfers.  As various things happen notes are writen in the
  122. Xftpmail log file.  
  123. X
  124. XIt is all writen in perl and sends responses using either mail or by
  125. Xdirectly calling sendmail.  When using sendmail MIME support is
  126. Xavailable.
  127. X
  128. XIf a transfer fails for a fatal reason then it is dequed and the user
  129. Xis emailed.  If it fails for a non-fatal reason (such as timeout on
  130. Xconnect) then it will be requeued to try later (the next time dq.pl is
  131. Xcalled).  Once a transfer (get|dir|ls) has succeeded it is marked as
  132. XDONE and will be skipped.  All other commands will still be obeyed.  A
  133. Xjob will only be tried for a fix number of times, then rejected.
  134. X
  135. XFor user level details read the help file.
  136. X
  137. XIf the file motd is present then its contents are inserted at
  138. Xthe start of any responses.
  139. X
  140. XARCHIVES
  141. X--------
  142. XThis packages is available from:
  143. X    file://src.doc.ic.ac.uk/packages/ftpmail/
  144. X    http://src.doc.ic.ac.uk/packages/ftpmail/
  145. X    gopher://src.doc.ic.ac.uk/1/packages/ftpmail/
  146. X
  147. X    file://grasp.univ-lyon1.fr/pub/unix/mail/tools/ftpmail/
  148. X
  149. X        file://ftp.sterling.com/mail/ftpmail/
  150. X
  151. X
  152. XUPGRADING
  153. X---------
  154. X
  155. XSee README.upgrade.
  156. X
  157. X
  158. XWHERE SERVERS ARE
  159. X-----------------
  160. X
  161. XSee the WWW file: http://src.doc.ic.ac.uk/ftpmail-servers.html
  162. Xor FTP file://src.doc.ic.ac.uk/packages/ftpmail/ftpmail-servers.txt
  163. Xfor details about where ftpmail servers are running.
  164. X
  165. X
  166. XTO INSTALL
  167. X----------
  168. X
  169. XCreate an account called 'ftpmail', the home directory of ftpmail is
  170. Xwhere all the scripts will be installed and subdirectories of it form
  171. Xthe queues.
  172. X
  173. XEdit config.pl to reflect your local details.  (If you
  174. Xchange the default site also edit help.)  The auth file is
  175. Xjust a series of regexps, so a line of just dot would allow all email
  176. Xaddresses to use ftpmail.
  177. X
  178. XOnce you have edited the above files run inst.pl.  inst.pl
  179. Xwill create the ftpmail directories based on values in
  180. Xconfig.pl and copy in various files.  Its a bit of a
  181. Xhack.
  182. X
  183. XAt src.doc.ic.ac.uk I only allow requests to be submitted via email.
  184. XThe ftpmail account is not present on any general machine, just on the
  185. Xmain mail gateway .  On that I use the PP .mailfilter script mechanism
  186. Xto cause any mail delivered to that ftpmail to invoke q.pl. But
  187. Xanything that causes q.pl to be run on the input request will do.
  188. XUnder sendmail create ~ftpmail/.forward containing:
  189. X|"/public/ic.doc/ftpmail/q.pl || exit 75"
  190. X(Or similar.)
  191. X
  192. XThe file crontab contains a suggested cron entry that should be run as
  193. Xthe user  ftpmail.  This calls dq.pl that dequeues the entries and
  194. Xruns them.  dq.pl should run forever once started.  But as I am a
  195. Xparanoid person I call it every half hour just to be safe.
  196. X
  197. XNote that mail sent is sent by ftpmail not ftpmail-request.  ftpmail
  198. Xdoes other tricks to prevent mail loops forming.  I tried running with
  199. Xmail being sent by ftpmail-request and ftpmail-request aliases to me.
  200. XI found that most of the traffic to ftpmail-request is from people who
  201. Xsubmit jobs by replying to ftpmail responses in order to submit new
  202. Xjobs.
  203. X
  204. XSOCKET.PH && SOLARIS 2.x
  205. X------------------------
  206. XAlthough there is a socket.ph in this distribution you should really
  207. Xuse the one generated by h2ph when installing perl.  Socket.ph is
  208. Xarchitecture specific so the socket.ph I use is unlikely to work unless
  209. Xyou are on a Sparc running Sunos 4.1.x.
  210. X
  211. XUnfortunetly the sys/socket.ph generated on Solaris 2.x by perl's h2ph is
  212. Xincorrect so you will have to install socket.ph-solaris from this distribution
  213. Xas /usr/local/lib/perl/sys/socket.ph (or whereever appropriate on your
  214. Xsystem).
  215. X
  216. XTHANKS
  217. X------
  218. XThanks to all those who suggested improvements.  Also special thanks
  219. Xto Christophe.Wolfhugel@hsc-sec.fr for all his work on mime
  220. Xand the new queing system which formed the basis for some of the new code.
  221. X
  222. XWORKERS
  223. X-------
  224. XIf you want to help develope ftpmail then there is now a mailing list:
  225. X    ftpmail-workers@doc.ic.ac.uk
  226. XTo subscribe email to:    ftpmail-workers-request@doc.ic.ac.uk
  227. Xa message like:
  228. X    Subject: add me
  229. X    
  230. X    subscribe ftpmail-workers Your Full Name Here
  231. X
  232. XCOPYRIGHT
  233. X---------
  234. XWriten by Lee McLoughlin <lmjm@doc.ic.ac.uk>
  235. X
  236. XYou can do what you like with this except claim that you wrote it or
  237. Xgive copies with changes not approved by Lee.  Neither Lee nor any other
  238. Xorganisation can be held liable for any problems caused by the use or
  239. Xstorage of this package.
  240. END_OF_FILE
  241.   if test 4550 -ne `wc -c <'README'`; then
  242.     echo shar: \"'README'\" unpacked with wrong size!
  243.   fi
  244.   # end of 'README'
  245. fi
  246. if test -f 'README.upgrade' -a "${1}" != "-c" ; then 
  247.   echo shar: Will not clobber existing file \"'README.upgrade'\"
  248. else
  249.   echo shar: Extracting \"'README.upgrade'\" \(1996 characters\)
  250.   sed "s/^X//" >'README.upgrade' <<'END_OF_FILE'
  251. XIf you are upgrading to 1.23 from an earlier release you may want to make
  252. Xuse of some new features.
  253. X
  254. X* You can now have multiple dq processes running in parallel.  This is all
  255. X  controlled by the $max_dqs variable in config.pl.  The interface is
  256. X  designed to not need any changes to the cron or other startup
  257. X  scripts.  The main dq will automatically spawn off the slaves.  All
  258. X  dq's will check the status of all dq's every 5 mins, spot any dead
  259. X  dq's and restart them.  So you shouldn't need to change and cron or
  260. X  other startup scripts.  This *requires* fcntl based locking code.
  261. X
  262. X  Unless you have a lot of traffic you should probably not bother setting
  263. X  max_dq's to anything other than 1.
  264. X
  265. X* Jobs can be given a priority base on the site the user is trying to reach.  See
  266. X  @site_priorities.  This is based on ideas by Kurt Jaeger <pi@rus.uni-stuttgart.de>.
  267. X  The first digit of queue items is a priority character.  The max length
  268. X  of a filename is still the same, for old USG filename restrictions.
  269. X
  270. X  To rename all the jobs to the new scheme use the command req in the
  271. X  home directory of ftpmail.  After that incoming deletes won't work for a while
  272. X  as jobs will have been renamed.  You could just let the old entries alone
  273. X  and let them be processed out of the queue.
  274. X
  275. X* The sites that can be accessed via ftpmail can be resticted with the $ftp_permitted
  276. X  pattern.
  277. X
  278. X* You can now vrfy addresses before trying to reply to them by using the external
  279. X  vrfy command, courtesy of Christophe.Wolfhugel@hsc-sec.fr
  280. X
  281. X* There is now an rfc parser, courtesy of Alan Barrett <barrett@daisy.ee.und.ac.za>.
  282. X
  283. X* q.pl is now very much better at handling weird input.  It can now cope with
  284. X  bizzare mailers that insert a second copy of the mail headers and whitespace in
  285. X  front of all the mail body!
  286. X
  287. X* The max_tries field is now obeyed correctly.
  288. X
  289. X* The delay between tries is now 2 hours.
  290. X
  291. X* killfm is a simple program to shutdown all the dq proc's.  It is not meant
  292. X  to be used casually.
  293. END_OF_FILE
  294.   if test 1996 -ne `wc -c <'README.upgrade'`; then
  295.     echo shar: \"'README.upgrade'\" unpacked with wrong size!
  296.   fi
  297.   # end of 'README.upgrade'
  298. fi
  299. if test -f 'ftp.pl' -a "${1}" != "-c" ; then 
  300.   echo shar: Will not clobber existing file \"'ftp.pl'\"
  301. else
  302.   echo shar: Extracting \"'ftp.pl'\" \(24614 characters\)
  303.   sed "s/^X//" >'ftp.pl' <<'END_OF_FILE'
  304. X#-*-perl-*-
  305. X# This is a wrapper to the lchat.pl routines that make life easier
  306. X# to do ftp type work.
  307. X# Mostly by Lee McLoughlin <lmjm@doc.ic.ac.uk>
  308. X# based on original version by Alan R. Martello <al@ee.pitt.edu>
  309. X# And by A.Macpherson@bnr.co.uk for multi-homed hosts
  310. X#
  311. X# Basic usage:
  312. X#  $ftp_port = 21;
  313. X#  $retry_call = 1;
  314. X#  $attempts = 2;
  315. X#  if( &ftp'open( $site, $ftp_port, $retry_call, $attempts ) != 1 ){
  316. X#   die "failed to open ftp connection";
  317. X#  }
  318. X#  if( ! &ftp'login( $user, $pass ) ){
  319. X#   die "failed to login";
  320. X#  }
  321. X#  &ftp'type( $text_mode ? 'A' : 'I' );
  322. X#  if( ! &ftp'get( $remote_filename, $local_filename, 0 ) ){
  323. X#   die "failed to get file;
  324. X#  }
  325. X#  &ftp'quit();
  326. X#
  327. X#
  328. X# $Id: ftp.pl,v 2.6 1994/06/06 18:37:37 lmjm Exp lmjm $
  329. X# $Log: ftp.pl,v $
  330. X# Revision 2.6  1994/06/06  18:37:37  lmjm
  331. X# Switched to lchat - a subset of chat.
  332. X# Allow for 'remote help's need to parse the help strings in the continuations
  333. X# Use real_site for proxy connections.
  334. X# Allow for cr stripping and corrected use of buffer (from Andrew).
  335. X#
  336. X# Revision 2.5  1994/04/29  20:11:04  lmjm
  337. X# Converted to use rfc1123.
  338. X#
  339. X# Revision 2.4  1994/01/26  14:59:07  lmjm
  340. X# Added DG result code.
  341. X#
  342. X# Revision 2.3  1994/01/18  21:58:18  lmjm
  343. X# Reduce calls to sigset.
  344. X# Reset to old signal after use.
  345. X#
  346. X# Revision 2.2  1993/12/14  11:09:06  lmjm
  347. X# Use installed socket.ph.
  348. X# Allow for more returns.
  349. X#
  350. X# Revision 2.1  1993/06/28  15:02:00  lmjm
  351. X# Full 2.1 release
  352. X#
  353. X#
  354. X
  355. Xrequire 'sys/socket.ph';
  356. X# lchat.pl is a special subset of chat2.pl that avoids some memory leaks.
  357. Xrequire 'lchat.pl';
  358. X
  359. X
  360. Xpackage ftp;
  361. X
  362. X$retry_pause = 60;    # Pause before retrying a login.
  363. X
  364. Xif( defined( &main'PF_INET ) ){
  365. X    $pf_inet = &main'PF_INET;
  366. X    $sock_stream = &main'SOCK_STREAM;
  367. X    local($name, $aliases, $proto) = getprotobyname( 'tcp' );
  368. X    $tcp_proto = $proto;
  369. X}
  370. Xelse {
  371. X    # XXX hardwired $PF_INET, $SOCK_STREAM, 'tcp'
  372. X    # but who the heck would change these anyway? (:-)
  373. X    $pf_inet = 2;
  374. X    $sock_stream = 1;
  375. X    $tcp_proto = 6;
  376. X}
  377. X
  378. X# If the remote ftp daemon doesn't respond within this time presume its dead
  379. X# or something.
  380. X$timeout = 120;
  381. X
  382. X# Timeout a read if I don't get data back within this many seconds
  383. X$timeout_read = 3 * $timeout;
  384. X
  385. X# Timeout an open
  386. X$timeout_open = $timeout;
  387. X
  388. X$ftp'version = '$Revision: 2.6 $';
  389. X
  390. X# This is a "global" it contains the last response from the remote ftp server
  391. X# for use in error messages
  392. X$ftp'response = "";
  393. X# Also ftp'NS is the socket containing the data coming in from the remote ls
  394. X# command.
  395. X
  396. X# The size of block to be read or written when talking to the remote
  397. X# ftp server
  398. X$ftp'ftpbufsize = 4096;
  399. X
  400. X# How often to print a hash out, when debugging
  401. X$ftp'hashevery = 1024;
  402. X# Output a newline after this many hashes to prevent outputing very long lines
  403. X$ftp'hashnl = 70;
  404. X
  405. X# Is there a connection open?
  406. X$ftp'service_open = 0;
  407. X
  408. X# If a proxy connection then who am I really talking to?
  409. X$real_site = "";
  410. X
  411. X# Where error/log reports are sent to
  412. X$ftp'showfd = 'STDERR';
  413. X
  414. X# Should a 421 be treated as a connection close and return 99 from
  415. X# ftp'expect.  This is against rfc1123 recommendations but I've found
  416. X# it to be a wise default.
  417. X$drop_on_421 = 1;
  418. X
  419. X# Name of a function to call on a pathname to map it into a remote
  420. X# pathname.
  421. X$ftp'mapunixout = '';
  422. X$ftp'manunixin = '';
  423. X
  424. X# This is just a tracing aid.
  425. X$ftp_show = 0;
  426. X
  427. X# Wether to keep the continuation messages so the user can look at them
  428. X$ftp'keep_continuations = 0;
  429. X
  430. X# Uncomment to turn on lots of debugging.
  431. X# &ftp'debug( 10 );
  432. X
  433. Xsub ftp'debug
  434. X{
  435. X    $ftp_show = @_[0];
  436. X    if( $ftp_show > 9 ){
  437. X        $chat'debug = 1;
  438. X    }
  439. X}
  440. X
  441. Xsub ftp'set_timeout
  442. X{
  443. X    local( $to ) = @_;
  444. X    return if $to == $timeout;
  445. X    $timeout = $to;
  446. X    $timeout_open = $timeout;
  447. X    $timeout_read = 3 * $timeout;
  448. X    if( $ftp_show ){
  449. X        print $ftp'showfd "ftp timeout set to $timeout\n";
  450. X    }
  451. X}
  452. X
  453. X
  454. Xsub ftp'open_alarm
  455. X{
  456. X    die "timeout: open";
  457. X}
  458. X
  459. Xsub ftp'timed_open
  460. X{
  461. X    local( $site, $ftp_port, $retry_call, $attempts ) = @_;
  462. X    local( $connect_site, $connect_port );
  463. X    local( $ret );
  464. X
  465. X    alarm( $timeout_open );
  466. X
  467. X    while( $attempts-- ){
  468. X        if( $ftp_show ){
  469. X            print $ftp'showfd "proxy connecting via $proxy_gateway [$proxy_ftp_port]\n" if $proxy;
  470. X            print $ftp'showfd "Connecting to $site";
  471. X            if( $ftp_port != 21 ){
  472. X                print $ftp'showfd " [port $ftp_port]";
  473. X            }
  474. X            print $ftp'showfd "\n";
  475. X        }
  476. X        
  477. X        if( $proxy ) {
  478. X            if( ! $proxy_gateway ) {
  479. X                # if not otherwise set
  480. X                $proxy_gateway = "internet-gateway";
  481. X            }
  482. X            if( $debug ) {
  483. X                print $ftp'showfd "using proxy services of $proxy_gateway, ";
  484. X                print $ftp'showfd "at $proxy_ftp_port\n";
  485. X            }
  486. X            $connect_site = $proxy_gateway;
  487. X            $connect_port = $proxy_ftp_port;
  488. X            $real_site = $site;
  489. X        }
  490. X        else {
  491. X            $connect_site = $site;
  492. X            $connect_port = $ftp_port;
  493. X        }
  494. X        if( ! &chat'open_port( $connect_site, $connect_port ) ){
  495. X            if( $retry_call ){
  496. X                print $ftp'showfd "Failed to connect\n" if $ftp_show;
  497. X                next;
  498. X            }
  499. X            else {
  500. X                print $ftp'showfd "proxy connection failed " if $proxy;
  501. X                print $ftp'showfd "Cannot open ftp to $connect_site\n" if $ftp_show;
  502. X                return 0;
  503. X            }
  504. X        }
  505. X        $ret = &ftp'expect( $timeout,
  506. X            220, 1 ); # ready for login to $site
  507. X        if( $ret != 1 ){
  508. X            &chat'close();
  509. X            next;
  510. X        }
  511. X        return 1;
  512. X    }
  513. X    continue {
  514. X        print $ftp'showfd "Pausing between retries\n";
  515. X        sleep( $retry_pause );
  516. X    }
  517. X    return 0;
  518. X}
  519. X
  520. Xsub main'ftp__sighandler
  521. X{
  522. X    local( $sig ) = @_;
  523. X    local( $msg ) = "Caught a SIG$sig flagging connection down";
  524. X    $ftp'service_open = 0;
  525. X    if( $ftp_logger ){
  526. X        eval "&$ftp_logger( \$msg )";
  527. X    }
  528. X}
  529. X
  530. Xsub ftp'set_signals
  531. X{
  532. X    $ftp_logger = @_;
  533. X    $SIG{ 'PIPE' } = "ftp__sighandler";
  534. X}
  535. X
  536. X# Set the mapunixout and mapunixin functions
  537. Xsub ftp'set_namemap
  538. X{
  539. X    ($ftp'mapunixout, $ftp'mapunixin) = @_;
  540. X    if( $debug ) {
  541. X        print $ftp'showfd "mapunixout = $ftp'mapunixout, $mapunixin = $ftp'mapunixin\n";
  542. X    }
  543. X}
  544. X
  545. X
  546. Xsub ftp'open
  547. X{
  548. X    local( $site, $ftp_port, $retry_call, $attempts ) = @_;
  549. X
  550. X    local( $old_sig ) = $SIG{ 'ALRM' };
  551. X    $SIG{ 'ALRM' } = "ftp\'open_alarm";
  552. X
  553. X    local( $ret ) = eval "&timed_open( '$site', $ftp_port, $retry_call, $attempts )";
  554. X    alarm( 0 );
  555. X    $SIG{ 'ALRM' } = $old_sig;
  556. X
  557. X    if( $@ =~ /^timeout/ ){
  558. X        return -1;
  559. X    }
  560. X
  561. X    if( $ret ){
  562. X        $ftp'service_open = 1;
  563. X    }
  564. X
  565. X    return $ret;
  566. X}
  567. X
  568. Xsub ftp'login
  569. X{
  570. X    local( $remote_user, $remote_password ) = @_;
  571. X        local( $ret );
  572. X
  573. X    if( ! $ftp'service_open ){
  574. X        return 0;
  575. X    }
  576. X
  577. X    if( $proxy ){
  578. X        # Should site or real_site be used here?
  579. X        &ftp'send( "USER $remote_user@$real_site" );
  580. X    }
  581. X    else {
  582. X        &ftp'send( "USER $remote_user" );
  583. X    }
  584. X    $ret = &ftp'expect( $timeout,
  585. X        230, 1,   # $remote_user logged in
  586. X        331, 2,   # send password for $remote_user
  587. X        332, 0 ); # account for login - not yet supported
  588. X    if( $ret == 99 ){
  589. X        &service_closed();
  590. X        $ret = 0;
  591. X    }
  592. X    if( $ret == 1 ){
  593. X        # Logged in no password needed
  594. X        return 1;
  595. X    }
  596. X    elsif( $ret == 2 ){
  597. X        # A password is needed
  598. X        &ftp'send( "PASS $remote_password" );
  599. X
  600. X        $ret = &ftp'expect( $timeout,
  601. X            230, 1 ); # $remote_user logged in
  602. X        if( $ret == 99 ){
  603. X            &service_closed();
  604. X        }
  605. X        elsif( $ret == 1 ){
  606. X            # Logged in
  607. X            return 1;
  608. X        }
  609. X    }
  610. X    # If I got here I failed to login
  611. X    return 0;
  612. X}
  613. X
  614. Xsub service_closed
  615. X{
  616. X    $ftp'service_open = 0;
  617. X    &chat'close();
  618. X}
  619. X
  620. Xsub ftp'close
  621. X{
  622. X    &ftp'quit();
  623. X    $ftp'service_open = 0;
  624. X    &chat'close();
  625. X}
  626. X
  627. X# Change directory
  628. X# return 1 if successful
  629. X# 0 on a failure
  630. Xsub ftp'cwd
  631. X{
  632. X    local( $dir ) = @_;
  633. X    local( $ret );
  634. X
  635. X    if( ! $ftp'service_open ){
  636. X        return 0;
  637. X    }
  638. X
  639. X    if( $ftp'mapunixout ){
  640. X        $dir = eval "&$ftp'mapunixout( \$dir, 'd' )";
  641. X    }
  642. X
  643. X    &ftp'send( "CWD $dir" );
  644. X
  645. X    $ret = &ftp'expect( $timeout,
  646. X        2, 1 ); # working directory = $dir
  647. X    if( $ret == 99 ){
  648. X        &service_closed();
  649. X        $ret = 0;
  650. X    }
  651. X
  652. X    return $ret;
  653. X}
  654. X
  655. X# Get a full directory listing:
  656. X# &ftp'dir( remote LIST options )
  657. X# Start a list going with the given options.
  658. X# Presuming that the remote deamon uses the ls command to generate the
  659. X# data to send back then then you can send it some extra options (eg: -lRa)
  660. X# return 1 if sucessful and 0 on a failure
  661. Xsub ftp'dir_open
  662. X{
  663. X    local( $options ) = @_;
  664. X    local( $ret );
  665. X    
  666. X    if( ! $ftp'service_open ){
  667. X        return 0;
  668. X    }
  669. X
  670. X    if( ! &ftp'open_data_socket() ){
  671. X        return 0;
  672. X    }
  673. X    
  674. X    if( $options ){
  675. X        &ftp'send( "LIST $options" );
  676. X    }
  677. X    else {
  678. X        &ftp'send( "LIST" );
  679. X    }
  680. X    
  681. X    $ret = &ftp'expect( $timeout,
  682. X        150, 1 ); # reading directory
  683. X    if( $ret == 99 ){
  684. X        &service_closed();
  685. X        $ret = 0;
  686. X    }
  687. X
  688. X    if( ! $ret ){
  689. X        &ftp'close_data_socket;
  690. X        return 0;
  691. X    }
  692. X    
  693. X    accept( NS, S ) || die "accept failed $!";
  694. X
  695. X    # 
  696. X    # the data should be coming at us now
  697. X    #
  698. X    
  699. X    return 1;
  700. X}
  701. X
  702. X
  703. X# Close down reading the result of a remote ls command
  704. X# return 1 if successful and 0 on failure
  705. Xsub ftp'dir_close
  706. X{
  707. X    local( $ret );
  708. X
  709. X    if( ! $ftp'service_open ){
  710. X        return 0;
  711. X    }
  712. X
  713. X    # read the close
  714. X    #
  715. X    $ret = &ftp'expect($timeout,
  716. X            2, 1 ); # transfer complete, closing connection
  717. X    if( $ret == 99 ){
  718. X        &service_closed();
  719. X        $ret = 0;
  720. X    }
  721. X
  722. X    # shut down our end of the socket
  723. X    &ftp'close_data_socket;
  724. X
  725. X    if( ! $ret ){
  726. X        return 0;
  727. X    }
  728. X
  729. X    return 1;
  730. X}
  731. X
  732. X# Quit from the remote ftp server
  733. X# return 1 if successful and 0 on failure
  734. Xsub ftp'quit
  735. X{
  736. X    local( $ret );
  737. X
  738. X    $site_command_check = 0;
  739. X    @site_command_list = ();
  740. X
  741. X    if( ! $ftp'service_open ){
  742. X        return 0;
  743. X    }
  744. X
  745. X    &ftp'send( "QUIT" );
  746. X
  747. X    $ret = &ftp'expect( $timeout, 
  748. X        221, 1 ); # transfer complete, closing connection
  749. X    if( $ret == 99 ){
  750. X        &service_closed();
  751. X        $ret = 0;
  752. X    }
  753. X    return $ret;
  754. X}
  755. X
  756. X# Support for ftp'read
  757. Xsub ftp'read_alarm
  758. X{
  759. X    die "timeout: read";
  760. X}
  761. X
  762. X# Support for ftp'read
  763. Xsub ftp'timed_read
  764. X{
  765. X    alarm( $timeout_read );
  766. X
  767. X    return sysread( NS, $ftpbuf, $ftpbufsize );
  768. X}
  769. X
  770. X# Do not use this routing use ftp'get
  771. Xsub ftp'read
  772. X{
  773. X    if( ! $ftp'service_open ){
  774. X        return -1;
  775. X    }
  776. X
  777. X    local( $ret ) = eval '&timed_read()';
  778. X    alarm( 0 );
  779. X
  780. X    if( $@ =~ /^timeout/ ){
  781. X        return -1;
  782. X    }
  783. X    return $ret;
  784. X}
  785. X
  786. Xsub ftp'dostrip
  787. X{
  788. X    ($strip_cr ) = @_;
  789. X}
  790. X
  791. X# Get a remote file back into a local file.
  792. X# If no loc_fname passed then uses rem_fname.
  793. X# returns 1 on success and 0 on failure
  794. Xsub ftp'get
  795. X{
  796. X    local($rem_fname, $loc_fname, $restart ) = @_;
  797. X    local( $ret );
  798. X    
  799. X    if( ! $ftp'service_open ){
  800. X        return 0;
  801. X    }
  802. X
  803. X    if( $loc_fname eq "" ){
  804. X        $loc_fname = $rem_fname;
  805. X    }
  806. X    
  807. X    if( ! &ftp'open_data_socket() ){
  808. X        print $ftp'showfd "Cannot open data socket\n";
  809. X        return 0;
  810. X    }
  811. X
  812. X    if( $loc_fname ne '-' ){
  813. X        # Find the size of the target file
  814. X        local( $restart_at ) = &ftp'filesize( $loc_fname );
  815. X        if( $restart && $restart_at > 0 && &ftp'restart( $restart_at ) ){
  816. X            $restart = 1;
  817. X            # Make sure the file can be updated
  818. X            chmod( 0644, $loc_fname );
  819. X        }
  820. X        else {
  821. X            $restart = 0;
  822. X            unlink( $loc_fname );
  823. X        }
  824. X    }
  825. X
  826. X    if( $ftp'mapunixout ){
  827. X        $rem_fname = eval "&$ftp'mapunixout( \$rem_fname, 'f' )";
  828. X    }
  829. X
  830. X    &ftp'send( "RETR $rem_fname" );
  831. X    
  832. X    $ret = &ftp'expect( $timeout, 
  833. X        150, 1 ); # receiving $rem_fname
  834. X    if( $ret == 99 ){
  835. X        &service_closed();
  836. X        $ret = 0;
  837. X    }
  838. X    if( $ret != 1 ){
  839. X        print $ftp'showfd "Failure on 'RETR $rem_fname' command\n";
  840. X
  841. X        # shut down our end of the socket
  842. X        &ftp'close_data_socket;
  843. X
  844. X        return 0;
  845. X    }
  846. X
  847. X    accept( NS, S ) || die "accept failed $!";
  848. X
  849. X    # 
  850. X    # the data should be coming at us now
  851. X    #
  852. X
  853. X    #
  854. X    #  open the local fname
  855. X    #  concatenate on the end if restarting, else just overwrite
  856. X    if( !open( FH, ($restart ? '>>' : '>') . $loc_fname ) ){
  857. X        print $ftp'showfd "Cannot create local file $loc_fname\n";
  858. X
  859. X        # shut down our end of the socket
  860. X        &ftp'close_data_socket;
  861. X
  862. X        return 0;
  863. X    }
  864. X
  865. X    local( $start_time ) = time;
  866. X    local( $bytes, $lasthash, $hashes ) = (0, 0, 0);
  867. X    local( $old_sig ) = $SIG{ 'ALRM' };
  868. X    $SIG{ 'ALRM' } = "ftp\'read_alarm";
  869. X    while( ($len = &ftp'read()) > 0 ){
  870. X        $bytes += $len;
  871. X        if( $strip_cr ){
  872. X            $ftp'ftpbuf =~ s/\r//g;
  873. X        }
  874. X        if( $ftp_show ){
  875. X            while( $bytes > ($lasthash + $ftp'hashevery) ){
  876. X                print $ftp'showfd '#';
  877. X                $lasthash += $ftp'hashevery;
  878. X                $hashes++;
  879. X                if( ($hashes % $ftp'hashnl) == 0 ){
  880. X                    print $ftp'showfd "\n";
  881. X                }
  882. X            }
  883. X        }
  884. X        if( ! print FH $ftp'ftpbuf ){
  885. X            print $ftp'showfd "\nfailed to write data";
  886. X            $bytes = -1;
  887. X            last;
  888. X        }
  889. X    }
  890. X    $SIG{ 'ALRM' } = $old_sig;
  891. X    close( FH );
  892. X
  893. X    # shut down our end of the socket
  894. X    &ftp'close_data_socket;
  895. X
  896. X    if( $len < 0 ){
  897. X        print $ftp'showfd "\ntimed out reading data!\n";
  898. X
  899. X        return 0;
  900. X    }
  901. X        
  902. X    if( $ftp_show && $bytes > 0 ){
  903. X        if( $hashes && ($hashes % $ftp'hashnl) != 0 ){
  904. X            print $ftp'showfd "\n";
  905. X        }
  906. X        local( $secs ) = (time - $start_time);
  907. X        if( $secs <= 0 ){
  908. X            $secs = 1; # To avoid a divide by zero;
  909. X        }
  910. X
  911. X        local( $rate ) = int( $bytes / $secs );
  912. X        print $ftp'showfd "Got $bytes bytes ($rate bytes/sec)\n";
  913. X    }
  914. X
  915. X    #
  916. X    # read the close
  917. X    #
  918. X
  919. X    $ret = &ftp'expect( $timeout, 
  920. X        2, 1 ); # transfer complete, closing connection
  921. X    if( $ret == 99 ){
  922. X        &service_closed();
  923. X        $ret = 0;
  924. X    }
  925. X
  926. X    if( $ret && $bytes < 0 ){
  927. X        $ret = 0;
  928. X    }
  929. X
  930. X    return $ret;
  931. X}
  932. X
  933. Xsub ftp'delete
  934. X{
  935. X    local( $rem_fname ) = @_;
  936. X    local( $ret );
  937. X
  938. X    if( ! $ftp'service_open ){
  939. X        return 0;
  940. X    }
  941. X
  942. X    if( $ftp'mapunixout ){
  943. X        $rem_fname = eval "&$ftp'mapunixout( \$rem_fname, 'f' )";
  944. X    }
  945. X
  946. X    &ftp'send( "DELE $rem_fname" );
  947. X
  948. X    $ret = &ftp'expect( $timeout, 
  949. X        250, 1 ); # Deleted $rem_fname
  950. X    if( $ret == 99 ){
  951. X        &service_closed();
  952. X        $ret = 0;
  953. X    }
  954. X
  955. X    return $ret == 1;
  956. X}
  957. X
  958. Xsub ftp'deldir
  959. X{
  960. X    local( $fname ) = @_;
  961. X
  962. X    # not yet implemented
  963. X    # RMD
  964. X}
  965. X
  966. X# UPDATE ME!!!!!!
  967. X# Add in the hash printing and newline conversion
  968. Xsub ftp'put
  969. X{
  970. X    local( $loc_fname, $rem_fname ) = @_;
  971. X    local( $strip_cr );
  972. X    
  973. X    if( ! $ftp'service_open ){
  974. X        return 0;
  975. X    }
  976. X
  977. X    if( $loc_fname eq "" ){
  978. X        $loc_fname = $rem_fname;
  979. X    }
  980. X    
  981. X    if( ! &ftp'open_data_socket() ){
  982. X        return 0;
  983. X    }
  984. X    
  985. X    if( $ftp'mapunixout ){
  986. X        $rem_fname = eval "&$ftp'mapunixout( \$rem_fname, 'f' )";
  987. X    }
  988. X
  989. X    &ftp'send( "STOR $rem_fname" );
  990. X    
  991. X    # 
  992. X    # the data should be coming at us now
  993. X    #
  994. X    
  995. X    local( $ret ) =
  996. X    &ftp'expect( $timeout, 
  997. X        150, 1 ); # sending $loc_fname
  998. X    if( $ret == 99 ){
  999. X        &service_closed();
  1000. X        $ret = 0;
  1001. X    }
  1002. X
  1003. X    if( $ret != 1 ){
  1004. X        # shut down our end of the socket
  1005. X        &ftp'close_data_socket;
  1006. X
  1007. X        return 0;
  1008. X    }
  1009. X
  1010. X
  1011. X    accept( NS, S ) || die "accept failed $!";
  1012. X
  1013. X    # 
  1014. X    # the data should be coming at us now
  1015. X    #
  1016. X    
  1017. X    #
  1018. X    #  open the local fname
  1019. X    #
  1020. X    if( !open( FH, "<$loc_fname" ) ){
  1021. X        print $ftp'showfd "Cannot open local file $loc_fname\n";
  1022. X
  1023. X        # shut down our end of the socket
  1024. X        &ftp'close_data_socket;
  1025. X
  1026. X        return 0;
  1027. X    }
  1028. X    
  1029. X    while( <FH> ){
  1030. X        if( ! $ftp'service_open ){
  1031. X            last;
  1032. X        }
  1033. X        print NS ;
  1034. X    }
  1035. X    close( FH );
  1036. X    
  1037. X    # shut down our end of the socket to signal EOF
  1038. X    &ftp'close_data_socket;
  1039. X    
  1040. X    #
  1041. X    # read the close
  1042. X    #
  1043. X    
  1044. X    $ret = &ftp'expect( $timeout, 
  1045. X        2, 1 ); # transfer complete, closing connection
  1046. X    if( $ret == 99 ){
  1047. X        &service_closed();
  1048. X        $ret = 0;
  1049. X    }
  1050. X    if( ! $ret ){
  1051. X        print $ftp'showfd "Failure on 'STOR $loc_fname' command\n";
  1052. X    }
  1053. X    return $ret;
  1054. X}
  1055. X
  1056. Xsub ftp'restart
  1057. X{
  1058. X    local( $restart_point, $ret ) = @_;
  1059. X
  1060. X    if( ! $ftp'service_open ){
  1061. X        return 0;
  1062. X    }
  1063. X
  1064. X    &ftp'send( "REST $restart_point" );
  1065. X
  1066. X    # 
  1067. X    # see what they say
  1068. X
  1069. X    $ret = &ftp'expect( $timeout, 
  1070. X        350, 1 );   # restarting at $restart_point
  1071. X    if( $ret == 99 ){
  1072. X        &service_closed();
  1073. X        $ret = 0;
  1074. X    }
  1075. X    return $ret;
  1076. X}
  1077. X
  1078. X# Set the file transfer type
  1079. Xsub ftp'type
  1080. X{
  1081. X    local( $type ) = @_;
  1082. X
  1083. X    if( ! $ftp'service_open ){
  1084. X        return 0;
  1085. X    }
  1086. X
  1087. X    &ftp'send( "TYPE $type" );
  1088. X
  1089. X    # 
  1090. X    # see what they say
  1091. X
  1092. X    $ret = &ftp'expect( $timeout, 
  1093. X        2, 1 ); # file type set to $type
  1094. X    if( $ret == 99 ){
  1095. X        &service_closed();
  1096. X        $ret = 0;
  1097. X    }
  1098. X    return $ret;
  1099. X}
  1100. X
  1101. X$site_command_check = 0;
  1102. X@site_command_list = ();
  1103. X
  1104. X# routine to query the remote server for 'SITE' commands supported
  1105. Xsub ftp'site_commands
  1106. X{
  1107. X    local( $ret );
  1108. X    
  1109. X    @site_command_list = ();
  1110. X    $site_command_check = 0;
  1111. X
  1112. X    if( ! $ftp'service_open ){
  1113. X        return @site_command_list;
  1114. X    }
  1115. X
  1116. X    # if we havent sent a 'HELP SITE', send it now
  1117. X    if( !$site_command_check ){
  1118. X    
  1119. X        $site_command_check = 1;
  1120. X    
  1121. X        &ftp'send( "HELP SITE" );
  1122. X    
  1123. X        # assume the line in the HELP SITE response with the 'HELP'
  1124. X        # command is the one for us
  1125. X        $ftp'keep_continuations = 1;
  1126. X        $ret = &ftp'expect( $timeout,
  1127. X            ".*HELP.*", 1 );
  1128. X        $ftp'keep_continuations = 0;
  1129. X        if( $ret == 99 ){
  1130. X            &service_closed();
  1131. X            return @site_command_list;
  1132. X        }
  1133. X    
  1134. X        if( $ret != 0 ){
  1135. X            print $ftp'showfd "No response from HELP SITE ($ret)\n" if( $ftp_show );
  1136. X        }
  1137. X    
  1138. X        @site_command_list = split(/\s+/, $ftp'response);
  1139. X    }
  1140. X    
  1141. X    return @site_command_list;
  1142. X}
  1143. X
  1144. X# return the pwd, or null if we can't get the pwd
  1145. Xsub ftp'pwd
  1146. X{
  1147. X    local( $ret, $cwd );
  1148. X
  1149. X    if( ! $ftp'service_open ){
  1150. X        return 0;
  1151. X    }
  1152. X
  1153. X    &ftp'send( "PWD" );
  1154. X
  1155. X    # 
  1156. X    # see what they say
  1157. X
  1158. X    $ret = &ftp'expect( $timeout, 
  1159. X        2, 1 ); # working dir is
  1160. X    if( $ret == 99 ){
  1161. X        &service_closed();
  1162. X        $ret = 0;
  1163. X    }
  1164. X    if( $ret ){
  1165. X        if( $ftp'response =~ /^2\d\d\s*"(.*)"\s.*$/ ){
  1166. X            $cwd = $1;
  1167. X        }
  1168. X    }
  1169. X    return $cwd;
  1170. X}
  1171. X
  1172. X# return 1 for success, 0 for failure
  1173. Xsub ftp'mkdir
  1174. X{
  1175. X    local( $path ) = @_;
  1176. X    local( $ret );
  1177. X
  1178. X    if( ! $ftp'service_open ){
  1179. X        return 0;
  1180. X    }
  1181. X
  1182. X    if( $ftp'mapunixout ){
  1183. X        $path = eval "&$ftp'mapunixout( \$path, 'f' )";
  1184. X    }
  1185. X
  1186. X    &ftp'send( "MKD $path" );
  1187. X
  1188. X    # 
  1189. X    # see what they say
  1190. X
  1191. X    $ret = &ftp'expect( $timeout, 
  1192. X        257, 1 ); # made directory $path
  1193. X    if( $ret == 99 ){
  1194. X        &service_closed();
  1195. X        $ret = 0;
  1196. X    }
  1197. X    return $ret;
  1198. X}
  1199. X
  1200. X# return 1 for success, 0 for failure
  1201. Xsub ftp'chmod
  1202. X{
  1203. X    local( $path, $mode ) = @_;
  1204. X    local( $ret );
  1205. X
  1206. X    if( ! $ftp'service_open ){
  1207. X        return 0;
  1208. X    }
  1209. X
  1210. X    if( $ftp'mapunixout ){
  1211. X        $path = eval "&$ftp'mapunixout( \$path, 'f' )";
  1212. X    }
  1213. X
  1214. X    &ftp'send( sprintf( "SITE CHMOD %o $path", $mode ) );
  1215. X
  1216. X    # 
  1217. X    # see what they say
  1218. X
  1219. X    $ret = &ftp'expect( $timeout, 
  1220. X        2, 1 ); # chmod $mode $path succeeded
  1221. X    if( $ret == 99 ){
  1222. X        &service_closed();
  1223. X        $ret = 0;
  1224. X    }
  1225. X    return $ret;
  1226. X}
  1227. X
  1228. X# rename a file
  1229. Xsub ftp'rename
  1230. X{
  1231. X    local( $old_name, $new_name ) = @_;
  1232. X    local( $ret );
  1233. X
  1234. X    if( ! $ftp'service_open ){
  1235. X        return 0;
  1236. X    }
  1237. X
  1238. X    if( $ftp'mapunixout ){
  1239. X        $old_name = eval "&$ftp'mapunixout( \$old_name, 'f' )";
  1240. X    }
  1241. X
  1242. X    &ftp'send( "RNFR $old_name" );
  1243. X
  1244. X    # 
  1245. X    # see what they say
  1246. X
  1247. X    $ret = &ftp'expect( $timeout, 
  1248. X        350, 1 ); #  OK
  1249. X    if( $ret == 99 ){
  1250. X        &service_closed();
  1251. X        $ret = 0;
  1252. X    }
  1253. X
  1254. X    # check if the "rename from" occurred ok
  1255. X    if( $ret ){
  1256. X        if( $ftp'mapunixout ){
  1257. X            $new_name = eval "&$ftp'mapunixout( \$new_name, 'f' )";
  1258. X        }
  1259. X
  1260. X        &ftp'send( "RNTO $new_name" );
  1261. X    
  1262. X        # 
  1263. X        # see what they say
  1264. X    
  1265. X        $ret = &ftp'expect( $timeout, 
  1266. X            250, 1 );  # rename $old_name to $new_name
  1267. X        if( $ret == 99 ){
  1268. X            &service_closed();
  1269. X            $ret = 0;
  1270. X        }
  1271. X    }
  1272. X
  1273. X    return $ret;
  1274. X}
  1275. X
  1276. X
  1277. Xsub ftp'quote
  1278. X{
  1279. X    local( $cmd ) = @_;
  1280. X    local( $ret );
  1281. X
  1282. X    if( ! $ftp'service_open ){
  1283. X        return 0;
  1284. X    }
  1285. X
  1286. X    &ftp'send( $cmd );
  1287. X
  1288. X    $ret = &ftp'expect( $timeout, 
  1289. X        2, 1 ); # Remote '$cmd' OK
  1290. X    if( $ret == 99 ){
  1291. X        &service_closed();
  1292. X        $ret = 0;
  1293. X    }
  1294. X    return $ret;
  1295. X}
  1296. X
  1297. X# ------------------------------------------------------------------------------
  1298. X# These are the lower level support routines
  1299. X
  1300. Xsub ftp'expectgot
  1301. X{
  1302. X    ($ftp'resp, $ftp'fatalerror) = @_;
  1303. X    if( $ftp_show ){
  1304. X        print $ftp'showfd "$ftp'resp\n";
  1305. X    }
  1306. X    if( $ftp'keep_continuations ){
  1307. X        $ftp'response .= $ftp'resp;
  1308. X    }
  1309. X    else {
  1310. X        $ftp'response = $ftp'resp;
  1311. X    }
  1312. X}
  1313. X
  1314. X#
  1315. X#  create the list of parameters for chat'expect
  1316. X#
  1317. X#  ftp'expect( time_out, {value, return value} );
  1318. X#  the last response is stored in $ftp'response
  1319. X#
  1320. Xsub ftp'expect
  1321. X{
  1322. X    local( $ret );
  1323. X    local( $time_out );
  1324. X    local( @expect_args );
  1325. X    local( $code, $pre );
  1326. X    
  1327. X    $ftp'response = '';
  1328. X    $ftp'fatalerror = 0;
  1329. X
  1330. X    $time_out = shift( @_ );
  1331. X    
  1332. X    if( $drop_on_421 ){
  1333. X        # Handle 421 specially - has to go first in case a pattern
  1334. X        # matches on a generic 4.. response
  1335. X        push( @expect_args, "[.|\n]*^(421 .*)\\015\\n" );
  1336. X        push( @expect_args, "&expectgot( \$1, 0 ); 99" );
  1337. X    }
  1338. X
  1339. X    # Match any obvious continuations.
  1340. X    push( @expect_args, "[.|\n]*^(\\d\\d\\d-.*|[^\\d].*)\\015\\n" );
  1341. X    push( @expect_args, "&expectgot( \$1, 0 ); 100" );
  1342. X
  1343. X    while( @_ ){
  1344. X        $code = shift( @_ );
  1345. X        $pre = '^';
  1346. X        $post = ' ';
  1347. X        if( $code =~ /^\d\d+$/ ){
  1348. X            $pre = "[.|\n]*^";
  1349. X        }
  1350. X        elsif( $code =~ /^\d$/ ){
  1351. X            $pre = "[.|\n]*^";
  1352. X            $post = '\d\d ';
  1353. X        }
  1354. X        push( @expect_args, "$pre(" . $code . $post . ".*)\\015\\n" );
  1355. X        push( @expect_args,
  1356. X            "&expectgot( \$1, 0 ); " . shift( @_ ) );
  1357. X    }
  1358. X    # Match any numeric response codes not explicitly looked for.
  1359. X    push( @expect_args, "[.|\n]*^(\\d\\d\\d .*)\\015\\n" );
  1360. X    push( @expect_args, "&expectgot( \$1, 0 ); 0" );
  1361. X    
  1362. X    # Treat all unrecognised lines as continuations
  1363. X    push( @expect_args, "^(.*)\\015\\n" );
  1364. X    push( @expect_args, "&expectgot( \$1, 0 ); 100" );
  1365. X    
  1366. X    # add patterns TIMEOUT and EOF
  1367. X    push( @expect_args, 'TIMEOUT' );
  1368. X    push( @expect_args, "&expectgot( 'timed out', 0 ); 0" );
  1369. X    push( @expect_args, 'EOF' );
  1370. X    push( @expect_args, "&expectgot( 'remote server gone away', 1 ); 99" );
  1371. X    
  1372. X    # if we see a continuation line, wait for the real info
  1373. X    $ret = 100;
  1374. X    while( $ret == 100 ){
  1375. X        if( $ftp_show > 9 ){
  1376. X            &printargs( $time_out, @expect_args );
  1377. X        }
  1378. X        $ret = &chat'expect( $time_out, @expect_args );
  1379. X    }
  1380. X
  1381. X    return $ret;
  1382. X}
  1383. X
  1384. X
  1385. X#
  1386. X#  opens NS for io
  1387. X#
  1388. Xsub ftp'open_data_socket
  1389. X{
  1390. X    local( $sockaddr, $port );
  1391. X    local( $type, $myaddr, $a, $b, $c, $d );
  1392. X    local( $mysockaddr, $family, $hi, $lo );
  1393. X    
  1394. X    $sockaddr = 'S n a4 x8';
  1395. X
  1396. X    ($a,$b,$c,$d) = unpack( 'C4', $chat'thisaddr );
  1397. X    $this = $chat'thisproc;
  1398. X    
  1399. X    socket( S, $pf_inet, $sock_stream, $tcp_proto ) || die "socket: $!";
  1400. X    bind( S, $this ) || die "bind: $!";
  1401. X    
  1402. X    # get the port number
  1403. X    $mysockaddr = getsockname( S );
  1404. X    ($family, $port, $myaddr) = unpack( $sockaddr, $mysockaddr );
  1405. X    
  1406. X    $hi = ($port >> 8) & 0x00ff;
  1407. X    $lo = $port & 0x00ff;
  1408. X    
  1409. X    #
  1410. X    # we MUST do a listen before sending the port otherwise
  1411. X    # the PORT may fail
  1412. X    #
  1413. X    listen( S, 5 ) || die "listen";
  1414. X    
  1415. X    &ftp'send( "PORT $a,$b,$c,$d,$hi,$lo" );
  1416. X    
  1417. X    return &ftp'expect( $timeout,
  1418. X        2, 1 ); # PORT command successful
  1419. X}
  1420. X    
  1421. Xsub ftp'close_data_socket
  1422. X{
  1423. X    close( NS );
  1424. X}
  1425. X
  1426. Xsub ftp'send
  1427. X{
  1428. X    local( $send_cmd ) = @_;
  1429. X
  1430. X    if( $send_cmd =~ /\n/ ){
  1431. X        print $ftp'showfd "ERROR, \\n in send string for $send_cmd\n";
  1432. X    }
  1433. X    
  1434. X    if( $ftp_show ){
  1435. X        local( $sc ) = $send_cmd;
  1436. X
  1437. X        if( $send_cmd =~ /^PASS/){
  1438. X            $sc = "PASS <somestring>";
  1439. X        }
  1440. X        print $ftp'showfd "---> $sc\n";
  1441. X    }
  1442. X    
  1443. X    &chat'print( "$send_cmd\r\n" );
  1444. X}
  1445. X
  1446. Xsub ftp'printargs
  1447. X{
  1448. X    while( @_ ){
  1449. X        print $ftp'showfd shift( @_ ) . "\n";
  1450. X    }
  1451. X}
  1452. X
  1453. Xsub ftp'filesize
  1454. X{
  1455. X    local( $fname ) = @_;
  1456. X
  1457. X    if( ! -f $fname ){
  1458. X        return -1;
  1459. X    }
  1460. X
  1461. X    return (stat( _ ))[ 7 ];
  1462. X    
  1463. X}
  1464. X
  1465. X# Reply codes, see RFC959:
  1466. X# 1yz Positive Preliminary.  Expect another reply before proceeding
  1467. X# 2yz Positive Completion.
  1468. X# 3yz Positive Intermediate. More information required.
  1469. X# 4yz Transient Negative Completion.  The user should try again.
  1470. X# 5yz Permanent Negative Completion.
  1471. X# x0z Syntax error
  1472. X# x1z Information
  1473. X# x2z Connection - control info.
  1474. X# x3z Authentication and accounting.
  1475. X# x4z Unspecified
  1476. X# x5z File system.
  1477. X
  1478. X# 110 Restart marker reply.
  1479. X#     In this case, the text is exact and not left to the
  1480. X#     particular implementation; it must read:
  1481. X#     MARK yyyy = mmmm
  1482. X#     Where yyyy is User-process data stream marker, and mmmm
  1483. X#     server's equivalent marker (note the spaces between markers
  1484. X#     and "=").
  1485. X# 120 Service ready in nnn minutes.
  1486. X# 125 Data connection already open; transfer starting.
  1487. X# 150 File status okay; about to open data connection.
  1488. X
  1489. X# 200 Command okay.
  1490. X# 202 Command not implemented, superfluous at this site.
  1491. X# 211 System status, or system help reply.
  1492. X# 212 Directory status.
  1493. X# 213 File status.
  1494. X# 214 Help message.
  1495. X#     On how to use the server or the meaning of a particular
  1496. X#     non-standard command.  This reply is useful only to the
  1497. X#     human user.
  1498. X# 215 NAME system type.
  1499. X#     Where NAME is an official system name from the list in the
  1500. X#     Assigned Numbers document.
  1501. X# 220 Service ready for new user.
  1502. X# 221 Service closing control connection.
  1503. X#     Logged out if appropriate.
  1504. X# 225 Data connection open; no transfer in progress.
  1505. X# 226 Closing data connection.
  1506. X#     Requested file action successful (for example, file
  1507. X#     transfer or file abort).
  1508. X# 227 Entering Passive Mode (h1,h2,h3,h4,p1,p2).
  1509. X# 230 User logged in, proceed.
  1510. X# 250 Requested file action okay, completed.
  1511. X# 257 "PATHNAME" created.
  1512. X
  1513. X# 331 User name okay, need password.
  1514. X# 332 Need account for login.
  1515. X# 350 Requested file action pending further information.
  1516. X
  1517. X# 421 Service not available, closing control connection.
  1518. X#     This may be a reply to any command if the service knows it
  1519. X#     must shut down.
  1520. X# 425 Can't open data connection.
  1521. X# 426 Connection closed; transfer aborted.
  1522. X# 450 Requested file action not taken.
  1523. X#     File unavailable (e.g., file busy).
  1524. X# 451 Requested action aborted: local error in processing.
  1525. X# 452 Requested action not taken.
  1526. X#     Insufficient storage space in system.
  1527. X
  1528. X# 500 Syntax error, command unrecognized.
  1529. X#     This may include errors such as command line too long.
  1530. X# 501 Syntax error in parameters or arguments.
  1531. X# 502 Command not implemented.
  1532. X# 503 Bad sequence of commands.
  1533. X# 504 Command not implemented for that parameter.
  1534. X# 530 Not logged in.
  1535. X# 532 Need account for storing files.
  1536. X# 550 Requested action not taken.
  1537. X#     File unavailable (e.g., file not found, no access).
  1538. X# 551 Requested action aborted: page type unknown.
  1539. X# 552 Requested file action aborted.
  1540. X#     Exceeded storage allocation (for current directory or
  1541. X#     dataset).
  1542. X# 553 Requested action not taken.
  1543. X#     File name not allowed.
  1544. X
  1545. X
  1546. X# make this package return true
  1547. X1;
  1548. END_OF_FILE
  1549.   if test 24614 -ne `wc -c <'ftp.pl'`; then
  1550.     echo shar: \"'ftp.pl'\" unpacked with wrong size!
  1551.   fi
  1552.   # end of 'ftp.pl'
  1553. fi
  1554. if test -f 'pp_mailfilter' -a "${1}" != "-c" ; then 
  1555.   echo shar: Will not clobber existing file \"'pp_mailfilter'\"
  1556. else
  1557.   echo shar: Extracting \"'pp_mailfilter'\" \(246 characters\)
  1558.   sed "s/^X//" >'pp_mailfilter' <<'END_OF_FILE'
  1559. X# Default path is only /vol/pp/bin
  1560. X# Under MMDF path contained $HOME, hence /homes/info-server
  1561. XPATH="/vol/pp/bin:/homes/info-server:/usr/local/bin:/usr/ucb/bin:/usr/bin";
  1562. X
  1563. Xif( !delivered ){
  1564. X    pipe "/src.doc.ic.ac.uk/public/ic.doc/ftpmail/q.pl";
  1565. X}
  1566. END_OF_FILE
  1567.   if test 246 -ne `wc -c <'pp_mailfilter'`; then
  1568.     echo shar: \"'pp_mailfilter'\" unpacked with wrong size!
  1569.   fi
  1570.   # end of 'pp_mailfilter'
  1571. fi
  1572. if test -f 'q.pl' -a "${1}" != "-c" ; then 
  1573.   echo shar: Will not clobber existing file \"'q.pl'\"
  1574. else
  1575.   echo shar: Extracting \"'q.pl'\" \(17435 characters\)
  1576.   sed "s/^X//" >'q.pl' <<'END_OF_FILE'
  1577. X#!/usr/bin/perl -s
  1578. X# Very simple ftpmail system
  1579. X# Queue a transfer to be done
  1580. X# By Lee McLoughlin <lmjm@doc.ic.ac.uk>
  1581. X#  You can do what you like with this except claim that you wrote it or
  1582. X#  give copies with changes not approved by Lee.  Neither Lee nor any other
  1583. X#  organisation can be held liable for any problems caused by the use or
  1584. X#  storage of this package.
  1585. X#
  1586. X# $Header: /a/swan/home/swan/staff/csg/lmjm/src/perl/mirror/src/ftpmail/RCS/q.pl,v 1.23 1994/07/06 14:56:38 lmjm Exp lmjm $
  1587. X# $Log: q.pl,v $
  1588. X# Revision 1.23  1994/07/06  14:56:38  lmjm
  1589. X# Allow for use of vrfy.
  1590. X# Skip leading rubbish and whitespace at the start of commands.
  1591. X# Give each job a priority.
  1592. X# Report queue size back to users.
  1593. X#
  1594. X# Revision 1.22  1994/05/02  18:10:49  lmjm
  1595. X# Switched to rfc822 parsing.
  1596. X#
  1597. X# Revision 1.21  1994/02/16  22:33:49  lmjm
  1598. X# Ignore message body till start of job found.
  1599. X# Check errors in correct order (patch was email to me but lost name).
  1600. X#
  1601. X# Revision 1.20  1993/12/14  10:40:14  lmjm
  1602. X# Try to ignore extra block of mail headers at start of job.
  1603. X# Allow for more ways to write reply-to.
  1604. X# Check for size argument.
  1605. X# Make sure patterns containing an @ have a \ in front.
  1606. X#
  1607. X# Revision 1.19  1993/06/17  18:18:10  lmjm
  1608. X# Version upgrade
  1609. X#
  1610. X# Revision 1.18  1993/06/17  09:58:33  lmjm
  1611. X# Version upgrade.
  1612. X#
  1613. X# Revision 1.17  1993/06/16  20:45:22  lmjm
  1614. X# Dont allow ' if not using sendmail.
  1615. X#
  1616. X# Revision 1.16  1993/05/13  21:23:35  lmjm
  1617. X# Corrected btoa_it use in dq.pl
  1618. X#
  1619. X# Revision 1.15  1993/05/12  11:14:50  lmjm
  1620. X# Upgraded support.pl
  1621. X#
  1622. X# Revision 1.14  1993/05/11  20:07:57  lmjm
  1623. X# Optionally ban connection to a.b.c.d type addresses
  1624. X#
  1625. X# Revision 1.13  1993/05/07  19:05:52  lmjm
  1626. X# Added Chris's fixed not_ok code.
  1627. X#
  1628. X# Revision 1.12  1993/04/28  18:19:20  lmjm
  1629. X# Handle size suffix correctly.
  1630. X#
  1631. X# Revision 1.11  1993/04/25  20:27:55  lmjm
  1632. X# Cut new release
  1633. X#
  1634. X# Revision 1.10  1993/04/25  14:15:11  lmjm
  1635. X# Allow for multiple help files (one per language).
  1636. X#
  1637. X# Revision 1.9  1993/04/23  23:27:07  lmjm
  1638. X# Massive renaming for sys5.
  1639. X# Also shrink qfile names.
  1640. X# Correct handling of <> on input.
  1641. X#
  1642. X# Revision 1.8  1993/04/23  20:03:17  lmjm
  1643. X# Use own version of library routines before others.
  1644. X#
  1645. X# Revision 1.7  1993/04/23  17:23:40  lmjm
  1646. X# Renamed ftpmail-local-config.pl to ftpmail-config.pl
  1647. X# Made pathnames relative to $ftpmail_dir.
  1648. X# Allow for some leeway in the max_cmds thing.
  1649. X# Look out for $ftpmail_response in the headers.
  1650. X# Fail if no reply_to in the headers.
  1651. X# Keep copies of input if they have peculiar errors.
  1652. X# If prematute end of input - check if the user is just after help.
  1653. X# Allow for 'reply to email'
  1654. X# Log change of reply_to in the job.
  1655. X# Added corrections from Wolf + his not-auth code..
  1656. X# Correct problem with 'no option' handling.
  1657. X#
  1658. X# Revision 1.6  1993/04/21  10:58:40  lmjm
  1659. X# Smarter mail header parsing by andy.linton@comp.vuw.ac.nz
  1660. X#
  1661. X# Revision 1.5  1993/04/20  20:15:40  lmjm
  1662. X# Added delete option.
  1663. X#
  1664. X# Revision 1.4  1993/04/13  10:34:38  lmjm
  1665. X# Tailored help variables.
  1666. X# Cleanup where necessary.
  1667. X# Allowed for a help command.
  1668. X# Corrected size option.
  1669. X#
  1670. X# Revision 1.3  1993/03/30  20:32:22  lmjm
  1671. X# Must have an ftpmail account whose home directory everything is in.
  1672. X# New -test option that uses /tmp/ftpmail-test
  1673. X# Added better error handling.
  1674. X#
  1675. X# Revision 1.2  1993/03/23  21:40:14  lmjm
  1676. X# Now use ftpmail home directory.
  1677. X# Cleanup tmp files when there are problem
  1678. X#
  1679. X
  1680. X$ftpmail = 'ftpmail';
  1681. X
  1682. X$Revision = '$Revision: 1.23 $';
  1683. X
  1684. Xif( $test ){
  1685. X    $ftpmail_dir = '/usr/tmp/ftpmail-test';
  1686. X}
  1687. Xelse {
  1688. X    # The ftpmail_dir is the home directory of ftpmail.
  1689. X    $ftpmail_dir = (getpwnam( $ftpmail ))[ 7 ];
  1690. X}
  1691. X
  1692. Xif( ! $ftpmail_dir ){
  1693. X    die "No home directory for ftpmail\n";
  1694. X}
  1695. X
  1696. Xif( ! -d $ftpmail_dir ){
  1697. X    die "no such directory as $ftpmail_dir\n";
  1698. X}
  1699. X
  1700. Xchdir( $ftpmail_dir ) || die "cannot chdir to $ftpmail_dir\n";
  1701. X
  1702. X# All the auxillary scripts come from ftpmail's home dir.
  1703. Xunshift( @INC, '.' );
  1704. X
  1705. Xrequire 'config.pl';
  1706. Xrequire 'support.pl';
  1707. Xrequire 'rfc822.pl';
  1708. X
  1709. X# It is more meaningful for the user to say 1 but in here zero is
  1710. X# more useful.
  1711. X$max_dqs--;
  1712. X
  1713. X# Don't leave files around writable
  1714. Xumask( 077 );
  1715. X
  1716. X$quenum = time();
  1717. X# Lop off the first bit to try and keep the namelen
  1718. X# small enough for system 5.
  1719. X$quenum =~ s/^....//;
  1720. X# If you change this keep the format as: \d+\.\d+
  1721. X# The T, for temporary, will be replaced by the priority.
  1722. X$qfile = "$quedir/T$quenum.$$";
  1723. X
  1724. X# No route: a pattern that doesn't match routes
  1725. X$nr = '[^@!%]+';
  1726. X
  1727. X# Match any ftpmail command.  (Don't match too much of the line
  1728. X# or error handling is much harder.
  1729. X$command = "^\\s*((reply(-|_)to|reply)(\\s+to)?\\s|delete\\s|help|open|connect|(cd|chdir)\\s|ls|dir|get\\s|binary|ascii|mode\\s|compress|gzip|uuencode|btoa|mime|vvencode|no|force|size\\s|quit|close)";
  1730. X
  1731. X# Copy of incoming data - keep all the header and the first lump of cmds
  1732. X$input_copy = "$incopydir/in$$";
  1733. Xopen( INCOPY, ">$input_copy" ) || &fatal( "Cannot create $input_copy" );
  1734. X$cmd_lines = 0;
  1735. X$in_body = 0;
  1736. X$toomany = 0;
  1737. Xwhile( <> ){
  1738. X    print INCOPY;
  1739. X    if( /^$/ ){
  1740. X        $in_body = 1;
  1741. X        next;
  1742. X    }
  1743. X    if( ! $in_body ){
  1744. X        next;
  1745. X    }
  1746. X    if( /^\s/ || /^\S+\s*:/ ){
  1747. X        next;
  1748. X    }
  1749. X    # Some mailers send an extra block of mail headers at the start
  1750. X    # of the job.
  1751. X    if( ! /$command/io ){
  1752. X        next;
  1753. X    }
  1754. X    # allow for some leeway in the max_cmds thing.
  1755. X    if( $cmd_lines++ > ($max_cmds +5) ){
  1756. X        $toomany = 1;
  1757. X    }
  1758. X}
  1759. Xclose( INCOPY );
  1760. X
  1761. Xopen( INCOPY, $input_copy ) || &fatal( "Cannot reopen $input_copy" );
  1762. X
  1763. X&read_auth();
  1764. X
  1765. X# Parse the email header to see who sent this message
  1766. X# (This clever bit of code by andy.linton@comp.vuw.ac.nz based on a posting
  1767. X#  by Larry Wall.)
  1768. X$/ = "";            # paragraph mode
  1769. X$* = 1;                # multi-line pattern matching
  1770. X$_ = <INCOPY>;            # read one paragraph
  1771. Xchop( $_ );            # Chop newline ending the paragraph
  1772. X
  1773. X# Should I ignore this?
  1774. Xif( /$ftpmail_response/ ){
  1775. X    &log( "Input contains '$ftpmail_response', ignoring file" );
  1776. X    &cleanexit();
  1777. X}
  1778. X
  1779. Xs/\n[ \t]+/ /g;            # join multi-line entries
  1780. Xs/^reply-to/Reply-To/ig;    # Fix up case on header keys
  1781. Xs/^from/From/ig;
  1782. Xs/^sender/Sender-to/ig;
  1783. X%head = ('PRESTUFF', split( /^(\S+):\s*/ )); # split on entry names
  1784. X$reply_to = $head{ 'Reply-To' } || $head{ 'From' } || $head{ 'Sender' };
  1785. Xchop( $reply_to );        # strip newline
  1786. X
  1787. X$/ = "\n";            # line mode
  1788. X$* = 0;                # single line pattern matching
  1789. X
  1790. Xif( ! $reply_to ){
  1791. X    &log( "No reply_to found in message $input_copy" );
  1792. X    # Force a copy to be kept
  1793. X    $cleanup = 0;
  1794. X    &cleanexit();
  1795. X}
  1796. X
  1797. Xif( $dumb_mailer ){
  1798. X    &dumb_fix_reply_to( $reply_to );
  1799. X}
  1800. X
  1801. Xif( $reply_to =~ /'/ && $mail_cmd !~ /sendmail/ ){
  1802. X    &log( "reply_to: $reply_to contains a quote - cannot cope with this without sendmail" );
  1803. X    &cleanexit();
  1804. X}
  1805. X
  1806. X$reply_to = &rfc822'first_addr_spec( $reply_to );
  1807. X$reply_to = &rfc822'uncomment( $reply_to );
  1808. Xif( $dont_reply_to && $reply_to =~ /$dont_reply_to/i ){
  1809. X    &log( "reply_to: $reply_to in dont_reply_to pattern: $dont_reply_to, ignoring" );
  1810. X    &cleanexit();
  1811. X}
  1812. X
  1813. Xif( $vrfy ){
  1814. X    &log( "vrfy $reply_to" );
  1815. X    if( system( "$vrfy -s -c 30 -t 120 $reply_to" ) != 0 ){
  1816. X        &log( "vrfy $reply_to failed, ignoring" );
  1817. X        &cleanexit();
  1818. X    }
  1819. X}
  1820. X
  1821. X
  1822. Xif( eof ){
  1823. X    # Maybe this is an attempt to get help?
  1824. X    local( $subject ) =  $head{ 'Subject' };
  1825. X    if( $subject =~ /help(\s+french)?/ ){
  1826. X        &mail_back( "help$1" );
  1827. X    }
  1828. X    # No point in going any further
  1829. X    &log( "Premature end of input $input_copy" );
  1830. X    # Force a copy to be kept
  1831. X    $cleanup = 0;
  1832. X    &cleanexit();
  1833. X}
  1834. X
  1835. Xif( $toomany ){
  1836. X    &mail_back( "there are too many commands in your job, the limit is $max_cmds" );
  1837. X}
  1838. X
  1839. X# Anything to actually transfer?
  1840. X$work = 0;
  1841. X
  1842. X# Process lines
  1843. Xwhile( <INCOPY> ){
  1844. X    if( /$ftpmail_response/ ){
  1845. X        &log( "Input contains '$ftpmail_response', ignoring file" );
  1846. X        &cleanexit();
  1847. X    }
  1848. X    # Some mailers send an extra block of mail headers at the start
  1849. X    # of the job so ignore everything not an ftpmail command.
  1850. X    if( ! /$command/io ){
  1851. X        next;
  1852. X    }
  1853. X    if( /^\s*(reply(-|_)to|reply)(\s+to)?(\s+(.+))?/i ){
  1854. X        local( $full, $addr ) = ($4, $5);
  1855. X        if( $full =~ /^\s*$/ ){
  1856. X            &mail_back( "reply-to needs an argument of who to send replies to" );
  1857. X        }
  1858. X        $new_reply_to = $addr;
  1859. X        if( ! $new_reply_to ){
  1860. X            &log( "tried to reset reply_to to nothing, ignored"  );
  1861. X        }
  1862. X        else {
  1863. X            $reply_to = $new_reply_to;
  1864. X            &log( "reply_to reset to $reply_to" );
  1865. X        }
  1866. X        next;
  1867. X    }
  1868. X
  1869. X    if( /^\s*delete\s+(.*)/ ){
  1870. X        $delete = $1;
  1871. X        last;
  1872. X    }
  1873. X
  1874. X    if( /^\s*help(\s+\S+)?/ ){
  1875. X        $help = "help$1";
  1876. X        last;
  1877. X    }
  1878. X    
  1879. X    if( /^\s*(open|connect)(\s+(\S+))?(\s+(\S+))?(\s+(\S+))?/i ){
  1880. X        if( $site ){
  1881. X            &mail_back( "Cannot have multiple open's" );
  1882. X        }
  1883. X        ($site, $user, $pass ) = ($3, $5, $7);
  1884. X        if( $site eq ''){
  1885. X            $site = $default_site;
  1886. X        }
  1887. X        if( $fqdn_only && $site =~ /^\d+\.\d+\.\d+\.\d+$/ ){
  1888. X            &mail_back( "Cannot ftp you may only use the NAME for the host to connect to" );
  1889. X        }
  1890. X        if( $ftp_permitted && $site !~ /$ftp_permitted/ ){
  1891. X            &mail_back( "Cannot ftp to that site only sites matching $ftp_permitted are allowed" );
  1892. X        }
  1893. X        push( @comms, "open $site" );
  1894. X        if( $user eq '' ){
  1895. X            $user = 'anonymous';
  1896. X        }
  1897. X        if( $pass eq '' ){
  1898. X            $pass = $reply_to;
  1899. X            $pass .= "@".$hostname unless $pass =~ /\@/;
  1900. X
  1901. X        }
  1902. X        if( ! $restricted ){
  1903. X            push( @comms, "user $user" );
  1904. X            push( @comms, "pass $pass" );
  1905. X        }
  1906. X        else {
  1907. X            push( @comms, "user anonymous" );
  1908. X            $pass = "ftpmail/$pass" unless $pass =~ /^ftpmail\//;
  1909. X            $pass =~ s,^ftpmail/-,-ftpmail/,;
  1910. X            push( @comms, "pass $pass" );
  1911. X        }
  1912. X    }
  1913. X    elsif( /^\s*(cd|chdir)(\s+(.+))?/i ){
  1914. X        if( $2 =~ /^\s*$/ ){
  1915. X            &mail_back( "chdir needs an argument of which directory to move to" );
  1916. X        }
  1917. X        push( @comms, "cd $3" );
  1918. X    }
  1919. X    elsif( /^\s*ls\s*(.*)/i ){
  1920. X        push( @comms, "ls $1" );
  1921. X        $work = 1;
  1922. X    }
  1923. X    elsif( /^\s*dir\s*(.*)/i ){
  1924. X        push( @comms, "dir $1" );
  1925. X        $work = 1;
  1926. X    }
  1927. X    elsif( /^\s*get(\s+(.+))?/i ){
  1928. X        if( $1 =~ /^\s*$/ ){
  1929. X            &mail_back( "get needs an argument of which file to get" );
  1930. X        }
  1931. X        push( @comms, "get $2" );
  1932. X        $work = 1;
  1933. X    }
  1934. X    elsif( /^\s*binary/i ){
  1935. X        push( @comms, "mode binary" );
  1936. X    }
  1937. X    elsif( /^\s*ascii/i ){
  1938. X        push( @comms, "mode ascii" );
  1939. X    }
  1940. X    elsif( /^\s*mode(\s+(binary|ascii))?\s*/i ){
  1941. X        if( $1 =~ /^\s*$/ ){
  1942. X            &mail_back( "mode needs an argument of either binary or ascii" );
  1943. X        }
  1944. X        push( @comms, "mode $2" );
  1945. X    }
  1946. X    elsif( /^\s*(compress|gzip|uuencode|btoa|mime|vvencode)(\s+no)?\s*$/i ){
  1947. X        local( $what, $yea_nay ) = ($1, $2);
  1948. X        local( $no ) = '';
  1949. X        if( $yea_nay =~ /no/i ){
  1950. X            $no = ' no';
  1951. X        }
  1952. X        push( @comms, "$what$no" );
  1953. X    }
  1954. X    elsif( /^\s*(no)\s*(compress|gzip|uuencode|btoa|mime|vvencode)\s*$/i ){
  1955. X        local( $yea_nay, $what ) = ($1, $2);
  1956. X        local( $no ) = '';
  1957. X        if( $yea_nay =~ /no/i ){
  1958. X            $no = ' no';
  1959. X        }
  1960. X        push( @comms, "$what$no" );
  1961. X    }
  1962. X    elsif( /^\s*force(\s+(compress|gzip|uuencode|btoa|mime|vvencode)\s*)?$/i ){
  1963. X        local( $full, $what ) = ($1, $2);
  1964. X        if( $full =~ /^\s*$/ ){
  1965. X            &mail_back( "force needs an argument of one of: compress gzip uuencode btoa mime" );
  1966. X        }
  1967. X         push( @comms, "force $what" );
  1968. X    }
  1969. X    elsif( /^\s*size\s+(\d+)?\s*(k|b|m)?\s*$/i ){
  1970. X        local( $size, $kind ) = ($1, $2);
  1971. X        if( $size eq '' ){
  1972. X            &mail_back( "size needs a number argument optionally followed by k, b or m" );
  1973. X        }
  1974. X        if( $kind =~ /[mM]/ ){
  1975. X            $size *= (1024*1024);
  1976. X        }
  1977. X        elsif( $kind =~ /[bB]/ ){
  1978. X            $size *= 512;
  1979. X        }
  1980. X        elsif( $kind =~ /[kK]/ ){
  1981. X            $size *= 1024;
  1982. X        }
  1983. X        if( $size < $min_size || $size > $max_size ){
  1984. X            $size = $def_max_size;
  1985. X        }
  1986. X        push( @comms, "size $size" );
  1987. X    }
  1988. X    elsif( /^\s*(quit|close|==)/i ){
  1989. X        last;
  1990. X    }
  1991. X    else {
  1992. X        $error = "Unrecognised input (maybe quit needed?): $_";
  1993. X        last;
  1994. X    }
  1995. X}
  1996. X
  1997. Xif( !$reply_to ){
  1998. X    &fatal( "Must have a 'reply-to emailaddress'" );
  1999. X}
  2000. X
  2001. X&fix_reply_to();
  2002. X
  2003. Xif( ! &auth( $reply_to ) ){
  2004. X    &mail_back( "reply-to $reply_to not allowed to use this service" );
  2005. X}    
  2006. X
  2007. Xif( $delete ){
  2008. X    # If any problems call &mail_back( "delete fail <err>\n<long err>" )
  2009. X    # and mail_back will generate sensible error messages
  2010. X    if( $delete =~ /^\s*(\d+.\d+)\s*$/ ){
  2011. X        $delete = $1;
  2012. X    }
  2013. X    else {
  2014. X        &mail_back( "delete fail bad argument\nShould be delete <jobid> not: delete $delete" );
  2015. X    }
  2016. X    local( $job ) = "$quedir/$delete";
  2017. X    # Make sure the reply_to's are the same
  2018. X    if( ! open( job, $job ) ){
  2019. X        &mail_back( "delete fail no such job\nCannot delete $delete failed because I couldn't find the job in the queue" );
  2020. X    }
  2021. X    while( <job> ){
  2022. X        if( /^reply-to (.+)$/ ){
  2023. X            $job_reply_to = $1;
  2024. X            last;
  2025. X        }
  2026. X    }
  2027. X    close( job );
  2028. X    if( $job_reply_to ne $reply_to ){
  2029. X        &mail_back( "delete fail not queuer\nYou cannot delete this job $delete as, according to the reply-to, you are not\nThe person who queued it.\n" );
  2030. X    }
  2031. X    # Zap a job and tell them its gone
  2032. X    unlink( $job );
  2033. X    &mail_back( "deleted $delete by user" );
  2034. X}
  2035. Xelsif( $help ){
  2036. X    &mail_back( $help );
  2037. X}
  2038. X
  2039. X
  2040. Xif( !$site ){
  2041. X    &mail_back( "Must have an 'open [site [user [pass]]]'" );
  2042. X}
  2043. X
  2044. Xif( $error ){
  2045. X    &mail_back( $error );
  2046. X}
  2047. X
  2048. Xif( ! $work ){
  2049. X    &mail_back( "Your job contains no get, ls or dir commands so I am ignoring it" );
  2050. X}
  2051. X
  2052. X# Work out the priority
  2053. X$prio = 0;
  2054. X$matched = 0;
  2055. Xforeach $site_prio ( @site_priorities ){
  2056. X    if( $site =~ /$site_prio/ ){
  2057. X        $matched = 1;
  2058. X        last;
  2059. X    }
  2060. X    $prio++;
  2061. X    last if $prio >= 9;
  2062. X}
  2063. Xif( ! $matched ){
  2064. X    $prio = 9;
  2065. X}
  2066. X
  2067. X$qfile = "$quedir/T$quenum.$$";
  2068. X$realqfile = $qfile;
  2069. X# replace the T by the prio.
  2070. X$realqfile =~ s/($quedir\/)T($quenum.$$)/$1$prio$2/;
  2071. X&log( "queueing entry for $reply_to in $realqfile" );
  2072. X$tries = 0;
  2073. X$whenretry = 0;
  2074. X&write_entry();
  2075. Xrename( $qfile, $realqfile );
  2076. X&mail_back( "ack" );
  2077. X
  2078. Xsub mail_back
  2079. X{
  2080. X    local( $error ) = @_;
  2081. X    local( $show_help ) = 1;
  2082. X    local( $help, $ack, $del, $del_fail );
  2083. X
  2084. X    chop( $error ) if $error =~ /\n$/;
  2085. X    
  2086. X    if( $error =~ /^help(\s+\S+)?/ ){
  2087. X        &log( "mail_back: $reply_to $error" );
  2088. X        $help = $error;
  2089. X        $error = 0;
  2090. X    }
  2091. X    elsif( $error eq 'ack' ){
  2092. X        &log( "mail_back: $reply_to $error" );
  2093. X        $ack = 1;
  2094. X        $error = 0;
  2095. X    }
  2096. X    elsif( $error =~ /^deleted / ){
  2097. X        &log( "mail_back: $reply_to $error" );
  2098. X        $del = $error;
  2099. X        $error = 0;
  2100. X    }
  2101. X    elsif( $error =~ /^(delete fail .*)\n/ ){
  2102. X        &log( "mail_back: $reply_to $1" );
  2103. X        $del_fail = $error;
  2104. X        $error = 0;
  2105. X    }
  2106. X    else {
  2107. X        &log( "mail_back: $reply_to failed to queue because: $error" );
  2108. X    }
  2109. X    
  2110. X    if( $mail_cmd =~ /sendmail/ ){
  2111. X        open( MAIL, "| $mail_cmd " ) ||
  2112. X             &fatal( "Cannot send email" );
  2113. X        print MAIL "To: $reply_to\n";
  2114. X        print MAIL "Subject: $ftpmail_response\n\n";
  2115. X    }
  2116. X    else {
  2117. X        open( MAIL, "| $mail_cmd -s '$ftpmail_response' '$reply_to' >/dev/null 2>&1" ) ||
  2118. X             &fatal( "Cannot send email" );
  2119. X    }
  2120. X    
  2121. X    print MAIL "$ftpmail_response\n";
  2122. X    
  2123. X    &mail_motd();
  2124. X    
  2125. X    if( $error ){
  2126. X        print MAIL "ftpmail has failed to queue your request with an";
  2127. X        print MAIL " error of:\n\t$error\n";
  2128. X        &mail_incopy();
  2129. X    }
  2130. X    elsif( $ack ){
  2131. X        local( $qf ) = $realqfile;
  2132. X        $qf =~ s,.*/([^/]+),$1,;
  2133. X        print MAIL "ftpmail has received the following job from you:\n";
  2134. X        &mail_comms();
  2135. X        print MAIL "\nftpmail has queued your job as: $qf\n";
  2136. X        print MAIL "Your priority is $prio (0 = highest, 9 = lowest)\n";
  2137. X        print MAIL "$priorities_msg\n";
  2138. X        &scan_q( $prio );
  2139. X        local( $ahead ) = $#qfiles;  # don't count my new one
  2140. X        $ahead = "no" if $ahead <= 0;
  2141. X        print MAIL "There are $ahead jobs ahead of this one in the queue.\n";
  2142. X        if( $max_dqs > 0 ){
  2143. X            local( $dqs ) = $max_dqs + 1;
  2144. X            print MAIL "$dqs ftpmail handlers available.\n";
  2145. X        }
  2146. X        print MAIL "\nTo remove send a message to $ftpmail_email containing just:\ndelete $qf\n\n";
  2147. X        &mail_incopy();
  2148. X        $show_help = 0;
  2149. X    }
  2150. X    elsif( $del ){
  2151. X        print MAIL "ftpmail has $del\n";
  2152. X        $show_help = 0;
  2153. X    }
  2154. X    elsif( $del_fail ){
  2155. X        print MAIL "ftpmail $del_fail\n";
  2156. X        $show_help = 0;
  2157. X    }
  2158. X    
  2159. X    if( $show_help ){
  2160. X        if( $help =~ /^help(\s+(\S+))/ ){
  2161. X            $hf = "$helpdir/$2";
  2162. X        }
  2163. X        else {
  2164. X            $hf = "$helpdir/help";
  2165. X        }
  2166. X        if( open( HELP, $hf ) ){
  2167. X            while( <HELP> ){
  2168. X                s/\$default_site/$default_site/g;
  2169. X                s/\$ftpmail_email/$ftpmail_email/g;
  2170. X                s/\$help_email/$help_email/g;
  2171. X                s/\$managers_email/$managers_email/g;
  2172. X                s/\$hostname/$hostname/g;
  2173. X                s/\$max_cmds/$max_cmds/g;
  2174. X                s/\$max_size/$max_size/g;
  2175. X                # I use the []'s to prevent RCS from expanding it
  2176. X                s/\$[R]evision/$Revision/g;
  2177. X                print MAIL;
  2178. X            }
  2179. X            close( HELP );
  2180. X        }
  2181. X        else {
  2182. X            print MAIL "Cannot find $help";
  2183. X        }
  2184. X    }
  2185. X
  2186. X    close( MAIL );
  2187. X
  2188. X    &cleanexit();
  2189. X}
  2190. X
  2191. Xsub mail_incopy
  2192. X{
  2193. X    close( INCOPY );
  2194. X    if( ! open( INCOPY, $input_copy ) ){
  2195. X        print MAIL "internal error, cannot reopen input file!";
  2196. X    }
  2197. X    else {
  2198. X        print MAIL "\nYour original input " . ($toomany ? "began" : "was") . ">>\n";
  2199. X        while( <INCOPY> ){
  2200. X            s/^/>/;
  2201. X            print MAIL;
  2202. X        }
  2203. X        close( INCOPY );
  2204. X        print MAIL "<<End of your input\n";
  2205. X    }
  2206. X}
  2207. X
  2208. X# Read a file of patterns for authorised users
  2209. Xsub read_auth
  2210. X{
  2211. X    if( ! open( auth, $authfile ) ){
  2212. X        &log( "Cannot open $authfile" );
  2213. X        return;
  2214. X    }
  2215. X    while( <auth> ){
  2216. X        next if /^#/;
  2217. X        chop;
  2218. X        if( /^not\s+(.+)$/ ){
  2219. X            $bad_add = $1;
  2220. X            if( /\@/ ){
  2221. X                $b = $auth_not_ok;
  2222. X                $auth_not_ok = $b ? "$b|$bad_add" : $bad_add;
  2223. X            }
  2224. X            else {
  2225. X                $auth_host{ $bad_add } = 0;
  2226. X            }
  2227. X        }
  2228. X        elsif( /\@/ ){
  2229. X            # user@host pattern 
  2230. X            $a = $auth_ok;
  2231. X            $auth_ok = $a ? "$a|$_" : $_;
  2232. X        }
  2233. X        else {
  2234. X            # hostname
  2235. X            $auth_host{ $_ } = 1;
  2236. X        }
  2237. X    }
  2238. X    close auth;
  2239. X}
  2240. X    
  2241. Xsub auth
  2242. X{
  2243. X    local( $addr ) = @_;
  2244. X    
  2245. X    if( $addr =~ /^$auth_not_ok$/i ){
  2246. X        return 0;
  2247. X    }
  2248. X    
  2249. X    if( $addr =~ /^$auth_ok$/){
  2250. X        return 1;
  2251. X    }
  2252. X
  2253. X    if( $addr =~ /^($nr)@($nr)$/ ){
  2254. X        local( $user, $host ) = ($1, $2);
  2255. X        return $auth_host{ $host };
  2256. X    }
  2257. X
  2258. X    if( $addr !~ /[@!%]/ ){
  2259. X        return $auth_host{ 'localhost' };
  2260. X    }
  2261. X    
  2262. X    return 0;
  2263. X}
  2264. X
  2265. Xsub fix_reply_to
  2266. X{
  2267. X    # Make sure that reply_to doesn't contain any shell escapes
  2268. X    # Since I use it as '$reply_to' then all I have to worry about is
  2269. X    # backprime itself
  2270. X    
  2271. X    # For now just zap them!
  2272. X    $reply_to =~ s/'//g;
  2273. X}
  2274. X
  2275. X# Try to strip away all comments.
  2276. Xsub dumb_fix_reply_to
  2277. X{
  2278. X    $reply_to = &rfc822'first_addr_spec( $reply_to );
  2279. X}
  2280. X
  2281. Xsub cleanexit
  2282. X{
  2283. X    if( $cleanup ){
  2284. X        unlink( $input_copy );
  2285. X    }
  2286. X    exit( 0 );
  2287. X}
  2288. END_OF_FILE
  2289.   if test 17435 -ne `wc -c <'q.pl'`; then
  2290.     echo shar: \"'q.pl'\" unpacked with wrong size!
  2291.   fi
  2292.   chmod +x 'q.pl'
  2293.   # end of 'q.pl'
  2294. fi
  2295. echo shar: End of archive 1 \(of 3\).
  2296. cp /dev/null ark1isdone
  2297. MISSING=""
  2298. for I in 1 2 3 ; do
  2299.     if test ! -f ark${I}isdone ; then
  2300.     MISSING="${MISSING} ${I}"
  2301.     fi
  2302. done
  2303. if test "${MISSING}" = "" ; then
  2304.     echo You have unpacked all 3 archives.
  2305.     rm -f ark[1-9]isdone
  2306. else
  2307.     echo You still must unpack the following archives:
  2308.     echo "        " ${MISSING}
  2309. fi
  2310. exit 0
  2311. exit 0 # Just in case...
  2312.