Add file Filter/ContentCheck.pm

fix typo

2 files changed, 186 insertions, 4 deletions

diff --git a/fml/lib/FML/Filter.pm b/fml/lib/FML/Filter.pm
index ed5019b2..3e0081ca 100644
--- a/fml/lib/FML/Filter.pm
+++ b/fml/lib/FML/Filter.pm
@@ -1,10 +1,10 @@
 #-*- perl -*-
 #
-#  Copyright (C) 2001 Ken'ichi Fukamachi
+#  Copyright (C) 2001,2002 Ken'ichi Fukamachi
 #   All rights reserved. This program is free software; you can
 #   redistribute it and/or modify it under the same terms as Perl itself.
 #
-# $FML: Filter.pm,v 1.4 2001/12/23 13:46:13 fukachan Exp $
+# $FML: Filter.pm,v 1.5 2001/12/23 13:48:07 fukachan Exp $
 #
 
 package FML::Filter;
@@ -96,7 +96,7 @@ sub check
 	    my $obj = new FML::Filter::BodyCheck;
 
 	    # overwrite filter rules based on FML::Config
-	    if (defined $config->{ header_filter_rles }) {
+	    if (defined $config->{ body_filter_rles }) {
 		my (@rules) = split(/\s+/, $config->{ body_filter_rles });
 		$obj->rules( \@rules );
 	    }
@@ -111,6 +111,27 @@ sub check
 		return $x;
 	    }
 	}
+
+	if ($config->yes( 'use_content_filter' )) {
+	    use FML::Filter::ContentCheck;
+	    my $obj = new FML::Filter::ContentCheck;
+
+	    # overwrite filter rules based on FML::Config
+	    if (defined $config->{ content_filter_rles }) {
+		my (@rules) = split(/\s+/, $config->{ content_filter_rles });
+		$obj->rules( \@rules );
+	    }
+
+	    # go check
+	    $obj->content_check($message);
+	    if ($obj->error()) {
+		my $x = $obj->error();
+		$x =~ s/\s*at .*$//;
+		$x =~ s/[\n\s]*$//m;
+		$self->error_set($x);
+		return $x;
+	    }
+	}
     }
 
     return undef; # O.K.
@@ -123,7 +144,7 @@ Ken'ichi Fukamachi
 
 =head1 COPYRIGHT
 
-Copyright (C) 2001 Ken'ichi Fukamachi
+Copyright (C) 2001,2002 Ken'ichi Fukamachi
 
 All rights reserved. This program is free software; you can
 redistribute it and/or modify it under the same terms as Perl itself.
diff --git a/fml/lib/FML/Filter/ContentCheck.pm b/fml/lib/FML/Filter/ContentCheck.pm
new file mode 100644
index 00000000..7bc58311
--- /dev/null
+++ b/fml/lib/FML/Filter/ContentCheck.pm
@@ -0,0 +1,161 @@
+#-*- perl -*-
+#
+#  Copyright (C) 2002 Ken'ichi Fukamachi
+#   All rights reserved. This program is free software; you can
+#   redistribute it and/or modify it under the same terms as Perl itself.
+#
+# $FML$
+#
+
+package FML::Filter::ContentCheck;
+use strict;
+use vars qw(@ISA @EXPORT @EXPORT_OK $AUTOLOAD);
+use Carp;
+use ErrorStatus qw(error_set error error_clear);
+
+=head1 NAME
+
+FML::Filter::ContentCheck - filter based on mail MIME content
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+C<FML::Filter::ContentCheck> is a MIME content filter
+
+=head1 METHODS
+
+=head2 C<new()>
+
+usual constructor.
+
+=cut
+
+
+my $debug = 0;
+
+my (@default_rules) = qw(only_plaintext);
+
+# Descriptions: constructor.
+#    Arguments: OBJ($self)
+# Side Effects: none
+# Return Value: OBJ
+sub new
+{
+    my ($self) = @_;
+    my ($type) = ref($self) || $self;
+    my $me     = {};
+
+    # apply default rules
+    $me->{ _rules } = \@default_rules;
+
+    return bless $me, $type;
+}
+
+
+
+=head2 C<rules( $rules )>
+
+overwrite rules by specified C<@$rules> ($rules is HASH ARRAY).
+
+=cut
+
+
+# Descriptions: access method to overwrite rule
+#    Arguments: OBJ($self) HASH_ARRAY($rarray)
+# Side Effects: overwrite info in object
+# Return Value: none
+sub rules
+{
+    my ($self, $rarray) = @_;
+    $self->{ _rules } = $rarray;
+}
+
+
+=head2 C<header_check($msg, $args)>
+
+C<$msg> is C<Mail::Message> object.
+
+C<Usage>:
+
+    use FML::Filter::ContentCheck;
+    my $obj  = new FML::Filter::ContentCheck;
+    my $msg  = $curproc->{'incoming_message'};
+
+    $obj->header_check($msg, $args);
+    if ($obj->error()) {
+       # do something for wrong formated message ...
+    }
+
+=cut
+
+
+# Descriptions: top level dispatcher
+#    Arguments: OBJ($self) OBJ($msg) HASH_REF($args)
+# Side Effects: none
+# Return Value: none
+sub content_check
+{
+    my ($self, $msg, $args) = @_;
+    my $h = $msg->whole_message_header();
+    my $rules = $self->{ _rules };
+
+    for my $rule (@$rules) {
+	eval q{
+	    $self->$rule($h, $args);
+	};
+
+	if ($@) {
+	    $self->error_set($@);
+	}
+    }
+}
+
+
+# Descriptions: plaintext only
+#    Arguments: OBJ($self) OBJ($msg) HASH_REF($args)
+# Side Effects: croak()
+# Return Value: none
+sub only_plaintext
+{
+    my ($self, $msg, $args) = @_;
+    my $mp   = $self;
+    my ($data_type,$prevmp,$nextmp);
+
+   for ( ; $mp; $mp = $mp->{ next }) {
+	$data_type = $mp->data_type();
+	next if($data_type eq "text/rfc822-headers");
+	next if($data_type eq "text/plain");
+	next if($data_type =~ "multipart\.");
+
+	$prevmp = $mp->{ prev };
+	if($prevmp) {
+	    $prev_type = $prevmp->data_type();
+	    if(prev_type eq "multipart.delimiter") {
+		$prevmp->delete_message_part_link();
+	    }
+	}
+	$mp->delete_message_part_link();
+    }
+}
+
+=head1 AUTHOR
+
+Ken'ichi Fukamachi
+
+=head1 COPYRIGHT
+
+Copyright (C) 2002 Ken'ichi Fukamachi
+
+All rights reserved. This program is free software; you can
+redistribute it and/or modify it under the same terms as Perl itself.
+
+=head1 HISTORY
+
+FML::Filter::ContentCheck appeared in fml5 mailing list driver package.
+See C<http://www.fml.org/> for more details.
+
+=cut
+
+
+1;