home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1994 March / Source_Code_CD-ROM_Walnut_Creek_March_1994.iso / compsrcs / misc / volume41 / mailagnt / part09 < prev    next >
Encoding:
Text File  |  1993-12-02  |  55.2 KB  |  1,826 lines
  1. Newsgroups: comp.sources.misc
  2. From: Raphael Manfredi <ram@acri.fr>
  3. Subject: v41i009:  mailagent - Flexible mail filtering and processing package, v3.0, Part09/26
  4. Message-ID: <1993Dec2.133830.18419@sparky.sterling.com>
  5. X-Md4-Signature: 225552b58db32df60ced138e7ac608fd
  6. Sender: kent@sparky.sterling.com (Kent Landfield)
  7. Organization: Advanced Computer Research Institute, Lyon, France.
  8. Date: Thu, 2 Dec 1993 13:38:30 GMT
  9. Approved: kent@sparky.sterling.com
  10.  
  11. Submitted-by: Raphael Manfredi <ram@acri.fr>
  12. Posting-number: Volume 41, Issue 9
  13. Archive-name: mailagent/part09
  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:  agent/pl/filter.pl agent/pl/getdate.pl
  24. #   agent/test/basic/mailagent.t
  25. # Wrapped by ram@soft208 on Mon Nov 29 16:49:55 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 9 (of 26)."'
  29. if test -f 'agent/pl/filter.pl' -a "${1}" != "-c" ; then 
  30.   echo shar: Will not clobber existing file \"'agent/pl/filter.pl'\"
  31. else
  32.   echo shar: Extracting \"'agent/pl/filter.pl'\" \(22116 characters\)
  33.   sed "s/^X//" >'agent/pl/filter.pl' <<'END_OF_FILE'
  34. X;# $Id: filter.pl,v 3.0 1993/11/29 13:48:46 ram Exp ram $
  35. X;#
  36. X;#  Copyright (c) 1990-1993, Raphael Manfredi
  37. X;#  
  38. X;#  You may redistribute only under the terms of the Artistic License,
  39. X;#  as specified in the README file that comes with the distribution.
  40. X;#  You may reuse parts of this distribution only within the terms of
  41. X;#  that same Artistic License; a copy of which may be found at the root
  42. X;#  of the source tree for mailagent 3.0.
  43. X;#
  44. X;# $Log: filter.pl,v $
  45. X;# Revision 3.0  1993/11/29  13:48:46  ram
  46. X;# Baseline for mailagent 3.0 netwide release.
  47. X;#
  48. X;#
  49. X;# There are a number of variables which are used by the filter commands and
  50. X;# which are in the dynamic scope when those functions are called. The calling
  51. X;# tree being: analyze_mail -> xeqte -> run_command -> run_*, where '*' stands
  52. X;# for the action we are currently executing.
  53. X;#
  54. X;# All the run_* commands are called from within an eval by run_command, so that
  55. X;# any otherwise fatal error can be trapped and reported in the log file. This
  56. X;# is only a precaution against possible typos or other unpredictable errors.
  57. X;#
  58. X;# The following variables are inherited from run_command:
  59. X;#  $mfile is the name of the mail file processed
  60. X;#  $cmd is the command to be run
  61. X;#  $cmd_name is the command name (upper-cased)
  62. X;#  $ever_saved which states whether a saving/discarding action occurred
  63. X;#  $cont is the continuation status, modified by REJECT and friends
  64. X;#  $vacation which is a boolean stating whether vacation messages are allowed
  65. X;# The following variable is inherited from xeqte:
  66. X;#  $lastcmd is the failure status of the last command (among those to be kept)
  67. X;# The working mode is held in $wmode (comes from analyze_mail).
  68. X;#
  69. X;# All the commands return an exit status: 0 for ok, 1 for failure. This status
  70. X;# is normally recorded in $lastcmd by run_command, unless the executed action
  71. X;# belongs to the set of commands whose exit status is discarded (because they
  72. X;# can never fail).
  73. X;#
  74. X#
  75. X# Filter commands are run from here
  76. X#
  77. X
  78. X# Run the PROCESS command
  79. Xsub run_process {
  80. X    if (0 != &process) {
  81. X        &add_log("ERROR while processing [$mfile]--queing it") if $loglvl;
  82. X        &queue_mail($file_name);
  83. X        return 1;
  84. X    }
  85. X    &add_log("PROCESSED [$mfile]") if $loglvl > 8;
  86. X    0;
  87. X}
  88. X
  89. X# Run the SERVER command
  90. Xsub run_server {
  91. X    local($options) = $cmd =~ /^\w+\s+(.*)/;    # Get options
  92. X    local($disabled);                            # List of disabled commands
  93. X    $disabled = $1 if $options =~ s/'(.*)'//;    # Disables commands within ''
  94. X    local($opt_t) = $options =~ /t/;
  95. X    local($opt_d) = $options =~ /d/;
  96. X    &cmdenv'inituid;                # Initialize server session environment
  97. X    &cmdserv'trusted if $opt_t;        # Server runs in trusted mode
  98. X    &cmdserv'disable($disabled) if $opt_d;    # Disable commands for this run
  99. X    local(@body) = split(/\n/, $Header{'Body'});
  100. X    &cmdserv'process(*body);
  101. X    &add_log("SERVED [$mfile]") if $loglvl > 8;
  102. X    0;
  103. X}
  104. X
  105. X# Run the LEAVE command
  106. Xsub run_leave {
  107. X    local($mbox, $failed) = &leave;
  108. X    unless ($failed) {
  109. X        &add_log("LEFT [$mfile] in mailbox") if $loglvl > 2;
  110. X    }
  111. X    # Even if it failed, mark it as saved anyway, as the default action would
  112. X    # be a saving in mailbox and there is little chance another attempt would
  113. X    # succeed while this one failed.
  114. X    $ever_saved = 1;        # At least we tried to save it
  115. X    $failed;
  116. X}
  117. X
  118. X# Run the SAVE command
  119. Xsub run_save {
  120. X    local($folder) = $cmd =~ /^\w+\s+(\S+)/;    # Get first parameter
  121. X    &save_message($folder);
  122. X}
  123. X
  124. X# Run the STORE command
  125. Xsub run_store {
  126. X    local($folder) = $cmd =~ /^\w+\s+(\S+)/;    # Get first parameter
  127. X    local($mbox, $failed, $log_message) = &run_saving($folder, $FOLDER_APPEND);
  128. X    unless ($failed) {
  129. X        $ever_saved = 1;            # We were able to save it
  130. X        ($mbox, $failed) = &leave;
  131. X        unless ($failed) {
  132. X            &add_log("STORED [$mfile] in $log_message") if $loglvl > 2;
  133. X        } else {
  134. X            &add_log("WARNING only SAVED [$mfile] in $log_message")
  135. X                if $loglvl > 1;
  136. X            return 1;
  137. X        }
  138. X    } else {
  139. X        ($mbox, $failed) = &leave;
  140. X        unless ($failed) {
  141. X            $ever_saved = 1;            # We were able to save it
  142. X            &add_log("WARNING only LEFT [$mfile] in mailbox")
  143. X                if $loglvl > 1;
  144. X        }
  145. X    }
  146. X    $failed;
  147. X}
  148. X
  149. X# Run the WRITE command
  150. Xsub run_write {
  151. X    local($folder) = $cmd =~ /^\w+\s+(\S+)/;    # Get first parameter
  152. X    local($mbox, $failed, $log_message) = &run_saving($folder, $FOLDER_REMOVE);
  153. X    unless ($failed) {
  154. X        &add_log("WROTE [$mfile] in $log_message") if $loglvl > 2;
  155. X        $ever_saved = 1;            # We were able to save it
  156. X    }
  157. X    $failed;
  158. X}
  159. X
  160. X# Run the DELETE command
  161. Xsub run_delete {
  162. X    &add_log("DELETED [$mfile]") if $loglvl > 2;
  163. X    $ever_saved = 1;        # User chose to discard it, it counts as a save
  164. X    0;
  165. X}
  166. X
  167. X# Run the MACRO command
  168. Xsub run_macro {
  169. X    local($args) = $cmd =~ m|^\w+\s+(.*)|;    # Get command arguments
  170. X    local($name, $action) = ¯o($args);    # Perform the command
  171. X    &add_log("MACRO [$mfile] $name $action") if $loglvl > 7;
  172. X    0;    # Never fails
  173. X}
  174. X
  175. X# Run the MESSAGE command
  176. Xsub run_message {
  177. X    local($msg) = $cmd =~ m|^\w+\s+(\S+)|;    # Vacation message location
  178. X    $msg =~ s/~/$cf'home/g;                    # ~ substitution
  179. X    local($failed) = &message($msg);
  180. X    unless ($failed) {
  181. X        $msg = &tilda($msg);                # Replace the home directory by ~
  182. X        &add_log("MESSAGE $msg for [$mfile]") if $loglvl > 2;
  183. X    }
  184. X    $failed;
  185. X}
  186. X
  187. X# Run the NOTIFY command
  188. Xsub run_notify {
  189. X    local($args) = $cmd =~ m|^\w+\s+(.*)|;
  190. X    local(@args) = split(' ', $args);
  191. X    local($msg) = shift(@args);                # First argument is message text
  192. X    $msg =~ s/~/$cf'home/g;                    # ~ substitution
  193. X    local($address) = join(' ', @args);        # Address list
  194. X    local($failed) = ¬ify($msg, $address);
  195. X    unless ($failed) {
  196. X        $msg = &tilda($msg);                # Replace the home directory by ~
  197. X        &add_log("NOTIFIED $msg [$mfile] to $address") if $loglvl > 2;
  198. X    }
  199. X    $failed;
  200. X}
  201. X
  202. X# Run the REJECT command
  203. Xsub run_reject {
  204. X    local(*perform) = *do_reject;
  205. X    &alter_flow;        # Change control flow by calling &perform
  206. X}
  207. X
  208. X# Run the RESTART command
  209. Xsub run_restart {
  210. X    local(*perform) = *do_restart;
  211. X    &alter_flow;        # Change control flow by calling &perform
  212. X}
  213. X
  214. X# Run the ABORT command
  215. Xsub run_abort {
  216. X    local(*perform) = *do_abort;
  217. X    &alter_flow;        # Change control flow by calling &perform
  218. X}
  219. X
  220. X# Run the RESYNC command
  221. Xsub run_resync {
  222. X    &header_resync;                # Resynchronize the %Header array
  223. X    &add_log("RESYNCED [$mfile]") if $loglvl > 4;
  224. X    0;
  225. X}
  226. X
  227. X# Run the BEGIN command
  228. Xsub run_begin {
  229. X    local($newstate) = $cmd =~ m|^\w+\s+(\S+)|;    # New state wanted
  230. X    $newstate = 'INITIAL' unless $newstate;
  231. X    $wmode = $newstate;            # $wmode comes from analyze_mail
  232. X    &add_log("BEGUN new state $newstate") if $loglvl > 4;
  233. X    0;
  234. X}
  235. X
  236. X# Run the RECORD command
  237. Xsub run_record {
  238. X    local($option, $mode) = $cmd =~ m|^\w+\s+(-\w)?\s*(\w+)?|;
  239. X    local($failed) = 0;
  240. X    if (&history_record) {        # Message already seen
  241. X        $wmode = '_SEEN_';        # Enter special mode ($wmode from analyze_mail)
  242. X        &add_log("NOTICE entering seen mode") if $loglvl > 5;
  243. X        &alter_execution($option, $mode);
  244. X        $failed = 1;            # Make sure it "fails"
  245. X    }
  246. X    &add_log("RECORDED [$mfile]") if $loglvl > 4;
  247. X    $failed;
  248. X}
  249. X
  250. X# Run the UNIQUE command
  251. Xsub run_unique {
  252. X    local($option, $mode) = $cmd =~ m|^\w+\s+(-\w)?\s*(\w+)?|;
  253. X    local($failed) = 0;
  254. X    if (&history_record) {        # Message already seen
  255. X        &add_log("NOTICE message tagged as saved") if $loglvl > 5;
  256. X        $ever_saved = 1;        # In effect, runs a DELETE
  257. X        &alter_execution($option, $mode);
  258. X        $failed = 1;            # Make sure it "fails"
  259. X    }
  260. X    &add_log("UNIQUE [$mfile]") if $loglvl > 4;
  261. X    $failed;
  262. X}
  263. X
  264. X# Run the FORWARD command
  265. Xsub run_forward {
  266. X    local($addresses) = $cmd =~ m|^\w+\s+(.*)|;    # Address(es)
  267. X    local($failed) = &forward($addresses);
  268. X    unless ($failed) {
  269. X        &add_log("FORWARDED [$mfile] to $addresses") if $loglvl > 2;
  270. X        $ever_saved = 1;        # Forwarding succeeded, counts as a save
  271. X    }
  272. X    $failed;
  273. X}
  274. X
  275. X# Run the BOUNCE command
  276. Xsub run_bounce {
  277. X    local($addresses) = $cmd =~ m|^\w+\s+(.*)|;    # Address(es)
  278. X    local($failed) = &bounce($addresses);
  279. X    unless ($failed) {
  280. X        &add_log("BOUNCED [$mfile] to $addresses") if $loglvl > 2;
  281. X        $ever_saved = 1;        # Bouncing succeeded, counts as a save
  282. X    }
  283. X    $failed;
  284. X}
  285. X
  286. X# Run the POST command
  287. Xsub run_post {
  288. X    local($newsgroups) = $cmd =~ m|^\w+\s+(.*)|;    # Newsgroup(s)
  289. X    local($failed) = &post($newsgroups);
  290. X    unless ($failed) {
  291. X        &add_log("POSTED [$mfile] to $newsgroups") if $loglvl > 2;
  292. X        $ever_saved = 1;        # Posting succeeded, counts as a save
  293. X    }
  294. X    $failed;
  295. X}
  296. X
  297. X# Run the RUN command
  298. Xsub run_run {
  299. X    local($program) = $cmd =~ m|^\w+\s+(.*)|;    # Program to run
  300. X    local($failed) = &shell_command($program, $NO_INPUT, $NO_FEEDBACK);
  301. X    unless ($failed) {
  302. X        &add_log("RAN '$program' for [$mfile]") if $loglvl > 4;
  303. X    }
  304. X    $failed;
  305. X}
  306. X
  307. X# Run the PIPE command
  308. Xsub run_pipe {
  309. X    local($program) = $cmd =~ m|^\w+\s+(.*)|;    # Program to run
  310. X    local($failed) = &shell_command($program, $MAIL_INPUT, $NO_FEEDBACK);
  311. X    unless ($failed) {
  312. X        &add_log("PIPED [$mfile] to '$program'") if $loglvl > 4;
  313. X    }
  314. X    $failed;
  315. X}
  316. X
  317. X# Run the GIVE command
  318. Xsub run_give {
  319. X    local($program) = $cmd =~ m|^\w+\s+(.*)|;    # Program to run
  320. X    local($failed) = &shell_command($program, $BODY_INPUT, $NO_FEEDBACK);
  321. X    unless ($failed) {
  322. X        &add_log("GAVE [$mfile] to '$program'") if $loglvl > 4;
  323. X    }
  324. X    $failed;
  325. X}
  326. X
  327. X# Run the PASS command
  328. Xsub run_pass {
  329. X    local($program) = $cmd =~ m|^\w+\s+(.*)|;    # Program to run
  330. X    local($failed) = &shell_command($program, $BODY_INPUT, $FEEDBACK);
  331. X    unless ($failed) {
  332. X        &add_log("PASSED [$mfile] through '$program'") if $loglvl > 4;
  333. X    }
  334. X    $failed;
  335. X}
  336. X
  337. X# Run the FEED command
  338. Xsub run_feed {
  339. X    local($program) = $cmd =~ m|^\w+\s+(.*)|;    # Program to run
  340. X    local($failed) = &shell_command($program, $MAIL_INPUT, $FEEDBACK);
  341. X    unless ($failed) {
  342. X        &add_log("FED [$mfile] through '$program'") if $loglvl > 4;
  343. X    }
  344. X    $failed;
  345. X}
  346. X
  347. X# Run the PURIFY command
  348. Xsub run_purify {
  349. X    local($program) = $cmd =~ m|^\w+\s+(.*)|;    # Program to run
  350. X    local($failed) = &shell_command($program, $HEADER_INPUT, $FEEDBACK);
  351. X    unless ($failed) {
  352. X        &add_log("PURIFIED [$mfile] through '$program'") if $loglvl > 4;
  353. X    }
  354. X    $failed;
  355. X}
  356. X
  357. X# Run the BACK command
  358. X# Manipulates dynamically bound variable $cont (output from xeqte)
  359. Xsub run_back {
  360. X    # BACK command is handled recursively. The local variable $Back will be set
  361. X    # by xeq_back() if any feedback is to ever occur. This routine will be
  362. X    # transparently called instead of the usual handle_output() because of the
  363. X    # dynamic aliasing done here.
  364. X    local($Back) = '';                    # BACK may be nested
  365. X    local(*handle_output) = *xeq_back;    # Any output to be put in $Back
  366. X    local($command) = $cmd =~ m|^BACK\s+(.*)|;
  367. X    local($failed) = 0;
  368. X    $command =~ s/%/%%/g;                # Protect against 2nd macro substitution
  369. X    # Calling run_command will position $lastcmd to be the return status of
  370. X    # the last meaningful command executed. However, we reset $lastcmd before
  371. X    # diving into the execution.
  372. X    $lastcmd = 0;                        # Assume everything went fine
  373. X    &run_command($command);                # Run command (ignore return value)
  374. X    if ($Back ne '') {
  375. X        &add_log("got '$Back' back") if $loglvl > 11;
  376. X        $cont = &xeqte($Back);            # Get continuation status back
  377. X        $@ = '';                        # Avoid cascade of (same) error report
  378. X        &add_log("BACK from '$command'") if $loglvl > 4;
  379. X    } else {
  380. X        &add_log("WARNING got nothing out of '$command'") if $loglvl > 5;
  381. X    }
  382. X    $lastcmd;            # Propage error status we got from the $command
  383. X}
  384. X
  385. X# Run the ONCE command
  386. Xsub run_once {
  387. X    local($_) = $cmd;                    # The whole command line
  388. X    local($hname);                        # Hash name (e-mail address)
  389. X    local($tag);                        # Tag associated with command
  390. X    local($raw_period);                    # The period, as written
  391. X    if (s/^ONCE\s*\(([^,\)]*),\s*([^,;\)]*),\s*(\w+)\s*\)//) {
  392. X        ($hname, $tag, $raw_period) = ($1, $2, $3);
  393. X        &add_log("tag is ($hname, $tag, $raw_period)") if $loglvl > 18;
  394. X    } else {
  395. X        &add_log("ERROR bad once syntax (invalid tag)") if $loglvl > 1;
  396. X        return 1;
  397. X    }
  398. X    s/^\s*//;                            # Remove leading spaces
  399. X    local($period) = &seconds_in_period($raw_period);
  400. X    &add_log("period is $raw_period = $period seconds") if $loglvl > 18;
  401. X
  402. X    # Calling run_command will set $lastcmd to the status of the command. In
  403. X    # case we are running a command which does not alter this status, assume
  404. X    # everything is fine.
  405. X    $lastcmd = 0;                        # Assume command will run correctly
  406. X
  407. X    if (&once_check($hname, $tag, $period)) {
  408. X        &add_log("ONCE ($hname, $tag, $raw_period) $_") if $loglvl > 7;
  409. X        &s_once($cmd_name, $wmode, $tag);
  410. X        s/%/%%/g;                        # Protect against 2nd macro substitution
  411. X        $cont = &run_command($_);        # Run it, update continuation status
  412. X    } else {
  413. X        &add_log("retry time not reached for $_") if $loglvl > 12;
  414. X        &s_noretry($cmd_name, $wmode, $tag);
  415. X    }
  416. X
  417. X    $lastcmd;                            # Propagates execution status
  418. X}
  419. X
  420. X# Run the SELECT command
  421. Xsub run_select {
  422. X    local($_) = $cmd;                    # The whole command line
  423. X    local($start, $end);                # Date strings for start and end
  424. X    if (s/^SELECT\s*\(([^.\)]*)\.\.\s*([^\)]*)\)//) {
  425. X        ($start, $end) = ($1, $2);
  426. X        $start =~ s/\s*$//;                # Remove trailing spaces
  427. X        $end =~ s/\s*$//;
  428. X        &add_log("time is ($start .. $end)") if $loglvl > 18;
  429. X    } else {
  430. X        &add_log("ERROR bad select syntax (invalid time)") if $loglvl > 1;
  431. X        return 1;
  432. X    }
  433. X    local($now) = time;                    # Current time
  434. X    local($sec_start, $sec_end);        # Start and end converted in seconds
  435. X    $sec_start = &getdate($start, $now);
  436. X    if ($sec_start == -1) {
  437. X        &add_log("ERROR in SELECT: 1st time '$start'") if $loglvl > 1;
  438. X        return 1;
  439. X    }
  440. X    $sec_end = &getdate($end, $now);
  441. X    if ($sec_end == -1) {
  442. X        &add_log("ERROR in SELECT: 2nd time '$end'") if $loglvl > 1;
  443. X        return 1;
  444. X    }
  445. X    if ($sec_start > $sec_end) {
  446. X        &add_log("WARNING time selection always impossible?") if $loglvl > 1;
  447. X        return 0;
  448. X    }
  449. X
  450. X    # Calling run_command will set $lastcmd to the status of the command. In
  451. X    # case we are running a command which does not alter this status, assume
  452. X    # everything is fine.
  453. X    $lastcmd = 0;                        # Assume command will run correctly
  454. X
  455. X    s/^\s*//;                            # Remove leading spaces
  456. X    if ($now >= $sec_start && $now <= $sec_end) {
  457. X        &add_log("SELECT ($start .. $end) $_") if $loglvl > 7;
  458. X        s/%/%%/g;                        # Protect against 2nd macro substitution
  459. X        $cont = &run_command($_);        # Run command and update control flow
  460. X    } else {
  461. X        &add_log("time period not good for $_") if $loglvl > 12;
  462. X    }
  463. X
  464. X    $lastcmd;                            # Propagates execution status
  465. X}
  466. X
  467. X# Run the NOP command
  468. Xsub run_nop {
  469. X    &add_log("NOP [$mfile]") if $loglvl > 7;
  470. X    0;
  471. X}
  472. X
  473. X# Run the STRIP command
  474. Xsub run_strip {
  475. X    local($headers) = $cmd =~ m|^\w+\s+(.*)|;    # Headers to remove
  476. X    &alter_header($headers, $HD_STRIP);
  477. X    $headers = join(', ', split(/\s/, $headers));
  478. X    &add_log("STRIPPED $headers from [$mfile]") if $loglvl > 7;
  479. X    0;
  480. X}
  481. X
  482. X# Run the KEEP command
  483. Xsub run_keep {
  484. X    local($headers) = $cmd =~ m|^\w+\s+(.*)|;    # Headers to keep
  485. X    &alter_header($headers, $HD_KEEP);
  486. X    $headers = join(', ', split(/\s/, $headers));
  487. X    &add_log("KEPT $headers from [$mfile]") if $loglvl > 7;
  488. X    0;
  489. X}
  490. X
  491. X# Run the ANNOTATE command
  492. Xsub run_annotate {
  493. X    local($date, $field, $value) = $cmd =~ m|^\w+\s+(-d\s+)?([\w\-]+):?\s*(.*)|;
  494. X    if (0 == &annotate_header($field, $value, $date)) {
  495. X        &add_log("ANNOTATED [$mfile] with $field") if $loglvl > 7;
  496. X    }
  497. X    0;
  498. X}
  499. X
  500. X# Run the ASSIGN command
  501. Xsub run_assign {
  502. X    local($var, $value) = $cmd =~ m|^\w+\s+(:?\w+)\s+(.*)|;
  503. X    local($eval);                        # Evaluated value for expression
  504. X    local($@);
  505. X    # An expression may be provided as a value. If the whole value is enclosed
  506. X    # within simple quotes, then those are stripped and no evaluation is made.
  507. X    unless ($value =~ s/^'(.*)'$/$1/) {
  508. X        eval "\$eval = $value";            # Maybe value is an expression?
  509. X    } else {
  510. X        $eval = $value;                    # Leading and trailing ' trimmed
  511. X    }
  512. X    $value = $eval if $eval && $@ eq '';
  513. X    if ($var =~ s/^://) {
  514. X        &extern'set($var, $value);        # Persistent variable is set
  515. X    } else {
  516. X        $Variable{$var} = $value;        # User defined variable is set
  517. X    }
  518. X    &add_log("ASSGINED '$value' to '$var' [$mfile]") if $loglvl > 7;
  519. X    0;
  520. X}
  521. X
  522. X# Run the TR command
  523. Xsub run_tr {
  524. X    local($variable, $tr) = $cmd =~ m|^\w+\s+(#?:?\w+)\s+(.*)|;
  525. X    &alter_value($variable, "tr$tr");
  526. X}
  527. X
  528. X# Run the SUBST command
  529. Xsub run_subst {
  530. X    local($variable, $s) = $cmd =~ m|^\w+\s+(#?:?\w+)\s+(.*)|;
  531. X    &alter_value($variable, "s$s");
  532. X}
  533. X
  534. X# Run the SPLIT command
  535. Xsub run_split {
  536. X    local($folder) = $cmd =~ m|^\w+\s+(.*)|;    # Folder where split occurs
  537. X    local($failed) = &split($folder);
  538. X    if (0 == $failed % 2) {            # Message was in digest format
  539. X        if ($failed & 0x4) {
  540. X            &add_log("SPLIT [$mfile] in mailagent's queue") if $loglvl > 2;
  541. X        } else {
  542. X            &add_log("SPLIT [$mfile] in $folder") if $loglvl > 2;
  543. X        }
  544. X        # If digest was not in RFC-934 style, there is a chance the split
  545. X        # was not correctly performed. To avoid any accidental loss of
  546. X        # information, the original digest message is also saved if SPLIT
  547. X        # had a folder argument, or it is not tagged saved.
  548. X        if ($failed & 0x8) {        # Digest was not RFC-934 compliant
  549. X            &add_log("NOTICE [$mfile] not RFC-934 compliant") if $loglvl > 6;
  550. X            if ($folder ne '') {
  551. X                &add_log("NOTICE saving original [$mfile] in $folder")
  552. X                    if $loglvl > 6;
  553. X                &save_message($folder);
  554. X            } else {
  555. X                &add_log("NOTICE [$mfile] not tagged as saved")
  556. X                    if $loglvl > 6 && ($failed & 0x2);
  557. X            }
  558. X        } else {
  559. X            $ever_saved = 1 if $failed & 0x2;    # Split -i succeeded
  560. X        }
  561. X        $failed = 0;
  562. X    }
  563. X    # If message was not in digest format and a folder was specified, save
  564. X    # message in that folder.
  565. X    if ($failed < 0 && $folder ne '') {
  566. X        &add_log("NOTICE [$mfile] not in digest format") if $loglvl > 6;
  567. X        $failed = &save_message($folder);
  568. X    }
  569. X    $failed ? 1 : 0;    # Failure status from split can be negative
  570. X}
  571. X
  572. X# Run the VACATION command
  573. Xsub run_vacation {
  574. X    return 0 unless $cf'vacation =~ /on/i;    # Ignore if vacation mode off
  575. X    local($mode) = $cmd =~ m|^\w+\s+(.*)|;    # Vacation mode
  576. X    $vacation = ($mode =~ /on/i) ? 1 : 0;
  577. X    $mode = $vacation ? 'on' : 'off';
  578. X    &add_log("vacation message turned $mode") if $loglvl > 7;
  579. X    0;
  580. X}
  581. X
  582. X# Run the QUEUE command
  583. Xsub run_queue {
  584. X    # Mail is saved as a 'qm' file, to avoid endless loops when mailagent
  585. X    # processes the queue. This means the mail will be deferred for at
  586. X    # least half an hour.
  587. X    local($failed) = &queue_mail('', 1);    # No file name, mail in %Header
  588. X    $ever_saved = 1 unless $failed;            # Queuing counts as saving
  589. X    $failed;
  590. X}
  591. X
  592. X# Run the PERL command
  593. Xsub run_perl {
  594. X    local($script) = $cmd =~ m|^\w+\s+(.*)|;    # Script to be loaded
  595. X    local($failed) = &perl($script);
  596. X    unless ($failed) {
  597. X        $script = &tilda($script);            # Replace the home directory by ~
  598. X        &add_log("PERLED [$mfile] through $script") if $loglvl > 7;
  599. X    }
  600. X    $failed;
  601. X}
  602. X
  603. X# Run the REQUIRE command
  604. Xsub run_require {
  605. X    local($file, $package) = $cmd =~ m|^\w+\s+(\S+)\s*(.*)|;
  606. X    local($failed) = &require($file, $package);
  607. X    unless ($failed) {
  608. X        $file = &tilda($file);        # Replace the home directory by ~
  609. X        local($inpack) = $file;        # Loaded in a package?
  610. X        $inpack .= " in package $package" if $package ne '';
  611. X        &add_log("REQUIRED [$mfile] $inpack") if $loglvl > 7;
  612. X    }
  613. X    $failed;
  614. X}
  615. X
  616. X# Run the APPLY command
  617. Xsub run_apply {
  618. X    local($rulefile) = $cmd =~ m|^\w+\s+(.*)|;    # Rule file to be applied
  619. X    local($failed, $saved) = &apply($rulefile);
  620. X    unless ($failed) {
  621. X        $rulefile = &tilda($rulefile);        # Replace the home directory by ~
  622. X        &add_log("APPLIED [$mfile] rules $rulefile") if $loglvl > 7;
  623. X    }
  624. X    $ever_saved = 1 if $saved;        # Mark mail as saved if appropriate
  625. X    $saved ? $failed : 1;            # Force failure if never saved
  626. X}
  627. X
  628. X# For SAVE, STORE or WRITE, the job is the same
  629. X# If the name is not an absolute path, the folder directory is taken
  630. X# in the "maildir" environment variable. If none, defaults to ~/Mail.
  631. X# A folder whose name begins with a '+' is taken as an MH folder.
  632. Xsub run_saving {
  633. X    local($folder, $remove) = @_;                # Shall we remove folder first?
  634. X    local($folddir) = $XENV{'maildir'};            # Folder directory location
  635. X    unless ($folder =~ /^\+/) {                    # Not an MH folder
  636. X        $folder = "~/mbox" unless $folder;        # No folder -> save in mbox
  637. X        $folder =~ s/~/$cf'home/g;                # ~ substitution
  638. X        $folddir =~ s/~/$cf'home/g;                # ~ substitution
  639. X        $folddir = "$cf'home/Mail" unless $folddir;    # Default folders in ~/Mail
  640. X        $folder = "$folddir/$folder" unless $folder =~ m|^/|;
  641. X        local($dir) = $folder =~ m|(.*)/.*|;    # Get directory name
  642. X        unless (-d "$dir") {
  643. X            &makedir($dir);
  644. X            unless (-d "$dir") {
  645. X                &add_log("ERROR couldn't create directory $dir")
  646. X                    if $loglvl > 0;
  647. X            } else {
  648. X                &add_log("created directory $dir") if $loglvl > 7;
  649. X            }
  650. X        }
  651. X    }
  652. X    # Cannot use WRITE with an MH folder, it behaves like a SAVE. Same thing
  653. X    # when attempting to save in a directory...
  654. X    if ($remove == $FOLDER_REMOVE && $folder !~ /^\+/) {
  655. X        # Folder has to be removed before writting into it. However, if it
  656. X        # is write protected, do not unlink it (save will fail later on anyway).
  657. X        # Note that this makes it a candidate for hooks via WRITE, if the
  658. X        # folder has its 'x' bit set with its 'w' bit cleared. This is an
  659. X        # undocumented feature however (WRITE is not supposed to trigger hooks).
  660. X        unlink "$folder" if -f "$folder" && -w _;
  661. X    }
  662. X    local($mbox, $failed) = &save($folder);
  663. X    local($log_message);                # Log message to be issued
  664. X    unless ($failed) {
  665. X        local($file) = $folder;            # Work on a copy to detect leading dir
  666. X        $file =~ s|^$folddir/||;        # Preceded by folder directory?
  667. X        if ($file =~ s/^\+//) {
  668. X            $log_message = "MH folder $file";
  669. X        } elsif ($file ne $folder) {
  670. X            $log_message = "folder $file";
  671. X        } else {
  672. X            $log_message = &tilda($folder);    # Replace the home directory by ~
  673. X        }
  674. X    }
  675. X
  676. X    # Return the status of the save command and a part of the logging message
  677. X    # to be issued. That way, we get a nice contextual log.
  678. X    ($mbox, $failed, $log_message);
  679. X}
  680. X
  681. X# Perform the appropriate continuation status, depending on the option:
  682. Xsub alter_execution {
  683. X    local($option) = shift(@_);        # The invocation option
  684. X    local($mode) = shift(@_);        # Mode we have to change to
  685. X    if ($mode ne '') {
  686. X        $wmode = $mode;
  687. X        &add_log("entering new state $wmode") if $loglvl > 6;
  688. X    }
  689. X    &add_log("altering execution in mode '$wmode', option '$option'")
  690. X        if $loglvl > 18;
  691. X    if ($option eq '-c') {        # Continue execution
  692. X        0;
  693. X    } elsif ($option eq '-r') {    # Asks for RESTART
  694. X        &do_restart;
  695. X    } elsif ($option eq '-a') {    # Asks for ABORT
  696. X        &do_abort;
  697. X    } else {                    # Default is to REJECT
  698. X        &do_reject;
  699. X    }
  700. X    # Propagate return status.
  701. X}
  702. X
  703. X# Save message in specified folder
  704. Xsub save_message {
  705. X    local($folder) = @_;
  706. X    local($mbox, $failed, $log_message) = &run_saving($folder, $FOLDER_APPEND);
  707. X    unless ($failed) {
  708. X        &add_log("SAVED [$mfile] in $log_message") if $loglvl > 2;
  709. X        $ever_saved = 1;            # We were able to save it
  710. X    }
  711. X    $failed;
  712. X}
  713. X
  714. END_OF_FILE
  715.   if test 22116 -ne `wc -c <'agent/pl/filter.pl'`; then
  716.     echo shar: \"'agent/pl/filter.pl'\" unpacked with wrong size!
  717.   fi
  718.   # end of 'agent/pl/filter.pl'
  719. fi
  720. if test -f 'agent/pl/getdate.pl' -a "${1}" != "-c" ; then 
  721.   echo shar: Will not clobber existing file \"'agent/pl/getdate.pl'\"
  722. else
  723.   echo shar: Extracting \"'agent/pl/getdate.pl'\" \(26821 characters\)
  724.   sed "s/^X//" >'agent/pl/getdate.pl' <<'END_OF_FILE'
  725. X;# From: rick@imd.sterling.com (Richard Ohnemus)
  726. X;# Newsgroups: comp.lang.perl
  727. X;# Subject: Re: Parsing a date/time string
  728. X;# Message-ID: <1992Jun26.133036.2077@sparky.imd.sterling.com>
  729. X;# Date: 26 Jun 92 13:30:36 GMT
  730. X;# References: <25116@life.ai.mit.edu>
  731. X;# Sender: news@sparky.imd.sterling.com (News Admin)
  732. X;# Organization: Sterling Software, IMD
  733. X;#
  734. X;# Here is the famous (or infamous) getdate routine adapted for use with
  735. X;# PERL. (This was a quick hack but, it is being used in a couple of
  736. X;# programs and no problems have shown up yet. 8-{)
  737. X;# 
  738. X;# Calling sequence:
  739. X;#   $seconds = &getdate($date_time_str, 
  740. X;#                       $time_in_seconds, 
  741. X;#                       $offset_from_GMT_in_minutes);
  742. X;# 
  743. X;# time_in_seconds and offset_from_GMT_in_minutes are optional arguments.
  744. X;# If time_in_seconds is not specified then the current time is used.
  745. X;# If offset_from_GMT_in_minutes is not specified then TZ is read from the
  746. X;# environment to get the offset.
  747. X;# 
  748. X;# Examples of use:
  749. X;#   require 'getdate.pl';
  750. X;#   seconds = &getdate('Apr 24 17:44');
  751. X;#   seconds = &getdate('2 Feb 1992 03:53:17');
  752. X;#   ... many more date/time formats supported ...
  753. X;#
  754. X;# getdate.pl was generated from getdate.y by a version of Berkeley Yacc
  755. X;# 1.8 that I modified to generate PERL output. (The patches are based on
  756. X;# Ray Lischner's patches to byacc 1.6.) If anyone would like a copy of
  757. X;# the patches I can e-mail them or make them available for anonymous FTP
  758. X;# if there is enough interest.
  759. X;#
  760. X;#
  761. X;# $yysccsid = "@(#)yaccpar    1.8 (Berkeley) 01/20/91 (Perl 2.0 04/23/92)";
  762. X;#     Steven M. Bellovin (unc!smb)
  763. X;#    Dept. of Computer Science
  764. X;#    University of North Carolina at Chapel Hill
  765. X;#    @(#)getdate.y    2.13    9/16/86
  766. X;#
  767. X;#    Richard J. Ohnemus (rick@IMD.Sterling.COM)
  768. X;#    (Where do I work??? I'm not even sure who I am! 8-{)
  769. X;#    converted to PERL 4/24/92
  770. X;#
  771. X;# Below are logging information for this package as included in the
  772. X;# mailagent program.
  773. X;#
  774. X;# $Id: getdate.pl,v 3.0 1993/11/29 13:48:48 ram Exp ram $
  775. X;#
  776. X;#  Copyright (c) 1990-1993, Raphael Manfredi
  777. X;#  
  778. X;#  You may redistribute only under the terms of the Artistic License,
  779. X;#  as specified in the README file that comes with the distribution.
  780. X;#  You may reuse parts of this distribution only within the terms of
  781. X;#  that same Artistic License; a copy of which may be found at the root
  782. X;#  of the source tree for mailagent 3.0.
  783. X;#
  784. X;# $Log: getdate.pl,v $
  785. X;# Revision 3.0  1993/11/29  13:48:48  ram
  786. X;# Baseline for mailagent 3.0 netwide release.
  787. X;#
  788. Xpackage getdate;
  789. X
  790. X# This package parses a date string and converts it into a number of seconds.
  791. X# I did minor editing on this code, mainly to remove all the YYDEBUG #if tests
  792. X# and to reformat some of the table. I also encapsulated all the initializations
  793. X# into init subroutines and reworked on the indentation of semantic actions.
  794. X# Oh yes, I also made some minor modifications in place (i.e. without running
  795. X# yacc again) to apply some small fixes Richard sent me via e-mail.
  796. X# Other than that, it's pretty verbatim--RAM.
  797. X
  798. Xsub yyinit {
  799. X    $daysec = 24 * 60 * 60;
  800. X
  801. X    $AM = 1;
  802. X    $PM = 2;
  803. X    $DAYLIGHT = 1;
  804. X    $STANDARD = 2;
  805. X    $MAYBE = 3;
  806. X
  807. X    $ID=257;
  808. X    $MONTH=258;
  809. X    $DAY=259;
  810. X    $MERIDIAN=260;
  811. X    $NUMBER=261;
  812. X    $UNIT=262;
  813. X    $MUNIT=263;
  814. X    $SUNIT=264;
  815. X    $ZONE=265;
  816. X    $DAYZONE=266;
  817. X    $AGO=267;
  818. X    $YYERRCODE=256;
  819. X    @yylhs = (                                               -1,
  820. X        0,    0,    1,    1,    1,    1,    1,    1,    7,    2,
  821. X        2,    2,    2,    2,    2,    2,    3,    3,    5,    5,
  822. X        5,    4,    4,    4,    4,    4,    4,    4,    4,    4,
  823. X        6,    6,    6,    6,    6,    6,    6,
  824. X    );
  825. X    @yylen = (                                                2,
  826. X        0,    2,    1,    1,    1,    1,    1,    1,    1,    2,
  827. X        3,    4,    4,    5,    6,    6,    1,    1,    1,    2,
  828. X        2,    3,    5,    2,    4,    5,    7,    3,    2,    3,
  829. X        2,    2,    2,    1,    1,    1,    2,
  830. X    );
  831. X    @yydefred = (                                             1,
  832. X        0,    0,    0,    0,   34,   35,   36,   17,   18,    2,
  833. X        3,    4,    5,    6,    0,    8,    0,   20,    0,   21,
  834. X       10,   31,   32,   33,    0,    0,   37,    0,    0,   30,
  835. X        0,    0,    0,   25,   12,   13,    0,    0,    0,    0,
  836. X       23,    0,   15,   16,   27,
  837. X    );
  838. X    @yydgoto = (                                              1,
  839. X       10,   11,   12,   13,   14,   15,   16,
  840. X    );
  841. X    @yysindex = (                                             0,
  842. X     -241, -255,  -37,  -47,    0,    0,    0,    0,    0,    0,
  843. X        0,    0,    0,    0, -259,    0,  -42,    0, -252,    0,
  844. X        0,    0,    0,    0, -249, -248,    0,  -44, -246,    0,
  845. X      -55,  -31, -235,    0,    0,    0, -234, -232,  -28, -256,
  846. X        0, -230,    0,    0,    0,
  847. X    );
  848. X    @yyrindex = (                                             0,
  849. X        0,    0,    1,   79,    0,    0,    0,    0,    0,    0,
  850. X        0,    0,    0,    0,   10,    0,   46,    0,   55,    0,
  851. X        0,    0,    0,    0,    0,    0,    0,   19,    0,    0,
  852. X       64,   28,    0,    0,    0,    0,    0,    0,   37,   73,
  853. X        0,    0,    0,    0,    0,
  854. X    );
  855. X    @yygindex = (                                             0,
  856. X        0,    0,    0,    0,    0,    0,    0,
  857. X    );
  858. X    $YYTABLESIZE=345;
  859. X    @yytable = (                                             26,
  860. X       19,   29,   37,   43,   44,   17,   18,   27,   30,    7,
  861. X       25,   31,   32,   33,   34,   38,    2,    3,   28,    4,
  862. X        5,    6,    7,    8,    9,   39,   40,   22,   41,   42,
  863. X       45,    0,    0,    0,    0,    0,   26,    0,    0,    0,
  864. X        0,    0,    0,    0,    0,   24,    0,    0,    0,    0,
  865. X        0,    0,    0,    0,   29,    0,    0,    0,    0,    0,
  866. X        0,    0,    0,   11,    0,    0,    0,    0,    0,    0,
  867. X        0,    0,   14,    0,    0,    0,    0,    0,    9,    0,
  868. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  869. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  870. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  871. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  872. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  873. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  874. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  875. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  876. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  877. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  878. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  879. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  880. X        0,    0,    0,    0,   35,   36,    0,    0,    0,    0,
  881. X       19,   20,   21,    0,   22,   23,   24,    0,   28,    0,
  882. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  883. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  884. X        0,    0,    0,    0,    0,    0,    0,    0,    0,    0,
  885. X        0,    0,    0,    0,    0,    0,    0,    0,   19,   19,
  886. X        0,   19,   19,   19,   19,   19,   19,    7,    7,    0,
  887. X        7,    7,    7,    7,    7,    7,   28,   28,    0,   28,
  888. X       28,   28,   28,   28,   28,   22,   22,    0,   22,   22,
  889. X       22,   22,   22,   22,   26,   26,    0,   26,   26,   26,
  890. X       26,   26,   26,   24,   24,    0,    0,   24,   24,   24,
  891. X       24,   24,   29,   29,    0,    0,   29,   29,   29,   29,
  892. X       29,   11,   11,    0,    0,   11,   11,   11,   11,   11,
  893. X       14,   14,    0,    0,   14,   14,   14,   14,   14,    9,
  894. X        0,    0,    0,    9,    9,
  895. X    );
  896. X    @yycheck = (                                             47,
  897. X        0,   44,   58,  260,  261,  261,   44,  267,  261,    0,
  898. X       58,  261,  261,   58,  261,   47,  258,  259,    0,  261,
  899. X      262,  263,  264,  265,  266,  261,  261,    0,  261,   58,
  900. X      261,   -1,   -1,   -1,   -1,   -1,    0,   -1,   -1,   -1,
  901. X       -1,   -1,   -1,   -1,   -1,    0,   -1,   -1,   -1,   -1,
  902. X       -1,   -1,   -1,   -1,    0,   -1,   -1,   -1,   -1,   -1,
  903. X       -1,   -1,   -1,    0,   -1,   -1,   -1,   -1,   -1,   -1,
  904. X       -1,   -1,    0,   -1,   -1,   -1,   -1,   -1,    0,   -1,
  905. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  906. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  907. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  908. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  909. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  910. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  911. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  912. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  913. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  914. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  915. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  916. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  917. X       -1,   -1,   -1,   -1,  260,  261,   -1,   -1,   -1,   -1,
  918. X      258,  259,  260,   -1,  262,  263,  264,   -1,  261,   -1,
  919. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  920. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  921. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,
  922. X       -1,   -1,   -1,   -1,   -1,   -1,   -1,   -1,  258,  259,
  923. X       -1,  261,  262,  263,  264,  265,  266,  258,  259,   -1,
  924. X      261,  262,  263,  264,  265,  266,  258,  259,   -1,  261,
  925. X      262,  263,  264,  265,  266,  258,  259,   -1,  261,  262,
  926. X      263,  264,  265,  266,  258,  259,   -1,  261,  262,  263,
  927. X      264,  265,  266,  258,  259,   -1,   -1,  262,  263,  264,
  928. X      265,  266,  258,  259,   -1,   -1,  262,  263,  264,  265,
  929. X      266,  258,  259,   -1,   -1,  262,  263,  264,  265,  266,
  930. X      258,  259,   -1,   -1,  262,  263,  264,  265,  266,  261,
  931. X       -1,   -1,   -1,  265,  266,
  932. X    );
  933. X    $YYFINAL=1;
  934. X    $YYSTACKSIZE = $YYSTACKSIZE || $YYMAXDEPTH || 500;
  935. X    $YYMAXDEPTH = $YYMAXDEPTH || $YYSTACKSIZE || 500;
  936. X    $yyss[$YYSTACKSIZE] = 0;
  937. X    $yyvs[$YYSTACKSIZE] = 0;
  938. X}
  939. X
  940. Xsub yyclearin { $yychar = -1; }
  941. Xsub yyerrok { $yyerrflag = 0; }
  942. Xsub YYERROR { ++$yynerrs; &yy_err_recover; }
  943. Xsub yy_err_recover {
  944. X  if ($yyerrflag < 3)
  945. X  {
  946. X    $yyerrflag = 3;
  947. X    while (1)
  948. X    {
  949. X      if (($yyn = $yysindex[$yyss[$yyssp]]) && 
  950. X          ($yyn += $YYERRCODE) >= 0 && 
  951. X          $yycheck[$yyn] == $YYERRCODE)
  952. X      {
  953. X        $yyss[++$yyssp] = $yystate = $yytable[$yyn];
  954. X        $yyvs[++$yyvsp] = $yylval;
  955. X        next yyloop;
  956. X      }
  957. X      else
  958. X      {
  959. X        return(1) if $yyssp <= 0;
  960. X        --$yyssp;
  961. X        --$yyvsp;
  962. X      }
  963. X    }
  964. X  }
  965. X  else
  966. X  {
  967. X    return (1) if $yychar == 0;
  968. X    $yychar = -1;
  969. X    next yyloop;
  970. X  }
  971. X0;
  972. X} # yy_err_recover
  973. X
  974. Xsub yyparse {
  975. X  $yynerrs = 0;
  976. X  $yyerrflag = 0;
  977. X  $yychar = (-1);
  978. X
  979. X  $yyssp = 0;
  980. X  $yyvsp = 0;
  981. X  $yyss[$yyssp] = $yystate = 0;
  982. X
  983. Xyyloop: while(1)
  984. X  {
  985. X    yyreduce: {
  986. X      last yyreduce if ($yyn = $yydefred[$yystate]);
  987. X      if ($yychar < 0)
  988. X      {
  989. X        if (($yychar = &yylex) < 0) { $yychar = 0; }
  990. X      }
  991. X      if (($yyn = $yysindex[$yystate]) && ($yyn += $yychar) >= 0 &&
  992. X              $yycheck[$yyn] == $yychar)
  993. X      {
  994. X        $yyss[++$yyssp] = $yystate = $yytable[$yyn];
  995. X        $yyvs[++$yyvsp] = $yylval;
  996. X        $yychar = (-1);
  997. X        --$yyerrflag if $yyerrflag > 0;
  998. X        next yyloop;
  999. X      }
  1000. X      if (($yyn = $yyrindex[$yystate]) && ($yyn += $yychar) >= 0 &&
  1001. X            $yycheck[$yyn] == $yychar)
  1002. X      {
  1003. X        $yyn = $yytable[$yyn];
  1004. X        last yyreduce;
  1005. X      }
  1006. X      if (! $yyerrflag) {
  1007. X        &yyerror('syntax error');
  1008. X        ++$yynerrs;
  1009. X      }
  1010. X      return(1) if &yy_err_recover;
  1011. X    } # yyreduce
  1012. X    $yym = $yylen[$yyn];
  1013. X    $yyval = $yyvs[$yyvsp+1-$yym];
  1014. X    switch:
  1015. X    {
  1016. X        if ($yyn == 3) {
  1017. X            $timeflag++;
  1018. X            last switch;
  1019. X        }
  1020. X        if ($yyn == 4) {
  1021. X            $zoneflag++;
  1022. X            last switch;
  1023. X        }
  1024. X        if ($yyn == 5) {
  1025. X            $dateflag++;
  1026. X            last switch;
  1027. X        }
  1028. X        if ($yyn == 6) {
  1029. X            $dayflag++;
  1030. X            last switch;
  1031. X        }
  1032. X        if ($yyn == 7) {
  1033. X            $relflag++;
  1034. X            last switch;
  1035. X        }
  1036. X        if ($yyn == 9) {
  1037. X            if ($timeflag && $dateflag && !$relflag) {
  1038. X                $year = $yyvs[$yyvsp-0];
  1039. X            }
  1040. X            else {
  1041. X                $timeflag++;
  1042. X                $hh = int($yyvs[$yyvsp-0] / 100);
  1043. X                $mm = $yyvs[$yyvsp-0] % 100;
  1044. X                $ss = 0;
  1045. X                $merid = 24;
  1046. X            }
  1047. X            last switch;
  1048. X        }
  1049. X        if ($yyn == 10) {
  1050. X            $hh = $yyvs[$yyvsp-1];
  1051. X            $mm = 0;
  1052. X            $ss = 0;
  1053. X            $merid = $yyvs[$yyvsp-0];
  1054. X            last switch;
  1055. X        }
  1056. X        if ($yyn == 11) {
  1057. X            $hh = $yyvs[$yyvsp-2];
  1058. X            $mm = $yyvs[$yyvsp-0];
  1059. X            $merid = 24;
  1060. X            last switch;
  1061. X        }
  1062. X        if ($yyn == 12) {
  1063. X            $hh = $yyvs[$yyvsp-3];
  1064. X            $mm = $yyvs[$yyvsp-1];
  1065. X            $merid = $yyvs[$yyvsp-0];
  1066. X            last switch;
  1067. X        }
  1068. X        if ($yyn == 13) {
  1069. X            $hh = $yyvs[$yyvsp-3];
  1070. X            $mm = $yyvs[$yyvsp-1];
  1071. X            $merid = 24;
  1072. X            $daylight = $STANDARD;
  1073. X            $ourzone = $yyvs[$yyvsp-0] % 100 + 60 * int($yyvs[$yyvsp-0] / 100);
  1074. X            last switch;
  1075. X        }
  1076. X        if ($yyn == 14) {
  1077. X            $hh = $yyvs[$yyvsp-4];
  1078. X            $mm = $yyvs[$yyvsp-2];
  1079. X            $ss = $yyvs[$yyvsp-0];
  1080. X            $merid = 24;
  1081. X            last switch;
  1082. X        }
  1083. X        if ($yyn == 15) {
  1084. X            $hh = $yyvs[$yyvsp-5];
  1085. X            $mm = $yyvs[$yyvsp-3];
  1086. X            $ss = $yyvs[$yyvsp-1];
  1087. X            $merid = $yyvs[$yyvsp-0];
  1088. X            last switch;
  1089. X        }
  1090. X        if ($yyn == 16) {
  1091. X            $hh = $yyvs[$yyvsp-5];
  1092. X            $mm = $yyvs[$yyvsp-3];
  1093. X            $ss = $yyvs[$yyvsp-1];
  1094. X            $merid = 24;
  1095. X            $daylight = $STANDARD;
  1096. X            $ourzone = $yyvs[$yyvsp-0] % 100 + 60 * int($yyvs[$yyvsp-0] / 100);
  1097. X            last switch;
  1098. X        }
  1099. X        if ($yyn == 17) {
  1100. X            $ourzone = $yyvs[$yyvsp-0];
  1101. X            $daylight = $STANDARD;
  1102. X            last switch;
  1103. X        }
  1104. X        if ($yyn == 18) {
  1105. X            $ourzone = $yyvs[$yyvsp-0];
  1106. X            $daylight = $DAYLIGHT;
  1107. X            last switch;
  1108. X        }
  1109. X        if ($yyn == 19) {
  1110. X            $dayord = 1;
  1111. X            $dayreq = $yyvs[$yyvsp-0];
  1112. X            last switch;
  1113. X        }
  1114. X        if ($yyn == 20) {
  1115. X            $dayord = 1;
  1116. X            $dayreq = $yyvs[$yyvsp-1];
  1117. X            last switch;
  1118. X        }
  1119. X        if ($yyn == 21) {
  1120. X            $dayord = $yyvs[$yyvsp-1];
  1121. X            $dayreq = $yyvs[$yyvsp-0];
  1122. X            last switch;
  1123. X        }
  1124. X        if ($yyn == 22) {
  1125. X            $month = $yyvs[$yyvsp-2];
  1126. X            $day = $yyvs[$yyvsp-0];
  1127. X            last switch;
  1128. X        }
  1129. X        if ($yyn == 23) {
  1130. X            #
  1131. X            # HACK ALERT!!!!
  1132. X            # The 1000 is a magic number to attempt to force
  1133. X            # use of 4 digit years if year/month/day can be
  1134. X            # parsed. This was only done for backwards
  1135. X            # compatibility in rh.
  1136. X            #
  1137. X            if ($yyvs[$yyvsp-4] > 1000) {
  1138. X                $year = $yyvs[$yyvsp-4];
  1139. X                $month = $yyvs[$yyvsp-2];
  1140. X                $day = $yyvs[$yyvsp-0];
  1141. X            }
  1142. X            else {
  1143. X                $month = $yyvs[$yyvsp-4];
  1144. X                $day = $yyvs[$yyvsp-2];
  1145. X                $year = $yyvs[$yyvsp-0];
  1146. X            }
  1147. X            last switch;
  1148. X        }
  1149. X        if ($yyn == 24) {
  1150. X            $month = $yyvs[$yyvsp-1];
  1151. X            $day = $yyvs[$yyvsp-0];
  1152. X            last switch;
  1153. X        }
  1154. X        if ($yyn == 25) {
  1155. X            $month = $yyvs[$yyvsp-3];
  1156. X            $day = $yyvs[$yyvsp-2];
  1157. X            $year = $yyvs[$yyvsp-0];
  1158. X            last switch;
  1159. X        }
  1160. X        if ($yyn == 26) {
  1161. X            $month = $yyvs[$yyvsp-4];
  1162. X            $day = $yyvs[$yyvsp-3];
  1163. X            $hh = $yyvs[$yyvsp-2];
  1164. X            $mm = $yyvs[$yyvsp-0];
  1165. X            $merid = 24;
  1166. X            $timeflag++;
  1167. X            last switch;
  1168. X        }
  1169. X        if ($yyn == 27) {
  1170. X            $month = $yyvs[$yyvsp-6];
  1171. X            $day = $yyvs[$yyvsp-5];
  1172. X            $hh = $yyvs[$yyvsp-4];
  1173. X            $mm = $yyvs[$yyvsp-2];
  1174. X            $ss = $yyvs[$yyvsp-0];
  1175. X            $merid = 24;
  1176. X            $timeflag++;
  1177. X            last switch;
  1178. X        }
  1179. X        if ($yyn == 28) {
  1180. X            $month = $yyvs[$yyvsp-2];
  1181. X            $day = $yyvs[$yyvsp-1];
  1182. X            $year = $yyvs[$yyvsp-0];
  1183. X            last switch;
  1184. X        }
  1185. X        if ($yyn == 29) {
  1186. X            $month = $yyvs[$yyvsp-0];
  1187. X            $day = $yyvs[$yyvsp-1];
  1188. X            last switch;
  1189. X        }
  1190. X        if ($yyn == 30) {
  1191. X            $month = $yyvs[$yyvsp-1];
  1192. X            $day = $yyvs[$yyvsp-2];
  1193. X            $year = $yyvs[$yyvsp-0];
  1194. X            last switch;
  1195. X        }
  1196. X        if ($yyn == 31) {
  1197. X            $relsec +=  60 * $yyvs[$yyvsp-1] * $yyvs[$yyvsp-0];
  1198. X            last switch;
  1199. X        }
  1200. X        if ($yyn == 32) {
  1201. X            $relmonth += $yyvs[$yyvsp-1] * $yyvs[$yyvsp-0];
  1202. X            last switch;
  1203. X        }
  1204. X        if ($yyn == 33) {
  1205. X            $relsec += $yyvs[$yyvsp-1];
  1206. X            last switch;
  1207. X        }
  1208. X        if ($yyn == 34) {
  1209. X            $relsec +=  60 * $yyvs[$yyvsp-0];
  1210. X            last switch;
  1211. X        }
  1212. X        if ($yyn == 35) {
  1213. X            $relmonth += $yyvs[$yyvsp-0];
  1214. X            last switch;
  1215. X        }
  1216. X        if ($yyn == 36) {
  1217. X            $relsec++;
  1218. X            last switch;
  1219. X        }
  1220. X        if ($yyn == 37) {
  1221. X            $relsec = -$relsec;
  1222. X            $relmonth = -$relmonth;
  1223. X            last switch;
  1224. X        }
  1225. X    } # switch
  1226. X    $yyssp -= $yym;
  1227. X    $yystate = $yyss[$yyssp];
  1228. X    $yyvsp -= $yym;
  1229. X    $yym = $yylhs[$yyn];
  1230. X    if ($yystate == 0 && $yym == 0) {
  1231. X      $yystate = $YYFINAL;
  1232. X      $yyss[++$yyssp] = $YYFINAL;
  1233. X      $yyvs[++$yyvsp] = $yyval;
  1234. X      if ($yychar < 0) {
  1235. X        if (($yychar = &yylex) < 0) { $yychar = 0; }
  1236. X      }
  1237. X      return(0) if $yychar == 0;
  1238. X      next yyloop;
  1239. X    }
  1240. X    if (($yyn = $yygindex[$yym]) && ($yyn += $yystate) >= 0 &&
  1241. X        $yyn <= $#yycheck && $yycheck[$yyn] == $yystate)
  1242. X    {
  1243. X        $yystate = $yytable[$yyn];
  1244. X    } else {
  1245. X        $yystate = $yydgoto[$yym];
  1246. X    }
  1247. X    $yyss[++$yyssp] = $yystate;
  1248. X    $yyvs[++$yyvsp] = $yyval;
  1249. X  } # yyloop
  1250. X} # yyparse
  1251. X
  1252. Xsub dateconv {
  1253. X    local($mm, $dd, $yy, $h, $m, $s, $mer, $zone, $dayflag) = @_;
  1254. X    local($time_of_day, $jdate);
  1255. X    local($i);
  1256. X
  1257. X    if ($yy < 0) {
  1258. X        $yy = -$yy;
  1259. X    }
  1260. X    if ($yy < 100) {
  1261. X        $yy += 1900;
  1262. X    }
  1263. X    $mdays[1] =
  1264. X        28 + (($yy % 4) == 0 && (($yy % 100) != 0 || ($yy % 400) == 0));
  1265. X    if ($yy < $epoch || $yy > 2001 || $mm < 1 || $mm > 12
  1266. X        || $dd < 1 || $dd > $mdays[--$mm]) {
  1267. X        return -1;
  1268. X    }
  1269. X    $jdate = $dd - 1;
  1270. X    for ($i = 0; $i < $mm; $i++) {
  1271. X        $jdate += $mdays[$i];
  1272. X    }
  1273. X    for ($i = $epoch; $i < $yy; $i++) {
  1274. X        $jdate += 365 + (($i % 4) == 0);
  1275. X    }
  1276. X    $jdate *= $daysec;
  1277. X    $jdate += $zone * 60;
  1278. X    if (($time_of_day = &timeconv($h, $m, $s, $mer)) < 0) {
  1279. X        return -1;
  1280. X    }
  1281. X    $jdate += $time_of_day;
  1282. X    if ($dayflag == $DAYLIGHT
  1283. X        || ($dayflag == $MAYBE && (localtime($jdate))[8])) {
  1284. X        $jdate -= 60 * 60;
  1285. X    }
  1286. X    return $jdate;
  1287. X}
  1288. X
  1289. Xsub dayconv {
  1290. X    local($ordday, $day, $now) = @_;
  1291. X    local(@loctime);
  1292. X    local($time_of_day);
  1293. X
  1294. X    $time_of_day = $now;
  1295. X    @loctime = localtime($time_of_day);
  1296. X    $time_of_day += $daysec * (($day - $loctime[6] + 7) % 7);
  1297. X    $time_of_day += 7 * $daysec * ($ordday <= 0 ? $ordday : $ordday - 1);
  1298. X    return &daylcorr($time_of_day, $now);
  1299. X}
  1300. X
  1301. Xsub timeconv {
  1302. X    local($hh, $mm, $ss, $mer) = @_;
  1303. X
  1304. X    return -1 if ($mm < 0 || $mm > 59 || $ss < 0 || $ss > 59);
  1305. X
  1306. X    if ($mer == $AM) {
  1307. X        return -1 if ($hh < 1 || $hh > 12);
  1308. X        return 60 * (($hh % 12) * 60 + $mm) + $ss;
  1309. X    }
  1310. X    if ($mer == $PM) {
  1311. X        return -1 if ($hh < 1 || $hh > 12);
  1312. X        return 60 * (($hh % 12 + 12) * 60 + $mm) + $ss;
  1313. X    }
  1314. X    if ($mer == 24) {
  1315. X        return -1 if ($hh < 0 || $hh > 23);
  1316. X        return 60 * ($hh * 60 + $mm) + $ss;
  1317. X    }
  1318. X    return -1;
  1319. X}
  1320. X
  1321. Xsub monthadd {
  1322. X    local($sdate, $relmonth) = @_;
  1323. X    local(@ltime);
  1324. X    local($mm, $yy);
  1325. X    
  1326. X    return 0 if ($relmonth == 0);
  1327. X
  1328. X    @ltime = localtime($sdate);
  1329. X    $mm = 12 * $ltime[5] + $ltime[4] + $relmonth;
  1330. X    $yy = int($mm / 12);
  1331. X    $mm = $mm % 12 + 1;
  1332. X    return &daylcorr(&dateconv($mm, $ltime[3], $yy, $ltime[2],
  1333. X                               $ltime[1], $ltime[0], 24, $ourzone, $MAYBE),
  1334. X                     $sdate);
  1335. X}
  1336. X
  1337. Xsub daylcorr {
  1338. X    local($future, $now) = @_;
  1339. X    local($fdayl, $nowdayl);
  1340. X
  1341. X    $nowdayl = ((localtime($now))[2] + 1) % 24;
  1342. X    $fdayl = ((localtime($future))[2] + 1) % 24;
  1343. X    return ($future - $now) + 60 * 60 * ($nowdayl - $fdayl);
  1344. X}
  1345. X
  1346. Xsub yylex {
  1347. X    local($pcnt, $sign);
  1348. X
  1349. X    while (1) {
  1350. X        $dtstr =~ s/^\s*//;
  1351. X        
  1352. X        if ($dtstr =~ /^([-+])/) {
  1353. X            $sign = ($1 eq '-') ? -1 : 1;
  1354. X            $dtstr =~ s/^.\s*//;
  1355. X            if ($dtstr =~ /^(\d+)/) {
  1356. X                $yylval = eval "$1 * $sign";
  1357. X                $dtstr =~ s/^\d+//;
  1358. X                return $NUMBER;
  1359. X            }
  1360. X            else {
  1361. X                return &yylex;
  1362. X            }
  1363. X        }
  1364. X        elsif ($dtstr =~ /^(\d+)/) {
  1365. X            $yylval = eval "$1";
  1366. X            $dtstr =~ s/^\d+//;
  1367. X            return $NUMBER;
  1368. X        }
  1369. X        elsif ($dtstr =~ /^([a-zA-z][a-zA-Z.]*)/) {
  1370. X            $dtstr = substr($dtstr, length($1));
  1371. X            return &lookup($1);
  1372. X        }
  1373. X        elsif ($dtstr =~ /^\(/) {
  1374. X            $pcnt = 0;
  1375. X            do {
  1376. X                $dtstr = s/^(.)//;
  1377. X                return 0 if !defined($1);
  1378. X                $pcnt++ if ($1 eq '(');
  1379. X                $pcnt-- if ($1 eq ')');
  1380. X            } while ($pcnt > 0);
  1381. X        }
  1382. X        else {
  1383. X            $yylval = ord(substr($dtstr, 0, 1));
  1384. X            $dtstr =~ s/^.//;
  1385. X            return $yylval;
  1386. X        }
  1387. X    }
  1388. X}
  1389. X        
  1390. Xsub lookup_init {
  1391. X    %mdtab = (
  1392. X        "January",        "$MONTH,1",
  1393. X        "February",        "$MONTH,2",
  1394. X        "March",        "$MONTH,3",
  1395. X        "April",        "$MONTH,4",
  1396. X        "May",            "$MONTH,5",
  1397. X        "June",            "$MONTH,6",
  1398. X        "July",            "$MONTH,7",
  1399. X        "August",        "$MONTH,8",
  1400. X        "September",    "$MONTH,9",
  1401. X        "Sept",            "$MONTH,9",
  1402. X        "October",        "$MONTH,10",
  1403. X        "November",        "$MONTH,11",
  1404. X        "December",        "$MONTH,12",
  1405. X
  1406. X        "Sunday",        "$DAY,0",
  1407. X        "Monday",        "$DAY,1",
  1408. X        "Tuesday",        "$DAY,2",
  1409. X        "Tues",            "$DAY,2",
  1410. X        "Wednesday",    "$DAY,3",
  1411. X        "Wednes",        "$DAY,3",
  1412. X        "Thursday",        "$DAY,4",
  1413. X        "Thur",            "$DAY,4",
  1414. X        "Thurs",        "$DAY,4",
  1415. X        "Friday",        "$DAY,5",
  1416. X        "Saturday",        "$DAY,6"
  1417. X    );
  1418. X
  1419. X    $HRS='*60';
  1420. X    $HALFHR='30';
  1421. X
  1422. X    %mztab = (
  1423. X        "a.m.",        "$MERIDIAN,$AM",
  1424. X        "am",        "$MERIDIAN,$AM",
  1425. X        "p.m.",        "$MERIDIAN,$PM",
  1426. X        "pm",        "$MERIDIAN,$PM",
  1427. X        "nst",        "$ZONE,3 $HRS + $HALFHR",        # Newfoundland
  1428. X        "n.s.t.",    "$ZONE,3 $HRS + $HALFHR",
  1429. X        "ast",        "$ZONE,4 $HRS",            # Atlantic
  1430. X        "a.s.t.",    "$ZONE,4 $HRS",
  1431. X        "adt",        "$DAYZONE,4 $HRS",
  1432. X        "a.d.t.",    "$DAYZONE,4 $HRS",
  1433. X        "est",        "$ZONE,5 $HRS",            # Eastern
  1434. X        "e.s.t.",    "$ZONE,5 $HRS",
  1435. X        "edt",        "$DAYZONE,5 $HRS",
  1436. X        "e.d.t.",    "$DAYZONE,5 $HRS",
  1437. X        "cst",        "$ZONE,6 $HRS",            # Central
  1438. X        "c.s.t.",    "$ZONE,6 $HRS",
  1439. X        "cdt",        "$DAYZONE,6 $HRS",
  1440. X        "c.d.t.",    "$DAYZONE,6 $HRS",
  1441. X        "mst",        "$ZONE,7 $HRS",            # Mountain
  1442. X        "m.s.t.",    "$ZONE,7 $HRS",
  1443. X        "mdt",        "$DAYZONE,7 $HRS",
  1444. X        "m.d.t.",    "$DAYZONE,7 $HRS",
  1445. X        "pst",        "$ZONE,8 $HRS",            # Pacific
  1446. X        "p.s.t.",    "$ZONE,8 $HRS",
  1447. X        "pdt",        "$DAYZONE,8 $HRS",
  1448. X        "p.d.t.",    "$DAYZONE,8 $HRS",
  1449. X        "yst",        "$ZONE,9 $HRS",            # Yukon
  1450. X        "y.s.t.",    "$ZONE,9 $HRS",
  1451. X        "ydt",        "$DAYZONE,9 $HRS",
  1452. X        "y.d.t.",    "$DAYZONE,9 $HRS",
  1453. X        "hst",        "$ZONE,10 $HRS",        # Hawaii
  1454. X        "h.s.t.",    "$ZONE,10 $HRS",
  1455. X        "hdt",        "$DAYZONE,10 $HRS",
  1456. X        "h.d.t.",    "$DAYZONE,10 $HRS",
  1457. X
  1458. X        "gmt",        "$ZONE,0 $HRS",
  1459. X        "g.m.t.",    "$ZONE,0 $HRS",
  1460. X        "bst",        "$DAYZONE,0 $HRS",        # British Summer Time
  1461. X        "b.s.t.",    "$DAYZONE,0 $HRS",
  1462. X        "eet",        "$ZONE,-2 $HRS",        # European Eastern Time
  1463. X        "e.e.t.",    "$ZONE,-2 $HRS",
  1464. X        "eest",        "$DAYZONE,-2 $HRS",        # European Eastern Summer Time
  1465. X        "e.e.s.t.",    "$DAYZONE,-2 $HRS",
  1466. X        "met",        "$ZONE,-1 $HRS",        # Middle European Time
  1467. X        "m.e.t.",    "$ZONE,-1 $HRS",
  1468. X        "mest",        "$DAYZONE,-1 $HRS",        # Middle European Summer Time
  1469. X        "m.e.s.t.",    "$DAYZONE,-1 $HRS",
  1470. X        "wet",        "$ZONE,0 $HRS ",        # Western European Time
  1471. X        "w.e.t.",    "$ZONE,0 $HRS ",
  1472. X        "west",        "$DAYZONE,0 $HRS",        # Western European Summer Time
  1473. X        "w.e.s.t.",    "$DAYZONE,0 $HRS",
  1474. X
  1475. X        "jst",        "$ZONE,-9 $HRS",        # Japan Standard Time
  1476. X        "j.s.t.",    "$ZONE,-9 $HRS",        # Japan Standard Time
  1477. X
  1478. X        "aest",        "$ZONE,-10 $HRS",        # Australian Eastern Time
  1479. X        "a.e.s.t.",    "$ZONE,-10 $HRS",
  1480. X        "aesst",    "$DAYZONE,-10 $HRS",    # Australian Eastern Summer Time
  1481. X        "a.e.s.s.t.",    "$DAYZONE,-10 $HRS",
  1482. X        "acst",            "$ZONE,-(9 $HRS + $HALFHR)",    # Austr. Central Time
  1483. X        "a.c.s.t.",        "$ZONE,-(9 $HRS + $HALFHR)",
  1484. X        "acsst",        "$DAYZONE,-(9 $HRS + $HALFHR)",    # Austr. Central Summer
  1485. X        "a.c.s.s.t.",    "$DAYZONE,-(9 $HRS + $HALFHR)",
  1486. X        "awst",            "$ZONE,-8 $HRS",    # Australian Western Time
  1487. X        "a.w.s.t.",        "$ZONE,-8 $HRS"        # (no daylight time there)
  1488. X    );
  1489. X
  1490. X    %unittab = (
  1491. X        "year",        "$MUNIT,12",
  1492. X        "month",    "$MUNIT,1",
  1493. X        "fortnight","$UNIT,14*24*60",
  1494. X        "week",        "$UNIT,7*24*60",
  1495. X        "day",        "$UNIT,1*24*60",
  1496. X        "hour",        "$UNIT,60",
  1497. X        "minute",    "$UNIT,1",
  1498. X        "min",        "$UNIT,1",
  1499. X        "second",    "$SUNIT,1",
  1500. X        "sec",        "$SUNIT,1"
  1501. X        );
  1502. X
  1503. X    %othertab = (
  1504. X        "tomorrow",    "$UNIT,1*24*60",
  1505. X        "yesterday","$UNIT,-1*24*60",
  1506. X        "today",    "$UNIT,0",
  1507. X        "now",        "$UNIT,0",
  1508. X        "last",        "$NUMBER,-1",
  1509. X        "this",        "$UNIT,0",
  1510. X        "next",        "$NUMBER,2",
  1511. X        "first",    "$NUMBER,1",
  1512. X        # "second",    "$NUMBER,2",
  1513. X        "third",    "$NUMBER,3",
  1514. X        "fourth",    "$NUMBER,4",
  1515. X        "fifth",    "$NUMBER,5",
  1516. X        "sixth",    "$NUMBER,6",
  1517. X        "seventh",    "$NUMBER,7",
  1518. X        "eigth",    "$NUMBER,8",
  1519. X        "ninth",    "$NUMBER,9",
  1520. X        "tenth",    "$NUMBER,10",
  1521. X        "eleventh",    "$NUMBER,11",
  1522. X        "twelfth",    "$NUMBER,12",
  1523. X        "ago",        "$AGO,1"
  1524. X    );
  1525. X
  1526. X    %milzone = (
  1527. X        "a",        "$ZONE,1 $HRS",
  1528. X        "b",        "$ZONE,2 $HRS",
  1529. X        "c",        "$ZONE,3 $HRS",
  1530. X        "d",        "$ZONE,4 $HRS",
  1531. X        "e",        "$ZONE,5 $HRS",
  1532. X        "f",        "$ZONE,6 $HRS",
  1533. X        "g",        "$ZONE,7 $HRS",
  1534. X        "h",        "$ZONE,8 $HRS",
  1535. X        "i",        "$ZONE,9 $HRS",
  1536. X        "k",        "$ZONE,10 $HRS",
  1537. X        "l",        "$ZONE,11 $HRS",
  1538. X        "m",        "$ZONE,12 $HRS",
  1539. X        "n",        "$ZONE,-1 $HRS",
  1540. X        "o",        "$ZONE,-2 $HRS",
  1541. X        "p",        "$ZONE,-3 $HRS",
  1542. X        "q",        "$ZONE,-4 $HRS",
  1543. X        "r",        "$ZONE,-5 $HRS",
  1544. X        "s",        "$ZONE,-6 $HRS",
  1545. X        "t",        "$ZONE,-7 $HRS",
  1546. X        "u",        "$ZONE,-8 $HRS",
  1547. X        "v",        "$ZONE,-9 $HRS",
  1548. X        "w",        "$ZONE,-10 $HRS",
  1549. X        "x",        "$ZONE,-11 $HRS",
  1550. X        "y",        "$ZONE,-12 $HRS",
  1551. X        "z",        "$ZONE,0 $HRS"
  1552. X    );
  1553. X
  1554. X    @mdays = (31, 0, 31,  30, 31, 30,  31, 31, 30,  31, 30, 31);
  1555. X    $epoch = 1970;
  1556. X}
  1557. X
  1558. Xsub lookup {
  1559. X    local($id) = @_;
  1560. X    local($abbrev, $idvar, $key, $token);
  1561. X
  1562. X    $idvar = $id;
  1563. X    if (length($idvar) == 3) {
  1564. X        $abbrev = 1;
  1565. X    }
  1566. X    elsif (length($idvar) == 4 && substr($idvar, 3, 1) eq '.') {
  1567. X        $abbrev = 1;
  1568. X        $idvar = substr($idvar, 0, 3);
  1569. X    }
  1570. X    else {
  1571. X        $abbrev = 0;
  1572. X    }
  1573. X
  1574. X    substr($idvar, 0, 1) =~ tr/a-z/A-Z/;
  1575. X    if (defined($mdtab{$idvar})) {
  1576. X        ($token, $yylval) = split(/,/,$mdtab{$idvar});
  1577. X        $yylval = eval "$yylval";
  1578. X        return $token;
  1579. X    }
  1580. X    foreach $key (keys %mdtab) {
  1581. X        if ($idvar eq substr($key, 0, 3)) {
  1582. X            ($token, $yylval) = split(/,/,$mdtab{$key});
  1583. X            $yylval = eval "$yylval";
  1584. X            return $token;
  1585. X        }
  1586. X    }
  1587. X    
  1588. X    $idvar = $id;
  1589. X    if (defined($mztab{$idvar})) {
  1590. X        ($token, $yylval) = split(/,/,$mztab{$idvar});
  1591. X        $yylval = eval "$yylval";
  1592. X        return $token;
  1593. X    }
  1594. X    
  1595. X    $idvar =~ tr/A-Z/a-z/;
  1596. X    if (defined($mztab{$idvar})) {
  1597. X        ($token, $yylval) = split(/,/,$mztab{$idvar});
  1598. X        $yylval = eval "$yylval";
  1599. X        return $token;
  1600. X    }
  1601. X    
  1602. X    $idvar = $id;
  1603. X    if (defined($unittab{$idvar})) {
  1604. X        ($token, $yylval) = split(/,/,$unittab{$idvar});
  1605. X        $yylval = eval "$yylval";
  1606. X        return $token;
  1607. X    }
  1608. X    
  1609. X    if ($idvar =~ /s$/) {
  1610. X        $idvar =~ s/s$//;
  1611. X    }
  1612. X    if (defined($unittab{$idvar})) {
  1613. X        ($token, $yylval) = split(/,/,$unittab{$idvar});
  1614. X        $yylval = eval "$yylval";
  1615. X        return $token;
  1616. X    }
  1617. X    
  1618. X    $idvar = $id;
  1619. X    if (defined($othertab{$idvar})) {
  1620. X        ($token, $yylval) = split(/,/,$othertab{$idvar});
  1621. X        $yylval = eval "$yylval";
  1622. X        return $token;
  1623. X    }
  1624. X    
  1625. X    if (length($idvar) == 1 && $idvar =~ /[a-zA-Z]/) {
  1626. X        $idvar =~ tr/A-Z/a-z/;
  1627. X        if (defined($milzone{$idvar})) {
  1628. X            ($token, $yylval) = split(/,/,$milzone{$idvar});
  1629. X            $yylval = eval "$yylval";
  1630. X            return $token;
  1631. X        }
  1632. X    }
  1633. X    
  1634. X    return $ID;
  1635. X}
  1636. X
  1637. Xsub main'getdate {
  1638. X    ($dtstr, $now, $timezone) = @_;
  1639. X    local($now, $timezone);
  1640. X    local(@lt);
  1641. X    local($sdate);
  1642. X    local($TZ);
  1643. X
  1644. X    &yyinit;
  1645. X    &lookup_init;
  1646. X    $odtstr = $dtstr;        # Save it for error report--RAM
  1647. X
  1648. X    if (!$now) {
  1649. X        $now = time;
  1650. X    }
  1651. X
  1652. X    if (!$timezone) {
  1653. X        $TZ = defined($ENV{'TZ'}) ? ($ENV{'TZ'} ? $ENV{'TZ'} : '') : '';
  1654. X        if( $TZ =~
  1655. X           /^([^:\d+\-,]{3,})([+-]?\d{1,2}(:\d{1,2}){0,2})([^\d+\-,]{3,})?/) {
  1656. X            $timezone = $2 * 60;
  1657. X        }
  1658. X        else {
  1659. X            $timezone = 0;
  1660. X        }
  1661. X    }
  1662. X
  1663. X    @lt = localtime($now);
  1664. X    $year = 0;
  1665. X    $month = $lt[4] + 1;
  1666. X    $day = $lt[3];
  1667. X    $relsec = $relmonth = 0;
  1668. X    $timeflag = $zoneflag = $dateflag = $dayflag = $relflag = 0;
  1669. X    $daylight = $MAYBE;
  1670. X    $hh = $mm = $ss = 0;
  1671. X    $merid = 24;
  1672. X    
  1673. X    $dtstr =~ tr/A-Z/a-z/;
  1674. X    return -1 if &yyparse;
  1675. X    return -1 if $timeflag > 1 || $zoneflag > 1 || $dateflag > 1 || $dayflag > 1;
  1676. X
  1677. X    if (!$year) {
  1678. X        $year = ($month > ($lt[4] + 1)) ? ($lt[5] - 1) : $lt[5];
  1679. X    }
  1680. X
  1681. X    if ($dateflag || $timeflag || $dayflag) {
  1682. X        $sdate = &dateconv($month, $day, $year, $hh, $mm, $ss,
  1683. X                           $merid, $timezone, $daylight);
  1684. X        if ($sdate < 0) {
  1685. X            return -1;
  1686. X        }
  1687. X    }
  1688. X    else {
  1689. X        $sdate = $now;
  1690. X        if ($relflag == 0) {
  1691. X            $sdate -= ($lt[0] + $lt[1] * 60 + $lt[2] * (60 * 60));
  1692. X        }
  1693. X    }
  1694. X    
  1695. X    $sdate += $relsec + &monthadd($sdate, $relmonth);
  1696. X    $sdate += &dayconv($dayord, $dayreq, $sdate) if ($dayflag && !$dateflag);
  1697. X    
  1698. X    return $sdate;
  1699. X}
  1700. X
  1701. X# Mark error within date string with a '^' cursor--RAM
  1702. Xsub yyerror {
  1703. X    local($parsed) = length($odstr) - length($dtstr);
  1704. X    substr($odtstr, $parsed) = '^' .  substr($odtstr, $parsed + 1);
  1705. X    &'add_log("syntax error in date: $odtstr") if $'loglvl > 5;
  1706. X}
  1707. X
  1708. Xpackage main;
  1709. X
  1710. END_OF_FILE
  1711.   if test 26821 -ne `wc -c <'agent/pl/getdate.pl'`; then
  1712.     echo shar: \"'agent/pl/getdate.pl'\" unpacked with wrong size!
  1713.   fi
  1714.   # end of 'agent/pl/getdate.pl'
  1715. fi
  1716. if test -f 'agent/test/basic/mailagent.t' -a "${1}" != "-c" ; then 
  1717.   echo shar: Will not clobber existing file \"'agent/test/basic/mailagent.t'\"
  1718. else
  1719.   echo shar: Extracting \"'agent/test/basic/mailagent.t'\" \(2692 characters\)
  1720.   sed "s/^X//" >'agent/test/basic/mailagent.t' <<'END_OF_FILE'
  1721. X# Basic mailagent test: ensure it is correctly invoked by filter.
  1722. X
  1723. X# $Id: mailagent.t,v 3.0 1993/11/29 13:49:25 ram Exp ram $
  1724. X#
  1725. X#  Copyright (c) 1990-1993, Raphael Manfredi
  1726. X#  
  1727. X#  You may redistribute only under the terms of the Artistic License,
  1728. X#  as specified in the README file that comes with the distribution.
  1729. X#  You may reuse parts of this distribution only within the terms of
  1730. X#  that same Artistic License; a copy of which may be found at the root
  1731. X#  of the source tree for mailagent 3.0.
  1732. X#
  1733. X# $Log: mailagent.t,v $
  1734. X# Revision 3.0  1993/11/29  13:49:25  ram
  1735. X# Baseline for mailagent 3.0 netwide release.
  1736. X#
  1737. X
  1738. Xdo '../pl/init.pl';
  1739. Xdo '../pl/logfile.pl';
  1740. X$user = $ENV{'USER'};
  1741. Xchdir '../out' || exit 0;
  1742. X# Make sure we'll find the mailagent
  1743. Xsystem 'perl', '-i', '-p', '-e', "s|^path.*|path     :.:$up|", '.mailagent';
  1744. X$? == 0 || print "1\n";
  1745. Xunlink '.cache';        # Make sure no cached rules yet
  1746. Xopen(RULES, ">.rules") || print "2\n";
  1747. Xprint RULES "{ DELETE };\n";
  1748. Xclose RULES;
  1749. Xunlink <queue/qm*>;
  1750. Xopen(FILTER, "|$filter -t >/dev/null 2>&1") || print "3\n";
  1751. Xprint FILTER <<EOF;
  1752. XFrom: test
  1753. X
  1754. XDummy body
  1755. XEOF
  1756. Xclose FILTER;
  1757. X$? == 0 || print "4\n";
  1758. X&get_log(5);
  1759. X&check_log('WARNING.*assuming', 6);        # No To: field
  1760. X&check_log('FILTERED', 7);                # Mail filtered
  1761. X&check_log('DELETED', 8);                # Mail deleted by only rule
  1762. X@files = <queue/qm*>;
  1763. X@files == 0 || print "9\n";                # Queued mail deleted when filtered
  1764. Xunlink 'agentlog', '.rules';
  1765. Xsleep 1 while -f 'perl.lock';            # Let background mailagent die
  1766. X# Check empty rules...
  1767. Xopen(FILTER, "|$filter -t >/dev/null 2>&1") || print "10\n";
  1768. Xprint FILTER <<EOF;
  1769. XFrom: test
  1770. X
  1771. XDummy body
  1772. XEOF
  1773. Xclose FILTER;
  1774. X$? == 0 || print "11\n";
  1775. X&get_log(12);
  1776. X&check_log('FILTERED', 13);                # Mail filtered
  1777. X&check_log('LEFT', 14);                    # Mail left in mbox
  1778. X&check_log('building default', 15);        # Used default rules
  1779. X-s "$user" || print "16\n";                # Maildrop is here, so is mbox
  1780. X@files = <queue/qm*>;
  1781. X@files == 0 || print "17\n";            # Queued mail deleted when filtered
  1782. X-f 'context' && print "18\n";            # Empty context must be deleted
  1783. Xunlink 'agentlog', "$user";
  1784. Xsleep 1 while -f 'perl.lock';            # Let background mailagent die
  1785. X# Make sure file is correctly queued when another mailagent is running
  1786. X`cp /dev/null perl.lock`;
  1787. X$? == 0 || print "19\n";
  1788. Xopen(FILTER, "|$filter -t >/dev/null 2>&1") || print "20\n";
  1789. Xprint FILTER <<EOF;
  1790. XDummy mail
  1791. XEOF
  1792. Xclose FILTER;
  1793. X$? == 0 || print "21\n";    # Must terminate correctly (queued)
  1794. X&get_log(22);
  1795. X&check_log('QUEUED', 23);    # Mail was queued
  1796. X$file = <queue/fm*>;
  1797. X-f "$file" || print "24\n";    # Must have been left in queue as a 'fm' file
  1798. X-s '.cache' || print "25\n";    # Rules are cached in ~/.cache
  1799. Xunlink "$file", 'agentlog', 'perl.lock';
  1800. Xprint "0\n";
  1801. END_OF_FILE
  1802.   if test 2692 -ne `wc -c <'agent/test/basic/mailagent.t'`; then
  1803.     echo shar: \"'agent/test/basic/mailagent.t'\" unpacked with wrong size!
  1804.   fi
  1805.   # end of 'agent/test/basic/mailagent.t'
  1806. fi
  1807. echo shar: End of archive 9 \(of 26\).
  1808. cp /dev/null ark9isdone
  1809. MISSING=""
  1810. 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
  1811.     if test ! -f ark${I}isdone ; then
  1812.     MISSING="${MISSING} ${I}"
  1813.     fi
  1814. done
  1815. if test "${MISSING}" = "" ; then
  1816.     echo You have unpacked all 26 archives.
  1817.     echo "Now run 'sh PACKNOTES', then read README and type Configure.'"
  1818.     rm -f ark[1-9]isdone ark[1-9][0-9]isdone
  1819. else
  1820.     echo You still must unpack the following archives:
  1821.     echo "        " ${MISSING}
  1822. fi
  1823. exit 0
  1824.  
  1825. exit 0 # Just in case...
  1826.