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.5 $=~/\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},
  }];
  $self->{option}->{value_type}->{per_recipient} = ['Message::Header',{
        -format => 'message-delivery-status-per-recipient',
        -ns_default_phuri       => $Message::Header::Message::DeliveryStatus::OPTION{namespace_uri},
  }];
}

=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;
  join ("\x0D\x0A", $self->{per_message}, @{ $self->{value} }) . "\x0D\x0A";
}
*as_string = \&stringify;

## 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/04 06:38:21 $

=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			$VERSION=do{my @r=(q$Revision: 1.5 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13
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			}];
49			$self->{option}->{value_type}->{per_recipient} = ['Message::Header',{
50			-format => 'message-delivery-status-per-recipient',
51			-ns_default_phuri => $Message::Header::Message::DeliveryStatus::OPTION{namespace_uri},
52			}];
53			}
54
55			=item $body = Message::Body::Multipart->new ([%options])
56
57			Constructs a new object. You might pass some options as parameters
58			to the constructor.
59
60			=cut
61
62			## Inherited
63
64			=item $body = Message::Body::Multipart->parse ($body, [%options])
65
66			Constructs a new object with given field body. You might pass
67			some options as parameters to the constructor.
68
69			=cut
70
71			sub parse ($$;%) {
72			my $class = shift;
73			my $self = bless {}, $class;
74			my $body = shift;
75			$self->_init (@_);
76			my $nl = "\x0D\x0A";
77			unless ($self->{option}->{linebreak_strict}) {
78			$nl = Message::Util::decide_newline ($body);
79			}
80
81			my @v;
82			@v = map { $_ . $nl } split (/$nl$nl/, $body);
83			$self->{per_message} = shift @v;
84
85			if ($self->{option}->{parse_all}) {
86			$self->{per_message} = $self->_parse_value (per_message => $self->{per_message});
87			@v = map {
88			$self->_parse_value (per_recipient => $_);
89			} @v;
90			}
91			$self->{value} = \@v;
92			$self;
93			}
94
95			=back
96
97			=cut
98
99			## add, item, delete, count
100
101			## item-by?, \$checked-item, {item-key => 1}, \%option
102			sub _item_match ($$\$\%\%) {
103			my $self = shift;
104			my ($by, $i, $list, $option) = @_;
105			return 0 unless ref $$i; ## Already removed
106			if ($by eq 'action') {
107			$$i = $self->_parse_value (per_recipient => $$i);
108			return 1 if ref $$i && $list->{ lc $$i->field ('action')->value };
109			} elsif ($by eq 'recipient') {
110			$$i = $self->_parse_value (per_recipient => $$i);
111			return 0 unless ref $$i;
112			return 1 if $list->{ $$i->field ('final-recipient')->value };
113			my $r = $$i->field ('original-recipient', -new_item_unless_exist => 0);
114			return 1 if ref $r && $list->{ $r->value };
115			$r = $$i->field ('x-actual-recipient', -new_item_unless_exist => 0);
116			return 1 if ref $r && $list->{ $r->value };
117			}
118			0;
119			}
120			*_delete_match = \&_item_match;
121
122			## Returns returned item value \$item-value, \%option
123			sub _item_return_value ($\$\%) {
124			unless (ref ${$_[1]}) {
125			${$_[1]} = $_[0]->_parse_value (body_part => ${$_[1]})
126			if $_[2]->{parse};
127			}
128			${$_[1]};
129			}
130			*_add_return_value = \&_item_return_value;
131
132			## Returns returned (new created) item value $name, \%option
133			sub _item_new_value ($$\%) {
134			my $v = shift->_parse_value (per_recipient => '');
135			my ($key, $option) = @_;
136			if ($option->{by} eq 'action') {
137			$v->header->field ('action')->value ($key);
138			} elsif ($option->{by} eq 'recipient') {
139			$v->header->add ('final-recipient' => $key);
140			}
141			$v;
142			}
143
144			sub _add_array_check ($$\%) {
145			my $self = shift;
146			my ($value, $option) = @_;
147			my $value_option = {};
148			if (ref $value eq 'ARRAY') {
149			($value, %$value_option) = @$value;
150			}
151			$value = $self->_parse_value (per_recipient => $value) if $$option{parse};
152			$$option{parse} = 0;
153			(1, value => $value);
154			}
155
156			## entity_header: Inherited
157
158			sub per_message ($;$) {
159			my $self = shift;
160			my $np = shift;
161			if (defined $np) {
162			$np = $self->_parse_value (per_message => $np) if $self->{option}->{parse_all};
163			$self->{per_message} = $np;
164			}
165			$self->{per_message};
166			}
167
168			sub per_recipient { shift->item (@_) }
169
170			=head2 $self->stringify ([%option])
171
172			Returns the C<body> as a string.
173
174			=cut
175
176			sub stringify ($;%) {
177			my $self = shift;
178			my %o = @_; my %option = %{$self->{option}};
179			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
180			$self->_delete_empty;
181			join ("\x0D\x0A", $self->{per_message}, @{ $self->{value} }) . "\x0D\x0A";
182			}
183			*as_string = \&stringify;
184
185			## Inherited: option, clone
186
187			## $self->_option_recursive (\%argv)
188			sub _option_recursive ($\%) {
189			my $self = shift;
190			my $o = shift;
191			for (@{$self->{value}}) {
192			$_->option (%$o) if ref $_;
193			}
194			$self->{per_message}->option (%$o) if ref $self->{per_message};
195			}
196
197			=head1 SEE ALSO
198
199			RFC 1894 <urn:ietf:rfc:1894>
200
201			=head1 LICENSE
202
203			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
204
205			This program is free software; you can redistribute it and/or modify
206			it under the terms of the GNU General Public License as published by
207			the Free Software Foundation; either version 2 of the License, or
208			(at your option) any later version.
209
210			This program is distributed in the hope that it will be useful,
211			but WITHOUT ANY WARRANTY; without even the implied warranty of
212			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
213			GNU General Public License for more details.
214
215			You should have received a copy of the GNU General Public License
216			along with this program; see the file COPYING. If not, write to
217			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
218			Boston, MA 02111-1307, USA.
219
220			=head1 CHANGE
221
222			See F<ChangeLog>.
223			$Date: 2002/07/04 06:38:21 $
224
225			=cut
226
227			1;