home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1992 #27 / NN_1992_27.iso / spool / comp / sources / misc / 4100 < prev    next >
Encoding:
Text File  |  1992-11-19  |  54.7 KB  |  1,663 lines
  1. Newsgroups: comp.sources.misc
  2. Path: sparky!kent
  3. From: ram@eiffel.com (Raphael Manfredi)
  4. Subject:  v33i095:  mailagent - Rule Based Mail Filtering, Part03/17
  5. Message-ID: <1992Nov20.050250.13405@sparky.imd.sterling.com>
  6. Followup-To: comp.sources.d
  7. X-Md4-Signature: f923aba983128a02c85d704b413f5aa2
  8. Sender: kent@sparky.imd.sterling.com (Kent Landfield)
  9. Organization: Sterling Software
  10. References: <csm-v33i093=mailagent.230117@sparky.IMD.Sterling.COM>
  11. Date: Fri, 20 Nov 1992 05:02:50 GMT
  12. Approved: kent@sparky.imd.sterling.com
  13. Lines: 1648
  14.  
  15. Submitted-by: ram@eiffel.com (Raphael Manfredi)
  16. Posting-number: Volume 33, Issue 95
  17. Archive-name: mailagent/part03
  18. Environment: Perl, Sendmail, UNIX
  19.  
  20. #! /bin/sh
  21. # This is a shell archive.  Remove anything before this line, then feed it
  22. # into a shell via "sh file" or similar.  To overwrite existing files,
  23. # type "sh file -c".
  24. # Contents:  agent/Makefile.SH agent/pl/actions.pl
  25. # Wrapped by kent@sparky on Wed Nov 18 22:42:20 1992
  26. PATH=/bin:/usr/bin:/usr/ucb:/usr/local/bin:/usr/lbin ; export PATH
  27. echo If this archive is complete, you will see the following message:
  28. echo '          "shar: End of archive 3 (of 17)."'
  29. if test -f 'agent/Makefile.SH' -a "${1}" != "-c" ; then 
  30.   echo shar: Will not clobber existing file \"'agent/Makefile.SH'\"
  31. else
  32.   echo shar: Extracting \"'agent/Makefile.SH'\" \(6715 characters\)
  33.   sed "s/^X//" >'agent/Makefile.SH' <<'END_OF_FILE'
  34. X: Makefile.SH generated from Jmake.tmpl and Jmakefile [jmake 2.8 PL13]
  35. X: $X-Id: Jmake.tmpl,v 2.8.1.2 91/11/18 13:22:54 ram Exp $
  36. X
  37. Xcase $CONFIG in
  38. X'')
  39. X    if test ! -f config.sh; then
  40. X        ln ../config.sh . || \
  41. X        ln ../../config.sh . || \
  42. X        ln ../../../config.sh . || \
  43. X        (echo "Can't find config.sh."; exit 1)
  44. X    fi 2>/dev/null
  45. X    . ./config.sh
  46. X    ;;
  47. Xesac
  48. Xcase "$0" in
  49. X*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
  50. Xesac
  51. XCURRENT=agent
  52. XDIR=`echo $CURRENT/ | sed -e 's/\.\///g'`
  53. Xecho "Extracting ${DIR}Makefile (with variable substitutions)"
  54. XDATE=`date`
  55. X$spitshell >Makefile <<!GROK!THIS!
  56. X########################################################################
  57. X# Makefile generated from Makefile.SH on $DATE
  58. X
  59. XSHELL = /bin/sh
  60. XJMAKE = jmake
  61. XTOP = ..
  62. XCURRENT = $CURRENT
  63. XDIR = $DIR
  64. XINSTALL = ../install
  65. X
  66. X########################################################################
  67. X# Parameters set by Configure -- edit config.sh if changes are needed
  68. X
  69. XBINDIR = $bin
  70. XCTAGS = ctags
  71. XL = $manext
  72. XMANSRC = $mansrc
  73. XMAKE = make
  74. XMV = $mv
  75. XPRIVLIB = $privlib
  76. XRM = $rm -f
  77. XSCRIPTDIR = $scriptdir
  78. X
  79. X########################################################################
  80. X# Automatically generated parameters -- do not edit
  81. X
  82. XSUBDIRS = files filter man test
  83. XSCRIPTS =  \$(BIN)
  84. X
  85. X!GROK!THIS!
  86. X$spitshell >>Makefile <<'!NO!SUBS!'
  87. X
  88. X########################################################################
  89. X# Jmake rules for building libraries, programs, scripts, and data files
  90. X# $X-Id: Jmake.rules,v 2.8.1.4 91/11/18 13:19:07 ram Exp $
  91. X
  92. X########################################################################
  93. X# Start of Jmakefile
  94. X
  95. X# $X-Id: Jmakefile,v 2.9.1.2 92/08/26 12:33:22 ram Exp $
  96. X#
  97. X#  Copyright (c) 1991, Raphael Manfredi
  98. X#
  99. X#  You may redistribute only under the terms of the GNU General Public
  100. X#  Licence as specified in the README file that comes with dist.
  101. X#
  102. X# $X-Log:    Jmakefile,v $
  103. X# Revision 2.9.1.2  92/08/26  12:33:22  ram
  104. X# patch8: new mailhook target, installed in private library directory
  105. X#
  106. X# Revision 2.9.1.1  92/08/12  21:27:08  ram
  107. X# patch6: mailagent is now built with offset table (perload -o)
  108. X#
  109. X# Revision 2.9  92/07/14  16:47:06  ram
  110. X# 3.0 beta baseline.
  111. X#
  112. X
  113. XBIN = mailpatch mailhelp maillist maildist
  114. X
  115. Xall:: $(BIN)
  116. X
  117. Xlocal_realclean::
  118. X    $(RM) $(BIN)
  119. X
  120. Xmailpatch: mailpatch.SH
  121. X    /bin/sh mailpatch.SH
  122. X
  123. Xmailhelp: mailhelp.SH
  124. X    /bin/sh mailhelp.SH
  125. X
  126. Xmaillist: maillist.SH
  127. X    /bin/sh maillist.SH
  128. X
  129. Xmaildist: maildist.SH
  130. X    /bin/sh maildist.SH
  131. X
  132. X
  133. Xinstall:: $(SCRIPTS) $(LSCRIPTS)
  134. X    @for file in $(SCRIPTS) $(LSCRIPTS); do \
  135. X        case '${MFLAGS}' in *[i]*) set +e;; esac; \
  136. X        (set -x; $(INSTALL) -c -m 555 $$file $(SCRIPTDIR)); \
  137. X    done
  138. X
  139. Xdeinstall::
  140. X    @for file in $(SCRIPTS) $(LSCRIPTS); do \
  141. X        case '${MFLAGS}' in *[i]*) set +e;; esac; \
  142. X        (set -x; $(RM) $(SCRIPTDIR)/$$file); \
  143. X    done
  144. X
  145. X
  146. Xall:: magent
  147. X
  148. Xlocal_realclean::
  149. X    $(RM) magent
  150. X
  151. Xmagent: magent.SH
  152. X    /bin/sh magent.SH
  153. X
  154. X
  155. Xall:: mhook
  156. X
  157. Xlocal_realclean::
  158. X    $(RM) mhook
  159. X
  160. Xmhook: mhook.SH
  161. X    /bin/sh mhook.SH
  162. X
  163. X
  164. Xall:: mailagent
  165. X
  166. Xlocal_realclean::
  167. X    $(RM) mailagent
  168. Xmailagent: magent
  169. X    $(TOP)/bin/perload -o magent > $@
  170. X    chmod +rx $@
  171. X
  172. Xall:: mailhook
  173. X
  174. Xlocal_realclean::
  175. X    $(RM) mailhook
  176. Xmailhook: mhook
  177. X    $(TOP)/bin/perload -o mhook > $@
  178. X    chmod +rx $@
  179. X
  180. Xinstall:: mailagent
  181. X    $(INSTALL) -c -m 555  mailagent $(BINDIR)
  182. X
  183. Xdeinstall::
  184. X    $(RM) $(BINDIR)/mailagent
  185. X
  186. Xdepend::
  187. X    @case '${MFLAGS}' in *[ik]*) set +e;; esac; \
  188. X    for i in filter ;\
  189. X    do \
  190. X        (cd $$i ; echo "Depending" "in $(DIR)$$i..."; \
  191. X            $(MAKE) $(MFLAGS)  depend); \
  192. X    done
  193. X
  194. Xinstall::
  195. X    @for dir in $(PRIVLIB); do \
  196. X        case '${MFLAGS}' in *[i]*) set +e;; esac; \
  197. X        (set -x; $(INSTALL) -d $$dir); \
  198. X    done
  199. X
  200. Xdeinstall::
  201. X    $(RM) -r $(PRIVLIB)
  202. X
  203. Xinstall:: mailhook
  204. X    @case '${MFLAGS}' in *[i]*) set +e;; esac; \
  205. X    for i in mailhook; do \
  206. X        (set -x; $(INSTALL) -c -m 555 $$i $(PRIVLIB)); \
  207. X    done
  208. X
  209. Xdeinstall::
  210. X    @case '${MFLAGS}' in *[i]*) set +e;; esac; \
  211. X    for i in mailhook; do \
  212. X        (set -x; $(RM) $(PRIVLIB)/$$i); \
  213. X    done
  214. X
  215. X########################################################################
  216. X# Common rules for all Makefiles -- do not edit
  217. X
  218. Xemptyrule::
  219. X
  220. Xclean: sub_clean local_clean
  221. Xrealclean: sub_realclean local_realclean
  222. Xclobber: sub_clobber local_clobber
  223. X
  224. Xlocal_clean::
  225. X    $(RM) core *~ *.o
  226. X
  227. Xlocal_realclean:: local_clean
  228. X
  229. Xlocal_clobber:: local_realclean
  230. X    $(RM) Makefile config.sh
  231. X
  232. XMakefile.SH: Jmakefile
  233. X    -@if test -f $(TOP)/.package; then \
  234. X        if test -f Makefile.SH; then \
  235. X            echo "    $(RM) Makefile.SH~; $(MV) Makefile.SH Makefile.SH~"; \
  236. X            $(RM) Makefile.SH~; $(MV) Makefile.SH Makefile.SH~; \
  237. X        fi; \
  238. X        echo "    $(JMAKE) -DTOPDIR=$(TOP) -DCURDIR=$(CURRENT)" ; \
  239. X        $(JMAKE) -DTOPDIR=$(TOP) -DCURDIR=$(CURRENT) ; \
  240. X    else touch $@; exit 0; fi
  241. X
  242. XMakefile: Makefile.SH
  243. X    /bin/sh Makefile.SH
  244. X
  245. Xtags::
  246. X    $(CTAGS) -w *.[ch]
  247. X    $(CTAGS) -xw *.[ch] > tags
  248. X
  249. Xlocal_clobber::
  250. X    $(RM) tags
  251. X
  252. X########################################################################
  253. X# Rules for building in sub-directories -- do not edit
  254. X
  255. Xsubdirs:
  256. X    @case '${MFLAGS}' in *[ik]*) set +e;; esac; \
  257. X    for i in $(SUBDIRS) ;\
  258. X    do \
  259. X        (cd $$i ; echo $(VERB) "in $(DIR)$$i..."; \
  260. X            $(MAKE) $(MFLAGS) $(FLAGS) $(TARGET)); \
  261. X    done
  262. X
  263. Xinstall::
  264. X    @$(MAKE) subdirs TARGET=install VERB="Installing" FLAGS=
  265. X
  266. Xdeinstall::
  267. X    @$(MAKE) subdirs TARGET=deinstall VERB="Deinstalling" FLAGS=
  268. X
  269. Xinstall.man::
  270. X    @$(MAKE) subdirs TARGET=install.man VERB="Installing man pages" FLAGS=
  271. X
  272. Xdeinstall.man::
  273. X    @$(MAKE) subdirs TARGET=deinstall.man VERB="Deinstalling man pages" FLAGS=
  274. X
  275. Xsub_clean::
  276. X    @$(MAKE) subdirs TARGET=clean VERB="Cleaning" FLAGS=
  277. X    @echo "Back to $(CURRENT) for "clean...
  278. X
  279. Xsub_realclean::
  280. X    @$(MAKE) subdirs TARGET=realclean VERB="Real cleaning" FLAGS=
  281. X    @echo "Back to $(CURRENT) for "realclean...
  282. X
  283. Xsub_clobber::
  284. X    @$(MAKE) subdirs TARGET=clobber VERB="Clobbering" FLAGS=
  285. X    @echo "Back to $(CURRENT) for "clobber...
  286. X
  287. Xtag::
  288. X    @case '${MFLAGS}' in *[ik]*) set +e;; esac; \
  289. X    for i in  ;\
  290. X    do \
  291. X        (cd $$i ; echo "Tagging" "in $(DIR)$$i..."; \
  292. X            $(MAKE) $(MFLAGS)  tag); \
  293. X    done
  294. X
  295. XMakefiles::
  296. X    @case '${MFLAGS}' in *[ik]*) set +e;; esac; \
  297. X    for i in $(SUBDIRS);\
  298. X    do \
  299. X        echo "Making "Makefiles" in $(DIR)$$i..."; \
  300. X        (cd $$i || exit 1; \
  301. X        if test ! -f Makefile; then /bin/sh Makefile.SH; fi; \
  302. X        $(MAKE) $(MFLAGS) Makefiles) \
  303. X    done
  304. X
  305. XMakefiles.SH:: Makefile.SH
  306. X    @case '${MFLAGS}' in *[ik]*) set +e;; esac; \
  307. X    for i in $(SUBDIRS);\
  308. X    do \
  309. X        case "$(DIR)$$i/" in \
  310. X        */*/*/*/) newtop=../../../..;; \
  311. X        */*/*/) newtop=../../..;; \
  312. X        */*/) newtop=../..;; \
  313. X        */) newtop=..;; \
  314. X        esac; \
  315. X        case "$(TOP)" in \
  316. X        /*) newtop="$(TOP)" ;; \
  317. X        esac; \
  318. X        echo "Making Makefiles.SH in $(DIR)$$i..."; \
  319. X        (cd $$i || exit 1; $(MAKE) $(MFLAGS) -f ../Makefile \
  320. X        Makefile TOP=$$newtop CURRENT=$(DIR)$$i;\
  321. X        $(MAKE) $(MFLAGS) Makefiles.SH) \
  322. X    done
  323. X
  324. Xall::
  325. X    @$(MAKE) subdirs TARGET=all VERB="Making all" FLAGS=
  326. X
  327. X!NO!SUBS!
  328. Xchmod 644 Makefile
  329. X$eunicefix Makefile
  330. X
  331. END_OF_FILE
  332.   if test 6715 -ne `wc -c <'agent/Makefile.SH'`; then
  333.     echo shar: \"'agent/Makefile.SH'\" unpacked with wrong size!
  334.   fi
  335.   chmod +x 'agent/Makefile.SH'
  336.   # end of 'agent/Makefile.SH'
  337. fi
  338. if test -f 'agent/pl/actions.pl' -a "${1}" != "-c" ; then 
  339.   echo shar: Will not clobber existing file \"'agent/pl/actions.pl'\"
  340. else
  341.   echo shar: Extracting \"'agent/pl/actions.pl'\" \(45237 characters\)
  342.   sed "s/^X//" >'agent/pl/actions.pl' <<'END_OF_FILE'
  343. X;# $Id: actions.pl,v 2.9.1.3 92/11/01 15:44:28 ram Exp $
  344. X;#
  345. X;#  Copyright (c) 1992, Raphael Manfredi
  346. X;#
  347. X;#  You may redistribute only under the terms of the GNU General Public
  348. X;#  Licence as specified in the README file that comes with dist.
  349. X;#
  350. X;# $Log:    actions.pl,v $
  351. X;# Revision 2.9.1.3  92/11/01  15:44:28  ram
  352. X;# patch11: the PERL command now sets up @ARGV as if invoked from shell
  353. X;# patch11: fixed message substitution bug (for MESSAGE and NOTIFY)
  354. X;# 
  355. X;# Revision 2.9.1.2  92/08/26  13:07:38  ram
  356. X;# patch8: saving command now supports executable folder hooks
  357. X;# patch8: explicit chdir to the home directory performed before RUN
  358. X;# patch8: value in ASSIGN is ran through perl first, for expressions
  359. X;# patch8: new PERL command to escape to a perl script
  360. X;# 
  361. X;# Revision 2.9.1.1  92/08/02  16:06:57  ram
  362. X;# patch2: bad commands were not correctly formatted when sent back
  363. X;# patch2: existing Sender field rewritten as Prev- instead of Original-
  364. X;# patch2: new -a option for SPLIT to tag each digest item
  365. X;# patch2: now waits only 2 seconds for child initialization
  366. X;# patch2: headers are case-normalized before entry in %Header
  367. X;# patch2: moved flow altering functions from filter.pl
  368. X;# patch2: headers in STRIP or KEEP are searched for case-insensitively
  369. X;# patch2: the Resent-To field added by FORWARD is now formatted
  370. X;# 
  371. X;# Revision 2.9  92/07/14  16:49:31  ram
  372. X;# 3.0 beta baseline.
  373. X;# 
  374. X;# 
  375. X#
  376. X# Implementation of filtering commands
  377. X#
  378. X
  379. X# The "LEAVE" command
  380. X# Leave a copy of the message in the mailbox. Returns (mbox, failed_status)
  381. Xsub leave {
  382. X    local($mailbox) = &mailbox_name;    # Incomming mailbox filename
  383. X    do add_log("starting LEAVE") if $loglvl > 15;
  384. X    do save($mailbox);                    # Propagate return status
  385. X}
  386. X
  387. X# The "SAVE" command
  388. X# Save a message in a folder. Returns (mbox, failed_status). If the folder
  389. X# already exists and has the 'x' bit set, then is is understood as an external
  390. X# hook and mailhook is invoked.
  391. Xsub save {
  392. X    local($mailbox) = @_;            # Where mail should be saved
  393. X    local($failed) = 0;                # Printing status
  394. X    &add_log("starting SAVE $mailbox") if $loglvl > 15;
  395. X    if (-x $mailbox) {                # Folder hook
  396. X        &save_hook;
  397. X    } else {
  398. X        &save_folder;
  399. X    }
  400. X    &emergency_save if $failed;
  401. X    ($mailbox, $failed);            # Where save was made and failure status
  402. X}
  403. X
  404. X# Called by &save when folder is a regular one (i.e. not a hook). Manipulates
  405. X# variables in the context of &save.
  406. Xsub save_folder {
  407. X    if (open(MBOX, ">>$mailbox")) {
  408. X        do mbox_lock($mailbox);            # Lock mailbox
  409. X        # First print the Header, and add the X-Filter: line.
  410. X        (print MBOX $Header{'Head'}) || ($failed = 1);
  411. X        (print MBOX $FILTER, "\n\n") || ($failed = 1);
  412. X        (print MBOX $Header{'Body'}) || ($failed = 1);
  413. X        print MBOX "\n";                # Allow parsing by other tools
  414. X        do mbox_unlock($mailbox);        # Will close file
  415. X        # Logging only in case of error
  416. X        if ($failed) {
  417. X            do add_log("ERROR could not save mail in $mailbox") if $loglvl > 0;
  418. X        }
  419. X    } else {
  420. X        if (-f "$mailbox") {
  421. X            do add_log("ERROR cannot append to $mailbox") if $loglvl;
  422. X        } else {
  423. X            do add_log("ERROR cannot create $mailbox") if $loglvl;
  424. X        }
  425. X        $failed = 1;
  426. X    }
  427. X}
  428. X
  429. X# Called by &save when folder is a hook. This simply calls the mailhook
  430. X# program, which will analyze the hook and perform the necessary actions.
  431. Xsub save_hook {
  432. X    &add_log("hooking mail on folder") if $loglvl > 15;
  433. X    $failed =
  434. X        &shell_command("$privlib/mailhook $mailbox", $MAIL_INPUT, $NO_FEEDBACK);
  435. X}
  436. X
  437. X# The "PROCESS" command
  438. X# The body of the message is expected to be in $Header{'Body'}
  439. Xsub process {
  440. X    local($subj) =            $Header{'Subject'};
  441. X    local($msg_id) =        $Header{'Message-Id'};
  442. X    local($sender) =        $Header{'Reply-To'};
  443. X    local($to) =            $Header{'To'};
  444. X    local($bad) = "";        # No bad commands
  445. X    local($pack) = "auto";    # Default packing mode for sending files
  446. X    local($ncmd) = 0;        # Number of valid commands we have found
  447. X    local($dest) = "";        # Destination (where to send answers)
  448. X    local(@cmd);            # Array of all commands
  449. X    local(%packmode);        # Records pack mode for each command
  450. X    local($error) = 0;        # Error report code
  451. X    local(@body);            # Body of message
  452. X
  453. X    &add_log("starting PROCESS") if $loglvl > 15;
  454. X
  455. X    # If no @PATH directive was found, use $sender as a return path
  456. X    $dest = $Userpath;                # Set by an @PATH
  457. X    $dest = $sender unless $dest;
  458. X    # Remove the <> if any (e.g. path derived from Return-Path)
  459. X    $dest =~ /<(.*)>/ && ($dest = $1);
  460. X
  461. X    # Debugging purposes
  462. X    &add_log("@PATH was '$Userpath' and sender was '$sender'") if $loglvl > 18;
  463. X    &add_log("computed destination: $dest") if $loglvl > 15;
  464. X
  465. X    # Copy body of message in an array, one line per entry
  466. X    @body = split(/\n/, $Header{'Body'});
  467. X
  468. X    # The command file contains the authorized commands
  469. X    if ($#command < 0) {            # Command file not processed yet
  470. X        open(COMMAND, "$cf'comfile") || do fatal("No command file!");
  471. X        while (<COMMAND>) {
  472. X            chop;
  473. X            $command{$_} = 1;
  474. X        }
  475. X        close(COMMAND);
  476. X    }
  477. X
  478. X    line: foreach (@body) {
  479. X        # Built-in commands
  480. X        if (/^@PACK\s*(.*)/) {        # Pack mode
  481. X            $pack = $1 if $1 ne '';
  482. X            $pack = "" if ($pack =~ /[=$^&*([{}`\\|;><?]/);
  483. X        }
  484. X        s/^[ \t]@SH/@SH/;    # allow one blank only
  485. X        if (/^@SH/) {
  486. X            s/\\!/!/g;        # if uucp address, un-escape `!'
  487. X            if (/[=\$^&*([{}`\\|;><?]/) {
  488. X                s/^@SH/bad command:/;    # space after ":" will be added
  489. X                $bad .= $_ . "\n";
  490. X                next line;
  491. X            }
  492. X            # Some useful substitutions
  493. X            s/@SH[ \t]*//;                # Allow leading blanks
  494. X            s/ PATH/ $dest/;             # PATH is a macro
  495. X            s/^mial(\w*)/mail\1/;        # Common mis-spellings
  496. X            s/^mailpath/mailpatch/;
  497. X            s/^mailist/maillist/;
  498. X            # Now fetch command's name (first symbol)
  499. X            if (/^([^ \t]+)[ \t]/) {
  500. X                $first = $1;
  501. X            } else {
  502. X                $first = $_;
  503. X            }
  504. X            if (!$command{$first}) {    # if un-authorized cmd
  505. X                s/^/unknown cmd: /;        # needs a space after ":"
  506. X                $bad .= $_ . "\n";
  507. X                next line;
  508. X            }
  509. X            $packmode{$_} = $pack;        # packing mode for this command
  510. X            push(@cmd, $_);                # record command
  511. X        }
  512. X    }
  513. X
  514. X    # ************* Check with authoritative file ****************
  515. X
  516. X    # Do not continue if an error occurred, in which case the mail will remain
  517. X    # in the queue and will be processed later on.
  518. X    return $error if $error || $dest eq '';
  519. X
  520. X    # Now we are sure the mail we proceed is for us
  521. X    $sender = "<someone>" if $sender eq '';
  522. X    $ncmd = $#cmd + 1;
  523. X    if ($ncmd > 1) {
  524. X        do add_log("$ncmd commands for $sender") if ($loglvl > 11);
  525. X    } elsif ($ncmd == 1) {
  526. X        do add_log("1 command for $sender") if ($loglvl > 11);
  527. X    } else {
  528. X        do add_log("no command for $sender") if ($loglvl > 11);
  529. X    }
  530. X    foreach $fullcmd (@cmd) {
  531. X        $cmdfile = "/tmp/mess.cmd$$";
  532. X        open(CMD,">$cmdfile");
  533. X        # For our children
  534. X        print CMD "jobnum=$jobnum export jobnum\n";
  535. X        print CMD "fullcmd=\"$fullcmd\" export fullcmd\n";
  536. X        print CMD "pack=\"$packmode{$fullcmd}\" export pack\n";
  537. X        print CMD "path=\"$dest\" export path\n";
  538. X        print CMD "sender=\"$sender\" export sender\n";
  539. X        print CMD "set -x\n";
  540. X        print CMD "$fullcmd\n";
  541. X        close CMD;
  542. X        $fullcmd =~ /^[ \t]*(\w+)/;        # extract first word
  543. X        $cmdname = $1;        # this is the command name
  544. X        $trace = "$cf'tmpdir/trace.cmd$$";
  545. X        $pid = fork;                        # We fork here
  546. X        if ($pid == 0) {
  547. X            open(STDOUT, ">$trace");        # Where output goes
  548. X            open(STDERR, ">&STDOUT");        # Make it follow pipe
  549. X            exec '/bin/sh', "$cmdfile";        # Don't use sh -c
  550. X        } elsif ($pid == -1) {
  551. X            # Set the error report code, and the mail will remain in queue
  552. X            # for later processing. Any @RR in the message will be re-executed
  553. X            # but it is not really important. In fact, this is going to be
  554. X            # a feature, not a bug--RAM.
  555. X            $error = 1;
  556. X            open(MAILER,"|/usr/lib/sendmail -odq -t");
  557. X            print MAILER
  558. X"To: $dest
  559. XBcc: $cf'user
  560. XSubject: $cmdname not executed
  561. XX-Mailer: mailagent [version $mversion PL$patchlevel]
  562. X
  563. XYour command was: $fullcmd
  564. X
  565. XIt was not executed because I could not fork. Sigh !
  566. X
  567. XThe command has been left in a queue and will be processed again
  568. Xas soon as possible, so it is useless to resend it.
  569. X
  570. X-- mailagent speaking for $cf'user";
  571. X            close MAILER;
  572. X            if ($?) {
  573. X                do add_log("ERROR cannot report failure")
  574. X                    if ($loglvl > 0);
  575. X            }
  576. X            do add_log("ERROR cannot fork") if $loglvl > 0;
  577. X            return $error;        # Abort processing now--mail remains in queue
  578. X        } else {
  579. X            wait();
  580. X            if ($?) {
  581. X                open(MAILER,"|/usr/lib/sendmail -odq -t");
  582. X                print MAILER
  583. X"To: $dest
  584. XBcc: $cf'user
  585. XSubject: $cmdname returned a non-zero status
  586. XX-Mailer: mailagent [version $mversion PL$patchlevel]
  587. X
  588. XYour command was: $fullcmd
  589. XIt produced the following output and failed:
  590. X
  591. X";
  592. X                if (open(TRACE, "$trace")) {
  593. X                    while (<TRACE>) {
  594. X                        print MAILER;
  595. X                    }
  596. X                    close TRACE;
  597. X                } else {
  598. X                    print MAILER "** SORRY - NOT AVAILABLE **\n";
  599. X                    do add_log("ERROR cannot dump trace") if ($loglvl > 0);
  600. X                }
  601. X                print MAILER "\n-- mailagent speaking for $cf'user";
  602. X                close MAILER;
  603. X                if ($?) {
  604. X                    do add_log("ERROR cannot report failure")
  605. X                        if ($loglvl > 0);
  606. X                }
  607. X                do add_log("FAILED $fullcmd") if $loglvl > 1;
  608. X            } else {
  609. X                do add_log("OK $fullcmd") if $loglvl > 5;
  610. X            }
  611. X        }
  612. X        unlink $cmdfile, $trace;
  613. X    }
  614. X
  615. X    if ($bad) {
  616. X        open(MAILER,"|/usr/lib/sendmail -odq -t");
  617. X        chop($bad);            # Remove trailing new-line
  618. X        print MAILER
  619. X"To: $dest
  620. XBcc: $cf'user
  621. XSubject: the following commands were not executed
  622. XX-Mailer: mailagent [version $mversion PL$patchlevel]
  623. X
  624. X$bad
  625. X
  626. XIf $cf'name can figure out what you wanted, he may do it anyway.
  627. X
  628. X-- mailagent speaking for $cf'user
  629. X";
  630. X        close MAILER;
  631. X        if ($?) {
  632. X            do add_log(
  633. X                "ERROR unable to mail back bad commands from $sender"
  634. X            ) if ($loglvl > 0);
  635. X        }
  636. X        do add_log("bad commands from $sender") if ($loglvl > 5);
  637. X    }
  638. X
  639. X    do add_log("all done for $sender") if ($loglvl > 11);
  640. X    $error;        # Return error report (0 for ok)
  641. X}
  642. X
  643. X# The "MESSAGE" command
  644. Xsub message {
  645. X    local($msg) = @_;            # Vacation message to be sent back
  646. X    local(@head) = (
  647. X        "To: %r (%N)",
  648. X        "Subject: Re: %R"
  649. X    );
  650. X    do send_message($msg, *head);
  651. X}
  652. X
  653. X# The "NOTIFY" command
  654. Xsub notify {
  655. X    local($msg, $address) = @_;
  656. X    # Protect all '%' in the address (subject to macro substitution)
  657. X    $address =~ s/%/%%/g;
  658. X    local(@head) = (
  659. X        "To: $address",
  660. X        "Subject: %s (notification)"
  661. X    );
  662. X    do send_message($msg, *head);
  663. X}
  664. X
  665. X# Send a given message to somebody, as specified in the given header
  666. X# The message and the header are subject to macro substitution
  667. Xsub send_message {
  668. X    local($msg, *header) = @_;    # Message to send, header of message
  669. X    unless (-f "$msg") {
  670. X        do add_log("cannot find message $msg") if $loglvl > 0;
  671. X        return 1;
  672. X    }
  673. X    unless (open(MSG, "$msg")) {
  674. X        do add_log("cannot open message $msg") if $loglvl > 0;
  675. X        return 1;
  676. X    }
  677. X    unless (open(MAILER,"|/usr/lib/sendmail -odq -t")) {
  678. X        do add_log("cannot run sendmail to send message") if $loglvl > 0;
  679. X        return 1;
  680. X    }
  681. X
  682. X    # Construction of value for the %T macro
  683. X    local($macro_T);            # Default value of macro %T is overwritten
  684. X    local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime, $mtime,
  685. X        $ctime,$blksize,$blocks) = stat($msg);
  686. X    local($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
  687. X            localtime($mtime);
  688. X    local($this_year) = (localtime(time))[5];
  689. X    # Do not put the year in %T if it is the same as the current one.
  690. X    ++$mon;                        # Month in the range 1-12
  691. X    if ($this_year != $year) {
  692. X        $macro_T = sprintf("%.2d/%.2d/%.2d", $year, $mon, $mday);
  693. X    } else {
  694. X        $macro_T = sprintf("%.2d/%.2d", $mon, $mday);
  695. X    }
  696. X
  697. X    # Header construction. If the file contains a header at the top, it is
  698. X    # added to the one we already have by default. Identical fields are
  699. X    # overwritten with the one found in the file.
  700. X    if (&header_found($msg)) {    # Top of message is a header
  701. X        local(@newhead);        # New header is constructed here
  702. X        local($field);
  703. X        while (<MSG>) {            # Read the header then
  704. X            last if /^$/;        # End of header
  705. X            chop;
  706. X            push(@newhead, $_);
  707. X            if (/^([\w\-]+):/) {
  708. X                $field = $1;
  709. X                @head = grep(!/^$field:/, @head);    # Field is overwritten
  710. X            }
  711. X        }
  712. X        foreach (@newhead) {
  713. X            push(@head, $_);
  714. X        }
  715. X    }
  716. X    push(@head, $FILTER);        # Avoid loops: replying to ourselves or whatever
  717. X    foreach $line (@head) {
  718. X        do macros_subst(*line);    # In-place macro substitutions
  719. X        print MAILER "$line\n";    # Write header
  720. X    }
  721. X    print MAILER "\n";            # Header separated from body
  722. X    # Now write the body
  723. X    local($tmp);                # Because of a bug in perl 4.0 PL19
  724. X    while ($tmp = <MSG>) {
  725. X        next if $tmp =~ /^$/ && $. == 1;    # Escape sequence to protect header
  726. X        do macros_subst(*tmp);        # In-place macro substitutions
  727. X        print MAILER $tmp;            # Write message line
  728. X    }
  729. X
  730. X    # Close pipe and check status
  731. X    close MSG;
  732. X    close MAILER;
  733. X    local($status) = $?;
  734. X    unless ($status) {
  735. X        if ($loglvl > 2) {
  736. X            local($dest) = $head[0];    # The To: header line
  737. X            ($dest) = $dest =~ m|^To:\s+(.*)|;
  738. X            do add_log("SENT message to $dest");
  739. X        }
  740. X    } else {
  741. X        do add_log("ERROR could not mail back $msg") if $loglvl > 1;
  742. X    }
  743. X    $status;        # 0 for success
  744. X}
  745. X
  746. X# The "FORWARD" command
  747. Xsub forward {
  748. X    local($addresses) = @_;            # Address(es) mail should be forwarded to
  749. X    local($address) = &email_addr;    # Address of user
  750. X    # Any address included withing "" is in fact a file name where actual
  751. X    # forwarding addresses are found.
  752. X    $addresses = &complete_addr($addresses);    # Process "include-requests"
  753. X    unless (open(MAILER,"|/usr/lib/sendmail -odq $addresses")) {
  754. X        do add_log("cannot run sendmail to forward message") if $loglvl > 0;
  755. X        return 1;
  756. X    }
  757. X    local(@addr) = split(' ', $addresses);
  758. X    print MAILER &header'format("Resent-From: $address"), "\n";
  759. X    local($to) = "Resent-To: ", join(', ', @addr);
  760. X    print MAILER &header'format($to), "\n";
  761. X    # Protect Sender: and Resent-: lines in the original message
  762. X    foreach (split(/\n/, $Header{'Head'})) {
  763. X        next if /^From\s+(\S+)/;
  764. X        s/^Sender:\s*(.*)/Prev-Sender: $1/;
  765. X        s/^Resent-([\w\-]+):\s*(.*)/Prev-Resent-$1: $2/;
  766. X        print MAILER $_, "\n";
  767. X    }
  768. X    print MAILER $FILTER, "\n";
  769. X    print MAILER "\n";
  770. X    print MAILER $Header{'Body'};
  771. X    close MAILER;
  772. X    local($failed) = $?;        # Status of forwarding
  773. X    if ($failed) {
  774. X        do add_log("ERROR could not forward to $addresses") if $loglvl > 1;
  775. X    }
  776. X    $failed;        # 0 for success
  777. X}
  778. X
  779. X# The "BOUNCE" command
  780. Xsub bounce {
  781. X    local($addresses) = @_;            # Address(es) mail should be bounced to
  782. X    # Any address included withing "" is in fact a file name where actual
  783. X    # bouncing addresses are found.
  784. X    $addresses = &complete_addr($addresses);    # Process "include-requests"
  785. X    unless (open(MAILER,"|/usr/lib/sendmail -odq $addresses")) {
  786. X        do add_log("cannot run sendmail to bounce message") if $loglvl > 0;
  787. X        return 1;
  788. X    }
  789. X    # Protect Sender: lines in the original message
  790. X    foreach (split(/\n/, $Header{'Head'})) {
  791. X        next if /^From\s+(\S+)/;
  792. X        s/^Sender:\s*(.*)/Original-Sender: $1/;
  793. X        print MAILER $_, "\n";
  794. X    }
  795. X    print MAILER $FILTER, "\n";
  796. X    print MAILER "\n";
  797. X    print MAILER $Header{'Body'};
  798. X    close MAILER;
  799. X    local($failed) = $?;        # Status of forwarding
  800. X    if ($failed) {
  801. X        do add_log("ERROR could not bounce to $addresses") if $loglvl > 1;
  802. X    }
  803. X    $failed;        # 0 for success
  804. X}
  805. X
  806. X# The "POST" command
  807. Xsub post {
  808. X    # Option parsing: a -l restricts distribution to local
  809. X    local($localdist) = 0;
  810. X    $localdist = 1 if ($_[0] =~ s/^\s*-l\s+//);
  811. X    local($newsgroups) = @_;        # Newsgroup(s) mail should be posted to
  812. X    local($address) = &email_addr;    # Address of user
  813. X    unless (open(NEWS,"| $inews -h")) {
  814. X        do add_log("cannot run $inews to post message") if $loglvl > 0;
  815. X        return 1;
  816. X    }
  817. X    do add_log("distribution of posting is local")
  818. X        if $loglvl > 18 && $localdist;
  819. X    # Protect Sender: lines in the original message and clean-up header
  820. X    local($last_was_header);        # Set to true when header is skipped
  821. X    foreach (split(/\n/, $Header{'Head'})) {
  822. X        s/^Sender:\s*(.*)/Original-Sender: $1/;
  823. X        next if /^From\s/;                    # First From line...
  824. X        if (
  825. X            /^To:/ ||
  826. X            /^Cc:/ ||
  827. X            /^Apparently-To:/ ||
  828. X            /^Distribution:/ ||                # No mix-up, please
  829. X            /^X-Mailer:/ ||                    # Mailer identification
  830. X            /^Newsgroups:/ ||                # Reply from news reader
  831. X            /^Return-Receipt-To:/ ||        # Sendmail's acknowledgment
  832. X            /^Received:/ ||                    # We want to remove received
  833. X            /^Errors-To:/ ||                # Error report redirection
  834. X            /^Resent-[\w-]*:/                # Resent tags
  835. X        ) {
  836. X            $last_was_header = 1;            # Mark we discarded the line
  837. X            next;                            # Line is skipped
  838. X        }
  839. X        next if /^\s/ && $last_was_header;    # Skip removed header continuations
  840. X        $last_was_header = 0;                # We decided to keep header line
  841. X        print NEWS $_, "\n";
  842. X    }
  843. X    # If no subject is present, fake one to make inews happy
  844. X    unless (defined($Header{'Subject'}) && $Header{'Subject'} ne '') {
  845. X        do add_log("WARNING no subject, faking one") if $loglvl > 5;
  846. X        print NEWS "Subject: <none>\n";
  847. X    }
  848. X    print NEWS "Newsgroups: $newsgroups\n";
  849. X    print NEWS "Distribution: local\n" if $localdist;
  850. X    # Avoid loops: inews may forward to sendmail
  851. X    print NEWS $FILTER, "\n";
  852. X    print NEWS "\n";
  853. X    print NEWS $Header{'Body'};
  854. X    close NEWS;
  855. X    local($failed) = $?;        # Status of forwarding
  856. X    if ($failed) {
  857. X        do add_log("ERROR could not post to $newsgroups") if $loglvl > 1;
  858. X    }
  859. X    $failed;        # 0 for success
  860. X}
  861. X
  862. X# The "SPLIT" command
  863. X# This routine is RFC-934 compliant and will correctly burst digests produced
  864. X# with this RFC in mind. For instance, MH produces RFC-934 style digest.
  865. X# However, in order to reliably split non RFC-934 digest, some extra work is
  866. X# performed to ensure a meaningful output.
  867. Xsub split {
  868. X    # Option parsing: a -i splits "inplace", i.e. acts as a saving if the split
  869. X    # is fully successful. A -d discards the leading part. A -q queues messsages
  870. X    # instead of filling them into a folder.
  871. X    $_[0] =~ s/^\s*-([adeiw]+)//;    # Remove options
  872. X    local($opt) = $1;
  873. X    local($inplace) = $opt =~ /i/;    # Inplace (original marked saved)
  874. X    local($discard) = $opt =~ /d/;    # Discard digest leading part
  875. X    local($empty) = $opt =~ /e/;    # Discard leading digest only if empty
  876. X    local($watch) = $opt =~ /w/;    # Watch digest closely
  877. X    local($annotate) = $opt =~ /a/;    # Annotate items with X-Digest-To: field
  878. X    $_[0] =~ s/^\s+//;                # Trim leading spaces
  879. X    local($folder) = $_[0];        # Folder to save messages
  880. X    local(@leading);            # Leading part of the digest
  881. X    local(@header);                # Looked ahead header
  882. X    local($found_header) = 0;    # True when header digest was found
  883. X    local($look_header) = 0;    # True when we are looking for a mail header
  884. X    local($found_end) = 0;        # True when end of digest found
  885. X    local($valid);                # Return value from header checking package
  886. X    local($failed) = 0;            # Queuing status for each mail item
  887. X    local(@body);                # Body of extracted mail
  888. X    local($item) = 0;            # Count digest items found
  889. X    local($not_rfc934) = 0;        # Is digest RFC-934 compliant?
  890. X    local($digest_to);            # Value of the X-Digest-To: field
  891. X    local($_);
  892. X    # If item annotation is requested, then each item will have a X-Digest-To:
  893. X    # field added, which lists both the To: and Cc: fields of the original
  894. X    # digest message.
  895. X    if ($annotate) {            # Annotation requested
  896. X        $digest_to = $Header{'Cc'};
  897. X        $digest_to = ', ' . $digest_to if $digest_to;
  898. X        $digest_to = 'X-Digest-To: ' . $Header{'To'} . $digest_to;
  899. X        $digest_to = &header'format($digest_to);
  900. X    }
  901. X    # Start digest parsing. According to RFC-934, we could only look for a
  902. X    # single '-' as encapsulation boundary, but for safety we look for at least
  903. X    # three consecutive ones.
  904. X    foreach (split(/\n/, $Header{'All'})) {
  905. X        push(@leading, $_) unless $found_header;
  906. X        push(@body, $_) if $found_header;
  907. X        if (/^---/) {            # Start looking for mail header
  908. X            $look_header = 1;    # Focus on mail headers now
  909. X            # We are withing the body of a digest and we've just reached
  910. X            # what may be the end of a message, or the end of the leading part.
  911. X            @header = ();        # Reset look ahead buffer
  912. X            &header'reset;        # Reset header checking package
  913. X            next;
  914. X        }
  915. X        next unless $look_header;
  916. X        # Record lines we find, but skip possible blank lines after dash.
  917. X        # Note that RFC-934 does not make spaces compulsory after each
  918. X        # encapsulation boundary (EB) but they are allowed nonetheless.
  919. X        next if /^\s*$/ && 0 == @header;
  920. X        $found_end = 0;            # Maybe it's not garbage after all...
  921. X        $valid = &header'valid($_);
  922. X        if ($valid == 0) {        # Not a valid header
  923. X            $look_header = 0;    # False alert
  924. X            $found_end = 1;        # Garbage after last EB is to be ignored
  925. X            if ($watch) {
  926. X                # Strict RFC-934: if an EB is followed by something which does
  927. X                # not prove to be a valid header but looked like one, enough
  928. X                # to have some lines collected into @header, then signal it.
  929. X                ++$not_rfc934 unless 0 == @header;
  930. X            } else {
  931. X                # Don't be too scrict. If what we have found so far *may be* a
  932. X                # header, then yes, it's not RFC-934. Otherwise let it go.
  933. X                ++$not_rfc934 if $header'maybe;
  934. X            }
  935. X            next;
  936. X        } elsif ($valid == 1) {    # Still in header
  937. X            push(@header, $_);    # Record header lines
  938. X            next;
  939. X        }
  940. X        # Coming here means we reached the end of a valid header
  941. X        push(@header, $digest_to) if $annotate;
  942. X        push(@header, '');        # Blank header line
  943. X        if (!$found_header) {
  944. X            if ($empty) {
  945. X                $failed |= &save_mail(*leading, $folder)
  946. X                    unless &empty_body(*leading) || $discard;
  947. X            } else {
  948. X                $failed |= &save_mail(*leading, $folder) unless $discard;
  949. X            }
  950. X            undef @leading;        # Not needed any longer
  951. X            $item++;            # So that 'save_mail' starts logging items
  952. X        }
  953. X        # If there was already a mail being collected, save it now, because
  954. X        # we are sure it is followed by a valid mail.
  955. X        $failed |= &save_mail(*body, $folder) if $found_header;
  956. X        $found_header = 1;        # End of header -> this is truly a digest
  957. X        $look_header = 0;        # We found our header
  958. X        &header'clean(*header);    # Ensure minimal set of header
  959. X        @body = @header;        # Copy headers in mail body for next message
  960. X    }
  961. X
  962. X    return -1 unless $found_header;    # Message was not in digest format
  963. X
  964. X    # Save last message, making sure to add a final dash line if digest did
  965. X    # not have one: There was one if $look_header is true. There was also
  966. X    # one if $found_end is true.
  967. X    push(@body, '---') unless $look_header || $found_end;
  968. X
  969. X    # If the -w option was used, we look closely at the supposed trailing
  970. X    # garbage. If the length is greater than 100 characters, then maybe we
  971. X    # are missing something here...
  972. X    if ($watch) {
  973. X        local($idx) = $#body;
  974. X        $_ = $body[$idx];            # Get last line
  975. X        @header = ();                # Reset "garbage collector"
  976. X        unless (/^---/) {            # Do not go on if end of digest truly found
  977. X            for (; $idx >= 0; $idx--) {
  978. X                $_ = $body[$idx];
  979. X                last if /^---/;        # Reached end of presumed trailing garbage
  980. X                unshift(@header, $_);
  981. X            }
  982. X        }
  983. X    }
  984. X
  985. X    # Now save last message
  986. X    $failed |= &save_mail(*body, $folder);
  987. X
  988. X    # If we collected something into @header and if it is big enough, save it
  989. X    # as a trailing message.
  990. X    if ($watch && length(join('', @header)) > 100) {
  991. X        &add_log("NOTICE [$mfile] has trailing garbage...") if $loglvl > 6;
  992. X        @body = @header;            # Copy saved garbage
  993. X        @header = ();                # Now build final garbage headers
  994. X        $header[0] = 'Subject: ' . $Header{'Subject'} . ' (trailing garbage)';
  995. X        $header[1] = $digest_to if $annotate;
  996. X        &header'clean(*header);        # Build other headers
  997. X        unshift(@body, '') unless $body[0] =~ s/^\s*$//;    # Ensure EOH
  998. X        foreach (@body) {
  999. X            push(@header, $_);
  1000. X        }
  1001. X        push(@header, '---');
  1002. X        $failed |= &save_mail(*header, $folder);
  1003. X    }
  1004. X
  1005. X    $failed + 0x2 * $inplace + 0x4 * ($folder =~ /^\s*$/)
  1006. X        + 0x8 * ($not_rfc934 > 0);
  1007. X}
  1008. X
  1009. X# The "RUN" command and its friends
  1010. X# Start a shell command and mail any output back to the user. The program is
  1011. X# invoked from within the home directory.
  1012. Xsub shell_command {
  1013. X    local($program, $input, $feedback) = @_;
  1014. X    unless (chdir $cf'home) {
  1015. X        &add_log("WARNING: cannot chdir to $cf'home: $!") if $loglvl > 5;
  1016. X    }
  1017. X    $program =~ s/^\s*~/$cf'home/;    # ~ substitution
  1018. X    $program =~ s/\b~/$cf'home/g;    # ~ substitution as first letter in word
  1019. X    $SIG{'PIPE'} = 'popen_failed';    # Protect against naughty program
  1020. X    $SIG{'ALRM'} = 'alarm_clock';    # Protect against loops
  1021. X    alarm 3600;                        # At most one hour of processing
  1022. X    eval "&execute_command(q\0$program\0, $input, $feedback)";
  1023. X    alarm 0;                        # Disable alarm timeout
  1024. X    $SIG{'PIPE'} = 'emergency';        # Restore initial value
  1025. X    $SIG{'ALRM'} = 'DEFAULT';        # Restore default behaviour
  1026. X    if ($@ =~ /^failed/) {            # Something went wrong?
  1027. X        do add_log("ERROR couldn't run '$program'") if $loglvl > 0;
  1028. X        return 1;                    # Failed
  1029. X    } elsif ($@ =~ /^aborted/) {    # Writing to program failed
  1030. X        do add_log("WARNING pipe closed by '$program'") if $loglvl > 5;
  1031. X        return 1;                    # Failed
  1032. X    } elsif ($@ =~ /^feedback/) {    # Feedback failed
  1033. X        do add_log("WARNING no feedback occurred") if $loglvl > 5;
  1034. X        return 1;                    # Failed
  1035. X    } elsif ($@ =~ /^alarm/) {        # Timeout
  1036. X        do add_log("WARNING time out received") if $loglvl > 5;
  1037. X        return 1;                    # Failed
  1038. X    } elsif ($@ =~ /^non-zero/) {    # Program returned non-zero status
  1039. X        &add_log("WARNING program returned non-zero status") if $loglvl > 5;
  1040. X        return 1;
  1041. X    } elsif ($@) {
  1042. X        do add_log("ERROR $@") if $loglvl > 0;
  1043. X        return 1;                    # Failed
  1044. X    }
  1045. X    0;            # Everything went fine
  1046. X}
  1047. X
  1048. X# Abort execution of command when popen() fails or program dies abruptly
  1049. Xsub popen_failed {
  1050. X    unlink "$trace" if -f "$trace";
  1051. X    die "$error\n";
  1052. X}
  1053. X
  1054. X# When an alarm call is received, we should be in the 'execute_command'
  1055. X# routine. The $pid variable holds the pid number of the process to be killed.
  1056. Xsub alarm_clock {
  1057. X    if ($trace ne '' && -f "$trace") {        # We come from execute_command
  1058. X        local($status) = "terminated";        # Process was terminated
  1059. X        if (kill "SIGTERM", $pid) {            # We could signal our child
  1060. X            sleep 30;                        # Give child time to die
  1061. X            unless (kill "SIGTERM", $pid) {    # Child did not die yet ?
  1062. X                unless (kill "SIGKILL", $pid) {
  1063. X                    do add_log("ERROR could not kill process $pid: $!")
  1064. X                        if $loglvl > 1;
  1065. X                } else {
  1066. X                    $status = "killed";
  1067. X                    do add_log("KILLED process $pid") if $loglvl > 4;
  1068. X                }
  1069. X            } else {
  1070. X                do add_log("TERMINATED process $pid") if $loglvl > 4;
  1071. X            }
  1072. X        } else {
  1073. X            $status = "unknwon";            # Process died ?
  1074. X            do add_log("ERROR coud not signal process $pid: $!")
  1075. X                if $loglvl > 1;
  1076. X        }
  1077. X        do mail_back();                # Mail back any output we have so far
  1078. X        unlink "$trace";            # Remove output of command
  1079. X    }
  1080. X    die "alarm call\n";                # Longjmp to shell_command
  1081. X}
  1082. X
  1083. X# Execute the command, ran in an eval to protect against SIGPIPE signals
  1084. Xsub execute_command {
  1085. X    local($program, $input, $feedback) = @_;
  1086. X    local($trace) = "$cf'tmpdir/trace.run$$";    # Where output goes
  1087. X    local($error) = "failed";                # Error reported by popen_failed
  1088. X    pipe(READ, WRITE);                        # Open a pipe
  1089. X    local($ppid) = $$;                        # Pid of parent process
  1090. X    local($pid) = fork;                        # We fork here
  1091. X    if ($pid == 0) {                        # Child process
  1092. X        alarm 0;
  1093. X        close WRITE;                        # The child reads from pipe
  1094. X        open(STDIN, "<&READ");                # Redirect stdin to pipe
  1095. X        close READ if $input == $NO_INPUT;    # Close stdin if needed
  1096. X        unless (open(STDOUT, ">$trace")) {    # Where output goes
  1097. X            do add_log("WARNING couldn't create $trace") if $loglvl > 5;
  1098. X            if ($feedback == $FEEDBACK) {    # Need trace if feedback
  1099. X                kill 'SIGPIPE', $ppid;        # Parent still waiting
  1100. X                exit 1;
  1101. X            }
  1102. X        }
  1103. X        open(STDERR, ">&STDOUT");            # Make it follow pipe
  1104. X        exec "$program";                    # Run the program now
  1105. X        do add_log("ERROR couldn't exec '$program': $!") if $loglvl > 1;
  1106. X        kill 'SIGPIPE', $ppid;                # Parent still waiting
  1107. X        exit 1;
  1108. X    } elsif ($pid == -1) {
  1109. X        do add_log("ERROR couldn't fork: $!") if $loglvl;
  1110. X        return;
  1111. X    }
  1112. X    close READ;                                # The parent writes to its child
  1113. X    # In case 'sleep' is inplemented using an alarm call, take precautions...
  1114. X    local($remaining) = alarm 0;            # Stop alarm, save remaining time
  1115. X    sleep 2;                                # Let the child initialize
  1116. X    alarm $remaining;                        # Restore alarm clock
  1117. X    $error = "aborted";                        # Error reported by popen_failed
  1118. X    select(WRITE);
  1119. X    $| = 1;                                    # Hot pipe wanted
  1120. X    select(STDOUT);
  1121. X    # Now feed the program with the mail
  1122. X    if ($input == $BODY_INPUT) {            # Pipes body
  1123. X        print WRITE $Header{'Body'};
  1124. X    } elsif ($input == $MAIL_INPUT) {        # Pipes the whole mail
  1125. X        print WRITE $Header{'All'};
  1126. X    } elsif ($input == $HEADER_INPUT) {        # Pipes the header
  1127. X        print WRITE $Header{'Head'};
  1128. X    }
  1129. X    close WRITE;                            # Close input, before waiting!
  1130. X    wait();                                    # Wait for our child
  1131. X    local($status) = $? ? "failed" : "ok";
  1132. X    if ($?) {
  1133. X        # Log execution failure and return to shell_command via die if some
  1134. X        # feedback was to be done.
  1135. X        do add_log("ERROR execution failed for '$program'") if $loglvl > 1;
  1136. X        if ($feedback == $FEEDBACK) {        # We wanted feedback
  1137. X            do mail_back();                    # Mail back any output
  1138. X            unlink "$trace";                # Remove output of command
  1139. X            die "feedback\n";                # Longjmp to shell_command
  1140. X        }
  1141. X    }
  1142. X    &handle_output;            # Take appropriate action with command output
  1143. X    unlink "$trace";        # Remove output of command
  1144. X    die "non-zero status\n" unless $status eq 'ok';
  1145. X}
  1146. X
  1147. X# If no feedback is wanted, simply mail the output of the commands to the
  1148. X# user. However, in case of feedback, we have to update the values of
  1149. X# %Header in the entries 'All', 'Body' and 'Head'. Note that the other
  1150. X# header fields are left untouched. Only a RESYNC can synchronize them
  1151. X# (this makes sense only for a FEED command, of course).
  1152. X# Uses $feedback from execute_command
  1153. Xsub handle_output {
  1154. X    if ($feedback == $NO_FEEDBACK) {
  1155. X        &mail_back;                        # Mail back any output
  1156. X    } elsif ($feedback == $FEEDBACK) {
  1157. X        &feed_back;                        # Feed result back into %Header
  1158. X    }
  1159. X}
  1160. X
  1161. X# Mail back the contents of the trace file (output of program), if not empty.
  1162. X# Uses some local variables from execute_command
  1163. Xsub mail_back {
  1164. X    local($size) = -s "$trace";                # Size of output
  1165. X    return unless $size;                    # Nothing to be done if no output
  1166. X    local($std_input);                        # Standard input used
  1167. X    $std_input = "none" if $input == $NO_INPUT;
  1168. X    $std_input = "mail body" if $input == $BODY_INPUT;
  1169. X    $std_input = "whole mail" if $input == $MAIL_INPUT;
  1170. X    $std_input = "header" if $input == $HEADER_INPUT;
  1171. X    local($program_name) = $program =~ m|^(\S+)|;
  1172. X    open(MAILER,"|/usr/lib/sendmail -odq -t");
  1173. X    print MAILER
  1174. X"To: $cf'user
  1175. XSubject: Output of your '$program_name' command ($status)
  1176. XX-Mailer: mailagent [version $mversion PL$patchlevel]
  1177. X
  1178. XYour command was: $program
  1179. XInput: $std_input
  1180. XStatus: $status
  1181. X
  1182. XIt produced the following output:
  1183. X
  1184. X";
  1185. X    unless (open(TRACE, "$trace")) {
  1186. X        do add_log("ERROR couldn't reopen $trace") if $loglvl > 1;
  1187. X        print MAILER "*** SORRY -- NOT AVAILABLE ***\n";
  1188. X    } else {
  1189. X        while (<TRACE>) {
  1190. X            print MAILER;
  1191. X        }
  1192. X        close TRACE;
  1193. X    }
  1194. X    close MAILER;
  1195. X    unless ($?) {
  1196. X        do add_log("SENT output of '$program_name' to $cf'user ($size bytes)")
  1197. X            if $loglvl > 2;
  1198. X    } else {
  1199. X        do add_log("ERROR couldn't send $size bytes to $cf'user") if $loglvl;
  1200. X    }
  1201. X}
  1202. X
  1203. X# Feed back output of a command in the %Header data structure.
  1204. X# Uses some local variables from execute_command
  1205. Xsub feed_back {
  1206. X    unless (open(TRACE, "$trace")) {
  1207. X        do add_log("ERROR couldn't feed back from $trace: $!") if $loglvl > 1;
  1208. X        unlink "$trace";                # Maybe I should leave it around
  1209. X        die "feedback\n";                # Return to shell_command
  1210. X    }
  1211. X    local($temp) = ' ' x 2000;            # Temporary storage (pre-extended)
  1212. X    $temp = '';
  1213. X    if ($input == $BODY_INPUT) {        # We have to feed back the body only
  1214. X        while (<TRACE>) {
  1215. X            s/^From\s/>From$1/;            # Protect potentially dangerous lines
  1216. X            $temp .= $_;
  1217. X        }
  1218. X    } else {
  1219. X        local($head) = ' ' x 500;        # Pre-extend header
  1220. X        $head = '';
  1221. X        while (<TRACE>) {
  1222. X            if (1../^$/) {
  1223. X                $head .= $_ unless /^$/;
  1224. X            } else {
  1225. X                s/^From\s/>From$1/;        # Protect potentially dangerous lines
  1226. X                $temp .= $_;
  1227. X            }
  1228. X        }
  1229. X        $Header{'Head'} = $head;
  1230. X    }
  1231. X    close TRACE;
  1232. X    $Header{'Body'} = $temp unless $input == $HEADER_INPUT;
  1233. X    $Header{'All'} = $Header{'Head'} . "\n" . $Header{'Body'};
  1234. X}
  1235. X
  1236. X# Feed output back into $Back variable (used by BACK command). Typically, the
  1237. X# BACK command is used with RUN, though any other command is allowed (but does
  1238. X# not always make sense).
  1239. X# NB: This routine:
  1240. X#  - Is never called explicitely but via a type glob through *handle_output
  1241. X#  - Uses some local variables from execute_command
  1242. Xsub xeq_back {
  1243. X    unless (open(TRACE, "$trace")) {
  1244. X        do add_log("ERROR couldn't feed back from $trace: $!") if $loglvl > 1;
  1245. X        unlink "$trace";                # Maybe I should leave it around
  1246. X        die "feedback\n";                # Return to shell_command
  1247. X    }
  1248. X    while (<TRACE>) {
  1249. X        chop;
  1250. X        next if /^\s*$/;
  1251. X        $Back .= $_ . '; ';                # Replace \n by ';' separator
  1252. X    }
  1253. X    close TRACE;
  1254. X}
  1255. X
  1256. X# The "RESYNC" command
  1257. X# Resynchronizes the %Header entries by reparsing the 'All' entry
  1258. Xsub header_resync {
  1259. X    # Clean up all the non-special entries
  1260. X    foreach $key (keys %Header) {
  1261. X        next if $Pseudokey{$key};        # Skip pseudo-header entries
  1262. X        delete $Header{$key};
  1263. X    }
  1264. X    # There is some code duplication with parse_mail()
  1265. X    local($lines) = 0;
  1266. X    local($first_from);                        # First From line records sender
  1267. X    local($last_header);                    # Current normalized header field
  1268. X    local($in_header) = 1;                    # Bug in the range operator
  1269. X    local($value);                            # Value of current field
  1270. X    foreach (split(/\n/, $Header{'All'})) {
  1271. X        if ($in_header) {                    # Still in header of message
  1272. X            $in_header = 0 if /^$/;            # End of header
  1273. X            if (/^\s/) {                    # It is a continuation line
  1274. X                s/^\s+/ /;                    # Swallow multiple spaces
  1275. X                $Header{$last_header} .= "\n$_" if $last_header ne '';
  1276. X            } elsif (/^([\w-]+):\s*(.*)/) {    # We found a new header
  1277. X                $value = $2;                # Bug in perl 4.0 PL19
  1278. X                $last_header = &header'normalize($1);
  1279. X                # Multiple headers like 'Received' are separated by a new-
  1280. X                # line character. All headers end on a non new-line.
  1281. X                if ($Header{$last_header} ne '') {
  1282. X                    $Header{$last_header} .= "\n$value";
  1283. X                } else {
  1284. X                    $Header{$last_header} .= $value;
  1285. X                }
  1286. X            } elsif (/^From\s+(\S+)/) {        # The very first From line
  1287. X                $first_from = $1;
  1288. X            }
  1289. X        } else {
  1290. X            $lines++;                        # One more line in body
  1291. X        }
  1292. X    }
  1293. X    do header_check($first_from, $lines);    # Sanity checks
  1294. X}
  1295. X
  1296. X# The "STRIP" and "KEEP" commands (case insensitive)
  1297. X# Removes or keeps some headers and update the Header structure
  1298. Xsub alter_header {
  1299. X    local($headers, $action) = @_;
  1300. X    local(@list) = split(/\s/, $headers);
  1301. X    local(@head) = split(/\n/, $Header{'Head'});
  1302. X    local(@newhead);                # The constructed header
  1303. X    local($last_was_altered) = 0;    # Set to true when header is altered
  1304. X    local($matched);                # Did any header matched ?
  1305. X    foreach (@head) {
  1306. X        if (/^From\s/) {            # First From line...
  1307. X            push(@newhead, $_);        # Keep it anyway
  1308. X            next;
  1309. X        }
  1310. X        unless (/^\s/) {            # If not a continuation line
  1311. X            $last_was_altered = 0;    # Reset header alteration flag
  1312. X            $matched = 0;            # Assume no match
  1313. X            foreach $h (@list) {    # Loop over to-be-altered lines
  1314. X                $h =~ s/:$//;        # Remove trailing ':' if any
  1315. X                if (/^$h:/i) {        # We found a line to be removed/kept
  1316. X                    $matched = 1;
  1317. X                    last;
  1318. X                }
  1319. X            }
  1320. X            $last_was_altered = $matched;
  1321. X            next if $matched && $action == $HD_SKIP;
  1322. X            next if !$matched && $action == $HD_KEEP;
  1323. X        }
  1324. X        if ($action == $HD_SKIP) {
  1325. X            next if /^\s/ && $last_was_altered;        # Skip header continuations
  1326. X        } else {                                    # Action is $HD_KEEP
  1327. X            next if /^\s/ && !$last_was_altered;    # Header was not kept
  1328. X        }
  1329. X        push(@newhead, $_);                        # Add line to the new header
  1330. X    }
  1331. X    $Header{'Head'} = join("\n", @newhead) . "\n";
  1332. X}
  1333. X
  1334. X# The "ANNOTATE" command
  1335. Xsub annotate_header {
  1336. X    local($field, $value, $date) = @_;    # Field, value and date flag.
  1337. X    if ($value eq '' && $date ne '') {    # No date and no value for field!
  1338. X        &add_log("WARNING no value for '$field' annotation") if $loglvl > 5;
  1339. X        return 1;
  1340. X    }
  1341. X    if ($field eq '') {                # No field specified!
  1342. X        &add_log("WARNING no field specified for annotation") if $loglvl > 5;
  1343. X        return 1;
  1344. X    }
  1345. X    local($annotation) = '';        # Annotation made
  1346. X    $annotation = "$field: " . &header'fake_date . "\n" unless $date;
  1347. X    $annotation .= &header'format("$field: $value") . "\n" if $value;
  1348. X    $Header{'Head'} .= $annotation;
  1349. X    0;
  1350. X}
  1351. X
  1352. X# The "TR" and "SUBST" commands
  1353. Xsub alter_value {
  1354. X    local($variable, $op) = @_;    # Variable and operation to performed
  1355. X    local($lvalue);                # Perl variable to be modified
  1356. X    local($extern);                # Lvalue used for persistent variables
  1357. X
  1358. X    # We may modify a variable or a backreference (not read-only as in perl)
  1359. X    if ($variable =~ s/^#://) {
  1360. X        $extern = &extern'val($variable);    # Fetch external value
  1361. X        $lvalue = '$extern';                # Modify this variable
  1362. X    } elsif ($variable =~ s/^#//) {
  1363. X        $lvalue = '$Variable{\''.$variable.'\'}';
  1364. X    } elsif ($variable =~ /^\d\d?$/) {
  1365. X        $variable = int($variable) - 1;
  1366. X        $lvalue = '$Backref[' . $variable . ']';
  1367. X    } else {
  1368. X        &add_log("ERROR incorrect variable name '$variable'") if $loglvl > 1;
  1369. X        return 1;
  1370. X    }
  1371. X
  1372. X    # Let perl do the work
  1373. X    &add_log("running $lvalue =~ $op") if $loglvl > 19;
  1374. X    eval $lvalue . " =~ $op";
  1375. X    &add_log("ERROR operation $op failed: $@") if $@ && $loglvl > 1;
  1376. X
  1377. X    # If an external (persistent) variable was used, update its value now,
  1378. X    # unless the operation failed, in which case the value is not modified.
  1379. X    &extern'set($variable, $extern) if $@ eq '' && $lvalue eq '$extern';
  1380. X
  1381. X    $@ eq '' ? 0 : 1;            # Failure status
  1382. X}
  1383. X
  1384. X# The "PERL" command
  1385. Xsub perl {
  1386. X    local($script) = @_;    # Location of perl script
  1387. X    local($failed) = '';    # Assume script did not fail
  1388. X    undef @_;                # No visible args for functions in script
  1389. X
  1390. X    unless (chdir $cf'home) {
  1391. X        &add_log("WARNING cannot chdir to $cf'home: $!") if $loglvl > 5;
  1392. X    }
  1393. X
  1394. X    # Set up the @ARGV array, by parsing the $script variable with &shellwords.
  1395. X    # Note that the @ARGV array is held in the main package, but since the
  1396. X    # mailagent makes no use of it at this point, there is no need to save its
  1397. X    # value before clobbering it.
  1398. X    require 'shellwords.pl';
  1399. X    eval '@ARGV = &shellwords($script)';
  1400. X    if (chop($@)) {                # There was an unmatched quote
  1401. X        $@ =~ s/^U/u/;
  1402. X        &add_log("ERROR $@") if $loglvl > 1;
  1403. X        &add_log("ERROR cannot run PERL $script") if $loglvl > 2;
  1404. X        return 1;
  1405. X    }
  1406. X
  1407. X    unless (open(PERL, $ARGV[0])) {
  1408. X        &add_log("ERROR cannot open perl script $ARGV[0]: $!") if $loglvl > 1;
  1409. X        return 1;
  1410. X    }
  1411. X
  1412. X    # Fetch the perl script in memory
  1413. X    local($/) = undef;
  1414. X    local($body) = <PERL>;    # Slurp whole file
  1415. X    close(PERL);
  1416. X    local(@saved) = @INC;    # Save INC array (perl library location path)
  1417. X    local(%saved) = %INC;    # Save already required files
  1418. X
  1419. X    # Run the perl script in special package
  1420. X    unshift(@INC, $privlib);    # Files first searched for in mailagent's lib
  1421. X    package mailhook;            # -- entering in mailhook --
  1422. X    &interface'new;                # Signal new script being loaded
  1423. X    &hook'initialize;            # Initialize convenience variables
  1424. X    eval $'body;                # Load, compile and execute within mailhook
  1425. X    &interface'reset;            # Clear the mailhook package if no more pending
  1426. X    package main;                # -- reverting to main --
  1427. X    @INC = @saved;                # Restore INC array
  1428. X    %INC = %saved;                # In case script has required some other files
  1429. X
  1430. X    # If the script died with an 'OK' error message, then it meant 'exit 0'
  1431. X    # but also wanted the exit to be trapped. The &exit function is provided
  1432. X    # for that purpose.
  1433. X    if (chop($@)) {
  1434. X        if ($@ =~ /^OK/) {
  1435. X            $@ = '';
  1436. X            &add_log("script exited with status 0") if $loglvl > 18;
  1437. X        }
  1438. X        elsif ($@ =~ /^Exit (\d+)/) {
  1439. X            $@ = '';
  1440. X            $failed = "exited with status $1";
  1441. X        }
  1442. X        elsif ($@ =~ /^Status (\d+)/) {        # A REJECT, RESTART or ABORT
  1443. X            $@ = '';
  1444. X            $cont = $1;                        # This will modify control flow
  1445. X            &add_log("script ended with a control '$cont'") if $loglvl > 18;
  1446. X        }
  1447. X        else {
  1448. X            $@ =~ s/ in file \(eval\)//;
  1449. X            &add_log("ERROR $@") if $loglvl;
  1450. X            $failed = "execution aborted";
  1451. X        }
  1452. X        &add_log("ERROR perl failed ($failed)") if $loglvl > 1 && $failed;
  1453. X    }
  1454. X    $failed ? 1 : 0;
  1455. X}
  1456. X
  1457. X# Modify control flow within automaton by calling a non-existant function
  1458. X# &perform, which has been dynamically bound to one of the do_* functions.
  1459. X# The REJECT, RESTART and ABORT actions share the following options and
  1460. X# arguments. If followed by -t (resp. -f), then the action only takes place
  1461. X# when the last recorded command status is true (resp. false, i.e. failure).
  1462. X# If a mode is present as an argument, the the state of the automaton is
  1463. X# changed to that mode prior alteration of the control flow.
  1464. Xsub alter_flow {
  1465. X    $_[0] =~ s/^\s*\w+//;            # Remove command name
  1466. X    $_[0] =~ s/^\s*-([tf]+)//;        # Remove options
  1467. X    local($opt) = $1;
  1468. X    local($true) = $opt =~ /t/;        # Perform only if $lastcmd is 0
  1469. X    local($false) = $opt =~ /f/;    # Perform only if $lastcmd recorded failure
  1470. X    $_[0] =~ s/^\s+//;                # Trim leading spaces
  1471. X    local($mode) = $_[0];            # New mode we eventually change to
  1472. X    # Variable $lastcmd comes from xeqte(), $wmode comes from analyze_mail().
  1473. X    return 0 if $true && $lastcmd != 0;
  1474. X    return 0 if $false && $lastcmd == 0;
  1475. X    if ($mode ne '') {
  1476. X        $wmode = $mode;
  1477. X        &add_log("entering new state $wmode") if $loglvl > 6;
  1478. X    }
  1479. X    &perform;                        # This was dynamically bound
  1480. X}
  1481. X
  1482. X# Perform a "REJECT"
  1483. Xsub do_reject {
  1484. X    $cont = $FT_REJECT;            # Reject ($cont defined in run_command)
  1485. X    do add_log("REJECTED [$mfile] in state $wmode") if $loglvl > 4;
  1486. X    0;
  1487. X}
  1488. X
  1489. X# Perform a "RESTART"
  1490. Xsub do_restart {
  1491. X    $cont = $FT_RESTART;        # Restart ($cont defined in run_command)
  1492. X    do add_log("RESTARTED [$mfile] in state $wmode") if $loglvl > 4;
  1493. X    0;
  1494. X}
  1495. X
  1496. X# Perform an "ABORT"
  1497. Xsub do_abort {
  1498. X    $cont = $FT_ABORT;            # Abort filtering ($cont defined in run_command)
  1499. X    do add_log("ABORTED [$mfile] in state $wmode") if $loglvl > 4;
  1500. X    0;
  1501. X}
  1502. X
  1503. X# Given a list of addresses separated by white spaces, return a new list of
  1504. X# addresses, but with "include-request" processed.
  1505. Xsub complete_addr {
  1506. X    local(@addr) = split(' ', $_[0]);    # Original list
  1507. X    local(@result);                        # Where result list is built
  1508. X    local($filename);                    # Name of include file
  1509. X    local($_);
  1510. X    foreach $addr (@addr) {
  1511. X        if ($addr !~ /^"/) {            # Address not enclosed within ""
  1512. X            push(@result, $addr);        # Kept as-is
  1513. X        } else {
  1514. X            ($filename) = $addr =~ /^"(.*)"$/;
  1515. X            $filename = &locate_file($filename);
  1516. X            if ($filename && open(ADDRESSES, "$filename")) {
  1517. X                while (<ADDRESSES>) {
  1518. X                    next if /^\s*#/;    # Skip shell comments
  1519. X                    chop;
  1520. X                    s/^\s+//;            # Remove leading spaces
  1521. X                    push(@result, $_);
  1522. X                }
  1523. X                close ADDRESSES;
  1524. X            } elsif ($filename) {        # Could not open file
  1525. X                &add_log("WARNING couldn't open $filename for addresses: $!")
  1526. X                    if $loglvl > 4;
  1527. X            } else {
  1528. X                &add_log("WARNING incorrect file inclusion request")
  1529. X                    if $loglvl > 4;
  1530. X            }
  1531. X        }
  1532. X    }
  1533. X    join(' ', @result);        # Return space separated addresses
  1534. X}
  1535. X
  1536. X# Save digest mail into a folder, or queue it if no folder is provided
  1537. X# Uses the variable '$item' from 'split' to log items.
  1538. Xsub save_mail {
  1539. X    local(*array, $folder) = @_;    # Where mail is and where to put it
  1540. X    local($length) = 0;                # Length of the digest item
  1541. X    local($mbox, $failed, $log_message);
  1542. X    local($_);
  1543. X    # Go back to the previous dash line, removing it from the body part
  1544. X    # (it's only a separator). In the process, we also remove any looked ahead
  1545. X    # header which belongs to the next digest item.
  1546. X    do {
  1547. X        $_ = pop(@array);            # Remove what belongs to next digest item
  1548. X    } while !/^---/;
  1549. X    # It is recommended in RFC-934 that all leading EB be escaped by a leading
  1550. X    # '- ' sequence, to allow nested forwarding. However, since the message
  1551. X    # we are dealing with might not be RFC-934 compliant, we are only removing
  1552. X    # the leading '- ' if it is followed by a '-'. We also use the loop to
  1553. X    # escape all potentially dangerous From lines.
  1554. X    local($last_was_space);
  1555. X    foreach (@array) {
  1556. X        s/^From\s+(\S+)/>From $1/ if $last_was_space;
  1557. X        s/^- -/-/;                    # This is the EB escape in RFC-934
  1558. X        $last_was_space = /^$/;        # From is dangerous after blank line
  1559. X    }
  1560. X    # Now @array holds the whole digest item
  1561. X    if ($folder =~ /^\s*$/) {        # No folder means we have to queue message
  1562. X        $failed = &qmail(*array);
  1563. X        $log_message = 'mailagent\'s queue';
  1564. X        foreach (@array) {
  1565. X            $length += length($_) + 1;    # No trailing new-lines
  1566. X        }
  1567. X    } else {
  1568. X        # Looks like we have to save the message in a folder. I cannot really
  1569. X        # ask for a local variable named %Header because emergency routines
  1570. X        # use it to save mail (they expect the whole mail in $Header{'All'}).
  1571. X        # However, if something goes wrong, we'll get back to the filter main
  1572. X        # loop and a LEAVE (default action) will be executed, taking the
  1573. X        # current values from 'Head' and 'Body'. Hence the following:
  1574. X
  1575. X        local(%NHeader);
  1576. X        $NHeader{'All'} = $Header{'All'};
  1577. X        local(*Header) = *NHeader;    # From now on, we really work on %NHeader
  1578. X        local($in_header) = 1;        # True while in message header
  1579. X        local($first_from);            # First From line
  1580. X
  1581. X        # Fill in %Header strcuture, which is expected by save(): header in
  1582. X        # entry 'Head' and body in entry 'Body'.
  1583. X        foreach (@array) {
  1584. X            if ($in_header) {
  1585. X                $in_header = 0 if /^$/;
  1586. X                next if /^$/;
  1587. X                $Header{'Head'} .= $_ . "\n";
  1588. X                $first_from = $_ if /^From\s+\S+/;
  1589. X                next;
  1590. X            }
  1591. X            $Header{'Body'} .= $_ . "\n";
  1592. X        }
  1593. X        $Header{'Head'} = "$FAKE_FROM\n" .  $Header{'Head'} unless $first_from;
  1594. X
  1595. X        # Now save into folder
  1596. X        ($mbox, $failed, $log_message) = &run_saving($folder, $FOLDER_APPEND);
  1597. X
  1598. X        # Keep track in the logfile of the length of the digest item.
  1599. X        $length = length($Header{'Head'}) + length($Header{'Body'}) + 1;
  1600. X    }
  1601. X    if ($failed) {
  1602. X        if ($loglvl > 2) {
  1603. X            local($s) = $length == 1 ? '' : 's';
  1604. X            &add_log("ERROR unable to save #$item ($length byte$s)") if $item;
  1605. X            &add_log("ERROR unable to save preamble ($length byte$s)")
  1606. X                unless $item;
  1607. X        }
  1608. X    } else {
  1609. X        if ($loglvl > 7) {
  1610. X            local($s) = $length == 1 ? '' : 's';
  1611. X            &add_log("SPLIT #$item in $log_message ($length byte$s)") if $item;
  1612. X            &add_log("SPLIT preamble in $log_message ($length byte$s)")
  1613. X                unless $item;
  1614. X        }
  1615. X    }
  1616. X    ++$item if $item;        # Count items, but not preamble (done by 'split')
  1617. X    $failed;                # Propagate failure status
  1618. X}
  1619. X
  1620. X# Check body message (typically head of digest message) and return 1 if its
  1621. X# body is empty, 0 otherwise.
  1622. Xsub empty_body {
  1623. X    local(*ary) = @_;
  1624. X    local(@array) = @ary;        # Work on a copy
  1625. X    local($_);
  1626. X    local($is_empty) = 1;
  1627. X    do {
  1628. X        $_ = pop(@array);        # Remove what belongs to next digest item
  1629. X    } while !/^---/;
  1630. X    do {
  1631. X        $_ = shift(@array);        # Remove the whole header
  1632. X    } while !/^$/;
  1633. X    foreach (@array) {
  1634. X        $is_empty = 0 unless /^\s*$/;
  1635. X        last unless $is_empty;
  1636. X    }
  1637. X    $is_empty;
  1638. X}
  1639. X
  1640. END_OF_FILE
  1641.   if test 45237 -ne `wc -c <'agent/pl/actions.pl'`; then
  1642.     echo shar: \"'agent/pl/actions.pl'\" unpacked with wrong size!
  1643.   fi
  1644.   # end of 'agent/pl/actions.pl'
  1645. fi
  1646. echo shar: End of archive 3 \(of 17\).
  1647. cp /dev/null ark3isdone
  1648. MISSING=""
  1649. for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 ; do
  1650.     if test ! -f ark${I}isdone ; then
  1651.     MISSING="${MISSING} ${I}"
  1652.     fi
  1653. done
  1654. if test "${MISSING}" = "" ; then
  1655.     echo You have unpacked all 17 archives.
  1656.     rm -f ark[1-9]isdone ark[1-9][0-9]isdone
  1657. else
  1658.     echo You still must unpack the following archives:
  1659.     echo "        " ${MISSING}
  1660. fi
  1661. exit 0
  1662. exit 0 # Just in case...
  1663.