/[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.17 by wakaba, Sun Apr 21 04:28:46 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  => 1,
60    fold_length   => 70,    fold_length   => 70,
61      field_format_pattern  => '%s: %s',
62    #field_type   => {},    #field_type   => {},
63    format        => 'mail-rfc2822',    format        => 'mail-rfc2822',
64    mail_from     => 0,    mail_from     => 0,
# Line 63  $DEFAULT{field_type} = { Line 75  $DEFAULT{field_type} = {
75          'x-received'    => 'Message::Field::Received',          'x-received'    => 'Message::Field::Received',
76                    
77          'content-type'  => 'Message::Field::ContentType',          'content-type'  => 'Message::Field::ContentType',
78          'content-disposition'   => 'Message::Field::ContentDisposition',          'auto-submitted'        => 'Message::Field::ValueParams',
79            'content-disposition'   => 'Message::Field::ValueParams',
80          link    => 'Message::Field::ValueParams',          link    => 'Message::Field::ValueParams',
81          archive => 'Message::Field::ValueParams',          archive => 'Message::Field::ValueParams',
82          'x-face-type'   => 'Message::Field::ValueParams',          'x-face-type'   => 'Message::Field::ValueParams',
# Line 75  $DEFAULT{field_type} = { Line 88  $DEFAULT{field_type} = {
88          'user-agent'    => 'Message::Field::UA',          'user-agent'    => 'Message::Field::UA',
89          server  => 'Message::Field::UA',          server  => 'Message::Field::UA',
90                    
91            ## Numeric value
92          'content-length'        => 'Message::Field::Numval',          'content-length'        => 'Message::Field::Numval',
93          lines   => 'Message::Field::Numval',          lines   => 'Message::Field::Numval',
94          'max-forwards'  => 'Message::Field::Numval',          'max-forwards'  => 'Message::Field::Numval',
95          'mime-version'  => 'Message::Field::Numval',          'mime-version'  => 'Message::Field::Numval',
96            'x-jsmail-priority'     => 'Message::Field::Numval',
97            'x-mail-count'  => 'Message::Field::Numval',
98            'x-ml-count'    => 'Message::Field::Numval',
99            'x-priority'    => 'Message::Field::Numval',
100                    
101          path    => 'Message::Field::Path',          path    => 'Message::Field::Path',
102  };  };
103  for (qw(cancel-lock importance   precedence list-id  for (qw(archive cancel-lock content-features content-md5
104    x-face x-mail-count x-msmail-priority x-priority xref))    disposition-notification-options encoding
105      importance injector-info
106      pics-label posted-and-mailed precedence list-id message-type
107      original-recipient priority
108      sensitivity status x-face x-msmail-priority xref))
109    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
110  for (qw(approved bcc cc delivered-to disposition-notification-to envelope-to          ## Not supported yet, but to be supported...
111    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
112      delivered-to disposition-notification-to envelope-to
113      errors-to  from mail-copies-to mail-followup-to mail-reply-to
114      notice-requested-upon-delivery-to read-receipt-to register-mail-reply-requested-by
115      reply-to resent-bcc
116    resent-cc resent-to resent-from resent-sender return-path    resent-cc resent-to resent-from resent-sender return-path
117    return-receipt-to sender to x-approved x-beenthere    return-receipt-to return-receipt-requested-to sender to x-abuse-reports-to
118      x-admin x-approved
119      x-beenthere
120      x-confirm-reading-to
121    x-complaints-to x-envelope-from x-envelope-sender    x-complaints-to x-envelope-from x-envelope-sender
122    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
123      x-rcpt-to x-sender x-x-sender))
124    {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}
125  for (qw(date date-received delivery-date expires  for (qw(date date-received delivery-date expires
126    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
127      x-originalarrivaltime x-tcup-date))
128    {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}
129  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
130    references resent-message-id see-also supersedes))    obsoletes references replaces resent-message-id see-also supersedes))
131    {$DEFAULT{field_type}->{$_} = 'Message::Field::MsgID'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::MsgID'}
132  for (qw(accept accept-charset accept-encoding accept-language  for (qw(accept accept-charset accept-encoding accept-language
133    content-language    content-language
134    content-transfer-encoding encrypted followup-to keywords    content-transfer-encoding encrypted followup-to keywords
135    list-archive list-digest list-help list-owner    list-archive list-digest list-help list-owner
136    list-post list-subscribe list-unsubscribe list-url uri newsgroups    list-post list-subscribe list-unsubscribe list-url uri newsgroups
137      posted-to
138    x-brother x-daughter x-respect x-moe x-syster x-wife))    x-brother x-daughter x-respect x-moe x-syster x-wife))
139    {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}
140  for (qw(content-alias content-base content-location location referer  for (qw(content-alias content-base content-location location referer
# Line 157  sub _init ($;%) { Line 189  sub _init ($;%) {
189      if $#new_fields > -1;      if $#new_fields > -1;
190        
191    my $format = $self->{option}->{format};    my $format = $self->{option}->{format};
192    if ($format =~ /^cgi/) {    if ($format =~ /cgi/) {
193      unshift @header_order, qw(content-type location);      unshift @header_order, qw(content-type location);
194      $self->{option}->{sort} = 'good-practice';      $self->{option}->{sort} = 'good-practice';
195        $self->{option}->{fold} = 0;
196    } elsif ($format =~ /^http/) {    } elsif ($format =~ /^http/) {
197      $self->{option}->{sort} = 'good-practice';      $self->{option}->{sort} = 'good-practice';
198    }    }
# Line 172  sub _init ($;%) { Line 205  sub _init ($;%) {
205    }    }
206  }  }
207    
208  =head2 Message::Header->new ([%initial-fields/options])  =item Message::Header->new ([%initial-fields/options])
209    
210  Constructs a new C<Message::Headers> object.  You might pass some initial  Constructs a new C<Message::Headers> object.  You might pass some initial
211  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.
212    
213  =head3 example  Example:
214    
215   $hdr = new Message::Headers   $hdr = new Message::Headers
216          Date         => 'Thu, 03 Feb 1994 00:00:00 +0000',          Date         => 'Thu, 03 Feb 1994 00:00:00 +0000',
# Line 195  sub new ($;%) { Line 228  sub new ($;%) {
228    $self;    $self;
229  }  }
230    
231  =head2 Message::Header->parse ($header, [%initial-fields/options])  =item Message::Header->parse ($header, [%initial-fields/options])
232    
233  Parses given C<header> and constructs a new C<Message::Headers>  Parses given C<header> and constructs a new C<Message::Headers>
234  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 259  sub parse ($$;%) {
259    $self;    $self;
260  }  }
261    
262    =item Message::Header->parse_array (\@header, [%initial-fields/options])
263    
264    Parses given C<header> and constructs a new C<Message::Headers>
265    object.  Same as C<Message::Header-E<lt>parse> but this method
266    is given an array reference.  You might pass some additional
267    C<field-name>-C<field-body> pairs or/and initial options
268    as parameters to the constructor.
269    
270    =cut
271    
272  sub parse_array ($\@;%) {  sub parse_array ($\@;%) {
273    my $class = shift;    my $class = shift;
274    my $header = shift;    my $header = shift;
# Line 258  sub parse_array ($\@;%) { Line 301  sub parse_array ($\@;%) {
301    $self;    $self;
302  }  }
303    
304    =back
305    
306    =head1 METHODS
307    
308  =head2 $self->field ($field_name)  =head2 $self->field ($field_name)
309    
310  Returns C<field-body> of given C<field-name>.  Returns C<field-body> of given C<field-name>.
# Line 328  sub _field_body ($$$) { Line 375  sub _field_body ($$$) {
375              || $self->{option}->{field_type}->{':DEFAULT'};              || $self->{option}->{field_type}->{':DEFAULT'};
376      eval "require $type" or Carp::croak ("_field_body: $type: $@");      eval "require $type" or Carp::croak ("_field_body: $type: $@");
377      unless ($body) {      unless ($body) {
378        $body = $type->new (-field_name => $name,        $body = $type->new (-field_name => $name,
379          -format => $self->{option}->{format});          -format => $self->{option}->{format}
380            , field_name => $name, format => $self->{option}->{format});
381      } else {      } else {
382        $body = $type->parse ($body, -field_name => $name,        $body = $type->parse ($body, -field_name => $name,
383          -format => $self->{option}->{format});          -format => $self->{option}->{format},
384             field_name => $name,format => $self->{option}->{format});
385      }      }
386    }    }
387    $body;    $body;
# Line 352  sub field_name_list ($) { Line 401  sub field_name_list ($) {
401    map {$_->{name}} @{$self->{field}};    map {$_->{name}} @{$self->{field}};
402  }  }
403    
404  =head2 $self->add ($field-name, $field-body, [$name, $body, ...])  =item $hdr->add ($field-name, $field-body, [$name, $body, ...])
405    
406  Adds an new C<field>.  It is not checked whether  Adds some field name/body pairs.  Even if there are
407  the field which named $field_body is already exist or not.  one or more fields named given C<$field-name>,
408  If you don't want duplicated C<field>s, use C<replace> method.  given name/body pairs are ADDed.  Use C<replace>
409    to remove same-name-fields.
410    
411  Instead of field name-body pair, you might pass some options.  Instead of field name-body pair, you might pass some options.
412  Four options are available for this method.  Four options are available for this method.
# Line 412  sub replace ($%) { Line 462  sub replace ($%) {
462    my %option = %{$self->{option}};    my %option = %{$self->{option}};
463    $option{parse} = defined wantarray unless defined $option{parse};    $option{parse} = defined wantarray unless defined $option{parse};
464    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
465    my (%new_field, $body);    my (%new_field);
466    for (grep {/^[^-]/} keys %params) {    for (grep {/^[^-]/} keys %params) {
467      my $name = lc $_;      my $name = lc $_;
468      $name =~ tr/_/-/ if $option{translate_underscore};      $name =~ tr/_/-/ if $option{translate_underscore};
# Line 421  sub replace ($%) { Line 471  sub replace ($%) {
471      $params{$_} = $self->_field_body ($params{$_}, $name) if $option{parse};      $params{$_} = $self->_field_body ($params{$_}, $name) if $option{parse};
472      $new_field{$name} = $params{$_};      $new_field{$name} = $params{$_};
473    }    }
474      my $body = (%new_field)[-1];
475    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
476      if (defined $new_field{$field->{name}}) {      if (defined $new_field{$field->{name}}) {
477        $body = $new_field {$field->{name}};        $field->{body} = $new_field {$field->{name}};
       $field->{body} = $body;  
478        $new_field{$field->{name}} = undef;        $new_field{$field->{name}} = undef;
479      }      }
480    }    }
# Line 442  Deletes C<field> named as $field_name. Line 492  Deletes C<field> named as $field_name.
492    
493  sub delete ($@) {  sub delete ($@) {
494    my $self = shift;    my $self = shift;
495    my %delete;    my %delete;  for (@_) {$delete{lc $_} = 1}
   for (@_) {$delete{lc $_} = 1}  
496    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
497      undef $field if $delete{$field->{name}};      undef $field if $delete{$field->{name}};
498    }    }
# Line 571  sub stringify ($;%) { Line 620  sub stringify ($;%) {
620      $fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;      $fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;
621      $fbody =~ s/\x0A(?=[^\x09\x20])/\x0A\x20/g;      $fbody =~ s/\x0A(?=[^\x09\x20])/\x0A\x20/g;
622      $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $option{capitalize};      $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $option{capitalize};
623      push @ret, $name.': '.$self->fold ($fbody);      $fbody = $self->_fold ($fbody) if $self->{option}->{fold};
624        push @ret, sprintf $self->{option}->{field_format_pattern}, $name, $fbody;
625    });    });
626    my $ret = join ("\n", @ret);    my $ret = join ("\n", @ret);
627    $ret? $ret."\n": '';    $ret? $ret."\n": '';
# Line 623  sub _delete_empty_field ($) { Line 673  sub _delete_empty_field ($) {
673    $self;    $self;
674  }  }
675    
676  sub fold ($$;$) {  sub _fold ($$;$) {
677    my $self = shift;    my $self = shift;
678    my $string = shift;    my $string = shift;
679    my $len = shift || $self->{option}->{fold_length};    my $len = shift || $self->{option}->{fold_length};
Legend:
Removed from v.1.14  
changed lines
  Added in v.1.17
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24