/[suikacvs]/messaging/manakai/lib/Message/Field/Received.pm
Suika

Diff of /messaging/manakai/lib/Message/Field/Received.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by wakaba, Sun Mar 31 13:11:55 2002 UTC revision 1.3 by wakaba, Mon Apr 22 08:28:20 2002 UTC
# Line 1  Line 1 
1    
2  =head1 NAME  =head1 NAME
3    
4  Message::Field::Received Perl module  Message::Field::Received --- Perl module for C<Received:>
5    Internet message header field body
 =head1 DESCRIPTION  
   
 Perl module for RFC 821/822/2821/2822 Received C<field>.  
6    
7  =cut  =cut
8    
9    ## TODO: reimplemention by using Message::Field::Params
10    
11  package Message::Field::Received;  package Message::Field::Received;
 require 5.6.0;  
12  use strict;  use strict;
13  use re 'eval';  use vars qw(@ISA %REG $VERSION);
14  use vars qw(%OPTION %REG $VERSION);  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
15  $VERSION = '1.00';  require Message::Util;
16    require Message::Field::Structured;
17    push @ISA, qw(Message::Field::Structured);
18    
19  use Message::Field::Date;  require Message::Field::Date;
20  use overload '@{}' => sub {shift->_delete_empty_item->{item}},  use overload '@{}' => sub {shift->_delete_empty_item->{item}},
21               '""' => sub {shift->stringify};               '""' => 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  $REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]+|(??{$REG{comment}}))*\x29/;  The following methods construct new objects:
 $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]+/;  
37    
38  %OPTION = (  =over 4
 );  
39    
40  =head2 Message::Field::Received->new ()  =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    
55  Return empty received object.  
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    
61  =cut  =cut
62    
63  sub new ($;%) {  sub new ($;%) {
64    my $self = bless {}, shift;    my $self = shift->SUPER::new (@_);
65    my %option = @_;    $self->{date_time} = new Message::Field::Date
66    for (%OPTION) {$option{$_} ||= $OPTION{$_}}        -field_name => $self->{option}->{field_name},
67    $self->{option} = \%option;        -field_param_name => 'date-time',
68    $self->{date_time} = new Message::Field::Date;        -format => $self->{option}->{format};
69    $self;    $self;
70  }  }
71    
72  =head2 Message::Field::Received->parse ($unfolded_field_body)  =item $r = Message::Field::Received->parse ($field-body, [%options])
73    
74  Parse Received: C<field-body>.  Constructs a new object with given field body.  You might pass
75    some options as parameters to the constructor.
76    
77  =cut  =cut
78    
79  sub parse ($$;%) {  sub parse ($$;%) {
80    my $self = bless {}, shift;    my $class = shift;
81      my $self = bless {}, $class;
82    my $field_body = shift;    my $field_body = shift;
83    my %option = @_;    $self->_init (@_);
84    for (%OPTION) {$option{$_} ||= $OPTION{$_}}    $field_body = Message::Util::delete_comment ($field_body);
   $self->{option} = \%option;  
   $field_body = $self->delete_comment ($field_body);  
85    $field_body =~ s{;$REG{FWS}($REG{date_time})$REG{FWS}$}{    $field_body =~ s{;$REG{FWS}($REG{date_time})$REG{FWS}$}{
86      $self->{date_time} = Message::Field::Date->parse ($1);      $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      '';      '';
91    }ex;    }ex;
92    unless ($self->{date_time}) {    unless ($self->{date_time}) {
93      if ($field_body =~ /($REG{asctime})/) {     ## old USENET format      if ($field_body =~ /($REG{asctime})/) {     ## old USENET format
94        $self->{date_time} = Message::Field::Date->parse ($1);        $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        return $self;        return $self;
99      } else {    ## broken!      } else {    ## broken!
100        $field_body =~ s/;[^;]+$//;        $field_body =~ s/;[^;]+$//;
101        $self->{date_time} = new Message::Field::Date (unknown => 1);        $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      }      }
107    }    }
108    $field_body =~ s{$REG{M_name_val_pair}$REG{FWS}}{    $field_body =~ s{$REG{M_name_val_pair}$REG{FWS}}{
# Line 91  sub parse ($$;%) { Line 114  sub parse ($$;%) {
114    $self;    $self;
115  }  }
116    
117    =back
118    
119    =head1 METHODS
120    
121    =over 4
122    
123  =head2 $self->items ()  =head2 $self->items ()
124    
125  Return item list hash that contains of C<name-val-list>  Return item list hash that contains of C<name-val-list>
# Line 143  C<item-val-pair> is valid as RFC (2)82[1 Line 172  C<item-val-pair> is valid as RFC (2)82[1
172    
173  =cut  =cut
174    
175  sub add ($$$) {  sub add ($%) {
176    my $self = shift;    my $self = shift;
177    my ($name, $value) = @_;    my %gp = @_; my %option = %{$self->{option}};
178    push @{$self->{item}}, [$name, $value];    for (grep {/^-/} keys %gp) {$option{substr ($_, 1)} = $gp{$_}}
179    $self;    $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  }  }
192    
193  sub replace ($$$) {  sub replace ($%) {
194    my $self = shift;    my $self = shift;
195    my ($name => $value) = (lc shift => shift);    my %gp = @_; my %option = %{$self->{option}};
196    for my $item (@{$self->{item}}) {    for (grep {/^-/} keys %gp) {$option{substr ($_, 1)} = $gp{$_}}
197      if ($item->[0] eq $name) {    $option{parse} = 1 if defined wantarray;
198        $item->[1] = $value;    my $p;
199        return $self;    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      }      }
205        push @{$self->{item}}, [$name => $value] unless $f == 1;
206    }    }
207    push @{$self->{item}}, [$name => $value];    $p;
   $self;  
208  }  }
209    
210  =head2 $self->delete ($item_name, [$index])  sub delete ($@) {
   
 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 ($$;$) {  
211    my $self = shift;    my $self = shift;
212    my ($name, $index) = (lc shift, shift);    my %delete;
213    my $i = 0;    for (@_) {$delete{lc $_} = 1}
214    for my $item (@{$self->{item}}) {    $self->{item} = [grep {!$delete{$_->[0]}} @{$self->{item}}];
     if ($item->[0] eq $name) {  
       $i++;  
       if ($index == 0 || $i == $index) {  
         undef $item;  
         return $self if $i == $index;  
       }  
     }  
   }  
   $self;  
215  }  }
216    
217  =head2 $self->count ([$item_name])  =head2 $self->count ([$item_name])
# Line 201  sub count ($;$) { Line 227  sub count ($;$) {
227    my $self = shift;    my $self = shift;
228    my ($name) = (lc shift);    my ($name) = (lc shift);
229    unless ($name) {    unless ($name) {
230      $self->_delete_empty_item ();      $self->_delete_empty;
231      return $#{$self->{item}}+1;      return $#{$self->{item}}+1;
232    }    }
233    my $count = 0;    my @c = grep {$_->[0] eq $name} @{$self->{item}};
234    for my $item (@{$self->{item}}) {    scalar @c;
     if ($item->[0] eq $name) {  
       $count++;  
     }  
   }  
   $count;  
235  }  }
236    
237  sub _delete_empty_item ($) {  sub _delete_empty ($) {
238    my $self = shift;    my $self = shift;
239    my @ret;    $self->{item} = [grep {ref $_ && length $_->[0]} @{$self->{item}}];
   for my $item (@{$self->{item}}) {  
     push @ret, $item if $item->[0];  
   }  
   $self->{item} = \@ret;  
240    $self;    $self;
241  }  }
242    
243    
   
244  sub stringify ($;%) {  sub stringify ($;%) {
245    my $self = shift;    my $self = shift;
246    my %option = @_;    my %option = @_;
247    my @return;    my @return;
248    $self->_delete_empty_item;    $self->_delete_empty;
249    for my $item (@{$self->{item}}) {    for my $item (@{$self->{item}}) {
250      push @return, $item->[0], $item->[1] if $item->[0] =~ /^$REG{item_name}$/;      push @return, $item->[0], $item->[1] if $item->[0] =~ /^$REG{item_name}$/;
251    }    }
252    join (' ', @return).'; '.$self->{date_time}->as_rfc2822_time;    join (' ', @return).'; '.$self->{date_time}->as_rfc2822_time;
253  }  }
254    *as_string = \&stringify;
255    
256    =item $option-value = $r->option ($option-name)
257    
258    Gets option value.
259    
260  sub as_string ($;%) {shift->stringify (@_)}  =item $r->option ($option-name, $option-value, ...)
 =head2 $self->option ($option_name, [$option_value])  
261    
262  Set/gets new value of the option.  Set option value(s).  You can pass multiple option name-value pair
263    as parameter when setting.
264    
265  =cut  =cut
266    
267  sub option ($$;$) {  ## Inherited
   my $self = shift;  
   my ($name, $value) = @_;  
   if (defined $value) {  
     $self->{option}->{$name} = $value;  
   }  
   $self->{option}->{$name};  
 }  
268    
269  =head2 $self->delete_comment ($field_body)  ## TODO: $r->value_type
270    
271  Remove all C<comment> in given strictured C<field-body>.  =item $clone = $r->clone ()
272  This method is intended for internal use.  
273    Returns a copy of the object.
274    
275  =cut  =cut
276    
277  sub delete_comment ($$) {  sub clone ($) {
278    my $self = shift;    my $self = shift;
279    my $body = shift;    $self->_delete_empty;
280    $body =~ s{($REG{quoted_string}|$REG{domain_literal})|$REG{comment}}{    my $clone = $self->SUPER::clone;
281      my $o = $1;  $o? $o : ' ';    $clone->{item} = Message::Util::make_clone ($self->{item});
282    }gex;    $clone->{value_type} = Message::Util::make_clone ($self->{value_type});
283    $body;    $clone;
284  }  }
285    
 =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";  
     }  
   }  
286    
287  =head1 LICENSE  =head1 LICENSE
288    
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24