Source Code 1994 March

home *** CD-ROM | disk | FTP | other *** search

/ Source Code 1994 March / Source_Code_CD-ROM_Walnut_Creek_March_1994.iso / compsrcs / misc / volume33 / mailagnt / part03 < prev next >

Wrap

Text File | 1992-11-19 | 54.5 KB | 1,657 lines

Newsgroups: comp.sources.misc From: ram@eiffel.com (Raphael Manfredi) Subject: v33i095: mailagent - Rule Based Mail Filtering, Part03/17 Message-ID: <1992Nov20.050250.13405@sparky.imd.sterling.com> X-Md4-Signature: f923aba983128a02c85d704b413f5aa2 Date: Fri, 20 Nov 1992 05:02:50 GMT Approved: kent@sparky.imd.sterling.com Submitted-by: ram@eiffel.com (Raphael Manfredi) Posting-number: Volume 33, Issue 95 Archive-name: mailagent/part03 Environment: Perl, Sendmail, UNIX #! /bin/sh # This is a shell archive. Remove anything before this line, then feed it # into a shell via "sh file" or similar. To overwrite existing files, # type "sh file -c". # Contents: agent/Makefile.SH agent/pl/actions.pl # Wrapped by kent@sparky on Wed Nov 18 22:42:20 1992 PATH=/bin:/usr/bin:/usr/ucb:/usr/local/bin:/usr/lbin ; export PATH echo If this archive is complete, you will see the following message: echo ' "shar: End of archive 3 (of 17)."' if test -f 'agent/Makefile.SH' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'agent/Makefile.SH'\" else echo shar: Extracting \"'agent/Makefile.SH'\" $6715 characters$ sed "s/^X//" >'agent/Makefile.SH' <<'END_OF_FILE' X: Makefile.SH generated from Jmake.tmpl and Jmakefile [jmake 2.8 PL13] X: $X-Id: Jmake.tmpl,v 2.8.1.2 91/11/18 13:22:54 ram Exp $ X Xcase $CONFIG in X'') X if test ! -f config.sh; then X ln ../config.sh . || \ X ln ../../config.sh . || \ X ln ../../../config.sh . || \ X (echo "Can't find config.sh."; exit 1) X fi 2>/dev/null X . ./config.sh X ;; Xesac Xcase "$0" in X*/*) cd `expr X$0 : 'X$.*$/'` ;; Xesac XCURRENT=agent XDIR=`echo $CURRENT/ | sed -e 's/\.\///g'` Xecho "Extracting ${DIR}Makefile (with variable substitutions)" XDATE=`date` X$spitshell >Makefile <<!GROK!THIS! X######################################################################## X# Makefile generated from Makefile.SH on $DATE X XSHELL = /bin/sh XJMAKE = jmake XTOP = .. XCURRENT = $CURRENT XDIR = $DIR XINSTALL = ../install X X######################################################################## X# Parameters set by Configure -- edit config.sh if changes are needed X XBINDIR = $bin XCTAGS = ctags XL = $manext XMANSRC = $mansrc XMAKE = make XMV = $mv XPRIVLIB = $privlib XRM = $rm -f XSCRIPTDIR = $scriptdir X X######################################################################## X# Automatically generated parameters -- do not edit X XSUBDIRS = files filter man test XSCRIPTS = \$(BIN) X X!GROK!THIS! X$spitshell >>Makefile <<'!NO!SUBS!' X X######################################################################## X# Jmake rules for building libraries, programs, scripts, and data files X# $X-Id: Jmake.rules,v 2.8.1.4 91/11/18 13:19:07 ram Exp $ X X######################################################################## X# Start of Jmakefile X X# $X-Id: Jmakefile,v 2.9.1.2 92/08/26 12:33:22 ram Exp $ X# X# Copyright (c) 1991, Raphael Manfredi X# X# You may redistribute only under the terms of the GNU General Public X# Licence as specified in the README file that comes with dist. X# X# $X-Log: Jmakefile,v $ X# Revision 2.9.1.2 92/08/26 12:33:22 ram X# patch8: new mailhook target, installed in private library directory X# X# Revision 2.9.1.1 92/08/12 21:27:08 ram X# patch6: mailagent is now built with offset table (perload -o) X# X# Revision 2.9 92/07/14 16:47:06 ram X# 3.0 beta baseline. X# X XBIN = mailpatch mailhelp maillist maildist X Xall:: $(BIN) X Xlocal_realclean:: X $(RM) $(BIN) X Xmailpatch: mailpatch.SH X /bin/sh mailpatch.SH X Xmailhelp: mailhelp.SH X /bin/sh mailhelp.SH X Xmaillist: maillist.SH X /bin/sh maillist.SH X Xmaildist: maildist.SH X /bin/sh maildist.SH X X Xinstall:: $(SCRIPTS) $(LSCRIPTS) X @for file in $(SCRIPTS) $(LSCRIPTS); do \ X case '${MFLAGS}' in *[i]*) set +e;; esac; \ X (set -x; $(INSTALL) -c -m 555 $$file $(SCRIPTDIR)); \ X done X Xdeinstall:: X @for file in $(SCRIPTS) $(LSCRIPTS); do \ X case '${MFLAGS}' in *[i]*) set +e;; esac; \ X (set -x; $(RM) $(SCRIPTDIR)/$$file); \ X done X X Xall:: magent X Xlocal_realclean:: X $(RM) magent X Xmagent: magent.SH X /bin/sh magent.SH X X Xall:: mhook X Xlocal_realclean:: X $(RM) mhook X Xmhook: mhook.SH X /bin/sh mhook.SH X X Xall:: mailagent X Xlocal_realclean:: X $(RM) mailagent Xmailagent: magent X $(TOP)/bin/perload -o magent > $@ X chmod +rx $@ X Xall:: mailhook X Xlocal_realclean:: X $(RM) mailhook Xmailhook: mhook X $(TOP)/bin/perload -o mhook > $@ X chmod +rx $@ X Xinstall:: mailagent X $(INSTALL) -c -m 555 mailagent $(BINDIR) X Xdeinstall:: X $(RM) $(BINDIR)/mailagent X Xdepend:: X @case '${MFLAGS}' in *[ik]*) set +e;; esac; \ X for i in filter ;\ X do \ X (cd $$i ; echo "Depending" "in $(DIR)$$i..."; \ X $(MAKE) $(MFLAGS) depend); \ X done X Xinstall:: X @for dir in $(PRIVLIB); do \ X case '${MFLAGS}' in *[i]*) set +e;; esac; \ X (set -x; $(INSTALL) -d $$dir); \ X done X Xdeinstall:: X $(RM) -r $(PRIVLIB) X Xinstall:: mailhook X @case '${MFLAGS}' in *[i]*) set +e;; esac; \ X for i in mailhook; do \ X (set -x; $(INSTALL) -c -m 555 $$i $(PRIVLIB)); \ X done X Xdeinstall:: X @case '${MFLAGS}' in *[i]*) set +e;; esac; \ X for i in mailhook; do \ X (set -x; $(RM) $(PRIVLIB)/$$i); \ X done X X######################################################################## X# Common rules for all Makefiles -- do not edit X Xemptyrule:: X Xclean: sub_clean local_clean Xrealclean: sub_realclean local_realclean Xclobber: sub_clobber local_clobber X Xlocal_clean:: X $(RM) core *~ *.o X Xlocal_realclean:: local_clean X Xlocal_clobber:: local_realclean X $(RM) Makefile config.sh X XMakefile.SH: Jmakefile X -@if test -f $(TOP)/.package; then \ X if test -f Makefile.SH; then \ X echo " $(RM) Makefile.SH~; $(MV) Makefile.SH Makefile.SH~"; \ X $(RM) Makefile.SH~; $(MV) Makefile.SH Makefile.SH~; \ X fi; \ X echo " $(JMAKE) -DTOPDIR=$(TOP) -DCURDIR=$(CURRENT)" ; \ X $(JMAKE) -DTOPDIR=$(TOP) -DCURDIR=$(CURRENT) ; \ X else touch $@; exit 0; fi X XMakefile: Makefile.SH X /bin/sh Makefile.SH X Xtags:: X $(CTAGS) -w *.[ch] X $(CTAGS) -xw *.[ch] > tags X Xlocal_clobber:: X $(RM) tags X X######################################################################## X# Rules for building in sub-directories -- do not edit X Xsubdirs: X @case '${MFLAGS}' in *[ik]*) set +e;; esac; \ X for i in $(SUBDIRS) ;\ X do \ X (cd $$i ; echo $(VERB) "in $(DIR)$$i..."; \ X $(MAKE) $(MFLAGS) $(FLAGS) $(TARGET)); \ X done X Xinstall:: X @$(MAKE) subdirs TARGET=install VERB="Installing" FLAGS= X Xdeinstall:: X @$(MAKE) subdirs TARGET=deinstall VERB="Deinstalling" FLAGS= X Xinstall.man:: X @$(MAKE) subdirs TARGET=install.man VERB="Installing man pages" FLAGS= X Xdeinstall.man:: X @$(MAKE) subdirs TARGET=deinstall.man VERB="Deinstalling man pages" FLAGS= X Xsub_clean:: X @$(MAKE) subdirs TARGET=clean VERB="Cleaning" FLAGS= X @echo "Back to $(CURRENT) for "clean... X Xsub_realclean:: X @$(MAKE) subdirs TARGET=realclean VERB="Real cleaning" FLAGS= X @echo "Back to $(CURRENT) for "realclean... X Xsub_clobber:: X @$(MAKE) subdirs TARGET=clobber VERB="Clobbering" FLAGS= X @echo "Back to $(CURRENT) for "clobber... X Xtag:: X @case '${MFLAGS}' in *[ik]*) set +e;; esac; \ X for i in ;\ X do \ X (cd $$i ; echo "Tagging" "in $(DIR)$$i..."; \ X $(MAKE) $(MFLAGS) tag); \ X done X XMakefiles:: X @case '${MFLAGS}' in *[ik]*) set +e;; esac; \ X for i in $(SUBDIRS);\ X do \ X echo "Making "Makefiles" in $(DIR)$$i..."; \ X (cd $$i || exit 1; \ X if test ! -f Makefile; then /bin/sh Makefile.SH; fi; \ X $(MAKE) $(MFLAGS) Makefiles) \ X done X XMakefiles.SH:: Makefile.SH X @case '${MFLAGS}' in *[ik]*) set +e;; esac; \ X for i in $(SUBDIRS);\ X do \ X case "$(DIR)$$i/" in \ X */*/*/*/) newtop=../../../..;; \ X */*/*/) newtop=../../..;; \ X */*/) newtop=../..;; \ X */) newtop=..;; \ X esac; \ X case "$(TOP)" in \ X /*) newtop="$(TOP)" ;; \ X esac; \ X echo "Making Makefiles.SH in $(DIR)$$i..."; \ X (cd $$i || exit 1; $(MAKE) $(MFLAGS) -f ../Makefile \ X Makefile TOP=$$newtop CURRENT=$(DIR)$$i;\ X $(MAKE) $(MFLAGS) Makefiles.SH) \ X done X Xall:: X @$(MAKE) subdirs TARGET=all VERB="Making all" FLAGS= X X!NO!SUBS! Xchmod 644 Makefile X$eunicefix Makefile X END_OF_FILE if test 6715 -ne `wc -c <'agent/Makefile.SH'`; then echo shar: \"'agent/Makefile.SH'\" unpacked with wrong size! fi chmod +x 'agent/Makefile.SH' # end of 'agent/Makefile.SH' fi if test -f 'agent/pl/actions.pl' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'agent/pl/actions.pl'\" else echo shar: Extracting \"'agent/pl/actions.pl'\" $45237 characters$ sed "s/^X//" >'agent/pl/actions.pl' <<'END_OF_FILE' X;# $Id: actions.pl,v 2.9.1.3 92/11/01 15:44:28 ram Exp $ X;# X;# Copyright (c) 1992, Raphael Manfredi X;# X;# You may redistribute only under the terms of the GNU General Public X;# Licence as specified in the README file that comes with dist. X;# X;# $Log: actions.pl,v $ X;# Revision 2.9.1.3 92/11/01 15:44:28 ram X;# patch11: the PERL command now sets up @ARGV as if invoked from shell X;# patch11: fixed message substitution bug (for MESSAGE and NOTIFY) X;# X;# Revision 2.9.1.2 92/08/26 13:07:38 ram X;# patch8: saving command now supports executable folder hooks X;# patch8: explicit chdir to the home directory performed before RUN X;# patch8: value in ASSIGN is ran through perl first, for expressions X;# patch8: new PERL command to escape to a perl script X;# X;# Revision 2.9.1.1 92/08/02 16:06:57 ram X;# patch2: bad commands were not correctly formatted when sent back X;# patch2: existing Sender field rewritten as Prev- instead of Original- X;# patch2: new -a option for SPLIT to tag each digest item X;# patch2: now waits only 2 seconds for child initialization X;# patch2: headers are case-normalized before entry in %Header X;# patch2: moved flow altering functions from filter.pl X;# patch2: headers in STRIP or KEEP are searched for case-insensitively X;# patch2: the Resent-To field added by FORWARD is now formatted X;# X;# Revision 2.9 92/07/14 16:49:31 ram X;# 3.0 beta baseline. X;# X;# X# X# Implementation of filtering commands X# X X# The "LEAVE" command X# Leave a copy of the message in the mailbox. Returns (mbox, failed_status) Xsub leave { X local($mailbox) = &mailbox_name; # Incomming mailbox filename X do add_log("starting LEAVE") if $loglvl > 15; X do save($mailbox); # Propagate return status X} X X# The "SAVE" command X# Save a message in a folder. Returns (mbox, failed_status). If the folder X# already exists and has the 'x' bit set, then is is understood as an external X# hook and mailhook is invoked. Xsub save { X local($mailbox) = @_; # Where mail should be saved X local($failed) = 0; # Printing status X &add_log("starting SAVE $mailbox") if $loglvl > 15; X if (-x $mailbox) { # Folder hook X &save_hook; X } else { X &save_folder; X } X &emergency_save if $failed; X ($mailbox, $failed); # Where save was made and failure status X} X X# Called by &save when folder is a regular one (i.e. not a hook). Manipulates X# variables in the context of &save. Xsub save_folder { X if (open(MBOX, ">>$mailbox")) { X do mbox_lock($mailbox); # Lock mailbox X # First print the Header, and add the X-Filter: line. X (print MBOX $Header{'Head'}) || ($failed = 1); X (print MBOX $FILTER, "\n\n") || ($failed = 1); X (print MBOX $Header{'Body'}) || ($failed = 1); X print MBOX "\n"; # Allow parsing by other tools X do mbox_unlock($mailbox); # Will close file X # Logging only in case of error X if ($failed) { X do add_log("ERROR could not save mail in $mailbox") if $loglvl > 0; X } X } else { X if (-f "$mailbox") { X do add_log("ERROR cannot append to $mailbox") if $loglvl; X } else { X do add_log("ERROR cannot create $mailbox") if $loglvl; X } X $failed = 1; X } X} X X# Called by &save when folder is a hook. This simply calls the mailhook X# program, which will analyze the hook and perform the necessary actions. Xsub save_hook { X &add_log("hooking mail on folder") if $loglvl > 15; X $failed = X &shell_command("$privlib/mailhook $mailbox", $MAIL_INPUT, $NO_FEEDBACK); X} X X# The "PROCESS" command X# The body of the message is expected to be in $Header{'Body'} Xsub process { X local($subj) = $Header{'Subject'}; X local($msg_id) = $Header{'Message-Id'}; X local($sender) = $Header{'Reply-To'}; X local($to) = $Header{'To'}; X local($bad) = ""; # No bad commands X local($pack) = "auto"; # Default packing mode for sending files X local($ncmd) = 0; # Number of valid commands we have found X local($dest) = ""; # Destination (where to send answers) X local(@cmd); # Array of all commands X local(%packmode); # Records pack mode for each command X local($error) = 0; # Error report code X local(@body); # Body of message X X &add_log("starting PROCESS") if $loglvl > 15; X X # If no @PATH directive was found, use $sender as a return path X $dest = $Userpath; # Set by an @PATH X $dest = $sender unless $dest; X # Remove the <> if any (e.g. path derived from Return-Path) X $dest =~ /<(.*)>/ && ($dest = $1); X X # Debugging purposes X &add_log("@PATH was '$Userpath' and sender was '$sender'") if $loglvl > 18; X &add_log("computed destination: $dest") if $loglvl > 15; X X # Copy body of message in an array, one line per entry X @body = split(/\n/, $Header{'Body'}); X X # The command file contains the authorized commands X if ($#command < 0) { # Command file not processed yet X open(COMMAND, "$cf'comfile") || do fatal("No command file!"); X while (<COMMAND>) { X chop; X $command{$_} = 1; X } X close(COMMAND); X } X X line: foreach (@body) { X # Built-in commands X if (/^@PACK\s*(.*)/) { # Pack mode X $pack = $1 if $1 ne ''; X $pack = "" if ($pack =~ /[=$^&*([{}`\\|;><?]/); X } X s/^[ \t]@SH/@SH/; # allow one blank only X if (/^@SH/) { X s/\\!/!/g; # if uucp address, un-escape `!' X if (/[=\$^&*([{}`\\|;><?]/) { X s/^@SH/bad command:/; # space after ":" will be added X $bad .= $_ . "\n"; X next line; X } X # Some useful substitutions X s/@SH[ \t]*//; # Allow leading blanks X s/ PATH/ $dest/; # PATH is a macro X s/^mial(\w*)/mail\1/; # Common mis-spellings X s/^mailpath/mailpatch/; X s/^mailist/maillist/; X # Now fetch command's name (first symbol) X if (/^([^ \t]+)[ \t]/) { X $first = $1; X } else { X $first = $_; X } X if (!$command{$first}) { # if un-authorized cmd X s/^/unknown cmd: /; # needs a space after ":" X $bad .= $_ . "\n"; X next line; X } X $packmode{$_} = $pack; # packing mode for this command X push(@cmd, $_); # record command X } X } X X # ************* Check with authoritative file **************** X X # Do not continue if an error occurred, in which case the mail will remain X # in the queue and will be processed later on. X return $error if $error || $dest eq ''; X X # Now we are sure the mail we proceed is for us X $sender = "<someone>" if $sender eq ''; X $ncmd = $#cmd + 1; X if ($ncmd > 1) { X do add_log("$ncmd commands for $sender") if ($loglvl > 11); X } elsif ($ncmd == 1) { X do add_log("1 command for $sender") if ($loglvl > 11); X } else { X do add_log("no command for $sender") if ($loglvl > 11); X } X foreach $fullcmd (@cmd) { X $cmdfile = "/tmp/mess.cmd$$"; X open(CMD,">$cmdfile"); X # For our children X print CMD "jobnum=$jobnum export jobnum\n"; X print CMD "fullcmd=\"$fullcmd\" export fullcmd\n"; X print CMD "pack=\"$packmode{$fullcmd}\" export pack\n"; X print CMD "path=\"$dest\" export path\n"; X print CMD "sender=\"$sender\" export sender\n"; X print CMD "set -x\n"; X print CMD "$fullcmd\n"; X close CMD; X $fullcmd =~ /^[ \t]*(\w+)/; # extract first word X $cmdname = $1; # this is the command name X $trace = "$cf'tmpdir/trace.cmd$$"; X $pid = fork; # We fork here X if ($pid == 0) { X open(STDOUT, ">$trace"); # Where output goes X open(STDERR, ">&STDOUT"); # Make it follow pipe X exec '/bin/sh', "$cmdfile"; # Don't use sh -c X } elsif ($pid == -1) { X # Set the error report code, and the mail will remain in queue X # for later processing. Any @RR in the message will be re-executed X # but it is not really important. In fact, this is going to be X # a feature, not a bug--RAM. X $error = 1; X open(MAILER,"|/usr/lib/sendmail -odq -t"); X print MAILER X"To: $dest XBcc: $cf'user XSubject: $cmdname not executed XX-Mailer: mailagent [version $mversion PL$patchlevel] X XYour command was: $fullcmd X XIt was not executed because I could not fork. Sigh ! X XThe command has been left in a queue and will be processed again Xas soon as possible, so it is useless to resend it. X X-- mailagent speaking for $cf'user"; X close MAILER; X if ($?) { X do add_log("ERROR cannot report failure") X if ($loglvl > 0); X } X do add_log("ERROR cannot fork") if $loglvl > 0; X return $error; # Abort processing now--mail remains in queue X } else { X wait(); X if ($?) { X open(MAILER,"|/usr/lib/sendmail -odq -t"); X print MAILER X"To: $dest XBcc: $cf'user XSubject: $cmdname returned a non-zero status XX-Mailer: mailagent [version $mversion PL$patchlevel] X XYour command was: $fullcmd XIt produced the following output and failed: X X"; X if (open(TRACE, "$trace")) { X while (<TRACE>) { X print MAILER; X } X close TRACE; X } else { X print MAILER "** SORRY - NOT AVAILABLE **\n"; X do add_log("ERROR cannot dump trace") if ($loglvl > 0); X } X print MAILER "\n-- mailagent speaking for $cf'user"; X close MAILER; X if ($?) { X do add_log("ERROR cannot report failure") X if ($loglvl > 0); X } X do add_log("FAILED $fullcmd") if $loglvl > 1; X } else { X do add_log("OK $fullcmd") if $loglvl > 5; X } X } X unlink $cmdfile, $trace; X } X X if ($bad) { X open(MAILER,"|/usr/lib/sendmail -odq -t"); X chop($bad); # Remove trailing new-line X print MAILER X"To: $dest XBcc: $cf'user XSubject: the following commands were not executed XX-Mailer: mailagent [version $mversion PL$patchlevel] X X$bad X XIf $cf'name can figure out what you wanted, he may do it anyway. X X-- mailagent speaking for $cf'user X"; X close MAILER; X if ($?) { X do add_log( X "ERROR unable to mail back bad commands from $sender" X ) if ($loglvl > 0); X } X do add_log("bad commands from $sender") if ($loglvl > 5); X } X X do add_log("all done for $sender") if ($loglvl > 11); X $error; # Return error report (0 for ok) X} X X# The "MESSAGE" command Xsub message { X local($msg) = @_; # Vacation message to be sent back X local(@head) = ( X "To: %r (%N)", X "Subject: Re: %R" X ); X do send_message($msg, *head); X} X X# The "NOTIFY" command Xsub notify { X local($msg, $address) = @_; X # Protect all '%' in the address (subject to macro substitution) X $address =~ s/%/%%/g; X local(@head) = ( X "To: $address", X "Subject: %s (notification)" X ); X do send_message($msg, *head); X} X X# Send a given message to somebody, as specified in the given header X# The message and the header are subject to macro substitution Xsub send_message { X local($msg, *header) = @_; # Message to send, header of message X unless (-f "$msg") { X do add_log("cannot find message $msg") if $loglvl > 0; X return 1; X } X unless (open(MSG, "$msg")) { X do add_log("cannot open message $msg") if $loglvl > 0; X return 1; X } X unless (open(MAILER,"|/usr/lib/sendmail -odq -t")) { X do add_log("cannot run sendmail to send message") if $loglvl > 0; X return 1; X } X X # Construction of value for the %T macro X local($macro_T); # Default value of macro %T is overwritten X local($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime, $mtime, X $ctime,$blksize,$blocks) = stat($msg); X local($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = X localtime($mtime); X local($this_year) = (localtime(time))[5]; X # Do not put the year in %T if it is the same as the current one. X ++$mon; # Month in the range 1-12 X if ($this_year != $year) { X $macro_T = sprintf("%.2d/%.2d/%.2d", $year, $mon, $mday); X } else { X $macro_T = sprintf("%.2d/%.2d", $mon, $mday); X } X X # Header construction. If the file contains a header at the top, it is X # added to the one we already have by default. Identical fields are X # overwritten with the one found in the file. X if (&header_found($msg)) { # Top of message is a header X local(@newhead); # New header is constructed here X local($field); X while (<MSG>) { # Read the header then X last if /^$/; # End of header X chop; X push(@newhead, $_); X if (/^([\w\-]+):/) { X $field = $1; X @head = grep(!/^$field:/, @head); # Field is overwritten X } X } X foreach (@newhead) { X push(@head, $_); X } X } X push(@head, $FILTER); # Avoid loops: replying to ourselves or whatever X foreach $line (@head) { X do macros_subst(*line); # In-place macro substitutions X print MAILER "$line\n"; # Write header X } X print MAILER "\n"; # Header separated from body X # Now write the body X local($tmp); # Because of a bug in perl 4.0 PL19 X while ($tmp = <MSG>) { X next if $tmp =~ /^$/ && $. == 1; # Escape sequence to protect header X do macros_subst(*tmp); # In-place macro substitutions X print MAILER $tmp; # Write message line X } X X # Close pipe and check status X close MSG; X close MAILER; X local($status) = $?; X unless ($status) { X if ($loglvl > 2) { X local($dest) = $head[0]; # The To: header line X ($dest) = $dest =~ m|^To:\s+(.*)|; X do add_log("SENT message to $dest"); X } X } else { X do add_log("ERROR could not mail back $msg") if $loglvl > 1; X } X $status; # 0 for success X} X X# The "FORWARD" command Xsub forward { X local($addresses) = @_; # Address(es) mail should be forwarded to X local($address) = &email_addr; # Address of user X # Any address included withing "" is in fact a file name where actual X # forwarding addresses are found. X $addresses = &complete_addr($addresses); # Process "include-requests" X unless (open(MAILER,"|/usr/lib/sendmail -odq $addresses")) { X do add_log("cannot run sendmail to forward message") if $loglvl > 0; X return 1; X } X local(@addr) = split(' ', $addresses); X print MAILER &header'format("Resent-From: $address"), "\n"; X local($to) = "Resent-To: ", join(', ', @addr); X print MAILER &header'format($to), "\n"; X # Protect Sender: and Resent-: lines in the original message X foreach (split(/\n/, $Header{'Head'})) { X next if /^From\s+(\S+)/; X s/^Sender:\s*(.*)/Prev-Sender: $1/; X s/^Resent-([\w\-]+):\s*(.*)/Prev-Resent-$1: $2/; X print MAILER $_, "\n"; X } X print MAILER $FILTER, "\n"; X print MAILER "\n"; X print MAILER $Header{'Body'}; X close MAILER; X local($failed) = $?; # Status of forwarding X if ($failed) { X do add_log("ERROR could not forward to $addresses") if $loglvl > 1; X } X $failed; # 0 for success X} X X# The "BOUNCE" command Xsub bounce { X local($addresses) = @_; # Address(es) mail should be bounced to X # Any address included withing "" is in fact a file name where actual X # bouncing addresses are found. X $addresses = &complete_addr($addresses); # Process "include-requests" X unless (open(MAILER,"|/usr/lib/sendmail -odq $addresses")) { X do add_log("cannot run sendmail to bounce message") if $loglvl > 0; X return 1; X } X # Protect Sender: lines in the original message X foreach (split(/\n/, $Header{'Head'})) { X next if /^From\s+(\S+)/; X s/^Sender:\s*(.*)/Original-Sender: $1/; X print MAILER $_, "\n"; X } X print MAILER $FILTER, "\n"; X print MAILER "\n"; X print MAILER $Header{'Body'}; X close MAILER; X local($failed) = $?; # Status of forwarding X if ($failed) { X do add_log("ERROR could not bounce to $addresses") if $loglvl > 1; X } X $failed; # 0 for success X} X X# The "POST" command Xsub post { X # Option parsing: a -l restricts distribution to local X local($localdist) = 0; X $localdist = 1 if ($_[0] =~ s/^\s*-l\s+//); X local($newsgroups) = @_; # Newsgroup(s) mail should be posted to X local($address) = &email_addr; # Address of user X unless (open(NEWS,"| $inews -h")) { X do add_log("cannot run $inews to post message") if $loglvl > 0; X return 1; X } X do add_log("distribution of posting is local") X if $loglvl > 18 && $localdist; X # Protect Sender: lines in the original message and clean-up header X local($last_was_header); # Set to true when header is skipped X foreach (split(/\n/, $Header{'Head'})) { X s/^Sender:\s*(.*)/Original-Sender: $1/; X next if /^From\s/; # First From line... X if ( X /^To:/ || X /^Cc:/ || X /^Apparently-To:/ || X /^Distribution:/ || # No mix-up, please X /^X-Mailer:/ || # Mailer identification X /^Newsgroups:/ || # Reply from news reader X /^Return-Receipt-To:/ || # Sendmail's acknowledgment X /^Received:/ || # We want to remove received X /^Errors-To:/ || # Error report redirection X /^Resent-[\w-]*:/ # Resent tags X ) { X $last_was_header = 1; # Mark we discarded the line X next; # Line is skipped X } X next if /^\s/ && $last_was_header; # Skip removed header continuations X $last_was_header = 0; # We decided to keep header line X print NEWS $_, "\n"; X } X # If no subject is present, fake one to make inews happy X unless (defined($Header{'Subject'}) && $Header{'Subject'} ne '') { X do add_log("WARNING no subject, faking one") if $loglvl > 5; X print NEWS "Subject: <none>\n"; X } X print NEWS "Newsgroups: $newsgroups\n"; X print NEWS "Distribution: local\n" if $localdist; X # Avoid loops: inews may forward to sendmail X print NEWS $FILTER, "\n"; X print NEWS "\n"; X print NEWS $Header{'Body'}; X close NEWS; X local($failed) = $?; # Status of forwarding X if ($failed) { X do add_log("ERROR could not post to $newsgroups") if $loglvl > 1; X } X $failed; # 0 for success X} X X# The "SPLIT" command X# This routine is RFC-934 compliant and will correctly burst digests produced X# with this RFC in mind. For instance, MH produces RFC-934 style digest. X# However, in order to reliably split non RFC-934 digest, some extra work is X# performed to ensure a meaningful output. Xsub split { X # Option parsing: a -i splits "inplace", i.e. acts as a saving if the split X # is fully successful. A -d discards the leading part. A -q queues messsages X # instead of filling them into a folder. X $_[0] =~ s/^\s*-([adeiw]+)//; # Remove options X local($opt) = $1; X local($inplace) = $opt =~ /i/; # Inplace (original marked saved) X local($discard) = $opt =~ /d/; # Discard digest leading part X local($empty) = $opt =~ /e/; # Discard leading digest only if empty X local($watch) = $opt =~ /w/; # Watch digest closely X local($annotate) = $opt =~ /a/; # Annotate items with X-Digest-To: field X $_[0] =~ s/^\s+//; # Trim leading spaces X local($folder) = $_[0]; # Folder to save messages X local(@leading); # Leading part of the digest X local(@header); # Looked ahead header X local($found_header) = 0; # True when header digest was found X local($look_header) = 0; # True when we are looking for a mail header X local($found_end) = 0; # True when end of digest found X local($valid); # Return value from header checking package X local($failed) = 0; # Queuing status for each mail item X local(@body); # Body of extracted mail X local($item) = 0; # Count digest items found X local($not_rfc934) = 0; # Is digest RFC-934 compliant? X local($digest_to); # Value of the X-Digest-To: field X local($_); X # If item annotation is requested, then each item will have a X-Digest-To: X # field added, which lists both the To: and Cc: fields of the original X # digest message. X if ($annotate) { # Annotation requested X $digest_to = $Header{'Cc'}; X $digest_to = ', ' . $digest_to if $digest_to; X $digest_to = 'X-Digest-To: ' . $Header{'To'} . $digest_to; X $digest_to = &header'format($digest_to); X } X # Start digest parsing. According to RFC-934, we could only look for a X # single '-' as encapsulation boundary, but for safety we look for at least X # three consecutive ones. X foreach (split(/\n/, $Header{'All'})) { X push(@leading, $_) unless $found_header; X push(@body, $_) if $found_header; X if (/^---/) { # Start looking for mail header X $look_header = 1; # Focus on mail headers now X # We are withing the body of a digest and we've just reached X # what may be the end of a message, or the end of the leading part. X @header = (); # Reset look ahead buffer X &header'reset; # Reset header checking package X next; X } X next unless $look_header; X # Record lines we find, but skip possible blank lines after dash. X # Note that RFC-934 does not make spaces compulsory after each X # encapsulation boundary (EB) but they are allowed nonetheless. X next if /^\s*$/ && 0 == @header; X $found_end = 0; # Maybe it's not garbage after all... X $valid = &header'valid($_); X if ($valid == 0) { # Not a valid header X $look_header = 0; # False alert X $found_end = 1; # Garbage after last EB is to be ignored X if ($watch) { X # Strict RFC-934: if an EB is followed by something which does X # not prove to be a valid header but looked like one, enough X # to have some lines collected into @header, then signal it. X ++$not_rfc934 unless 0 == @header; X } else { X # Don't be too scrict. If what we have found so far *may be* a X # header, then yes, it's not RFC-934. Otherwise let it go. X ++$not_rfc934 if $header'maybe; X } X next; X } elsif ($valid == 1) { # Still in header X push(@header, $_); # Record header lines X next; X } X # Coming here means we reached the end of a valid header X push(@header, $digest_to) if $annotate; X push(@header, ''); # Blank header line X if (!$found_header) { X if ($empty) { X $failed |= &save_mail(*leading, $folder) X unless &empty_body(*leading) || $discard; X } else { X $failed |= &save_mail(*leading, $folder) unless $discard; X } X undef @leading; # Not needed any longer X $item++; # So that 'save_mail' starts logging items X } X # If there was already a mail being collected, save it now, because X # we are sure it is followed by a valid mail. X $failed |= &save_mail(*body, $folder) if $found_header; X $found_header = 1; # End of header -> this is truly a digest X $look_header = 0; # We found our header X &header'clean(*header); # Ensure minimal set of header X @body = @header; # Copy headers in mail body for next message X } X X return -1 unless $found_header; # Message was not in digest format X X # Save last message, making sure to add a final dash line if digest did X # not have one: There was one if $look_header is true. There was also X # one if $found_end is true. X push(@body, '---') unless $look_header || $found_end; X X # If the -w option was used, we look closely at the supposed trailing X # garbage. If the length is greater than 100 characters, then maybe we X # are missing something here... X if ($watch) { X local($idx) = $#body; X $_ = $body[$idx]; # Get last line X @header = (); # Reset "garbage collector" X unless (/^---/) { # Do not go on if end of digest truly found X for (; $idx >= 0; $idx--) { X $_ = $body[$idx]; X last if /^---/; # Reached end of presumed trailing garbage X unshift(@header, $_); X } X } X } X X # Now save last message X $failed |= &save_mail(*body, $folder); X X # If we collected something into @header and if it is big enough, save it X # as a trailing message. X if ($watch && length(join('', @header)) > 100) { X &add_log("NOTICE [$mfile] has trailing garbage...") if $loglvl > 6; X @body = @header; # Copy saved garbage X @header = (); # Now build final garbage headers X $header[0] = 'Subject: ' . $Header{'Subject'} . ' (trailing garbage)'; X $header[1] = $digest_to if $annotate; X &header'clean(*header); # Build other headers X unshift(@body, '') unless $body[0] =~ s/^\s*$//; # Ensure EOH X foreach (@body) { X push(@header, $_); X } X push(@header, '---'); X $failed |= &save_mail(*header, $folder); X } X X $failed + 0x2 * $inplace + 0x4 * ($folder =~ /^\s*$/) X + 0x8 * ($not_rfc934 > 0); X} X X# The "RUN" command and its friends X# Start a shell command and mail any output back to the user. The program is X# invoked from within the home directory. Xsub shell_command { X local($program, $input, $feedback) = @_; X unless (chdir $cf'home) { X &add_log("WARNING: cannot chdir to $cf'home: $!") if $loglvl > 5; X } X $program =~ s/^\s*~/$cf'home/; # ~ substitution X $program =~ s/\b~/$cf'home/g; # ~ substitution as first letter in word X $SIG{'PIPE'} = 'popen_failed'; # Protect against naughty program X $SIG{'ALRM'} = 'alarm_clock'; # Protect against loops X alarm 3600; # At most one hour of processing X eval "&execute_command(q\0$program\0, $input, $feedback)"; X alarm 0; # Disable alarm timeout X $SIG{'PIPE'} = 'emergency'; # Restore initial value X $SIG{'ALRM'} = 'DEFAULT'; # Restore default behaviour X if ($@ =~ /^failed/) { # Something went wrong? X do add_log("ERROR couldn't run '$program'") if $loglvl > 0; X return 1; # Failed X } elsif ($@ =~ /^aborted/) { # Writing to program failed X do add_log("WARNING pipe closed by '$program'") if $loglvl > 5; X return 1; # Failed X } elsif ($@ =~ /^feedback/) { # Feedback failed X do add_log("WARNING no feedback occurred") if $loglvl > 5; X return 1; # Failed X } elsif ($@ =~ /^alarm/) { # Timeout X do add_log("WARNING time out received") if $loglvl > 5; X return 1; # Failed X } elsif ($@ =~ /^non-zero/) { # Program returned non-zero status X &add_log("WARNING program returned non-zero status") if $loglvl > 5; X return 1; X } elsif ($@) { X do add_log("ERROR $@") if $loglvl > 0; X return 1; # Failed X } X 0; # Everything went fine X} X X# Abort execution of command when popen() fails or program dies abruptly Xsub popen_failed { X unlink "$trace" if -f "$trace"; X die "$error\n"; X} X X# When an alarm call is received, we should be in the 'execute_command' X# routine. The $pid variable holds the pid number of the process to be killed. Xsub alarm_clock { X if ($trace ne '' && -f "$trace") { # We come from execute_command X local($status) = "terminated"; # Process was terminated X if (kill "SIGTERM", $pid) { # We could signal our child X sleep 30; # Give child time to die X unless (kill "SIGTERM", $pid) { # Child did not die yet ? X unless (kill "SIGKILL", $pid) { X do add_log("ERROR could not kill process $pid: $!") X if $loglvl > 1; X } else { X $status = "killed"; X do add_log("KILLED process $pid") if $loglvl > 4; X } X } else { X do add_log("TERMINATED process $pid") if $loglvl > 4; X } X } else { X $status = "unknwon"; # Process died ? X do add_log("ERROR coud not signal process $pid: $!") X if $loglvl > 1; X } X do mail_back(); # Mail back any output we have so far X unlink "$trace"; # Remove output of command X } X die "alarm call\n"; # Longjmp to shell_command X} X X# Execute the command, ran in an eval to protect against SIGPIPE signals Xsub execute_command { X local($program, $input, $feedback) = @_; X local($trace) = "$cf'tmpdir/trace.run$$"; # Where output goes X local($error) = "failed"; # Error reported by popen_failed X pipe(READ, WRITE); # Open a pipe X local($ppid) = $$; # Pid of parent process X local($pid) = fork; # We fork here X if ($pid == 0) { # Child process X alarm 0; X close WRITE; # The child reads from pipe X open(STDIN, "<&READ"); # Redirect stdin to pipe X close READ if $input == $NO_INPUT; # Close stdin if needed X unless (open(STDOUT, ">$trace")) { # Where output goes X do add_log("WARNING couldn't create $trace") if $loglvl > 5; X if ($feedback == $FEEDBACK) { # Need trace if feedback X kill 'SIGPIPE', $ppid; # Parent still waiting X exit 1; X } X } X open(STDERR, ">&STDOUT"); # Make it follow pipe X exec "$program"; # Run the program now X do add_log("ERROR couldn't exec '$program': $!") if $loglvl > 1; X kill 'SIGPIPE', $ppid; # Parent still waiting X exit 1; X } elsif ($pid == -1) { X do add_log("ERROR couldn't fork: $!") if $loglvl; X return; X } X close READ; # The parent writes to its child X # In case 'sleep' is inplemented using an alarm call, take precautions... X local($remaining) = alarm 0; # Stop alarm, save remaining time X sleep 2; # Let the child initialize X alarm $remaining; # Restore alarm clock X $error = "aborted"; # Error reported by popen_failed X select(WRITE); X $| = 1; # Hot pipe wanted X select(STDOUT); X # Now feed the program with the mail X if ($input == $BODY_INPUT) { # Pipes body X print WRITE $Header{'Body'}; X } elsif ($input == $MAIL_INPUT) { # Pipes the whole mail X print WRITE $Header{'All'}; X } elsif ($input == $HEADER_INPUT) { # Pipes the header X print WRITE $Header{'Head'}; X } X close WRITE; # Close input, before waiting! X wait(); # Wait for our child X local($status) = $? ? "failed" : "ok"; X if ($?) { X # Log execution failure and return to shell_command via die if some X # feedback was to be done. X do add_log("ERROR execution failed for '$program'") if $loglvl > 1; X if ($feedback == $FEEDBACK) { # We wanted feedback X do mail_back(); # Mail back any output X unlink "$trace"; # Remove output of command X die "feedback\n"; # Longjmp to shell_command X } X } X &handle_output; # Take appropriate action with command output X unlink "$trace"; # Remove output of command X die "non-zero status\n" unless $status eq 'ok'; X} X X# If no feedback is wanted, simply mail the output of the commands to the X# user. However, in case of feedback, we have to update the values of X# %Header in the entries 'All', 'Body' and 'Head'. Note that the other X# header fields are left untouched. Only a RESYNC can synchronize them X# (this makes sense only for a FEED command, of course). X# Uses $feedback from execute_command Xsub handle_output { X if ($feedback == $NO_FEEDBACK) { X &mail_back; # Mail back any output X } elsif ($feedback == $FEEDBACK) { X &feed_back; # Feed result back into %Header X } X} X X# Mail back the contents of the trace file (output of program), if not empty. X# Uses some local variables from execute_command Xsub mail_back { X local($size) = -s "$trace"; # Size of output X return unless $size; # Nothing to be done if no output X local($std_input); # Standard input used X $std_input = "none" if $input == $NO_INPUT; X $std_input = "mail body" if $input == $BODY_INPUT; X $std_input = "whole mail" if $input == $MAIL_INPUT; X $std_input = "header" if $input == $HEADER_INPUT; X local($program_name) = $program =~ m|^(\S+)|; X open(MAILER,"|/usr/lib/sendmail -odq -t"); X print MAILER X"To: $cf'user XSubject: Output of your '$program_name' command ($status) XX-Mailer: mailagent [version $mversion PL$patchlevel] X XYour command was: $program XInput: $std_input XStatus: $status X XIt produced the following output: X X"; X unless (open(TRACE, "$trace")) { X do add_log("ERROR couldn't reopen $trace") if $loglvl > 1; X print MAILER "*** SORRY -- NOT AVAILABLE ***\n"; X } else { X while (<TRACE>) { X print MAILER; X } X close TRACE; X } X close MAILER; X unless ($?) { X do add_log("SENT output of '$program_name' to $cf'user ($size bytes)") X if $loglvl > 2; X } else { X do add_log("ERROR couldn't send $size bytes to $cf'user") if $loglvl; X } X} X X# Feed back output of a command in the %Header data structure. X# Uses some local variables from execute_command Xsub feed_back { X unless (open(TRACE, "$trace")) { X do add_log("ERROR couldn't feed back from $trace: $!") if $loglvl > 1; X unlink "$trace"; # Maybe I should leave it around X die "feedback\n"; # Return to shell_command X } X local($temp) = ' ' x 2000; # Temporary storage (pre-extended) X $temp = ''; X if ($input == $BODY_INPUT) { # We have to feed back the body only X while (<TRACE>) { X s/^From\s/>From$1/; # Protect potentially dangerous lines X $temp .= $_; X } X } else { X local($head) = ' ' x 500; # Pre-extend header X $head = ''; X while (<TRACE>) { X if (1../^$/) { X $head .= $_ unless /^$/; X } else { X s/^From\s/>From$1/; # Protect potentially dangerous lines X $temp .= $_; X } X } X $Header{'Head'} = $head; X } X close TRACE; X $Header{'Body'} = $temp unless $input == $HEADER_INPUT; X $Header{'All'} = $Header{'Head'} . "\n" . $Header{'Body'}; X} X X# Feed output back into $Back variable (used by BACK command). Typically, the X# BACK command is used with RUN, though any other command is allowed (but does X# not always make sense). X# NB: This routine: X# - Is never called explicitely but via a type glob through *handle_output X# - Uses some local variables from execute_command Xsub xeq_back { X unless (open(TRACE, "$trace")) { X do add_log("ERROR couldn't feed back from $trace: $!") if $loglvl > 1; X unlink "$trace"; # Maybe I should leave it around X die "feedback\n"; # Return to shell_command X } X while (<TRACE>) { X chop; X next if /^\s*$/; X $Back .= $_ . '; '; # Replace \n by ';' separator X } X close TRACE; X} X X# The "RESYNC" command X# Resynchronizes the %Header entries by reparsing the 'All' entry Xsub header_resync { X # Clean up all the non-special entries X foreach $key (keys %Header) { X next if $Pseudokey{$key}; # Skip pseudo-header entries X delete $Header{$key}; X } X # There is some code duplication with parse_mail() X local($lines) = 0; X local($first_from); # First From line records sender X local($last_header); # Current normalized header field X local($in_header) = 1; # Bug in the range operator X local($value); # Value of current field X foreach (split(/\n/, $Header{'All'})) { X if ($in_header) { # Still in header of message X $in_header = 0 if /^$/; # End of header X if (/^\s/) { # It is a continuation line X s/^\s+/ /; # Swallow multiple spaces X $Header{$last_header} .= "\n$_" if $last_header ne ''; X } elsif (/^([\w-]+):\s*(.*)/) { # We found a new header X $value = $2; # Bug in perl 4.0 PL19 X $last_header = &header'normalize($1); X # Multiple headers like 'Received' are separated by a new- X # line character. All headers end on a non new-line. X if ($Header{$last_header} ne '') { X $Header{$last_header} .= "\n$value"; X } else { X $Header{$last_header} .= $value; X } X } elsif (/^From\s+(\S+)/) { # The very first From line X $first_from = $1; X } X } else { X $lines++; # One more line in body X } X } X do header_check($first_from, $lines); # Sanity checks X} X X# The "STRIP" and "KEEP" commands (case insensitive) X# Removes or keeps some headers and update the Header structure Xsub alter_header { X local($headers, $action) = @_; X local(@list) = split(/\s/, $headers); X local(@head) = split(/\n/, $Header{'Head'}); X local(@newhead); # The constructed header X local($last_was_altered) = 0; # Set to true when header is altered X local($matched); # Did any header matched ? X foreach (@head) { X if (/^From\s/) { # First From line... X push(@newhead, $_); # Keep it anyway X next; X } X unless (/^\s/) { # If not a continuation line X $last_was_altered = 0; # Reset header alteration flag X $matched = 0; # Assume no match X foreach $h (@list) { # Loop over to-be-altered lines X $h =~ s/:$//; # Remove trailing ':' if any X if (/^$h:/i) { # We found a line to be removed/kept X $matched = 1; X last; X } X } X $last_was_altered = $matched; X next if $matched && $action == $HD_SKIP; X next if !$matched && $action == $HD_KEEP; X } X if ($action == $HD_SKIP) { X next if /^\s/ && $last_was_altered; # Skip header continuations X } else { # Action is $HD_KEEP X next if /^\s/ && !$last_was_altered; # Header was not kept X } X push(@newhead, $_); # Add line to the new header X } X $Header{'Head'} = join("\n", @newhead) . "\n"; X} X X# The "ANNOTATE" command Xsub annotate_header { X local($field, $value, $date) = @_; # Field, value and date flag. X if ($value eq '' && $date ne '') { # No date and no value for field! X &add_log("WARNING no value for '$field' annotation") if $loglvl > 5; X return 1; X } X if ($field eq '') { # No field specified! X &add_log("WARNING no field specified for annotation") if $loglvl > 5; X return 1; X } X local($annotation) = ''; # Annotation made X $annotation = "$field: " . &header'fake_date . "\n" unless $date; X $annotation .= &header'format("$field: $value") . "\n" if $value; X $Header{'Head'} .= $annotation; X 0; X} X X# The "TR" and "SUBST" commands Xsub alter_value { X local($variable, $op) = @_; # Variable and operation to performed X local($lvalue); # Perl variable to be modified X local($extern); # Lvalue used for persistent variables X X # We may modify a variable or a backreference (not read-only as in perl) X if ($variable =~ s/^#://) { X $extern = &extern'val($variable); # Fetch external value X $lvalue = '$extern'; # Modify this variable X } elsif ($variable =~ s/^#//) { X $lvalue = '$Variable{\''.$variable.'\'}'; X } elsif ($variable =~ /^\d\d?$/) { X $variable = int($variable) - 1; X $lvalue = '$Backref[' . $variable . ']'; X } else { X &add_log("ERROR incorrect variable name '$variable'") if $loglvl > 1; X return 1; X } X X # Let perl do the work X &add_log("running $lvalue =~ $op") if $loglvl > 19; X eval $lvalue . " =~ $op"; X &add_log("ERROR operation $op failed: $@") if $@ && $loglvl > 1; X X # If an external (persistent) variable was used, update its value now, X # unless the operation failed, in which case the value is not modified. X &extern'set($variable, $extern) if $@ eq '' && $lvalue eq '$extern'; X X $@ eq '' ? 0 : 1; # Failure status X} X X# The "PERL" command Xsub perl { X local($script) = @_; # Location of perl script X local($failed) = ''; # Assume script did not fail X undef @_; # No visible args for functions in script X X unless (chdir $cf'home) { X &add_log("WARNING cannot chdir to $cf'home: $!") if $loglvl > 5; X } X X # Set up the @ARGV array, by parsing the $script variable with &shellwords. X # Note that the @ARGV array is held in the main package, but since the X # mailagent makes no use of it at this point, there is no need to save its X # value before clobbering it. X require 'shellwords.pl'; X eval '@ARGV = &shellwords($script)'; X if (chop($@)) { # There was an unmatched quote X $@ =~ s/^U/u/; X &add_log("ERROR $@") if $loglvl > 1; X &add_log("ERROR cannot run PERL $script") if $loglvl > 2; X return 1; X } X X unless (open(PERL, $ARGV[0])) { X &add_log("ERROR cannot open perl script $ARGV[0]: $!") if $loglvl > 1; X return 1; X } X X # Fetch the perl script in memory X local($/) = undef; X local($body) = <PERL>; # Slurp whole file X close(PERL); X local(@saved) = @INC; # Save INC array (perl library location path) X local(%saved) = %INC; # Save already required files X X # Run the perl script in special package X unshift(@INC, $privlib); # Files first searched for in mailagent's lib X package mailhook; # -- entering in mailhook -- X &interface'new; # Signal new script being loaded X &hook'initialize; # Initialize convenience variables X eval $'body; # Load, compile and execute within mailhook X &interface'reset; # Clear the mailhook package if no more pending X package main; # -- reverting to main -- X @INC = @saved; # Restore INC array X %INC = %saved; # In case script has required some other files X X # If the script died with an 'OK' error message, then it meant 'exit 0' X # but also wanted the exit to be trapped. The &exit function is provided X # for that purpose. X if (chop($@)) { X if ($@ =~ /^OK/) { X $@ = ''; X &add_log("script exited with status 0") if $loglvl > 18; X } X elsif ($@ =~ /^Exit (\d+)/) { X $@ = ''; X $failed = "exited with status $1"; X } X elsif ($@ =~ /^Status (\d+)/) { # A REJECT, RESTART or ABORT X $@ = ''; X $cont = $1; # This will modify control flow X &add_log("script ended with a control '$cont'") if $loglvl > 18; X } X else { X $@ =~ s/ in file $eval$//; X &add_log("ERROR $@") if $loglvl; X $failed = "execution aborted"; X } X &add_log("ERROR perl failed ($failed)") if $loglvl > 1 && $failed; X } X $failed ? 1 : 0; X} X X# Modify control flow within automaton by calling a non-existant function X# &perform, which has been dynamically bound to one of the do_* functions. X# The REJECT, RESTART and ABORT actions share the following options and X# arguments. If followed by -t (resp. -f), then the action only takes place X# when the last recorded command status is true (resp. false, i.e. failure). X# If a mode is present as an argument, the the state of the automaton is X# changed to that mode prior alteration of the control flow. Xsub alter_flow { X $_[0] =~ s/^\s*\w+//; # Remove command name X $_[0] =~ s/^\s*-([tf]+)//; # Remove options X local($opt) = $1; X local($true) = $opt =~ /t/; # Perform only if $lastcmd is 0 X local($false) = $opt =~ /f/; # Perform only if $lastcmd recorded failure X $_[0] =~ s/^\s+//; # Trim leading spaces X local($mode) = $_[0]; # New mode we eventually change to X # Variable $lastcmd comes from xeqte(), $wmode comes from analyze_mail(). X return 0 if $true && $lastcmd != 0; X return 0 if $false && $lastcmd == 0; X if ($mode ne '') { X $wmode = $mode; X &add_log("entering new state $wmode") if $loglvl > 6; X } X &perform; # This was dynamically bound X} X X# Perform a "REJECT" Xsub do_reject { X $cont = $FT_REJECT; # Reject ($cont defined in run_command) X do add_log("REJECTED [$mfile] in state $wmode") if $loglvl > 4; X 0; X} X X# Perform a "RESTART" Xsub do_restart { X $cont = $FT_RESTART; # Restart ($cont defined in run_command) X do add_log("RESTARTED [$mfile] in state $wmode") if $loglvl > 4; X 0; X} X X# Perform an "ABORT" Xsub do_abort { X $cont = $FT_ABORT; # Abort filtering ($cont defined in run_command) X do add_log("ABORTED [$mfile] in state $wmode") if $loglvl > 4; X 0; X} X X# Given a list of addresses separated by white spaces, return a new list of X# addresses, but with "include-request" processed. Xsub complete_addr { X local(@addr) = split(' ', $_[0]); # Original list X local(@result); # Where result list is built X local($filename); # Name of include file X local($_); X foreach $addr (@addr) { X if ($addr !~ /^"/) { # Address not enclosed within "" X push(@result, $addr); # Kept as-is X } else { X ($filename) = $addr =~ /^"(.*)"$/; X $filename = &locate_file($filename); X if ($filename && open(ADDRESSES, "$filename")) { X while (<ADDRESSES>) { X next if /^\s*#/; # Skip shell comments X chop; X s/^\s+//; # Remove leading spaces X push(@result, $_); X } X close ADDRESSES; X } elsif ($filename) { # Could not open file X &add_log("WARNING couldn't open $filename for addresses: $!") X if $loglvl > 4; X } else { X &add_log("WARNING incorrect file inclusion request") X if $loglvl > 4; X } X } X } X join(' ', @result); # Return space separated addresses X} X X# Save digest mail into a folder, or queue it if no folder is provided X# Uses the variable '$item' from 'split' to log items. Xsub save_mail { X local(*array, $folder) = @_; # Where mail is and where to put it X local($length) = 0; # Length of the digest item X local($mbox, $failed, $log_message); X local($_); X # Go back to the previous dash line, removing it from the body part X # (it's only a separator). In the process, we also remove any looked ahead X # header which belongs to the next digest item. X do { X $_ = pop(@array); # Remove what belongs to next digest item X } while !/^---/; X # It is recommended in RFC-934 that all leading EB be escaped by a leading X # '- ' sequence, to allow nested forwarding. However, since the message X # we are dealing with might not be RFC-934 compliant, we are only removing X # the leading '- ' if it is followed by a '-'. We also use the loop to X # escape all potentially dangerous From lines. X local($last_was_space); X foreach (@array) { X s/^From\s+(\S+)/>From $1/ if $last_was_space; X s/^- -/-/; # This is the EB escape in RFC-934 X $last_was_space = /^$/; # From is dangerous after blank line X } X # Now @array holds the whole digest item X if ($folder =~ /^\s*$/) { # No folder means we have to queue message X $failed = &qmail(*array); X $log_message = 'mailagent\'s queue'; X foreach (@array) { X $length += length($_) + 1; # No trailing new-lines X } X } else { X # Looks like we have to save the message in a folder. I cannot really X # ask for a local variable named %Header because emergency routines X # use it to save mail (they expect the whole mail in $Header{'All'}). X # However, if something goes wrong, we'll get back to the filter main X # loop and a LEAVE (default action) will be executed, taking the X # current values from 'Head' and 'Body'. Hence the following: X X local(%NHeader); X $NHeader{'All'} = $Header{'All'}; X local(*Header) = *NHeader; # From now on, we really work on %NHeader X local($in_header) = 1; # True while in message header X local($first_from); # First From line X X # Fill in %Header strcuture, which is expected by save(): header in X # entry 'Head' and body in entry 'Body'. X foreach (@array) { X if ($in_header) { X $in_header = 0 if /^$/; X next if /^$/; X $Header{'Head'} .= $_ . "\n"; X $first_from = $_ if /^From\s+\S+/; X next; X } X $Header{'Body'} .= $_ . "\n"; X } X $Header{'Head'} = "$FAKE_FROM\n" . $Header{'Head'} unless $first_from; X X # Now save into folder X ($mbox, $failed, $log_message) = &run_saving($folder, $FOLDER_APPEND); X X # Keep track in the logfile of the length of the digest item. X $length = length($Header{'Head'}) + length($Header{'Body'}) + 1; X } X if ($failed) { X if ($loglvl > 2) { X local($s) = $length == 1 ? '' : 's'; X &add_log("ERROR unable to save #$item ($length byte$s)") if $item; X &add_log("ERROR unable to save preamble ($length byte$s)") X unless $item; X } X } else { X if ($loglvl > 7) { X local($s) = $length == 1 ? '' : 's'; X &add_log("SPLIT #$item in $log_message ($length byte$s)") if $item; X &add_log("SPLIT preamble in $log_message ($length byte$s)") X unless $item; X } X } X ++$item if $item; # Count items, but not preamble (done by 'split') X $failed; # Propagate failure status X} X X# Check body message (typically head of digest message) and return 1 if its X# body is empty, 0 otherwise. Xsub empty_body { X local(*ary) = @_; X local(@array) = @ary; # Work on a copy X local($_); X local($is_empty) = 1; X do { X $_ = pop(@array); # Remove what belongs to next digest item X } while !/^---/; X do { X $_ = shift(@array); # Remove the whole header X } while !/^$/; X foreach (@array) { X $is_empty = 0 unless /^\s*$/; X last unless $is_empty; X } X $is_empty; X} X END_OF_FILE if test 45237 -ne `wc -c <'agent/pl/actions.pl'`; then echo shar: \"'agent/pl/actions.pl'\" unpacked with wrong size! fi # end of 'agent/pl/actions.pl' fi echo shar: End of archive 3 $of 17$. cp /dev/null ark3isdone MISSING="" for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 ; do if test ! -f ark${I}isdone ; then MISSING="${MISSING} ${I}" fi done if test "${MISSING}" = "" ; then echo You have unpacked all 17 archives. rm -f ark[1-9]isdone ark[1-9][0-9]isdone else echo You still must unpack the following archives: echo " " ${MISSING} fi exit 0 exit 0 # Just in case...