/[suikacvs]/test/cvs
Suika

Diff of /test/cvs

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

revision 1.7 by wakaba, Thu Mar 21 04:21:28 2002 UTC revision 1.19 by wakaba, Wed May 15 07:31:28 2002 UTC
# Line 11  Perl module for RFC 822/2822 message C<h Line 11  Perl module for RFC 822/2822 message C<h
11    
12  package Message::Header;  package Message::Header;
13  use strict;  use strict;
14  use vars qw($VERSION %REG %DEFAULT);  use vars qw($VERSION %REG);
15  $VERSION = '1.00';  $VERSION = '1.00';
16    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  %DEFAULT = (  =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 = (
58    capitalize    => 1,    capitalize    => 1,
59      fold  => 1,
60    fold_length   => 70,    fold_length   => 70,
61      field_format_pattern  => '%s: %s',
62      #field_type   => {},
63      format        => 'mail-rfc2822',
64      linebreak_strict      => 0,
65    mail_from     => 0,    mail_from     => 0,
66    field_type    => {':DEFAULT' => 'Message::Field::Unstructured'},    output_bcc    => 0,
67      parse_all     => 0,
68      sort  => 'none',
69      translate_underscore  => 1,
70      uri_mailto_safe       => {
71            ## 1 all (no check)     2 no trace & bcc & from
72            ## 3 no sender's info   4 (default) (currently not used)
73            ## 5 only a few
74            ':default'      => 4,
75            'cc'    => 4,
76            'bcc'   => 1,
77            'body'  => 1,
78            'comment'       => 5,
79            'content-id'    => 1,
80            'date'  => 1,
81            'from'  => 1,
82            'keywords'      => 5,
83            'list-id'       => 1,
84            'mail-from'     => 1,
85            'message-id'    => 1,
86            'received'      => 1,
87            'resent-bcc'    => 1,
88            'resent-date'   => 1,
89            'resent-from'   => 1,
90            'resent-sender' => 1,
91            'return-path'   => 1,
92            'sender'        => 1,
93            'subject'       => 5,
94            'summary'       => 5,
95            'to'    => 4,
96            'user-agent'    => 3,
97            'x-face'        => 2,
98            'x-mailer'      => 3,
99            'x-nsubject'    => 5,
100            'x-received'    => 1,
101            'x400-received' => 1,
102            },
103      uri_mailto_safe_level => 4,
104      validate      => 1,
105  );  );
106  my @field_type_Structured = qw(cancel-lock  $DEFAULT{field_type} = {
107    importance mime-version path precedence user-agent x-cite          ':DEFAULT'      => 'Message::Field::Unstructured',
108    x-face x-mail-count x-msmail-priority x-priority x-uidl xref);          
109  for (@field_type_Structured)          received        => 'Message::Field::Received',
110            'x-received'    => 'Message::Field::Received',
111            
112            'content-type'  => 'Message::Field::ContentType',
113            p3p     => 'Message::Field::Params',
114            'auto-submitted'        => 'Message::Field::ValueParams',
115            'content-disposition'   => 'Message::Field::ValueParams',
116            link    => 'Message::Field::ValueParams',
117            archive => 'Message::Field::ValueParams',
118            'x-face-type'   => 'Message::Field::ValueParams',
119            'x-mozilla-draft-info'  => 'Message::Field::ValueParams',
120            
121            subject => 'Message::Field::Subject',
122            'x-nsubject'    => 'Message::Field::Subject',
123            
124            'list-software' => 'Message::Field::UA',
125            'user-agent'    => 'Message::Field::UA',
126            'resent-user-agent'     => 'Message::Field::UA',
127            server  => 'Message::Field::UA',
128            
129            ## A message id
130            'content-id'    => 'Message::Field::MsgID',
131            'message-id'    => 'Message::Field::MsgID',
132            'resent-message-id'     => 'Message::Field::MsgID',
133            
134            ## Numeric value
135            'content-length'        => 'Message::Field::Numval',
136            lines   => 'Message::Field::Numval',
137            'max-forwards'  => 'Message::Field::Numval',
138            'mime-version'  => 'Message::Field::Numval',
139            'x-jsmail-priority'     => 'Message::Field::Numval',
140            'x-mail-count'  => 'Message::Field::Numval',
141            'x-ml-count'    => 'Message::Field::Numval',
142            'x-priority'    => 'Message::Field::Numval',
143            
144            path    => 'Message::Field::Path',
145    };
146    for (qw(archive cancel-lock content-features content-md5
147      disposition-notification-options encoding
148      importance injector-info
149      pics-label posted-and-mailed precedence list-id message-type
150      original-recipient priority x-list-id
151      sensitivity status x-face x-msmail-priority xref))
152    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
153  my @field_type_Address = qw(approved bcc cc delivered-to envelope-to          ## Not supported yet, but to be supported...
154    errors-to fcc from mail-followup-to mail-followup-cc mail-from reply-to resent-bcc          # x-list: unstructured, ml name
155    for (qw(abuse-reports-to apparently-to approved approved-by bcc cc complaints-to
156      delivered-to disposition-notification-to envelope-to
157      errors-to  from mail-copies-to mail-followup-to mail-reply-to
158      notice-requested-upon-delivery-to read-receipt-to register-mail-reply-requested-by
159      reply-to resent-bcc
160    resent-cc resent-to resent-from resent-sender return-path    resent-cc resent-to resent-from resent-sender return-path
161    return-receipt-to sender to x-approved x-beenthere    return-receipt-to return-receipt-requested-to sender to x-abuse-reports-to
162      x-admin x-approved x-beenthere x-confirm-reading-to
163    x-complaints-to x-envelope-from x-envelope-sender    x-complaints-to x-envelope-from x-envelope-sender
164    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
165  for (@field_type_Address)    x-rcpt-to x-sender x-x-sender))
166    {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Addresses'}
167  my @field_type_Date = qw(date date-received delivery-date expires  for (qw(client-date date date-received delivery-date expires
168    expire-date nntp-posting-date posted reply-by resent-date x-tcup-date);    expire-date nntp-posting-date posted posted-date received-date
169  for (@field_type_Date)    reply-by resent-date
170      x-originalarrivaltime x-tcup-date))
171    {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}
172  my @field_type_MsgID = qw(content-id in-reply-to message-id  for (qw(article-updates in-reply-to
173    references resent-message-id see-also supersedes);    obsoletes references replaces see-also supersedes))
174  for (@field_type_MsgID)    {$DEFAULT{field_type}->{$_} = 'Message::Field::MsgIDs'}
   {$DEFAULT{field_type}->{$_} = 'Message::Field::MsgID'}  
 for (qw(received x-received))  
   {$DEFAULT{field_type}->{$_} = 'Message::Field::Received'}  
175  for (qw(accept accept-charset accept-encoding accept-language  for (qw(accept accept-charset accept-encoding accept-language
176    content-disposition content-language    content-language
177    content-transfer-encoding content-type encrypted followup-to keywords newsgroups    content-transfer-encoding encrypted followup-to keywords
178    x-brother x-daughter x-face-type x-respect x-moe    list-archive list-digest list-help list-owner
179    x-syster x-wife))    list-post list-subscribe list-unsubscribe list-url uri newsgroups
180      posted-to))
181    {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}
182  my @field_type_URI = qw(list-archive list-help list-owner  for (qw(x-brother x-boss x-classmate x-daughter x-dearfriend x-favoritesong
183    list-post list-subscribe list-unsubscribe uri url x-home-page x-http_referer    x-friend x-me
184    x-info x-pgp-key x-ml-url x-uri x-url x-web);    x-moe x-respect
185  for (@field_type_URI)    x-sublimate x-son x-sister x-wife))
186    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}  ## NOT M::F::XMOE!
187  for (qw(list-id))  for (qw(content-alias content-base content-location location referer
188    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}    url x-home-page x-http_referer
189  for (qw(content-description subject title x-nsubject))    x-info x-pgp-key x-ml-url x-uri x-url x-web))
190    {$DEFAULT{field_type}->{$_} = 'Message::Field::Subject'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::URI'}
191    
192    my %header_goodcase = (
193            'article-i.d.'  => 'Article-I.D.',
194            'content-id'    => 'Content-ID',
195            'content-md5'   => 'Content-MD5',
196            'content-sgml-entity'   => 'Content-SGML-Entity',
197            etag    => 'ETag',
198            fax     => 'FAX',
199            'pics-label'    => 'PICS-Label',
200            'list-url'      => 'List-URL',
201            'list-id'       => 'List-ID',
202            'message-id'    => 'Message-ID',
203            'mime-version'  => 'MIME-Version',
204            'nic'   => 'NIC',
205            'nntp-posting-date'     => 'NNTP-Posting-Date',
206            'nntp-posting-host'     => 'NNTP-Posting-Host',
207            'resent-message-id'     => 'Resent-Message-ID',
208            te      => 'TE',
209            url     => 'URL',
210            'www-authenticate'      => 'WWW-Authenticate',
211            'x-dearfriend'  => 'X-DearFriend',
212            'x-mime-autoconverted'  => 'X-MIME-Autoconverted',
213            'x-nntp-posting-date'   => 'X-NNTP-Posting-Date',
214            'x-nntp-posting-host'   => 'X-NNTP-Posting-Host',
215            'x-uri' => 'X-URI',
216            'x-url' => 'X-URL',
217    );
218    $DEFAULT{capitalize} = sub {
219      my $self = shift;
220      my $name = shift;
221      if ($header_goodcase{$name}) {
222        return $header_goodcase{$name};
223      }
224      $name =~ s/(?:^|-)cgi-/uc $&/ge;
225      $name =~ s/(?:^|-)[a-z]/uc $&/ge;
226      $name;
227    };
228    
229    ## taken from L<HTTP::Header>
230    # "Good Practice" order of HTTP message headers:
231    #    - General-Headers
232    #    - Request-Headers
233    #    - Response-Headers
234    #    - Entity-Headers
235    # (From draft-ietf-http-v11-spec-rev-01, Nov 21, 1997)
236    my @header_order = qw(
237      mail-from x-envelope-from relay-version path status
238    
239       cache-control connection date pragma transfer-encoding upgrade trailer via
240    
241       accept accept-charset accept-encoding accept-language
242       authorization expect from host
243       if-modified-since if-match if-none-match if-range if-unmodified-since
244       max-forwards proxy-authorization range referer te user-agent
245    
246       accept-ranges age location proxy-authenticate retry-after server vary
247       warning www-authenticate
248    
249       mime-version
250       allow content-base content-encoding content-language content-length
251       content-location content-md5 content-range content-type
252       etag expires last-modified content-style-type content-script-type
253       link
254    
255      xref
256    );
257    my %header_order;
258    
259    sub _init ($;%) {
260      my $self = shift;
261      my %options = @_;
262      $self->{field} = [];
263      $self->{option} = \%DEFAULT;
264      my @new_fields = ();
265      for my $name (keys %options) {
266        if (substr ($name, 0, 1) eq '-') {
267          $self->{option}->{substr ($name, 1)} = $options{$name};
268        } else {
269          push @new_fields, ($name => $options{$name});
270        }
271      }
272      $self->_init_by_format ($self->{option}->{format}, $self->{option});
273      # Make alternative representations of @header_order.  This is used
274      # for sorting.
275      my $i = 1;
276      for (@header_order) {
277          $header_order{$_} = $i++ unless $header_order{$_};
278      }
279      
280      $self->add (@new_fields, -parse => $self->{option}->{parse_all})
281        if $#new_fields > -1;
282    }
283    
284  =head2 Message::Header->new ([%option])  sub _init_by_format ($$\%) {
285      my $self = shift;
286      my ($format, $option) = @_;
287      if ($format =~ /rfc822/) {
288        $header_goodcase{bcc} = 'bcc';
289        $header_goodcase{cc} = 'cc';
290        $header_goodcase{'resent-bcc'} = 'Resent-bcc';
291        $header_goodcase{'resent-cc'} = 'Resent-cc';
292      } elsif ($format =~ /cgi/) {
293        unshift @header_order, qw(content-type location);
294        $option->{sort} = 'good-practice';
295        $option->{fold} = 0;
296      } elsif ($format =~ /http/) {
297        $option->{sort} = 'good-practice';
298      }
299      if ($format =~ /uri-url-mailto/) {
300        $option->{output_bcc} = 0;
301        $option->{capitalize} = 0;
302        $option->{field_format_pattern} = '%s=%s';
303        $option->{fold} = sub {
304          $_[1] =~ s/([^:@+\$A-Za-z0-9\-_.!~*])/sprintf('%%%02X', ord $1)/ge;
305          $_[1];
306        };
307      }
308    }
309    
310  Returns new Message::Header instance.  Some options can be  =item Message::Header->new ([%initial-fields/options])
311  specified as hash.  
312    Constructs a new C<Message::Headers> object.  You might pass some initial
313    C<field-name>-C<field-body> pairs and/or options as parameters to the constructor.
314    
315    Example:
316    
317     $hdr = new Message::Headers
318            Date         => 'Thu, 03 Feb 1994 00:00:00 +0000',
319            Content_Type => 'text/html',
320            Content_Location => 'http://www.foo.example/',
321            -format => 'mail-rfc2822'       ## not to be header field
322            ;
323    
324  =cut  =cut
325    
326  sub new ($;%) {  sub new ($;%) {
327    my $class = shift;    my $class = shift;
328    my $self = bless {option => {@_}}, $class;    my $self = bless {}, $class;
329    for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}    $self->_init (@_);
330    $self;    $self;
331  }  }
332    
333  =head2 Message::Header->parse ($header, [%option])  =item Message::Header->parse ($header, [%initial-fields/options])
334    
335  Parses given C<header> and return a new Message::Header  Parses given C<header> and constructs a new C<Message::Headers>
336  object.  Some options can be specified as hash.  object.  You might pass some additional C<field-name>-C<field-body> pairs
337    or/and initial options as parameters to the constructor.
338    
339  =cut  =cut
340    
341  sub parse ($$;%) {  sub parse ($$;%) {
342    my $class = shift;    my $class = shift;
343    my $header = shift;    my $header = shift;
344    my $self = bless {option => {@_}}, $class;    my $self = bless {}, $class;
345    for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}    $self->_init (@_);    ## BUG: don't check linebreak_strict
346    $header =~ s/\x0D?\x0A$REG{WSP}+/\x20/gos;    ## unfold    $header =~ s/\x0D?\x0A$REG{WSP}/\x20/gos;     ## unfold
347    for my $field (split /\x0D?\x0A/, $header) {    for my $field (split /\x0D?\x0A/, $header) {
348      if ($field =~ /$REG{M_fromline}/) {      if ($field =~ /$REG{M_fromline}/) {
349        push @{$self->{field}}, {name => 'mail-from', body => $1};        my $body = $1;
350          $body = $self->_field_body ($body, 'mail-from')
351            if $self->{option}->{parse_all};
352          push @{$self->{field}}, {name => 'mail-from', body => $body};
353      } elsif ($field =~ /$REG{M_field}/) {      } elsif ($field =~ /$REG{M_field}/) {
354        my ($name, $body) = ($1, $2);        my ($name, $body) = (lc $1, $2);
355        $name =~ s/$REG{WSP}+$//;        $name =~ s/$REG{WSP}+$//;
356        $body =~ s/$REG{WSP}+$//;        $body =~ s/$REG{WSP}+$//;
357        push @{$self->{field}}, {name => lc $name, body => $body};        $body = $self->_field_body ($body, $name) if $self->{option}->{parse_all};
358          push @{$self->{field}}, {name => $name, body => $body};
359      }      }
360    }    }
361    $self;    $self;
362  }  }
363    
364    =item Message::Header->parse_array (\@header, [%initial-fields/options])
365    
366    Parses given C<header> and constructs a new C<Message::Headers>
367    object.  Same as C<Message::Header-E<lt>parse> but this method
368    is given an array reference.  You might pass some additional
369    C<field-name>-C<field-body> pairs or/and initial options
370    as parameters to the constructor.
371    
372    =cut
373    
374    sub parse_array ($\@;%) {
375      my $class = shift;
376      my $header = shift;
377      Carp::croak "parse_array: first argument is not an array reference"
378        unless ref $header eq 'ARRAY';
379      my $self = bless {}, $class;
380      $self->_init (@_);
381      while (1) {
382        my $field = shift @$header;
383        while (1) {
384          if ($$header[0] =~ /^$REG{WSP}/) {
385            $field .= shift @$header;
386          } else {last}
387        }
388        if ($self->{option}->{linebreak_strict}) {
389          $field =~ s/\x0D\x0A//g;
390        } else {
391          $field =~ tr/\x0D\x0A//d;
392        }
393        if ($field =~ /$REG{M_fromline}/) {
394          my $body = $1;
395          $body = $self->_field_body ($body, 'mail-from')
396            if $self->{option}->{parse_all};
397          push @{$self->{field}}, {name => 'mail-from', body => $body};
398        } elsif ($field =~ /$REG{M_field}/) {
399          my ($name, $body) = (lc $1, $2);
400          $name =~ s/$REG{WSP}+$//;
401          $body =~ s/$REG{WSP}+$//;
402          $body = $self->_field_body ($body, $name) if $self->{option}->{parse_all};
403          push @{$self->{field}}, {name => $name, body => $body};
404        }
405        last if $#$header < 0;
406      }
407      $self;
408    }
409    
410    =back
411    
412    =head1 METHODS
413    
414  =head2 $self->field ($field_name)  =head2 $self->field ($field_name)
415    
416  Returns C<field-body> of given C<field-name>.  Returns C<field-body> of given C<field-name>.
# Line 153  sub field ($$) { Line 435  sub field ($$) {
435        }        }
436      }      }
437    }    }
438      if ($#ret < 0) {
439        return $self->add ($name);
440      }
441    @ret;    @ret;
442  }  }
443    
444    sub field_exist ($$) {
445      my $self = shift;
446      my $name = lc shift;
447      my @ret;
448      for my $field (@{$self->{field}}) {
449        return 1 if ($field->{name} eq $name);
450      }
451      0;
452    }
453    
454  =head2 $self->field_name ($index)  =head2 $self->field_name ($index)
455    
456  Returns C<field-name> of $index'th C<field>.  Returns C<field-name> of $index'th C<field>.
# Line 184  sub _field_body ($$$) { Line 479  sub _field_body ($$$) {
479    unless (ref $body) {    unless (ref $body) {
480      my $type = $self->{option}->{field_type}->{$name}      my $type = $self->{option}->{field_type}->{$name}
481              || $self->{option}->{field_type}->{':DEFAULT'};              || $self->{option}->{field_type}->{':DEFAULT'};
482      eval "require $type";      eval "require $type" or Carp::croak ("_field_body: $type: $@");
483      unless ($body) {      unless ($body) {
484        $body = $type->new (field_name => $name);        $body = $type->new (-field_name => $name,
485            -format => $self->{option}->{format},
486            -parse_all => $self->{option}->{parse_all});
487      } else {      } else {
488        $body = $type->parse ($body, field_name => $name);        $body = $type->parse ($body, -field_name => $name,
489            -format => $self->{option}->{format},
490            -parse_all => $self->{option}->{parse_all});
491      }      }
492    }    }
493    $body;    $body;
# Line 208  sub field_name_list ($) { Line 507  sub field_name_list ($) {
507    map {$_->{name}} @{$self->{field}};    map {$_->{name}} @{$self->{field}};
508  }  }
509    
510  =head2 $self->add ($field_name, $field_body)  =item $hdr->add ($field-name, $field-body, [$name, $body, ...])
511    
512    Adds some field name/body pairs.  Even if there are
513    one or more fields named given C<$field-name>,
514    given name/body pairs are ADDed.  Use C<replace>
515    to remove same-name-fields.
516    
517    Instead of field name-body pair, you might pass some options.
518    Four options are available for this method.
519    
520    C<-parse>: Parses and validates C<field-body>, and returns
521    C<field-body> object.  (When multiple C<field-body>s are
522    added, returns only last one.)  (Default: C<defined wantarray>)
523    
524    C<-prepend>: New fields are not appended,
525    but prepended to current fields.  (Default: C<0>)
526    
527    C<-translate-underscore>: Do C<field-name> =~ tr/_/-/.  (Default: C<1>)
528    
529  Adds an new C<field>.  It is not checked whether  C<-validate>: Checks whether C<field-name> is valid or not.
 the field which named $field_body is already exist or not.  
 If you don't want duplicated C<field>s, use C<replace> method.  
530    
531  =cut  =cut
532    
533  sub add ($$$) {  sub add ($%) {
534    my $self = shift;    my $self = shift;
535    my ($name, $body) = (lc shift, shift);    my %fields = @_;
536    return 0 if $name =~ /$REG{UNSAFE_field_name}/;    my %option = %{$self->{option}};
537    $body = $self->_field_body ($body, $name);    $option{parse} = 1 if defined wantarray;
538    push @{$self->{field}}, {name => $name, body => $body};    for (grep {/^-/} keys %fields) {$option{substr ($_, 1)} = $fields{$_}}
539    $body;    my $body;
540      for (grep {/^[^-]/} keys %fields) {
541        my $name = lc $_;  $body = $fields{$_};
542        $name =~ tr/_/-/ if $option{translate_underscore};
543        Carp::croak "add: $name: invalid field-name"
544          if $option{validate} && $name =~ /$REG{UNSAFE_field_name}/;
545        $body = $self->_field_body ($body, $name) if $option{parse};
546        if ($option{prepend}) {
547          unshift @{$self->{field}}, {name => $name, body => $body};
548        } else {
549          push @{$self->{field}}, {name => $name, body => $body};
550        }
551      }
552      $body if $option{parse};
553  }  }
554    
555  =head2 $self->relace ($field_name, $field_body)  =head2 $self->relace ($field_name, $field_body)
# Line 235  first one is used and the others are not Line 562  first one is used and the others are not
562    
563  =cut  =cut
564    
565  sub replace ($$$) {  sub replace ($%) {
566    my $self = shift;    my $self = shift;
567    my ($name, $body) = (lc shift, shift);    my %params = @_;
568    return 0 if $name =~ /$REG{UNSAFE_field_name}/;    my %option = %{$self->{option}};
569      $option{parse} = defined wantarray unless defined $option{parse};
570      for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
571      my (%new_field);
572      for (grep {/^[^-]/} keys %params) {
573        my $name = lc $_;
574        $name =~ tr/_/-/ if $option{translate_underscore};
575        Carp::croak "replace: $name: invalid field-name"
576          if $option{validate} && $name =~ /$REG{UNSAFE_field_name}/;
577        $params{$_} = $self->_field_body ($params{$_}, $name) if $option{parse};
578        $new_field{$name} = $params{$_};
579      }
580      my $body = (%new_field)[-1];
581    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
582      if ($field->{name} eq $name) {      if (defined $new_field{$field->{name}}) {
583        $field->{body} = $body;        $field->{body} = $new_field {$field->{name}};
584        return $self;        $new_field{$field->{name}} = undef;
585      }      }
586    }    }
587    push @{$self->{field}}, {name => $name, body => $body};    for (keys %new_field) {
588    $self;      push @{$self->{field}}, {name => $_, body => $new_field{$_}};
589      }
590      $body if $option{parse};
591  }  }
592    
593  =head2 $self->delete ($field_name, [$index])  =head2 $self->delete ($field-name, [$name, ...])
594    
595  Deletes C<field> named as $field_name.  Deletes C<field> named as $field_name.
 If $index is specified, only $index'th C<field> is deleted.  
 If not, ($index == 0), all C<field>s that have the C<field-name>  
 $field_name are deleted.  
596    
597  =cut  =cut
598    
599  sub delete ($$;$) {  sub delete ($@) {
600    my $self = shift;    my $self = shift;
601    my ($name, $index) = (lc shift, shift);    my %delete;  for (@_) {$delete{lc $_} = 1}
   my $i = 0;  
602    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
603      if ($field->{name} eq $name) {      undef $field if $delete{$field->{name}};
       $i++;  
       if ($index == 0 || $i == $index) {  
         undef $field;  
         return $self if $i == $index;  
       }  
     }  
604    }    }
   $self;  
605  }  }
606    
607  =head2 $self->count ([$field_name])  =head2 $self->count ([$field_name])
# Line 298  sub count ($;$) { Line 628  sub count ($;$) {
628    $count;    $count;
629  }  }
630    
631  =head2 $self->stringify ([%option])  =head2 $self->rename ($field-name, $new-name, [$old, $new,...])
632    
633  Returns the C<header> as a string.  Renames C<$field-name> as C<$new-name>.
634    
635  =cut  =cut
636    
637  sub stringify ($;%) {  sub rename ($%) {
638    my $self = shift;    my $self = shift;
639    my %OPT = @_;    my %params = @_;
640    my @ret;    my %option = %{$self->{option}};
641    $OPT{capitalize} ||= $self->{option}->{capitalize};    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
642    $OPT{mail_from} ||= $self->{option}->{mail_from};    my %new_name;
643    push @ret, 'From '.$self->field ('mail-from') if $OPT{mail_from};    for (grep {/^[^-]/} keys %params) {
644        my ($old => $new) = (lc $_ => lc $params{$_});
645        $new =~ tr/_/-/ if $option{translate_underscore};
646        Carp::croak "rename: $new: invalid field-name"
647          if $option{validate} && $new =~ /$REG{UNSAFE_field_name}/;
648        $new_name{$old} = $new;
649      }
650    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
651      my $name = $field->{name};      if (length $new_name{$field->{name}}) {
652      next unless $field->{name};        $field->{name} = $new_name{$field->{name}};
653      next if !$OPT{mail_from} && $name eq 'mail-from';      }
654      my $fbody = scalar $field->{body};    }
655      next unless $fbody;    $self if defined wantarray;
656      $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $OPT{capitalize};  }
657      push @ret, $name.': '.$self->fold ($fbody);  
658    
659    =item $self->scan(\&doit)
660    
661    Apply a subroutine to each header field in turn.  The callback routine is
662    called with two parameters; the name of the field and a single value.
663    If the header has more than one value, then the routine is called once
664    for each value.
665    
666    =cut
667    
668    sub scan ($&) {
669      my ($self, $sub) = @_;
670      my $sort;
671      $sort = \&_header_cmp if $self->{option}->{sort} eq 'good-practice';
672      $sort = {$a cmp $b} if $self->{option}->{sort} eq 'alphabetic';
673      my @field = @{$self->{field}};
674      if (ref $sort) {
675        @field = sort $sort @{$self->{field}};
676      }
677      for my $field (@field) {
678        next if $field->{name} =~ /^_/;
679        &$sub($field->{name} => $field->{body});
680    }    }
   my $ret = join ("\n", @ret);  
   $ret? $ret."\n": "";  
681  }  }
682    
683  =head2 $self->get_option ($option_name)  # Compare function which makes it easy to sort headers in the
684    # recommended "Good Practice" order.
685    ## taken from HTTP::Header
686    sub _header_cmp
687    {
688      my ($na, $nb) = ($a->{name}, $b->{name});
689        # Unknown headers are assign a large value so that they are
690        # sorted last.  This also helps avoiding a warning from -w
691        # about comparing undefined values.
692        $header_order{$na} = 999 unless defined $header_order{$na};
693        $header_order{$nb} = 999 unless defined $header_order{$nb};
694    
695  Returns value of the option.      $header_order{$na} <=> $header_order{$nb} || $na cmp $nb;
696    }
697    
698  =head2 $self->set_option ($option_name, $option_value)  =head2 $self->stringify ([%option])
699    
700  Set new value of the option.  Returns the C<header> as a string.
701    
702  =cut  =cut
703    
704  sub get_option ($$) {  sub stringify ($;%) {
705    my $self = shift;    my $self = shift;
706    my ($name) = @_;    my %params = @_;
707    $self->{option}->{$name};    my %option = %{$self->{option}};
708      $option{format} = $params{-format} if $params{-format};
709      $self->_init_by_format ($option{format}, \%option);
710      for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
711      my @ret;
712      my $_stringify = sub {
713          my ($name, $body) = (@_);
714          return unless length $name;
715          return if $option{mail_from} && $name eq 'mail-from';
716          return if !$option{output_bcc} && ($name eq 'bcc' || $name eq 'resent-bcc');
717          if ($option{format} =~ /uri-url-mailto/) {
718            return if ((   $option{uri_mailto_safe}->{$name}
719                 || $option{uri_mailto_safe}->{':default'})
720                  < $option{uri_mailto_safe_level});
721            if ($name eq 'to') {
722              $body = $self->field ('to');
723              return unless ref $body && $body->have_group;
724            }
725          }
726          my $fbody;
727          if (ref $body) {
728            $fbody = $body->stringify (-format => $option{format});
729          } else {
730            $fbody = $body;
731          }
732          return unless length $fbody;
733          unless ($option{linebreak_strict}) {
734            ## bare \x0D and bare \x0A are unsafe
735            $fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;
736            $fbody =~ s/\x0A(?=[^\x09\x20])/\x0A\x20/g;
737          } else {
738            $fbody =~ s/\x0D\x0A(?=[^\x09\x20])/\x0D\x0A\x20/g;
739          }
740          if (ref $option{capitalize}) {
741            $name = &{$option{capitalize}} ($self, $name);
742          } elsif ($option{capitalize}) {
743            $name =~ s/((?:^|-)[a-z])/uc($1)/ge;
744          }
745          if (ref $option{fold}) {
746            $fbody = &{$option{fold}} ($self, $fbody);
747          } elsif ($option{fold}) {
748            $fbody = $self->_fold ($fbody);
749          }
750          push @ret, sprintf $option{field_format_pattern}, $name, $fbody;
751        };
752      if ($option{format} =~ /uri-url-mailto-to/) {
753        if ($self->field_exist ('to')) {
754          my $to = $self->field ('to');
755          unless ($to->have_group) {
756            my $fbody = $to->stringify (-format => $option{format});
757            return &{$option{fold}} ($self, $fbody);
758          }
759        }
760        '';
761      } elsif ($option{format} =~ /uri-url-mailto/) {
762        $self->scan ($_stringify);
763        my $ret = join ('&', @ret);
764        $ret;
765      } else {
766        if ($option{mail_from}) {
767          my $fromline = $self->field ('mail-from');
768          push @ret, 'From '.$fromline if $fromline;
769        }
770        $self->scan ($_stringify);
771        my $ret = join ("\n", @ret);
772        $ret? $ret."\n": '';
773      }
774  }  }
775  sub set_option ($$$) {  *as_string = \&stringify;
776    
777    =head2 $self->option ($option_name, [$option_value])
778    
779    Set/gets new value of the option.
780    
781    =cut
782    
783    sub option ($@) {
784    my $self = shift;    my $self = shift;
785    my ($name, $value) = @_;    if (@_ == 1) {
786    $self->{option}->{$name} = $value;      return $self->{option}->{ shift (@_) };
787    $self;    }
788      while (my ($name, $value) = splice (@_, 0, 2)) {
789        $name =~ s/^-//;
790        $self->{option}->{$name} = $value;
791        if ($name eq 'format') {
792          for my $f (@{$self->{field}}) {
793            if (ref $f->{body}) {
794              $f->{body}->option (-format => $value);
795            }
796          }
797        }
798      }
799  }  }
800    
801  sub field_type ($$;$) {  sub field_type ($$;$) {
# Line 367  sub _delete_empty_field ($) { Line 819  sub _delete_empty_field ($) {
819    $self;    $self;
820  }  }
821    
822  sub fold ($$;$) {  sub _fold ($$;$) {
823    my $self = shift;    my $self = shift;
824    my $string = shift;    my $string = shift;
825    my $len = shift || $self->{option}->{fold_length};    my $len = shift || $self->{option}->{fold_length};
# Line 385  sub fold ($$;$) { Line 837  sub fold ($$;$) {
837       # next split a whitespace       # next split a whitespace
838       # else we are looking at a single word and probably don't want to split       # else we are looking at a single word and probably don't want to split
839       my $x = "";       my $x = "";
840       $x .= "$1\n    "       $x .= "$1\n "
841         while($string =~ s/^$REG{WSP}*(         while($string =~ s/^$REG{WSP}*(
842                            [^"]{$min,$max}?[\,\;]                            [^"]{$min,$max}?[\,\;]
843                            |[^"]{1,$max}$REG{WSP}                            |[^"]{1,$max}$REG{WSP}
# Line 401  sub fold ($$;$) { Line 853  sub fold ($$;$) {
853    $string;    $string;
854  }  }
855    
856    =head2 $self->clone ()
857    
858    Returns a copy of Message::Header object.
859    
860    =cut
861    
862    sub clone ($) {
863      my $self = shift;
864      my $clone = new Message::Header;
865      for my $name (%{$self->{option}}) {
866        if (ref $self->{option}->{$name} eq 'HASH') {
867          $clone->{option}->{$name} = {%{$self->{option}->{$name}}};
868        } elsif (ref $self->{option}->{$name} eq 'ARRAY') {
869          $clone->{option}->{$name} = [@{$self->{option}->{$name}}];
870        } else {
871          $clone->{option}->{$name} = $self->{option}->{$name};
872        }
873      }
874      for (@{$self->{field}}) {
875        $clone->add ($_->{name}, scalar $_->{body});
876      }
877      $clone;
878    }
879    
880    =head1 NOTE
881    
882    =head2 C<field-name>
883    
884    The header field name is not case sensitive.  To make the life
885    easier for perl users who wants to avoid quoting before the => operator,
886    you can use '_' as a synonym for '-' in header field names
887    (this behaviour can be suppressed by setting
888    C<translate_underscore> option to C<0> value).
889    
890  =head1 EXAMPLE  =head1 EXAMPLE
891    
892    ## Print field list    ## Print field list
# Line 408  sub fold ($$;$) { Line 894  sub fold ($$;$) {
894    use Message::Header;    use Message::Header;
895    my $header = Message::Header->parse ($header);    my $header = Message::Header->parse ($header);
896        
   ## Next sample is better.  
   #for my $field (@$header) {  
   #  print $field->{name}, "\t=> ", $field->{body}, "\n";  
   #}  
     
897    for my $i (0..$#$header) {    for my $i (0..$#$header) {
898      print $header->field_name ($i), "\t=> ", $header->field_body ($i), "\n";      print $header->field_name ($i), "\t=> ", $header->field_body ($i), "\n";
899    }    }
# Line 435  sub fold ($$;$) { Line 916  sub fold ($$;$) {
916    $header->add ('References' => '<hoge.msgid%foo@foo.example>');    $header->add ('References' => '<hoge.msgid%foo@foo.example>');
917    print $header;    print $header;
918    
919    =head1 ACKNOWLEDGEMENTS
920    
921    Some of codes are taken from other modules such as
922    HTTP::Header, Mail::Header.
923    
924  =head1 LICENSE  =head1 LICENSE
925    
926  Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.  Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
Legend:
Removed from v.1.7  
changed lines
  Added in v.1.19
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24