| 1 |
|
| 2 |
=head1 NAME |
| 3 |
|
| 4 |
Message::Body::TextMessageRFC1153 --- Perl module |
| 5 |
for digest message format defined by RFC 1153 |
| 6 |
|
| 7 |
=cut |
| 8 |
|
| 9 |
## TODO: |
| 10 |
## - Select and sort enclosed message header fields (See RFC 1153) |
| 11 |
|
| 12 |
package Message::Body::TextMessageRFC1153; |
| 13 |
use strict; |
| 14 |
use vars qw(%DEFAULT @ISA $VERSION); |
| 15 |
$VERSION=do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r}; |
| 16 |
|
| 17 |
require Message::Body::Multipart; |
| 18 |
push @ISA, qw(Message::Body::Multipart); |
| 19 |
|
| 20 |
%DEFAULT = ( |
| 21 |
## "#i" : only inherited from parent Entity and inherits to child Entity |
| 22 |
-_ARRAY_NAME => 'value', |
| 23 |
-_METHODS => [qw|entity_header add delete count item preamble list_name digest_info|], |
| 24 |
-_MEMBERS => [qw|preamble list_name digest_info|], |
| 25 |
#i accept_cte |
| 26 |
#i body_default_charset |
| 27 |
#i body_default_charset_input |
| 28 |
#i cte_default |
| 29 |
#linebreak_strict => 0, |
| 30 |
-media_type => 'text', |
| 31 |
-media_subtype => 'x-message-rfc1153', |
| 32 |
#parse_all => 0, |
| 33 |
#parts_min => 1, |
| 34 |
#parts_max => 0, |
| 35 |
#i text_coderange |
| 36 |
#use_normalization => 0, |
| 37 |
-use_param_charset => 0, |
| 38 |
-value_type => {}, |
| 39 |
); |
| 40 |
|
| 41 |
=head1 CONSTRUCTORS |
| 42 |
|
| 43 |
The following methods construct new objects: |
| 44 |
|
| 45 |
=over 4 |
| 46 |
|
| 47 |
=cut |
| 48 |
|
| 49 |
## Initialize of this class -- called by constructors |
| 50 |
sub _init ($;%) { |
| 51 |
my $self = shift; |
| 52 |
my $DEFAULT = Message::Util::make_clone (\%DEFAULT); |
| 53 |
my %option = @_; |
| 54 |
$self->SUPER::_init (%$DEFAULT, %option); |
| 55 |
$self->{option}->{value_type}->{body_part} |
| 56 |
= [@{ $Message::MIME::MediaType::type{message}->{rfc822}->{handler} }]; |
| 57 |
} |
| 58 |
|
| 59 |
=item $body = Message::Body::Multipart->new ([%options]) |
| 60 |
|
| 61 |
Constructs a new object. You might pass some options as parameters |
| 62 |
to the constructor. |
| 63 |
|
| 64 |
=cut |
| 65 |
|
| 66 |
## Inherited |
| 67 |
|
| 68 |
=item $body = Message::Body::Multipart->parse ($body, [%options]) |
| 69 |
|
| 70 |
Constructs a new object with given field body. You might pass |
| 71 |
some options as parameters to the constructor. |
| 72 |
|
| 73 |
=cut |
| 74 |
|
| 75 |
sub parse ($$;%) { |
| 76 |
my $class = shift; |
| 77 |
my $self = bless {}, $class; |
| 78 |
my $body = shift; |
| 79 |
$self->_init (@_); |
| 80 |
my $nl = "\x0D\x0A"; |
| 81 |
unless ($self->{option}->{linebreak_strict}) { |
| 82 |
$nl = Message::Util::decide_newline ($body); |
| 83 |
} |
| 84 |
## Split the body |
| 85 |
$body = $nl . $body if $body =~ /^-{70,70}$nl/s; |
| 86 |
($self->{preamble}, $body) = split /(?<=$nl)-{70,70}$nl$nl/s, $body, 2; |
| 87 |
$body = $nl . $body if $body =~ /^-{30,30}$nl/s; |
| 88 |
$self->{value} = [ split /(?!=$nl)$nl-{30,30}$nl$nl/, $body ]; |
| 89 |
if ($self->{value}->[-1] =~ /^End of(.+?)Digest(.*?)$nl\*+(?:$nl)*$/is) { |
| 90 |
($self->{list_name}, $self->{digest_info}) = ($1, $2); |
| 91 |
$self->{list_name} =~ s/^\s+//; $self->{list_name} =~ s/\s+$//; |
| 92 |
$self->{digest_info} =~ s/^\s+//; $self->{digest_info} =~ s/\s+$//; |
| 93 |
pop @{ $self->{value} }; |
| 94 |
} |
| 95 |
|
| 96 |
if ($self->{option}->{parse_all}) { |
| 97 |
$self->{value} = [ map { |
| 98 |
$self->_parse_value (body_part => $_); |
| 99 |
} @{ $self->{value} } ]; |
| 100 |
$self->{preamble} = $self->_parse_value (preamble => $self->{preamble}); |
| 101 |
} |
| 102 |
$self; |
| 103 |
} |
| 104 |
|
| 105 |
=back |
| 106 |
|
| 107 |
=cut |
| 108 |
|
| 109 |
## add, item, delete, count |
| 110 |
|
| 111 |
## entity_header: Inherited |
| 112 |
|
| 113 |
sub preamble ($;$) { |
| 114 |
my $self = shift; |
| 115 |
my $np = shift; |
| 116 |
if (defined $np) { |
| 117 |
$np = $self->_parse_value (preamble => $np) if $self->{option}->{parse_all}; |
| 118 |
$self->{preamble} = $np; |
| 119 |
} |
| 120 |
$self->{preamble}; |
| 121 |
} |
| 122 |
sub list_name ($;$) { |
| 123 |
my $self = shift; |
| 124 |
my $np = shift; |
| 125 |
if (defined $np) { |
| 126 |
$self->{list_name} = $np; |
| 127 |
} |
| 128 |
$self->{list_name}; |
| 129 |
} |
| 130 |
sub digest_info ($;$) { |
| 131 |
my $self = shift; |
| 132 |
my $np = shift; |
| 133 |
if (defined $np) { |
| 134 |
$self->{digest_info} = $np; |
| 135 |
} |
| 136 |
$self->{digest_info}; |
| 137 |
} |
| 138 |
|
| 139 |
=head2 $self->stringify ([%option]) |
| 140 |
|
| 141 |
Returns the C<body> as a string. |
| 142 |
|
| 143 |
=cut |
| 144 |
|
| 145 |
sub stringify ($;%) { |
| 146 |
my $self = shift; |
| 147 |
my %o = @_; my %option = %{$self->{option}}; |
| 148 |
for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}} |
| 149 |
$self->_delete_empty; |
| 150 |
## Check the number of parts |
| 151 |
my $min = $option{parts_min} || 1; $min--; |
| 152 |
$#{ $self->{value} } = $min unless $min <= $#{ $self->{value} }; |
| 153 |
my $max = $option{parts_max} || $#{$self->{value}}+1; $max--; |
| 154 |
$max = $#{$self->{value}} if $max > $#{$self->{value}}; |
| 155 |
## Make trailer |
| 156 |
my $trailer = sprintf 'End of %s Digest%s', |
| 157 |
(length $self->{list_name}? $self->{list_name}: 'list'), |
| 158 |
(length $self->{digest_info}? ' '.$self->{digest_info}:''); |
| 159 |
$trailer .= "\x0D\x0A" . ('*' x length $trailer) . "\x0D\x0A"; |
| 160 |
## Preparates parts |
| 161 |
my @parts = map { ''. $_ } @{ $self->{value} }[0..$max]; |
| 162 |
push @parts, $trailer; |
| 163 |
my $preamble = ''.$self->{preamble}; |
| 164 |
|
| 165 |
if (ref $self->{header}) { |
| 166 |
my $ct = $self->{header}->field ('content-type'); |
| 167 |
if (ref $self->{preamble}) { |
| 168 |
unless (ref $self->{preamble}->entity_header) { |
| 169 |
$self->{preamble}->entity_header (new Message::Header -format => 'mail-rfc822'); |
| 170 |
} |
| 171 |
my $pct = $self->{preamble}->entity_header->field ('content-type', -new_item_unless_exist => 0); |
| 172 |
$ct->replace ('x-preamble-type' => $pct) |
| 173 |
if $pct && $pct ne 'text/plain; charset=us-ascii'; |
| 174 |
} |
| 175 |
} |
| 176 |
|
| 177 |
$preamble =~ s/^-{70,70}\x0D?$/"\x20".('-' x 69)/gem; |
| 178 |
$preamble .= "\x0D\x0A" unless $preamble =~ /\x0D\x0A$/s; |
| 179 |
|
| 180 |
$preamble |
| 181 |
."----------------------------------------------------------------------\x0D\x0A" |
| 182 |
."\x0D\x0A" |
| 183 |
.join "\x0D\x0A------------------------------\x0D\x0A\x0D\x0A", |
| 184 |
map { s/^-{30,30}\x0D?$/"\x20".('-' x 29)/gem; |
| 185 |
$_ .= "\x0D\x0A" unless /\x0D\x0A$/s; $_ } @parts; |
| 186 |
} |
| 187 |
*as_string = \&stringify; |
| 188 |
|
| 189 |
## Inherited: option, clone |
| 190 |
|
| 191 |
|
| 192 |
=head1 SEE ALSO |
| 193 |
|
| 194 |
RFC 1153 E<lt>urn:ietf:rfc:1153> |
| 195 |
|
| 196 |
=head1 LICENSE |
| 197 |
|
| 198 |
Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>. |
| 199 |
|
| 200 |
This program is free software; you can redistribute it and/or modify |
| 201 |
it under the terms of the GNU General Public License as published by |
| 202 |
the Free Software Foundation; either version 2 of the License, or |
| 203 |
(at your option) any later version. |
| 204 |
|
| 205 |
This program is distributed in the hope that it will be useful, |
| 206 |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 207 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 208 |
GNU General Public License for more details. |
| 209 |
|
| 210 |
You should have received a copy of the GNU General Public License |
| 211 |
along with this program; see the file COPYING. If not, write to |
| 212 |
the Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
| 213 |
Boston, MA 02111-1307, USA. |
| 214 |
|
| 215 |
=head1 CHANGE |
| 216 |
|
| 217 |
See F<ChangeLog>. |
| 218 |
$Date: 2002/07/20 03:09:29 $ |
| 219 |
|
| 220 |
=cut |
| 221 |
|
| 222 |
1; |
Parent Directory
| 
Revision Log