fix rule appling algorithm:

+ for rule (rules) {
+    for mp (message) {
+       check mp by $rule
+   }
+ }

enable to read filter rules from the specified file (-c file).

show more debug info.

1 files changed, 162 insertions, 86 deletions

diff --git a/fml/lib/FML/Filter/MimeComponent2.pm b/fml/lib/FML/Filter/MimeComponent2.pm
index e77876cb..af788962 100644
--- a/fml/lib/FML/Filter/MimeComponent2.pm
+++ b/fml/lib/FML/Filter/MimeComponent2.pm
@@ -4,7 +4,7 @@
 #   All rights reserved. This program is free software; you can
 #   redistribute it and/or modify it under the same terms as Perl itself.
 #
-# $FML: MimeComponent.pm,v 1.1 2002/09/30 11:00:54 fukachan Exp $
+# $FML: MimeComponent2.pm,v 1.1 2002/10/21 07:35:43 fukachan Exp $
 #
 
 package FML::Filter::MimeComponent;
@@ -24,6 +24,20 @@ FML::Filter::MimeComponent - filter based on mail MIME component
 
 C<FML::Filter::MimeComponent> is a MIME content filter.
 
+=head1 INTERNAL PRESENTATION FOR FILTER RULES
+
+Our filter rule is a list of the following components:
+
+    (whole message type, message type, action)
+
+For example, 
+
+    $rules = (
+	      (text/plain   *  permit),
+	      (multipart/*  *  reject),
+	      (*            *  reject),
+	    );
+
 =head1 METHODS
 
 =head2 C<new()>
@@ -36,6 +50,15 @@ usual constructor.
 my $debug = 0;
 
 
+# default rules
+my $filter_rules = [
+		    ['text/plain',   '*',  'permit'],
+		    ['text/*',       '*',  'reject'],
+		    ['multipart/*',  '*',  'reject'],
+		    ['*',            '*',  'reject'],
+		    ];
+
+
 # Descriptions: constructor.
 #    Arguments: OBJ($self)
 # Side Effects: none
@@ -80,33 +103,43 @@ sub mime_component_check
     my ($data_type, $prevmp, $nextmp, $mp, $action);
     my $is_match = 0;
     my $i = 1;
+    my $j = 1;
 
     # whole message type
     my $whole_data_type = $msg->whole_message_header_data_type();
-    
-  MSG:
-    for ($mp = $msg; $mp; $mp = $mp->{ next }) {
-	$data_type = $mp->data_type();
 
-	# skip 
-	# 1. the header part of the whole RFC822 message.
-	# 2. parts of Mail::Message internal use.
-	next MSG if ($data_type eq "text/rfc822-headers");
-	next MSG if ($data_type =~ "multipart\.");
+    # debug info
+    if (1) { $self->dump_message_structure($msg);}
 
-	# o.k. apply our filter rules.
-	print STDERR "\n   msg($i) ($whole_data_type, $data_type)\n"; 
-	$action = 
-	    $self->_rule_match($msg, $args, $mp, $whole_data_type);
+  RULE:
+    for my $rule (@$filter_rules) {
+	print STDERR "\n    rule ${j}: (@$rule)\n";
+	$j++;
+
+      MSG:
+	for ($mp = $msg, $i = 1; $mp; $mp = $mp->{ next }) {
+	    $data_type = $mp->data_type();
+
+	    # skip 
+	    # 1. the header part of the whole RFC822 message.
+	    # 2. parts of Mail::Message internal use.
+	    next MSG if ($data_type eq "text/rfc822-headers");
+	    next MSG if ($data_type =~ "multipart\.");
+
+	    # o.k. apply our filter rules.
+	    print STDERR "\n\tmsg($i) type=$data_type\n"; 
+	    $action = 
+		$self->_rule_match($msg, $rule, $mp, $whole_data_type);
+
+	    if ($action eq 'reject' || $action eq 'permit') {
+		print STDERR "\n\t! action = $action. stop here.\n";
+		$is_match = 1;
+		last RULE;
+	    }
 
-	if ($action eq 'reject' || $action eq 'permit') {
-	    print STDERR "\n\t! action = $action. stop here.\n";
-	    $is_match = 1;
-	    last MSG;
+	    # prepare for the next _rule_match().
+	    $i++;
 	}
-
-	# prepare for the next _rule_match().
-	$i++;
     }
 
     my $decision = $is_match ? $action : $default_action;
@@ -116,66 +149,30 @@ sub mime_component_check
 }
 
 
-=head1 INTERNAL PRESENTATION FOR FILTER RULES
-
-Our filter rule is a list of the following components:
-
-    (whole message type, message type, action)
-
-For example, 
-
-    $rules = (
-	      (text/plain   *  permit),
-	      (multipart/*  *  reject),
-	      (*            *  reject),
-	    );
-
-=cut
-
-
-my $filter_rules = [
-		    ['text/plain',   '*',  'permit'],
-		    ['multipart/*',  'image/*',  'reject'],
-		    ];
-
-
 # Descriptions: 
-#    Arguments: OBJ($self) OBJ($msg) HASH_REF($args) 
+#    Arguments: OBJ($self) OBJ($msg) ARRAY_REF($rule)
 #               OBJ($mp) STR($whole_type)
 # Side Effects: "reject" and "permit" affects nothing.
 #               "cutoff" changes the chain of Mail::Message OBJs.
 # Return Value: none
 sub _rule_match
 {
-    my ($self, $msg, $args, $mp, $whole_type) = @_;
-    my $type = $mp->data_type();
-    my $i    = 0;
-
-    if ($debug) {
-	print STDERR "\twhole_type = $whole_type\n";
-	print STDERR "\t      type = $type\n";
-    }
-
-    for my $rule (@$filter_rules) {
-	$i++;
-
-	my ($r_whole_type, $r_type, $r_action) = @$rule;
-	print STDERR 
-	    "\n\trule ${i}: ($r_whole_type, $r_type, $r_action)\n";
-
-	if (__regexp_match($whole_type, $r_whole_type)) {
-	    if (__regexp_match($type, $r_type)) {
-		print STDERR "\t\t* checked. => $r_action\n";
-		return $r_action;
-	    }
-	    else {
-		print STDERR "\t\tnot check (type not matched)\n";
-	    }
+    my ($self, $msg, $rule, $mp, $whole_type) = @_;
+    my ($r_whole_type, $r_type, $r_action) = @$rule;
+    my $type                               = $mp->data_type();
+
+    if (__regexp_match($whole_type, $r_whole_type)) {
+	if (__regexp_match($type, $r_type)) {
+	    print STDERR "\t\t* checked. => $r_action\n";
+	    return $r_action;
 	}
 	else {
-	    print STDERR "\t\tnot check (whole_type not matched)\n";
+	    print STDERR "\t\tnot check (type not matched)\n";
 	}
     }
+    else {
+	print STDERR "\t\tnot check (whole_type not matched)\n";
+    }
 }
 
 
@@ -213,6 +210,86 @@ sub __regexp_match
 }
 
 
+#
+#sub _cutoff
+#{
+#	$prevmp = $mp->{ prev };
+#	if ($prevmp) {
+#	    my $prev_type = $prevmp->data_type();
+#	    if ($prev_type eq "multipart.delimiter") {
+#		$prevmp->delete_message_part_link();
+#		Log("only_plaintext delete multipart delimiter");
+#	    }
+#	}
+#	$mp->delete_message_part_link();
+#	Log("only_plaintext delete not plain $data_type");
+#    }
+#}
+#
+
+
+=head1 utilities
+
+=cut
+
+
+# Descriptions: read rule file.
+#               XXX we should enhance this to use IO::Adapter.
+#    Arguments: OBJ($self) STR($file)
+# Side Effects: update filter rules.
+# Return Value: none
+sub read_filter_rule_from_file
+{
+    my ($self, $file) = @_;
+    my ($whole_type, $type, $action);
+
+    use FileHandle;
+    my $fh = new FileHandle $file;
+
+    if (defined $fh) {
+	my $rules = [];
+
+	while (<$fh>) {
+	    next if /^#/o;
+	    next if /^\s*$/o;
+
+	    ($whole_type, $type, $action) = split(/\s+/, $_);
+	    push(@$rules, [ $whole_type, $type, $action ] );
+	}
+
+	$fh->close();
+
+	if (@$rules) {
+	    $filter_rules = $rules;
+	}
+	else {
+	    use Carp;
+	    carp("no valid filter rules");
+	}
+    }
+}
+
+
+sub dump_message_structure
+{
+    my ($self, $msg) = @_;
+    my ($data_type, $prevmp, $nextmp, $mp, $action, $i);
+    my $whole_data_type = $msg->whole_message_header_data_type();
+
+    print STDERR "\t[message structure]\n";
+    print STDERR "\t\twhole_type = $whole_data_type\n";
+
+  MSG:
+    for ($mp = $msg, $i = 1; $mp; $mp = $mp->{ next }) {
+	$data_type = $mp->data_type();
+	next MSG if ($data_type eq "text/rfc822-headers");
+	next MSG if ($data_type =~ "multipart\.");
+	print STDERR "\t\t$data_type\n";
+	$i++;
+    }
+}
+
+
 # Descriptions: print filter rules.
 #    Arguments: none
 # Side Effects: none
@@ -231,22 +308,11 @@ sub dump_filter_rules
 }
 
 
-#
-#sub _cutoff
-#{
-#	$prevmp = $mp->{ prev };
-#	if ($prevmp) {
-#	    my $prev_type = $prevmp->data_type();
-#	    if ($prev_type eq "multipart.delimiter") {
-#		$prevmp->delete_message_part_link();
-#		Log("only_plaintext delete multipart delimiter");
-#	    }
-#	}
-#	$mp->delete_message_part_link();
-#	Log("only_plaintext delete not plain $data_type");
-#    }
-#}
-#
+=head1 DEBUG
+
+    perl -I PERL_INCLUDE_PATH MimeComponent2.pm -c RULE_FILE @FILES
+
+=cut
 
 
 # 
@@ -258,9 +324,17 @@ if ($0 eq __FILE__) {
 	use FileHandle;
 	use File::Basename;
 	use Mail::Message;
+	use Getopt::Long;
+	my $opt = {};
+	GetOptions($opt, qw(debug! -c=s));
 
+	# rule ?
 	print STDERR "* current filter rules:\n";
 	my $obj = new FML::Filter::MimeComponent;
+	if (defined $opt->{ 'c' }) {
+	    my $file = $opt->{ 'c' };
+	    $obj->read_filter_rule_from_file($file);
+	}
 	$obj->dump_filter_rules();
 	print STDERR "\n";
 
@@ -302,6 +376,8 @@ version to be able to handle enhanced filter rules.
 
 2002/09/30: rename ContentCheck to MimeComponent.
 
+2002/10/21: fully rewritten by fukachan@fml.org.
+
 =cut