Message/Body/MessageDeliveryStatus.pm


=head1 NAME

Message::Body::MessageDeliveryStatus --- Perl module
for "message/delivery-status" Internet Media Types

=cut

package Message::Body::MessageDeliveryStatus;
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 = (
  -_ARRAY_NAME  => 'value',
  -_METHODS     => [qw|entity_header add delete count item per_message per_recipient|],
  -_MEMBERS     => [qw|per_message|],
  -linebreak_strict     => 0,
  -media_type   => 'message',
  -media_subtype        => 'delivery-status',
  -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->{value} = [];
  require Message::Header::Message;
  $self->{option}->{value_type}->{per_message} = ['Message::Header',{
        -format => 'message-delivery-status-per-message',
        -ns_default_phuri       => $Message::Header::Message::DeliveryStatus::OPTION{namespace_uri},
        -hook_init_fill_options => \&_fill_init_pm,
        -hook_stringify_fill_fields     => \&_fill_fields_pm,
  }];
  $self->{option}->{value_type}->{per_recipient} = ['Message::Header',{
        -format => 'message-delivery-status-per-recipient',
        -ns_default_phuri       => $Message::Header::Message::DeliveryStatus::OPTION{namespace_uri},
        -hook_init_fill_options => \&_fill_init_pr,
        -hook_stringify_fill_fields     => \&_fill_fields_pr,
  }];
}

=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 $body = shift;
  $self->_init (@_);
  my $nl = "\x0D\x0A";
  unless ($self->{option}->{linebreak_strict}) {
    $nl = Message::Util::decide_newline ($body);
  }
  
  my @v;
  @v = map { $_ . $nl } split (/$nl$nl/, $body);
  $self->{per_message} = shift @v;
  
  if ($self->{option}->{parse_all}) {
    $self->{per_message} = $self->_parse_value (per_message => $self->{per_message});
    @v = map {
        $self->_parse_value (per_recipient => $_);
    } @v;
  }
  $self->{value} = \@v;
  $self;
}

=back

=cut

## add, item, delete, count

## item-by?, \$checked-item, {item-key => 1}, \%option
sub _item_match ($$\$\%\%) {
  my $self = shift;
  my ($by, $i, $list, $option) = @_;
  return 0 unless ref $$i;  ## Already removed
  if ($by eq 'action') {
    $$i = $self->_parse_value (per_recipient => $$i);
    return 1 if ref $$i && $list->{ lc $$i->field ('action')->value };
  } elsif ($by eq 'recipient') {
    $$i = $self->_parse_value (per_recipient => $$i);
    return 0 unless ref $$i;
    return 1 if $list->{ $$i->field ('final-recipient')->value };
    my $r = $$i->field ('original-recipient', -new_item_unless_exist => 0);
    return 1 if ref $r && $list->{ $r->value };
    $r = $$i->field ('x-actual-recipient', -new_item_unless_exist => 0);
    return 1 if ref $r && $list->{ $r->value };
  }
  0;
}
*_delete_match = \&_item_match;

## Returns returned item value    \$item-value, \%option
sub _item_return_value ($\$\%) {
  unless (ref ${$_[1]}) {
    ${$_[1]} = $_[0]->_parse_value (body_part => ${$_[1]})
      if $_[2]->{parse};
  }
  ${$_[1]};
}
*_add_return_value = \&_item_return_value;

## Returns returned (new created) item value    $name, \%option
sub _item_new_value ($$\%) {
  my $v = shift->_parse_value (per_recipient => '');
  my ($key, $option) = @_;
  if ($option->{by} eq 'action') {
    $v->header->field ('action')->value ($key);
  } elsif ($option->{by} eq 'recipient') {
    $v->header->add ('final-recipient' => $key);
  }
  $v;
}

sub _add_array_check ($$\%) {
  my $self = shift;
  my ($value, $option) = @_;
  my $value_option = {};
  if (ref $value eq 'ARRAY') {
    ($value, %$value_option) = @$value;
  }
  $value = $self->_parse_value (per_recipient => $value) if $$option{parse};
  $$option{parse} = 0;
  (1, value => $value);
}

## entity_header: Inherited

sub per_message ($;$) {
  my $self = shift;
  my $np = shift;
  if (defined $np) {
    $np = $self->_parse_value (per_message => $np) if $self->{option}->{parse_all};
    $self->{per_message} = $np;
  }
  $self->{per_message};
}

sub per_recipient { shift->item (@_) }

=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{$_}}
  $self->_delete_empty;
  $self->add ({-parse => 1}, '') unless $#{ $self->{value} } + 1;
  join ("\x0D\x0A", $self->{per_message}, @{ $self->{value} }) . "\x0D\x0A";
}
*as_string = \&stringify;

sub _fill_init_pm ($\%) {
  my ($hdr, $option) = @_;
  unless (defined $option->{fill_reporting_mta}) {
    $option->{fill_reporting_mta} = 1;
    $option->{fill_reporting_mta_name} = 'reporting-mta';
  }
}
sub _fill_init_pr ($\%) {
  my ($hdr, $option) = @_;
  unless (defined $option->{fill_action}) {
    $option->{fill_action} = 1;
  }
  unless (defined $option->{fill_final_recipient}) {
    $option->{fill_final_recipient} = 1;
  }
  unless (defined $option->{fill_status}) {
    $option->{fill_status} = 1;
  }
}

sub _fill_fields_pm ($\%\%) {
  my ($hdr, $exist, $option) = @_;
  my $ns = ':'.$option->{ns_default_phuri};
  if ($option->{fill_reporting_mta}
    && !$exist->{ $option->{fill_reporting_mta_name}.$ns  }) {
    my $rmta = $hdr->field ($option->{fill_reporting_mta_name});
    $rmta->type ('dns');
    $rmta->value ('localhost');
  }
}
sub _fill_fields_pr ($\%\%) {
  my ($hdr, $exist, $option) = @_;
  my $ns = ':'.$option->{ns_default_phuri};
  if ($option->{fill_action} && !$exist->{ 'action'.$ns }) {
    my $act = $hdr->field ('action');
    $act->value ('failed');
  }
  if ($option->{fill_final_recipient} && !$exist->{ 'final-recipient'.$ns }) {
    my $fr = $hdr->field ('final-recipient');
    $fr->type ('rfc822');
    $fr->value ('foo@bar.invalid');
  }
  if ($option->{fill_status} && !$exist->{ 'status'.$ns }) {
    my $fr = $hdr->add (status => '4.0.0');
  }
}

## Inherited: option, clone

## $self->_option_recursive (\%argv)
sub _option_recursive ($\%) {
  my $self = shift;
  my $o = shift;
  for (@{$self->{value}}) {
    $_->option (%$o) if ref $_;
  }
  $self->{per_message}->option (%$o) if ref $self->{per_message};
}

=head1 SEE ALSO

RFC 1894 <urn:ietf:rfc:1894>

=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/08 11:48:12 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Body::MessageDeliveryStatus --- Perl module
5			for "message/delivery-status" Internet Media Types
6
7			=cut
8
9			package Message::Body::MessageDeliveryStatus;
10			use strict;
11			use vars qw(%DEFAULT @ISA $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::Body::Text;
15			push @ISA, qw(Message::Body::Text);
16
17			%DEFAULT = (
18			-_ARRAY_NAME => 'value',
19			-_METHODS => [qw\|entity_header add delete count item per_message per_recipient\|],
20			-_MEMBERS => [qw\|per_message\|],
21			-linebreak_strict => 0,
22			-media_type => 'message',
23			-media_subtype => 'delivery-status',
24			-parse_all => 0,
25			#use_normalization => 0,
26			-value_type => {},
27			);
28
29			=head1 CONSTRUCTORS
30
31			The following methods construct new objects:
32
33			=over 4
34
35			=cut
36
37			## Initialize of this class -- called by constructors
38			sub _init ($;%) {
39			my $self = shift;
40			my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
41			my %option = @_;
42			$self->SUPER::_init (%$DEFAULT, %option);
43			$self->{value} = [];
44			require Message::Header::Message;
45			$self->{option}->{value_type}->{per_message} = ['Message::Header',{
46			-format => 'message-delivery-status-per-message',
47			-ns_default_phuri => $Message::Header::Message::DeliveryStatus::OPTION{namespace_uri},
48	wakaba	1.2	-hook_init_fill_options => \&_fill_init_pm,
49			-hook_stringify_fill_fields => \&_fill_fields_pm,
50	wakaba	1.1	}];
51			$self->{option}->{value_type}->{per_recipient} = ['Message::Header',{
52			-format => 'message-delivery-status-per-recipient',
53			-ns_default_phuri => $Message::Header::Message::DeliveryStatus::OPTION{namespace_uri},
54	wakaba	1.2	-hook_init_fill_options => \&_fill_init_pr,
55			-hook_stringify_fill_fields => \&_fill_fields_pr,
56	wakaba	1.1	}];
57			}
58
59			=item $body = Message::Body::Multipart->new ([%options])
60
61			Constructs a new object. You might pass some options as parameters
62			to the constructor.
63
64			=cut
65
66			## Inherited
67
68			=item $body = Message::Body::Multipart->parse ($body, [%options])
69
70			Constructs a new object with given field body. You might pass
71			some options as parameters to the constructor.
72
73			=cut
74
75			sub parse ($$;%) {
76			my $class = shift;
77			my $self = bless {}, $class;
78			my $body = shift;
79			$self->_init (@_);
80			my $nl = "\x0D\x0A";
81			unless ($self->{option}->{linebreak_strict}) {
82			$nl = Message::Util::decide_newline ($body);
83			}
84
85			my @v;
86			@v = map { $_ . $nl } split (/$nl$nl/, $body);
87			$self->{per_message} = shift @v;
88
89			if ($self->{option}->{parse_all}) {
90			$self->{per_message} = $self->_parse_value (per_message => $self->{per_message});
91			@v = map {
92			$self->_parse_value (per_recipient => $_);
93			} @v;
94			}
95			$self->{value} = \@v;
96			$self;
97			}
98
99			=back
100
101			=cut
102
103			## add, item, delete, count
104
105			## item-by?, \$checked-item, {item-key => 1}, \%option
106			sub _item_match ($$\$\%\%) {
107			my $self = shift;
108			my ($by, $i, $list, $option) = @_;
109			return 0 unless ref $$i; ## Already removed
110			if ($by eq 'action') {
111			$$i = $self->_parse_value (per_recipient => $$i);
112			return 1 if ref $$i && $list->{ lc $$i->field ('action')->value };
113			} elsif ($by eq 'recipient') {
114			$$i = $self->_parse_value (per_recipient => $$i);
115			return 0 unless ref $$i;
116			return 1 if $list->{ $$i->field ('final-recipient')->value };
117			my $r = $$i->field ('original-recipient', -new_item_unless_exist => 0);
118			return 1 if ref $r && $list->{ $r->value };
119			$r = $$i->field ('x-actual-recipient', -new_item_unless_exist => 0);
120			return 1 if ref $r && $list->{ $r->value };
121			}
122			0;
123			}
124			*_delete_match = \&_item_match;
125
126			## Returns returned item value \$item-value, \%option
127			sub _item_return_value ($\$\%) {
128			unless (ref ${$_[1]}) {
129			${$_[1]} = $_[0]->_parse_value (body_part => ${$_[1]})
130			if $_[2]->{parse};
131			}
132			${$_[1]};
133			}
134			*_add_return_value = \&_item_return_value;
135
136			## Returns returned (new created) item value $name, \%option
137			sub _item_new_value ($$\%) {
138			my $v = shift->_parse_value (per_recipient => '');
139			my ($key, $option) = @_;
140			if ($option->{by} eq 'action') {
141			$v->header->field ('action')->value ($key);
142			} elsif ($option->{by} eq 'recipient') {
143			$v->header->add ('final-recipient' => $key);
144			}
145			$v;
146			}
147
148			sub _add_array_check ($$\%) {
149			my $self = shift;
150			my ($value, $option) = @_;
151			my $value_option = {};
152			if (ref $value eq 'ARRAY') {
153			($value, %$value_option) = @$value;
154			}
155			$value = $self->_parse_value (per_recipient => $value) if $$option{parse};
156			$$option{parse} = 0;
157			(1, value => $value);
158			}
159
160			## entity_header: Inherited
161
162			sub per_message ($;$) {
163			my $self = shift;
164			my $np = shift;
165			if (defined $np) {
166			$np = $self->_parse_value (per_message => $np) if $self->{option}->{parse_all};
167			$self->{per_message} = $np;
168			}
169			$self->{per_message};
170			}
171
172			sub per_recipient { shift->item (@_) }
173
174			=head2 $self->stringify ([%option])
175
176			Returns the C<body> as a string.
177
178			=cut
179
180			sub stringify ($;%) {
181			my $self = shift;
182			my %o = @_; my %option = %{$self->{option}};
183			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
184			$self->_delete_empty;
185	wakaba	1.2	$self->add ({-parse => 1}, '') unless $#{ $self->{value} } + 1;
186	wakaba	1.1	join ("\x0D\x0A", $self->{per_message}, @{ $self->{value} }) . "\x0D\x0A";
187			}
188			*as_string = \&stringify;
189
190	wakaba	1.2	sub _fill_init_pm ($\%) {
191			my ($hdr, $option) = @_;
192			unless (defined $option->{fill_reporting_mta}) {
193			$option->{fill_reporting_mta} = 1;
194			$option->{fill_reporting_mta_name} = 'reporting-mta';
195			}
196			}
197			sub _fill_init_pr ($\%) {
198			my ($hdr, $option) = @_;
199			unless (defined $option->{fill_action}) {
200			$option->{fill_action} = 1;
201			}
202			unless (defined $option->{fill_final_recipient}) {
203			$option->{fill_final_recipient} = 1;
204			}
205			unless (defined $option->{fill_status}) {
206			$option->{fill_status} = 1;
207			}
208			}
209
210			sub _fill_fields_pm ($\%\%) {
211			my ($hdr, $exist, $option) = @_;
212			my $ns = ':'.$option->{ns_default_phuri};
213			if ($option->{fill_reporting_mta}
214			&& !$exist->{ $option->{fill_reporting_mta_name}.$ns }) {
215			my $rmta = $hdr->field ($option->{fill_reporting_mta_name});
216			$rmta->type ('dns');
217			$rmta->value ('localhost');
218			}
219			}
220			sub _fill_fields_pr ($\%\%) {
221			my ($hdr, $exist, $option) = @_;
222			my $ns = ':'.$option->{ns_default_phuri};
223			if ($option->{fill_action} && !$exist->{ 'action'.$ns }) {
224			my $act = $hdr->field ('action');
225			$act->value ('failed');
226			}
227			if ($option->{fill_final_recipient} && !$exist->{ 'final-recipient'.$ns }) {
228			my $fr = $hdr->field ('final-recipient');
229			$fr->type ('rfc822');
230			$fr->value ('foo@bar.invalid');
231			}
232			if ($option->{fill_status} && !$exist->{ 'status'.$ns }) {
233			my $fr = $hdr->add (status => '4.0.0');
234			}
235			}
236
237	wakaba	1.1	## Inherited: option, clone
238
239			## $self->_option_recursive (\%argv)
240			sub _option_recursive ($\%) {
241			my $self = shift;
242			my $o = shift;
243			for (@{$self->{value}}) {
244			$_->option (%$o) if ref $_;
245			}
246			$self->{per_message}->option (%$o) if ref $self->{per_message};
247			}
248
249			=head1 SEE ALSO
250
251			RFC 1894 <urn:ietf:rfc:1894>
252
253			=head1 LICENSE
254
255			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
256
257			This program is free software; you can redistribute it and/or modify
258			it under the terms of the GNU General Public License as published by
259			the Free Software Foundation; either version 2 of the License, or
260			(at your option) any later version.
261
262			This program is distributed in the hope that it will be useful,
263			but WITHOUT ANY WARRANTY; without even the implied warranty of
264			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
265			GNU General Public License for more details.
266
267			You should have received a copy of the GNU General Public License
268			along with this program; see the file COPYING. If not, write to
269			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
270			Boston, MA 02111-1307, USA.
271
272			=head1 CHANGE
273
274			See F<ChangeLog>.
275	wakaba	1.2	$Date: 2002/07/08 11:48:12 $
276	wakaba	1.1
277			=cut
278
279			1;