Message/Body/TextPlainFlowed.pm


=head1 NAME

Message::Body::TextPlainFlowed --- Perl Module for Internet Media Type "text/plain"
with "Format=Flowed" parameter

=cut

package Message::Body::TextPlainFlowed;
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::Body::Text;
push @ISA, qw(Message::Body::Text);

%DEFAULT = (
  -_METHODS     => [qw|value|],
  -_MEMBERS     => [qw|_charset|],
  #default_charset
  -parent_type  => 'text/plain',
  -use_normalization    => 1,
  -use_param_charset    => 1,
);

=head1 CONSTRUCTORS

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

=over 4

=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

## parse: Inherited
sub _parse ($$) {
  my $self = shift;
  $self->SUPER::_parse (@_);
  unless ($self->{_charset}) {
    my @v;
    my @l = split /\x0D?\x0A/, $self->{value};
    
    for my $i (0..$#l) {
      if ($i == 0 || $l[$i-1] !~ /\x20$/ || $l[$i-1] eq '-- ') {
        $v[$#v+1] = {value => ''};
      }
      if ($l[$i] =~ s/^(>+)//) {
        my $depth = length $1;
        $v[$#v+1] = {value => ''} if defined $v[$#v]->{depth}
                                     && $depth != $v[$#v]->{depth};
        $v[$#v]->{depth} = $depth;
      }
      $l[$i] = substr ($l[$i], 1) if substr ($l[$i], 0, 1) eq ' ';
      $v[$#v]->{value} .= $l[$i];
    }
    $self->{value} = \@v;
  }
  $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

## $self->_prep_stringify ($value, \%option)
sub _prep_stringify ($$\%) {
  my $self = shift;
  my ($s, $option) = @_;
  if (ref $s eq 'ARRAY') {
    join "\x0D\x0A", grep {length $_} map {
      my $quote = ('>' x $_->{depth});
      my $line_body = $_->{value};
      if ($quote) {
        $quote .= ' ';
      } else {
        $line_body = ' ' . $line_body if $line_body =~ /^(?:\x20|[Ff]rom\x20|>)/;
      }
      $line_body = $self->_fold ($line_body, -initial_length => length $quote,
                                 -quote => $quote);
      $line_body .= "\x20\x0D\x0A" . $quote if length $line_body;
      $quote . $line_body;
    } @$s;
  } else {
    $s;
  }
}

## $self->_fold ($string, %option = (-max, -initial_length) )
sub _fold ($$;%) {
  my $self = shift;
  my $string = shift;
  my %option = @_;
  my $max = 66;
  $max = 20 if $max < 20;
  $option{-newline} ||= "\x0D\x0A";
  
  my $l = 0; #$option{-initial_length} || 0;
  $string =~ s{([^\x09\x20]+[\x09\x20])}{
    my $s = $1;
    if ($l && $l + length $s > $max) {
      if (!$option{-quote} && $s =~ /^(?:\x20|[Ff]rom\x20|>)/) {
        $s = $option{-newline} . ' ' . $s;
      } else {
        $s = $option{-newline} . $option{-quote} . $s;
      }
      $l = length ($s) - 2;     ## 2 is for CRLF
    } else { $l += length $s }
    $s;
  }gex;
  $string;
}

## 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	wakaba	1.1
2			=head1 NAME
3
4			Message::Body::TextPlainFlowed --- Perl Module for Internet Media Type "text/plain"
5			with "Format=Flowed" parameter
6
7			=cut
8
9			package Message::Body::TextPlainFlowed;
10			use strict;
11			use vars qw(%DEFAULT @ISA $VERSION);
12			$VERSION=do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13
14			require Message::Body::Text;
15			push @ISA, qw(Message::Body::Text);
16
17			%DEFAULT = (
18			-_METHODS => [qw\|value\|],
19			-_MEMBERS => [qw\|_charset\|],
20			#default_charset
21			-parent_type => 'text/plain',
22			-use_normalization => 1,
23			-use_param_charset => 1,
24			);
25
26			=head1 CONSTRUCTORS
27
28			The following methods construct new C<Message::Field::Structured> objects:
29
30			=over 4
31
32			=item $body = Message::Body::TextPlain->new ([%options])
33
34			Constructs a new object. You might pass some options as parameters
35			to the constructor.
36
37			=cut
38
39			## Inherited
40
41			=item $body = Message::Body::TextPlain->parse ($body, [%options])
42
43			Constructs a new object with given field body. You might pass
44			some options as parameters to the constructor.
45
46			=cut
47
48			## parse: Inherited
49			sub _parse ($$) {
50			my $self = shift;
51			$self->SUPER::_parse (@_);
52			unless ($self->{_charset}) {
53			my @v;
54			my @l = split /\x0D?\x0A/, $self->{value};
55
56			for my $i (0..$#l) {
57			if ($i == 0 \|\| $l[$i-1] !~ /\x20$/ \|\| $l[$i-1] eq '-- ') {
58			$v[$#v+1] = {value => ''};
59			}
60			if ($l[$i] =~ s/^(>+)//) {
61			my $depth = length $1;
62			$v[$#v+1] = {value => ''} if defined $v[$#v]->{depth}
63			&& $depth != $v[$#v]->{depth};
64			$v[$#v]->{depth} = $depth;
65			}
66			$l[$i] = substr ($l[$i], 1) if substr ($l[$i], 0, 1) eq ' ';
67			$v[$#v]->{value} .= $l[$i];
68			}
69			$self->{value} = \@v;
70			}
71			$self;
72			}
73
74			=back
75
76			=cut
77
78			=item $body->header ([$new_header])
79
80
81			=cut
82
83			## Inherited
84
85			=item $body->value ([$new_body])
86
87			Returns C<body> as string unless $new_body.
88			Set $new_body instead of current C<body>.
89
90			=cut
91
92			## Inherited
93
94			=head2 $self->stringify ([%option])
95
96			Returns the C<body> as a string.
97
98			=cut
99
100			## $self->_prep_stringify ($value, \%option)
101			sub _prep_stringify ($$\%) {
102			my $self = shift;
103			my ($s, $option) = @_;
104			if (ref $s eq 'ARRAY') {
105			join "\x0D\x0A", grep {length $_} map {
106			my $quote = ('>' x $_->{depth});
107			my $line_body = $_->{value};
108			if ($quote) {
109			$quote .= ' ';
110			} else {
111			$line_body = ' ' . $line_body if $line_body =~ /^(?:\x20\|[Ff]rom\x20\|>)/;
112			}
113			$line_body = $self->_fold ($line_body, -initial_length => length $quote,
114			-quote => $quote);
115			$line_body .= "\x20\x0D\x0A" . $quote if length $line_body;
116			$quote . $line_body;
117			} @$s;
118			} else {
119			$s;
120			}
121			}
122
123			## $self->_fold ($string, %option = (-max, -initial_length) )
124			sub _fold ($$;%) {
125			my $self = shift;
126			my $string = shift;
127			my %option = @_;
128			my $max = 66;
129			$max = 20 if $max < 20;
130			$option{-newline} \|\|= "\x0D\x0A";
131
132			my $l = 0; #$option{-initial_length} \|\| 0;
133			$string =~ s{([^\x09\x20]+[\x09\x20])}{
134			my $s = $1;
135			if ($l && $l + length $s > $max) {
136			if (!$option{-quote} && $s =~ /^(?:\x20\|[Ff]rom\x20\|>)/) {
137			$s = $option{-newline} . ' ' . $s;
138			} else {
139			$s = $option{-newline} . $option{-quote} . $s;
140			}
141			$l = length ($s) - 2; ## 2 is for CRLF
142			} else { $l += length $s }
143			$s;
144			}gex;
145			$string;
146			}
147
148			## Inherited: option, clone
149
150			=head1 SEE ALSO
151
152			RFC 822 <urn:ietf:rfc:822>,
153			RFC 2046 <urn:ietf:rfc:2046>, RFC 2646 <urn:ietf:rfc:2646>.
154
155			=head1 LICENSE
156
157			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
158
159			This program is free software; you can redistribute it and/or modify
160			it under the terms of the GNU General Public License as published by
161			the Free Software Foundation; either version 2 of the License, or
162			(at your option) any later version.
163
164			This program is distributed in the hope that it will be useful,
165			but WITHOUT ANY WARRANTY; without even the implied warranty of
166			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
167			GNU General Public License for more details.
168
169			You should have received a copy of the GNU General Public License
170			along with this program; see the file COPYING. If not, write to
171			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
172			Boston, MA 02111-1307, USA.
173
174			=head1 CHANGE
175
176			See F<ChangeLog>.
177			$Date: 2002/05/29 11:05:53 $
178
179			=cut
180
181			1;