1;# $Id$
2;#
3;#  Copyright (c) 1990-2006, Raphael Manfredi
4;#
5;#  You may redistribute only under the terms of the Artistic License,
6;#  as specified in the README file that comes with the distribution.
7;#  You may reuse parts of this distribution only within the terms of
8;#  that same Artistic License; a copy of which may be found at the root
9;#  of the source tree for mailagent 3.0.
10;#
11;# $Log: filter.pl,v $
12;# Revision 3.0.1.11  2001/03/13 13:13:37  ram
13;# patch71: changed SUBST/TR parameter parsing to support header fields
14;#
15;# Revision 3.0.1.10  1998/03/31  15:22:19  ram
16;# patch59: when "vacfixed" is on, forbid any change of vacation message
17;# patch59: new ON command to process commands on certain days only
18;#
19;# Revision 3.0.1.9  1997/09/15  15:15:04  ram
20;# patch57: fixed ASSGINED -> ASSIGNED typo in log message
21;# patch57: implemented new -t and -f flags for BEGIN and NOP
22;# patch57: insert user e-mail address if no address for NOTIFY
23;#
24;# Revision 3.0.1.8  1996/12/24  14:51:51  ram
25;# patch45: added initial logging of the SELECT command
26;#
27;# Revision 3.0.1.7  1995/08/07  16:18:57  ram
28;# patch37: new BIFF command
29;#
30;# Revision 3.0.1.6  1995/01/25  15:20:39  ram
31;# patch27: new commands BEEP and PROTECT
32;#
33;# Revision 3.0.1.5  1995/01/03  18:10:04  ram
34;# patch24: commands now get a string with the command name chopped off
35;# patch24: modified &alter_execution to accomodate new option parsing
36;#
37;# Revision 3.0.1.4  1994/10/04  17:50:24  ram
38;# patch17: SERVER will now discard whole message on errors
39;#
40;# Revision 3.0.1.3  1994/09/22  14:20:43  ram
41;# patch12: propagated change to the &queue_mail interface
42;# patch12: added stubs for DO and AFTER commands
43;#
44;# Revision 3.0.1.2  1994/07/01  15:00:30  ram
45;# patch8: new UMASK command
46;#
47;# Revision 3.0.1.1  1994/01/26  09:31:43  ram
48;# patch5: added tags to UNIQUE and RECORD commands
49;#
50;# Revision 3.0  1993/11/29  13:48:46  ram
51;# Baseline for mailagent 3.0 netwide release.
52;#
53;#
54;# There are a number of variables which are used by the filter commands and
55;# which are in the dynamic scope when those functions are called. The calling
56;# tree being: analyze_mail -> xeqte -> run_command -> run_*, where '*' stands
57;# for the action we are currently executing.
58;#
59;# All the run_* commands are called from within an eval by run_command, so that
60;# any otherwise fatal error can be trapped and reported in the log file. This
61;# is only a precaution against possible typos or other unpredictable errors.
62;#
63;# The following variables are inherited from run_command:
64;#  $mfile is the name of the mail file processed
65;#  $cmd is the command to be run
66;#  $cms is the same as $cmd but with options and command name chopped off
67;#  $cmd_name is the command name (upper-cased)
68;#  $ever_saved which states whether a saving/discarding action occurred
69;#  $cont is the continuation status, modified by REJECT and friends
70;#  $vacation which is a boolean stating whether vacation messages are allowed
71;# The following variable is inherited from analyze_mail:
72;#  $lastcmd is the failure status of the last command (among those to be kept)
73;# The working mode is held in $wmode (comes from analyze_mail).
74;#
75;# All the commands return an exit status: 0 for ok, 1 for failure. This status
76;# is normally recorded in $lastcmd by run_command, unless the executed action
77;# belongs to the set of commands whose exit status is discarded (because they
78;# can never fail).
79;#
80#
81# Filter commands are run from here
82#
83
84# Run the PROCESS command
85sub run_process {
86	if (0 != &process) {
87		&add_log("ERROR while processing [$mfile]--queing it") if $loglvl;
88		&queue_mail($file_name, 'fm');
89		return 1;
90	}
91	&add_log("PROCESSED [$mfile]") if $loglvl > 8;
92	0;
93}
94
95# Run the SERVER command
96sub run_server {
97	&cmdenv'inituid;				# Initialize server session environment
98	&cmdserv'trusted if $opt'sw_t;	# Server runs in trusted mode
99	&cmdserv'disable($opt'sw_d) if $opt'sw_d;	# Disable commands for this run
100	local(@body) = split(/\n/, $Header{'Body'});
101	local($failed) = &cmdserv'process(*body);
102	unless ($failed) {
103		&add_log("SERVED [$mfile]") if $loglvl > 8;
104	} else {
105		&add_log("ERROR unable to serve [$mfile]--discarded") if $loglvl;
106	}
107	$failed;
108}
109
110# Run the LEAVE command
111sub run_leave {
112	local($mbox, $failed) = &leave;
113	unless ($failed) {
114		&add_log("LEFT [$mfile] in mailbox") if $loglvl > 2;
115	}
116	# Even if it failed, mark it as saved anyway, as the default action would
117	# be a saving in mailbox and there is little chance another attempt would
118	# succeed while this one failed.
119	$ever_saved = 1;		# At least we tried to save it
120	$failed;
121}
122
123# Run the SAVE command
124sub run_save {
125	local($folder) = @_;	# Folder where message should be saved
126	&save_message($folder);
127}
128
129# Run the STORE command
130sub run_store {
131	local($folder) = @_;	# Folder where message should be saved
132	local($mbox, $failed, $log_message) = &run_saving($folder, $FOLDER_APPEND);
133	unless ($failed) {
134		$ever_saved = 1;			# We were able to save it
135		($mbox, $failed) = &leave;
136		unless ($failed) {
137			&add_log("STORED [$mfile] in $log_message") if $loglvl > 2;
138		} else {
139			&add_log("WARNING only SAVED [$mfile] in $log_message")
140				if $loglvl > 1;
141			return 1;
142		}
143	} else {
144		($mbox, $failed) = &leave;
145		unless ($failed) {
146			$ever_saved = 1;			# We were able to save it
147			&add_log("WARNING only LEFT [$mfile] in mailbox")
148				if $loglvl > 1;
149		}
150	}
151	$failed;
152}
153
154# Run the WRITE command
155sub run_write {
156	local($folder) = @_;	# Folder where message should be saved
157	local($mbox, $failed, $log_message) = &run_saving($folder, $FOLDER_REMOVE);
158	unless ($failed) {
159		&add_log("WROTE [$mfile] in $log_message") if $loglvl > 2;
160		$ever_saved = 1;			# We were able to save it
161	}
162	$failed;
163}
164
165# Run the DELETE command
166sub run_delete {
167	&add_log("DELETED [$mfile]") if $loglvl > 2;
168	$ever_saved = 1;		# User chose to discard it, it counts as a save
169	0;
170}
171
172# Run the MACRO command
173sub run_macro {
174	local($args) = @_;		# Get command arguments
175	local($name, $action) = &macro($args);	# Perform the command
176	&add_log("MACRO [$mfile] $name $action") if $loglvl > 7;
177	0;	# Never fails
178}
179
180# Run the MESSAGE command
181sub run_message {
182	local($msg) = @_;		# Vacation message location
183	$msg =~ s/~/$cf'home/g;					# ~ substitution
184	local($failed) = &message($msg);
185	unless ($failed) {
186		$msg = &tilda($msg);				# Replace the home directory by ~
187		&add_log("MESSAGE $msg for [$mfile]") if $loglvl > 2;
188	}
189	$failed;
190}
191
192# Run the NOTIFY command
193sub run_notify {
194	local($args) = @_;
195	local(@args) = split(' ', $args);
196	local($msg) = shift(@args);				# First argument is message text
197	$msg =~ s/~/$cf'home/g;					# ~ substitution
198	local($address) = join(' ', @args);		# Address list
199	$address = $cf'email if $address eq '';	# No address, defaults to user
200	local($failed) = &notify($msg, $address);
201	unless ($failed) {
202		$msg = &tilda($msg);				# Replace the home directory by ~
203		&add_log("NOTIFIED $msg [$mfile] to $address") if $loglvl > 2;
204	}
205	$failed;
206}
207
208# Run the REJECT command
209sub run_reject {
210	local(*perform) = *do_reject;
211	&alter_flow;		# Change control flow by calling &perform
212}
213
214# Run the RESTART command
215sub run_restart {
216	local(*perform) = *do_restart;
217	&alter_flow;		# Change control flow by calling &perform
218}
219
220# Run the ABORT command
221sub run_abort {
222	local(*perform) = *do_abort;
223	&alter_flow;		# Change control flow by calling &perform
224}
225
226# Run the RESYNC command
227sub run_resync {
228	# Headers pertaining to body encoding could have changed.
229	&header_check_body_encoding;	# Check and recode if possible
230	&header_resync;					# Resynchronize the %Header array
231	&add_log("RESYNCED [$mfile]") if $loglvl > 4;
232	0;
233}
234
235# Run the BEGIN command
236sub run_begin {
237	local($newstate) = @_;		# New state wanted
238	return 0 if $opt'sw_t && $lastcmd;		# -t means change only if true
239	return 0 if $opt'sw_f && !$lastcmd;		# -f means change only if false
240	$newstate = 'INITIAL' unless $newstate;
241	$wmode = $newstate;			# $wmode comes from analyze_mail
242	&add_log("BEGUN [$mfile] state $newstate") if $loglvl > 4;
243	0;
244}
245
246# Run the RECORD command
247sub run_record {
248	local($mode) = @_;
249	local($tags);
250	$mode =~ s|^(\w*)\s*\(([^()]*)\).*|$1| && ($tags = $2);
251	local($failed) = 0;
252	if (&history_tag($tags)) {	# Message already seen
253		if ($mode eq '') {
254			&add_log("NOTICE entering seen mode")
255				if $loglvl > 5 && $wmode ne '_SEEN_';
256			# Enter special mode ($wmode from analyze_mail)
257			$wmode = '_SEEN_';
258		}
259		&alter_execution('x', $mode);
260		$failed = 1;			# Make sure it "fails"
261	}
262	local($tagmsg) = $tags ne '' ? " ($tags)" : '';
263	&add_log("RECORDED [$mfile]" . $tagmsg) if $loglvl > 4;
264	$failed;
265}
266
267# Run the UNIQUE command
268sub run_unique {
269	local($mode) = @_;
270	local($tags);
271	$mode =~ s|^(\w*)\s*\(([^()]*)\).*|$1| && ($tags = $2);
272	local($failed) = 0;
273	if (&history_tag($tags)) {	# Message already seen
274		&add_log("NOTICE message tagged as saved") if $loglvl > 5;
275		$ever_saved = 1;		# In effect, runs a DELETE
276		&alter_execution('x', $mode);
277		$failed = 1;			# Make sure it "fails"
278	}
279	local($tagmsg) = $tags ne '' ? " ($tags)" : '';
280	&add_log("UNIQUE [$mfile]" . $tagmsg) if $loglvl > 4;
281	$failed;
282}
283
284# Run the FORWARD command
285sub run_forward {
286	local($addresses) = @_;		# Address(es)
287	local($failed) = &forward($addresses);
288	unless ($failed) {
289		&add_log("FORWARDED [$mfile] to $addresses") if $loglvl > 2;
290		$ever_saved = 1;		# Forwarding succeeded, counts as a save
291	}
292	$failed;
293}
294
295# Run the BOUNCE command
296sub run_bounce {
297	local($addresses) = @_;		# Address(es)
298	local($failed) = &bounce($addresses);
299	unless ($failed) {
300		&add_log("BOUNCED [$mfile] to $addresses") if $loglvl > 2;
301		$ever_saved = 1;		# Bouncing succeeded, counts as a save
302	}
303	$failed;
304}
305
306# Run the POST command
307sub run_post {
308	local($newsgroups) = @_;	# Newsgroup(s)
309	local($failed) = &post($newsgroups);
310	unless ($failed) {
311		&add_log("POSTED [$mfile] to $newsgroups") if $loglvl > 2;
312		$ever_saved = 1;		# Posting succeeded, counts as a save
313	}
314	$failed;
315}
316
317# Run the RUN command
318sub run_run {
319	local($program) = @_;		# Program to run
320	local($failed) = &shell_command($program, $NO_INPUT, $NO_FEEDBACK);
321	unless ($failed) {
322		&add_log("RAN '$program' for [$mfile]") if $loglvl > 4;
323	}
324	$failed;
325}
326
327# Run the PIPE command
328sub run_pipe {
329	local($program) = @_;		# Program to run
330	my $mail = $opt'sw_b ? $MAIL_INPUT_BINARY : $MAIL_INPUT;
331	local($failed) = &shell_command($program, $mail, $NO_FEEDBACK);
332	unless ($failed) {
333		&add_log("PIPED [$mfile] to '$program'") if $loglvl > 4;
334	}
335	$failed;
336}
337
338# Run the GIVE command
339sub run_give {
340	local($program) = @_;		# Program to run
341	local($failed) = &shell_command($program, $BODY_INPUT, $NO_FEEDBACK);
342	unless ($failed) {
343		&add_log("GAVE [$mfile] to '$program'") if $loglvl > 4;
344	}
345	$failed;
346}
347
348# Run the PASS command
349sub run_pass {
350	local($program) = @_;		# Program to run
351	local($failed) = &shell_command($program, $BODY_INPUT, $FEEDBACK);
352	unless ($failed) {
353		&add_log("PASSED [$mfile] through '$program'") if $loglvl > 4;
354	}
355	$failed;
356}
357
358# Run the FEED command
359sub run_feed {
360	local($program) = @_;		# Program to run
361	my $mail = $opt'sw_b ? $MAIL_INPUT_BINARY : $MAIL_INPUT;
362	my $feedback = $opt'sw_e ? $FEEDBACK_ENCODING : $FEEDBACK;
363	local($failed) = &shell_command($program, $mail, $feedback);
364	unless ($failed) {
365		&add_log("FED [$mfile] through '$program'") if $loglvl > 4;
366	}
367	$failed;
368}
369
370# Run the PURIFY command
371sub run_purify {
372	local($program) = @_;		# Program to run
373	local($failed) = &shell_command($program, $HEADER_INPUT, $FEEDBACK);
374	unless ($failed) {
375		&add_log("PURIFIED [$mfile] through '$program'") if $loglvl > 4;
376	}
377	$failed;
378}
379
380# Run the BACK command
381# Manipulates dynamically bound variable $cont (output from xeqte)
382sub run_back {
383	local($command) = @_;
384	# The BACK command is handled recursively. The local variable $Back will be
385	# set by xeq_back() if any feedback is to ever occur. This routine will be
386	# transparently called instead of the usual handle_output() because of the
387	# dynamic aliasing done here.
388	local($Back) = '';					# BACK may be nested
389	local(*handle_output) = *xeq_back;	# Any output to be put in $Back
390	local($failed) = 0;
391	$command =~ s/%/%%/g;				# Protect against 2nd macro substitution
392	# Calling run_command will position $lastcmd to be the return status of
393	# the last meaningful command executed. However, we reset $lastcmd before
394	# diving into the execution.
395	$lastcmd = 0;						# Assume everything went fine
396	&run_command($command);				# Run command (ignore return value)
397	if ($Back ne '') {
398		&add_log("got '$Back' back") if $loglvl > 11;
399		$cont = &xeqte($Back);			# Get continuation status back
400		$@ = '';						# Avoid cascade of (same) error report
401		&add_log("BACK from '$command'") if $loglvl > 4;
402	} else {
403		&add_log("WARNING got nothing out of '$command'") if $loglvl > 5;
404	}
405	$lastcmd;			# Propage error status we got from the $command
406}
407
408# Run the ON command
409sub run_on {
410	local($_) = $cmd;					# The whole command line
411	local(@days) = split(' ', 'Sun Mon Tue Wed Thu Fri Sat');
412	local(%days);
413	local($daynum) = 0;
414	foreach $day (@days) {				# Initialize Sun => 0, Mon => 1, etc...
415		$days{$day} = $daynum++;
416	}
417	local(@on);							# List of specified days
418	local(%on);							# Hash '0' (for sunday) => 1 if selected
419	if (s/^ON\s*\(([^\)]*)\)//) {		# List of days, like (Mon Tue)
420		@on = split(/,?\s+/, $1);		# Allow (Mon Thu) and (Mon, Thu)
421		local($non);
422		foreach $on (@on) {
423			$non = $on;					# New $on will be canonicalized
424			$non =~ s/^(...).*/\u\L$1/;	# Keep only first 3 letters
425			unless (defined $days{$non}) {
426				&add_log("WARNING ignoring bad day $on in ON (@on)")
427					if $loglvl > 5;
428				next;
429			}
430			$on{$days{$non}}++;			# E.g sets $on{1} for Mon
431		}
432		&add_log("on (@on)") if $loglvl > 18;
433	} else {
434		&add_log("ERROR bad ON syntax (did not parse right)") if $loglvl > 1;
435		return 1;
436	}
437
438	# Calling run_command will set $lastcmd to the status of the command. In
439	# case we are running a command which does not alter this status, assume
440	# everything is fine.
441
442	$lastcmd = 0;						# Assume command will run correctly
443	s/^\s*//;							# Remove leading spaces
444
445	local($wday) = (localtime(time))[6];
446
447	if (defined $on{$wday}) {
448		&add_log("ON (@on) $_") if $loglvl > 7;
449		s/%/%%/g;						# Protect against 2nd macro substitution
450		$cont = &run_command($_);		# Run command and update control flow
451	} else {
452		&add_log("not a good day for $_") if $loglvl > 12;
453	}
454
455	$lastcmd;							# Propagates execution status
456}
457
458# Run the ONCE command
459sub run_once {
460	local($_) = $cmd;					# The whole command line
461	local($hname);						# Hash name (e-mail address)
462	local($tag);						# Tag associated with command
463	local($raw_period);					# The period, as written
464	if (s/^ONCE\s*\(([^,\)]*),\s*([^,;\)]*),\s*(\w+)\s*\)//) {
465		($hname, $tag, $raw_period) = ($1, $2, $3);
466		&add_log("tag is ($hname, $tag, $raw_period)") if $loglvl > 18;
467	} else {
468		&add_log("ERROR bad once syntax (invalid tag)") if $loglvl > 1;
469		return 1;
470	}
471	s/^\s*//;							# Remove leading spaces
472	local($period) = &seconds_in_period($raw_period);
473	&add_log("period is $raw_period = $period seconds") if $loglvl > 18;
474
475	# Calling run_command will set $lastcmd to the status of the command. In
476	# case we are running a command which does not alter this status, assume
477	# everything is fine.
478	$lastcmd = 0;						# Assume command will run correctly
479
480	if (&once_check($hname, $tag, $period)) {
481		&add_log("ONCE ($hname, $tag, $raw_period) $_") if $loglvl > 7;
482		&s_once($cmd_name, $wmode, $tag);
483		s/%/%%/g;						# Protect against 2nd macro substitution
484		$cont = &run_command($_);		# Run it, update continuation status
485	} else {
486		&add_log("retry time not reached for $_") if $loglvl > 12;
487		&s_noretry($cmd_name, $wmode, $tag);
488	}
489
490	$lastcmd;							# Propagates execution status
491}
492
493# Run the SELECT command
494sub run_select {
495	local($_) = $cmd;					# The whole command line
496	local($start, $end);				# Date strings for start and end
497	if (s/^SELECT\s*\(([^.\)]*)\.\.\s*([^\)]*)\)//) {
498		($start, $end) = ($1, $2);
499		$start =~ s/\s*$//;				# Remove trailing spaces
500		$end =~ s/\s*$//;
501		&add_log("time is ($start .. $end)") if $loglvl > 18;
502	} else {
503		&add_log("ERROR bad select syntax (invalid time)") if $loglvl > 1;
504		return 1;
505	}
506	local($now) = time;					# Current time
507	local($sec_start, $sec_end);		# Start and end converted in seconds
508	$sec_start = &getdate($start, $now);
509	if ($sec_start == -1) {
510		&add_log("ERROR in SELECT: 1st time '$start'") if $loglvl > 1;
511		return 1;
512	}
513	$sec_end = &getdate($end, $now);
514	if ($sec_end == -1) {
515		&add_log("ERROR in SELECT: 2nd time '$end'") if $loglvl > 1;
516		return 1;
517	}
518	if ($sec_start > $sec_end) {
519		&add_log("WARNING time selection always impossible?") if $loglvl > 1;
520		return 0;
521	}
522
523	# Calling run_command will set $lastcmd to the status of the command. In
524	# case we are running a command which does not alter this status, assume
525	# everything is fine.
526	$lastcmd = 0;						# Assume command will run correctly
527
528	&add_log("SELECT ($sec_start, $sec_end) at $now") if $loglvl > 11;
529
530	s/^\s*//;							# Remove leading spaces
531	if ($now >= $sec_start && $now <= $sec_end) {
532		&add_log("SELECT ($start .. $end) $_") if $loglvl > 7;
533		s/%/%%/g;						# Protect against 2nd macro substitution
534		$cont = &run_command($_);		# Run command and update control flow
535	} else {
536		&add_log("time period not good for $_") if $loglvl > 12;
537	}
538
539	$lastcmd;							# Propagates execution status
540}
541
542# Run the NOP command
543sub run_nop {
544	local($what) = $opt'sw_f ? 'failure' : ($opt'sw_t ? 'success' : '');
545	local($force) = $what ? " forcing $what" : '';
546	&add_log("NOP [$mfile]$force") if $loglvl > 7;
547	return 1 if $opt'sw_f;		# -f forces failure
548	return 0 if $opt'sw_t;		# -t forces failure
549	$lastcmd;					# Propagates curremt exec status
550}
551
552# Run the STRIP command
553sub run_strip {
554	local($headers) = @_;		# Headers to remove
555	&alter_header($headers, $HD_STRIP);
556	$headers = join(', ', split(/\s/, $headers));
557	&add_log("STRIPPED $headers from [$mfile]") if $loglvl > 7;
558	0;
559}
560
561# Run the KEEP command
562sub run_keep {
563	local($headers) = @_;		# Headers to keep
564	&alter_header($headers, $HD_KEEP);
565	$headers = join(', ', split(/\s/, $headers));
566	&add_log("KEPT $headers from [$mfile]") if $loglvl > 7;
567	0;
568}
569
570# Run the ANNOTATE command
571sub run_annotate {
572	local($field, $value) = $cms =~ m|([\w\-]+):?\s*(.*)|;
573	local($failed) = &annotate_header($field, $value);
574	unless ($failed) {
575		local($msg) = $opt'sw_d ? ' (no date)' : '';
576		&add_log("ANNOTATED [$mfile] with $field$msg") if $loglvl > 7;
577	}
578	$failed;
579}
580
581# Run the ASSIGN command
582sub run_assign {
583	local($var, $value) = $cms =~ m|^(:?\w+)\s+(.*)|;
584	local($eval);						# Evaluated value for expression
585	local($@);
586	# An expression may be provided as a value. If the whole value is enclosed
587	# within simple quotes, then those are stripped and no evaluation is made.
588	unless ($value =~ s/^'(.*)'$/$1/) {
589		eval "\$eval = $value";			# Maybe value is an expression?
590		if ($@) {
591			chop($@);
592			&add_log("WARNINIG can't evaluate '$value': $@");
593		} else {
594			$value = $eval;
595		}
596	}
597	if ($var =~ s/^://) {
598		&extern'set($var, $value);		# Persistent variable is set
599	} else {
600		$Variable{$var} = $value;		# User defined variable is set
601	}
602	&add_log("ASSIGNED '$value' to '$var' [$mfile]") if $loglvl > 7;
603	0;
604}
605
606# Run the TR command
607sub run_tr {
608	local($variable, $tr) = $cms =~ m|^(\S+)\s+(.*)|;
609	&alter_value($variable, "tr$tr");
610}
611
612# Run the SUBST command
613sub run_subst {
614	local($variable, $s) = $cms =~ m|^(\S+)\s+(.*)|;
615	&alter_value($variable, "s$s");
616}
617
618# Run the SPLIT command
619sub run_split {
620	local($folder) = @_;			# Folder where split occurs
621	local($failed) = &split($folder);
622	if (0 == $failed % 2) {			# Message was in digest format
623		if ($failed & 0x4) {
624			&add_log("SPLIT [$mfile] in mailagent's queue") if $loglvl > 2;
625		} else {
626			&add_log("SPLIT [$mfile] in $folder") if $loglvl > 2;
627		}
628		# If digest was not in RFC-934 style, there is a chance the split
629		# was not correctly performed. To avoid any accidental loss of
630		# information, the original digest message is also saved if SPLIT
631		# had a folder argument, or it is not tagged saved.
632		if ($failed & 0x8) {		# Digest was not RFC-934 compliant
633			&add_log("NOTICE [$mfile] not RFC-934 compliant") if $loglvl > 6;
634			if ($folder ne '') {
635				&add_log("NOTICE saving original [$mfile] in $folder")
636					if $loglvl > 6;
637				&save_message($folder);
638			} else {
639				&add_log("NOTICE [$mfile] not tagged as saved")
640					if $loglvl > 6 && ($failed & 0x2);
641			}
642		} else {
643			$ever_saved = 1 if $failed & 0x2;	# Split -i succeeded
644		}
645		$failed = 0;
646	}
647	# If message was not in digest format and a folder was specified, save
648	# message in that folder.
649	if ($failed < 0 && $folder ne '') {
650		&add_log("NOTICE [$mfile] not in digest format") if $loglvl > 6;
651		$failed = &save_message($folder);
652	}
653	$failed ? 1 : 0;	# Failure status from split can be negative
654}
655
656# Run the VACATION command
657sub run_vacation {
658	return 0 unless $cf'vacation =~ /on/i;	# Ignore if vacation mode off
659	local($mode, $period) = $cms =~ m|^(\S+)(\s+\S+)?|;
660	local($l) = $opt'sw_l ? ' locally' : '';
661	local($allowed) = ($mode =~ /off/i) ? 0 : 1;
662	&env'local('vacation', $allowed) if $opt'sw_l;
663	$env'vacation = $allowed;			# Won't hurt given the above local call
664	if ($allowed && $mode !~ /^on$/i) {	# New vacation path given
665		if ($cf'vacfixed =~ /on/i) {	# Not allowed if vacfixed is ON
666			&add_log("WARNING no message change allowed by 'vacfixed'")
667				if $loglvl > 5;
668		} else {
669			$mode =~ s/^~/$cf'home/;		# ~ substitution
670			&env'local('vacfile', $mode) if $opt'sw_l;
671			$env'vacfile = $mode;
672			&add_log("vacation message in file $mode$l") if $loglvl > 7;
673		}
674	}
675	if ($allowed && $period) {
676		&env'local('vacperiod', $period) if $opt'sw_l;
677		$env'vacperiod = $period;
678		&add_log("vacation period is now $period$l") if $loglvl > 7;
679	}
680	$mode = $env'vacation ? 'on' : 'off';
681	&add_log("vacation message turned $mode$l") if $loglvl > 7;
682	0;
683}
684
685# Run the QUEUE command
686sub run_queue {
687	# Mail is saved as a 'qm' file, to avoid endless loops when mailagent
688	# processes the queue. This means the mail will be deferred for at
689	# least half an hour.
690	local($name) = &queue_mail('', 'qm');	# No file name, mail in %Header
691	$ever_saved = 1 if defined $name;		# Queuing counts as saving
692	defined $name ? 0 : 1;					# Failed if $name is undef
693}
694
695# Run the PERL command
696sub run_perl {
697	local($script) = @_;	# Script to be loaded
698	local($failed) = &perl($script);
699	unless ($failed) {
700		$script = &tilda($script);			# Replace the home directory by ~
701		&add_log("PERLED [$mfile] through $script") if $loglvl > 7;
702	}
703	$failed;
704}
705
706# Run the REQUIRE command
707sub run_require {
708	local($file, $package) = $cms =~ m|^(\S+)\s*(.*)|;
709	local($failed) = &require($file, $package);
710	unless ($failed) {
711		$file = &tilda($file);		# Replace the home directory by ~
712		local($inpack) = $file;		# Loaded in a package?
713		$inpack .= " in package $package" if $package ne '';
714		&add_log("REQUIRED [$mfile] $inpack") if $loglvl > 7;
715	}
716	$failed;
717}
718
719# Run the APPLY command
720sub run_apply {
721	local($rulefile) = @_;	# Rule file to be applied
722	local($failed, $saved) = &apply($rulefile);
723	unless ($failed) {
724		$rulefile = &tilda($rulefile);		# Replace the home directory by ~
725		&add_log("APPLIED [$mfile] rules $rulefile") if $loglvl > 7;
726	}
727	$ever_saved = 1 if $saved;		# Mark mail as saved if appropriate
728	$saved ? $failed : 1;			# Force failure if never saved
729}
730
731# Run the UMASK command
732sub run_umask {
733	local($mask) = @_;
734	$mask = oct($mask) if $mask =~ /^0/;
735	&env'local('umask', $mask) if $opt'sw_l;	# Restored when leaving rule
736	$env'umask = $mask;		# Permanent change, unless changed locally already
737	umask($env'umask);
738	local($omask) = sprintf("0%o", $mask);	# Octal string, for logging
739	local($local) = $opt'sw_l ? ' locally' : '';
740	&add_log("UMASK [$mfile] set to ${omask}$local") if $loglvl > 7;
741	0;	# Ok
742}
743
744# Run the AFTER command
745sub run_after {
746	local($time, $action) = $cms =~ m|^\((.*)\)(.*)|;
747	local($failed, $queued) = &after($time, $action);
748	unless ($failed) {
749		local(@msg);
750		push(@msg, 'shell') if $opt'sw_s;
751		push(@msg, 'command') if $opt'sw_c;
752		push(@msg, 'no input') if $opt'sw_n;
753		push(@msg, 'agent') if $opt'sw_a || 0 == @msg;
754		local($type) = join(', ', @msg);
755		local($qmsg) = $queued ne '-' ? "-> $queued" : '';
756		&add_log("AFTER [$mfile$qmsg] $time {$action} ($type)") if $loglvl > 3;
757	}
758	$failed;	# Failure status
759}
760
761# Run the DO command
762sub run_do {
763	local($what, $args) = $cms =~ m|^([^()\s]*)(.*)|;
764	local($something, $routine) = $what =~ m|^([^:]*):(.*)|;
765	$routine = $what if $something eq '';
766	local($failed) = &do($something, $routine, $args);
767	&add_log("DONE [$mfile] $routine$args") if $loglvl > 7 && !$failed;
768	$failed;	# Failure status
769}
770
771# Run the BEEP command
772sub run_beep {
773	local($beep) = @_;
774	&env'local('beep', $beep) if $opt'sw_l;	# Restored when leaving rule
775	$env'beep = $beep;		# Permanent change, unless changed locally already
776	local($local) = $opt'sw_l ? ' locally' : '';
777	&add_log("BEEP [$mfile] set to ${beep}$local") if $loglvl > 7;
778	0;	# Ok
779}
780
781# Run the PROTECT command
782sub run_protect {
783	local($mode) = @_;
784	local($local) = $opt'sw_l ? ' locally' : '';
785	if ($opt'sw_u) {
786		&env'undef('protect');
787		&env'unset('protect') unless $opt'sw_l;
788		&add_log("PROTECT [$mfile] reset to default$local") if $loglvl > 7;
789		return 0;	# Ok
790	}
791	$mode = oct($mode) if $mode =~ /^0/;
792	&env'local('protect', $mode) if $opt'sw_l;	# Restored when leaving rule
793	$env'protect = $mode;	# Permanent change, unless changed locally already
794	local($omode) = sprintf("0%o", $mode);	# Octal string, for logging
795	&add_log("PROTECT [$mfile] mode set to ${omode}$local") if $loglvl > 7;
796	0;	# Ok
797}
798
799# Run the BIFF command
800sub run_biff {
801	local($mode) = $cms =~ m|^(\S+)|;
802	local($l) = $opt'sw_l ? ' locally' : '';
803	local($allowed) = ($mode =~ /off/i) ? 0 : 1;	# New boolean setting
804	local($was) = ($env'biff =~ /off/i) ? 0 : 1;	# Old boolean setting
805	local($setting) = $allowed ? 'ON' : 'OFF';
806	&env'local('biff', $setting) if $opt'sw_l;
807	$env'biff = $setting;				# Won't hurt given the above local call
808	if ($allowed && $mode !~ /^on$/i) {	# New biff template format path given
809		$mode =~ s/^~/$cf'home/;		# ~ substitution
810		&env'local('biffmsg', $mode) if $opt'sw_l;
811		$env'biffmsg = $mode;
812		&add_log("biff template in file $mode$l") if $loglvl > 7;
813	}
814	&add_log("biffing turned $setting$l") if $loglvl > 7 && $was != $allowed;
815	0;
816}
817
818# For SAVE, STORE or WRITE, the job is the same
819# If the name is not an absolute path, the folder directory is taken
820# in the "maildir" environment variable. If none, defaults to ~/Mail.
821# A folder whose name begins with a '+' is taken as an MH folder.
822sub run_saving {
823	local($folder, $remove) = @_;				# Shall we remove folder first?
824	local($folddir) = $XENV{'maildir'};			# Folder directory location
825	unless ($folder =~ /^\+/) {					# Not an MH folder
826		$folder = "~/mbox" unless $folder;		# No folder -> save in mbox
827		$folder =~ s/~/$cf'home/g;				# ~ substitution
828		$folddir =~ s/~/$cf'home/g;				# ~ substitution
829		$folddir = "$cf'home/Mail" unless $folddir;	# Default folders in ~/Mail
830		$folder = "$folddir/$folder" unless $folder =~ m|^/|;
831		local($dir) = $folder =~ m|(.*)/.*|;	# Get directory name
832		unless (-d "$dir") {
833			&makedir($dir);
834			unless (-d "$dir") {
835				&add_log("ERROR couldn't create directory $dir")
836					if $loglvl > 0;
837			} else {
838				&add_log("created directory $dir") if $loglvl > 7;
839			}
840		}
841	}
842	# Cannot use WRITE with an MH folder, it behaves like a SAVE. Same thing
843	# when attempting to save in a directory...
844	if ($remove == $FOLDER_REMOVE && $folder !~ /^\+/) {
845		# Folder has to be removed before writting into it. However, if it
846		# is write protected, do not unlink it (save will fail later on anyway).
847		# Note that this makes it a candidate for hooks via WRITE, if the
848		# folder has its 'x' bit set with its 'w' bit cleared. This is an
849		# undocumented feature however (WRITE is not supposed to trigger hooks).
850		unlink "$folder" if -f "$folder" && -w _;
851	}
852	local($mbox, $failed) = &save($folder);
853	local($log_message);				# Log message to be issued
854	unless ($failed) {
855		local($file) = $folder;			# Work on a copy to detect leading dir
856		$folddir =~ s/(\W)/\\$1/g;		# Escape possible meta-characters
857		$file =~ s|^$folddir/||;		# Preceded by folder directory?
858		if ($file =~ s/^\+//) {
859			$log_message = "MH folder $file";
860		} elsif ($file ne $folder) {
861			$log_message = "folder $file";
862		} else {
863			$log_message = &tilda($folder);	# Replace the home directory by ~
864		}
865	}
866
867	# Return the status of the save command and a part of the logging message
868	# to be issued. That way, we get a nice contextual log.
869	($mbox, $failed, $log_message);
870}
871
872# Perform the appropriate continuation status, depending on the option:
873# When 'x' is given as the option string, then the current options in the
874# opt package are used instead of -c, -r or -a.
875sub alter_execution {
876	local($option, $mode) = @_;	# Option, mode we have to change to
877	if ($mode ne '') {
878		&add_log("entering new state $mode") if $loglvl > 6 && $wmode ne $mode;
879		$wmode = $mode;
880	}
881	if ($option eq 'x') {		# Backward compatibility at 3.0 PL24
882		$option = '-c' if $opt'sw_c;
883		$option = '-a' if $opt'sw_a;
884		$option = '-r' if $opt'sw_r;
885		$option = '' if $option eq 'x';
886	}
887	&add_log("altering execution in mode '$wmode', option '$option'")
888		if $loglvl > 18;
889	if ($option eq '-c') {		# Continue execution
890		0;
891	} elsif ($option eq '-r') {	# Asks for RESTART
892		&do_restart;
893	} elsif ($option eq '-a') {	# Asks for ABORT
894		&do_abort;
895	} else {					# Default is to REJECT
896		&do_reject;
897	}
898	# Propagate return status.
899}
900
901# Save message in specified folder
902sub save_message {
903	local($folder) = @_;
904	local($mbox, $failed, $log_message) = &run_saving($folder, $FOLDER_APPEND);
905	unless ($failed) {
906		&add_log("SAVED [$mfile] in $log_message") if $loglvl > 2;
907		$ever_saved = 1;			# We were able to save it
908	}
909	$failed;
910}
911
912