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.5 $=~/\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 ||= 'part@partial.message.pm.invalid';
    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,
        -fill_missing_fields    => 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>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/07 00:46:07 $

=cut

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	$VERSION=do{my @r=(q$Revision: 1.5 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13
14	require Message::Entity;
15	require Message::Header;
16	require Message::Field::MsgID;
17
18	%OPTION = (
19	-part_length => 60 * 1024,
20	-subject_format_pattern => '%s (%d/%d)',
21	);
22
23	my %ENCLOSED_FIELD = (
24	'disposition-notification-to' => 1, ## RFC 2298
25	'disposition-notification-options' => 1, ## RFC 2298
26	encrypted => 1, ## RFC 1521
27	'message-id' => 2, ## RFC 1341
28	'mime-version' => 2, ## RFC 1521
29	'original-recipient' => 1, ## RFC 2298
30	subject => 1, ## RFC 2046
31	'user-agent' => 1, ## non-standard extension
32	## 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	);
37	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	my $rfc822 = $Message::Header::NS_phname2uri{'x-rfc822'};
54	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	}
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 \|\|= 'part@partial.message.pm.invalid';
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	my %eo; %eo = (
89	-add_ua => 0,
90	# -fill_date => 0,
91	) if $i == 0;
92	$pmsg[$i] = new Message::Entity %eo;
93	$pmsg[$i]->header ($outer_header->clone);
94	my $hdr = $pmsg[$i]->header;
95	$hdr->replace (subject
96	=> $i == 0? $subject:
97	sprintf ($option{-subject_format_pattern}, $subject, $i+1, $#pbody+1));
98	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	$hdr->field ('user-agent')->add ('Message-Partial-pm' => $VERSION);
108	}
109	}
110	@pmsg;
111	}
112
113	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	-fill_missing_fields => 0,
142	;
143	my $inner_header = $msg->header;
144	my $hdr;
145	if (ref $part[1]) {
146	$hdr = $msg->header ($part[1]->header);
147	$hdr->delete ({-by => 'ns'}, $Message::Header::NS_phname2uri{content});
148	$hdr->delete (grep {$ENCLOSED_FIELD{$_} > 1} keys %ENCLOSED_FIELD);
149	} else {
150	$hdr = $msg->header ('');
151	}
152	$inner_header->scan (sub {
153	my $i = $_[1];
154	my $rfc822 = $Message::Header::NS_phname2uri{'x-rfc822'};
155	if ($i->{ns} eq $Message::Header::NS_phname2uri{content}
156	\|\| $i->{ns} eq $rfc822 && $ENCLOSED_FIELD{ $i->{name} }) {
157	$msg->header->replace ($i->{name} => [ $i->{body} , ns => $i->{ns} ] );
158	}
159	});
160	$msg;
161	}
162
163	=head1 SEE ALSO
164
165	L<Message::Entity>
166
167	RFC 1341 E<lt>urn:ietf:rfc:1341E<gt>,
168	RFC 1521 E<lt>urn:ietf:rfc:1521E<gt>,
169	RFC 2046 E<lt>urn:ietf:rfc:2046E<gt>
170
171	RFC 822 E<lt>urn:ietf:rfc:822E<gt>,
172	RFC 2822 E<lt>urn:ietf:rfc:2822E<gt>
173
174	=head1 LICENSE
175
176	Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
177
178	This program is free software; you can redistribute it and/or modify
179	it under the terms of the GNU General Public License as published by
180	the Free Software Foundation; either version 2 of the License, or
181	(at your option) any later version.
182
183	This program is distributed in the hope that it will be useful,
184	but WITHOUT ANY WARRANTY; without even the implied warranty of
185	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
186	GNU General Public License for more details.
187
188	You should have received a copy of the GNU General Public License
189	along with this program; see the file COPYING. If not, write to
190	the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
191	Boston, MA 02111-1307, USA.
192
193	=head1 CHANGE
194
195	See F<ChangeLog>.
196	$Date: 2002/07/07 00:46:07 $
197
198	=cut
199
200	1;