diff options
| -rw-r--r-- | fml/lib/FML/Filter.pm | 29 | ||||
| -rw-r--r-- | fml/lib/FML/Filter/ContentCheck.pm | 161 |
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; |