home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1994 March / Source_Code_CD-ROM_Walnut_Creek_March_1994.iso / compsrcs / misc / volume41 / mailagnt / part12 < prev    next >
Encoding:
Text File  |  1993-12-02  |  54.7 KB  |  1,342 lines
  1. Newsgroups: comp.sources.misc
  2. From: Raphael Manfredi <ram@acri.fr>
  3. Subject: v41i012:  mailagent - Flexible mail filtering and processing package, v3.0, Part12/26
  4. Message-ID: <1993Dec2.133940.18644@sparky.sterling.com>
  5. X-Md4-Signature: 431e377a5f4975ccb81b9530b42f80e1
  6. Sender: kent@sparky.sterling.com (Kent Landfield)
  7. Organization: Advanced Computer Research Institute, Lyon, France.
  8. Date: Thu, 2 Dec 1993 13:39:40 GMT
  9. Approved: kent@sparky.sterling.com
  10.  
  11. Submitted-by: Raphael Manfredi <ram@acri.fr>
  12. Posting-number: Volume 41, Issue 12
  13. Archive-name: mailagent/part12
  14. Environment: UNIX, Perl
  15. Supersedes: mailagent: Volume 33, Issue 93-109
  16.  
  17. #! /bin/sh
  18. # This is a shell archive.  Remove anything before this line, then feed it
  19. # into a shell via "sh file" or similar.  To overwrite existing files,
  20. # type "sh file -c".
  21. # The tool that generated this appeared in the comp.sources.unix newsgroup;
  22. # send mail to comp-sources-unix@uunet.uu.net if you want that tool.
  23. # Contents:  MANIFEST agent/pl/analyze.pl agent/pl/interface.pl
  24. #   agent/pl/rules.pl
  25. # Wrapped by ram@soft208 on Mon Nov 29 16:49:56 1993
  26. PATH=/bin:/usr/bin:/usr/ucb ; export PATH
  27. echo If this archive is complete, you will see the following message:
  28. echo '          "shar: End of archive 12 (of 26)."'
  29. if test -f 'MANIFEST' -a "${1}" != "-c" ; then 
  30.   echo shar: Will not clobber existing file \"'MANIFEST'\"
  31. else
  32.   echo shar: Extracting \"'MANIFEST'\" \(15748 characters\)
  33.   sed "s/^X//" >'MANIFEST' <<'END_OF_FILE'
  34. XArtistic                   The Artistic Licence
  35. XChanges                    User-visible changes between 2.9 and 3.0
  36. XConfigure                  Portability tool
  37. XCredits                    Traditional "thank you" list
  38. XJmakefile                  Description of the main Makefile
  39. XMANIFEST                   This list of files
  40. XMakefile.SH                A makefile to run subsidiary makefiles
  41. XREADME                     Basic instructions
  42. Xagent/                     Where mailagent support files are located
  43. Xagent/Jmakefile            High level description of Makefile
  44. Xagent/Makefile.SH          Makefile which builds and installs mailagent
  45. Xagent/README               Welcome to mailagent
  46. Xagent/examples/            A set of files from my own environment
  47. Xagent/examples/README      Explains what the examples are
  48. Xagent/examples/daemon      Rules for "vacation" emulation
  49. Xagent/examples/mailfolders A copy of my ~/.mailfolders
  50. Xagent/examples/mchk        Checks for new mail
  51. Xagent/examples/mhinc       Call the MH inc command to incorporate new mail
  52. Xagent/examples/nocmds      Message you currently get if you send me a command
  53. Xagent/examples/profile     What I added to my onw ~/.profile
  54. Xagent/examples/rules       The rules I am currently using
  55. Xagent/examples/vacation    A sample vacation message
  56. Xagent/files/               Mailagent's configuration files
  57. Xagent/files/Jmakefile      High level description for Makefile
  58. Xagent/files/Makefile.SH    Makefile for subsidiary files
  59. Xagent/files/README         Notes about files found in this directory
  60. Xagent/files/agenthelp      Help file used by mailhelp
  61. Xagent/files/chkagent.sh    Cron script to spot problems in the mailagent system
  62. Xagent/files/commands       Allowed commands for mailagent
  63. Xagent/files/distribs       Example of distribution list
  64. Xagent/files/filter.sh      Shell script version of the mail filter
  65. Xagent/files/help               Directory holding SERVER help files
  66. Xagent/files/help/Jmakefile     Generic makefile for help directory
  67. Xagent/files/help/Makefile.SH   Generated makefile
  68. Xagent/files/help/README        States what this directory is about
  69. Xagent/files/help/addauth.SH    Help file for addauth
  70. Xagent/files/help/approve.SH    Help file for approve
  71. Xagent/files/help/delpower.SH   Help file for delpower
  72. Xagent/files/help/end.SH        Help file for end
  73. Xagent/files/help/getauth.SH    Help file for getauth
  74. Xagent/files/help/help.SH       Help file for help
  75. Xagent/files/help/newpower.SH   Help file for newpower
  76. Xagent/files/help/passwd.SH     Help file for passwd
  77. Xagent/files/help/password.SH   Help file for password
  78. Xagent/files/help/power.SH      Help file for power
  79. Xagent/files/help/release.SH    Help file for release
  80. Xagent/files/help/remauth.SH    Help file for remauth
  81. Xagent/files/help/set.SH        Help file for set
  82. Xagent/files/help/setauth.SH    Help file for setauth
  83. Xagent/files/help/user.SH       Help file for user
  84. Xagent/files/mailagent.cf   Example of configuration file
  85. Xagent/files/passwd         An example for power password file
  86. Xagent/files/proglist       Example of description file
  87. Xagent/files/server         An example for server command file
  88. Xagent/filter/              The C version of the mail filter
  89. Xagent/filter/Jmakefile     Generic makefile template
  90. Xagent/filter/Makefile.SH   Makefile for C filter
  91. Xagent/filter/README        Introduction to filter
  92. Xagent/filter/environ.c     Environment management routines
  93. Xagent/filter/environ.h     Declarations for environment management routines
  94. Xagent/filter/hash.c        Symbol table handling
  95. Xagent/filter/hash.h        Declarations for symbol table
  96. Xagent/filter/io.c          I/O routines
  97. Xagent/filter/io.h          Header for I/O routines
  98. Xagent/filter/lock.c        File locking
  99. Xagent/filter/lock.h        Declarations for file locking routines
  100. Xagent/filter/logfile.c     Logging facilities
  101. Xagent/filter/logfile.h     Header for logging routines
  102. Xagent/filter/main.c        The main entry point for filter
  103. Xagent/filter/misc.c        Miscellaneous routines
  104. Xagent/filter/msg.c         Handles fatal messages
  105. Xagent/filter/msg.h         Declarations for user messages
  106. Xagent/filter/parser.c      Parse the config file with variable substitutions
  107. Xagent/filter/parser.h      About config file parsing
  108. Xagent/filter/portable.h    Portable declarations
  109. Xagent/filter/sysexits.h    Standard exit codes
  110. Xagent/filter/user.c        To get login name from user
  111. Xagent/magent.SH            The main processor
  112. Xagent/maildist.SH          Mails a whole distribution
  113. Xagent/mailhelp.SH          Mails some help
  114. Xagent/maillist.SH          Mails a list of available distributions
  115. Xagent/mailpatch.SH         Mails patches for a given distribution
  116. Xagent/man/                 Manual pages for mailagent
  117. Xagent/man/Jmakefile        Makefile description for jmake
  118. Xagent/man/Makefile.SH      Makefile for manual pages extraction
  119. Xagent/man/mailagent.SH     Produces a manual page for mailagent
  120. Xagent/man/maildist.SH      Produces a manual page for maildist
  121. Xagent/man/mailhelp.SH      Produces a manual page for mailhelp
  122. Xagent/man/maillist.SH      Produces a manual page for maillist
  123. Xagent/man/mailpatch.SH     Produces a manual page for mailpatch
  124. Xagent/man/package.SH       Produces a manual page for package
  125. Xagent/package.SH           Records users of a PD package (cf dist-3.0)
  126. Xagent/pl/                  Perl files used by mailagent scripts
  127. Xagent/pl/acs_rqst.pl       Perl library to ask for private file access
  128. Xagent/pl/actions.pl        Implementation of mailagent's actions
  129. Xagent/pl/add_log.pl        Perl library to add logs to logfile
  130. Xagent/pl/analyze.pl        Perl library analyzing the incoming mail
  131. Xagent/pl/builtins.pl       Perl library dealing with builtins
  132. Xagent/pl/checklock.pl      Perl library to check for long lasting locks
  133. Xagent/pl/cmdserv.pl        Implements generic mail server
  134. Xagent/pl/compress.pl       Folder compression library
  135. Xagent/pl/context.pl        Mailagent context file handling
  136. Xagent/pl/dbr.pl            Internal database management
  137. Xagent/pl/distribs.pl       Perl library to scan the distribs file
  138. Xagent/pl/dynload.pl        Dynamically loads perl code into mailagent
  139. Xagent/pl/emergency.pl      Perl library dealing with emergencies
  140. Xagent/pl/eval.pl           A little expression interpreter
  141. Xagent/pl/extern.pl         Perl library to handle persistent variables
  142. Xagent/pl/fatal.pl          Perl library to deal with fatal errors
  143. Xagent/pl/file_edit.pl      File edition with extensive error checking
  144. Xagent/pl/filter.pl         Running the filtering commands
  145. Xagent/pl/free_file.pl      Perl library to free file access
  146. Xagent/pl/gensym.pl         Dynamic symbol generator
  147. Xagent/pl/getdate.pl        Richard Ohnemus's getdate package
  148. Xagent/pl/header.pl         Header-related routines
  149. Xagent/pl/history.pl        Perl library to implement history mechanism
  150. Xagent/pl/hook.pl           Mail hook wrapping functions
  151. Xagent/pl/hostname.pl       Perl library to compute hostname
  152. Xagent/pl/include.pl        Processing of "include file" requests
  153. Xagent/pl/interface.pl      Perl interface with filter commands
  154. Xagent/pl/jobnum.pl         Perl library to compute a job number
  155. Xagent/pl/lexical.pl        Perl library for lexical analysis
  156. Xagent/pl/listqueue.pl      Perl library to list the queue
  157. Xagent/pl/locate.pl         Perl library to locate loaded patterns/addresses
  158. Xagent/pl/macros.pl         Perl library for macros expansion
  159. Xagent/pl/mailhook.pl       Initializing and running hooks
  160. Xagent/pl/makedir.pl        Perl library for making a directory
  161. Xagent/pl/matching.pl       Matching routines used by filter
  162. Xagent/pl/mbox.pl           Getting mails from a mailbox file
  163. Xagent/pl/mh.pl             Handles MH-style folder delivery
  164. Xagent/pl/mmdf.pl           MMDF-style mailbox handling
  165. Xagent/pl/newcmd.pl         Filter command extension driver
  166. Xagent/pl/once.pl           Dealing with once commands
  167. Xagent/pl/parse.pl          Perl library to parse a mail message
  168. Xagent/pl/period.pl         Perl library to compute periods
  169. Xagent/pl/plsave.pl         Perl library to handle the plsave cache file
  170. Xagent/pl/plural.pl         Perl library to pluralize words
  171. Xagent/pl/power.pl          Power management for mail server
  172. Xagent/pl/pqueue.pl         Processing the queued mails
  173. Xagent/pl/q.pl              Quote removal function
  174. Xagent/pl/queue_mail.pl     Queuing mails
  175. Xagent/pl/rangeargs.pl      Perl library to expand a list of patches
  176. Xagent/pl/read_conf.pl      Perl library to read configuration file
  177. Xagent/pl/rfc822.pl         Perl library to parse RFC822 addresses
  178. Xagent/pl/rules.pl          Compiles the filtering rules
  179. Xagent/pl/runcmd.pl         Filter commands ran from here
  180. Xagent/pl/secure.pl         Make sure a file is "secure" and can be trusted
  181. Xagent/pl/sendfile.pl       Perl library to send files in shar / kit mode
  182. Xagent/pl/stats.pl          Mailagent's statistics recording and printing
  183. Xagent/pl/tilde.pl          Perl library to perform ~name expansion
  184. Xagent/pl/unpack.pl         Perl library to unpack archive files
  185. Xagent/pl/usrmac.pl         User-defined macros
  186. Xagent/test/                Regression test suite
  187. Xagent/test/Jmakefile       Generic makefile for test suite
  188. Xagent/test/Makefile.SH     Makefile for test suite
  189. Xagent/test/README          About the regression tests
  190. Xagent/test/TEST            Runs the full test suite
  191. Xagent/test/actions         Rule file for cmd tests
  192. Xagent/test/basic/              Basic tests
  193. Xagent/test/basic/config.t      Main test initialization and sanity checks
  194. Xagent/test/basic/filter.t      Make sure C filter works
  195. Xagent/test/basic/mailagent.t   Make sure mailagent basically works
  196. Xagent/test/cmd/                Tests of mailagent's filtering commands
  197. Xagent/test/cmd/abort.t         Test ABORT command
  198. Xagent/test/cmd/annotate.t      Test ANNOTATE command
  199. Xagent/test/cmd/apply.t         Test APPLY command
  200. Xagent/test/cmd/assign.t        Test ASSIGN command
  201. Xagent/test/cmd/back.t          Test BACK command
  202. Xagent/test/cmd/begin.t         Test BEGIN command
  203. Xagent/test/cmd/bounce.t        Test BOUNCE command
  204. Xagent/test/cmd/delete.t        Test DELETE command
  205. Xagent/test/cmd/feed.t          Test FEED command
  206. Xagent/test/cmd/forward.t       Test FORWARD command
  207. Xagent/test/cmd/give.t          Test GIVE command
  208. Xagent/test/cmd/keep.t          Test KEEP command
  209. Xagent/test/cmd/leave.t         Test LEAVE command
  210. Xagent/test/cmd/macro.t         Test MACRO command
  211. Xagent/test/cmd/message.t       Test MESSAGE command
  212. Xagent/test/cmd/nop.t           Test NOP command
  213. Xagent/test/cmd/notify.t        Test NOTIFY command
  214. Xagent/test/cmd/once.t          Test ONCE command
  215. Xagent/test/cmd/pass.t          Test PASS command
  216. Xagent/test/cmd/perl.t          Test PERL command
  217. Xagent/test/cmd/pipe.t          Test PIPE command
  218. Xagent/test/cmd/post.t          Test POST command
  219. Xagent/test/cmd/process.t       Test PROCESS command
  220. Xagent/test/cmd/purify.t        Test PURIFY command
  221. Xagent/test/cmd/queue.t         Test QUEUE command
  222. Xagent/test/cmd/record.t        Test RECORD command
  223. Xagent/test/cmd/reject.t        Test REJECT command
  224. Xagent/test/cmd/require.t       Test REQUIRE command
  225. Xagent/test/cmd/restart.t       Test RESTART command
  226. Xagent/test/cmd/resync.t        Test RESYNC command
  227. Xagent/test/cmd/run.t           Test RUN command
  228. Xagent/test/cmd/save.t          Test SAVE command
  229. Xagent/test/cmd/select.t        Test SELECT command
  230. Xagent/test/cmd/server.t        Test SERVER command
  231. Xagent/test/cmd/split.t         Test SPLIT command
  232. Xagent/test/cmd/store.t         Test STORE command
  233. Xagent/test/cmd/strip.t         Test STRIP command
  234. Xagent/test/cmd/subst.t         Test SUBST command
  235. Xagent/test/cmd/tr.t            Test TR command
  236. Xagent/test/cmd/unique.t        Test UNIQUE command
  237. Xagent/test/cmd/unknown.t       Make sure unknown command defaults correctly
  238. Xagent/test/cmd/vacation.t      Test VACATION command
  239. Xagent/test/cmd/write.t         Test WRITE command
  240. Xagent/test/filter/             Testing the filtering capabilities
  241. Xagent/test/filter/backref.t    Check backreferences
  242. Xagent/test/filter/case.t       Normalized header case tests
  243. Xagent/test/filter/default.t    Check default behaviour when mail not saved
  244. Xagent/test/filter/escape.t     Escape sequences within actions
  245. Xagent/test/filter/group.t      Selector combination tests
  246. Xagent/test/filter/hook.t       Ensure hooks are correctly invoked
  247. Xagent/test/filter/list.t       Check matching on lists like To and Newsgroups
  248. Xagent/test/filter/loop.t       Check loop detection
  249. Xagent/test/filter/mode.t       Make sure mode selection logic works
  250. Xagent/test/filter/multiple.t   Check multiple selectors
  251. Xagent/test/filter/not.t        Negated pattern tests
  252. Xagent/test/filter/pattern.t    Check patterns specification and loading
  253. Xagent/test/filter/range.t      Selector range tests
  254. Xagent/test/filter/status.t     Action status updating tests
  255. Xagent/test/level               Default logging level for tests
  256. Xagent/test/mail                The mail used by testing routines
  257. Xagent/test/misc/               Directory for miscellaneous tests
  258. Xagent/test/misc/compress.t     Folder compression checks
  259. Xagent/test/misc/mh.t           MH-style folder checks
  260. Xagent/test/misc/mmdf.t         MMDF-style mailbox checks
  261. Xagent/test/misc/newcmd.t       Filter command extension tests
  262. Xagent/test/misc/usrmac.t       User-defined macros checks
  263. Xagent/test/option/             Tests the options to the mailagent program
  264. Xagent/test/option/L.t          Test -L option
  265. Xagent/test/option/V.t          Test -V option
  266. Xagent/test/option/c.t          Test -c option
  267. Xagent/test/option/d.t          Test -d option
  268. Xagent/test/option/e.t          Test -e option
  269. Xagent/test/option/f.t          Test -f option
  270. Xagent/test/option/h.t          Test -h option
  271. Xagent/test/option/i.t          Test -i option
  272. Xagent/test/option/l.t          Test -l option
  273. Xagent/test/option/o.t          Test -o option
  274. Xagent/test/option/q.t          Test -q option
  275. Xagent/test/option/r.t          Test -r option
  276. Xagent/test/option/s.t          Test -s option
  277. Xagent/test/option/t.t          Test -t option
  278. Xagent/test/option/what.t       Ensure good behaviour with unknown option
  279. Xagent/test/pl/                 Perl libraries for the regression test suite
  280. Xagent/test/pl/cmd.pl           Initializes command paths
  281. Xagent/test/pl/filter.pl        Set up environment for filter tests
  282. Xagent/test/pl/init.pl          Variable initializations
  283. Xagent/test/pl/logfile.pl       Logging file checking
  284. Xagent/test/pl/mail.pl          Modifies mail components
  285. Xagent/test/pl/misc.pl          Set up for miscellaneous tests
  286. Xagent/test/pl/mta.pl           Trivial MTA and NTA for tests
  287. Xagent/test/rules               Rules used by filtering tests
  288. Xbin/                       Directory for uninstalled binaries
  289. Xbin/perload                The dataloading/autoloading perl translator
  290. Xconfig_h.SH                Produces config.h
  291. Xconfmagic.h                Magic symbol remapping
  292. Xinstall.SH                 Installation script
  293. Xmisc/                      Miscellaneous server commands
  294. Xmisc/README                Introduction to the misc directory
  295. Xmisc/shell/                Command to run arbitrary shell commands
  296. Xmisc/shell/README          Warning, should be read carefully
  297. Xmisc/shell/server.cf       Configuration of this server command
  298. Xmisc/shell/shell           The shell command itself
  299. Xmisc/unkit/                Command to automatically unkit messages
  300. Xmisc/unkit/README          Some notes about the UNKIT command
  301. Xmisc/unkit/kitok.msg       An example of message to be sent when kit received
  302. Xmisc/unkit/mailagent.cf    Template for inclusion into your ~/.mailagent
  303. Xmisc/unkit/newcmd.cf       Configuration of the new command
  304. Xmisc/unkit/rules           Rules to be added to handle kit messages
  305. Xmisc/unkit/unkit.pl        Implementation of the user-defined UNKIT command
  306. Xpatchlevel.h               Current version number and patch level
  307. END_OF_FILE
  308.   if test 15748 -ne `wc -c <'MANIFEST'`; then
  309.     echo shar: \"'MANIFEST'\" unpacked with wrong size!
  310.   fi
  311.   # end of 'MANIFEST'
  312. fi
  313. if test -f 'agent/pl/analyze.pl' -a "${1}" != "-c" ; then 
  314.   echo shar: Will not clobber existing file \"'agent/pl/analyze.pl'\"
  315. else
  316.   echo shar: Extracting \"'agent/pl/analyze.pl'\" \(14857 characters\)
  317.   sed "s/^X//" >'agent/pl/analyze.pl' <<'END_OF_FILE'
  318. X;# $Id: analyze.pl,v 3.0 1993/11/29 13:48:35 ram Exp ram $
  319. X;#
  320. X;#  Copyright (c) 1990-1993, Raphael Manfredi
  321. X;#  
  322. X;#  You may redistribute only under the terms of the Artistic License,
  323. X;#  as specified in the README file that comes with the distribution.
  324. X;#  You may reuse parts of this distribution only within the terms of
  325. X;#  that same Artistic License; a copy of which may be found at the root
  326. X;#  of the source tree for mailagent 3.0.
  327. X;#
  328. X;# $Log: analyze.pl,v $
  329. X;# Revision 3.0  1993/11/29  13:48:35  ram
  330. X;# Baseline for mailagent 3.0 netwide release.
  331. X;#
  332. X;# 
  333. X#
  334. X# Analyzing mail
  335. X#
  336. X
  337. X# Special users. Note that as login name matches are done in a case-insensitive
  338. X# manner, there is no need to upper-case any of the followings.
  339. Xsub init_special {
  340. X    %Special = (
  341. X        'root', 1,                # Super-user
  342. X        'uucp', 1,                # Unix to Unix copy
  343. X        'daemon', 1,            # Not a real user, hopefully
  344. X        'news', 1,                # News daemon
  345. X        'postmaster', 1,        # X-400 mailer-daemon name
  346. X        'newsmaster', 1,        # My convention for news administrator--RAM
  347. X        'usenet', 1,            # Aka newsmaster
  348. X        'mailer-daemon', 1,        # Sendmail
  349. X        'mailer-agent', 1,        # NeXT mailer
  350. X        'nobody', 1                # Nobody we've heard of
  351. X    );
  352. X}
  353. X
  354. X# Parse mail message and apply the filtering rules on it
  355. Xsub analyze_mail {
  356. X    local($file) = shift(@_);    # Mail file to be parsed
  357. X    local($mode) = 'INITIAL';    # Initial working mode
  358. X    local($wmode) = $mode;        # Needed for statistics routines
  359. X
  360. X    # Set-up proper environment. Dynamic scoping is used on those variables
  361. X    # for the APPLY command (see the &apply function). Note that the $wmode
  362. X    # variable is passed to &apply_rules but is local to that function,
  363. X    # meaning there is no feedback of the working mode when using APPLY.
  364. X    # However, the variables listed below may be probed upon return since they
  365. X    # are external to &apply_rules.
  366. X    local($ever_matched) = 0;    # Did we ever matched a single saving rule ?
  367. X    local($ever_saved) = 0;        # Did we ever saved a message ?
  368. X
  369. X    # Other local variables used only in this function
  370. X    local($ever_seen) = 0;        # Did we ever enter seen mode ?
  371. X    local($vacation) = 1;        # Vacation message allowed a priori
  372. X    local($header);                # Header entry name to look for in Header table
  373. X
  374. X    # Parse the mail message in file
  375. X    &parse_mail($file);            # Parse the mail and fill-in H tables
  376. X    return 0 unless defined $Header{'All'};        # Mail not parsed correctly
  377. X    &reception if $loglvl > 8;    # Log mail reception
  378. X    &run_builtins;                # Execute builtins, if any were found
  379. X
  380. X    # Now analyze the mail. If there is already a X-Filter header, then the
  381. X    # mail has already been processed. In that case, the default action is
  382. X    # performed: leave it in the incomming mailbox with no further action.
  383. X    # This should prevent nasty loops.
  384. X
  385. X    &add_log ("analyzing mail") if $loglvl > 18;
  386. X    $header = $Header{'X-Filter'};                # Mulitple occurences possible
  387. X    if ($header ne '') {                        # Hmm... already filtered...
  388. X        local(@filter) = split(/\n/, $header);    # Look for each X-Filter
  389. X        local($address) = &email_addr;            # Our e-mail address
  390. X        local($done) = 0;                        # Already processed ?
  391. X        local($*) = 0;
  392. X        local($_);
  393. X        foreach (@filter) {                        # Maybe we'll find ourselves
  394. X            if (/mailagent.*for (\S+)/) {        # Mark left by us ?
  395. X                $done = 1 if $1 eq $address;    # Yes, we did that
  396. X                $* = 1;
  397. X                # Remove that X-Filter line, LEAVE will add one anyway
  398. X                $Header{'Head'} =~ s/^X-Filter:\s*mailagent.*for $address\n//;
  399. X                $* = 0;
  400. X                last;
  401. X            }
  402. X        }
  403. X        if ($done) {            # We already processed that message
  404. X            &add_log("NOTICE already filtered, entering seen mode")
  405. X                if $loglvl > 5;
  406. X            $mode = '_SEEN_';    # This is a special mode
  407. X            $ever_seen = 1;        # This will prevent vacation messages
  408. X            &s_seen;            # Update statistics
  409. X        }
  410. X    }
  411. X
  412. X    &apply_rules($mode, 1);        # Now apply the filtering rules on it.
  413. X
  414. X    # Deal with vacation mode. It applies only on mail not previously seen.
  415. X    # The vacation mode must be turned on in the configuration file. The
  416. X    # conditions for a vacation message to be sent are:
  417. X    #   - Message was directly sent to the user.
  418. X    #   - Message does not come from a special user like root.
  419. X    #   - Vacation message was not disabled via a VACATION command
  420. X
  421. X    if (!$ever_seen && $cf'vacation =~ /on/i && $vacation) {
  422. X        unless (&special_user) {    # Not from special user and sent to me
  423. X            # Send vacation message only once per address per period
  424. X            &xeqte("ONCE (%r,vacation,$cf'vacperiod) MESSAGE $cf'vacfile");
  425. X            &s_vacation;        # Message received while in vacation
  426. X        }
  427. X    }
  428. X
  429. X    # Default action if no rule ever matched. Statistics routines will use
  430. X    # our own local $wmode variable.
  431. X
  432. X    unless ($ever_matched) {
  433. X        &add_log("NOTICE no match, leaving in mailbox") if $loglvl > 5;
  434. X        &xeqte("LEAVE");            # Default action anyway
  435. X        &s_default;                    # One more application of default rule
  436. X    } else {
  437. X        unless ($ever_saved) {
  438. X            &add_log("NOTICE not saved, leaving in mailbox") if $loglvl > 5;
  439. X            &xeqte("LEAVE");        # Leave if message not saved
  440. X            &s_saved;                # Message saved by default rule
  441. X        }
  442. X    }
  443. X    &s_filtered($Header{'Length'});        # Update statistics
  444. X
  445. X    0;                                    # Ok status
  446. X}
  447. X
  448. X# This is the heart of the mail agent -- Apply the filtering rules
  449. Xsub apply_rules {
  450. X    local($wmode, $stats)= @_;    # Working mode (the mode we start in)
  451. X    local($mode);                # Mode (optional)
  452. X    local($selector);            # Selector (mandatory)
  453. X    local($range);                # Range for selection (optional)
  454. X    local($rulentry);            # Entry in rule H table
  455. X    local($pattern);            # Pattern for selection, as written in rules
  456. X    local($action);                # Related action
  457. X    local($last_selector);        # Last used selector
  458. X    local($rules);                # A copy of the rules
  459. X    local($matched);            # Flag set to true if a rule is matched
  460. X    local(%Matched);            # Records the selectors which have been matched
  461. X    local($status);                # Status returned by xeqte
  462. X    local(@Executed);            # Records already executed rules
  463. X    local($selist);                # Key used to detect identical selector lists
  464. X    local(%Inverted);            # Records inverted '!' selectors which matched
  465. X    local(%Variable);            # User-defined variables
  466. X
  467. X    # The @Executed array records whether a specified action for a rule was
  468. X    # executed. Loops are possible via the RESTART action, and as there is
  469. X    # almost no way to exit from such a loop (there is one with FEED and RESYNC)
  470. X    # I decided to prohibit them. Hence a given action is allowed to be executed
  471. X    # only once during a mail analysis (modulo each possible working mode).
  472. X    # For a rule number n, $Executed[n] is a collection of modes in which the
  473. X    # rule was executed, comma separated.
  474. X
  475. X    $Executed[$#Rules] = '';        # Pre-extend array
  476. X
  477. X    # Order wrt the one in the rule file is guaranteed. I use a for construct
  478. X    # with indexed access to be able to restart from the beginning upon
  479. X    # execution of RESTART. This also helps filling in the @Executed array.
  480. X
  481. X    local($i, $j);            # Indices within rule array
  482. X
  483. X    rule: for ($i = 0; $i <= $#Rules; $i++) {
  484. X        $j = $i + 1;
  485. X        $_ = $Rules[$i];
  486. X
  487. X        # The %Matched array records the boolean value associated with each
  488. X        # possible selector. If two identical selector are found, the values
  489. X        # are OR'ed (and we stop evaluating as soon as one is true). Otherwise,
  490. X        # the values are AND'ed (for different selectors, but all are evaluated
  491. X        # in case we later find another identical selectors -- no sort is done).
  492. X        # The %Inverted which records '!' selector matches has all the above
  493. X        # rules inverted according to De Morgan's Law.
  494. X
  495. X        undef %Matched;                            # Reset matching patterns
  496. X        undef %Inverted;                        # Reset negated patterns
  497. X        $rules = $_;                            # Work on a copy
  498. X        $rules =~ s/^([^{]*){// && ($mode = $1);    # First word is the mode
  499. X        $rules =~ s/\s*(.*)}// && ($action = $1);    # Followed by action
  500. X        $mode =~ s/\s*$//;                            # Remove trailing spaces
  501. X        $rules =~ s/^\s+//;                        # Remove leading spaces
  502. X        $last_selector = "";                    # Last selector used
  503. X
  504. X        # Make sure we are in the correct mode. The $mode variable holds a
  505. X        # list of comma-separated modes. If the working mode is found in it
  506. X        # then the rules apply. Otherwise, skip them.
  507. X
  508. X        next rule unless &right_mode;        # Skip rule if not in right mode
  509. X
  510. X        # Now loop over all the keys and apply the patterns in turn
  511. X
  512. X        &reset_backref;                        # Reset backreferences
  513. X        foreach $key (split(/ /, $rules)) {
  514. X            $rulentry = $Rule{$key};
  515. X            $rulentry =~ s/^\s*([^\/]*:)// && ($selector = $1);
  516. X            $rulentry =~ s/^\s*//;
  517. X            $pattern = $rulentry;
  518. X            if ($last_selector ne $selector) {    # Update last selector
  519. X                $last_selector = $selector;
  520. X            }
  521. X            $selector =~ s/:$//;            # Remove final ':' on selector
  522. X            $range = '<1,->';                # Default range
  523. X            $selector =~ s/\s*(<[\d\s,-]+>)$// && ($range = $1);
  524. X
  525. X            &add_log ("selector '$selector' on '$range', pattern '$pattern'")
  526. X                if $loglvl > 19;
  527. X
  528. X            # Identical (lists of) selectors are logically OR'ed. To make sure
  529. X            # 'To Cc:' and 'Cc To:' are correctly OR'ed, the selector list is
  530. X            # alphabetically sorted.
  531. X
  532. X            $selist = join(',', sort split(' ', $selector));
  533. X
  534. X            # Direct selectors and negated selectors (starting with a !) are
  535. X            # kept separately, because the rules are dual:
  536. X            # For normal selectors (kept in %Matched):
  537. X            #  - Identical are OR'ed
  538. X            #  - Different are AND'ed
  539. X            # For inverted selectors (kept in %Inverted):
  540. X            #  - Identical are AND'ed
  541. X            #  - Different are OR'ed
  542. X            # Multiple selectors like 'To Cc' are sorted according to the first
  543. X            # selector on the list, i.e. 'To !Cc' is normal but '!To Cc' is
  544. X            # inverted.
  545. X
  546. X            if ($selector =~ /^!/) {        # Inverted selector
  547. X                # In order to guarantee an optimized AND, we first check that
  548. X                # no previous failure has been reported for the current set of
  549. X                # selectors.
  550. X                unless (defined $Inverted{$selist} && !$Inverted{$selist}) {
  551. X                    $Inverted{$selist} = &match($selector, $pattern, $range);
  552. X                }
  553. X            } else {                        # Normal selector
  554. X                # Here it is the OR which is guaranteed to be optimized. Do
  555. X                # not attempt the match if an identical selector already
  556. X                # matched sucessfully.
  557. X                unless ($Matched{$selist}) {
  558. X                    $Matched{$selist} = &match($selector, $pattern, $range);
  559. X                }
  560. X            }
  561. X        }
  562. X
  563. X        # Both groups recorded in %Matched and %Inverted are globally AND'ed
  564. X        # However, only one match is necessary within %Inverted whilst all
  565. X        # must have matched within %Matched...
  566. X
  567. X        $matched = 1;                        # Assume everything matched
  568. X        foreach $key (keys %Matched) {        # All entries must have matched
  569. X            $matched = 0 unless $Matched{$key};
  570. X        }
  571. X        if ($matched) {                        # If %Matched failed, all failed!
  572. X            foreach $key (keys %Inverted) {    # Only one entry needs to match
  573. X                $matched = 0 unless $Inverted{$key};
  574. X                last if $matched;
  575. X            }
  576. X        }
  577. X
  578. X        if ($matched) {                        # Execute action if pattern matched
  579. X            # Make sure the rule has not already been executed in that mode
  580. X            if ($Executed[$i] =~ /,$wmode,/) {
  581. X                &add_log("NOTICE loop detected, rule $j, state $wmode")
  582. X                    if $loglvl > 5;
  583. X                last rule;                    # Processing ends here
  584. X            } else {                        # Rule was never executed
  585. X                $Executed[$i] = ',' unless $Executed[$i];
  586. X                $Executed[$i] .= "$wmode,";
  587. X            }
  588. X            $ever_matched = 1;                # At least one match
  589. X            &add_log("MATCH on rule #$j in mode $wmode") if $loglvl > 8;
  590. X            &track_rule($j, $wmode) if $track_all;
  591. X            &s_match($j, $wmode) if $stats;    # Record match for statistics
  592. X            $status = &xeqte($action);
  593. X            last rule if $status == $FT_CONT;
  594. X            $ever_matched = 0;                # No match if REJECT or RESTART
  595. X            next rule if $status == $FT_REJECT;
  596. X            $i = -1;        # Restart analysis from the beginning ($FT_RESTART)
  597. X        }
  598. X    }
  599. X    ($ever_saved, $ever_matched);
  600. X}
  601. X
  602. X# Return true if the modes currently specified by the rule (held in $mode)
  603. X# are selected by the current mode (in $wmode), meaning the rule has to
  604. X# be applied.
  605. Xsub right_mode {
  606. X    local($list) = "," . $mode . ",";
  607. X    &add_log("in mode '$wmode' for $mode") if $loglvl > 19;
  608. X
  609. X    # If mode is negated, skip the rule, whatever other selectors may
  610. X    # indicate. Thus <ALL, !INITIAL> will not be taken into account if
  611. X    # mode is INITIAL, despite the leading ALL. They can be seen as further
  612. X    # requirements or restrictions applied to the mode list (like in the
  613. X    # sentence "all the listed modes *but* the one negated").
  614. X
  615. X    return 0 if $list =~ /!ALL/;        # !ALL cannot match, ever
  616. X    return 0 if $list =~ /,!$wmode,/;    # Negated modes logically and'ed
  617. X
  618. X    # Now strip out all negated modes, and if the resulting string is
  619. X    # empty, force a match...
  620. X
  621. X    1 while $list =~ s/,![^,]*,/,/;        # Strip out negated modes
  622. X    $list = ',ALL,' if $list eq ',';    # Emtpy list, force a match
  623. X
  624. X    # The special ALL mode matches anything but the other sepcial mode for
  625. X    # already filtered messages. Otherwise, direct mode (i.e. non-negated)
  626. X    # are logically or'ed.
  627. X
  628. X    if ($list =~ /,ALL,/) {
  629. X        return 0 if $wmode eq '_SEEN_' && $list !~ /,_SEEN_,/;
  630. X    } else {
  631. X        return 0 unless $list =~ /,$wmode,/;
  632. X    }
  633. X
  634. X    1;    # Ok, rule can be applied
  635. X}
  636. X
  637. X# Return true if the mail was from a special user (root, uucp...) or if the
  638. X# mail was not directly mailed to the user (i.e. it comes from a distribution
  639. X# list or has bounced somewhere).
  640. Xsub special_user {
  641. X    # Before sending the vacation message, we have to make sure the mail
  642. X    # was sent to the user directly, through a 'To:' or a 'Cc:'. Otherwise,
  643. X    # it must be from a mailing list or a 'Bcc:' and we don't want to
  644. X    # send something back in that case.
  645. X    local($matched) = &match_list("To", $cf'user);
  646. X    $matched = &match_list("Cc", $cf'user) unless $matched;
  647. X    unless ($matched) {
  648. X        &add_log("mail was not directly sent to $cf'user") if $loglvl > 8;
  649. X        return 1;
  650. X    }
  651. X    # If there is a Precedence: header set to either 'bulk', 'list' or 'junk',
  652. X    # then we do not reply either.
  653. X    local($prec) = $Header{'Precedence'};
  654. X    if ($prec =~ /^bulk|junk|list/i) {
  655. X        &add_log("mail was tagged with a '$prec' precedence") if $loglvl > 8;
  656. X        return 1;
  657. X    }
  658. X    # Make sure the mail does not come from a "special" user, as listed in
  659. X    # the %Special array (root, uucp...)
  660. X    $matched = 0;
  661. X    local($matched_login);
  662. X    foreach $login (keys %Special) {
  663. X        $matched = &match_single("From", $login);
  664. X        $matched_login = $login if $matched;
  665. X        last if $matched;
  666. X    }
  667. X    if ($matched) {
  668. X        &add_log("mail was from special user $matched_login")
  669. X            if $loglvl > 8;
  670. X        return 1;
  671. X    }
  672. X}
  673. X
  674. X# Log reception of mail (sender and subject fields). This is mainly intended
  675. X# for people like me who parse the logfile once in a while to do more 
  676. X# statistics about mail reception. Hence the another distinction between
  677. X# original mails and answers.
  678. Xsub reception {
  679. X    local($subject) = $Header{'Subject'};
  680. X    local($sender) = $Header{'Sender'};
  681. X    local($from) = $Header{'From'};
  682. X    &add_log("FROM $from");
  683. X    &add_log("VIA $sender") if $sender ne '' &&
  684. X        (&parse_address($sender))[0] ne (&parse_address($from))[0];
  685. X    if ($subject ne '') {
  686. X        if ($subject =~ s/^Re:\s*//) {
  687. X            &add_log("REPLY $subject");
  688. X        } else {
  689. X            &add_log("ABOUT $subject");
  690. X        }
  691. X    }
  692. X    print "-------- From $from\n" if $track_all;
  693. X}
  694. X
  695. X# Print match on STDOUT when -t option is used
  696. Xsub track_rule {
  697. X    local($number, $mode) = @_;
  698. X    print "*** Match on rule $number in mode $mode ***\n";
  699. X    &print_rule($number);
  700. X}
  701. X
  702. END_OF_FILE
  703.   if test 14857 -ne `wc -c <'agent/pl/analyze.pl'`; then
  704.     echo shar: \"'agent/pl/analyze.pl'\" unpacked with wrong size!
  705.   fi
  706.   # end of 'agent/pl/analyze.pl'
  707. fi
  708. if test -f 'agent/pl/interface.pl' -a "${1}" != "-c" ; then 
  709.   echo shar: Will not clobber existing file \"'agent/pl/interface.pl'\"
  710. else
  711.   echo shar: Extracting \"'agent/pl/interface.pl'\" \(5893 characters\)
  712.   sed "s/^X//" >'agent/pl/interface.pl' <<'END_OF_FILE'
  713. X;# $Id: interface.pl,v 3.0 1993/11/29 13:48:53 ram Exp ram $
  714. X;#
  715. X;#  Copyright (c) 1990-1993, Raphael Manfredi
  716. X;#  
  717. X;#  You may redistribute only under the terms of the Artistic License,
  718. X;#  as specified in the README file that comes with the distribution.
  719. X;#  You may reuse parts of this distribution only within the terms of
  720. X;#  that same Artistic License; a copy of which may be found at the root
  721. X;#  of the source tree for mailagent 3.0.
  722. X;#
  723. X;# $Log: interface.pl,v $
  724. X;# Revision 3.0  1993/11/29  13:48:53  ram
  725. X;# Baseline for mailagent 3.0 netwide release.
  726. X;#
  727. X;# 
  728. X;# This is for people who, like me, are perl die-hards :-). It simply provides
  729. X;# a simple perl interface for hook scripts and PERL commands. Instead of
  730. X;# writing 'COMMAND with some arguments;' in the filter rule file, you may say
  731. X;# &command('with some arguments') in the perl script. Big deal! Well, at least
  732. X;# that brings you some other nice features from perl itself ;-).
  733. X;#
  734. X#
  735. X# Perl interface with the filter actions
  736. X#
  737. X
  738. Xpackage mailhook;
  739. X
  740. Xsub abort        { &interface'dispatch; }
  741. Xsub annotate    { &interface'dispatch; }
  742. Xsub apply        { &interface'dispatch; }
  743. Xsub assign        { &interface'dispatch; }
  744. Xsub back        { &interface'dispatch; }
  745. Xsub begin        { &interface'dispatch; }
  746. Xsub bounce        { &interface'dispatch; }
  747. Xsub delete        { &interface'dispatch; }
  748. Xsub feed        { &interface'dispatch; }
  749. Xsub forward        { &interface'dispatch; }
  750. Xsub give        { &interface'dispatch; }
  751. Xsub keep        { &interface'dispatch; }
  752. Xsub leave        { &interface'dispatch; }
  753. Xsub macro        { &interface'dispatch; }
  754. Xsub message        { &interface'dispatch; }
  755. Xsub nop            { &interface'dispatch; }
  756. Xsub notify        { &interface'dispatch; }
  757. Xsub once        { &interface'dispatch; }
  758. Xsub pass        { &interface'dispatch; }
  759. Xsub perl        { &interface'dispatch; }
  760. Xsub pipe        { &interface'dispatch; }
  761. Xsub post        { &interface'dispatch; }
  762. Xsub process        { &interface'dispatch; }
  763. Xsub purify        { &interface'dispatch; }
  764. Xsub queue        { &interface'dispatch; }
  765. Xsub record        { &interface'dispatch; }
  766. Xsub reject        { &interface'dispatch; }
  767. Xsub require        { &interface'dispatch; }
  768. Xsub restart        { &interface'dispatch; }
  769. Xsub resync        { &interface'dispatch; }
  770. Xsub run            { &interface'dispatch; }
  771. Xsub save        { &interface'dispatch; }
  772. Xsub select        { &interface'dispatch; }
  773. Xsub server        { &interface'dispatch; }
  774. Xsub split        { &interface'dispatch; }
  775. Xsub store        { &interface'dispatch; }
  776. Xsub strip        { &interface'dispatch; }
  777. Xsub subst        { &interface'dispatch; }
  778. Xsub tr            { &interface'dispatch; }
  779. Xsub unique        { &interface'dispatch; }
  780. Xsub vacation    { &interface'dispatch; }
  781. Xsub write        { &interface'dispatch; }
  782. X
  783. X# A perl filtering script should call &exit and not exit directly.
  784. Xsub exit { 
  785. X    local($code) = @_;
  786. X    die "OK\n" unless $code;
  787. X    die "Exit $code\n";
  788. X}
  789. X
  790. Xpackage interface;
  791. X
  792. X# Perload OFF
  793. X# (Cannot be dynamically loaded as it uses the caller() function)
  794. X
  795. X# The dispatch routine is really simple. We compute the name of our caller,
  796. X# prepend it to the argument and call run_command to actually run the command.
  797. X# Upon return, if we get anything but a continue status, we simply die with
  798. X# an 'OK' string, which will be a signal to the routine monitoring the execution
  799. X# that nothing wrong happened.
  800. Xsub dispatch {
  801. X    local($args) = join(' ', @_);            # Arguments for the command
  802. X    local($name) = (caller(1))[3];            # Function which called us
  803. X    local($status);                            # Continuation status
  804. X    $name =~ s/^\w+'//;                        # Strip leading package name
  805. X    &'add_log("calling '$name $args'") if $'loglvl > 18;
  806. X    $status = &'run_command("$name $args");    # Case does not matter
  807. X
  808. X    # The status propagation is the only thing we have to deal with, as this
  809. X    # is handled within run_command. All other variables which are meaningful
  810. X    # for the filter are dynamically bound to function called before in the
  811. X    # stack, hence they are modified directly from within the perl script.
  812. X
  813. X    die "Status $status\n" unless $status == $'FT_CONT;
  814. X
  815. X    # Return the status held in $lastcmd, unless the command does not alter
  816. X    # the status significantly, in which case we return success. Note that
  817. X    # this is in fact a boolean success status, so 1 means success, whereas
  818. X    # $lastcmd records a failure status.
  819. X
  820. X    $name =~ tr/a-z/A-Z/;                    # Stored upper-cased
  821. X    $'Nostatus{$name} ? 1 : !$lastcmd;        # Propagate status
  822. X}
  823. X
  824. X# Perload ON
  825. X
  826. X$in_perl = 0;                    # Number of nested perl evaluations
  827. X
  828. X# Record entry in new perl evaluation
  829. Xsub new {
  830. X    ++$in_perl;                    # Add one evalution level
  831. X}
  832. X
  833. X# Reset an empty mailhook package by undefining all its symbols.
  834. X# (Warning: heavy wizardry used here -- look at perl's manpage for recipe.)
  835. Xsub reset {
  836. X    return if --$in_perl > 0;    # Do nothing if pending evals remain
  837. X    &'add_log("undefining variables from mailhook") if $'loglvl > 11;
  838. X    local($key, $val);            # Key/value from perl's symbol table
  839. X    # Loop over perl's symbol table for the mailhook package
  840. X    while (($key, $val) = each(%_mailhook)) {
  841. X        local(*entry) = $val;    # Get definitions of current slot
  842. X        undef $entry unless length($key) == 1 && $key !~ /^\w/;
  843. X        undef @entry;
  844. X        undef %entry unless $key =~ /^_/ || $key eq 'header';
  845. X        undef &entry if &valid($key);
  846. X        $_mailhook{$key} = *entry;    # Commit our changes
  847. X    }
  848. X}
  849. X
  850. X# Return true if the function may safely be undefined
  851. Xsub valid {
  852. X    local($fun) = @_;            # Function name
  853. X    return 0 if $fun eq 'exit';    # This function is a convenience
  854. X    # We cannot undefine a filter function, which are listed (upper-cased) in
  855. X    # the %main'Filter table.
  856. X    return 1 unless length($fun) == ($fun =~ tr/a-z/A-Z/);
  857. X    return 1 unless $'Filter{$fun};
  858. X    0;
  859. X}
  860. X
  861. X# Add a new interface function for user-defined commands
  862. Xsub add {
  863. X    local($cmd) = @_;            # Command name
  864. X    $cmd =~ tr/A-Z/a-z/;        # Cannonicalize to lower case
  865. X    eval &'q(<<EOP);            # Compile new mailhook perl interface function
  866. X:    sub mailhook'$cmd { &interface'dispatch; }
  867. XEOP
  868. X    if (chop($@)) {
  869. X        &'add_log("ERROR while adding 'sub $cmd': $@") if $'loglvl;
  870. X        &'add_log("WARNING cannot use '&$cmd' in perl hooks")
  871. X            if $'loglvl > 5;
  872. X    }
  873. X}
  874. X
  875. Xpackage main;
  876. X
  877. END_OF_FILE
  878.   if test 5893 -ne `wc -c <'agent/pl/interface.pl'`; then
  879.     echo shar: \"'agent/pl/interface.pl'\" unpacked with wrong size!
  880.   fi
  881.   # end of 'agent/pl/interface.pl'
  882. fi
  883. if test -f 'agent/pl/rules.pl' -a "${1}" != "-c" ; then 
  884.   echo shar: Will not clobber existing file \"'agent/pl/rules.pl'\"
  885. else
  886.   echo shar: Extracting \"'agent/pl/rules.pl'\" \(14814 characters\)
  887.   sed "s/^X//" >'agent/pl/rules.pl' <<'END_OF_FILE'
  888. X;# $Id: rules.pl,v 3.0 1993/11/29 13:49:14 ram Exp ram $
  889. X;#
  890. X;#  Copyright (c) 1990-1993, Raphael Manfredi
  891. X;#  
  892. X;#  You may redistribute only under the terms of the Artistic License,
  893. X;#  as specified in the README file that comes with the distribution.
  894. X;#  You may reuse parts of this distribution only within the terms of
  895. X;#  that same Artistic License; a copy of which may be found at the root
  896. X;#  of the source tree for mailagent 3.0.
  897. X;#
  898. X;# $Log: rules.pl,v $
  899. X;# Revision 3.0  1993/11/29  13:49:14  ram
  900. X;# Baseline for mailagent 3.0 netwide release.
  901. X;#
  902. X;# 
  903. X# Here are the data structures we use to store the compiled form of the rules:
  904. X#  @Rules has entries looking like "<$mode> {$action} $rulekeys..."
  905. X#  %Rule has entries looking like "$selector: $pattern"
  906. X# Each rule was saved in @Rules. The ruleskeys have the form H<num> where <num>
  907. X# is an increasing integer. They index the rules in %Rule.
  908. X
  909. X# Compile the rules held in file $cf'rules (usually ~/.rules) or in memory
  910. Xsub compile_rules {
  911. X    local($mode);            # mode (optional)
  912. X    local($first_selector);    # selector (mandatory first time)
  913. X    local($selector);        # selector (optional)
  914. X    local($pattern);        # pattern to be matched
  915. X    local($action);            # associated action
  916. X    local($rulekeys);        # keys to rules in hash table
  917. X    local($rulenum) = 0;    # to compute unique keys for the hash table
  918. X    local($line);            # buffer for next rule
  919. X    local($env);            # environment variable recognized
  920. X
  921. X    # This function is called whenever a new line rule has to be read. By
  922. X    # default, rules are read from a file, but if @Linerules is set, they
  923. X    # are read from there.
  924. X    local(*read_rule) = *read_filerule if @Linerules == 0;
  925. X    local(*read_rule) = *read_linerule if @Linerules > 0;
  926. X
  927. X    unless ($edited_rules) {        # If no rules from command line
  928. X        unless (-s "$cf'rules") {    # No rule file or empty
  929. X            &default_rules;            # Build default rules
  930. X            return;
  931. X        }
  932. X        unless (open(RULES, "$cf'rules")) {
  933. X            &add_log("ERROR cannot open $cf'rules: $!") if $loglvl;
  934. X            &default_rules;            # Default rules will apply then
  935. X            return;
  936. X        }
  937. X        if (&rules'read_cache) {    # Rules already compiled and cached
  938. X            close RULES;            # No parsing needs to be done
  939. X            return;
  940. X        }
  941. X    } else {                        # Rules in @Linerules array
  942. X        &rule_cleanup if @Linerules == 1;
  943. X    }
  944. X
  945. X    while ($line = &get_line) {
  946. X        # Detect environment settings as soon as possible
  947. X        if ($line =~ s/^\s*(\w+)\s*=\s*//) {
  948. X            # All the variables referenced in the line have to be environment
  949. X            # variables. So replace them with the values we already computed as
  950. X            # perl variables. This enables us to do variable substitution in
  951. X            # perl with minimum trouble.
  952. X            $env = $1;                                # Variable being changed
  953. X            $line =~ s/\$(\w+)/\$XENV{'$1'}/g;        # $VAR -> $XENV{'VAR'}
  954. X            $line =~ s/;$//;                        # Remove trailing ;
  955. X            eval "\$XENV{'$env'} = \"$line\"";        # Perl does the evaluations
  956. X            &eval_error;                            # Report any eval error
  957. X            next;
  958. X        }
  959. X        $rulekeys = '';                        # Reset keys for each line
  960. X        $mode = &get_mode(*line);            # Get operational mode
  961. X        &add_log("mode: <$mode>") if $loglvl > 19;
  962. X        $first_selector = &get_selector(*line);        # Fetch a selector
  963. X        $first_selector = "Subject:" unless $first_selector;
  964. X        $selector = $first_selector;
  965. X        for (;;) {
  966. X            if ($line =~ /^\s*;/) {            # Selector alone on the line
  967. X                &add_log("ERROR no pattern nor action, line $.") if $loglvl > 1;
  968. X                last;                        # Ignore the whole line
  969. X            }
  970. X            &add_log("selector: $selector") if $loglvl > 19;
  971. X            # Get a pattern. If none is found, it is assumed to be '*', which
  972. X            # will match anything.
  973. X            $pattern = &get_pattern(*line);
  974. X            $pattern = '*' if $pattern =~ /^\s*$/;
  975. X            &add_log("pattern: $pattern") if $loglvl > 19;
  976. X            # Record entry in H table and update the set of used keys
  977. X            $Rule{"H$rulenum"} = "$selector $pattern";
  978. X            $rulekeys .= "H$rulenum ";
  979. X            $rulenum++;
  980. X            # Now look for an action. No action at the end means LEAVE.
  981. X            $action = &get_action(*line);
  982. X            $action = "LEAVE" if $action =~ /^\s*$/ && $line =~/^\s*;/;
  983. X            if ($action !~ /^\s*$/) {
  984. X                &add_log("action: $action") if $loglvl > 19;
  985. X                push(@Rules, "$mode {$action} $rulekeys");
  986. X                $rulekeys = '';        # Reset rule keys once used
  987. X            }
  988. X            last if $line =~ /^\s*;/;    # Finished if end of line reached
  989. X            last if $line =~ /^\s*$/;    # Also finished if end of file
  990. X            # Get a new selector, defaults to last one seen if none is found
  991. X            $selector = &get_selector(*line);
  992. X            $selector = $first_selector if $selector eq '';
  993. X            $first_selector = $selector;
  994. X        }
  995. X    }
  996. X    close RULES;        # This may not have been opened
  997. X
  998. X    &default_rules unless @Rules;    # Use defaults if no valid rules
  999. X
  1000. X    # If rules have been compiled from a file and not entered on the command
  1001. X    # line via -e switch(es), then $edited_rules is false and it makes sense
  1002. X    # to cache the lattest compiled rules. Note that the 'rulecache' parameter
  1003. X    # is optional, and rules are actually cached only if it is defined.
  1004. X
  1005. X    &rules'write_cache unless $edited_rules;
  1006. X}
  1007. X
  1008. X# Build default rules:
  1009. X#  -  Anything with 'Subject: Command' in it is processed.
  1010. X#  -  All the mails are left in the mailbox.
  1011. Xsub default_rules {
  1012. X    &add_log("building default rules") if $loglvl > 18;
  1013. X    @Rules = ("ALL {LEAVE; PROCESS} H0");
  1014. X    $Rule{'H0'} = "All: /^Subject: [Cc]ommand/";
  1015. X}
  1016. X
  1017. X# Rule cleanup: If there is only one rule specified within the @Linerules
  1018. X# array, it might not have {} braces.
  1019. Xsub rule_cleanup {
  1020. X    return if $Linerules[0] =~ /[{}]/;        # Braces found
  1021. X    $Linerules[0] = '{' . $Linerules[0] . '}';
  1022. X}
  1023. X
  1024. X# Hook functions for dumping rules
  1025. Xsub print_rule_number {
  1026. X    local($rulenum) = @_;
  1027. X    print "# Rule $rulenum\n";            # For easier reference
  1028. X    1;                                    # Continue
  1029. X}
  1030. X
  1031. X# Void function
  1032. Xsub void_func {
  1033. X    print "\n";
  1034. X}
  1035. X
  1036. X# Print only rule whose number is held in variable $number
  1037. Xsub exact_rule {
  1038. X    $_[0] eq $number;
  1039. X}
  1040. X
  1041. Xsub nothing { }             # Do nothing, really nothing
  1042. X
  1043. X# Dump the rules we've compiled -- for debug purposes
  1044. Xsub dump_rules {
  1045. X    # The 'before' hook is called before each rule is called. It returns a
  1046. X    # boolean stating wether we should continue or skip the rule. The 'after'
  1047. X    # hook is called after the rule has been printed. Both hooks are given the
  1048. X    # rule number as argument.
  1049. X    local(*before, *after) = @_;    # Hook functions to be called
  1050. X    local($mode);            # mode (optional)
  1051. X    local($selector);        # selector (mandatory)
  1052. X    local($rulentry);        # entry in rule H table
  1053. X    local($pattern);        # pattern for selection
  1054. X    local($action);            # related action
  1055. X    local($last_selector);    # last used selector
  1056. X    local($rules);            # a copy of the rules
  1057. X    local($rulenum) = 0;    # each rule is numbered
  1058. X    local($lines);            # number of pattern lines printed
  1059. X    local(@action);            # split actions (split on ;)
  1060. X    local($printed) = 0;    # characters printed on line so far
  1061. X    local($indent);            # next item indentation
  1062. X    local($linelen) = 78;    # maximum line length
  1063. X    # Print the environement variable which differ from the original
  1064. X    # environment, i.e. those variable which were set by the user.
  1065. X    $lines = 0;
  1066. X    foreach (keys(%XENV)) {
  1067. X        unless ("$XENV{$_}" eq "$ENV{$_}") {
  1068. X            print "$_ = ", $XENV{$_}, ";\n";
  1069. X            $lines++;
  1070. X        }
  1071. X    }
  1072. X    print "\n" if $lines;
  1073. X    # Order wrt the one in the rule file is guaranteed
  1074. X    foreach (@Rules) {
  1075. X        $rulenum++;
  1076. X        next unless &before($rulenum);                # Call 'before' hook
  1077. X        $rules = $_;        # Work on a copy
  1078. X        $rules =~ s/^([^{]*){// && ($mode = $1);    # First "word" is the mode
  1079. X        $rules =~ s/\s*(.*)}// && ($action = $1);    # Then action within {}
  1080. X        $mode =~ s/\s*$//;                            # Remove trailing spaces
  1081. X        print "<$mode> ";                            # Mode in which it applies
  1082. X        $printed = length($mode) + 3;
  1083. X        $rules =~ s/^\s+//;                            # The rule keys remain
  1084. X        $last_selector = "";                        # Last selector in use
  1085. X        $lines = 0;
  1086. X        foreach $key (split(/ /, $rules)) {            # Loop over the keys
  1087. X            $rulentry = $Rule{$key};
  1088. X            $rulentry =~ s/^\s*([^\/]*:)// && ($selector = $1);
  1089. X            $rulentry =~ s/^\s*//;
  1090. X            $pattern = $rulentry;
  1091. X            if ($last_selector eq $selector) {        # Try to stay on same line
  1092. X                # Go to next line if current pattern won't fit nicely
  1093. X                if ($printed + length($pattern) > $linelen) {
  1094. X                    $indent = length($mode) + length($selector) + 4;
  1095. X                    print ",\n", ' ' x $indent;
  1096. X                    $lines++;
  1097. X                    $printed = $indent;
  1098. X                } else {
  1099. X                    print ", ";
  1100. X                    $printed += 2;
  1101. X                }
  1102. X            } else {                                # Selector has changed
  1103. X                if ($lines++) {
  1104. X                    $indent = length($mode) + 3;
  1105. X                    print ",\n", ' ' x $indent;
  1106. X                    $printed = $indent;
  1107. X                }
  1108. X            }
  1109. X            if ($last_selector ne $selector) {        # Update last selector
  1110. X                $last_selector = $selector;
  1111. X                if ($selector ne 'script:') {        # Pseudo not printed
  1112. X                    print "$selector ";
  1113. X                    $printed += length($selector) + 1;
  1114. X                }
  1115. X            }
  1116. X            if ($selector ne 'script:') {
  1117. X                print "$pattern";                    # Normal pattern
  1118. X                $printed += length($pattern);
  1119. X            } else {
  1120. X                print "[[ $pattern ]] ";            # An interpreted script
  1121. X                $printed += length($pattern) + 7;
  1122. X            }
  1123. X        }
  1124. X        print "  " if $lines == 1 && $printed += 2;
  1125. X
  1126. X        # Split actions, but take care of escaped \; (layout purposes)
  1127. X        $action =~ s/\\\\/\02/g;            # \\ -> ^B
  1128. X        $action =~ s/\\;/\01/g;                # \; -> ^A
  1129. X        @action = split(/;/, $action);
  1130. X        foreach (@action) {                    # Restore escapes by in-place edit
  1131. X            s/\01/\\;/g;                    # ^A -> \;
  1132. X            s/\02/\\\\/g;                    # ^B -> \\
  1133. X        }
  1134. X
  1135. X        # If action is large enough, format differently (one action/line)
  1136. X        $lines++ if length($action) + 5 + $printed > $linelen;
  1137. X        $indent = $lines > 1 ? length($mode) + 3 + 4 : 0;
  1138. X        $printed = $indent == 0 ? $printed : $indent;
  1139. X        if ((length($action) + $printed) > $linelen && @action > 1) {
  1140. X            print "\n\t{\n";
  1141. X            foreach $act (@action) {
  1142. X                $act =~ s/^\s+//;
  1143. X                print "\t\t$act;\n";
  1144. X            }
  1145. X            print "\t};\n";
  1146. X        } else {
  1147. X            print "\n", ' ' x $indent if $lines > 1;
  1148. X            print "{ $action };\n";
  1149. X        }
  1150. X        $printed = 0;
  1151. X
  1152. X        # Call the hook function after having printed the rule
  1153. X        &after($rulenum);
  1154. X    }
  1155. X}
  1156. X
  1157. X# Print only a specific rule on stdout
  1158. Xsub print_rule {
  1159. X    local($number) = @_;
  1160. X    local(%XENV);            # Suppress printing of leading variables
  1161. X    &dump_rules(*exact_rule, *nothing);
  1162. X}
  1163. X
  1164. X#
  1165. X# The following package added to hold all the new rule-specific functions
  1166. X# added at version 3.0.
  1167. X#
  1168. X
  1169. Xpackage rules;
  1170. X
  1171. X# Cache rules to the 'rulecache' file. The first line is the full pathname
  1172. X# of the rule file, followed by the modification time stamp. The rulecache
  1173. X# file will be recreated each time a different rule file is provided or when
  1174. X# it is out of date. Note that this function is only called when actually
  1175. X# compiling from the 'rules' file defined in the config file.
  1176. X# The function returns 1 if success, 0 on failure.
  1177. Xsub write_cache {
  1178. X    return 0 unless defined $cf'rulecache;
  1179. X    local(*CACHE);                    # File handle used to write the cache
  1180. X    unless (open(CACHE, ">$cf'rulecache")) {
  1181. X        &'add_log("ERROR cannot create rule cache $cf'rulecache: $!")
  1182. X            if $'loglvl;
  1183. X        unlink $cf'rulecache;
  1184. X        return 0;
  1185. X    }
  1186. X    local($error) = 0;
  1187. X    local($ST_MTIME) = 9 + $[;
  1188. X    local($mtime) = (stat($cf'rules))[$ST_MTIME];
  1189. X    (print CACHE "$cf'rules $mtime\n") || $error++;
  1190. X    &write_fd(CACHE) || $error++;        # Write rules
  1191. X    &writevar_fd(CACHE) || $error++;    # And XENV variables
  1192. X    close(CACHE) || $error++;
  1193. X    if ($error) {
  1194. X        &'add_log("WARNING could not cache rules") if $'loglvl > 5;
  1195. X        unlink $cf'rulecache;
  1196. X        return 0;
  1197. X    }
  1198. X    1;    # Success
  1199. X}
  1200. X
  1201. X# Read cached rules into @Rules and %Rules and returns 1 if done, 0 when
  1202. X# the cache may not be read for whatever reason (e.g. out of date).
  1203. Xsub read_cache {
  1204. X    return 0 unless &cache_ok;
  1205. X    local(*CACHE);                    # File handle used to read the cache
  1206. X    local($_);
  1207. X    open(CACHE, $cf'rulecache) || return 0;    # Cannot open, assume out of date
  1208. X    $_ = <CACHE>;                    # Disregard top line
  1209. X    while (<CACHE>) {                # First read the @Rules
  1210. X        chop;
  1211. X        last if /^$/;                # Reached end of @Rules table
  1212. X        push(@'Rules, $_);
  1213. X    }
  1214. X    local($rulenum) = 0;
  1215. X    while (<CACHE>) {                # Next read sorted values, assigned to H...
  1216. X        chop;
  1217. X        last if /^\+\+\+\+\+\+/;    # End of dumped rules
  1218. X        $'Rule{"H$rulenum"} = $_;
  1219. X        $rulenum++;
  1220. X    }
  1221. X    while (<CACHE>) {                # Read XENV variables
  1222. X        chop;
  1223. X        s/^\s*(\w+)\s*=\s*// && ($'XENV{$1} = $_);
  1224. X    }
  1225. X    close CACHE;
  1226. X    1;    # Success
  1227. X}
  1228. X
  1229. X# Is cache up-to-date with respect to the rule file? Returns true if cache ok.
  1230. Xsub cache_ok {
  1231. X    return 0 unless defined $cf'rulecache;
  1232. X    local(*CACHE);                    # File handle used to read the cache
  1233. X    local($top);                    # Top line recording file name and timestamp
  1234. X    open(CACHE, $cf'rulecache) || return 0;    # Cannot open, assume out of date
  1235. X    $top = <CACHE>;                    # Get that first line
  1236. X    close CACHE;
  1237. X    local($name, $stamp) = split(' ', $top);
  1238. X    return 0 if $name ne $cf'rules;    # File changed, cache out of date
  1239. X    local($ST_MTIME) = 9 + $[;
  1240. X    local($mtime) = (stat($cf'rules))[$ST_MTIME];
  1241. X    $mtime != $stamp ? 0 : 1;        # Cache up-to-date only if $stamp == $mtime
  1242. X}
  1243. X
  1244. X# Dump the internal form of the rules, returning 1 for success.
  1245. Xsub write_fd {
  1246. X    local($file) = @_;                # Filehandle in which rules are to be dumped
  1247. X    local($_);
  1248. X    local($error) = 0;
  1249. X    foreach (@'Rules) {
  1250. X        (print $file $_, "\n") || $error++;
  1251. X    }
  1252. X    (print $file "\n") || $error++;    # A blank line separates tables
  1253. X    foreach (sort hashkey keys %'Rule) {
  1254. X        (print $file $'Rule{$_}, "\n") || $error++;
  1255. X    }
  1256. X    (print $file "++++++\n") || $error++;    # Marks end of dumped rules
  1257. X    $error ? 0 : 1;        # Success when no error reported
  1258. X}
  1259. X
  1260. X# Dump the internal form of environment variables, returning 1 for success.
  1261. Xsub writevar_fd {
  1262. X    local($file) = @_;                # Filehandle in which variables are printed
  1263. X    local($error) = 0;
  1264. X    local($_);
  1265. X    foreach (keys(%'XENV)) {
  1266. X        unless ("$'XENV{$_}" eq "$'ENV{$_}") {
  1267. X            (print $file "$_ = ", $'XENV{$_}, "\n") || $error++;
  1268. X        }
  1269. X    }
  1270. X    $error ? 0 : 1;        # Success when no error reported
  1271. X}
  1272. X
  1273. X# Sorting for hash keys used by %Rule
  1274. Xsub hashkey {
  1275. X    local($c) = $a =~ /^H(\d+)/;
  1276. X    local($d) = $b =~ /^H(\d+)/;
  1277. X    $c <=> $d;
  1278. X}
  1279. X
  1280. X# The following sets-up a new rule environment and then transfers the control
  1281. X# to some other function, giving it the remaining parameters. That enables the
  1282. X# other function to work transparently with a different set of rules. Merely
  1283. X# done for the APPLY function. Returns undef for errors, or propagates the
  1284. X# result of the function.
  1285. Xsub alternate {
  1286. X    local($rules, $fn, @rest) = @_;
  1287. X    local($'edited_rules) = 1;    # Signals that rules do not come from main file
  1288. X    local(@'Rules);                # Set up a new dynamic environment...
  1289. X    local(%'Rule);
  1290. X    local(@'Linerules);            # We're stuffing our new rules there
  1291. X
  1292. X    unless (open(RULES, $rules)) {
  1293. X        &'add_log("ERROR cannot open alternate rule file $rules: $!")
  1294. X            if $'loglvl;
  1295. X        return undef;
  1296. X    }
  1297. X    local($_);
  1298. X    while (<RULES>) {
  1299. X        chop;                    # Not really needed, but it'll save space :-)
  1300. X        push(@'Linerules, $_);
  1301. X    }
  1302. X    close RULES;
  1303. X
  1304. X    # Need at list two line rules or we'll try to apply some default fixes
  1305. X    # used by the -e 'rules' switch...
  1306. X    push(@'Linerules, '', '') if @'Linerules <= 1;
  1307. X
  1308. X    # Make sure transfer function is package-qualified
  1309. X    $fn = "main'$fn" unless $fn =~ /'/;
  1310. X
  1311. X    &'compile_rules;    # Compile new rules held in the @'Linerules array
  1312. X    &$fn(@rest);        # Transfer control in new environment
  1313. X}
  1314. X
  1315. Xpackage main;
  1316. X
  1317. END_OF_FILE
  1318.   if test 14814 -ne `wc -c <'agent/pl/rules.pl'`; then
  1319.     echo shar: \"'agent/pl/rules.pl'\" unpacked with wrong size!
  1320.   fi
  1321.   # end of 'agent/pl/rules.pl'
  1322. fi
  1323. echo shar: End of archive 12 \(of 26\).
  1324. cp /dev/null ark12isdone
  1325. MISSING=""
  1326. for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 ; do
  1327.     if test ! -f ark${I}isdone ; then
  1328.     MISSING="${MISSING} ${I}"
  1329.     fi
  1330. done
  1331. if test "${MISSING}" = "" ; then
  1332.     echo You have unpacked all 26 archives.
  1333.     echo "Now run 'sh PACKNOTES', then read README and type Configure.'"
  1334.     rm -f ark[1-9]isdone ark[1-9][0-9]isdone
  1335. else
  1336.     echo You still must unpack the following archives:
  1337.     echo "        " ${MISSING}
  1338. fi
  1339. exit 0
  1340.  
  1341. exit 0 # Just in case...
  1342.