diff options
Diffstat (limited to 'fml/lib/Mail/ThreadTrack/Print/Message.pm')
| -rw-r--r-- | fml/lib/Mail/ThreadTrack/Print/Message.pm | 253 |
1 files changed, 0 insertions, 253 deletions
diff --git a/fml/lib/Mail/ThreadTrack/Print/Message.pm b/fml/lib/Mail/ThreadTrack/Print/Message.pm deleted file mode 100644 index 7c61a63a..00000000 --- a/fml/lib/Mail/ThreadTrack/Print/Message.pm +++ /dev/null @@ -1,253 +0,0 @@ -#-*- perl -*- -# -# Copyright (C) 2001,2002,2003 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: Message.pm,v 1.9 2002/12/22 03:19:15 fukachan Exp $ -# - -package Mail::ThreadTrack::Print::Message; -use strict; -use vars qw(@ISA @EXPORT @EXPORT_OK $AUTOLOAD); -use Carp; -use Mail::ThreadTrack::Print::Utils qw(decode_mime_string STR2EUC); - - -=head1 NAME - -Mail::ThreadTrack::Print::Message - summarize message et.al. - -=head1 SYNOPSIS - -See C<Mail::ThreadTrack::Print> for usage of this subclass. - -=head1 DESCRIPTION - -See C<Mail::ThreadTrack::Print> for usage of this subclass. - -=head1 METHODS - -=head2 message_summary($file) - -make message summary for specified $file (article). - -=cut - - -# Descriptions: make summary of the specified $file (article). -# Arguments: OBJ($self) STR($file) -# Side Effects: none -# Return Value: STR -sub message_summary -{ - my ($self, $file) = @_; - my (@header) = (); - my $msgbuf = ''; - my $line = $self->{ _article_summary_lines } || 3; - my $mode = $self->get_mode || 'text'; - my $padding = $mode eq 'text' ? ' ' : ''; - - use FileHandle; - my $fh = new FileHandle $file; - - if (defined $fh) { - my $buf; - - LINE: - while ($buf = <$fh>) { - # remove useless lines - next LINE if $buf =~ /^\>/o; - next LINE if $buf =~ /^\-/o; - - # header part - if (1 .. $buf =~ /^$/o) { - push(@header, $buf); - } - # body part - else { - next LINE if $buf =~ /^\s*$/o; - - # ignore mail header like patterns. - next LINE if $buf =~ /^X-[-A-Za-z0-9]+:/io; - next LINE if $buf =~ /^Return-[-A-Za-z0-9]+:/io; - next LINE if $buf =~ /^Mime-[-A-Za-z0-9]+:/io; - next LINE if $buf =~ /^Content-[-A-Za-z0-9]+:/io; - next LINE if $buf =~ /^(To|From|Subject|Reply-To|Received):/io; - next LINE if $buf =~ /^(Message-ID|Date):/io; - - # pick up effetive the first $line lines - if (_is_valid_buf($buf)) { - $line--; - $msgbuf .= $padding . $buf; - } - - last LINE if $line < 0; - } - } - - $fh->close(); - - # XXX-TODO: WHO CARE FOR CSS ? return raw messages from here. - # XXX-TODO: care for non Japanese. - if (defined $self->{ _no_header_summary }) { - return STR2EUC( $msgbuf ); - } - else { - use Mail::Header; - my $header = new Mail::Header \@header; - my $header_info = $self->header_summary({ - header => $header, - padding => $padding, - }); - return STR2EUC( $header_info ."\n". $msgbuf ); - } - } - else { - return undef; - } -} - - -# Descriptions: check if $str looks effective, not quotation et.al. ? -# Arguments: STR($str) -# Side Effects: none -# Return Value: 1 or 0 -sub _is_valid_buf -{ - my ($str) = @_; - $str = STR2EUC( $str ); - - if ($str =~ /^[\>\#\|\*\:\;\=]/o) { - return 0; - } - elsif ($str =~ /^in /o) { # quotation ? - return 0; - } - elsif ($str =~ /\w+\@\w+/o) { # mail address ? - return 0; - } - elsif ($str =~ /^\S+\>/o) { # quotation ? - return 0; - } - - return 1; -} - - -# Descriptions: remove subject tag like string in $str e.g. [elena 100]. -# Arguments: STR($str) -# Side Effects: none -# Return Value: STR -sub _delete_subject_tag_like_string -{ - my ($str) = @_; - - if (defined $str) { - # XXX-TODO: hmm, method-ify Mail::Message::Utils ? - use Mail::Message::Utils; - return Mail::Message::Utils::remove_subject_tag_like_string($str); - } - else { - return undef; - } -} - - -# Descriptions: make summary of header $args->{ header }. -# Arguments: OBJ($self) HASH_REF($args) -# Side Effects: none -# Return Value: STR -sub header_summary -{ - my ($self, $args) = @_; - my $date = $args->{ header }->get('date'); - my $from = $args->{ header }->get('from'); - my $subject = $args->{ header }->get('subject'); - my $padding = $args->{ padding } || ' '; - - # XXX-TODO: care for non Japanese. - if (defined $subject) { - $subject = decode_mime_string($subject, { charset => 'euc-japan' }); - $subject =~ s/\n/ /g; - $subject = _delete_subject_tag_like_string($subject); - $subject =~ s/[\s\n]*$//g; - } - - if (defined $from) { - $from = $self->_who_of_address( $from ); - $from =~ s/\n/ /g; - $from =~ s/[\s\n]*$//g; - } - - # XXX-TODO: WHO CARE FOR CSS ? return raw messages from here. - # XXX-TODO: care for non Japanese. - # return buffer - my $r = $padding. $date; - $r .= $padding. "$subject, $from\n"; - return STR2EUC( $r ); -} - - -# Descriptions: get gecos field in $address. -# return $address itself if the extraction failed. -# Arguments: OBJ($self) STR($address) -# Side Effects: none -# Return Value: STR -sub _who_of_address -{ - my ($self, $address) = @_; - my ($user); - - use Mail::Address; - my (@addrs) = Mail::Address->parse($address); - - for my $addr (@addrs) { - if (defined( $addr->phrase() )) { - # XXX-TODO: care for non Japanese. - my $phrase = decode_mime_string( $addr->phrase(), { - charset => 'euc-japan', - }); - - if ($phrase) { - return($phrase); - } - } - - $user = $addr->user(); - } - - # XXX-TODO: hmm, CROSS SITE SCRIPTING may cause ? - if ($self->get_mode() eq 'html') { - return( $user ? "$user\@xxx.xxx.xxx.xxx" : $address ); - } - else { - return $address; - } -} - - -=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) 2001,2002,2003 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::ThreadTrack::Print::Message first appeared in fml8 mailing list driver package. -See C<http://www.fml.org/> for more details. - -=cut - - -1; |