/[suikacvs]/test/cvs
Suika

Diff of /test/cvs

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

revision 1.9 by wakaba, Mon Mar 25 10:18:35 2002 UTC revision 1.17 by wakaba, Sun Apr 21 04:28:46 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_type    => {':DEFAULT' => 'Message::Field::Unstructured'},    field_format_pattern  => '%s: %s',
62    mail_from     => -1,    #field_type   => {},
63    parse_all     => -1,    format        => 'mail-rfc2822',
64      mail_from     => 0,
65      output_bcc    => 0,
66      parse_all     => 0,
67      sort  => 'none',
68      translate_underscore  => 1,
69      validate      => 1,
70  );  );
71  my @field_type_Structured = qw(cancel-lock  $DEFAULT{field_type} = {
72    importance mime-version path precedence user-agent x-cite          ':DEFAULT'      => 'Message::Field::Unstructured',
73    x-face x-mail-count x-msmail-priority x-priority x-uidl xref);          
74  for (@field_type_Structured)          received        => 'Message::Field::Received',
75            'x-received'    => 'Message::Field::Received',
76            
77            'content-type'  => 'Message::Field::ContentType',
78            'auto-submitted'        => 'Message::Field::ValueParams',
79            'content-disposition'   => 'Message::Field::ValueParams',
80            link    => 'Message::Field::ValueParams',
81            archive => 'Message::Field::ValueParams',
82            'x-face-type'   => 'Message::Field::ValueParams',
83            
84            subject => 'Message::Field::Subject',
85            'x-nsubject'    => 'Message::Field::Subject',
86            
87            'list-software' => 'Message::Field::UA',
88            'user-agent'    => 'Message::Field::UA',
89            server  => 'Message::Field::UA',
90            
91            ## Numeric value
92            'content-length'        => 'Message::Field::Numval',
93            lines   => 'Message::Field::Numval',
94            'max-forwards'  => 'Message::Field::Numval',
95            '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',
102    };
103    for (qw(archive cancel-lock content-features content-md5
104      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  my @field_type_Address = qw(approved bcc cc delivered-to disposition-notification-to          ## Not supported yet, but to be supported...
111    envelope-to  for (qw(abuse-reports-to apparently-to approved approved-by bcc cc complaints-to
112    errors-to fcc from mail-followup-to mail-followup-cc mail-from reply-to resent-bcc    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  for (@field_type_Address)    x-rcpt-to x-sender x-x-sender))
124    {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}
125  my @field_type_Date = 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  for (@field_type_Date)    x-originalarrivaltime x-tcup-date))
128    {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}
129  my @field_type_MsgID = qw(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))
 for (@field_type_MsgID)  
131    {$DEFAULT{field_type}->{$_} = 'Message::Field::MsgID'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::MsgID'}
 for (qw(received x-received))  
   {$DEFAULT{field_type}->{$_} = 'Message::Field::Received'}  
 $DEFAULT{field_type}->{'content-type'} = 'Message::Field::ContentType';  
 $DEFAULT{field_type}->{'content-disposition'} = 'Message::Field::ContentDisposition';  
 for (qw(x-face-type))  
   {$DEFAULT{field_type}->{$_} = 'Message::Field::ValueParams'}  
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 newsgroups    content-transfer-encoding encrypted followup-to keywords
135      list-archive list-digest list-help list-owner
136      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  my @field_type_URI = qw(list-archive list-help list-owner  for (qw(content-alias content-base content-location location referer
141    list-post list-subscribe list-unsubscribe uri url x-home-page x-http_referer    url x-home-page x-http_referer
142    x-info x-pgp-key x-ml-url x-uri x-url x-web);    x-info x-pgp-key x-ml-url x-uri x-url x-web))
143  for (@field_type_URI)    {$DEFAULT{field_type}->{$_} = 'Message::Field::URI'}
144    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}  
145  for (qw(list-id))  ## taken from L<HTTP::Header>
146    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}  # "Good Practice" order of HTTP message headers:
147  for (qw(content-description subject title x-nsubject))  #    - General-Headers
148    {$DEFAULT{field_type}->{$_} = 'Message::Field::Subject'}  #    - Request-Headers
149    #    - Response-Headers
150    #    - Entity-Headers
151    # (From draft-ietf-http-v11-spec-rev-01, Nov 21, 1997)
152    my @header_order = qw(
153      mail-from x-envelope-from relay-version path status
154    
155       cache-control connection date pragma transfer-encoding upgrade trailer via
156    
157       accept accept-charset accept-encoding accept-language
158       authorization expect from host
159       if-modified-since if-match if-none-match if-range if-unmodified-since
160       max-forwards proxy-authorization range referer te user-agent
161    
162       accept-ranges age location proxy-authenticate retry-after server vary
163       warning www-authenticate
164    
165       mime-version
166       allow content-base content-encoding content-language content-length
167       content-location content-md5 content-range content-type
168       etag expires last-modified content-style-type content-script-type
169       link
170    
171  =head2 Message::Header->new ([%option])    xref
172    );
173    my %header_order;
174    
175  Returns new Message::Header instance.  Some options can be  sub _init ($;%) {
176  specified as hash.    my $self = shift;
177      my %options = @_;
178      $self->{field} = [];
179      $self->{option} = \%DEFAULT;
180      my @new_fields = ();
181      for my $name (keys %options) {
182        if (substr ($name, 0, 1) eq '-') {
183          $self->{option}->{substr ($name, 1)} = $options{$name};
184        } else {
185          push @new_fields, ($name => $options{$name});
186        }
187      }
188      $self->add (@new_fields, -parse => $self->{option}->{parse_all})
189        if $#new_fields > -1;
190      
191      my $format = $self->{option}->{format};
192      if ($format =~ /cgi/) {
193        unshift @header_order, qw(content-type location);
194        $self->{option}->{sort} = 'good-practice';
195        $self->{option}->{fold} = 0;
196      } elsif ($format =~ /^http/) {
197        $self->{option}->{sort} = 'good-practice';
198      }
199      
200      # Make alternative representations of @header_order.  This is used
201      # for sorting.
202      my $i = 1;
203      for (@header_order) {
204          $header_order{$_} = $i++ unless $header_order{$_};
205      }
206    }
207    
208    =item Message::Header->new ([%initial-fields/options])
209    
210    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.
212    
213    Example:
214    
215     $hdr = new Message::Headers
216            Date         => 'Thu, 03 Feb 1994 00:00:00 +0000',
217            Content_Type => 'text/html',
218            Content_Location => 'http://www.foo.example/',
219            -format => 'mail-rfc2822'       ## not to be header field
220            ;
221    
222  =cut  =cut
223    
224  sub new ($;%) {  sub new ($;%) {
225    my $class = shift;    my $class = shift;
226    my $self = bless {option => {@_}}, $class;    my $self = bless {}, $class;
227    for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}    $self->_init (@_);
228    $self;    $self;
229  }  }
230    
231  =head2 Message::Header->parse ($header, [%option])  =item Message::Header->parse ($header, [%initial-fields/options])
232    
233  Parses given C<header> and return a new Message::Header  Parses given C<header> and constructs a new C<Message::Headers>
234  object.  Some options can be specified as hash.  object.  You might pass some additional C<field-name>-C<field-body> pairs
235    or/and initial options as parameters to the constructor.
236    
237  =cut  =cut
238    
239  sub parse ($$;%) {  sub parse ($$;%) {
240    my $class = shift;    my $class = shift;
241    my $header = shift;    my $header = shift;
242    my $self = bless {option => {@_}}, $class;    my $self = bless {}, $class;
243    for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}    $self->_init (@_);
244    $header =~ s/\x0D?\x0A$REG{WSP}+/\x20/gos;    ## unfold    $header =~ s/\x0D?\x0A$REG{WSP}/\x20/gos;     ## unfold
245    for my $field (split /\x0D?\x0A/, $header) {    for my $field (split /\x0D?\x0A/, $header) {
246      if ($field =~ /$REG{M_fromline}/) {      if ($field =~ /$REG{M_fromline}/) {
247        my $body = $1;        my $body = $1;
248        $body = $self->_field_body ($body, 'mail-from')        $body = $self->_field_body ($body, 'mail-from')
249          if $self->{option}->{parse_all}>0;          if $self->{option}->{parse_all};
250        push @{$self->{field}}, {name => 'mail-from', body => $body};        push @{$self->{field}}, {name => 'mail-from', body => $body};
251      } elsif ($field =~ /$REG{M_field}/) {      } elsif ($field =~ /$REG{M_field}/) {
252        my ($name, $body) = (lc $1, $2);        my ($name, $body) = (lc $1, $2);
253        $name =~ s/$REG{WSP}+$//;        $name =~ s/$REG{WSP}+$//;
254        $body =~ s/$REG{WSP}+$//;        $body =~ s/$REG{WSP}+$//;
255        $body = $self->_field_body ($body, $name) if $self->{option}->{parse_all}>0;        $body = $self->_field_body ($body, $name) if $self->{option}->{parse_all};
256        push @{$self->{field}}, {name => $name, body => $body};        push @{$self->{field}}, {name => $name, body => $body};
257      }      }
258    }    }
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 ($\@;%) {
273      my $class = shift;
274      my $header = shift;
275      Carp::croak "parse_array: first argument is not an array reference"
276        unless ref $header eq 'ARRAY';
277      my $self = bless {}, $class;
278      $self->_init (@_);
279      while (1) {
280        my $field = shift @$header;
281        while (1) {
282          if ($$header[0] =~ /^$REG{WSP}/) {
283            $field .= shift @$header;
284          } else {last}
285        }
286        $field =~ tr/\x0D\x0A//d;   ## BUG: not safe for bar CR/LF
287        if ($field =~ /$REG{M_fromline}/) {
288          my $body = $1;
289          $body = $self->_field_body ($body, 'mail-from')
290            if $self->{option}->{parse_all};
291          push @{$self->{field}}, {name => 'mail-from', body => $body};
292        } elsif ($field =~ /$REG{M_field}/) {
293          my ($name, $body) = (lc $1, $2);
294          $name =~ s/$REG{WSP}+$//;
295          $body =~ s/$REG{WSP}+$//;
296          $body = $self->_field_body ($body, $name) if $self->{option}->{parse_all};
297          push @{$self->{field}}, {name => $name, body => $body};
298        }
299        last if $#$header < 0;
300      }
301      $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 206  sub _field_body ($$$) { Line 373  sub _field_body ($$$) {
373    unless (ref $body) {    unless (ref $body) {
374      my $type = $self->{option}->{field_type}->{$name}      my $type = $self->{option}->{field_type}->{$name}
375              || $self->{option}->{field_type}->{':DEFAULT'};              || $self->{option}->{field_type}->{':DEFAULT'};
376      eval "require $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}
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},
384             field_name => $name,format => $self->{option}->{format});
385      }      }
386    }    }
387    $body;    $body;
# Line 230  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)  =item $hdr->add ($field-name, $field-body, [$name, $body, ...])
405    
406    Adds some field name/body pairs.  Even if there are
407    one or more fields named given C<$field-name>,
408    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.
412    Four options are available for this method.
413    
414    C<-parse>: Parses and validates C<field-body>, and returns
415    C<field-body> object.  (When multiple C<field-body>s are
416    added, returns only last one.)  (Default: C<defined wantarray>)
417    
418    C<-prepend>: New fields are not appended,
419    but prepended to current fields.  (Default: C<0>)
420    
421    C<-translate-underscore>: Do C<field-name> =~ tr/_/-/.  (Default: C<1>)
422    
423  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.  
424    
425  =cut  =cut
426    
427  sub add ($$;$%) {  sub add ($%) {
428    my $self = shift;    my $self = shift;
429    my ($name, $body) = (lc shift, shift);    my %fields = @_;
430    my %option = @_;    my %option = %{$self->{option}};
431    return 0 if $name =~ /$REG{UNSAFE_field_name}/;    $option{parse} = defined wantarray unless defined $option{parse};
432    $body = $self->_field_body ($body, $name);    for (grep {/^-/} keys %fields) {$option{substr ($_, 1)} = $fields{$_}}
433    if ($option{prepend}) {    my $body;
434      unshift @{$self->{field}}, {name => $name, body => $body};    for (grep {/^[^-]/} keys %fields) {
435    } else {      my $name = lc $_;  $body = $fields{$_};
436      push @{$self->{field}}, {name => $name, body => $body};      $name =~ tr/_/-/ if $option{translate_underscore};
437        Carp::croak "add: $name: invalid field-name"
438          if $option{validate} && $name =~ /$REG{UNSAFE_field_name}/;
439        $body = $self->_field_body ($body, $name) if $option{parse};
440        if ($option{prepend}) {
441          unshift @{$self->{field}}, {name => $name, body => $body};
442        } else {
443          push @{$self->{field}}, {name => $name, body => $body};
444        }
445    }    }
446    $body;    $body if $option{parse};
447  }  }
448    
449  =head2 $self->relace ($field_name, $field_body)  =head2 $self->relace ($field_name, $field_body)
# Line 262  first one is used and the others are not Line 456  first one is used and the others are not
456    
457  =cut  =cut
458    
459  sub replace ($$$) {  sub replace ($%) {
460    my $self = shift;    my $self = shift;
461    my ($name, $body) = (lc shift, shift);    my %params = @_;
462    return 0 if $name =~ /$REG{UNSAFE_field_name}/;    my %option = %{$self->{option}};
463    $body = $self->_field_body ($body, $name);    $option{parse} = defined wantarray unless defined $option{parse};
464      for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
465      my (%new_field);
466      for (grep {/^[^-]/} keys %params) {
467        my $name = lc $_;
468        $name =~ tr/_/-/ if $option{translate_underscore};
469        Carp::croak "replace: $name: invalid field-name"
470          if $option{validate} && $name =~ /$REG{UNSAFE_field_name}/;
471        $params{$_} = $self->_field_body ($params{$_}, $name) if $option{parse};
472        $new_field{$name} = $params{$_};
473      }
474      my $body = (%new_field)[-1];
475    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
476      if ($field->{name} eq $name) {      if (defined $new_field{$field->{name}}) {
477        $field->{body} = $body;        $field->{body} = $new_field {$field->{name}};
478        return $body;        $new_field{$field->{name}} = undef;
479      }      }
480    }    }
481    push @{$self->{field}}, {name => $name, body => $body};    for (keys %new_field) {
482    $body;      push @{$self->{field}}, {name => $_, body => $new_field{$_}};
483      }
484      $body if $option{parse};
485  }  }
486    
487  =head2 $self->delete ($field_name, [$index])  =head2 $self->delete ($field-name, [$name, ...])
488    
489  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.  
490    
491  =cut  =cut
492    
493  sub delete ($$;$) {  sub delete ($@) {
494    my $self = shift;    my $self = shift;
495    my ($name, $index) = (lc shift, shift);    my %delete;  for (@_) {$delete{lc $_} = 1}
   my $i = 0;  
496    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
497      if ($field->{name} eq $name) {      undef $field if $delete{$field->{name}};
       $i++;  
       if ($index == 0 || $i == $index) {  
         undef $field;  
         return $self if $i == $index;  
       }  
     }  
498    }    }
   $self;  
499  }  }
500    
501  =head2 $self->count ([$field_name])  =head2 $self->count ([$field_name])
# Line 326  sub count ($;$) { Line 522  sub count ($;$) {
522    $count;    $count;
523  }  }
524    
525  =head2 $self->stringify ([%option])  =head2 $self->rename ($field-name, $new-name, [$old, $new,...])
526    
527  Returns the C<header> as a string.  Renames C<$field-name> as C<$new-name>.
528    
529  =cut  =cut
530    
531  sub stringify ($;%) {  sub rename ($%) {
532    my $self = shift;    my $self = shift;
533    my %OPT = @_;    my %params = @_;
534    my @ret;    my %option = %{$self->{option}};
535    $OPT{capitalize} ||= $self->{option}->{capitalize};    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
536    $OPT{mail_from} ||= $self->{option}->{mail_from};    my %new_name;
537    push @ret, 'From '.$self->field ('mail-from') if $OPT{mail_from}>0;    for (grep {/^[^-]/} keys %params) {
538        my ($old => $new) = (lc $_ => lc $params{$_});
539        $new =~ tr/_/-/ if $option{translate_underscore};
540        Carp::croak "rename: $new: invalid field-name"
541          if $option{validate} && $new =~ /$REG{UNSAFE_field_name}/;
542        $new_name{$old} = $new;
543      }
544    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
545      my $name = $field->{name};      if (length $new_name{$field->{name}}) {
546      next unless $field->{name};        $field->{name} = $new_name{$field->{name}};
547      next if $OPT{mail_from}<0 && $name eq 'mail-from';      }
548      my $fbody = scalar $field->{body};    }
549      next unless $fbody;    $self if defined wantarray;
550      $fbody =~ s/\x0D([^\x09\x0A\x20])/\x0D\x20$1/g;  }
551      $fbody =~ s/\x0A([^\x09\x20])/\x0A\x20$1/g;  
552      $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $OPT{capitalize};  
553      push @ret, $name.': '.$self->fold ($fbody);  =item $self->scan(\&doit)
554    
555    Apply a subroutine to each header field in turn.  The callback routine is
556    called with two parameters; the name of the field and a single value.
557    If the header has more than one value, then the routine is called once
558    for each value.
559    
560    =cut
561    
562    sub scan ($&) {
563      my ($self, $sub) = @_;
564      my $sort;
565      $sort = \&_header_cmp if $self->{option}->{sort} eq 'good-practice';
566      $sort = {$a cmp $b} if $self->{option}->{sort} eq 'alphabetic';
567      my @field = @{$self->{field}};
568      if (ref $sort) {
569        @field = sort $sort @{$self->{field}};
570      }
571      for my $field (@field) {
572        next if $field->{name} =~ /^_/;
573        &$sub($field->{name} => $field->{body});
574    }    }
   my $ret = join ("\n", @ret);  
   $ret? $ret."\n": "";  
575  }  }
576    
577  =head2 $self->get_option ($option_name)  # Compare function which makes it easy to sort headers in the
578    # recommended "Good Practice" order.
579    ## taken from HTTP::Header
580    sub _header_cmp
581    {
582      my ($na, $nb) = ($a->{name}, $b->{name});
583        # Unknown headers are assign a large value so that they are
584        # sorted last.  This also helps avoiding a warning from -w
585        # about comparing undefined values.
586        $header_order{$na} = 999 unless defined $header_order{$na};
587        $header_order{$nb} = 999 unless defined $header_order{$nb};
588    
589  Returns value of the option.      $header_order{$na} <=> $header_order{$nb} || $na cmp $nb;
590    }
591    
592  =head2 $self->set_option ($option_name, $option_value)  =head2 $self->stringify ([%option])
593    
594  Set new value of the option.  Returns the C<header> as a string.
595    
596  =cut  =cut
597    
598  sub get_option ($$) {  sub stringify ($;%) {
599    my $self = shift;    my $self = shift;
600    my ($name) = @_;    my %params = @_;
601    $self->{option}->{$name};    my %option = %{$self->{option}};
602      for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
603      my @ret;
604      if ($option{mail_from}) {
605        my $fromline = $self->field ('mail-from');
606        push @ret, 'From '.$fromline if $fromline;
607      }
608      $self->scan (sub {
609        my ($name, $body) = (@_);
610        return unless length $name;
611        return if $option{mail_from} && $name eq 'mail-from';
612        return if !$option{output_bcc} && ($name eq 'bcc' || $name eq 'resent-bcc');
613        my $fbody;
614        if (ref $body) {
615          $fbody = $body->stringify (-format => $option{format});
616        } else {
617          $fbody = $body;
618        }
619        return unless length $fbody;
620        $fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;
621        $fbody =~ s/\x0A(?=[^\x09\x20])/\x0A\x20/g;
622        $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $option{capitalize};
623        $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);
627      $ret? $ret."\n": '';
628  }  }
629  sub set_option ($$$) {  *as_string = \&stringify;
630    
631    =head2 $self->option ($option_name, [$option_value])
632    
633    Set/gets new value of the option.
634    
635    =cut
636    
637    sub option ($@) {
638    my $self = shift;    my $self = shift;
639    my ($name, $value) = @_;    if (@_ == 1) {
640    $self->{option}->{$name} = $value;      return $self->{option}->{ shift (@_) };
641    $self;    }
642      while (my ($name, $value) = splice (@_, 0, 2)) {
643        $name =~ s/^-//;
644        $self->{option}->{$name} = $value;
645        if ($name eq 'format') {
646          for my $f (@{$self->{field}}) {
647            if (ref $f->{body}) {
648              $f->{body}->option (-format => $value);
649            }
650          }
651        }
652      }
653  }  }
654    
655  sub field_type ($$;$) {  sub field_type ($$;$) {
# Line 397  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};
# Line 415  sub fold ($$;$) { Line 691  sub fold ($$;$) {
691       # next split a whitespace       # next split a whitespace
692       # 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
693       my $x = "";       my $x = "";
694       $x .= "$1\n    "       $x .= "$1\n "
695         while($string =~ s/^$REG{WSP}*(         while($string =~ s/^$REG{WSP}*(
696                            [^"]{$min,$max}?[\,\;]                            [^"]{$min,$max}?[\,\;]
697                            |[^"]{1,$max}$REG{WSP}                            |[^"]{1,$max}$REG{WSP}
# Line 431  sub fold ($$;$) { Line 707  sub fold ($$;$) {
707    $string;    $string;
708  }  }
709    
710    =head2 $self->clone ()
711    
712    Returns a copy of Message::Header object.
713    
714    =cut
715    
716    sub clone ($) {
717      my $self = shift;
718      my $clone = new Message::Header;
719      for my $name (%{$self->{option}}) {
720        if (ref $self->{option}->{$name} eq 'HASH') {
721          $clone->{option}->{$name} = {%{$self->{option}->{$name}}};
722        } elsif (ref $self->{option}->{$name} eq 'ARRAY') {
723          $clone->{option}->{$name} = [@{$self->{option}->{$name}}];
724        } else {
725          $clone->{option}->{$name} = $self->{option}->{$name};
726        }
727      }
728      for (@{$self->{field}}) {
729        $clone->add ($_->{name}, scalar $_->{body});
730      }
731      $clone;
732    }
733    
734    =head1 NOTE
735    
736    =head2 C<field-name>
737    
738    The header field name is not case sensitive.  To make the life
739    easier for perl users who wants to avoid quoting before the => operator,
740    you can use '_' as a synonym for '-' in header field names
741    (this behaviour can be suppressed by setting
742    C<translate_underscore> option to C<0> value).
743    
744  =head1 EXAMPLE  =head1 EXAMPLE
745    
746    ## Print field list    ## Print field list
# Line 438  sub fold ($$;$) { Line 748  sub fold ($$;$) {
748    use Message::Header;    use Message::Header;
749    my $header = Message::Header->parse ($header);    my $header = Message::Header->parse ($header);
750        
   ## Next sample is better.  
   #for my $field (@$header) {  
   #  print $field->{name}, "\t=> ", $field->{body}, "\n";  
   #}  
     
751    for my $i (0..$#$header) {    for my $i (0..$#$header) {
752      print $header->field_name ($i), "\t=> ", $header->field_body ($i), "\n";      print $header->field_name ($i), "\t=> ", $header->field_body ($i), "\n";
753    }    }
# Line 465  sub fold ($$;$) { Line 770  sub fold ($$;$) {
770    $header->add ('References' => '<hoge.msgid%foo@foo.example>');    $header->add ('References' => '<hoge.msgid%foo@foo.example>');
771    print $header;    print $header;
772    
773    =head1 ACKNOWLEDGEMENTS
774    
775    Some of codes are taken from other modules such as
776    HTTP::Header, Mail::Header.
777    
778  =head1 LICENSE  =head1 LICENSE
779    
780  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.9  
changed lines
  Added in v.1.17
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24