Message/Body/MessageExternalBody.pm


=head1 NAME

Message::Body::MessageExternalBody --- Perl module
for "message/external-body" Internet Media Types

=cut

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

%DEFAULT = (
        ## "#i" : only inherited from parent Entity and inherits to child Entity
  -_METHODS     => [qw|entity_header encapsulated_header phantom_body|],
  -_MEMBERS     => [qw|encapsulated_header phantom_body|],
  #i body_default_charset
  #i body_default_charset_input
  -fill_cid     => 1,
  -fill_cte     => 1,
  -linebreak_strict     => 1,
  -media_type   => 'message',
  -media_subtype        => 'external-body',
  -msg_id_from  => '',
  -output_phantom_body  => 1,
  -parse_all    => 0,
  #use_normalization    => 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}->[1]->{-format}
    = 
  my @ilist = qw/body_default_charset body_default_charset_input/;
  $self->{option}->{value_type}->{phantom_body} = ['Message::Body::TextPlain',
    {-media_type => 'text', -media_subtype => '/external_phantom_body'},
    \@ilist];
  $self->{encapsulated_header} = new Message::Header
    -parse_all => $self->{option}->{parse_all},
    -format => 'mime-entity-external-body';
}

=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 $message = shift;
  $self->_init (@_);
  my $nl = "\x0D\x0A";
  unless ($self->{option}->{strict_linebreak}) {
    unless ($message =~ /\x0D\x0A/s) {
      my $lfcr = $message =~ s/\x0A\x0D/\x0A\x0D/gs;
      my $cr = $message =~ s/\x0D(?!\x0A)/\x0D/gs;
      my $lf = $message =~ s/(?<!\x0D)\x0A/\x0A/gs;
      if ($lfcr >= $cr && $lfcr >= $lf) { $nl = "\x0A\x0D" }
      elsif ($cr >= $lf) { $nl = "\x0D" }
      else { $nl = "\x0A" }
    }
  }
  my @header = (); my @body = split /$nl/, $message;
  while (my $line = shift @body) {
    unless (length($line)) { last }
    else { push @header, $line }
  }
  $self->{encapsulated_header} = parse_array Message::Header \@header,
    -parse_all => $self->{option}->{parse_all},
    -format => 'mime-entity-external-body';
  $self->{body} = join $nl, @body;
  $self->{body} = $self->_parse_value (phantom_body => $self->{body})
    if $self->{option}->{parse_all};
  $self;
}

=back

=cut


## entity_header: Inherited

sub encapsulated_header ($;$) {
  my $self = shift;
  my $np = shift;
  if (defined $np) {
    $self->{encapsulated_header} = parse Message::Header $np,
      -parse_all => $self->{option}->{parse_all},
      -format => 'mime-entity-external-body';
  }
  $self->{encapsulated_header};
}

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

sub set_reference ($$%) {
  my $self = shift;
  my $atype = lc shift;
  my %p = @_;
  Carp::croak "set_reference: Access-type is not specified" unless $atype;
  Carp::croak "set_reference: Entity header is not assosiated" unless ref $self->{header};
  my $ct = $self->{header}->field ('content-type');
  $ct->parameter ('access-type' => $atype);
  if ($atype eq 'uri') {
    $self->{phantom_body} = $p{url} if $p{url};
    $self->{phantom_body} = $p{uri} if $p{uri};
    delete $p{url}; delete $p{uri};
  } elsif ($p{body}) {
    $self->{phantom_body} = $p{body};
    delete $p{body};
  }
  if ($p{ct}) {
    $self->{encapsulated_header}->replace ('content-type' => $p{ct}, -parse => 1);
    delete $p{ct};
  }
  if ($p{cid}) {
    $self->{encapsulated_header}->replace ('content-id' => $p{cid}, -parse => 1);
    $self->{header}->replace ('content-id' => $p{cid}, -parse => 1)
      if $atype eq 'content-id';
    delete $p{cid};
  }
  if ($p{cte}) {
    $self->{encapsulated_header}->replace ('content-transfer-encoding' => $p{cte}, -parse => 1);
    delete $p{cte};
  }
  if (defined $p{dir} && !defined $p{directory}) {
    $p{directory} = $p{dir}; delete $p{dir};
  }
  $ct->parameter (%p);
  $self;
}

=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{$_}}
  
  my $ct = $self->{header}->field ('content-type');
  my $atype = $ct->parameter ('access-type');
  
  my $ihdr = $self->{encapsulated_header};
  my $icte = $ihdr->field ('content-transfer-encoding');
  if ($option{fill_cte} && !$icte->value) {
    if ($atype eq 'mail-server' || $atype eq 'content-id') {
      $icte->value ('7bit');
    } else {
      $icte->value ('binary');
    }
  }
  my $icid = $ihdr->field ('content-id', -new_item_unless_exist => 0);
  if ($option{fill_cid} && !$icid) {
    my $pcid = $self->{header}->field ('content-id', -new_item_unless_exist => 0);
    if ($pcid) {
      $ihdr->replace ('content-id' => $pcid);
    } else {
      require Message::Field::MsgID;
      my $as = $option{msg_id_from}.'';
      $as = $self->{header}->field ('resent-from', -new_item_unless_exist => 0)
         || $self->{header}->field ('from', -new_item_unless_exist => 0) unless $as;
      $as = $as->addr_spec if ref $as;
      $as ||= 'meb@external.body.message.pm.invalid';
      my $cid = new Message::Field::MsgID
        addr_spec       => $as,
        -field_name     => 'content-id',
      ;
      $ihdr->replace ('content-id' => $cid);
    }
  }
  
  $ihdr.
  "\x0D\x0A".
  ($option{output_phantom_body}? $self->{phantom_body}: '');
}
*as_string = \&stringify;

## Inherited: option, clone

## $self->_option_recursive (\%argv)
sub _option_recursive ($\%) {
  my $self = shift;
  my $o = shift;
  $self->{encapsulated_header}->option (%$o) if ref $self->{encapsulated_header};
  $self->{phantom_body}->option (%$o) if ref $self->{phantom_body};
}

=head1 SEE ALSO

RFC 2046 <urn:ietf:rfc:2046>

=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/06/14 11:35:11 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Body::MessageExternalBody --- Perl module
5			for "message/external-body" Internet Media Types
6
7			=cut
8
9			package Message::Body::MessageExternalBody;
10			use strict;
11			use vars qw(%DEFAULT @ISA $VERSION);
12	wakaba	1.2	$VERSION=do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13	wakaba	1.1
14			require Message::Body::Text;
15			push @ISA, qw(Message::Body::Text);
16
17			%DEFAULT = (
18			## "#i" : only inherited from parent Entity and inherits to child Entity
19			-_METHODS => [qw\|entity_header encapsulated_header phantom_body\|],
20			-_MEMBERS => [qw\|encapsulated_header phantom_body\|],
21			#i body_default_charset
22			#i body_default_charset_input
23			-fill_cid => 1,
24			-fill_cte => 1,
25			-linebreak_strict => 1,
26			-media_type => 'message',
27			-media_subtype => 'external-body',
28	wakaba	1.2	-msg_id_from => '',
29	wakaba	1.1	-output_phantom_body => 1,
30			-parse_all => 0,
31			#use_normalization => 0,
32			-value_type => {},
33			);
34
35			=head1 CONSTRUCTORS
36
37			The following methods construct new objects:
38
39			=over 4
40
41			=cut
42
43			## Initialize of this class -- called by constructors
44			sub _init ($;%) {
45			my $self = shift;
46			my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
47			my %option = @_;
48			$self->SUPER::_init (%$DEFAULT, %option);
49
50			$self->{option}->{value_type}->{body_part}->[1]->{-format}
51			=
52			my @ilist = qw/body_default_charset body_default_charset_input/;
53			$self->{option}->{value_type}->{phantom_body} = ['Message::Body::TextPlain',
54			{-media_type => 'text', -media_subtype => '/external_phantom_body'},
55			\@ilist];
56	wakaba	1.2	$self->{encapsulated_header} = new Message::Header
57			-parse_all => $self->{option}->{parse_all},
58			-format => 'mime-entity-external-body';
59	wakaba	1.1	}
60
61			=item $body = Message::Body::Multipart->new ([%options])
62
63			Constructs a new object. You might pass some options as parameters
64			to the constructor.
65
66			=cut
67
68			## Inherited
69
70			=item $body = Message::Body::Multipart->parse ($body, [%options])
71
72			Constructs a new object with given field body. You might pass
73			some options as parameters to the constructor.
74
75			=cut
76
77			sub parse ($$;%) {
78			my $class = shift;
79			my $self = bless {}, $class;
80			my $message = shift;
81			$self->_init (@_);
82			my $nl = "\x0D\x0A";
83			unless ($self->{option}->{strict_linebreak}) {
84			unless ($message =~ /\x0D\x0A/s) {
85			my $lfcr = $message =~ s/\x0A\x0D/\x0A\x0D/gs;
86			my $cr = $message =~ s/\x0D(?!\x0A)/\x0D/gs;
87			my $lf = $message =~ s/(?<!\x0D)\x0A/\x0A/gs;
88			if ($lfcr >= $cr && $lfcr >= $lf) { $nl = "\x0A\x0D" }
89			elsif ($cr >= $lf) { $nl = "\x0D" }
90			else { $nl = "\x0A" }
91			}
92			}
93			my @header = (); my @body = split /$nl/, $message;
94			while (my $line = shift @body) {
95			unless (length($line)) { last }
96			else { push @header, $line }
97			}
98			$self->{encapsulated_header} = parse_array Message::Header \@header,
99			-parse_all => $self->{option}->{parse_all},
100			-format => 'mime-entity-external-body';
101			$self->{body} = join $nl, @body;
102			$self->{body} = $self->_parse_value (phantom_body => $self->{body})
103			if $self->{option}->{parse_all};
104			$self;
105			}
106
107			=back
108
109			=cut
110
111
112			## entity_header: Inherited
113
114			sub encapsulated_header ($;$) {
115			my $self = shift;
116			my $np = shift;
117			if (defined $np) {
118			$self->{encapsulated_header} = parse Message::Header $np,
119			-parse_all => $self->{option}->{parse_all},
120			-format => 'mime-entity-external-body';
121			}
122			$self->{encapsulated_header};
123			}
124
125			sub phantom_body ($;$) {
126			my $self = shift;
127			my $np = shift;
128			if (defined $np) {
129			$np = $self->_parse_value (phantom_body => $np) if $self->{option}->{parse_all};
130			$self->{phantom_body} = $np;
131			}
132			$self->{phantom_body};
133			}
134
135			sub set_reference ($$%) {
136			my $self = shift;
137			my $atype = lc shift;
138			my %p = @_;
139			Carp::croak "set_reference: Access-type is not specified" unless $atype;
140			Carp::croak "set_reference: Entity header is not assosiated" unless ref $self->{header};
141			my $ct = $self->{header}->field ('content-type');
142			$ct->parameter ('access-type' => $atype);
143			if ($atype eq 'uri') {
144			$self->{phantom_body} = $p{url} if $p{url};
145			$self->{phantom_body} = $p{uri} if $p{uri};
146			delete $p{url}; delete $p{uri};
147			} elsif ($p{body}) {
148			$self->{phantom_body} = $p{body};
149			delete $p{body};
150			}
151			if ($p{ct}) {
152			$self->{encapsulated_header}->replace ('content-type' => $p{ct}, -parse => 1);
153			delete $p{ct};
154			}
155			if ($p{cid}) {
156			$self->{encapsulated_header}->replace ('content-id' => $p{cid}, -parse => 1);
157			$self->{header}->replace ('content-id' => $p{cid}, -parse => 1)
158			if $atype eq 'content-id';
159			delete $p{cid};
160			}
161			if ($p{cte}) {
162			$self->{encapsulated_header}->replace ('content-transfer-encoding' => $p{cte}, -parse => 1);
163			delete $p{cte};
164			}
165			if (defined $p{dir} && !defined $p{directory}) {
166			$p{directory} = $p{dir}; delete $p{dir};
167			}
168			$ct->parameter (%p);
169			$self;
170			}
171
172			=head2 $self->stringify ([%option])
173
174			Returns the C<body> as a string.
175
176			=cut
177
178			sub stringify ($;%) {
179			my $self = shift;
180			my %o = @_; my %option = %{$self->{option}};
181			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
182
183			my $ct = $self->{header}->field ('content-type');
184			my $atype = $ct->parameter ('access-type');
185
186			my $ihdr = $self->{encapsulated_header};
187			my $icte = $ihdr->field ('content-transfer-encoding');
188			if ($option{fill_cte} && !$icte->value) {
189			if ($atype eq 'mail-server' \|\| $atype eq 'content-id') {
190			$icte->value ('7bit');
191			} else {
192			$icte->value ('binary');
193			}
194			}
195			my $icid = $ihdr->field ('content-id', -new_item_unless_exist => 0);
196			if ($option{fill_cid} && !$icid) {
197			my $pcid = $self->{header}->field ('content-id', -new_item_unless_exist => 0);
198			if ($pcid) {
199			$ihdr->replace ('content-id' => $pcid);
200			} else {
201			require Message::Field::MsgID;
202			my $as = $option{msg_id_from}.'';
203			$as = $self->{header}->field ('resent-from', -new_item_unless_exist => 0)
204			\|\| $self->{header}->field ('from', -new_item_unless_exist => 0) unless $as;
205			$as = $as->addr_spec if ref $as;
206			$as \|\|= 'meb@external.body.message.pm.invalid';
207			my $cid = new Message::Field::MsgID
208			addr_spec => $as,
209			-field_name => 'content-id',
210			;
211			$ihdr->replace ('content-id' => $cid);
212			}
213			}
214
215			$ihdr.
216			"\x0D\x0A".
217			($option{output_phantom_body}? $self->{phantom_body}: '');
218			}
219			*as_string = \&stringify;
220
221			## Inherited: option, clone
222
223			## $self->_option_recursive (\%argv)
224			sub _option_recursive ($\%) {
225			my $self = shift;
226			my $o = shift;
227			$self->{encapsulated_header}->option (%$o) if ref $self->{encapsulated_header};
228			$self->{phantom_body}->option (%$o) if ref $self->{phantom_body};
229			}
230
231			=head1 SEE ALSO
232
233			RFC 2046 <urn:ietf:rfc:2046>
234
235			=head1 LICENSE
236
237			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
238
239			This program is free software; you can redistribute it and/or modify
240			it under the terms of the GNU General Public License as published by
241			the Free Software Foundation; either version 2 of the License, or
242			(at your option) any later version.
243
244			This program is distributed in the hope that it will be useful,
245			but WITHOUT ANY WARRANTY; without even the implied warranty of
246			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
247			GNU General Public License for more details.
248
249			You should have received a copy of the GNU General Public License
250			along with this program; see the file COPYING. If not, write to
251			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
252			Boston, MA 02111-1307, USA.
253
254			=head1 CHANGE
255
256			See F<ChangeLog>.
257	wakaba	1.2	$Date: 2002/06/14 11:35:11 $
258	wakaba	1.1
259			=cut
260
261			1;