;# $Id: rules.pl,v 3.0.1.9 1998/03/31 15:27:04 ram Exp $
;#
;# Copyright (c) 1990-1993, Raphael Manfredi
;#
;# You may redistribute only under the terms of the Artistic License,
;# as specified in the README file that comes with the distribution.
;# You may reuse parts of this distribution only within the terms of
;# that same Artistic License; a copy of which may be found at the root
;# of the source tree for mailagent 3.0.
;#
;# $Log: rules.pl,v $
;# Revision 3.0.1.9 1998/03/31 15:27:04 ram
;# patch59: allow ~name expansion when specifying alternate rule files
;#
;# Revision 3.0.1.8 1997/01/31 18:08:02 ram
;# patch54: esacape metacharacter '{' in regexps for perl5.003_20
;#
;# Revision 3.0.1.7 1996/12/24 15:00:11 ram
;# patch45: forgot to unlock rulecache on errors
;# patch45: don't dataload hashkey(), used as a sort routine
;#
;# Revision 3.0.1.6 1995/08/07 16:24:53 ram
;# patch37: skip possible spaces before trailing command ';' terminator
;#
;# Revision 3.0.1.5 1995/02/16 14:36:26 ram
;# patch32: was not properly propagating rule-file variable definitions
;#
;# Revision 3.0.1.4 1995/02/03 18:03:57 ram
;# patch30: added tracing of alternate rules to help debug their parsing
;#
;# Revision 3.0.1.3 1995/01/03 18:15:44 ram
;# patch24: don't try to read the rule cache when none was configured
;#
;# Revision 3.0.1.2 1994/09/22 14:36:40 ram
;# patch12: lock rule cache before reading to prevent from concurrent updates
;#
;# Revision 3.0.1.1 1994/04/25 15:23:03 ram
;# patch7: added locking protections when updating rule cache
;#
;# Revision 3.0 1993/11/29 13:49:14 ram
;# Baseline for mailagent 3.0 netwide release.
;#
;#
# Here are the data structures we use to store the compiled form of the rules:
# @Rules has entries looking like "<$mode> {$action} $rulekeys..."
# %Rule has entries looking like "$selector: $pattern"
# Each rule was saved in @Rules. The ruleskeys have the form H<num> where <num>
# is an increasing integer. They index the rules in %Rule.
# Compile the rules held in file $cf'rules (usually ~/.rules) or in memory
sub compile_rules {
local($mode); # mode (optional)
local($first_selector); # selector (mandatory first time)
local($selector); # selector (optional)
local($pattern); # pattern to be matched
local($action); # associated action
local($rulekeys); # keys to rules in hash table
local($rulenum) = 0; # to compute unique keys for the hash table
local($line); # buffer for next rule
local($env); # environment variable recognized
# This function is called whenever a new line rule has to be read. By
# default, rules are read from a file, but if @Linerules is set, they
# are read from there.
local(*read_rule) = *read_filerule if @Linerules == 0;
local(*read_rule) = *read_linerule if @Linerules > 0;
unless ($edited_rules) { # If no rules from command line
unless (-s "$cf'rules") { # No rule file or empty
&default_rules; # Build default rules
return;
}
unless (open(RULES, "$cf'rules")) {
&add_log("ERROR cannot open $cf'rules: $!") if $loglvl;
&default_rules; # Default rules will apply then
return;
}
if (&rules'read_cache) { # Rules already compiled and cached
close RULES; # No parsing needs to be done
return;
}
} else { # Rules in @Linerules array
&rule_cleanup if @Linerules == 1;
}
while ($line = &get_line) {
# Detect environment settings as soon as possible
if ($line =~ s/^\s*(\w+)\s*=\s*//) {
# All the variables referenced in the line have to be environment
# variables. So replace them with the values we already computed as
# perl variables. This enables us to do variable substitution in
# perl with minimum trouble.
$env = $1; # Variable being changed
$line =~ s/\$(\w+)/\$XENV{'$1'}/g; # $VAR -> $XENV{'VAR'}
$line =~ s/\s*;$//; # Remove trailing ;
eval "\$XENV{'$env'} = \"$line\""; # Perl does the evaluations
&eval_error; # Report any eval error
next;
}
$rulekeys = ''; # Reset keys for each line
$mode = &get_mode(*line); # Get operational mode
&add_log("mode: <$mode>") if $loglvl > 19;
$first_selector = &get_selector(*line); # Fetch a selector
$first_selector = "Subject:" unless $first_selector;
$selector = $first_selector;
for (;;) {
if ($line =~ /^\s*;/) { # Selector alone on the line
&add_log("ERROR no pattern nor action, line $.") if $loglvl > 1;
last; # Ignore the whole line
}
&add_log("selector: $selector") if $loglvl > 19;
# Get a pattern. If none is found, it is assumed to be '*', which
# will match anything.
$pattern = &get_pattern(*line);
$pattern = '*' if $pattern =~ /^\s*$/;
&add_log("pattern: $pattern") if $loglvl > 19;
# Record entry in H table and update the set of used keys
$Rule{"H$rulenum"} = "$selector $pattern";
$rulekeys .= "H$rulenum ";
$rulenum++;
# Now look for an action. No action at the end means LEAVE.
$action = &get_action(*line);
$action = "LEAVE" if $action =~ /^\s*$/ && $line =~/^\s*;/;
if ($action !~ /^\s*$/) {
&add_log("action: $action") if $loglvl > 19;
push(@Rules, "$mode {$action} $rulekeys");
$rulekeys = ''; # Reset rule keys once used
}
last if $line =~ /^\s*;/; # Finished if end of line reached
last if $line =~ /^\s*$/; # Also finished if end of file
# Get a new selector, defaults to last one seen if none is found
$selector = &get_selector(*line);
$selector = $first_selector if $selector eq '';
$first_selector = $selector;
}
}
close RULES; # This may not have been opened
&default_rules unless @Rules; # Use defaults if no valid rules
# If rules have been compiled from a file and not entered on the command
# line via -e switch(es), then $edited_rules is false and it makes sense
# to cache the lattest compiled rules. Note that the 'rulecache' parameter
# is optional, and rules are actually cached only if it is defined.
&rules'write_cache unless $edited_rules;
}
# Build default rules:
# - Anything with 'Subject: Command' in it is processed.
# - All the mails are left in the mailbox.
sub default_rules {
&add_log("building default rules") if $loglvl > 18;
@Rules = ("ALL {LEAVE; PROCESS} H0");
$Rule{'H0'} = "All: /^Subject: [Cc]ommand/";
}
# Rule cleanup: If there is only one rule specified within the @Linerules
# array, it might not have {} braces.
sub rule_cleanup {
return if $Linerules[0] =~ /[{}]/; # Braces found
$Linerules[0] = '{' . $Linerules[0] . '}';
}
# Hook functions for dumping rules
sub print_rule_number {
local($rulenum) = @_;
print "# Rule $rulenum\n"; # For easier reference
1; # Continue
}
# Void function
sub void_func {
print "\n";
}
# Print only rule whose number is held in variable $number
sub exact_rule {
$_[0] eq $number;
}
sub nothing { } # Do nothing, really nothing
# Dump the rules we've compiled -- for debug purposes
sub dump_rules {
# The 'before' hook is called before each rule is called. It returns a
# boolean stating wether we should continue or skip the rule. The 'after'
# hook is called after the rule has been printed. Both hooks are given the
# rule number as argument.
local(*before, *after) = @_; # Hook functions to be called
local($mode); # mode (optional)
local($selector); # selector (mandatory)
local($rulentry); # entry in rule H table
local($pattern); # pattern for selection
local($action); # related action
local($last_selector); # last used selector
local($rules); # a copy of the rules
local($rulenum) = 0; # each rule is numbered
local($lines); # number of pattern lines printed
local(@action); # split actions (split on ;)
local($printed) = 0; # characters printed on line so far
local($indent); # next item indentation
local($linelen) = 78; # maximum line length
# Print the environement variable which differ from the original
# environment, i.e. those variable which were set by the user.
$lines = 0;
foreach (keys(%XENV)) {
unless ("$XENV{$_}" eq "$ENV{$_}") {
print "$_ = ", $XENV{$_}, ";\n";
$lines++;
}
}
print "\n" if $lines;
# Order wrt the one in the rule file is guaranteed
foreach (@Rules) {
$rulenum++;
next unless &before($rulenum); # Call 'before' hook
$rules = $_; # Work on a copy
$rules =~ s/^([^{]*)\{// && ($mode = $1); # First "word" is the mode
$rules =~ s/\s*(.*)\}// && ($action = $1); # Then action within {}
$mode =~ s/\s*$//; # Remove trailing spaces
print "<$mode> "; # Mode in which it applies
$printed = length($mode) + 3;
$rules =~ s/^\s+//; # The rule keys remain
$last_selector = ""; # Last selector in use
$lines = 0;
foreach $key (split(/ /, $rules)) { # Loop over the keys
$rulentry = $Rule{$key};
$rulentry =~ s/^\s*([^\/]*:)// && ($selector = $1);
$rulentry =~ s/^\s*//;
$pattern = $rulentry;
if ($last_selector eq $selector) { # Try to stay on same line
# Go to next line if current pattern won't fit nicely
if ($printed + length($pattern) > $linelen) {
$indent = length($mode) + length($selector) + 4;
print ",\n", ' ' x $indent;
$lines++;
$printed = $indent;
} else {
print ", ";
$printed += 2;
}
} else { # Selector has changed
if ($lines++) {
$indent = length($mode) + 3;
print ",\n", ' ' x $indent;
$printed = $indent;
}
}
if ($last_selector ne $selector) { # Update last selector
$last_selector = $selector;
if ($selector ne 'script:') { # Pseudo not printed
print "$selector ";
$printed += length($selector) + 1;
}
}
if ($selector ne 'script:') {
print "$pattern"; # Normal pattern
$printed += length($pattern);
} else {
print "[[ $pattern ]] "; # An interpreted script
$printed += length($pattern) + 7;
}
}
print " " if $lines == 1 && ($printed += 2);
# Split actions, but take care of escaped \; (layout purposes)
$action =~ s/\\\\/\02/g; # \\ -> ^B
$action =~ s/\\;/\01/g; # \; -> ^A
@action = split(/;/, $action);
foreach (@action) { # Restore escapes by in-place edit
s/\01/\\;/g; # ^A -> \;
s/\02/\\\\/g; # ^B -> \\
}
# If action is large enough, format differently (one action/line)
$lines++ if length($action) + 5 + $printed > $linelen;
$indent = $lines > 1 ? length($mode) + 3 + 4 : 0;
$printed = $indent == 0 ? $printed : $indent;
if ((length($action) + $printed) > $linelen && @action > 1) {
print "\n\t{\n";
foreach $act (@action) {
$act =~ s/^\s+//;
print "\t\t$act;\n";
}
print "\t};\n";
} else {
print "\n", ' ' x $indent if $lines > 1;
print "{ $action };\n";
}
$printed = 0;
# Call the hook function after having printed the rule
&after($rulenum);
}
}
# Print only a specific rule on stdout
sub print_rule {
local($number) = @_;
local(%XENV); # Suppress printing of leading variables
&dump_rules(*exact_rule, *nothing);
}
#
# The following package added to hold all the new rule-specific functions
# added at version 3.0.
#
package rules;
# Cache rules to the 'rulecache' file. The first line is the full pathname
# of the rule file, followed by the modification time stamp. The rulecache
# file will be recreated each time a different rule file is provided or when
# it is out of date. Note that this function is only called when actually
# compiling from the 'rules' file defined in the config file.
# The function returns 1 if success, 0 on failure.
sub write_cache {
return 0 unless defined $cf'rulecache;
local(*CACHE); # File handle used to write the cache
if (0 != &'acs_rqst($cf'rulecache)) {
&'add_log("NOTICE unable to write-lock $cf'rulecache") if $'loglvl > 6;
return 0; # Cannot write
}
unless (open(CACHE, ">$cf'rulecache")) {
&'add_log("ERROR cannot create rule cache $cf'rulecache: $!")
if $'loglvl;
&'free_file($cf'rulecache); # Unlock cache
unlink $cf'rulecache;
return 0;
}
local($error) = 0;
local($ST_MTIME) = 9 + $[;
local($mtime) = (stat($cf'rules))[$ST_MTIME];
(print CACHE "$cf'rules $mtime\n") || $error++;
&write_fd(CACHE) || $error++; # Write rules
&writevar_fd(CACHE) || $error++; # And XENV variables
close(CACHE) || $error++;
&'free_file($cf'rulecache); # Unlock cache
if ($error) {
unlink $cf'rulecache;
&'add_log("WARNING could not cache rules") if $'loglvl > 5;
return 0;
}
1; # Success
}
# Read cached rules into @Rules and %Rules and returns 1 if done, 0 when
# the cache may not be read for whatever reason (e.g. out of date).
# Since the '-r' option may also need to cache rules and no mailagent lock
# is taken in that case, we need to lock the rule file before accessing it.
sub read_cache {
return 0 unless defined $cf'rulecache;
if (0 != &'acs_rqst($cf'rulecache)) {
&'add_log("NOTICE unable to read-lock $cf'rulecache") if $'loglvl > 6;
return 0; # Cannot read
}
unless (&cache_ok) {
&'free_file($cf'rulecache);
return 0; # Cache outdated
}
local(*CACHE); # File handle used to read the cache
local($_);
open(CACHE, $cf'rulecache) || return 0; # Cannot open, assume out of date
$_ = <CACHE>; # Disregard top line
while (<CACHE>) { # First read the @Rules
chop;
last if /^$/; # Reached end of @Rules table
push(@'Rules, $_);
}
local($rulenum) = 0;
while (<CACHE>) { # Next read sorted values, assigned to H...
chop;
last if /^\+\+\+\+\+\+/; # End of dumped rules
$'Rule{"H$rulenum"} = $_;
$rulenum++;
}
while (<CACHE>) { # Read XENV variables
chop;
s/^\s*(\w+)\s*=\s*// && ($'XENV{$1} = $_);
}
close CACHE;
&'free_file($cf'rulecache); # Unlock cache
1; # Success
}
# Is cache up-to-date with respect to the rule file? Returns true if cache ok.
# The rule file should be read-locked by the caller.
sub cache_ok {
return 0 unless defined $cf'rulecache;
local(*CACHE); # File handle used to read the cache
local($top); # Top line recording file name and timestamp
open(CACHE, $cf'rulecache) || return 0; # Cannot open, assume out of date
$top = <CACHE>; # Get that first line
close CACHE;
local($name, $stamp) = split(' ', $top);
return 0 if $name ne $cf'rules; # File changed, cache out of date
local($ST_MTIME) = 9 + $[;
local($mtime) = (stat($cf'rules))[$ST_MTIME];
$mtime != $stamp ? 0 : 1; # Cache up-to-date only if $stamp == $mtime
}
# Dump the internal form of the rules, returning 1 for success.
sub write_fd {
local($file) = @_; # Filehandle in which rules are to be dumped
local($_);
local($error) = 0;
foreach (@'Rules) {
(print $file $_, "\n") || $error++;
}
(print $file "\n") || $error++; # A blank line separates tables
foreach (sort hashkey keys %'Rule) {
(print $file $'Rule{$_}, "\n") || $error++;
}
(print $file "++++++\n") || $error++; # Marks end of dumped rules
$error ? 0 : 1; # Success when no error reported
}
# Dump the internal form of environment variables, returning 1 for success.
sub writevar_fd {
local($file) = @_; # Filehandle in which variables are printed
local($error) = 0;
local($_);
foreach (keys(%'XENV)) {
unless ("$'XENV{$_}" eq "$'ENV{$_}") {
(print $file "$_ = ", $'XENV{$_}, "\n") || $error++;
}
}
$error ? 0 : 1; # Success when no error reported
}
# Perload OFF
# (Used as a sort function, causes perl5 to dump core with native AUTOLOAD)
# Sorting for hash keys used by %Rule
sub hashkey {
local($c) = $a =~ /^H(\d+)/;
local($d) = $b =~ /^H(\d+)/;
$c <=> $d;
}
# Perload ON
# The following sets-up a new rule environment and then transfers the control
# to some other function, giving it the remaining parameters. That enables the
# other function to work transparently with a different set of rules. Merely
# done for the APPLY function. Returns undef for errors, or propagates the
# result of the function.
sub alternate {
local($rules, $fn, @rest) = @_;
local($'edited_rules) = 1; # Signals that rules do not come from main file
local(@'Linerules); # We're stuffing our new rules there
$rules =~ s/^~/$cf'home/; # ~ substitution
unless (open(RULES, $rules)) {
&'add_log("ERROR cannot open alternate rule file $rules: $!")
if $'loglvl;
return undef;
}
local($_);
while (<RULES>) {
chop; # Not really needed, but it'll save space :-)
push(@'Linerules, $_);
&'add_log("PUSH <<$_>>") if $'loglvl > 24;
}
close RULES;
# Need at list two line rules or we'll try to apply some default fixes
# used by the -e 'rules' switch...
push(@'Linerules, '', '') if @'Linerules <= 1;
# Make sure transfer function is package-qualified
$fn = "main'$fn" unless $fn =~ /'/;
# Create local instances of @Rules and %Rule that will get filled-up
# by &compile_rules. Also make a copy of %XENV so that the local
# rules may override some default settings.
local(@'Rules); # Set up a new dynamic environment...
local(%'Rule);
local(@xenv) = %'XENV;
local(%'XENV) = @xenv; # Local copy of previous environment
&'compile_rules; # Compile new rules held in the @'Linerules array
&$fn(@rest); # Transfer control in new environment
}
package main;