Message/Field/Received.pm


=head1 NAME

Message::Field::Received --- Perl module for C<Received:>
Internet message header field body

=cut

## TODO: reimplemention by using Message::Field::Params

package Message::Field::Received;
use strict;
use vars qw(@ISA %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Util;
require Message::Field::Structured;
push @ISA, qw(Message::Field::Structured);

require Message::Field::Date;
use overload '@{}' => sub {shift->_delete_empty->{value}},
             '""' => sub { $_[0]->stringify };

*REG = \%Message::Util::REG;
## Inherited: comment, quoted_string, domain_literal
        ## WSP, FWS, atext
        ## domain, addr_spec, msg_id
        ## date_time, asctime

        $REG{item_name} = qr/[A-Za-z][0-9A-Za-z-]*[0-9A-Za-z]/;
                ## strictly, item-name = ALPHA *(["-"] (ALPHA / DIGIT))
        $REG{M_name_val_pair} = qr/($REG{item_name})$REG{FWS}($REG{msg_id}|$REG{addr_spec}|$REG{domain}|$REG{atext})/;


=head1 CONSTRUCTORS

The following methods construct new objects:

=over 4

=cut

## Initialize of this class -- called by constructors
sub _init ($;%) {
  my $self = shift;
  my %options = @_;
  my %DEFAULT = (
    -_HASH_NAME => 'value',
    -field_name => 'received',
    #format     ## Inherited
    -parse_all  => 0,
    -validate   => 1,
    -value_type => {'*default'  => [':none:']},
  );
  $self->SUPER::_init (%DEFAULT, %options);
}


=item $r = Message::Field::Received->new ([%options])

Constructs a new object.  You might pass some options as parameters 
to the constructor.

=cut

sub new ($;%) {
  my $self = shift->SUPER::new (@_);
  $self->{date_time} = new Message::Field::Date
      -field_name => $self->{option}->{field_name},
      -field_param_name => 'date-time',
      -format => $self->{option}->{format};
  $self;
}

=item $r = Message::Field::Received->parse ($field-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 $field_body = shift;
  $self->_init (@_);
  $field_body = Message::Util::delete_comment ($field_body);
  $field_body =~ s{;$REG{FWS}($REG{date_time})$REG{FWS}$}{
    $self->{date_time} = parse Message::Field::Date $1,
      -field_name => $self->{option}->{field_name},
      -field_param_name => 'date-time',
      -format => $self->{option}->{format};
    '';
  }ex;
  unless ($self->{date_time}) {
    if ($field_body =~ /($REG{asctime})/) {     ## old USENET format
      $self->{date_time} = parse Message::Field::Date $1,
        -field_name => $self->{option}->{field_name},
        -field_param_name => 'date-time',
        -format => $self->{option}->{format};
      return $self;
    } else {    ## broken!
      $field_body =~ s/;[^;]+$//;
      $self->{date_time} = new Message::Field::Date
        -time_is_unknown => 1,
        -field_name => $self->{option}->{field_name},
        -field_param_name => 'date-time',
        -format => $self->{option}->{format};
    }
  }
  $field_body =~ s{$REG{M_name_val_pair}$REG{FWS}}{
    my ($name, $value) = (lc $1, $2);
    $name =~ tr/-/_/;
    push @{$self->{value}}, [$name => $value];
    ''
  }goex;
  $self;
}

=back

=head1 METHODS

=over 4

=head2 $self->items ()

Return item list hash that contains of C<name-val-list>
array references.

=cut

sub items ($) {@{shift->{value}}}

sub item_name ($$) {
  my $self = shift;
  my $i = shift;
  $self->{value}->[$i]->[0];
}

sub item_value ($$) {
  my $self = shift;
  my $i = shift;
  $self->{value}->[$i]->[1];
}

sub item ($$) {
  my $self = shift;
  my $name = lc shift;
  my @ret;
  for my $item (@{$self->{value}}) {
    if ($item->[0] eq $name) {
      unless (wantarray) {
        return $item->[1];
      } else {
        push @ret, $item->[1];
      }
    }
  }
  @ret;
}

sub date_time ($) {
  my $self = shift;
  $self->{date_time};
}

## add: Inherited
## replace: Inherited

sub _add_hash_check ($$$\%) {
  my $self = shift;
  my ($name => $value, $option) = @_;
  if ($$option{validate} && $name !~ /^$REG{item_name}$/) {
    if ($$option{dont_croak}) {
      return (0);
    } else {
      Carp::croak qq{add/replace: $name: Invalid item-name};
    }
  }
  $value = $self->_item_value ($name => $value) if $$option{parse};
  (1, $name => [$name => $value]);
}
*_replace_hash_check = \&_add_hash_check;

sub _replace_cleaning ($) {
  $_[0]->_delete_empty;
}

=item $count = $r->count ([%options])

Returns the number of C<item-val-pair>s.

Available Options:

=over 2 

=item -name => "C<item-name>"

Counts only C<item-val-oair>s whose name is same as given.

=back

=cut

*_count_cleaning = \&_replace_cleaning;
sub _count_by_name ($$\%) {
  my $self = shift;
  my ($array, $option) = @_;
  my $name = lc ($$option{-name});
  my @a = grep {$_->[0] eq $name} @{$self->{$array}};
  $#a + 1;
}

sub delete ($@) {
  my $self = shift;
  my %delete;
  for (@_) {$delete{lc $_} = 1}
  $self->{value} = [grep {!$delete{$_->[0]}} @{$self->{value}}];
}

sub _delete_empty ($) {
  my $self = shift;
  $self->{value} = [grep {ref $_ && length $_->[0]} @{$self->{value}}];
  $self;
}


sub stringify ($;%) {
  my $self = shift;
  my %option = @_;
  my @return;
  $self->_delete_empty;
  for my $item (@{$self->{value}}) {
    push @return, $item->[0], $item->[1] if $item->[0] =~ /^$REG{item_name}$/;
  }
  join (' ', @return).'; '.$self->{date_time}->as_rfc2822_time;
}
*as_string = \&stringify;

=item $option-value = $r->option ($option-name)

Gets option value.

=item $r->option ($option-name, $option-value, ...)

Set option value(s).  You can pass multiple option name-value pair
as parameter when setting.

=cut

## Inherited

## TODO: $r->value_type

=item $clone = $r->clone ()

Returns a copy of the object.

=cut

## Inherited

=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/05/04 06:03:58 $

=cut

1;
1
2	=head1 NAME
3
4	Message::Field::Received --- Perl module for C<Received:>
5	Internet message header field body
6
7	=cut
8
9	## TODO: reimplemention by using Message::Field::Params
10
11	package Message::Field::Received;
12	use strict;
13	use vars qw(@ISA %REG $VERSION);
14	$VERSION=do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
15	require Message::Util;
16	require Message::Field::Structured;
17	push @ISA, qw(Message::Field::Structured);
18
19	require Message::Field::Date;
20	use overload '@{}' => sub {shift->_delete_empty->{value}},
21	'""' => sub { $_[0]->stringify };
22
23	*REG = \%Message::Util::REG;
24	## Inherited: comment, quoted_string, domain_literal
25	## WSP, FWS, atext
26	## domain, addr_spec, msg_id
27	## date_time, asctime
28
29	$REG{item_name} = qr/[A-Za-z][0-9A-Za-z-]*[0-9A-Za-z]/;
30	## strictly, item-name = ALPHA *(["-"] (ALPHA / DIGIT))
31	$REG{M_name_val_pair} = qr/($REG{item_name})$REG{FWS}($REG{msg_id}\|$REG{addr_spec}\|$REG{domain}\|$REG{atext})/;
32
33
34	=head1 CONSTRUCTORS
35
36	The following methods construct new objects:
37
38	=over 4
39
40	=cut
41
42	## Initialize of this class -- called by constructors
43	sub _init ($;%) {
44	my $self = shift;
45	my %options = @_;
46	my %DEFAULT = (
47	-_HASH_NAME => 'value',
48	-field_name => 'received',
49	#format ## Inherited
50	-parse_all => 0,
51	-validate => 1,
52	-value_type => {'*default' => [':none:']},
53	);
54	$self->SUPER::_init (%DEFAULT, %options);
55	}
56
57
58	=item $r = Message::Field::Received->new ([%options])
59
60	Constructs a new object. You might pass some options as parameters
61	to the constructor.
62
63	=cut
64
65	sub new ($;%) {
66	my $self = shift->SUPER::new (@_);
67	$self->{date_time} = new Message::Field::Date
68	-field_name => $self->{option}->{field_name},
69	-field_param_name => 'date-time',
70	-format => $self->{option}->{format};
71	$self;
72	}
73
74	=item $r = Message::Field::Received->parse ($field-body, [%options])
75
76	Constructs a new object with given field body. You might pass
77	some options as parameters to the constructor.
78
79	=cut
80
81	sub parse ($$;%) {
82	my $class = shift;
83	my $self = bless {}, $class;
84	my $field_body = shift;
85	$self->_init (@_);
86	$field_body = Message::Util::delete_comment ($field_body);
87	$field_body =~ s{;$REG{FWS}($REG{date_time})$REG{FWS}$}{
88	$self->{date_time} = parse Message::Field::Date $1,
89	-field_name => $self->{option}->{field_name},
90	-field_param_name => 'date-time',
91	-format => $self->{option}->{format};
92	'';
93	}ex;
94	unless ($self->{date_time}) {
95	if ($field_body =~ /($REG{asctime})/) { ## old USENET format
96	$self->{date_time} = parse Message::Field::Date $1,
97	-field_name => $self->{option}->{field_name},
98	-field_param_name => 'date-time',
99	-format => $self->{option}->{format};
100	return $self;
101	} else { ## broken!
102	$field_body =~ s/;[^;]+$//;
103	$self->{date_time} = new Message::Field::Date
104	-time_is_unknown => 1,
105	-field_name => $self->{option}->{field_name},
106	-field_param_name => 'date-time',
107	-format => $self->{option}->{format};
108	}
109	}
110	$field_body =~ s{$REG{M_name_val_pair}$REG{FWS}}{
111	my ($name, $value) = (lc $1, $2);
112	$name =~ tr/-/_/;
113	push @{$self->{value}}, [$name => $value];
114	''
115	}goex;
116	$self;
117	}
118
119	=back
120
121	=head1 METHODS
122
123	=over 4
124
125	=head2 $self->items ()
126
127	Return item list hash that contains of C<name-val-list>
128	array references.
129
130	=cut
131
132	sub items ($) {@{shift->{value}}}
133
134	sub item_name ($$) {
135	my $self = shift;
136	my $i = shift;
137	$self->{value}->[$i]->[0];
138	}
139
140	sub item_value ($$) {
141	my $self = shift;
142	my $i = shift;
143	$self->{value}->[$i]->[1];
144	}
145
146	sub item ($$) {
147	my $self = shift;
148	my $name = lc shift;
149	my @ret;
150	for my $item (@{$self->{value}}) {
151	if ($item->[0] eq $name) {
152	unless (wantarray) {
153	return $item->[1];
154	} else {
155	push @ret, $item->[1];
156	}
157	}
158	}
159	@ret;
160	}
161
162	sub date_time ($) {
163	my $self = shift;
164	$self->{date_time};
165	}
166
167	## add: Inherited
168	## replace: Inherited
169
170	sub _add_hash_check ($$$\%) {
171	my $self = shift;
172	my ($name => $value, $option) = @_;
173	if ($$option{validate} && $name !~ /^$REG{item_name}$/) {
174	if ($$option{dont_croak}) {
175	return (0);
176	} else {
177	Carp::croak qq{add/replace: $name: Invalid item-name};
178	}
179	}
180	$value = $self->_item_value ($name => $value) if $$option{parse};
181	(1, $name => [$name => $value]);
182	}
183	*_replace_hash_check = \&_add_hash_check;
184
185	sub _replace_cleaning ($) {
186	$_[0]->_delete_empty;
187	}
188
189	=item $count = $r->count ([%options])
190
191	Returns the number of C<item-val-pair>s.
192
193	Available Options:
194
195	=over 2
196
197	=item -name => "C<item-name>"
198
199	Counts only C<item-val-oair>s whose name is same as given.
200
201	=back
202
203	=cut
204
205	*_count_cleaning = \&_replace_cleaning;
206	sub _count_by_name ($$\%) {
207	my $self = shift;
208	my ($array, $option) = @_;
209	my $name = lc ($$option{-name});
210	my @a = grep {$_->[0] eq $name} @{$self->{$array}};
211	$#a + 1;
212	}
213
214	sub delete ($@) {
215	my $self = shift;
216	my %delete;
217	for (@_) {$delete{lc $_} = 1}
218	$self->{value} = [grep {!$delete{$_->[0]}} @{$self->{value}}];
219	}
220
221	sub _delete_empty ($) {
222	my $self = shift;
223	$self->{value} = [grep {ref $_ && length $_->[0]} @{$self->{value}}];
224	$self;
225	}
226
227
228	sub stringify ($;%) {
229	my $self = shift;
230	my %option = @_;
231	my @return;
232	$self->_delete_empty;
233	for my $item (@{$self->{value}}) {
234	push @return, $item->[0], $item->[1] if $item->[0] =~ /^$REG{item_name}$/;
235	}
236	join (' ', @return).'; '.$self->{date_time}->as_rfc2822_time;
237	}
238	*as_string = \&stringify;
239
240	=item $option-value = $r->option ($option-name)
241
242	Gets option value.
243
244	=item $r->option ($option-name, $option-value, ...)
245
246	Set option value(s). You can pass multiple option name-value pair
247	as parameter when setting.
248
249	=cut
250
251	## Inherited
252
253	## TODO: $r->value_type
254
255	=item $clone = $r->clone ()
256
257	Returns a copy of the object.
258
259	=cut
260
261	## Inherited
262
263	=head1 LICENSE
264
265	Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
266
267	This program is free software; you can redistribute it and/or modify
268	it under the terms of the GNU General Public License as published by
269	the Free Software Foundation; either version 2 of the License, or
270	(at your option) any later version.
271
272	This program is distributed in the hope that it will be useful,
273	but WITHOUT ANY WARRANTY; without even the implied warranty of
274	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
275	GNU General Public License for more details.
276
277	You should have received a copy of the GNU General Public License
278	along with this program; see the file COPYING. If not, write to
279	the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
280	Boston, MA 02111-1307, USA.
281
282	=head1 CHANGE
283
284	See F<ChangeLog>.
285	$Date: 2002/05/04 06:03:58 $
286
287	=cut
288
289	1;