Message/Body/Text.pm


=head1 NAME

Message::Body::Text --- Perl Module for Internet Media Types "text/*"

=cut

package Message::Body::Text;
use strict;
use vars qw(%DEFAULT @ISA %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

require Message::Field::Structured;
push @ISA, qw(Message::Field::Structured);
require Message::Header;
require Message::MIME::Charset;
use overload '""' => sub { $_[0]->stringify },
             fallback => 1;
%REG = %Message::Util::REG;

%DEFAULT = (
  -_METHODS     => [qw|value|],
  -_MEMBERS     => [qw|_charset|],
        ## header -- Don't clone
  -body_default_charset => 'iso-2022-int-1',
  -body_default_charset_input   => 'iso-2022-int-1',
  -check_msmime => 1,
  -hook_encode_string   => \&Message::Util::encode_body_string,
  -hook_decode_string   => \&Message::Util::decode_body_string,
  #internal_charset_name
  -media_type   => 'text',
  -media_subtype        => 'plain',
  -parse_all    => 0,
  -use_normalization    => 0,
  -use_param_charset    => 0,
);

=head1 CONSTRUCTORS

The following methods construct new C<Message::Field::Structured> objects:

=over 4

=cut

## Initialize of this class -- called by constructors
sub _init ($;%) {
  my $self = shift;
  my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
  my %option = @_;
  $self->SUPER::_init (%$DEFAULT, %option);
  
  if (ref $option{entity_header}) {
    $self->{header} = $option{entity_header};
  }
  my $mt = $self->{option}->{media_type};
  my $mst = $self->{option}->{media_subtype};
  my $mt_def = $Message::MIME::MediaType::type{$mt}->{$mst};
  $mt_def = $Message::MIME::MediaType::type{$mt}->{'/default'} unless ref $mt_def;
  $mt_def = $Message::MIME::MediaType::type{'/default'}->{'/default'}
    unless ref $mt_def;
    if ($self->{option}->{format} =~ /http/) {
      $self->{option}->{use_normalization} = 0;
    } else {
      $self->{option}->{use_normalization} = 1;
    }
  if ($mt_def->{mime_charset}) {
    $self->{option}->{use_param_charset} = 1;
    if ($self->{option}->{format} =~ /http/) {
      $self->{option}->{body_default_charset} = 'iso-8859-1';
      $self->{option}->{body_default_charset_input} = 'iso-8859-1';
    } elsif ($self->{option}->{format} =~ /news-usefor|sip/) {
      $self->{option}->{body_default_charset} = 'utf-8';
      $self->{option}->{body_default_charset_input} = 'utf-8';
    } else {
      #$self->{option}->{body_default_charset} = 'iso-2022-int-1';
      #$self->{option}->{body_default_charset_input} = 'iso-2022-int-1';
    }
  }
  if ($mt_def->{default_charset}) {
    $self->{option}->{body_default_charset} = $mt_def->{default_charset};
  }
}

=item $body = Message::Body::TextPlain->new ([%options])

Constructs a new object.  You might pass some options as parameters 
to the constructor.

=cut

## Inherited

=item $body = Message::Body::TextPlain->parse ($body, [%options])

Constructs a new object with given field body.  You might pass 
some options as parameters to the constructor.

=cut

sub parse ($$;%) {
  my $class = shift;
  my $self = bless {}, $class;
  my $body = shift;
  $self->_init (@_);
  $self->_parse ($body);
  $self;
}

sub _parse ($$) {
  my $self = shift;
  my $body = shift;
  my $charset;
  if ($self->{option}->{use_param_charset}) {
    my $ct;
    $ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0) 
      if ref $self->{header};
    $charset = $ct->parameter ('charset', -new_item_unless_exist => 0) if ref $ct;
    if ($charset && $self->{option}->{check_msmime}) {
      my $msmime;
      $msmime = $self->{header}->field ('x-mimeole', -new_item_unless_exist => 0) 
        if ref $self->{header};
      $msmime = $msmime =~ /Microsoft MimeOLE/i;
      $charset = Message::MIME::Charset::msname2iananame ($charset) if $msmime;
    }
  }
  unless ($charset) {
    $charset = $self->{option}->{encoding_before_decode};
  }
  my %s = &{$self->{option}->{hook_decode_string}} ($self, $body,
    type => 'body', charset => $charset);
  $self->{value} = $s{value};
  $self->{_charset} = $s{charset};      ## In case convertion failed
  $self->{_charset} = $self->{option}->{body_default_charset_input}
    if !$s{charset} && !$s{success};
}

=back

=cut

=item $body->header ([$new_header])


=cut

sub entity_header ($;$) {
  my $self = shift;
  my $new_header = shift;
  if (ref $new_header) {
    $self->{header} = $new_header;
  }
  $self->{header};
}

=item $body->value ([$new_body])

Returns C<body> as string unless $new_body.
Set $new_body instead of current C<body>.

=cut

sub value ($;$) {
  my $self = shift;
  my $new_body = shift;
  if ($new_body) {
    $self->{value} = $new_body;
  }
  $self->{value};
}

=head2 $self->stringify ([%option])

Returns the C<body> as a string.

=cut

sub stringify ($;%) {
  my $self = shift;
  my %o = @_;  my %option = %{$self->{option}};
  for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
  my $v = $self->_prep_stringify ($self->{value}, \%option);
  my $ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0)
    if ref $self->{header};
  unless ($option{use_param_charset}) {
    if ($option{use_normalization}) {
        $v =~ s/\x0D(?!\x0A)/\x0D\x0A/gs;
        $v =~ s/(?<!\x0D)\x0A/\x0D\x0A/gs;
        #$v .= "\x0D\x0A" unless $v =~ /\x0D\x0A$/s;
    }
    return $v;
  }
  my %e;
  unless ($self->{_charset}) {
    my $charset;
    if ($option{use_param_charset}) {
      $charset = $ct->parameter ('*charset-to-be', -new_item_unless_exist => 0) if ref $ct;
      $charset = $ct->parameter ('charset', -new_item_unless_exist => 0) if !$charset && ref $ct;
    }
    $charset ||= $option{encoding_after_encode};
    (%e) = &{$option{hook_encode_string}} ($self, $v,
      type => 'body', charset => $charset);
    $e{charset} ||= $self->{option}->{internal_charset_name} if $e{failed};
    ## Normalize
    if ($option{use_normalization}) {
      if ($Message::MIME::Charset::CHARSET{ $charset }->{mime_text}) {
        $e{value} =~ s/\x0D(?!\x0A)/\x0D\x0A/gs;
        $e{value} =~ s/(?<!\x0D)\x0A/\x0D\x0A/gs;
        #$e{value} .= "\x0D\x0A" unless $e{value} =~ /\x0D\x0A$/s;
      }
    }
  } else {      ## if $self->{_charset},
    %e = (value => $v, charset => $self->{_charset});
  }
  if (ref $self->{header}) {
    unless (ref $ct) {
      $ct = $self->{header}->field ('content-type');
      $ct->value ($option{parent_type});
    }
    if ($e{charset}) {
      $ct->replace (charset => $e{charset});
    } else {
      $ct->replace (Message::MIME::Charset::name_minimumize
                    ($option{body_default_charset}, $e{value}));
    }
  }
  $e{value};
}
*as_string = \&stringify;

## $self->_prep_stringify ($value, \%option)
sub _prep_stringify ($$\%) {
  my $self = shift;
  shift;
}

## Inherited: option, clone

=head1 SEE ALSO

RFC 822 <urn:ietf:rfc:822>,
RFC 2046 <urn:ietf:rfc:2046>, RFC 2646 <urn:ietf:rfc:2646>.

=head1 LICENSE

Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.

=head1 CHANGE

See F<ChangeLog>.
$Date: 2002/07/21 03:23:50 $

=cut

1;
1
2	=head1 NAME
3
4	Message::Body::Text --- Perl Module for Internet Media Types "text/*"
5
6	=cut
7
8	package Message::Body::Text;
9	use strict;
10	use vars qw(%DEFAULT @ISA %REG $VERSION);
11	$VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
12
13	require Message::Field::Structured;
14	push @ISA, qw(Message::Field::Structured);
15	require Message::Header;
16	require Message::MIME::Charset;
17	use overload '""' => sub { $_[0]->stringify },
18	fallback => 1;
19	%REG = %Message::Util::REG;
20
21	%DEFAULT = (
22	-_METHODS => [qw\|value\|],
23	-_MEMBERS => [qw\|_charset\|],
24	## header -- Don't clone
25	-body_default_charset => 'iso-2022-int-1',
26	-body_default_charset_input => 'iso-2022-int-1',
27	-check_msmime => 1,
28	-hook_encode_string => \&Message::Util::encode_body_string,
29	-hook_decode_string => \&Message::Util::decode_body_string,
30	#internal_charset_name
31	-media_type => 'text',
32	-media_subtype => 'plain',
33	-parse_all => 0,
34	-use_normalization => 0,
35	-use_param_charset => 0,
36	);
37
38	=head1 CONSTRUCTORS
39
40	The following methods construct new C<Message::Field::Structured> objects:
41
42	=over 4
43
44	=cut
45
46	## Initialize of this class -- called by constructors
47	sub _init ($;%) {
48	my $self = shift;
49	my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
50	my %option = @_;
51	$self->SUPER::_init (%$DEFAULT, %option);
52
53	if (ref $option{entity_header}) {
54	$self->{header} = $option{entity_header};
55	}
56	my $mt = $self->{option}->{media_type};
57	my $mst = $self->{option}->{media_subtype};
58	my $mt_def = $Message::MIME::MediaType::type{$mt}->{$mst};
59	$mt_def = $Message::MIME::MediaType::type{$mt}->{'/default'} unless ref $mt_def;
60	$mt_def = $Message::MIME::MediaType::type{'/default'}->{'/default'}
61	unless ref $mt_def;
62	if ($self->{option}->{format} =~ /http/) {
63	$self->{option}->{use_normalization} = 0;
64	} else {
65	$self->{option}->{use_normalization} = 1;
66	}
67	if ($mt_def->{mime_charset}) {
68	$self->{option}->{use_param_charset} = 1;
69	if ($self->{option}->{format} =~ /http/) {
70	$self->{option}->{body_default_charset} = 'iso-8859-1';
71	$self->{option}->{body_default_charset_input} = 'iso-8859-1';
72	} elsif ($self->{option}->{format} =~ /news-usefor\|sip/) {
73	$self->{option}->{body_default_charset} = 'utf-8';
74	$self->{option}->{body_default_charset_input} = 'utf-8';
75	} else {
76	#$self->{option}->{body_default_charset} = 'iso-2022-int-1';
77	#$self->{option}->{body_default_charset_input} = 'iso-2022-int-1';
78	}
79	}
80	if ($mt_def->{default_charset}) {
81	$self->{option}->{body_default_charset} = $mt_def->{default_charset};
82	}
83	}
84
85	=item $body = Message::Body::TextPlain->new ([%options])
86
87	Constructs a new object. You might pass some options as parameters
88	to the constructor.
89
90	=cut
91
92	## Inherited
93
94	=item $body = Message::Body::TextPlain->parse ($body, [%options])
95
96	Constructs a new object with given field body. You might pass
97	some options as parameters to the constructor.
98
99	=cut
100
101	sub parse ($$;%) {
102	my $class = shift;
103	my $self = bless {}, $class;
104	my $body = shift;
105	$self->_init (@_);
106	$self->_parse ($body);
107	$self;
108	}
109
110	sub _parse ($$) {
111	my $self = shift;
112	my $body = shift;
113	my $charset;
114	if ($self->{option}->{use_param_charset}) {
115	my $ct;
116	$ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0)
117	if ref $self->{header};
118	$charset = $ct->parameter ('charset', -new_item_unless_exist => 0) if ref $ct;
119	if ($charset && $self->{option}->{check_msmime}) {
120	my $msmime;
121	$msmime = $self->{header}->field ('x-mimeole', -new_item_unless_exist => 0)
122	if ref $self->{header};
123	$msmime = $msmime =~ /Microsoft MimeOLE/i;
124	$charset = Message::MIME::Charset::msname2iananame ($charset) if $msmime;
125	}
126	}
127	unless ($charset) {
128	$charset = $self->{option}->{encoding_before_decode};
129	}
130	my %s = &{$self->{option}->{hook_decode_string}} ($self, $body,
131	type => 'body', charset => $charset);
132	$self->{value} = $s{value};
133	$self->{_charset} = $s{charset}; ## In case convertion failed
134	$self->{_charset} = $self->{option}->{body_default_charset_input}
135	if !$s{charset} && !$s{success};
136	}
137
138	=back
139
140	=cut
141
142	=item $body->header ([$new_header])
143
144
145	=cut
146
147	sub entity_header ($;$) {
148	my $self = shift;
149	my $new_header = shift;
150	if (ref $new_header) {
151	$self->{header} = $new_header;
152	}
153	$self->{header};
154	}
155
156	=item $body->value ([$new_body])
157
158	Returns C<body> as string unless $new_body.
159	Set $new_body instead of current C<body>.
160
161	=cut
162
163	sub value ($;$) {
164	my $self = shift;
165	my $new_body = shift;
166	if ($new_body) {
167	$self->{value} = $new_body;
168	}
169	$self->{value};
170	}
171
172	=head2 $self->stringify ([%option])
173
174	Returns the C<body> as a string.
175
176	=cut
177
178	sub stringify ($;%) {
179	my $self = shift;
180	my %o = @_; my %option = %{$self->{option}};
181	for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
182	my $v = $self->_prep_stringify ($self->{value}, \%option);
183	my $ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0)
184	if ref $self->{header};
185	unless ($option{use_param_charset}) {
186	if ($option{use_normalization}) {
187	$v =~ s/\x0D(?!\x0A)/\x0D\x0A/gs;
188	$v =~ s/(?<!\x0D)\x0A/\x0D\x0A/gs;
189	#$v .= "\x0D\x0A" unless $v =~ /\x0D\x0A$/s;
190	}
191	return $v;
192	}
193	my %e;
194	unless ($self->{_charset}) {
195	my $charset;
196	if ($option{use_param_charset}) {
197	$charset = $ct->parameter ('*charset-to-be', -new_item_unless_exist => 0) if ref $ct;
198	$charset = $ct->parameter ('charset', -new_item_unless_exist => 0) if !$charset && ref $ct;
199	}
200	$charset \|\|= $option{encoding_after_encode};
201	(%e) = &{$option{hook_encode_string}} ($self, $v,
202	type => 'body', charset => $charset);
203	$e{charset} \|\|= $self->{option}->{internal_charset_name} if $e{failed};
204	## Normalize
205	if ($option{use_normalization}) {
206	if ($Message::MIME::Charset::CHARSET{ $charset }->{mime_text}) {
207	$e{value} =~ s/\x0D(?!\x0A)/\x0D\x0A/gs;
208	$e{value} =~ s/(?<!\x0D)\x0A/\x0D\x0A/gs;
209	#$e{value} .= "\x0D\x0A" unless $e{value} =~ /\x0D\x0A$/s;
210	}
211	}
212	} else { ## if $self->{_charset},
213	%e = (value => $v, charset => $self->{_charset});
214	}
215	if (ref $self->{header}) {
216	unless (ref $ct) {
217	$ct = $self->{header}->field ('content-type');
218	$ct->value ($option{parent_type});
219	}
220	if ($e{charset}) {
221	$ct->replace (charset => $e{charset});
222	} else {
223	$ct->replace (Message::MIME::Charset::name_minimumize
224	($option{body_default_charset}, $e{value}));
225	}
226	}
227	$e{value};
228	}
229	*as_string = \&stringify;
230
231	## $self->_prep_stringify ($value, \%option)
232	sub _prep_stringify ($$\%) {
233	my $self = shift;
234	shift;
235	}
236
237	## Inherited: option, clone
238
239	=head1 SEE ALSO
240
241	RFC 822 <urn:ietf:rfc:822>,
242	RFC 2046 <urn:ietf:rfc:2046>, RFC 2646 <urn:ietf:rfc:2646>.
243
244	=head1 LICENSE
245
246	Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
247
248	This program is free software; you can redistribute it and/or modify
249	it under the terms of the GNU General Public License as published by
250	the Free Software Foundation; either version 2 of the License, or
251	(at your option) any later version.
252
253	This program is distributed in the hope that it will be useful,
254	but WITHOUT ANY WARRANTY; without even the implied warranty of
255	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
256	GNU General Public License for more details.
257
258	You should have received a copy of the GNU General Public License
259	along with this program; see the file COPYING. If not, write to
260	the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
261	Boston, MA 02111-1307, USA.
262
263	=head1 CHANGE
264
265	See F<ChangeLog>.
266	$Date: 2002/07/21 03:23:50 $
267
268	=cut
269
270	1;