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
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.1 $=~/\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	-msg_id_from => '',
29	-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	$self->{encapsulated_header} = new Message::Header
57	-parse_all => $self->{option}->{parse_all},
58	-format => 'mime-entity-external-body';
59	}
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	$Date: 2002/06/14 11:35:11 $
258
259	=cut
260
261	1;