lib/Message/Partial.pm


=head1 NAME

Message::Partial --- Perl module for partial message defined by MIME
(message/partial)

=cut

package Message::Partial;
use strict;
use vars qw(%OPTION $VERSION);
$VERSION=do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

require Message::Entity;
require Message::Header;
require Message::Field::MsgID;

%OPTION = (
  -part_length  => 60 * 1024,
  -subject_format_pattern       => '%s (%d/%d)',
);

my %ENCLOSED_FIELD = (
        'disposition-notification-to'   => 1,   ## RFC 2298
        'disposition-notification-options'      => 1,   ## RFC 2298
        encrypted       => 1,   ## RFC 1521
        'message-id'    => 2,   ## RFC 1341
        'mime-version'  => 2,   ## RFC 1521
        'original-recipient'    => 1,   ## RFC 2298
        subject => 1,   ## RFC 2046
        'user-agent'    => 1,   ## non-standard extension
## Note: If value is 2, that header field from the first fragment
##       is removed.  1 or 0, not removed.  Usually, 1-valued fields
##       are encapsulated and does not occur in fragments.  Such
##       context, 1 and 2 have no difference.
);
sub fragmentate ($;%) {
  my $msg = shift;
  my %params = @_;
  my %option = %OPTION;
  for (grep {/^-/} keys %params) {$option{$_} = $params{$_}}
  
  if (ref $msg) {
    $msg = $msg->clone;
  } else {
    $msg = parse Message::Entity $msg;
  }
  my @copy_field;
  $msg->option (force_mime_entity => 1);
  $msg->stringify;      ## Make fill_* work
  $msg->header->scan (sub {
    my $i = $_[1];
    my $rfc822 = $Message::Header::NS_phname2uri{'x-rfc822'};
    if ($i->{ns} eq $Message::Header::NS_phname2uri{content}) {
      push @copy_field, {%$i};
      $i->{name} = undef;
    } elsif ($i->{ns} eq $rfc822 && $ENCLOSED_FIELD{ $i->{name} }) {
      #push @copy_field, Message::Util::make_clone ($i);
      ##$i->{name} = undef;     ## Don't remove to keep compatible w/ RFC 1341/1521
      push @copy_field, {%$i};
      $i->{name} = undef;
    }
  });
  my $outer_header = $msg->header;
  my $inner_header = new Message::Header;
  $inner_header->{value} = \@copy_field;        ## Warning: direct access to internal structure!
  $msg->header ($inner_header);
  my @msg = split /\x0D\x0A/, $msg->stringify (-accept_cte => '7bit');
  my @pbody = ('');
  for (@msg) {
    if (length $pbody[$#pbody] > $option{-part_length}) {
      push @pbody, '';
    }
    $pbody[$#pbody] .= $_."\x0D\x0A";
  }
  my @pmsg;
  my $subject = $inner_header->field ('subject', -new_item_unless_exist => 0);
  my $ct = $outer_header->field ('content-type');
    $ct->media_type ('message/partial');
    my $as = $outer_header->field ('resent-from', -new_item_unless_exist => 0)
          || $outer_header->field ('from', -new_item_unless_exist => 0);
    $as = $as->addr_spec if ref $as;
    $as ||= '[email protected]';
    my $pid = Message::Field::MsgID->new (addr_spec => $as);
    $ct->parameter (id => $pid->content);
  my $first_mid;
  for my $i (0..$#pbody) {
    my %eo;  %eo = (
        -add_ua => 0,
    #   -fill_date      => 0,
    ) if $i == 0;
    $pmsg[$i] = new Message::Entity %eo;
    $pmsg[$i]->header ($outer_header->clone);
    my $hdr = $pmsg[$i]->header;
    $hdr->replace (subject
      => $i == 0? $subject:
         sprintf ($option{-subject_format_pattern}, $subject, $i+1, $#pbody+1));
    my $ct = $hdr->field ('content-type');
    $ct->parameter (number => $i +1);
    $ct->parameter (total => $#pbody +1);
    $pmsg[$i]->body ($pbody[$i]);
    if ($i == 0) {
      $pmsg[$i]->stringify;
      $first_mid = $hdr->field ('message-id');
    } else {
      $hdr->field ('references')->add ($first_mid);
      $hdr->field ('user-agent')->add ('Message-Partial-pm' => $VERSION);
    }
  }
  @pmsg;
}

sub reassembly (@) {
  my @msg = @_;
  my ($id, @part);
  for my $msg (@msg) {
    unless (ref $msg) {
      $msg = parse Message::Entity $msg;
    }
    my $ct = $msg->header->field ('content-type', -new_item_unless_exist => 0) if ref $msg;
    if (ref $ct && $ct->media_type eq 'message/partial') {
      unless (length $id) {
        $id = $ct->parameter ('id');
      } elsif ($id ne $ct->parameter ('id')) {
        next;
      }
      $part[ $ct->parameter ('number') ] = $msg;
      my $total = $ct->parameter ('total');
      $#part = $total if $total && $#part < $total;
    }
  }
  my $msg = '';
  for my $i (1..$#part) {
    if (ref $part[$i]) {
      $msg .= $part[$i]->body;
    } else {
      Carp::carp "reassembly: part $i of $#part is missing";
    }
  };
  $msg = parse Message::Entity $msg,
        -add_ua => 0,
        -fill_ct        => 0,
        -fill_date      => 0,
        -fill_mimever   => 0,
        -fill_msgid     => 0,
  ;
  my $inner_header = $msg->header;
  my $hdr;
  if (ref $part[1]) {
    $hdr = $msg->header ($part[1]->header);
    $hdr->delete ({-by => 'ns'}, $Message::Header::NS_phname2uri{content});
    $hdr->delete (grep {$ENCLOSED_FIELD{$_} > 1} keys %ENCLOSED_FIELD);
  } else {
    $hdr = $msg->header ('');
  }
  $inner_header->scan (sub {
    my $i = $_[1];
    my $rfc822 = $Message::Header::NS_phname2uri{'x-rfc822'};
    if ($i->{ns} eq $Message::Header::NS_phname2uri{content}
     || $i->{ns} eq $rfc822 && $ENCLOSED_FIELD{ $i->{name} }) {
      $msg->header->replace ($i->{name} => [ $i->{body} , ns => $i->{ns} ] );
    }
  });
  $msg;
}

=head1 SEE ALSO

L<Message::Entity>

RFC 1341 E<lt>urn:ietf:rfc:1341E<gt>,
RFC 1521 E<lt>urn:ietf:rfc:1521E<gt>,
RFC 2046 E<lt>urn:ietf:rfc:2046E<gt>

RFC 822 E<lt>urn:ietf:rfc:822E<gt>,
RFC 2822 E<lt>urn:ietf:rfc:2822E<gt>

=head1 LICENSE

Copyright 2002 wakaba E<lt>[email protected]<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/03 23:39:15 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Partial --- Perl module for partial message defined by MIME
5			(message/partial)
6
7			=cut
8
9			package Message::Partial;
10			use strict;
11			use vars qw(%OPTION $VERSION);
12	wakaba	1.5	$VERSION=do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13	wakaba	1.1
14			require Message::Entity;
15			require Message::Header;
16			require Message::Field::MsgID;
17
18			%OPTION = (
19	wakaba	1.2	-part_length => 60 * 1024,
20	wakaba	1.1	-subject_format_pattern => '%s (%d/%d)',
21			);
22
23	wakaba	1.2	my %ENCLOSED_FIELD = (
24	wakaba	1.4	'disposition-notification-to' => 1, ## RFC 2298
25			'disposition-notification-options' => 1, ## RFC 2298
26	wakaba	1.3	encrypted => 1, ## RFC 1521
27	wakaba	1.2	'message-id' => 2, ## RFC 1341
28	wakaba	1.4	'mime-version' => 2, ## RFC 1521
29			'original-recipient' => 1, ## RFC 2298
30	wakaba	1.3	subject => 1, ## RFC 2046
31	wakaba	1.2	'user-agent' => 1, ## non-standard extension
32	wakaba	1.4	## Note: If value is 2, that header field from the first fragment
33			## is removed. 1 or 0, not removed. Usually, 1-valued fields
34			## are encapsulated and does not occur in fragments. Such
35			## context, 1 and 2 have no difference.
36	wakaba	1.2	);
37	wakaba	1.1	sub fragmentate ($;%) {
38			my $msg = shift;
39			my %params = @_;
40			my %option = %OPTION;
41			for (grep {/^-/} keys %params) {$option{$_} = $params{$_}}
42
43			if (ref $msg) {
44			$msg = $msg->clone;
45			} else {
46			$msg = parse Message::Entity $msg;
47			}
48			my @copy_field;
49			$msg->option (force_mime_entity => 1);
50			$msg->stringify; ## Make fill_* work
51			$msg->header->scan (sub {
52			my $i = $_[1];
53	wakaba	1.5	my $rfc822 = $Message::Header::NS_phname2uri{'x-rfc822'};
54	wakaba	1.2	if ($i->{ns} eq $Message::Header::NS_phname2uri{content}) {
55			push @copy_field, {%$i};
56			$i->{name} = undef;
57			} elsif ($i->{ns} eq $rfc822 && $ENCLOSED_FIELD{ $i->{name} }) {
58			#push @copy_field, Message::Util::make_clone ($i);
59			##$i->{name} = undef; ## Don't remove to keep compatible w/ RFC 1341/1521
60			push @copy_field, {%$i};
61			$i->{name} = undef;
62	wakaba	1.1	}
63			});
64			my $outer_header = $msg->header;
65			my $inner_header = new Message::Header;
66			$inner_header->{value} = \@copy_field; ## Warning: direct access to internal structure!
67			$msg->header ($inner_header);
68			my @msg = split /\x0D\x0A/, $msg->stringify (-accept_cte => '7bit');
69			my @pbody = ('');
70			for (@msg) {
71			if (length $pbody[$#pbody] > $option{-part_length}) {
72			push @pbody, '';
73			}
74			$pbody[$#pbody] .= $_."\x0D\x0A";
75			}
76			my @pmsg;
77			my $subject = $inner_header->field ('subject', -new_item_unless_exist => 0);
78			my $ct = $outer_header->field ('content-type');
79			$ct->media_type ('message/partial');
80			my $as = $outer_header->field ('resent-from', -new_item_unless_exist => 0)
81			\|\| $outer_header->field ('from', -new_item_unless_exist => 0);
82			$as = $as->addr_spec if ref $as;
83			$as \|\|= '[email protected]';
84			my $pid = Message::Field::MsgID->new (addr_spec => $as);
85			$ct->parameter (id => $pid->content);
86			my $first_mid;
87			for my $i (0..$#pbody) {
88	wakaba	1.2	my %eo; %eo = (
89			-add_ua => 0,
90			# -fill_date => 0,
91			) if $i == 0;
92			$pmsg[$i] = new Message::Entity %eo;
93	wakaba	1.1	$pmsg[$i]->header ($outer_header->clone);
94			my $hdr = $pmsg[$i]->header;
95			$hdr->replace (subject
96	wakaba	1.2	=> $i == 0? $subject:
97			sprintf ($option{-subject_format_pattern}, $subject, $i+1, $#pbody+1));
98	wakaba	1.1	my $ct = $hdr->field ('content-type');
99			$ct->parameter (number => $i +1);
100			$ct->parameter (total => $#pbody +1);
101			$pmsg[$i]->body ($pbody[$i]);
102			if ($i == 0) {
103			$pmsg[$i]->stringify;
104			$first_mid = $hdr->field ('message-id');
105			} else {
106			$hdr->field ('references')->add ($first_mid);
107	wakaba	1.2	$hdr->field ('user-agent')->add ('Message-Partial-pm' => $VERSION);
108	wakaba	1.1	}
109			}
110			@pmsg;
111			}
112
113	wakaba	1.2	sub reassembly (@) {
114			my @msg = @_;
115			my ($id, @part);
116			for my $msg (@msg) {
117			unless (ref $msg) {
118			$msg = parse Message::Entity $msg;
119			}
120			my $ct = $msg->header->field ('content-type', -new_item_unless_exist => 0) if ref $msg;
121			if (ref $ct && $ct->media_type eq 'message/partial') {
122			unless (length $id) {
123			$id = $ct->parameter ('id');
124			} elsif ($id ne $ct->parameter ('id')) {
125			next;
126			}
127			$part[ $ct->parameter ('number') ] = $msg;
128			my $total = $ct->parameter ('total');
129			$#part = $total if $total && $#part < $total;
130			}
131			}
132			my $msg = '';
133			for my $i (1..$#part) {
134			if (ref $part[$i]) {
135			$msg .= $part[$i]->body;
136			} else {
137			Carp::carp "reassembly: part $i of $#part is missing";
138			}
139			};
140			$msg = parse Message::Entity $msg,
141			-add_ua => 0,
142			-fill_ct => 0,
143			-fill_date => 0,
144			-fill_mimever => 0,
145			-fill_msgid => 0,
146			;
147			my $inner_header = $msg->header;
148			my $hdr;
149			if (ref $part[1]) {
150			$hdr = $msg->header ($part[1]->header);
151			$hdr->delete ({-by => 'ns'}, $Message::Header::NS_phname2uri{content});
152			$hdr->delete (grep {$ENCLOSED_FIELD{$_} > 1} keys %ENCLOSED_FIELD);
153			} else {
154			$hdr = $msg->header ('');
155			}
156			$inner_header->scan (sub {
157			my $i = $_[1];
158	wakaba	1.5	my $rfc822 = $Message::Header::NS_phname2uri{'x-rfc822'};
159	wakaba	1.2	if ($i->{ns} eq $Message::Header::NS_phname2uri{content}
160			\|\| $i->{ns} eq $rfc822 && $ENCLOSED_FIELD{ $i->{name} }) {
161			$msg->header->replace ($i->{name} => [ $i->{body} , ns => $i->{ns} ] );
162			}
163			});
164			$msg;
165			}
166
167	wakaba	1.1	=head1 SEE ALSO
168
169			L<Message::Entity>
170
171			RFC 1341 E<lt>urn:ietf:rfc:1341E<gt>,
172			RFC 1521 E<lt>urn:ietf:rfc:1521E<gt>,
173			RFC 2046 E<lt>urn:ietf:rfc:2046E<gt>
174
175			RFC 822 E<lt>urn:ietf:rfc:822E<gt>,
176			RFC 2822 E<lt>urn:ietf:rfc:2822E<gt>
177
178			=head1 LICENSE
179
180			Copyright 2002 wakaba E<lt>[email protected]<gt>.
181
182			This program is free software; you can redistribute it and/or modify
183			it under the terms of the GNU General Public License as published by
184			the Free Software Foundation; either version 2 of the License, or
185			(at your option) any later version.
186
187			This program is distributed in the hope that it will be useful,
188			but WITHOUT ANY WARRANTY; without even the implied warranty of
189			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
190			GNU General Public License for more details.
191
192			You should have received a copy of the GNU General Public License
193			along with this program; see the file COPYING. If not, write to
194			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
195			Boston, MA 02111-1307, USA.
196
197			=head1 CHANGE
198
199			See F<ChangeLog>.
200	wakaba	1.5	$Date: 2002/07/03 23:39:15 $
201	wakaba	1.1
202			=cut
203
204			1;