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>[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/08 12:39:39 $

=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.3	$VERSION=do{my @r=(q$Revision: 1.2 $=~/\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	wakaba	1.3	require Message::Header::Message;
17	wakaba	1.1
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	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	wakaba	1.3	${$_[1]} = $_[0]->_parse_value (per_recipient => ${$_[1]})
130	wakaba	1.1	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	wakaba	1.3	$self->{per_message} = $self->_parse_value (per_message => $self->{per_message})
169			if ($self->{option}->{parse_all} && defined $np)
170			\|\| (defined wantarray);
171	wakaba	1.1	$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	wakaba	1.2	$self->add ({-parse => 1}, '') unless $#{ $self->{value} } + 1;
188	wakaba	1.3	join ("\x0D\x0A", $self->{per_message}, @{ $self->{value} });
189	wakaba	1.1	}
190			*as_string = \&stringify;
191
192	wakaba	1.2	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	wakaba	1.3	$rmta->value (&Message::Util::get_host_fqdn \|\| 'localhost');
220	wakaba	1.2	}
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	wakaba	1.3	$fr->value ('foo@'. (&Message::Util::get_host_fqdn \|\| 'bar.invalid'));
233	wakaba	1.2	}
234			if ($option->{fill_status} && !$exist->{ 'status'.$ns }) {
235			my $fr = $hdr->add (status => '4.0.0');
236			}
237			}
238
239	wakaba	1.1	## 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>[email protected]<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	wakaba	1.3	$Date: 2002/07/08 12:39:39 $
278	wakaba	1.1
279			=cut
280
281			1;