Message/Body/TextPlain.pm


=head1 NAME

Message::Body::TextPlain --- Perl Module for Internet Media Type "text/plain"

=cut

package Message::Body::TextPlain;
use strict;
use vars qw(%DEFAULT @ISA $VERSION);
$VERSION=do{my @r=(q$Revision: 1.4 $=~/\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;

  %DEFAULT = (
    -_METHODS   => [qw|value|],
    -_MEDIA_TYPE        => 'text/plain',
    -_MEMBERS   => [qw|_charset|],
    -body_default_charset       => 'us-ascii',
    -body_default_charset_input => 'iso-2022-int-1',
    #encoding_after_encode
    #encoding_before_decode
    -hook_encode_string => \&Message::Util::encode_body_string,
    -hook_decode_string => \&Message::Util::decode_body_string,
    -parse_all  => 0,
    -use_normalization  => 1,
    -use_param_charset  => 1,
  );

=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{header}) {
    $self->{header} = $option{header};
  }
  if ($self->{option}->{format} =~ /http/) {
    $self->{option}->{use_normalization} = 0;
  }
}

=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 (@_);
  my $charset;
  my $ct; $ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0) 
    if ref $self->{header};
  $charset = $ct->parameter ('charset') if ref $ct;
  $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};      ## When convertion failed
  $self;
}

=back

=cut

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


=cut

sub header ($;$) {
  my $self = shift;
  my $new_header = shift;
  if (ref $new_header) {
    $self->{header} = $new_header;
  #} elsif ($new_header) {
  #  $self->{header} = Message::Header->parse ($new_header);
  }
  #unless ($self->{header}) {
  #  $self->{header} = new Message::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 $ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0)
    if ref $self->{header};
  my %e;
  unless ($self->{_charset}) {
    my $charset; $charset = $ct->parameter ('charset') if ref $ct;
    $charset ||= $self->{option}->{encoding_after_encode};
    (%e) = &{$self->{option}->{hook_encode_string}} ($self, 
          $self->{value}, type => 'body',
          charset => $charset);
    #$e{charset} ||= $self->{option}->{body_default_charset}
    #  if $self->{option}->{body_default_charset_input}
    #     ne $self->{option}->{body_default_charset};
    ## Normalize
    if ($option{use_normalization}) {
      if ($Message::MIME::Charset::CHARSET{$charset || '*default'}->{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 {
    %e = (value => $self->{value}, charset => $self->{_charset});
  }
  if (ref $self->{header}) {
    if ($e{charset}) {
      unless (ref $ct) {
        $ct = $self->{header}->field ('content-type');
        $ct->value ($option{_MEDIA_TYPE});
      }
      $ct->replace (charset => $e{charset});
    } elsif (ref $ct) {
      $ct->replace (charset => $self->{option}->{body_default_charset});
    }
  }
  $e{value};
}
*as_string = \&stringify;

=head2 $self->option ($option_name)

Returns/set (new) value of the option.

=cut

## 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/05/29 11:05:53 $

=cut

1;
1
2	=head1 NAME
3
4	Message::Body::TextPlain --- Perl Module for Internet Media Type "text/plain"
5
6	=cut
7
8	package Message::Body::TextPlain;
9	use strict;
10	use vars qw(%DEFAULT @ISA $VERSION);
11	$VERSION=do{my @r=(q$Revision: 1.4 $=~/\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
20	%DEFAULT = (
21	-_METHODS => [qw\|value\|],
22	-_MEDIA_TYPE => 'text/plain',
23	-_MEMBERS => [qw\|_charset\|],
24	-body_default_charset => 'us-ascii',
25	-body_default_charset_input => 'iso-2022-int-1',
26	#encoding_after_encode
27	#encoding_before_decode
28	-hook_encode_string => \&Message::Util::encode_body_string,
29	-hook_decode_string => \&Message::Util::decode_body_string,
30	-parse_all => 0,
31	-use_normalization => 1,
32	-use_param_charset => 1,
33	);
34
35	=head1 CONSTRUCTORS
36
37	The following methods construct new C<Message::Field::Structured> objects:
38
39	=over 4
40
41	=cut
42
43	## Initialize of this class -- called by constructors
44	sub _init ($;%) {
45	my $self = shift;
46	my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
47	my %option = @_;
48	$self->SUPER::_init (%$DEFAULT, %option);
49
50	if (ref $option{header}) {
51	$self->{header} = $option{header};
52	}
53	if ($self->{option}->{format} =~ /http/) {
54	$self->{option}->{use_normalization} = 0;
55	}
56	}
57
58	=item $body = Message::Body::TextPlain->new ([%options])
59
60	Constructs a new object. You might pass some options as parameters
61	to the constructor.
62
63	=cut
64
65	## Inherited
66
67	=item $body = Message::Body::TextPlain->parse ($body, [%options])
68
69	Constructs a new object with given field body. You might pass
70	some options as parameters to the constructor.
71
72	=cut
73
74	sub parse ($$;%) {
75	my $class = shift;
76	my $self = bless {}, $class;
77	my $body = shift;
78	$self->_init (@_);
79	my $charset;
80	my $ct; $ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0)
81	if ref $self->{header};
82	$charset = $ct->parameter ('charset') if ref $ct;
83	$charset \|\|= $self->{option}->{encoding_before_decode};
84	my %s = &{$self->{option}->{hook_decode_string}} ($self, $body,
85	type => 'body', charset => $charset);
86	$self->{value} = $s{value};
87	$self->{_charset} = $s{charset}; ## When convertion failed
88	$self;
89	}
90
91	=back
92
93	=cut
94
95	=item $body->header ([$new_header])
96
97
98	=cut
99
100	sub header ($;$) {
101	my $self = shift;
102	my $new_header = shift;
103	if (ref $new_header) {
104	$self->{header} = $new_header;
105	#} elsif ($new_header) {
106	# $self->{header} = Message::Header->parse ($new_header);
107	}
108	#unless ($self->{header}) {
109	# $self->{header} = new Message::Header;
110	#}
111	$self->{header};
112	}
113
114	=item $body->value ([$new_body])
115
116	Returns C<body> as string unless $new_body.
117	Set $new_body instead of current C<body>.
118
119	=cut
120
121	sub value ($;$) {
122	my $self = shift;
123	my $new_body = shift;
124	if ($new_body) {
125	$self->{value} = $new_body;
126	}
127	$self->{value};
128	}
129
130	=head2 $self->stringify ([%option])
131
132	Returns the C<body> as a string.
133
134	=cut
135
136	sub stringify ($;%) {
137	my $self = shift;
138	my %o = @_; my %option = %{$self->{option}};
139	for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
140	my $ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0)
141	if ref $self->{header};
142	my %e;
143	unless ($self->{_charset}) {
144	my $charset; $charset = $ct->parameter ('charset') if ref $ct;
145	$charset \|\|= $self->{option}->{encoding_after_encode};
146	(%e) = &{$self->{option}->{hook_encode_string}} ($self,
147	$self->{value}, type => 'body',
148	charset => $charset);
149	#$e{charset} \|\|= $self->{option}->{body_default_charset}
150	# if $self->{option}->{body_default_charset_input}
151	# ne $self->{option}->{body_default_charset};
152	## Normalize
153	if ($option{use_normalization}) {
154	if ($Message::MIME::Charset::CHARSET{$charset \|\| '*default'}->{mime_text}) {
155	$e{value} =~ s/\x0D(?!\x0A)/\x0D\x0A/gs;
156	$e{value} =~ s/(?<!\x0D)\x0A/\x0D\x0A/gs;
157	$e{value} .= "\x0D\x0A" unless $e{value} =~ /\x0D\x0A$/s;
158	}
159	}
160	} else {
161	%e = (value => $self->{value}, charset => $self->{_charset});
162	}
163	if (ref $self->{header}) {
164	if ($e{charset}) {
165	unless (ref $ct) {
166	$ct = $self->{header}->field ('content-type');
167	$ct->value ($option{_MEDIA_TYPE});
168	}
169	$ct->replace (charset => $e{charset});
170	} elsif (ref $ct) {
171	$ct->replace (charset => $self->{option}->{body_default_charset});
172	}
173	}
174	$e{value};
175	}
176	*as_string = \&stringify;
177
178	=head2 $self->option ($option_name)
179
180	Returns/set (new) value of the option.
181
182	=cut
183
184	## Inherited: option, clone
185
186	=head1 SEE ALSO
187
188	RFC 822 <urn:ietf:rfc:822>,
189	RFC 2046 <urn:ietf:rfc:2046>, RFC 2646 <urn:ietf:rfc:2646>.
190
191	=head1 LICENSE
192
193	Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
194
195	This program is free software; you can redistribute it and/or modify
196	it under the terms of the GNU General Public License as published by
197	the Free Software Foundation; either version 2 of the License, or
198	(at your option) any later version.
199
200	This program is distributed in the hope that it will be useful,
201	but WITHOUT ANY WARRANTY; without even the implied warranty of
202	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
203	GNU General Public License for more details.
204
205	You should have received a copy of the GNU General Public License
206	along with this program; see the file COPYING. If not, write to
207	the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
208	Boston, MA 02111-1307, USA.
209
210	=head1 CHANGE
211
212	See F<ChangeLog>.
213	$Date: 2002/05/29 11:05:53 $
214
215	=cut
216
217	1;