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.12 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

require Message::Body::Text;
push @ISA, qw(Message::Body::Text);

%DEFAULT = (
  -_METHODS     => [qw|value|],
  -_MEMBERS     => [qw|_charset|],
  -body_default_charset => 'iso-2022-int-1',
  -body_default_charset_input   => 'iso-2022-int-1',
  -check_msmime => 1,
  #encoding_after_encode
  #encoding_before_decode
  #fill_ct      => 0,
  #hook_encode_string
  #hook_decode_string
  #internal_charset_name
  -media_type   => 'text',
  -media_subtype        => 'plain',
  -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);
  
  unless (defined $self->{option}->{fill_ct}) {
    $self->{option}->{fill_ct} = $self->{option}->{format} =~ /rfc2822|news-usefor|http|mime|news-son-of-rfc1036/;
  }
    if ($self->{option}->{format} =~ /http/) {
      $self->{option}->{use_normalization} = 0;
    } else {
      $self->{option}->{use_normalization} = 1;
    }
}

=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;
    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;
    }
  $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->{_charset} = $self->{option}->{body_default_charset_input}
    if !$s{charset} && !$s{success};
  $self;
}

=back

=cut

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


=cut

## Inherited

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

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

=cut

## Inherited

=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-to-be', -new_item_unless_exist => 0) if ref $ct;
    $charset = $ct->parameter ('charset', -new_item_unless_exist => 0) if !$charset && 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}->{internal_charset_name} if $e{failed};
    ## 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}.'/'.$option{media_subtype});
      }
      $ct->replace (charset => $e{charset});
    } elsif (ref $ct) {
      $ct->replace (Message::MIME::Charset::name_minimumize ($option{body_default_charset}, $e{value}));
    } elsif ($option{fill_ct}) {
      $ct = $self->{header}->field ('content-type');
      $ct->media_type_major ($option{media_type});
      $ct->media_type_minor ($option{media_subtype});
      $ct->replace (Message::MIME::Charset::name_minimumize ($option{body_default_charset}, $e{value}));
    }
  }
  $e{value};
}
*as_string = \&stringify;

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