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.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

require Message::Body::Text;
push @ISA, qw(Message::Body::Text);
require Message::Header::Message;

%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} = [];
  $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 (per_recipient => ${$_[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) {
    $self->{per_message} = $np;
  }
  $self->{per_message} = $self->_parse_value (per_message => $self->{per_message})
    if   ($self->{option}->{parse_all} && defined $np)
      || (defined wantarray);
  $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} });
}
*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 (&Message::Util::get_host_fqdn || '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@'. (&Message::Util::get_host_fqdn || '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 12:39:39 $

=cut

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	$VERSION=do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13
14	require Message::Body::Text;
15	push @ISA, qw(Message::Body::Text);
16	require Message::Header::Message;
17
18	%DEFAULT = (
19	-_ARRAY_NAME => 'value',
20	-_METHODS => [qw\|entity_header add delete count item per_message per_recipient\|],
21	-_MEMBERS => [qw\|per_message\|],
22	-linebreak_strict => 0,
23	-media_type => 'message',
24	-media_subtype => 'delivery-status',
25	-parse_all => 0,
26	#use_normalization => 0,
27	-value_type => {},
28	);
29
30	=head1 CONSTRUCTORS
31
32	The following methods construct new objects:
33
34	=over 4
35
36	=cut
37
38	## Initialize of this class -- called by constructors
39	sub _init ($;%) {
40	my $self = shift;
41	my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
42	my %option = @_;
43	$self->SUPER::_init (%$DEFAULT, %option);
44	$self->{value} = [];
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	-hook_init_fill_options => \&_fill_init_pm,
49	-hook_stringify_fill_fields => \&_fill_fields_pm,
50	}];
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	-hook_init_fill_options => \&_fill_init_pr,
55	-hook_stringify_fill_fields => \&_fill_fields_pr,
56	}];
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 (per_recipient => ${$_[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	$self->{per_message} = $np;
167	}
168	$self->{per_message} = $self->_parse_value (per_message => $self->{per_message})
169	if ($self->{option}->{parse_all} && defined $np)
170	\|\| (defined wantarray);
171	$self->{per_message};
172	}
173
174	sub per_recipient { shift->item (@_) }
175
176	=head2 $self->stringify ([%option])
177
178	Returns the C<body> as a string.
179
180	=cut
181
182	sub stringify ($;%) {
183	my $self = shift;
184	my %o = @_; my %option = %{$self->{option}};
185	for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
186	$self->_delete_empty;
187	$self->add ({-parse => 1}, '') unless $#{ $self->{value} } + 1;
188	join ("\x0D\x0A", $self->{per_message}, @{ $self->{value} });
189	}
190	*as_string = \&stringify;
191
192	sub _fill_init_pm ($\%) {
193	my ($hdr, $option) = @_;
194	unless (defined $option->{fill_reporting_mta}) {
195	$option->{fill_reporting_mta} = 1;
196	$option->{fill_reporting_mta_name} = 'reporting-mta';
197	}
198	}
199	sub _fill_init_pr ($\%) {
200	my ($hdr, $option) = @_;
201	unless (defined $option->{fill_action}) {
202	$option->{fill_action} = 1;
203	}
204	unless (defined $option->{fill_final_recipient}) {
205	$option->{fill_final_recipient} = 1;
206	}
207	unless (defined $option->{fill_status}) {
208	$option->{fill_status} = 1;
209	}
210	}
211
212	sub _fill_fields_pm ($\%\%) {
213	my ($hdr, $exist, $option) = @_;
214	my $ns = ':'.$option->{ns_default_phuri};
215	if ($option->{fill_reporting_mta}
216	&& !$exist->{ $option->{fill_reporting_mta_name}.$ns }) {
217	my $rmta = $hdr->field ($option->{fill_reporting_mta_name});
218	$rmta->type ('dns');
219	$rmta->value (&Message::Util::get_host_fqdn \|\| 'localhost');
220	}
221	}
222	sub _fill_fields_pr ($\%\%) {
223	my ($hdr, $exist, $option) = @_;
224	my $ns = ':'.$option->{ns_default_phuri};
225	if ($option->{fill_action} && !$exist->{ 'action'.$ns }) {
226	my $act = $hdr->field ('action');
227	$act->value ('failed');
228	}
229	if ($option->{fill_final_recipient} && !$exist->{ 'final-recipient'.$ns }) {
230	my $fr = $hdr->field ('final-recipient');
231	$fr->type ('rfc822');
232	$fr->value ('foo@'. (&Message::Util::get_host_fqdn \|\| 'bar.invalid'));
233	}
234	if ($option->{fill_status} && !$exist->{ 'status'.$ns }) {
235	my $fr = $hdr->add (status => '4.0.0');
236	}
237	}
238
239	## Inherited: option, clone
240
241	## $self->_option_recursive (\%argv)
242	sub _option_recursive ($\%) {
243	my $self = shift;
244	my $o = shift;
245	for (@{$self->{value}}) {
246	$_->option (%$o) if ref $_;
247	}
248	$self->{per_message}->option (%$o) if ref $self->{per_message};
249	}
250
251	=head1 SEE ALSO
252
253	RFC 1894 <urn:ietf:rfc:1894>
254
255	=head1 LICENSE
256
257	Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
258
259	This program is free software; you can redistribute it and/or modify
260	it under the terms of the GNU General Public License as published by
261	the Free Software Foundation; either version 2 of the License, or
262	(at your option) any later version.
263
264	This program is distributed in the hope that it will be useful,
265	but WITHOUT ANY WARRANTY; without even the implied warranty of
266	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
267	GNU General Public License for more details.
268
269	You should have received a copy of the GNU General Public License
270	along with this program; see the file COPYING. If not, write to
271	the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
272	Boston, MA 02111-1307, USA.
273
274	=head1 CHANGE
275
276	See F<ChangeLog>.
277	$Date: 2002/07/08 12:39:39 $
278
279	=cut
280
281	1;