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.2 $=~/\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
  -default_charset      => 'us-ascii',
  -hook_encode_string   => \&Message::Util::encode_body_string,
  -hook_decode_string   => \&Message::Util::decode_body_string,
  -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}->{default_charset} = 'iso-8859-1';
    } elsif ($self->{option}->{format} =~ /news-usefor|sip/) {
      $self->{option}->{default_charset} = 'utf-8';
    } else {
      $self->{option}->{default_charset} = 'us-ascii';
    }
  }
  if ($mt_def->{default_charset}) {
    $self->{option}->{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;
  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}->{default_charset};
  my %s = &{$self->{option}->{hook_decode_string}} ($self, $body,
    type => 'body', charset => $charset);
  $self->{value} = $s{value};
  $self->{_charset} = $s{charset};      ## When convertion failed
}

=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;
  #} 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 $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; $charset = $ct->parameter ('charset') if ref $ct;
    $charset ||= $option{default_charset};
    (%e) = &{$option{hook_encode_string}} ($self, $v,
      type => 'body', charset => $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 {      ## 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});
    }
    $ct->replace (charset => ($e{charset} || $option{default_charset}));
  }
  $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/06/16 10:44:08 $

=cut

1;
1	wakaba	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	wakaba	1.3	$VERSION=do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
12	wakaba	1.1
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			-default_charset => 'us-ascii',
26			-hook_encode_string => \&Message::Util::encode_body_string,
27			-hook_decode_string => \&Message::Util::decode_body_string,
28			-media_type => 'text',
29			-media_subtype => 'plain',
30			-parse_all => 0,
31			-use_normalization => 0,
32			-use_param_charset => 0,
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{entity_header}) {
51			$self->{header} = $option{entity_header};
52			}
53			my $mt = $self->{option}->{media_type};
54			my $mst = $self->{option}->{media_subtype};
55			my $mt_def = $Message::MIME::MediaType::type{$mt}->{$mst};
56			$mt_def = $Message::MIME::MediaType::type{$mt}->{'/default'} unless ref $mt_def;
57			$mt_def = $Message::MIME::MediaType::type{'/default'}->{'/default'}
58			unless ref $mt_def;
59			if ($self->{option}->{format} =~ /http/) {
60			$self->{option}->{use_normalization} = 0;
61			} else {
62			$self->{option}->{use_normalization} = 1;
63			}
64			if ($mt_def->{mime_charset}) {
65			$self->{option}->{use_param_charset} = 1;
66			if ($self->{option}->{format} =~ /http/) {
67			$self->{option}->{default_charset} = 'iso-8859-1';
68	wakaba	1.3	} elsif ($self->{option}->{format} =~ /news-usefor\|sip/) {
69			$self->{option}->{default_charset} = 'utf-8';
70	wakaba	1.1	} else {
71			$self->{option}->{default_charset} = 'us-ascii';
72			}
73			}
74			if ($mt_def->{default_charset}) {
75			$self->{option}->{default_charset} = $mt_def->{default_charset};
76			}
77			}
78
79			=item $body = Message::Body::TextPlain->new ([%options])
80
81			Constructs a new object. You might pass some options as parameters
82			to the constructor.
83
84			=cut
85
86			## Inherited
87
88			=item $body = Message::Body::TextPlain->parse ($body, [%options])
89
90			Constructs a new object with given field body. You might pass
91			some options as parameters to the constructor.
92
93			=cut
94
95			sub parse ($$;%) {
96			my $class = shift;
97			my $self = bless {}, $class;
98			my $body = shift;
99			$self->_init (@_);
100			$self->_parse ($body);
101			$self;
102			}
103
104			sub _parse ($$) {
105			my $self = shift;
106			my $body = shift;
107			my $charset;
108			my $ct; $ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0)
109			if ref $self->{header};
110			$charset = $ct->parameter ('charset') if ref $ct;
111			$charset \|\|= $self->{option}->{default_charset};
112			my %s = &{$self->{option}->{hook_decode_string}} ($self, $body,
113			type => 'body', charset => $charset);
114			$self->{value} = $s{value};
115			$self->{_charset} = $s{charset}; ## When convertion failed
116			}
117
118			=back
119
120			=cut
121
122			=item $body->header ([$new_header])
123
124
125			=cut
126
127			sub entity_header ($;$) {
128			my $self = shift;
129			my $new_header = shift;
130			if (ref $new_header) {
131			$self->{header} = $new_header;
132			#} elsif ($new_header) {
133			# $self->{header} = Message::Header->parse ($new_header);
134			}
135			#unless ($self->{header}) {
136			# $self->{header} = new Message::Header;
137			#}
138			$self->{header};
139			}
140
141			=item $body->value ([$new_body])
142
143			Returns C<body> as string unless $new_body.
144			Set $new_body instead of current C<body>.
145
146			=cut
147
148			sub value ($;$) {
149			my $self = shift;
150			my $new_body = shift;
151			if ($new_body) {
152			$self->{value} = $new_body;
153			}
154			$self->{value};
155			}
156
157			=head2 $self->stringify ([%option])
158
159			Returns the C<body> as a string.
160
161			=cut
162
163			sub stringify ($;%) {
164			my $self = shift;
165			my %o = @_; my %option = %{$self->{option}};
166			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
167			my $v = $self->_prep_stringify ($self->{value}, \%option);
168			my $ct = $self->{header}->field ('content-type', -new_item_unless_exist => 0)
169			if ref $self->{header};
170			unless ($option{use_param_charset}) {
171			if ($option{use_normalization}) {
172			$v =~ s/\x0D(?!\x0A)/\x0D\x0A/gs;
173			$v =~ s/(?<!\x0D)\x0A/\x0D\x0A/gs;
174			#$v .= "\x0D\x0A" unless $v =~ /\x0D\x0A$/s;
175			}
176			return $v;
177			}
178			my %e;
179			unless ($self->{_charset}) {
180			my $charset; $charset = $ct->parameter ('charset') if ref $ct;
181			$charset \|\|= $option{default_charset};
182			(%e) = &{$option{hook_encode_string}} ($self, $v,
183			type => 'body', charset => $charset);
184			## Normalize
185			if ($option{use_normalization}) {
186			if ($Message::MIME::Charset::CHARSET{$charset \|\| '*default'}->{mime_text}) {
187			$e{value} =~ s/\x0D(?!\x0A)/\x0D\x0A/gs;
188			$e{value} =~ s/(?<!\x0D)\x0A/\x0D\x0A/gs;
189			#$e{value} .= "\x0D\x0A" unless $e{value} =~ /\x0D\x0A$/s;
190			}
191			}
192			} else { ## if $self->{_charset},
193			%e = (value => $v, charset => $self->{_charset});
194			}
195			if (ref $self->{header}) {
196			unless (ref $ct) {
197			$ct = $self->{header}->field ('content-type');
198			$ct->value ($option{parent_type});
199			}
200			$ct->replace (charset => ($e{charset} \|\| $option{default_charset}));
201			}
202			$e{value};
203			}
204			*as_string = \&stringify;
205
206			## $self->_prep_stringify ($value, \%option)
207			sub _prep_stringify ($$\%) {
208			my $self = shift;
209			shift;
210			}
211
212			## Inherited: option, clone
213
214			=head1 SEE ALSO
215
216			RFC 822 <urn:ietf:rfc:822>,
217			RFC 2046 <urn:ietf:rfc:2046>, RFC 2646 <urn:ietf:rfc:2646>.
218
219			=head1 LICENSE
220
221			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
222
223			This program is free software; you can redistribute it and/or modify
224			it under the terms of the GNU General Public License as published by
225			the Free Software Foundation; either version 2 of the License, or
226			(at your option) any later version.
227
228			This program is distributed in the hope that it will be useful,
229			but WITHOUT ANY WARRANTY; without even the implied warranty of
230			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
231			GNU General Public License for more details.
232
233			You should have received a copy of the GNU General Public License
234			along with this program; see the file COPYING. If not, write to
235			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
236			Boston, MA 02111-1307, USA.
237
238			=head1 CHANGE
239
240			See F<ChangeLog>.
241	wakaba	1.3	$Date: 2002/06/16 10:44:08 $
242	wakaba	1.1
243			=cut
244
245			1;