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.2 $=~/\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
  #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;
    my $preamble = ''.$self->{preamble};
  
    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';
      }
    }
  
  $preamble =~ s/^-/-\x20-/gm;
  
  $preamble . "\x0D\x0A"
  ."----------------------------------------------------------------------\x0D\x0A"
  .($option{output_souround_blank_line}? "\x0D\x0A":'')
  .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/20 03:09:29 $

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