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.1 $=~/\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/19 11:49:23 $

=cut

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.1 $=~/\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	#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	#unshift @parts, $self->{preamble}.'';
156	push @parts, ( $option{output_epilogue}? '' . $self->{epilogue} :'' );
157	#$parts[-1] .= "\x0D\x0A" unless $parts[-1] =~ /\x0D\x0A$/s;
158	my $preamble = ''.$self->{preamble};
159
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
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	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	$Date: 2002/07/19 11:49:23 $
221
222	=cut
223
224	1;