Message/Body/TextMessageRFC934.pm


=head1 NAME

Message::Body::TextMessageRFC934 --- Perl module
for encapsulated message format defined by RFC 934

=cut

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

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

%DEFAULT = (
        ## "#i" : only inherited from parent Entity and inherits to child Entity
  -_ARRAY_NAME  => 'value',
  -_METHODS     => [qw|entity_header add delete count item preamble epilogue|],
  -_MEMBERS     => [qw|preamble epilogue|],
  #i accept_cte
  #i body_default_charset
  #i body_default_charset_input
  #i cte_default
  #default_media_type   => 'text',
  #default_media_subtype        => 'plain',
  #linebreak_strict     => 0,
  -media_type   => 'text',
  -media_subtype        => 'x-message-rfc934',
  -no_final_text        => 0,
  -output_epilogue      => 1,
  #parse_all    => 0,
  #parts_min    => 1,
  #parts_max    => 0,
  #i text_coderange
  -output_souround_blank_line   => 1,
  #use_normalization    => 0,
  -use_param_charset    => 0,
  -value_type   => {},
);

=head1 CONSTRUCTORS

The following methods construct new 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);
  $self->{option}->{value_type}->{body_part}
    = $Message::MIME::MediaType::type{message}->{rfc822}->{handler};
  
  if (ref $self->{header}) {
    my $s = $self->{header}->field ('x-mlserver', -new_item_unless_exist => 0);
    if (ref $s && $s =~ /fml/) {
      $self->{option}->{no_final_text} = 1;
    }
  }
}

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

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

=cut

## Inherited

=item $body = Message::Body::Multipart->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 $nl = "\x0D\x0A";
  unless ($self->{option}->{linebreak_strict}) {
    $nl = Message::Util::decide_newline ($body);
  }
  ## Split the body
    $body = $nl . $body if $body =~ /^-(?!\x20)/;
    $body =~ s/(?<=$nl)-[^\x20$nl][^$nl]*(?=$nl)/-/gs;
    $self->{value} = [ split /(?<=$nl)(?:$nl)?-$nl(?:$nl)?/s, $body ];
    $self->{preamble} = shift (@{ $self->{value} });
    $self->{epilogue} = pop (@{ $self->{value} })
      if !$self->{option}->{no_final_text} && $body !~ /$nl-$nl(?:$nl)?$/s;
    @{ $self->{value} } = grep {length} map { s/^-\x20//gm; $_ } @{ $self->{value} };
  
  if ($self->{option}->{parse_all}) {
    $self->{value} = [ map {
      $self->_parse_value (body_part => $_);
    } @{ $self->{value} } ];
    $self->{preamble} = $self->_parse_value (preamble => $self->{preamble});
    $self->{epilogue} = $self->_parse_value (epilogue => $self->{epilogue});
  }
  $self;
}

=back

=cut

## add, item, delete, count

## entity_header: Inherited

sub preamble ($;$) {
  my $self = shift;
  my $np = shift;
  if (defined $np) {
    $np = $self->_parse_value (preamble => $np) if $self->{option}->{parse_all};
    $self->{preamble} = $np;
  }
  $self->{preamble};
}
sub epilogue ($;$) {
  my $self = shift;
  my $np = shift;
  if (defined $np) {
    $np = $self->_parse_value (epilogue => $np) if $self->{option}->{parse_all};
    $self->{epilogue} = $np;
  }
  $self->{epilogue};
}

=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{$_}}
  $self->_delete_empty;
  ## Check the number of parts
    my $min = $option{parts_min} || 1;  $min--;
    $#{ $self->{value} } = $min unless $min <= $#{ $self->{value} };
    my $max = $option{parts_max} || $#{$self->{value}}+1;  $max--;
    $max = $#{$self->{value}} if $max > $#{$self->{value}};
  ## Preparates parts
    my @parts = map { ''. $_ } @{ $self->{value} }[0..$max];
    unshift @parts, $self->{preamble}.'';
    push @parts, ( $option{output_epilogue}? '' . $self->{epilogue} :'' );
    $parts[-1] .= "\x0D\x0A" unless $parts[-1] =~ /\x0D\x0A$/s;
  
    if (ref $self->{header}) {
      my $ct = $self->{header}->field ('content-type');
      if (ref $self->{preamble}) {
        unless (ref $self->{preamble}->entity_header) {
          $self->{preamble}->entity_header (new Message::Header -format => 'mail-rfc822');
        }
        my $pct = $self->{preamble}->entity_header->field ('content-type', -new_item_unless_exist => 0);
        $ct->replace ('x-preamble-type' => $pct)
          if $pct && $pct ne 'text/plain; charset=us-ascii';
      }
      if (ref $self->{epilogue} && $option{output_epilogue}) {
        unless (ref $self->{epilogue}->entity_header) {
          $self->{epilogue}->entity_header (new Message::Header -format => 'mail-rfc822');
        }
        my $ect = $self->{epilogue}->entity_header->field ('content-type', -new_item_unless_exist => 0);
        $ct->replace ('x-epilogue-type' => $ect)
          if $ect && $ect ne 'text/plain; charset=us-ascii';
      }
    }
  join "\x0D\x0A------------------------------\x0D\x0A"
       .($option{output_souround_blank_line}? "\x0D\x0A":''),
    map { s/^-/-\x20-/gm; $_ } @parts;
}
*as_string = \&stringify;

## Inherited: option, clone


=head1 SEE ALSO

RFC 934 E<lt>urn:ietf:rfc:934>

=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/08 11:48:12 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Body::TextMessageRFC934 --- Perl module
5			for encapsulated message format defined by RFC 934
6
7			=cut
8
9			package Message::Body::TextMessageRFC934;
10			use strict;
11			use vars qw(%DEFAULT @ISA $VERSION);
12			$VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13
14			require Message::Body::Multipart;
15			push @ISA, qw(Message::Body::Multipart);
16
17			%DEFAULT = (
18			## "#i" : only inherited from parent Entity and inherits to child Entity
19			-_ARRAY_NAME => 'value',
20			-_METHODS => [qw\|entity_header add delete count item preamble epilogue\|],
21			-_MEMBERS => [qw\|preamble epilogue\|],
22			#i accept_cte
23			#i body_default_charset
24			#i body_default_charset_input
25			#i cte_default
26			#default_media_type => 'text',
27			#default_media_subtype => 'plain',
28			#linebreak_strict => 0,
29			-media_type => 'text',
30			-media_subtype => 'x-message-rfc934',
31			-no_final_text => 0,
32			-output_epilogue => 1,
33			#parse_all => 0,
34			#parts_min => 1,
35			#parts_max => 0,
36			#i text_coderange
37			-output_souround_blank_line => 1,
38			#use_normalization => 0,
39			-use_param_charset => 0,
40			-value_type => {},
41			);
42
43			=head1 CONSTRUCTORS
44
45			The following methods construct new objects:
46
47			=over 4
48
49			=cut
50
51			## Initialize of this class -- called by constructors
52			sub _init ($;%) {
53			my $self = shift;
54			my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
55			my %option = @_;
56			$self->SUPER::_init (%$DEFAULT, %option);
57			$self->{option}->{value_type}->{body_part}
58			= $Message::MIME::MediaType::type{message}->{rfc822}->{handler};
59
60			if (ref $self->{header}) {
61			my $s = $self->{header}->field ('x-mlserver', -new_item_unless_exist => 0);
62			if (ref $s && $s =~ /fml/) {
63			$self->{option}->{no_final_text} = 1;
64			}
65			}
66			}
67
68			=item $body = Message::Body::Multipart->new ([%options])
69
70			Constructs a new object. You might pass some options as parameters
71			to the constructor.
72
73			=cut
74
75			## Inherited
76
77			=item $body = Message::Body::Multipart->parse ($body, [%options])
78
79			Constructs a new object with given field body. You might pass
80			some options as parameters to the constructor.
81
82			=cut
83
84			sub parse ($$;%) {
85			my $class = shift;
86			my $self = bless {}, $class;
87			my $body = shift;
88			$self->_init (@_);
89			my $nl = "\x0D\x0A";
90			unless ($self->{option}->{linebreak_strict}) {
91			$nl = Message::Util::decide_newline ($body);
92			}
93			## Split the body
94			$body = $nl . $body if $body =~ /^-(?!\x20)/;
95			$body =~ s/(?<=$nl)-[^\x20$nl][^$nl]*(?=$nl)/-/gs;
96			$self->{value} = [ split /(?<=$nl)(?:$nl)?-$nl(?:$nl)?/s, $body ];
97			$self->{preamble} = shift (@{ $self->{value} });
98			$self->{epilogue} = pop (@{ $self->{value} })
99			if !$self->{option}->{no_final_text} && $body !~ /$nl-$nl(?:$nl)?$/s;
100			@{ $self->{value} } = grep {length} map { s/^-\x20//gm; $_ } @{ $self->{value} };
101
102			if ($self->{option}->{parse_all}) {
103			$self->{value} = [ map {
104			$self->_parse_value (body_part => $_);
105			} @{ $self->{value} } ];
106			$self->{preamble} = $self->_parse_value (preamble => $self->{preamble});
107			$self->{epilogue} = $self->_parse_value (epilogue => $self->{epilogue});
108			}
109			$self;
110			}
111
112			=back
113
114			=cut
115
116			## add, item, delete, count
117
118			## entity_header: Inherited
119
120			sub preamble ($;$) {
121			my $self = shift;
122			my $np = shift;
123			if (defined $np) {
124			$np = $self->_parse_value (preamble => $np) if $self->{option}->{parse_all};
125			$self->{preamble} = $np;
126			}
127			$self->{preamble};
128			}
129			sub epilogue ($;$) {
130			my $self = shift;
131			my $np = shift;
132			if (defined $np) {
133			$np = $self->_parse_value (epilogue => $np) if $self->{option}->{parse_all};
134			$self->{epilogue} = $np;
135			}
136			$self->{epilogue};
137			}
138
139			=head2 $self->stringify ([%option])
140
141			Returns the C<body> as a string.
142
143			=cut
144
145			sub stringify ($;%) {
146			my $self = shift;
147			my %o = @_; my %option = %{$self->{option}};
148			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
149			$self->_delete_empty;
150			## Check the number of parts
151			my $min = $option{parts_min} \|\| 1; $min--;
152			$#{ $self->{value} } = $min unless $min <= $#{ $self->{value} };
153			my $max = $option{parts_max} \|\| $#{$self->{value}}+1; $max--;
154			$max = $#{$self->{value}} if $max > $#{$self->{value}};
155			## Preparates parts
156			my @parts = map { ''. $_ } @{ $self->{value} }[0..$max];
157			unshift @parts, $self->{preamble}.'';
158			push @parts, ( $option{output_epilogue}? '' . $self->{epilogue} :'' );
159			$parts[-1] .= "\x0D\x0A" unless $parts[-1] =~ /\x0D\x0A$/s;
160
161			if (ref $self->{header}) {
162			my $ct = $self->{header}->field ('content-type');
163			if (ref $self->{preamble}) {
164			unless (ref $self->{preamble}->entity_header) {
165			$self->{preamble}->entity_header (new Message::Header -format => 'mail-rfc822');
166			}
167			my $pct = $self->{preamble}->entity_header->field ('content-type', -new_item_unless_exist => 0);
168			$ct->replace ('x-preamble-type' => $pct)
169			if $pct && $pct ne 'text/plain; charset=us-ascii';
170			}
171			if (ref $self->{epilogue} && $option{output_epilogue}) {
172			unless (ref $self->{epilogue}->entity_header) {
173			$self->{epilogue}->entity_header (new Message::Header -format => 'mail-rfc822');
174			}
175			my $ect = $self->{epilogue}->entity_header->field ('content-type', -new_item_unless_exist => 0);
176			$ct->replace ('x-epilogue-type' => $ect)
177			if $ect && $ect ne 'text/plain; charset=us-ascii';
178			}
179			}
180			join "\x0D\x0A------------------------------\x0D\x0A"
181			.($option{output_souround_blank_line}? "\x0D\x0A":''),
182			map { s/^-/-\x20-/gm; $_ } @parts;
183			}
184			*as_string = \&stringify;
185
186			## Inherited: option, clone
187
188
189			=head1 SEE ALSO
190
191			RFC 934 E<lt>urn:ietf:rfc:934>
192
193			=head1 LICENSE
194
195			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
196
197			This program is free software; you can redistribute it and/or modify
198			it under the terms of the GNU General Public License as published by
199			the Free Software Foundation; either version 2 of the License, or
200			(at your option) any later version.
201
202			This program is distributed in the hope that it will be useful,
203			but WITHOUT ANY WARRANTY; without even the implied warranty of
204			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
205			GNU General Public License for more details.
206
207			You should have received a copy of the GNU General Public License
208			along with this program; see the file COPYING. If not, write to
209			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
210			Boston, MA 02111-1307, USA.
211
212			=head1 CHANGE
213
214			See F<ChangeLog>.
215			$Date: 2002/07/08 11:48:12 $
216
217			=cut
218
219			1;