Message/Field/Received.pm


=head1 NAME

Message::Field::Received Perl module

=head1 DESCRIPTION

Perl module for RFC 821/822/2821/2822 Received C<field>.

=cut

package Message::Field::Received;
require 5.6.0;
use strict;
use re 'eval';
use vars qw(%OPTION %REG $VERSION);
$VERSION = '1.00';

use Message::Field::Date;
use overload '@{}' => sub {shift->_delete_empty_item->{item}},
             '""' => sub {shift->stringify};

$REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]+|(??{$REG{comment}}))*\x29/;
$REG{quoted_string} = qr/\x22(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*\x22/;
$REG{domain_literal} = qr/\x5B(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x5A\x5E-\xFF])*\x5D/;

$REG{WSP} = qr/[\x20\x09]+/;
$REG{FWS} = qr/[\x20\x09]*/;
$REG{atext} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
$REG{dot_atom} = qr/$REG{atext}(?:$REG{FWS}\x2E$REG{FWS}$REG{atext})*/;
$REG{dot_word} = qr/(?:$REG{atext}|$REG{quoted_string})(?:$REG{FWS}\x2E$REG{FWS}(?:$REG{atext}|$REG{quoted_string}))*/;
$REG{domain} = qr/(?:$REG{dot_atom}|$REG{domain_literal})/;
$REG{addr_spec} = qr/$REG{dot_word}$REG{FWS}\x40$REG{FWS}$REG{domain}/;
$REG{msg_id} = qr/<$REG{FWS}$REG{addr_spec}$REG{FWS}>/;
$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})/;
$REG{date_time} = qr/(?:[A-Za-z]+$REG{FWS},$REG{FWS})?[0-9]+$REG{WSP}*[A-Za-z]+$REG{WSP}*[0-9]+$REG{WSP}+[0-9]+$REG{FWS}:$REG{WSP}*[0-9]+(?:$REG{FWS}:$REG{WSP}*[0-9]+)?$REG{FWS}(?:[A-Za-z]+|[+-]$REG{WSP}*[0-9]+)/;
$REG{asctime} = qr/[A-Za-z]+$REG{WSP}*[A-Za-z]+$REG{WSP}*[0-9]+$REG{WSP}+[0-9]+$REG{FWS}:$REG{WSP}*[0-9]+$REG{FWS}:$REG{WSP}*[0-9]+$REG{WSP}+[0-9]+/;

%OPTION = (
);

=head2 Message::Field::Received->new ()

Return empty received object.

=cut

sub new ($;%) {
  my $self = bless {}, shift;
  my %option = @_;
  for (%OPTION) {$option{$_} ||= $OPTION{$_}}
  $self->{option} = \%option;
  $self->{date_time} = new Message::Field::Date;
  $self;
}

=head2 Message::Field::Received->parse ($unfolded_field_body)

Parse Received: C<field-body>.

=cut

sub parse ($$;%) {
  my $self = bless {}, shift;
  my $field_body = shift;
  my %option = @_;
  for (%OPTION) {$option{$_} ||= $OPTION{$_}}
  $self->{option} = \%option;
  $field_body = $self->delete_comment ($field_body);
  $field_body =~ s{;$REG{FWS}($REG{date_time})$REG{FWS}$}{
    $self->{date_time} = Message::Field::Date->parse ($1);
    '';
  }ex;
  unless ($self->{date_time}) {
    if ($field_body =~ /($REG{asctime})/) {     ## old USENET format
      $self->{date_time} = Message::Field::Date->parse ($1);
      return $self;
    } else {    ## broken!
      $field_body =~ s/;[^;]+$//;
      $self->{date_time} = new Message::Field::Date (unknown => 1);
    }
  }
  $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;
}

=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 ($name, $value) = @_;
  push @{$self->{item}}, [$name, $value];
  $self;
}

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

=head2 $self->delete ($item_name, [$index])

Deletes C<name-val-pair> named as $item_name.
If $index is specified, only $index'th C<name-val-pair> is deleted.
If not, ($index == 0), all C<name-val-pair>s that have the C<item-name>
$item_name are deleted.

=cut

sub delete ($$;$) {
  my $self = shift;
  my ($name, $index) = (lc shift, shift);
  my $i = 0;
  for my $item (@{$self->{item}}) {
    if ($item->[0] eq $name) {
      $i++;
      if ($index == 0 || $i == $index) {
        undef $item;
        return $self if $i == $index;
      }
    }
  }
  $self;
}

=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_item ();
    return $#{$self->{item}}+1;
  }
  my $count = 0;
  for my $item (@{$self->{item}}) {
    if ($item->[0] eq $name) {
      $count++;
    }
  }
  $count;
}

sub _delete_empty_item ($) {
  my $self = shift;
  my @ret;
  for my $item (@{$self->{item}}) {
    push @ret, $item if $item->[0];
  }
  $self->{item} = \@ret;
  $self;
}


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

sub as_string ($;%) {shift->stringify (@_)}
=head2 $self->option ($option_name, [$option_value])

Set/gets new value of the option.

=cut

sub option ($$;$) {
  my $self = shift;
  my ($name, $value) = @_;
  if (defined $value) {
    $self->{option}->{$name} = $value;
  }
  $self->{option}->{$name};
}

=head2 $self->delete_comment ($field_body)

Remove all C<comment> in given strictured C<field-body>.
This method is intended for internal use.

=cut

sub delete_comment ($$) {
  my $self = shift;
  my $body = shift;
  $body =~ s{($REG{quoted_string}|$REG{domain_literal})|$REG{comment}}{
    my $o = $1;  $o? $o : ' ';
  }gex;
  $body;
}

=head1 EXAMPLE

  ## Compose field-body for To: field.
  
  use Message::Field::Address;
  my $addr = new Message::Field::Address;
  $addr->add ('foo@example.org', name => 'Mr. foo bar');
  $addr->add ('webmaster@example.org', group => 'administrators');
  $addr->add ('postmaster@example.org', group => 'administrators');
  
  my $field_body = $addr->stringify ();


  ## Output parsed address-list tree.
  
  use Message::Field::Address;
  my $addr = Message::Field::Address->parse ($field_body);
  
  for my $i (@$addr) {
    if ($i->{type} eq 'group') {
      print "\x40 $i->{display_name}: \n";
      for my $j (@{$i->{address}}) {
        print "\t- $j->{display_name} <$j->{route}$j->{addr_spec}>\n";
      }
    } else {
      print "- $i->{display_name} <$i->{route}$i->{addr_spec}>\n";
    }
  }

=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/20 09:56:26 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Field::Received Perl module
5
6			=head1 DESCRIPTION
7
8			Perl module for RFC 821/822/2821/2822 Received C<field>.
9
10			=cut
11
12			package Message::Field::Received;
13			require 5.6.0;
14			use strict;
15			use re 'eval';
16			use vars qw(%OPTION %REG $VERSION);
17			$VERSION = '1.00';
18
19			use Message::Field::Date;
20			use overload '@{}' => sub {shift->_delete_empty_item->{item}},
21			'""' => sub {shift->stringify};
22
23			$REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]+\|(??{$REG{comment}}))*\x29/;
24			$REG{quoted_string} = qr/\x22(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*\x22/;
25			$REG{domain_literal} = qr/\x5B(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x5A\x5E-\xFF])*\x5D/;
26
27			$REG{WSP} = qr/[\x20\x09]+/;
28			$REG{FWS} = qr/[\x20\x09]*/;
29			$REG{atext} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
30			$REG{dot_atom} = qr/$REG{atext}(?:$REG{FWS}\x2E$REG{FWS}$REG{atext})*/;
31			$REG{dot_word} = qr/(?:$REG{atext}\|$REG{quoted_string})(?:$REG{FWS}\x2E$REG{FWS}(?:$REG{atext}\|$REG{quoted_string}))*/;
32			$REG{domain} = qr/(?:$REG{dot_atom}\|$REG{domain_literal})/;
33			$REG{addr_spec} = qr/$REG{dot_word}$REG{FWS}\x40$REG{FWS}$REG{domain}/;
34			$REG{msg_id} = qr/<$REG{FWS}$REG{addr_spec}$REG{FWS}>/;
35			$REG{item_name} = qr/[A-Za-z][0-9A-Za-z-]*[0-9A-Za-z]/;
36			## strictly, item-name = ALPHA *(["-"] (ALPHA / DIGIT))
37			$REG{M_name_val_pair} = qr/($REG{item_name})$REG{FWS}($REG{msg_id}\|$REG{addr_spec}\|$REG{domain}\|$REG{atext})/;
38			$REG{date_time} = qr/(?:[A-Za-z]+$REG{FWS},$REG{FWS})?[0-9]+$REG{WSP}[A-Za-z]+$REG{WSP}[0-9]+$REG{WSP}+[0-9]+$REG{FWS}:$REG{WSP}[0-9]+(?:$REG{FWS}:$REG{WSP}[0-9]+)?$REG{FWS}(?:[A-Za-z]+\|[+-]$REG{WSP}*[0-9]+)/;
39			$REG{asctime} = qr/[A-Za-z]+$REG{WSP}[A-Za-z]+$REG{WSP}[0-9]+$REG{WSP}+[0-9]+$REG{FWS}:$REG{WSP}[0-9]+$REG{FWS}:$REG{WSP}[0-9]+$REG{WSP}+[0-9]+/;
40
41			%OPTION = (
42			);
43
44			=head2 Message::Field::Received->new ()
45
46			Return empty received object.
47
48			=cut
49
50			sub new ($;%) {
51			my $self = bless {}, shift;
52			my %option = @_;
53			for (%OPTION) {$option{$_} \|\|= $OPTION{$_}}
54			$self->{option} = \%option;
55			$self->{date_time} = new Message::Field::Date;
56			$self;
57			}
58
59			=head2 Message::Field::Received->parse ($unfolded_field_body)
60
61			Parse Received: C<field-body>.
62
63			=cut
64
65			sub parse ($$;%) {
66			my $self = bless {}, shift;
67			my $field_body = shift;
68			my %option = @_;
69			for (%OPTION) {$option{$_} \|\|= $OPTION{$_}}
70			$self->{option} = \%option;
71			$field_body = $self->delete_comment ($field_body);
72			$field_body =~ s{;$REG{FWS}($REG{date_time})$REG{FWS}$}{
73			$self->{date_time} = Message::Field::Date->parse ($1);
74			'';
75			}ex;
76			unless ($self->{date_time}) {
77			if ($field_body =~ /($REG{asctime})/) { ## old USENET format
78			$self->{date_time} = Message::Field::Date->parse ($1);
79			return $self;
80			} else { ## broken!
81			$field_body =~ s/;[^;]+$//;
82			$self->{date_time} = new Message::Field::Date (unknown => 1);
83			}
84			}
85			$field_body =~ s{$REG{M_name_val_pair}$REG{FWS}}{
86			my ($name, $value) = (lc $1, $2);
87			$name =~ tr/-/_/;
88			push @{$self->{item}}, [$name => $value];
89			''
90			}goex;
91			$self;
92			}
93
94			=head2 $self->items ()
95
96			Return item list hash that contains of C<name-val-list>
97			array references.
98
99			=cut
100
101			sub items ($) {@{shift->{item}}}
102
103			sub item_name ($$) {
104			my $self = shift;
105			my $i = shift;
106			$self->{item}->[$i]->[0];
107			}
108
109			sub item_value ($$) {
110			my $self = shift;
111			my $i = shift;
112			$self->{item}->[$i]->[1];
113			}
114
115			sub item ($$) {
116			my $self = shift;
117			my $name = lc shift;
118			my @ret;
119			for my $item (@{$self->{item}}) {
120			if ($item->[0] eq $name) {
121			unless (wantarray) {
122			return $item->[1];
123			} else {
124			push @ret, $item->[1];
125			}
126			}
127			}
128			@ret;
129			}
130
131			sub date_time ($) {
132			my $self = shift;
133			$self->{date_time};
134			}
135
136			=head2 $self->add ($item_name, $item_value)
137
138			Add an C<nama-val-pair>.
139
140			Note that this method (and other methods) does not check
141			C<item-val-pair> is valid as RFC (2)82[12] definition or not.
142			(But only C<item-name> is changed when C<stringify>.)
143
144			=cut
145
146			sub add ($$$) {
147			my $self = shift;
148			my ($name, $value) = @_;
149			push @{$self->{item}}, [$name, $value];
150			$self;
151			}
152
153			sub replace ($$$) {
154			my $self = shift;
155			my ($name => $value) = (lc shift => shift);
156			for my $item (@{$self->{item}}) {
157			if ($item->[0] eq $name) {
158			$item->[1] = $value;
159			return $self;
160			}
161			}
162			push @{$self->{item}}, [$name => $value];
163			$self;
164			}
165
166			=head2 $self->delete ($item_name, [$index])
167
168			Deletes C<name-val-pair> named as $item_name.
169			If $index is specified, only $index'th C<name-val-pair> is deleted.
170			If not, ($index == 0), all C<name-val-pair>s that have the C<item-name>
171			$item_name are deleted.
172
173			=cut
174
175			sub delete ($$;$) {
176			my $self = shift;
177			my ($name, $index) = (lc shift, shift);
178			my $i = 0;
179			for my $item (@{$self->{item}}) {
180			if ($item->[0] eq $name) {
181			$i++;
182			if ($index == 0 \|\| $i == $index) {
183			undef $item;
184			return $self if $i == $index;
185			}
186			}
187			}
188			$self;
189			}
190
191			=head2 $self->count ([$item_name])
192
193			Returns the number of times the given C<item-name>'ed
194			C<name-val-pair> appears.
195			If no $item_name is given, returns the number
196			of fields. (Same as $#$self+1)
197
198			=cut
199
200			sub count ($;$) {
201			my $self = shift;
202			my ($name) = (lc shift);
203			unless ($name) {
204			$self->_delete_empty_item ();
205			return $#{$self->{item}}+1;
206			}
207			my $count = 0;
208			for my $item (@{$self->{item}}) {
209			if ($item->[0] eq $name) {
210			$count++;
211			}
212			}
213			$count;
214			}
215
216			sub _delete_empty_item ($) {
217			my $self = shift;
218			my @ret;
219			for my $item (@{$self->{item}}) {
220			push @ret, $item if $item->[0];
221			}
222			$self->{item} = \@ret;
223			$self;
224			}
225
226
227
228			sub stringify ($;%) {
229			my $self = shift;
230			my %option = @_;
231			my @return;
232			$self->_delete_empty_item;
233			for my $item (@{$self->{item}}) {
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
239			sub as_string ($;%) {shift->stringify (@_)}
240	wakaba	1.2	=head2 $self->option ($option_name, [$option_value])
241
242			Set/gets new value of the option.
243
244			=cut
245
246			sub option ($$;$) {
247			my $self = shift;
248			my ($name, $value) = @_;
249			if (defined $value) {
250			$self->{option}->{$name} = $value;
251			}
252			$self->{option}->{$name};
253			}
254	wakaba	1.1
255			=head2 $self->delete_comment ($field_body)
256
257			Remove all C<comment> in given strictured C<field-body>.
258			This method is intended for internal use.
259
260			=cut
261
262			sub delete_comment ($$) {
263			my $self = shift;
264			my $body = shift;
265			$body =~ s{($REG{quoted_string}\|$REG{domain_literal})\|$REG{comment}}{
266			my $o = $1; $o? $o : ' ';
267			}gex;
268			$body;
269			}
270
271			=head1 EXAMPLE
272
273			## Compose field-body for To: field.
274
275			use Message::Field::Address;
276			my $addr = new Message::Field::Address;
277			$addr->add ('foo@example.org', name => 'Mr. foo bar');
278			$addr->add ('webmaster@example.org', group => 'administrators');
279			$addr->add ('postmaster@example.org', group => 'administrators');
280
281			my $field_body = $addr->stringify ();
282
283
284			## Output parsed address-list tree.
285
286			use Message::Field::Address;
287			my $addr = Message::Field::Address->parse ($field_body);
288
289			for my $i (@$addr) {
290			if ($i->{type} eq 'group') {
291			print "\x40 $i->{display_name}: \n";
292			for my $j (@{$i->{address}}) {
293			print "\t- $j->{display_name} <$j->{route}$j->{addr_spec}>\n";
294			}
295			} else {
296			print "- $i->{display_name} <$i->{route}$i->{addr_spec}>\n";
297			}
298			}
299
300			=head1 LICENSE
301
302			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
303
304			This program is free software; you can redistribute it and/or modify
305			it under the terms of the GNU General Public License as published by
306			the Free Software Foundation; either version 2 of the License, or
307			(at your option) any later version.
308
309			This program is distributed in the hope that it will be useful,
310			but WITHOUT ANY WARRANTY; without even the implied warranty of
311			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
312			GNU General Public License for more details.
313
314			You should have received a copy of the GNU General Public License
315			along with this program; see the file COPYING. If not, write to
316			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
317			Boston, MA 02111-1307, USA.
318
319			=head1 CHANGE
320
321			See F<ChangeLog>.
322	wakaba	1.2	$Date: 2002/03/20 09:56:26 $
323	wakaba	1.1
324			=cut
325
326			1;