new class to handle subject like string

1 files changed, 237 insertions, 0 deletions

diff --git a/fml/lib/Mail/Message/Subject.pm b/fml/lib/Mail/Message/Subject.pm
new file mode 100644
index 00000000..40b988b2
--- /dev/null
+++ b/fml/lib/Mail/Message/Subject.pm
@@ -0,0 +1,237 @@
+#-*- perl -*-
+#
+# Copyright (C) 2004 Ken'ichi Fukamachi
+#
+# $FML: Subject.pm,v 1.25 2004/01/24 09:04:00 fukachan Exp $
+#
+
+package Mail::Message::Subject;
+use strict;
+use vars qw(@ISA @EXPORT @EXPORT_OK $AUTOLOAD);
+use Carp;
+
+# base class is "Mail::Message::String".
+use Mail::Message::String;
+@ISA = qw(Mail::Message::String);
+
+
+=head1 NAME
+
+Mail::Message::Subject - utilities to manipulate subject string.
+
+=head1 SYNOPSIS
+
+
+    my $subject = new Mail::Message::Subject $header->get('subject');
+    if ($subject->has_reply_tag()) {
+	$subject->delete_dup_reply_tag();
+    }
+    $subject->mime_decode();
+    my $subject_str = $subject->as_str();
+
+
+=head1 DESCRIPTION
+
+=head2 new($subject)
+
+constructor.
+
+=cut
+
+
+# Descriptions: constructor.
+#    Arguments: OBJ($self) STR($subject)
+# Side Effects: none
+# Return Value: OBJ
+sub new
+{
+    my ($self, $subject) = @_;
+    $self->SUPER::new($subject);
+}
+
+
+=head1 Re: TAG HANLING
+
+=cut
+
+
+# Descriptions: cut off reply keywords like "Re:".
+#    Arguments: OBJ($self)
+# Side Effects: none
+# Return Value: none
+sub delete_dup_reply_tag
+{
+    my ($self)  = @_;
+    my $subject = $self->as_str();
+    my $charset = $self->get_mime_charset();
+
+    # XXX-TODO: care for not Japanese string!
+    if ($charset =~ /iso-2022-jp/io) {
+	use Mail::Message::Language::Japanese::Subject;
+	my $sbj  = new Mail::Message::Language::Japanese::Subject;
+	$subject = $sbj->cut_off_reply_tag($subject);
+	$self->set($subject);
+    }
+}
+
+
+# Descriptions: speculate $subject looks a reply message or not?
+#    Arguments: OBJ($self)
+# Side Effects: none
+# Return Value: 1 (looks reply message) or 0
+sub has_reply_tag
+{
+    my ($self)  = @_;
+    my $subject = $self->as_str();
+    my $charset = $self->get_mime_charset();
+
+    return 1 if $subject =~ /^\s*Re:/i;
+
+    # XXX anyway, we use this method always :-)
+    # XXX-TODO: care for not Japanese string!
+    if (1 || $charset =~ /iso-2022-jp/io) {
+	# XXX-TODO: method-ify ?
+	use Mail::Message::Language::Japanese::Subject;
+	if (&Mail::Message::Language::Japanese::Subject::is_reply($subject)) {
+	    return 1;
+	}
+    }
+
+    return 0;
+}
+
+
+=head1 ML TAG HANDLING
+
+=cut
+
+
+# Descriptions: remove tag-like string.
+#    Arguments: OBJ($self) STR($tag)
+# Side Effects: none
+# Return Value: STR(subject string)
+sub delete_tag
+{
+    my ($self, $tag) = @_;
+    my $subject = $self->as_str();
+
+    # for example, ml_name = elena
+    # if $tag has special regexp such as \U$ml_name\E or \L$ml_name\E
+    if (defined $tag) {
+        if ($tag =~ /\\E/o && $tag =~ /\\U|\\L/o) {
+            eval qq{ \$tag = "$tag";};
+            carp($@) if $@;
+        }
+
+	my $retag = $self->_regexp_compile($tag);
+	$subject  =~ s/$retag//g;
+	$subject  =~ s/^\s*//;
+    }
+
+    $self->set($subject);
+    return $subject;
+}
+
+
+# Descriptions: create regexp for a subject tag, for example
+#               "[%s %05d]" => "\[\S+ \d+\]"
+#               not OO style.
+#    Arguments: OBJ($self) STR($s)
+#               $s == a subject tag string
+# Side Effects: none
+# Return Value: STR(a regexp for the given tag)
+sub _regexp_compile
+{
+    my ($self, $s) = @_;
+
+    if (defined $s) {
+	$s = quotemeta( $s );
+	$s =~ s@\\\%@\%@g;
+	$s =~ s@\%s@\\S+@g;
+	$s =~ s@\%d@\\d+@g;
+	$s =~ s@\%0\d+d@\\d+@g;
+	$s =~ s@\%\d+d@\\d+@g;
+	$s =~ s@\%\-\d+d@\\d+@g;
+
+	# quote for regexp substitute: [ something ] -> \[ something \]
+	# $s =~ s/^(.)/quotemeta($1)/e;
+	# $s =~ s/(.)$/quotemeta($1)/e;
+
+	return $s;
+    }
+    else {
+	return '';
+    }
+}
+
+
+######################################################################
+#
+# debug
+#
+
+# Descriptions: debug function.
+#    Arguments: STR($str)
+# Side Effects: none
+# Return Value: none
+sub _debug
+{
+    my ($str) = @_;
+    my $sbj = new Mail::Message::Subject $str;
+
+    # start.
+    print "\n";
+    print $str, " (original)\n";
+
+    # mime charset
+    print "# charset = ", $sbj->get_mime_charset() ,"\n";
+
+    # mime decode test.
+    $sbj->mime_decode();
+    print $sbj->as_str() ,"\n";
+
+    # delete subject tag.
+    if ($sbj->has_reply_tag()) {
+	print "# looks replied message. try cut off the dup tag.\n";
+	$sbj->delete_dup_reply_tag();
+	print $sbj->as_str(), " (cut off reply tag)\n";
+    }
+
+    # mime decode test.
+    $sbj->mime_encode();
+    print $sbj->as_str() ,"\n";
+}
+
+if ($0 eq __FILE__) {
+    my $str = '=?ISO-2022-JP?B?GyRCJDckRCRiJHMbKEI=?=';
+    _debug($str);
+    _debug("Re: $str");
+    _debug("Re: Re: $str");
+}
+
+=head1 CODING STYLE
+
+See C<http://www.fml.org/software/FNF/> on fml coding style guide.
+
+=head1 AUTHOR
+
+Ken'ichi Fukamachi
+
+=head1 COPYRIGHT
+
+Copyright (C) 2004 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
+
+Mail::Message::Subject first appeared in fml8 mailing list driver package.
+See C<http://www.fml.org/> for more details.
+
+C<Subject_to_unixtime> is imported from fml 4.0-current libmti.pl.
+
+=cut
+
+
+1;