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.1 $=~/\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 = (
        encrypted       => 2,   ## RFC 1521
        'message-id'    => 2,   ## RFC 1341
        'mime-version'  => 2,   ## RFC 1521
        subject => 2,   ## RFC 2046
        'user-agent'    => 1,   ## non-standard extension
);
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{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{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/06/11 13:01:21 $

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