/[suikacvs]/test/cvs
Suika

Diff of /test/cvs

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

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