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.2 $=~/\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',
  -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];
}

=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/11 12:58:06 $

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