/[suikacvs]/test/cvs
Suika

Diff of /test/cvs

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

revision 1.14 by wakaba, Wed Apr 3 13:31:36 2002 UTC revision 1.16 by wakaba, Fri Apr 19 12:00:36 2002 UTC
# Line 14  use strict; Line 14  use strict;
14  use vars qw($VERSION %REG);  use vars qw($VERSION %REG);
15  $VERSION = '1.00';  $VERSION = '1.00';
16  use Carp ();  use Carp ();
17  use overload '@{}' => sub {shift->_delete_empty_field()->{field}},  use overload '@{}' => sub { shift->_delete_empty_field->{field} },
18               '""' => sub {shift->stringify};               '""' => sub { shift->stringify },
19                 fallback => 1;
20    
21  $REG{WSP}     = qr/[\x09\x20]/;  $REG{WSP}     = qr/[\x09\x20]/;
22  $REG{FWS}     = qr/[\x09\x20]*/;  $REG{FWS}     = qr/[\x09\x20]*/;
# Line 44  when C<stringify>.  (Default = 0) Line 45  when C<stringify>.  (Default = 0)
45    
46  =cut  =cut
47    
48    =head1 CONSTRUCTORS
49    
50    The following methods construct new C<Message::Header> objects:
51    
52    =over 4
53    
54    =cut
55    
56    ## Initialize
57  my %DEFAULT = (  my %DEFAULT = (
58    capitalize    => 1,    capitalize    => 1,
59    fold_length   => 70,    fold_length   => 70,
# Line 64  $DEFAULT{field_type} = { Line 74  $DEFAULT{field_type} = {
74                    
75          'content-type'  => 'Message::Field::ContentType',          'content-type'  => 'Message::Field::ContentType',
76          'content-disposition'   => 'Message::Field::ContentDisposition',          'content-disposition'   => 'Message::Field::ContentDisposition',
77            'auto-submitted'        => 'Message::Field::ValueParams',
78          link    => 'Message::Field::ValueParams',          link    => 'Message::Field::ValueParams',
79          archive => 'Message::Field::ValueParams',          archive => 'Message::Field::ValueParams',
80          'x-face-type'   => 'Message::Field::ValueParams',          'x-face-type'   => 'Message::Field::ValueParams',
# Line 75  $DEFAULT{field_type} = { Line 86  $DEFAULT{field_type} = {
86          'user-agent'    => 'Message::Field::UA',          'user-agent'    => 'Message::Field::UA',
87          server  => 'Message::Field::UA',          server  => 'Message::Field::UA',
88                    
89            ## Numeric value
90          'content-length'        => 'Message::Field::Numval',          'content-length'        => 'Message::Field::Numval',
91          lines   => 'Message::Field::Numval',          lines   => 'Message::Field::Numval',
92          'max-forwards'  => 'Message::Field::Numval',          'max-forwards'  => 'Message::Field::Numval',
93          'mime-version'  => 'Message::Field::Numval',          'mime-version'  => 'Message::Field::Numval',
94            'x-jsmail-priority'     => 'Message::Field::Numval',
95            'x-mail-count'  => 'Message::Field::Numval',
96            'x-ml-count'    => 'Message::Field::Numval',
97            'x-priority'    => 'Message::Field::Numval',
98                    
99          path    => 'Message::Field::Path',          path    => 'Message::Field::Path',
100  };  };
101  for (qw(cancel-lock importance   precedence list-id  for (qw(archive cancel-lock content-features content-md5
102    x-face x-mail-count x-msmail-priority x-priority xref))    disposition-notification-options encoding
103      importance injector-info
104      pics-label posted-and-mailed precedence list-id message-type
105      original-recipient priority
106      sensitivity status x-face x-msmail-priority xref))
107    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
108  for (qw(approved bcc cc delivered-to disposition-notification-to envelope-to          ## Not supported yet, but to be supported...
109    errors-to fcc from mail-followup-to mail-followup-cc reply-to resent-bcc  for (qw(abuse-reports-to apparently-to approved approved-by bcc cc complaints-to
110      delivered-to disposition-notification-to envelope-to
111      errors-to  from mail-copies-to mail-followup-to mail-reply-to
112      notice-requested-upon-delivery-to read-receipt-to register-mail-reply-requested-by
113      reply-to resent-bcc
114    resent-cc resent-to resent-from resent-sender return-path    resent-cc resent-to resent-from resent-sender return-path
115    return-receipt-to sender to x-approved x-beenthere    return-receipt-to return-receipt-requested-to sender to x-abuse-reports-to
116      x-admin x-approved
117      x-beenthere
118      x-confirm-reading-to
119    x-complaints-to x-envelope-from x-envelope-sender    x-complaints-to x-envelope-from x-envelope-sender
120    x-envelope-to x-ml-address x-ml-command x-ml-to x-nfrom x-nto))    x-envelope-to x-ml-address x-ml-command x-ml-to x-nfrom x-nto
121      x-rcpt-to x-sender x-x-sender))
122    {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}
123  for (qw(date date-received delivery-date expires  for (qw(date date-received delivery-date expires
124    expire-date nntp-posting-date posted reply-by resent-date x-tcup-date))    expire-date nntp-posting-date posted posted-date reply-by resent-date
125      x-originalarrivaltime x-tcup-date))
126    {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}
127  for (qw(article-updates client-date content-id in-reply-to message-id  for (qw(article-updates client-date content-id in-reply-to message-id
128    references resent-message-id see-also supersedes))    obsoletes references replaces resent-message-id see-also supersedes))
129    {$DEFAULT{field_type}->{$_} = 'Message::Field::MsgID'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::MsgID'}
130  for (qw(accept accept-charset accept-encoding accept-language  for (qw(accept accept-charset accept-encoding accept-language
131    content-language    content-language
132    content-transfer-encoding encrypted followup-to keywords    content-transfer-encoding encrypted followup-to keywords
133    list-archive list-digest list-help list-owner    list-archive list-digest list-help list-owner
134    list-post list-subscribe list-unsubscribe list-url uri newsgroups    list-post list-subscribe list-unsubscribe list-url uri newsgroups
135      posted-to
136    x-brother x-daughter x-respect x-moe x-syster x-wife))    x-brother x-daughter x-respect x-moe x-syster x-wife))
137    {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}
138  for (qw(content-alias content-base content-location location referer  for (qw(content-alias content-base content-location location referer
# Line 172  sub _init ($;%) { Line 202  sub _init ($;%) {
202    }    }
203  }  }
204    
205  =head2 Message::Header->new ([%initial-fields/options])  =item Message::Header->new ([%initial-fields/options])
206    
207  Constructs a new C<Message::Headers> object.  You might pass some initial  Constructs a new C<Message::Headers> object.  You might pass some initial
208  C<field-name>-C<field-body> pairs and/or options as parameters to the constructor.  C<field-name>-C<field-body> pairs and/or options as parameters to the constructor.
209    
210  =head3 example  Example:
211    
212   $hdr = new Message::Headers   $hdr = new Message::Headers
213          Date         => 'Thu, 03 Feb 1994 00:00:00 +0000',          Date         => 'Thu, 03 Feb 1994 00:00:00 +0000',
# Line 195  sub new ($;%) { Line 225  sub new ($;%) {
225    $self;    $self;
226  }  }
227    
228  =head2 Message::Header->parse ($header, [%initial-fields/options])  =item Message::Header->parse ($header, [%initial-fields/options])
229    
230  Parses given C<header> and constructs a new C<Message::Headers>  Parses given C<header> and constructs a new C<Message::Headers>
231  object.  You might pass some additional C<field-name>-C<field-body> pairs  object.  You might pass some additional C<field-name>-C<field-body> pairs
# Line 226  sub parse ($$;%) { Line 256  sub parse ($$;%) {
256    $self;    $self;
257  }  }
258    
259    =item Message::Header->parse_array (\@header, [%initial-fields/options])
260    
261    Parses given C<header> and constructs a new C<Message::Headers>
262    object.  Same as C<Message::Header-E<lt>parse> but this method
263    is given an array reference.  You might pass some additional
264    C<field-name>-C<field-body> pairs or/and initial options
265    as parameters to the constructor.
266    
267    =cut
268    
269  sub parse_array ($\@;%) {  sub parse_array ($\@;%) {
270    my $class = shift;    my $class = shift;
271    my $header = shift;    my $header = shift;
# Line 258  sub parse_array ($\@;%) { Line 298  sub parse_array ($\@;%) {
298    $self;    $self;
299  }  }
300    
301    =back
302    
303    =head1 METHODS
304    
305  =head2 $self->field ($field_name)  =head2 $self->field ($field_name)
306    
307  Returns C<field-body> of given C<field-name>.  Returns C<field-body> of given C<field-name>.
# Line 328  sub _field_body ($$$) { Line 372  sub _field_body ($$$) {
372              || $self->{option}->{field_type}->{':DEFAULT'};              || $self->{option}->{field_type}->{':DEFAULT'};
373      eval "require $type" or Carp::croak ("_field_body: $type: $@");      eval "require $type" or Carp::croak ("_field_body: $type: $@");
374      unless ($body) {      unless ($body) {
375        $body = $type->new (-field_name => $name,        $body = $type->new (-field_name => $name,
376          -format => $self->{option}->{format});          -format => $self->{option}->{format}
377            , field_name => $name, format => $self->{option}->{format});
378      } else {      } else {
379        $body = $type->parse ($body, -field_name => $name,        $body = $type->parse ($body, -field_name => $name,
380          -format => $self->{option}->{format});          -format => $self->{option}->{format},
381             field_name => $name,format => $self->{option}->{format});
382      }      }
383    }    }
384    $body;    $body;
# Line 352  sub field_name_list ($) { Line 398  sub field_name_list ($) {
398    map {$_->{name}} @{$self->{field}};    map {$_->{name}} @{$self->{field}};
399  }  }
400    
401  =head2 $self->add ($field-name, $field-body, [$name, $body, ...])  =item $hdr->add ($field-name, $field-body, [$name, $body, ...])
402    
403  Adds an new C<field>.  It is not checked whether  Adds some field name/body pairs.  Even if there are
404  the field which named $field_body is already exist or not.  one or more fields named given C<$field-name>,
405  If you don't want duplicated C<field>s, use C<replace> method.  given name/body pairs are ADDed.  Use C<replace>
406    to remove same-name-fields.
407    
408  Instead of field name-body pair, you might pass some options.  Instead of field name-body pair, you might pass some options.
409  Four options are available for this method.  Four options are available for this method.
# Line 412  sub replace ($%) { Line 459  sub replace ($%) {
459    my %option = %{$self->{option}};    my %option = %{$self->{option}};
460    $option{parse} = defined wantarray unless defined $option{parse};    $option{parse} = defined wantarray unless defined $option{parse};
461    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
462    my (%new_field, $body);    my (%new_field);
463    for (grep {/^[^-]/} keys %params) {    for (grep {/^[^-]/} keys %params) {
464      my $name = lc $_;      my $name = lc $_;
465      $name =~ tr/_/-/ if $option{translate_underscore};      $name =~ tr/_/-/ if $option{translate_underscore};
# Line 421  sub replace ($%) { Line 468  sub replace ($%) {
468      $params{$_} = $self->_field_body ($params{$_}, $name) if $option{parse};      $params{$_} = $self->_field_body ($params{$_}, $name) if $option{parse};
469      $new_field{$name} = $params{$_};      $new_field{$name} = $params{$_};
470    }    }
471      my $body = (%new_field)[-1];
472    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
473      if (defined $new_field{$field->{name}}) {      if (defined $new_field{$field->{name}}) {
474        $body = $new_field {$field->{name}};        $field->{body} = $new_field {$field->{name}};
       $field->{body} = $body;  
475        $new_field{$field->{name}} = undef;        $new_field{$field->{name}} = undef;
476      }      }
477    }    }
# Line 442  Deletes C<field> named as $field_name. Line 489  Deletes C<field> named as $field_name.
489    
490  sub delete ($@) {  sub delete ($@) {
491    my $self = shift;    my $self = shift;
492    my %delete;    my %delete;  for (@_) {$delete{lc $_} = 1}
   for (@_) {$delete{lc $_} = 1}  
493    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
494      undef $field if $delete{$field->{name}};      undef $field if $delete{$field->{name}};
495    }    }
Legend:
Removed from v.1.14  
changed lines
  Added in v.1.16
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24