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	wakaba	1.1
2			=head1 NAME
3
4	wakaba	1.3	Message::Field::Received --- Perl module for C<Received:>
5			Internet message header field body
6	wakaba	1.1
7	wakaba	1.3	=cut
8	wakaba	1.1
9	wakaba	1.3	## TODO: reimplemention by using Message::Field::Params
10	wakaba	1.1
11			package Message::Field::Received;
12			use strict;
13	wakaba	1.3	use vars qw(@ISA %REG $VERSION);
14	wakaba	1.4	$VERSION=do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
15	wakaba	1.3	require Message::Util;
16			require Message::Field::Structured;
17			push @ISA, qw(Message::Field::Structured);
18	wakaba	1.1
19	wakaba	1.3	require Message::Field::Date;
20	wakaba	1.4	use overload '@{}' => sub {shift->_delete_empty->{value}},
21	wakaba	1.3	'""' => 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	wakaba	1.1
36	wakaba	1.3	The following methods construct new objects:
37	wakaba	1.1
38	wakaba	1.3	=over 4
39	wakaba	1.1
40	wakaba	1.3	=cut
41
42			## Initialize of this class -- called by constructors
43			sub _init ($;%) {
44			my $self = shift;
45			my %options = @_;
46			my %DEFAULT = (
47	wakaba	1.4	-_HASH_NAME => 'value',
48	wakaba	1.3	-field_name => 'received',
49			#format ## Inherited
50			-parse_all => 0,
51	wakaba	1.4	-validate => 1,
52	wakaba	1.3	-value_type => {'*default' => [':none:']},
53			);
54			$self->SUPER::_init (%DEFAULT, %options);
55			}
56	wakaba	1.1
57	wakaba	1.3
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	wakaba	1.1
63			=cut
64
65			sub new ($;%) {
66	wakaba	1.3	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	wakaba	1.1	$self;
72			}
73
74	wakaba	1.3	=item $r = Message::Field::Received->parse ($field-body, [%options])
75	wakaba	1.1
76	wakaba	1.3	Constructs a new object with given field body. You might pass
77			some options as parameters to the constructor.
78	wakaba	1.1
79			=cut
80
81			sub parse ($$;%) {
82	wakaba	1.3	my $class = shift;
83			my $self = bless {}, $class;
84	wakaba	1.1	my $field_body = shift;
85	wakaba	1.3	$self->_init (@_);
86			$field_body = Message::Util::delete_comment ($field_body);
87	wakaba	1.1	$field_body =~ s{;$REG{FWS}($REG{date_time})$REG{FWS}$}{
88	wakaba	1.3	$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	wakaba	1.1	'';
93			}ex;
94			unless ($self->{date_time}) {
95			if ($field_body =~ /($REG{asctime})/) { ## old USENET format
96	wakaba	1.3	$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	wakaba	1.1	return $self;
101			} else { ## broken!
102			$field_body =~ s/;[^;]+$//;
103	wakaba	1.3	$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	wakaba	1.1	}
109			}
110			$field_body =~ s{$REG{M_name_val_pair}$REG{FWS}}{
111			my ($name, $value) = (lc $1, $2);
112			$name =~ tr/-/_/;
113	wakaba	1.4	push @{$self->{value}}, [$name => $value];
114	wakaba	1.1	''
115			}goex;
116			$self;
117			}
118
119	wakaba	1.3	=back
120
121			=head1 METHODS
122
123			=over 4
124
125	wakaba	1.1	=head2 $self->items ()
126
127			Return item list hash that contains of C<name-val-list>
128			array references.
129
130			=cut
131
132	wakaba	1.4	sub items ($) {@{shift->{value}}}
133	wakaba	1.1
134			sub item_name ($$) {
135			my $self = shift;
136			my $i = shift;
137	wakaba	1.4	$self->{value}->[$i]->[0];
138	wakaba	1.1	}
139
140			sub item_value ($$) {
141			my $self = shift;
142			my $i = shift;
143	wakaba	1.4	$self->{value}->[$i]->[1];
144	wakaba	1.1	}
145
146			sub item ($$) {
147			my $self = shift;
148			my $name = lc shift;
149			my @ret;
150	wakaba	1.4	for my $item (@{$self->{value}}) {
151	wakaba	1.1	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	wakaba	1.4	## add: Inherited
168			## replace: Inherited
169	wakaba	1.1
170	wakaba	1.4	sub _add_hash_check ($$$\%) {
171	wakaba	1.1	my $self = shift;
172	wakaba	1.4	my ($name => $value, $option) = @_;
173			if ($$option{validate} && $name !~ /^$REG{item_name}$/) {
174			if ($$option{dont_croak}) {
175			return (0);
176	wakaba	1.3	} else {
177	wakaba	1.4	Carp::croak qq{add/replace: $name: Invalid item-name};
178	wakaba	1.3	}
179			}
180	wakaba	1.4	$value = $self->_item_value ($name => $value) if $$option{parse};
181			(1, $name => [$name => $value]);
182	wakaba	1.1	}
183	wakaba	1.4	*_replace_hash_check = \&_add_hash_check;
184	wakaba	1.1
185	wakaba	1.4	sub _replace_cleaning ($) {
186			$_[0]->_delete_empty;
187	wakaba	1.1	}
188
189	wakaba	1.4	=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	wakaba	1.1
199	wakaba	1.4	Counts only C<item-val-oair>s whose name is same as given.
200	wakaba	1.1
201	wakaba	1.4	=back
202	wakaba	1.1
203			=cut
204
205	wakaba	1.4	*_count_cleaning = \&_replace_cleaning;
206			sub _count_by_name ($$\%) {
207	wakaba	1.1	my $self = shift;
208	wakaba	1.4	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	wakaba	1.1	}
220
221	wakaba	1.3	sub _delete_empty ($) {
222	wakaba	1.1	my $self = shift;
223	wakaba	1.4	$self->{value} = [grep {ref $_ && length $_->[0]} @{$self->{value}}];
224	wakaba	1.1	$self;
225			}
226
227
228			sub stringify ($;%) {
229			my $self = shift;
230			my %option = @_;
231			my @return;
232	wakaba	1.3	$self->_delete_empty;
233	wakaba	1.4	for my $item (@{$self->{value}}) {
234	wakaba	1.1	push @return, $item->[0], $item->[1] if $item->[0] =~ /^$REG{item_name}$/;
235			}
236			join (' ', @return).'; '.$self->{date_time}->as_rfc2822_time;
237			}
238	wakaba	1.3	*as_string = \&stringify;
239
240			=item $option-value = $r->option ($option-name)
241
242			Gets option value.
243	wakaba	1.1
244	wakaba	1.3	=item $r->option ($option-name, $option-value, ...)
245	wakaba	1.2
246	wakaba	1.3	Set option value(s). You can pass multiple option name-value pair
247			as parameter when setting.
248	wakaba	1.2
249			=cut
250
251	wakaba	1.3	## Inherited
252
253			## TODO: $r->value_type
254	wakaba	1.1
255	wakaba	1.3	=item $clone = $r->clone ()
256	wakaba	1.1
257	wakaba	1.3	Returns a copy of the object.
258	wakaba	1.1
259			=cut
260
261	wakaba	1.4	## Inherited
262	wakaba	1.1
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	wakaba	1.4	$Date: 2002/05/04 06:03:58 $
286	wakaba	1.1
287			=cut
288
289			1;