summaryrefslogtreecommitdiff
path: root/fml/lib/FML
diff options
context:
space:
mode:
Diffstat (limited to 'fml/lib/FML')
-rw-r--r--fml/lib/FML/Command/Filter.pm38
-rw-r--r--fml/lib/FML/Filter.pm70
-rw-r--r--fml/lib/FML/Filter/Header.pm8
-rw-r--r--fml/lib/FML/Filter/MimeComponent.pm151
-rw-r--r--fml/lib/FML/Filter/Size.pm29
-rw-r--r--fml/lib/FML/Filter/TextPlain.pm22
6 files changed, 163 insertions, 155 deletions
diff --git a/fml/lib/FML/Command/Filter.pm b/fml/lib/FML/Command/Filter.pm
index a3f138a1..a9cb50f4 100644
--- a/fml/lib/FML/Command/Filter.pm
+++ b/fml/lib/FML/Command/Filter.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: Filter.pm,v 1.2 2003/08/23 07:24:42 fukachan Exp $
+# $FML: Filter.pm,v 1.3 2004/01/02 14:42:43 fukachan Exp $
#
package FML::Command::Filter;
@@ -38,41 +38,42 @@ dummy :-)
# Descriptions: constructor.
-# Arguments: OBJ($self) HASH_REF($args)
+# Arguments: OBJ($self) OBJ($curproc) HASH_REF($args)
# Side Effects: none
# Return Value: OBJ
sub new
{
- my ($self, $args) = @_;
+ my ($self, $curproc, $args) = @_;
my ($type) = ref($self) || $self;
- my $me = {};
+ my $me = { _curproc => $curproc };
return bless $me, $type;
}
# Descriptions: virtual reject handler, just return __LAST__ :-)
-# Arguments: OBJ($self) OBJ($curproc) OBJ($msg)
+# Arguments: OBJ($self) OBJ($msg)
# Side Effects: none
# Return Value: STR (__LAST__, a special upcall)
sub reject
{
- my ($self, $curproc, $msg) = @_;
+ my ($self, $msg) = @_;
return '__LAST__';
}
# Descriptions:
-# Arguments: OBJ($self) OBJ($curproc) OBJ($msg)
+# Arguments: OBJ($self) OBJ($msg)
# Side Effects: admin password modified.
# Return Value: NUM
sub check_command_limit
{
- my ($self, $curproc, $msg) = @_;
- my $config = $curproc->config();
- my $limit = $config->{ command_mail_valid_command_limit } || 1024;
- my $lines = $msg->message_text_as_array_ref();
- my $count = 0;
+ my ($self, $msg) = @_;
+ my $curproc = $self->{ _curproc };
+ my $config = $curproc->config();
+ my $limit = $config->{ command_mail_valid_command_limit } || 1024;
+ my $lines = $msg->message_text_as_array_ref();
+ my $count = 0;
LINE:
for my $buf (@$lines) {
@@ -90,16 +91,17 @@ sub check_command_limit
# Descriptions:
-# Arguments: OBJ($self) OBJ($curproc) OBJ($msg)
+# Arguments: OBJ($self) OBJ($msg)
# Side Effects: admin password modified.
# Return Value: NUM
sub check_line_length_limit
{
- my ($self, $curproc, $msg) = @_;
- my $config = $curproc->config();
- my $limit = $config->{ command_mail_line_length_limit } || 999;
- my $lines = $msg->message_text_as_array_ref();
- my $match = 0;
+ my ($self, $msg) = @_;
+ my $curproc = $self->{ _curproc };
+ my $config = $curproc->config();
+ my $limit = $config->{ command_mail_line_length_limit } || 999;
+ my $lines = $msg->message_text_as_array_ref();
+ my $match = 0;
my $len;
LINE:
diff --git a/fml/lib/FML/Filter.pm b/fml/lib/FML/Filter.pm
index 33c6e2ec..8e4b9604 100644
--- a/fml/lib/FML/Filter.pm
+++ b/fml/lib/FML/Filter.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: Filter.pm,v 1.38 2004/01/02 14:50:28 fukachan Exp $
+# $FML: Filter.pm,v 1.39 2004/01/21 03:48:32 fukachan Exp $
#
package FML::Filter;
@@ -58,7 +58,7 @@ sub new
}
-# Descriptions: entry point for FML::Filter::* modules
+# Descriptions: entry point for FML::Filter::* modules.
# Arguments: OBJ($self) OBJ($curproc)
# Side Effects: none
# Return Value: STR or UNDEF, error reason (string). return undef if ok.
@@ -81,7 +81,7 @@ sub article_filter
}
else {
if ($debug) {
- $curproc->log("filter(debug): not check by $function");
+ $curproc->log("filter(debug): $function check disabled.");
}
}
@@ -95,7 +95,7 @@ sub article_filter
}
-# Descriptions: size based filtering
+# Descriptions: size based filtering.
# Arguments: OBJ($self) OBJ($curproc) OBJ($mesg)
# Side Effects: none
# Return Value: STR(reason) or 0 (not trapped, ok)
@@ -115,7 +115,7 @@ sub _apply_article_size_filter
# overwrite rules
if (defined $rules) {
- $obj->rules( $rules );
+ $obj->set_rules( $rules );
}
# go check
@@ -123,8 +123,8 @@ sub _apply_article_size_filter
if ($obj->error()) {
my $x;
$x = $obj->error();
- $x =~ s/\s*at .*$//;
- $x =~ s/[\n\s]*$//m;
+ $x =~ s/\s*at .*$//o;
+ $x =~ s/[\n\s]*$//mo;
$self->error_set($x);
return $x;
}
@@ -134,7 +134,7 @@ sub _apply_article_size_filter
}
-# Descriptions: header based filter
+# Descriptions: header based filter.
# Arguments: OBJ($self) OBJ($curproc) OBJ($mesg)
# Side Effects: none
# Return Value: STR(reason) or 0 (not trapped, ok)
@@ -152,7 +152,7 @@ sub _apply_article_header_filter
# overwrite rules
if (defined $rules) {
- $obj->rules( $rules );
+ $obj->set_rules( $rules );
}
# go check
@@ -160,8 +160,8 @@ sub _apply_article_header_filter
if ($obj->error()) {
my $x;
$x = $obj->error();
- $x =~ s/\s*at .*$//;
- $x =~ s/[\n\s]*$//m;
+ $x =~ s/\s*at .*$//o;
+ $x =~ s/[\n\s]*$//mo;
$self->error_set($x);
return $x;
}
@@ -171,7 +171,7 @@ sub _apply_article_header_filter
}
-# Descriptions: filter non MIME format message
+# Descriptions: filter non MIME format message.
# Arguments: OBJ($self) OBJ($curproc) OBJ($mesg)
# Side Effects: none
# Return Value: 0 (always ok, anyway)
@@ -181,18 +181,27 @@ sub _apply_article_non_mime_filter
my $config = $curproc->config();
if ($config->yes( 'use_article_non_mime_filter' )) {
+ my $hdr = $curproc->incoming_message_header();
my $rules =
- $config->get_as_array_ref('article_none_mime_filter_rules');
+ $config->get_as_array_ref('article_non_mime_filter_rules');
RULE:
for my $rule (@$rules) {
+ $curproc->log("article_non_mime_filter.check $rule") if $debug;
+
if ($rule eq 'permit') {
return 0;
}
- # XXX-TODO: implement this!
- if ($rule eq 'reject') {
- ;
+ if ($rule eq 'reject_empty_content_type') {
+ if (defined $hdr) {
+ my $type = $hdr->get('content-type') || '';
+ unless ($type) {
+ my $s = "no Content-Type:";
+ $self->error_set($s);
+ return $s;
+ }
+ }
}
}
}
@@ -201,7 +210,7 @@ sub _apply_article_non_mime_filter
}
-# Descriptions: syntax check for text(/plain)
+# Descriptions: syntax check for text(/plain).
# Arguments: OBJ($self) OBJ($curproc) OBJ($mesg)
# Side Effects: none
# Return Value: none
@@ -218,7 +227,7 @@ sub _apply_article_text_plain_filter
my $rules =
$config->get_as_array_ref('article_text_plain_filter_rules');
if (defined $rules) {
- $obj->rules( $rules );
+ $obj->set_rules( $rules );
}
# go check
@@ -226,8 +235,8 @@ sub _apply_article_text_plain_filter
if ($obj->error()) {
my $x;
$x = $obj->error();
- $x =~ s/\s*at .*$//;
- $x =~ s/[\n\s]*$//m;
+ $x =~ s/\s*at .*$//o;
+ $x =~ s/[\n\s]*$//mo;
$self->error_set($x);
return $x;
}
@@ -266,8 +275,8 @@ sub _apply_article_mime_component_filter
if ($obj->error()) {
my $x;
$x = $obj->error();
- $x =~ s/\s*at .*$//;
- $x =~ s/[\n\s]*$//m;
+ $x =~ s/\s*at .*$//o;
+ $x =~ s/[\n\s]*$//mo;
$self->error_set($x);
return $x;
}
@@ -365,9 +374,14 @@ sub _filter_reject_notice
=head1 COMMAND MAIL
+=head2 command_mail_filter($curproc)
+
+entry point for FML::Filter::* modules.
+
=cut
-# Descriptions: entry point for FML::Filter::* modules
+
+# Descriptions: entry point for FML::Filter::* modules.
# Arguments: OBJ($self) OBJ($curproc)
# Side Effects: none
# Return Value: STR or UNDEF, error reason (string). return undef if ok.
@@ -391,7 +405,7 @@ sub command_mail_filter
}
else {
if ($debug) {
- $curproc->log("filter(debug): not check by $function");
+ $curproc->log("filter(debug): $function check disabled.");
}
}
@@ -405,7 +419,7 @@ sub command_mail_filter
}
-# Descriptions: size based filtering
+# Descriptions: size based filtering.
# Arguments: OBJ($self) OBJ($curproc) OBJ($mesg)
# Side Effects: none
# Return Value: STR(reason) or 0 (not trapped, ok)
@@ -426,7 +440,7 @@ sub _apply_command_mail_size_filter
# overwrite rules
if (defined $rules) {
- $obj->rules( $rules );
+ $obj->set_rules( $rules );
}
# go check
@@ -434,8 +448,8 @@ sub _apply_command_mail_size_filter
if ($obj->error()) {
my $x;
$x = $obj->error();
- $x =~ s/\s*at .*$//;
- $x =~ s/[\n\s]*$//m;
+ $x =~ s/\s*at .*$//o;
+ $x =~ s/[\n\s]*$//mo;
$self->error_set($x);
return $x;
}
diff --git a/fml/lib/FML/Filter/Header.pm b/fml/lib/FML/Filter/Header.pm
index 9c3326ab..5bc78061 100644
--- a/fml/lib/FML/Filter/Header.pm
+++ b/fml/lib/FML/Filter/Header.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: Header.pm,v 1.7 2004/01/02 14:50:30 fukachan Exp $
+# $FML: Header.pm,v 1.8 2004/01/21 03:52:00 fukachan Exp $
#
package FML::Filter::Header;
@@ -37,7 +37,7 @@ constructor.
my $debug = 0;
-# XXX-TODO: need this default rules here ? (principle of least surprise?)
+# default rules for convenience.
my (@default_rules) = qw(check_message_id);
@@ -59,7 +59,7 @@ sub new
-=head2 rules( $rules )
+=head2 set_rules( $rules )
overwrite rules by specified C<@$rules> ($rules is ARRAY_REF).
@@ -70,7 +70,7 @@ overwrite rules by specified C<@$rules> ($rules is ARRAY_REF).
# Arguments: OBJ($self) ARRAY_REF($rarray)
# Side Effects: overwrite info in object
# Return Value: ARRAY_REF
-sub rules
+sub set_rules
{
my ($self, $rarray) = @_;
diff --git a/fml/lib/FML/Filter/MimeComponent.pm b/fml/lib/FML/Filter/MimeComponent.pm
index f54b6f47..e7969e5f 100644
--- a/fml/lib/FML/Filter/MimeComponent.pm
+++ b/fml/lib/FML/Filter/MimeComponent.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.8 2004/01/02 14:50:31 fukachan Exp $
+# $FML: MimeComponent.pm,v 1.9 2004/01/21 03:53:18 fukachan Exp $
#
package FML::Filter::MimeComponent;
@@ -51,7 +51,7 @@ usual constructor.
my $debug = 0;
-# default rules
+# default rules for convenience.
my $filter_rules = [
['text/plain', '*', 'permit'],
['text/html' , '*', 'reject'],
@@ -59,6 +59,17 @@ my $filter_rules = [
];
+# XXX-TODO: $default_action customizable ?
+my $default_action = 'permit';
+
+# XXX-TODO: $opt_cut_off_empty_part customizable ?
+my $opt_cut_off_empty_part = 1;
+
+# XXX-TODO: $recursive_max_level customizable ?
+my $recursive_max_level = 10;
+
+
+
# Descriptions: constructor.
# Arguments: OBJ($self) OBJ($curproc)
# Side Effects: none
@@ -97,79 +108,6 @@ C<Usage>:
=cut
-# XXX-TODO: $default_action customizable ?
-my $default_action = 'permit';
-
-# XXX-TODO: $opt_cut_off_empty_part customizable ?
-my $opt_cut_off_empty_part = 1;
-
-# XXX-TODO: $recursive_max_level customizable ?
-my $recursive_max_level = 10;
-
-
-# Descriptions: parser of child multipart
-# Arguments: OBJ($self) OBJ($msg)
-# Side Effects: update $recursive_level
-# Return Value: NUM
-sub _rfc822_mime_component_check
-{
- my ($self, $msg) = @_;
- my $curproc = $self->{ _curproc };
-
- $recursive_level ||= 0;
- $recursive_level++;
-
- if ($debug) {
- print STDERR "\t_rfc822_mime_component_check ($recursive_level)\n";
- }
-
- if ($recursive_level > $recursive_max_level) {
- croak("too deep recursive call");
- }
- else {
- my $tmpf = $self->_temp_file_path();
-
- use FileHandle;
- my $wh = new FileHandle "> $tmpf";
- if (defined $wh) {
- $msg->print($wh);
- $wh->close();
- }
-
- my $rh = new FileHandle $tmpf;
- if (defined $rh) {
- use Mail::Message;
- my $msg0 = new Mail::Message->parse( { fd => $rh } );
- $self->mime_component_check($msg0);
- }
- }
-
- $recursive_level--;
-}
-
-
-# Descriptions: return temporary file path to be used.
-# Arguments: OBJ($self)
-# Side Effects: none
-# Return Value: none
-sub _temp_file_path
-{
- my ($self) = @_;
- my $curproc = $self->{ _curproc };
-
- if (defined $curproc) {
- return $curproc->temp_file_path();
- }
- elsif ($debug) {
- return "./fileter.debug.$$";
- }
- else {
- $curproc->logerror("\$curproc is mandatory");
- croak("\$curproc undefined");
- }
-}
-
-
# Descriptions: top level dispatcher
# Arguments: OBJ($self) OBJ($msg)
# Side Effects: none
@@ -451,6 +389,69 @@ sub _has_effective_part
}
+# Descriptions: parser of child multipart
+# Arguments: OBJ($self) OBJ($msg)
+# Side Effects: update $recursive_level
+# Return Value: NUM
+sub _rfc822_mime_component_check
+{
+ my ($self, $msg) = @_;
+ my $curproc = $self->{ _curproc };
+
+ $recursive_level ||= 0;
+ $recursive_level++;
+
+ if ($debug) {
+ print STDERR "\t_rfc822_mime_component_check ($recursive_level)\n";
+ }
+
+ if ($recursive_level > $recursive_max_level) {
+ croak("too deep recursive call");
+ }
+ else {
+ my $tmpf = $self->_temp_file_path();
+
+ use FileHandle;
+ my $wh = new FileHandle "> $tmpf";
+ if (defined $wh) {
+ $msg->print($wh);
+ $wh->close();
+ }
+
+ my $rh = new FileHandle $tmpf;
+ if (defined $rh) {
+ use Mail::Message;
+ my $msg0 = new Mail::Message->parse( { fd => $rh } );
+ $self->mime_component_check($msg0);
+ }
+ }
+
+ $recursive_level--;
+}
+
+
+# Descriptions: return temporary file path to be used.
+# Arguments: OBJ($self)
+# Side Effects: none
+# Return Value: none
+sub _temp_file_path
+{
+ my ($self) = @_;
+ my $curproc = $self->{ _curproc };
+
+ if (defined $curproc) {
+ return $curproc->temp_file_path();
+ }
+ elsif ($debug) {
+ return "./fileter.debug.$$";
+ }
+ else {
+ $curproc->logerror("\$curproc is mandatory");
+ croak("\$curproc undefined");
+ }
+}
+
+
=head1 UTILITY FUNCTIONS
=cut
diff --git a/fml/lib/FML/Filter/Size.pm b/fml/lib/FML/Filter/Size.pm
index 0d98ae85..52c0c249 100644
--- a/fml/lib/FML/Filter/Size.pm
+++ b/fml/lib/FML/Filter/Size.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: Size.pm,v 1.7 2004/01/02 14:50:31 fukachan Exp $
+# $FML: Size.pm,v 1.8 2004/01/21 03:43:30 fukachan Exp $
#
package FML::Filter::Size;
@@ -37,7 +37,7 @@ constructor.
my $debug = 0;
-# XXX-TODO: need this default rules here ? (principle of least surprise?)
+# default rules for convenience.
my (@default_rules) = qw(check_header_size check_body_size);
@@ -61,21 +61,18 @@ sub new
}
-# XXX-TODO rules() -> set_rules() ?
-
-
-=head2 rules( $rules )
+=head2 set_rules( $rules )
overwrite rules by specified C<@$rules> ($rules is ARRAY_REF).
=cut
-# Descriptions: access method to overwrite rule
+# Descriptions: overwrite rules.
# Arguments: OBJ($self) ARRAY_REF($rarray)
# Side Effects: overwrite info in object
# Return Value: ARRAY_REF
-sub rules
+sub set_rules
{
my ($self, $rarray) = @_;
@@ -124,7 +121,7 @@ C<Usage>:
=cut
-# Descriptions: top level dispatcher
+# Descriptions: top level dispatcher.
# Arguments: OBJ($self) OBJ($msg)
# Side Effects: none
# Return Value: none
@@ -236,7 +233,7 @@ check the length limit of one command request.
=cut
-# Descriptions: check the total number of command requests
+# Descriptions: check the total number of command requests.
# Arguments: OBJ($self) OBJ($msg) STR($type)
# Side Effects: croak() if condition matched.
# Return Value: none
@@ -247,10 +244,8 @@ sub check_command_limit
use FML::Command::Filter;
my $_msg = $curproc->incoming_message_body();
-
- # XXX-TODO new FML::Command::Filter $curproc ?
- my $obj = new FML::Command::Filter;
- my $reason = $obj->check_command_limit($curproc, $_msg);
+ my $obj = new FML::Command::Filter $curproc;
+ my $reason = $obj->check_command_limit($_msg);
if ($reason) {
$self->error_set($reason);
@@ -270,10 +265,8 @@ sub check_line_length_limit
use FML::Command::Filter;
my $_msg = $curproc->incoming_message_body();
-
- # XXX-TODO new FML::Command::Filter $curproc ?
- my $obj = new FML::Command::Filter;
- my $reason = $obj->check_line_length_limit($curproc, $_msg);
+ my $obj = new FML::Command::Filter $curproc;
+ my $reason = $obj->check_line_length_limit($_msg);
if ($reason) {
$self->error_set($reason);
diff --git a/fml/lib/FML/Filter/TextPlain.pm b/fml/lib/FML/Filter/TextPlain.pm
index c3a59b86..6ef8813b 100644
--- a/fml/lib/FML/Filter/TextPlain.pm
+++ b/fml/lib/FML/Filter/TextPlain.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: TextPlain.pm,v 1.8 2004/01/02 14:50:31 fukachan Exp $
+# $FML: TextPlain.pm,v 1.9 2004/01/21 03:43:30 fukachan Exp $
#
package FML::Filter::TextPlain;
@@ -34,8 +34,7 @@ constructor.
=cut
-# default rules to apply
-# XXX-TODO: need this default rules here ? (principle of least surprise?)
+# default rules for convenience.
my (@default_rules) = qw(reject_not_iso2022jp_japanese_string
reject_null_mail_body
reject_one_line_message
@@ -62,7 +61,7 @@ sub new
}
-=head2 rules( $rules )
+=head2 set_rules( $rules )
overwrite rules by specified C<@$rules> ($rules is ARRAY_REF).
@@ -73,7 +72,7 @@ overwrite rules by specified C<@$rules> ($rules is ARRAY_REF).
# Arguments: OBJ($self) ARRAY_REF($rarray)
# Side Effects: overwrite info in object
# Return Value: ARRAY_REF
-sub rules
+sub set_rules
{
my ($self, $rarray) = @_;
@@ -451,17 +450,16 @@ sub is_signature
{
my ($self, $data) = @_;
- # XXX-TODO: //o
- if ($data =~ /\@/ ||
- $data =~ /TEL:/i ||
- $data =~ /FAX:/i ||
- $data =~ /:\/\// ) {
+ if ($data =~ /\@/o ||
+ $data =~ /TEL:/oi ||
+ $data =~ /FAX:/oi ||
+ $data =~ /:\/\//o ) {
return 1;
}
# -- fukachan ( usenet style signature ? )
# // fukachan ( signature derived from what ? )
- if ($data =~ /^--/ || $data =~ /^\/\//) {
+ if ($data =~ /^--/o || $data =~ /^\/\//o) {
return 1;
}
@@ -471,7 +469,7 @@ sub is_signature
$data = $obj->convert( $data, 'euc-jp' );
# "2-byte @"domain where "@" is a 2-byte "@" character.
- if ($data =~ /[-A-Za-z0-9]\241\367[-A-Za-z0-9]/) {
+ if ($data =~ /[-A-Za-z0-9]\241\367[-A-Za-z0-9]/o) {
return 1;
}
generated by cgit v1.2.1 (git 2.18.0) at 2026-09-08 04:18:22 +0000