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.7 $=~/\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_item->{item}},
             '""' => 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 = (
    -field_name => 'received',
    #format     ## Inherited
    -parse_all  => 0,
    -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->{item}}, [$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->{item}}}

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

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

sub item ($$) {
  my $self = shift;
  my $name = lc shift;
  my @ret;
  for my $item (@{$self->{item}}) {
    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};
}

=head2 $self->add ($item_name, $item_value)

Add an C<nama-val-pair>.

Note that this method (and other methods) does not check
C<item-val-pair> is valid as RFC (2)82[12] definition or not.
(But only C<item-name> is changed when C<stringify>.)

=cut

sub add ($%) {
  my $self = shift;
  my %gp = @_; my %option = %{$self->{option}};
  for (grep {/^-/} keys %gp) {$option{substr ($_, 1)} = $gp{$_}}
  $option{parse} = 1 if defined wantarray;
  my $p;
  for (grep {/^[^-]/} keys %gp) {
    my ($name => $value) = (lc $_ => $gp{$_});
    $value = $self->_item_value ($name => $value) if $option{parse};
    if ($option{prepend}) {
      unshift @{$self->{item}}, [$name => $value];
    } else {
      push @{$self->{item}}, [$name => $value];
    }
  }
  $p;
}

sub replace ($%) {
  my $self = shift;
  my %gp = @_; my %option = %{$self->{option}};
  for (grep {/^-/} keys %gp) {$option{substr ($_, 1)} = $gp{$_}}
  $option{parse} = 1 if defined wantarray;
  my $p;
  for (grep {/^[^-]/} keys %gp) {
    my ($name => $value) = (lc $_ => $gp{$_});
    my $f = 0;
    for my $item (@{$self->{item}}) {
      if ($item->[0] eq $name) {$item = [$name => $value]; $f = 1}
    }
    push @{$self->{item}}, [$name => $value] unless $f == 1;
  }
  $p;
}

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

=head2 $self->count ([$item_name])

Returns the number of times the given C<item-name>'ed 
C<name-val-pair> appears.
If no $item_name is given, returns the number
of fields.  (Same as $#$self+1)

=cut

sub count ($;$) {
  my $self = shift;
  my ($name) = (lc shift);
  unless ($name) {
    $self->_delete_empty;
    return $#{$self->{item}}+1;
  }
  my @c = grep {$_->[0] eq $name} @{$self->{item}};
  scalar @c;
}

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


sub stringify ($;%) {
  my $self = shift;
  my %option = @_;
  my @return;
  $self->_delete_empty;
  for my $item (@{$self->{item}}) {
    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

sub clone ($) {
  my $self = shift;
  $self->_delete_empty;
  my $clone = $self->SUPER::clone;
  $clone->{item} = Message::Util::make_clone ($self->{item});
  $clone->{value_type} = Message::Util::make_clone ($self->{value_type});
  $clone;
}


=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/03/31 13:11:55 $

=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			$VERSION=do{my @r=(q$Revision: 1.7 $=~/\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	wakaba	1.1
19	wakaba	1.3	require Message::Field::Date;
20	wakaba	1.1	use overload '@{}' => sub {shift->_delete_empty_item->{item}},
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			-field_name => 'received',
48			#format ## Inherited
49			-parse_all => 0,
50			-value_type => {'*default' => [':none:']},
51			);
52			$self->SUPER::_init (%DEFAULT, %options);
53			}
54	wakaba	1.1
55	wakaba	1.3
56			=item $r = Message::Field::Received->new ([%options])
57
58			Constructs a new object. You might pass some options as parameters
59			to the constructor.
60	wakaba	1.1
61			=cut
62
63			sub new ($;%) {
64	wakaba	1.3	my $self = shift->SUPER::new (@_);
65			$self->{date_time} = new Message::Field::Date
66			-field_name => $self->{option}->{field_name},
67			-field_param_name => 'date-time',
68			-format => $self->{option}->{format};
69	wakaba	1.1	$self;
70			}
71
72	wakaba	1.3	=item $r = Message::Field::Received->parse ($field-body, [%options])
73	wakaba	1.1
74	wakaba	1.3	Constructs a new object with given field body. You might pass
75			some options as parameters to the constructor.
76	wakaba	1.1
77			=cut
78
79			sub parse ($$;%) {
80	wakaba	1.3	my $class = shift;
81			my $self = bless {}, $class;
82	wakaba	1.1	my $field_body = shift;
83	wakaba	1.3	$self->_init (@_);
84			$field_body = Message::Util::delete_comment ($field_body);
85	wakaba	1.1	$field_body =~ s{;$REG{FWS}($REG{date_time})$REG{FWS}$}{
86	wakaba	1.3	$self->{date_time} = parse Message::Field::Date $1,
87			-field_name => $self->{option}->{field_name},
88			-field_param_name => 'date-time',
89			-format => $self->{option}->{format};
90	wakaba	1.1	'';
91			}ex;
92			unless ($self->{date_time}) {
93			if ($field_body =~ /($REG{asctime})/) { ## old USENET format
94	wakaba	1.3	$self->{date_time} = parse Message::Field::Date $1,
95			-field_name => $self->{option}->{field_name},
96			-field_param_name => 'date-time',
97			-format => $self->{option}->{format};
98	wakaba	1.1	return $self;
99			} else { ## broken!
100			$field_body =~ s/;[^;]+$//;
101	wakaba	1.3	$self->{date_time} = new Message::Field::Date
102			-time_is_unknown => 1,
103			-field_name => $self->{option}->{field_name},
104			-field_param_name => 'date-time',
105			-format => $self->{option}->{format};
106	wakaba	1.1	}
107			}
108			$field_body =~ s{$REG{M_name_val_pair}$REG{FWS}}{
109			my ($name, $value) = (lc $1, $2);
110			$name =~ tr/-/_/;
111			push @{$self->{item}}, [$name => $value];
112			''
113			}goex;
114			$self;
115			}
116
117	wakaba	1.3	=back
118
119			=head1 METHODS
120
121			=over 4
122
123	wakaba	1.1	=head2 $self->items ()
124
125			Return item list hash that contains of C<name-val-list>
126			array references.
127
128			=cut
129
130			sub items ($) {@{shift->{item}}}
131
132			sub item_name ($$) {
133			my $self = shift;
134			my $i = shift;
135			$self->{item}->[$i]->[0];
136			}
137
138			sub item_value ($$) {
139			my $self = shift;
140			my $i = shift;
141			$self->{item}->[$i]->[1];
142			}
143
144			sub item ($$) {
145			my $self = shift;
146			my $name = lc shift;
147			my @ret;
148			for my $item (@{$self->{item}}) {
149			if ($item->[0] eq $name) {
150			unless (wantarray) {
151			return $item->[1];
152			} else {
153			push @ret, $item->[1];
154			}
155			}
156			}
157			@ret;
158			}
159
160			sub date_time ($) {
161			my $self = shift;
162			$self->{date_time};
163			}
164
165			=head2 $self->add ($item_name, $item_value)
166
167			Add an C<nama-val-pair>.
168
169			Note that this method (and other methods) does not check
170			C<item-val-pair> is valid as RFC (2)82[12] definition or not.
171			(But only C<item-name> is changed when C<stringify>.)
172
173			=cut
174
175	wakaba	1.3	sub add ($%) {
176	wakaba	1.1	my $self = shift;
177	wakaba	1.3	my %gp = @_; my %option = %{$self->{option}};
178			for (grep {/^-/} keys %gp) {$option{substr ($_, 1)} = $gp{$_}}
179			$option{parse} = 1 if defined wantarray;
180			my $p;
181			for (grep {/^[^-]/} keys %gp) {
182			my ($name => $value) = (lc $_ => $gp{$_});
183			$value = $self->_item_value ($name => $value) if $option{parse};
184			if ($option{prepend}) {
185			unshift @{$self->{item}}, [$name => $value];
186			} else {
187			push @{$self->{item}}, [$name => $value];
188			}
189			}
190			$p;
191	wakaba	1.1	}
192
193	wakaba	1.3	sub replace ($%) {
194	wakaba	1.1	my $self = shift;
195	wakaba	1.3	my %gp = @_; my %option = %{$self->{option}};
196			for (grep {/^-/} keys %gp) {$option{substr ($_, 1)} = $gp{$_}}
197			$option{parse} = 1 if defined wantarray;
198			my $p;
199			for (grep {/^[^-]/} keys %gp) {
200			my ($name => $value) = (lc $_ => $gp{$_});
201			my $f = 0;
202			for my $item (@{$self->{item}}) {
203			if ($item->[0] eq $name) {$item = [$name => $value]; $f = 1}
204	wakaba	1.1	}
205	wakaba	1.3	push @{$self->{item}}, [$name => $value] unless $f == 1;
206	wakaba	1.1	}
207	wakaba	1.3	$p;
208	wakaba	1.1	}
209
210	wakaba	1.3	sub delete ($@) {
211	wakaba	1.1	my $self = shift;
212	wakaba	1.3	my %delete;
213			for (@_) {$delete{lc $_} = 1}
214			$self->{item} = [grep {!$delete{$_->[0]}} @{$self->{item}}];
215	wakaba	1.1	}
216
217			=head2 $self->count ([$item_name])
218
219			Returns the number of times the given C<item-name>'ed
220			C<name-val-pair> appears.
221			If no $item_name is given, returns the number
222			of fields. (Same as $#$self+1)
223
224			=cut
225
226			sub count ($;$) {
227			my $self = shift;
228			my ($name) = (lc shift);
229			unless ($name) {
230	wakaba	1.3	$self->_delete_empty;
231	wakaba	1.1	return $#{$self->{item}}+1;
232			}
233	wakaba	1.3	my @c = grep {$_->[0] eq $name} @{$self->{item}};
234			scalar @c;
235	wakaba	1.1	}
236
237	wakaba	1.3	sub _delete_empty ($) {
238	wakaba	1.1	my $self = shift;
239	wakaba	1.3	$self->{item} = [grep {ref $_ && length $_->[0]} @{$self->{item}}];
240	wakaba	1.1	$self;
241			}
242
243
244			sub stringify ($;%) {
245			my $self = shift;
246			my %option = @_;
247			my @return;
248	wakaba	1.3	$self->_delete_empty;
249	wakaba	1.1	for my $item (@{$self->{item}}) {
250			push @return, $item->[0], $item->[1] if $item->[0] =~ /^$REG{item_name}$/;
251			}
252			join (' ', @return).'; '.$self->{date_time}->as_rfc2822_time;
253			}
254	wakaba	1.3	*as_string = \&stringify;
255
256			=item $option-value = $r->option ($option-name)
257
258			Gets option value.
259	wakaba	1.1
260	wakaba	1.3	=item $r->option ($option-name, $option-value, ...)
261	wakaba	1.2
262	wakaba	1.3	Set option value(s). You can pass multiple option name-value pair
263			as parameter when setting.
264	wakaba	1.2
265			=cut
266
267	wakaba	1.3	## Inherited
268
269			## TODO: $r->value_type
270	wakaba	1.1
271	wakaba	1.3	=item $clone = $r->clone ()
272	wakaba	1.1
273	wakaba	1.3	Returns a copy of the object.
274	wakaba	1.1
275			=cut
276
277	wakaba	1.3	sub clone ($) {
278	wakaba	1.1	my $self = shift;
279	wakaba	1.3	$self->_delete_empty;
280			my $clone = $self->SUPER::clone;
281			$clone->{item} = Message::Util::make_clone ($self->{item});
282			$clone->{value_type} = Message::Util::make_clone ($self->{value_type});
283			$clone;
284			}
285
286	wakaba	1.1
287			=head1 LICENSE
288
289			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
290
291			This program is free software; you can redistribute it and/or modify
292			it under the terms of the GNU General Public License as published by
293			the Free Software Foundation; either version 2 of the License, or
294			(at your option) any later version.
295
296			This program is distributed in the hope that it will be useful,
297			but WITHOUT ANY WARRANTY; without even the implied warranty of
298			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
299			GNU General Public License for more details.
300
301			You should have received a copy of the GNU General Public License
302			along with this program; see the file COPYING. If not, write to
303			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
304			Boston, MA 02111-1307, USA.
305
306			=head1 CHANGE
307
308			See F<ChangeLog>.
309	wakaba	1.3	$Date: 2002/03/31 13:11:55 $
310	wakaba	1.1
311			=cut
312
313			1;