Message/Body/TextMessageRFC1153.pm


=head1 NAME

Message::Body::TextMessageRFC1153 --- Perl module
for digest message format defined by RFC 1153

=cut

## TODO: 
##   - Select and sort enclosed message header fields (See RFC 1153)

package Message::Body::TextMessageRFC1153;
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 list_name digest_info|],
  -_MEMBERS     => [qw|preamble list_name digest_info|],
  #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-rfc1153',
  #parse_all    => 0,
  #parts_min    => 1,
  #parts_max    => 0,
  #i text_coderange
  #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} }];
}

=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 =~ /^-{70,70}$nl/s;
    ($self->{preamble}, $body) = split /(?<=$nl)-{70,70}$nl$nl/s, $body, 2;
    $body = $nl . $body if $body =~ /^-{30,30}$nl/s;
    $self->{value} = [ split /(?!=$nl)$nl-{30,30}$nl$nl/, $body ];
    if ($self->{value}->[-1] =~ /^End of(.+?)Digest(.*?)$nl\*+(?:$nl)*$/is) {
      ($self->{list_name}, $self->{digest_info}) = ($1, $2);
      $self->{list_name} =~ s/^\s+//;  $self->{list_name} =~ s/\s+$//;
      $self->{digest_info} =~ s/^\s+//;  $self->{digest_info} =~ s/\s+$//;
      pop @{ $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;
}

=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 list_name ($;$) {
  my $self = shift;
  my $np = shift;
  if (defined $np) {
    $self->{list_name} = $np;
  }
  $self->{list_name};
}
sub digest_info ($;$) {
  my $self = shift;
  my $np = shift;
  if (defined $np) {
    $self->{digest_info} = $np;
  }
  $self->{digest_info};
}

=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}};
  ## Make trailer
    my $trailer = sprintf 'End of %s Digest%s',
      (length $self->{list_name}? $self->{list_name}: 'list'),
      (length $self->{digest_info}? ' '.$self->{digest_info}:'');
    $trailer .= "\x0D\x0A" . ('*' x length $trailer) . "\x0D\x0A";
  ## Preparates parts
    my @parts = map { ''. $_ } @{ $self->{value} }[0..$max];
    push @parts, $trailer;
    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';
      }
    }
  
  $preamble =~ s/^-{70,70}\x0D?$/"\x20".('-' x 69)/gem;
  $preamble .= "\x0D\x0A" unless $preamble =~ /\x0D\x0A$/s;
  
  $preamble
  ."----------------------------------------------------------------------\x0D\x0A"
  ."\x0D\x0A"
  .join "\x0D\x0A------------------------------\x0D\x0A\x0D\x0A",
    map { s/^-{30,30}\x0D?$/"\x20".('-' x 29)/gem; 
          $_ .= "\x0D\x0A" unless /\x0D\x0A$/s; $_ } @parts;
}
*as_string = \&stringify;

## Inherited: option, clone


=head1 SEE ALSO

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

=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::TextMessageRFC1153 --- Perl module
5			for digest message format defined by RFC 1153
6
7			=cut
8
9			## TODO:
10			## - Select and sort enclosed message header fields (See RFC 1153)
11
12			package Message::Body::TextMessageRFC1153;
13			use strict;
14			use vars qw(%DEFAULT @ISA $VERSION);
15			$VERSION=do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
16
17			require Message::Body::Multipart;
18			push @ISA, qw(Message::Body::Multipart);
19
20			%DEFAULT = (
21			## "#i" : only inherited from parent Entity and inherits to child Entity
22			-_ARRAY_NAME => 'value',
23			-_METHODS => [qw\|entity_header add delete count item preamble list_name digest_info\|],
24			-_MEMBERS => [qw\|preamble list_name digest_info\|],
25			#i accept_cte
26			#i body_default_charset
27			#i body_default_charset_input
28			#i cte_default
29			#linebreak_strict => 0,
30			-media_type => 'text',
31			-media_subtype => 'x-message-rfc1153',
32			#parse_all => 0,
33			#parts_min => 1,
34			#parts_max => 0,
35			#i text_coderange
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
59			=item $body = Message::Body::Multipart->new ([%options])
60
61			Constructs a new object. You might pass some options as parameters
62			to the constructor.
63
64			=cut
65
66			## Inherited
67
68			=item $body = Message::Body::Multipart->parse ($body, [%options])
69
70			Constructs a new object with given field body. You might pass
71			some options as parameters to the constructor.
72
73			=cut
74
75			sub parse ($$;%) {
76			my $class = shift;
77			my $self = bless {}, $class;
78			my $body = shift;
79			$self->_init (@_);
80			my $nl = "\x0D\x0A";
81			unless ($self->{option}->{linebreak_strict}) {
82			$nl = Message::Util::decide_newline ($body);
83			}
84			## Split the body
85			$body = $nl . $body if $body =~ /^-{70,70}$nl/s;
86			($self->{preamble}, $body) = split /(?<=$nl)-{70,70}$nl$nl/s, $body, 2;
87			$body = $nl . $body if $body =~ /^-{30,30}$nl/s;
88			$self->{value} = [ split /(?!=$nl)$nl-{30,30}$nl$nl/, $body ];
89			if ($self->{value}->[-1] =~ /^End of(.+?)Digest(.?)$nl\+(?:$nl)*$/is) {
90			($self->{list_name}, $self->{digest_info}) = ($1, $2);
91			$self->{list_name} =~ s/^\s+//; $self->{list_name} =~ s/\s+$//;
92			$self->{digest_info} =~ s/^\s+//; $self->{digest_info} =~ s/\s+$//;
93			pop @{ $self->{value} };
94			}
95
96			if ($self->{option}->{parse_all}) {
97			$self->{value} = [ map {
98			$self->_parse_value (body_part => $_);
99			} @{ $self->{value} } ];
100			$self->{preamble} = $self->_parse_value (preamble => $self->{preamble});
101			}
102			$self;
103			}
104
105			=back
106
107			=cut
108
109			## add, item, delete, count
110
111			## entity_header: Inherited
112
113			sub preamble ($;$) {
114			my $self = shift;
115			my $np = shift;
116			if (defined $np) {
117			$np = $self->_parse_value (preamble => $np) if $self->{option}->{parse_all};
118			$self->{preamble} = $np;
119			}
120			$self->{preamble};
121			}
122			sub list_name ($;$) {
123			my $self = shift;
124			my $np = shift;
125			if (defined $np) {
126			$self->{list_name} = $np;
127			}
128			$self->{list_name};
129			}
130			sub digest_info ($;$) {
131			my $self = shift;
132			my $np = shift;
133			if (defined $np) {
134			$self->{digest_info} = $np;
135			}
136			$self->{digest_info};
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			## Make trailer
156			my $trailer = sprintf 'End of %s Digest%s',
157			(length $self->{list_name}? $self->{list_name}: 'list'),
158			(length $self->{digest_info}? ' '.$self->{digest_info}:'');
159			$trailer .= "\x0D\x0A" . ('*' x length $trailer) . "\x0D\x0A";
160			## Preparates parts
161			my @parts = map { ''. $_ } @{ $self->{value} }[0..$max];
162			push @parts, $trailer;
163			my $preamble = ''.$self->{preamble};
164
165			if (ref $self->{header}) {
166			my $ct = $self->{header}->field ('content-type');
167			if (ref $self->{preamble}) {
168			unless (ref $self->{preamble}->entity_header) {
169			$self->{preamble}->entity_header (new Message::Header -format => 'mail-rfc822');
170			}
171			my $pct = $self->{preamble}->entity_header->field ('content-type', -new_item_unless_exist => 0);
172			$ct->replace ('x-preamble-type' => $pct)
173			if $pct && $pct ne 'text/plain; charset=us-ascii';
174			}
175			}
176
177			$preamble =~ s/^-{70,70}\x0D?$/"\x20".('-' x 69)/gem;
178			$preamble .= "\x0D\x0A" unless $preamble =~ /\x0D\x0A$/s;
179
180			$preamble
181			."----------------------------------------------------------------------\x0D\x0A"
182			."\x0D\x0A"
183			.join "\x0D\x0A------------------------------\x0D\x0A\x0D\x0A",
184			map { s/^-{30,30}\x0D?$/"\x20".('-' x 29)/gem;
185			$_ .= "\x0D\x0A" unless /\x0D\x0A$/s; $_ } @parts;
186			}
187			*as_string = \&stringify;
188
189			## Inherited: option, clone
190
191
192			=head1 SEE ALSO
193
194			RFC 1153 E<lt>urn:ietf:rfc:1153>
195
196			=head1 LICENSE
197
198			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
199
200			This program is free software; you can redistribute it and/or modify
201			it under the terms of the GNU General Public License as published by
202			the Free Software Foundation; either version 2 of the License, or
203			(at your option) any later version.
204
205			This program is distributed in the hope that it will be useful,
206			but WITHOUT ANY WARRANTY; without even the implied warranty of
207			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
208			GNU General Public License for more details.
209
210			You should have received a copy of the GNU General Public License
211			along with this program; see the file COPYING. If not, write to
212			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
213			Boston, MA 02111-1307, USA.
214
215			=head1 CHANGE
216
217			See F<ChangeLog>.
218			$Date: 2002/07/20 03:09:29 $
219
220			=cut
221
222			1;