/[suikacvs]/test/cvs
Suika

Diff of /test/cvs

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

revision 1.10 by wakaba, Tue Mar 26 05:41:16 2002 UTC revision 1.15 by wakaba, Fri Apr 5 14:56:26 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    ## Initialize
55    my %DEFAULT = (
56    capitalize    => 1,    capitalize    => 1,
57    fold_length   => 70,    fold_length   => 70,
58    field_type    => {':DEFAULT' => 'Message::Field::Unstructured'},    #field_type   => {},
59    mail_from     => -1,    format        => 'mail-rfc2822',
60    output_bcc    => -1,    mail_from     => 0,
61    parse_all     => -1,    output_bcc    => 0,
62      parse_all     => 0,
63      sort  => 'none',
64      translate_underscore  => 1,
65      validate      => 1,
66  );  );
67  my @field_type_Structured = qw(cancel-lock  $DEFAULT{field_type} = {
68    importance mime-version path precedence x-cite          ':DEFAULT'      => 'Message::Field::Unstructured',
69    x-face x-mail-count x-msmail-priority x-priority x-uidl xref);          
70  for (@field_type_Structured)          received        => 'Message::Field::Received',
71            'x-received'    => 'Message::Field::Received',
72            
73            'content-type'  => 'Message::Field::ContentType',
74            'content-disposition'   => 'Message::Field::ContentDisposition',
75            'auto-submitted'        => 'Message::Field::ValueParams',
76            link    => 'Message::Field::ValueParams',
77            archive => 'Message::Field::ValueParams',
78            'x-face-type'   => 'Message::Field::ValueParams',
79            
80            subject => 'Message::Field::Subject',
81            'x-nsubject'    => 'Message::Field::Subject',
82            
83            'list-software' => 'Message::Field::UA',
84            'user-agent'    => 'Message::Field::UA',
85            server  => 'Message::Field::UA',
86            
87            ## Numeric value
88            'content-length'        => 'Message::Field::Numval',
89            lines   => 'Message::Field::Numval',
90            'max-forwards'  => 'Message::Field::Numval',
91            'mime-version'  => 'Message::Field::Numval',
92            'x-jsmail-priority'     => 'Message::Field::Numval',
93            'x-priority'    => 'Message::Field::Numval',
94            
95            path    => 'Message::Field::Path',
96    };
97    for (qw(cancel-lock importance   precedence list-id
98      x-face x-mail-count x-msmail-priority x-priority xref))
99    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
100  my @field_type_Address = qw(approved bcc cc delivered-to disposition-notification-to  for (qw(approved bcc cc complaints-to
101    envelope-to    delivered-to disposition-notification-to envelope-to
102    errors-to fcc from mail-followup-to mail-followup-cc mail-from reply-to resent-bcc    errors-to fcc from mail-followup-to mail-followup-cc
103      mail-reply-to
104      notice-requested-upon-delivery-to reply-to resent-bcc
105    resent-cc resent-to resent-from resent-sender return-path    resent-cc resent-to resent-from resent-sender return-path
106    return-receipt-to sender to x-approved x-beenthere    return-receipt-to sender to x-approved x-beenthere
107    x-complaints-to x-envelope-from x-envelope-sender    x-complaints-to x-envelope-from x-envelope-sender
108    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))
 for (@field_type_Address)  
109    {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}
110  my @field_type_Date = qw(date date-received delivery-date expires  for (qw(date date-received delivery-date expires
111    expire-date nntp-posting-date posted reply-by resent-date x-tcup-date);    expire-date nntp-posting-date posted reply-by resent-date x-tcup-date))
 for (@field_type_Date)  
112    {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}
113  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
114    references resent-message-id see-also supersedes);    references resent-message-id see-also supersedes))
 for (@field_type_MsgID)  
115    {$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'}  
116  for (qw(accept accept-charset accept-encoding accept-language  for (qw(accept accept-charset accept-encoding accept-language
117    content-language    content-language
118    content-transfer-encoding encrypted followup-to keywords newsgroups    content-transfer-encoding encrypted followup-to keywords
119      list-archive list-digest list-help list-owner
120      list-post list-subscribe list-unsubscribe list-url uri newsgroups
121    x-brother x-daughter x-respect x-moe x-syster x-wife))    x-brother x-daughter x-respect x-moe x-syster x-wife))
122    {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}
123  my @field_type_URI = qw(list-archive list-help list-owner  for (qw(content-alias content-base content-location location referer
124    list-post list-subscribe list-unsubscribe uri url x-home-page x-http_referer    url x-home-page x-http_referer
125    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))
126  for (@field_type_URI)    {$DEFAULT{field_type}->{$_} = 'Message::Field::URI'}
127    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}  
128  for (qw(list-id))  ## taken from L<HTTP::Header>
129    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}  # "Good Practice" order of HTTP message headers:
130  for (qw(subject title x-nsubject))  #    - General-Headers
131    {$DEFAULT{field_type}->{$_} = 'Message::Field::Subject'}  #    - Request-Headers
132  for (qw(list-software user-agent server))  #    - Response-Headers
133    {$DEFAULT{field_type}->{$_} = 'Message::Field::UA'}  #    - Entity-Headers
134    # (From draft-ietf-http-v11-spec-rev-01, Nov 21, 1997)
135    my @header_order = qw(
136      mail-from x-envelope-from relay-version path status
137    
138       cache-control connection date pragma transfer-encoding upgrade trailer via
139    
140       accept accept-charset accept-encoding accept-language
141       authorization expect from host
142       if-modified-since if-match if-none-match if-range if-unmodified-since
143       max-forwards proxy-authorization range referer te user-agent
144    
145       accept-ranges age location proxy-authenticate retry-after server vary
146       warning www-authenticate
147    
148       mime-version
149       allow content-base content-encoding content-language content-length
150       content-location content-md5 content-range content-type
151       etag expires last-modified content-style-type content-script-type
152       link
153    
154  =head2 Message::Header->new ([%option])    xref
155    );
156    my %header_order;
157    
158  Returns new Message::Header instance.  Some options can be  sub _init ($;%) {
159  specified as hash.    my $self = shift;
160      my %options = @_;
161      $self->{field} = [];
162      $self->{option} = \%DEFAULT;
163      my @new_fields = ();
164      for my $name (keys %options) {
165        if (substr ($name, 0, 1) eq '-') {
166          $self->{option}->{substr ($name, 1)} = $options{$name};
167        } else {
168          push @new_fields, ($name => $options{$name});
169        }
170      }
171      $self->add (@new_fields, -parse => $self->{option}->{parse_all})
172        if $#new_fields > -1;
173      
174      my $format = $self->{option}->{format};
175      if ($format =~ /^cgi/) {
176        unshift @header_order, qw(content-type location);
177        $self->{option}->{sort} = 'good-practice';
178      } elsif ($format =~ /^http/) {
179        $self->{option}->{sort} = 'good-practice';
180      }
181      
182      # Make alternative representations of @header_order.  This is used
183      # for sorting.
184      my $i = 1;
185      for (@header_order) {
186          $header_order{$_} = $i++ unless $header_order{$_};
187      }
188    }
189    
190    =item Message::Header->new ([%initial-fields/options])
191    
192    Constructs a new C<Message::Headers> object.  You might pass some initial
193    C<field-name>-C<field-body> pairs and/or options as parameters to the constructor.
194    
195    Example:
196    
197     $hdr = new Message::Headers
198            Date         => 'Thu, 03 Feb 1994 00:00:00 +0000',
199            Content_Type => 'text/html',
200            Content_Location => 'http://www.foo.example/',
201            -format => 'mail-rfc2822'       ## not to be header field
202            ;
203    
204  =cut  =cut
205    
206  sub new ($;%) {  sub new ($;%) {
207    my $class = shift;    my $class = shift;
208    my $self = bless {option => {@_}}, $class;    my $self = bless {}, $class;
209    for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}    $self->_init (@_);
210    $self;    $self;
211  }  }
212    
213  =head2 Message::Header->parse ($header, [%option])  =item Message::Header->parse ($header, [%initial-fields/options])
214    
215  Parses given C<header> and return a new Message::Header  Parses given C<header> and constructs a new C<Message::Headers>
216  object.  Some options can be specified as hash.  object.  You might pass some additional C<field-name>-C<field-body> pairs
217    or/and initial options as parameters to the constructor.
218    
219  =cut  =cut
220    
221  sub parse ($$;%) {  sub parse ($$;%) {
222    my $class = shift;    my $class = shift;
223    my $header = shift;    my $header = shift;
224    my $self = bless {option => {@_}}, $class;    my $self = bless {}, $class;
225    for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}    $self->_init (@_);
226    $header =~ s/\x0D?\x0A$REG{WSP}+/\x20/gos;    ## unfold    $header =~ s/\x0D?\x0A$REG{WSP}/\x20/gos;     ## unfold
227    for my $field (split /\x0D?\x0A/, $header) {    for my $field (split /\x0D?\x0A/, $header) {
228      if ($field =~ /$REG{M_fromline}/) {      if ($field =~ /$REG{M_fromline}/) {
229        my $body = $1;        my $body = $1;
230        $body = $self->_field_body ($body, 'mail-from')        $body = $self->_field_body ($body, 'mail-from')
231          if $self->{option}->{parse_all}>0;          if $self->{option}->{parse_all};
232        push @{$self->{field}}, {name => 'mail-from', body => $body};        push @{$self->{field}}, {name => 'mail-from', body => $body};
233      } elsif ($field =~ /$REG{M_field}/) {      } elsif ($field =~ /$REG{M_field}/) {
234        my ($name, $body) = (lc $1, $2);        my ($name, $body) = (lc $1, $2);
235        $name =~ s/$REG{WSP}+$//;        $name =~ s/$REG{WSP}+$//;
236        $body =~ s/$REG{WSP}+$//;        $body =~ s/$REG{WSP}+$//;
237        $body = $self->_field_body ($body, $name) if $self->{option}->{parse_all}>0;        $body = $self->_field_body ($body, $name) if $self->{option}->{parse_all};
238        push @{$self->{field}}, {name => $name, body => $body};        push @{$self->{field}}, {name => $name, body => $body};
239      }      }
240    }    }
241    $self;    $self;
242  }  }
243    
244    =item Message::Header->parse_array (\@header, [%initial-fields/options])
245    
246    Parses given C<header> and constructs a new C<Message::Headers>
247    object.  Same as C<Message::Header-E<lt>parse> but this method
248    is given an array reference.  You might pass some additional
249    C<field-name>-C<field-body> pairs or/and initial options
250    as parameters to the constructor.
251    
252    =cut
253    
254    sub parse_array ($\@;%) {
255      my $class = shift;
256      my $header = shift;
257      Carp::croak "parse_array: first argument is not an array reference"
258        unless ref $header eq 'ARRAY';
259      my $self = bless {}, $class;
260      $self->_init (@_);
261      while (1) {
262        my $field = shift @$header;
263        while (1) {
264          if ($$header[0] =~ /^$REG{WSP}/) {
265            $field .= shift @$header;
266          } else {last}
267        }
268        $field =~ tr/\x0D\x0A//d;   ## BUG: not safe for bar CR/LF
269        if ($field =~ /$REG{M_fromline}/) {
270          my $body = $1;
271          $body = $self->_field_body ($body, 'mail-from')
272            if $self->{option}->{parse_all};
273          push @{$self->{field}}, {name => 'mail-from', body => $body};
274        } elsif ($field =~ /$REG{M_field}/) {
275          my ($name, $body) = (lc $1, $2);
276          $name =~ s/$REG{WSP}+$//;
277          $body =~ s/$REG{WSP}+$//;
278          $body = $self->_field_body ($body, $name) if $self->{option}->{parse_all};
279          push @{$self->{field}}, {name => $name, body => $body};
280        }
281        last if $#$header < 0;
282      }
283      $self;
284    }
285    
286    =back
287    
288    =head1 METHODS
289    
290  =head2 $self->field ($field_name)  =head2 $self->field ($field_name)
291    
292  Returns C<field-body> of given C<field-name>.  Returns C<field-body> of given C<field-name>.
# Line 209  sub _field_body ($$$) { Line 355  sub _field_body ($$$) {
355    unless (ref $body) {    unless (ref $body) {
356      my $type = $self->{option}->{field_type}->{$name}      my $type = $self->{option}->{field_type}->{$name}
357              || $self->{option}->{field_type}->{':DEFAULT'};              || $self->{option}->{field_type}->{':DEFAULT'};
358      eval "require $type";      eval "require $type" or Carp::croak ("_field_body: $type: $@");
359      unless ($body) {      unless ($body) {
360        $body = $type->new (field_name => $name);        $body = $type->new (-field_name => $name,
361            -format => $self->{option}->{format});
362      } else {      } else {
363        $body = $type->parse ($body, field_name => $name);        $body = $type->parse ($body, -field_name => $name,
364            -format => $self->{option}->{format});
365      }      }
366    }    }
367    $body;    $body;
# Line 233  sub field_name_list ($) { Line 381  sub field_name_list ($) {
381    map {$_->{name}} @{$self->{field}};    map {$_->{name}} @{$self->{field}};
382  }  }
383    
384  =head2 $self->add ($field_name, $field_body)  =head2 $self->add ($field-name, $field-body, [$name, $body, ...])
385    
386  Adds an new C<field>.  It is not checked whether  Adds an new C<field>.  It is not checked whether
387  the field which named $field_body is already exist or not.  the field which named $field_body is already exist or not.
388  If you don't want duplicated C<field>s, use C<replace> method.  If you don't want duplicated C<field>s, use C<replace> method.
389    
390    Instead of field name-body pair, you might pass some options.
391    Four options are available for this method.
392    
393    C<-parse>: Parses and validates C<field-body>, and returns
394    C<field-body> object.  (When multiple C<field-body>s are
395    added, returns only last one.)  (Default: C<defined wantarray>)
396    
397    C<-prepend>: New fields are not appended,
398    but prepended to current fields.  (Default: C<0>)
399    
400    C<-translate-underscore>: Do C<field-name> =~ tr/_/-/.  (Default: C<1>)
401    
402    C<-validate>: Checks whether C<field-name> is valid or not.
403    
404  =cut  =cut
405    
406  sub add ($$;$%) {  sub add ($%) {
407    my $self = shift;    my $self = shift;
408    my ($name, $body) = (lc shift, shift);    my %fields = @_;
409    my %option = @_;    my %option = %{$self->{option}};
410    return 0 if $name =~ /$REG{UNSAFE_field_name}/;    $option{parse} = defined wantarray unless defined $option{parse};
411    $body = $self->_field_body ($body, $name);    for (grep {/^-/} keys %fields) {$option{substr ($_, 1)} = $fields{$_}}
412    if ($option{prepend}) {    my $body;
413      unshift @{$self->{field}}, {name => $name, body => $body};    for (grep {/^[^-]/} keys %fields) {
414    } else {      my $name = lc $_;  $body = $fields{$_};
415      push @{$self->{field}}, {name => $name, body => $body};      $name =~ tr/_/-/ if $option{translate_underscore};
416        Carp::croak "add: $name: invalid field-name"
417          if $option{validate} && $name =~ /$REG{UNSAFE_field_name}/;
418        $body = $self->_field_body ($body, $name) if $option{parse};
419        if ($option{prepend}) {
420          unshift @{$self->{field}}, {name => $name, body => $body};
421        } else {
422          push @{$self->{field}}, {name => $name, body => $body};
423        }
424    }    }
425    $body;    $body if $option{parse};
426  }  }
427    
428  =head2 $self->relace ($field_name, $field_body)  =head2 $self->relace ($field_name, $field_body)
# Line 265  first one is used and the others are not Line 435  first one is used and the others are not
435    
436  =cut  =cut
437    
438  sub replace ($$$) {  sub replace ($%) {
439    my $self = shift;    my $self = shift;
440    my ($name, $body) = (lc shift, shift);    my %params = @_;
441    return 0 if $name =~ /$REG{UNSAFE_field_name}/;    my %option = %{$self->{option}};
442    $body = $self->_field_body ($body, $name);    $option{parse} = defined wantarray unless defined $option{parse};
443      for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
444      my (%new_field);
445      for (grep {/^[^-]/} keys %params) {
446        my $name = lc $_;
447        $name =~ tr/_/-/ if $option{translate_underscore};
448        Carp::croak "replace: $name: invalid field-name"
449          if $option{validate} && $name =~ /$REG{UNSAFE_field_name}/;
450        $params{$_} = $self->_field_body ($params{$_}, $name) if $option{parse};
451        $new_field{$name} = $params{$_};
452      }
453      my $body = (%new_field)[-1];
454    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
455      if ($field->{name} eq $name) {      if (defined $new_field{$field->{name}}) {
456        $field->{body} = $body;        $field->{body} = $new_field {$field->{name}};
457        return $body;        $new_field{$field->{name}} = undef;
458      }      }
459    }    }
460    push @{$self->{field}}, {name => $name, body => $body};    for (keys %new_field) {
461    $body;      push @{$self->{field}}, {name => $_, body => $new_field{$_}};
462      }
463      $body if $option{parse};
464  }  }
465    
466  =head2 $self->delete ($field_name, [$index])  =head2 $self->delete ($field-name, [$name, ...])
467    
468  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.  
469    
470  =cut  =cut
471    
472  sub delete ($$;$) {  sub delete ($@) {
473    my $self = shift;    my $self = shift;
474    my ($name, $index) = (lc shift, shift);    my %delete;
475    my $i = 0;    for (@_) {$delete{lc $_} = 1}
476    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
477      if ($field->{name} eq $name) {      undef $field if $delete{$field->{name}};
       $i++;  
       if ($index == 0 || $i == $index) {  
         undef $field;  
         return $self if $i == $index;  
       }  
     }  
478    }    }
   $self;  
479  }  }
480    
481  =head2 $self->count ([$field_name])  =head2 $self->count ([$field_name])
# Line 329  sub count ($;$) { Line 502  sub count ($;$) {
502    $count;    $count;
503  }  }
504    
505  =head2 $self->stringify ([%option])  =head2 $self->rename ($field-name, $new-name, [$old, $new,...])
506    
507  Returns the C<header> as a string.  Renames C<$field-name> as C<$new-name>.
508    
509  =cut  =cut
510    
511  sub stringify ($;%) {  sub rename ($%) {
512    my $self = shift;    my $self = shift;
513    my %OPT = @_;    my %params = @_;
514    my @ret;    my %option = %{$self->{option}};
515    $OPT{capitalize} ||= $self->{option}->{capitalize};    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
516    $OPT{mail_from} ||= $self->{option}->{mail_from};    my %new_name;
517    $OPT{output_bcc} ||= $self->{option}->{output_bcc};    for (grep {/^[^-]/} keys %params) {
518    push @ret, 'From '.$self->field ('mail-from') if $OPT{mail_from}>0;      my ($old => $new) = (lc $_ => lc $params{$_});
519        $new =~ tr/_/-/ if $option{translate_underscore};
520        Carp::croak "rename: $new: invalid field-name"
521          if $option{validate} && $new =~ /$REG{UNSAFE_field_name}/;
522        $new_name{$old} = $new;
523      }
524    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
525      my $name = $field->{name};      if (length $new_name{$field->{name}}) {
526      next unless $name;        $field->{name} = $new_name{$field->{name}};
527      next if $OPT{mail_from}<0 && $name eq 'mail-from';      }
528      next if $OPT{output_bcc}<0 && ($name eq 'bcc' || $name eq 'resent-bcc');    }
529      my $fbody = scalar $field->{body};    $self if defined wantarray;
530      next unless $fbody;  }
531      $fbody =~ s/\x0D([^\x09\x0A\x20])/\x0D\x20$1/g;  
532      $fbody =~ s/\x0A([^\x09\x20])/\x0A\x20$1/g;  
533      $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $OPT{capitalize};  =item $self->scan(\&doit)
534      push @ret, $name.': '.$self->fold ($fbody);  
535    Apply a subroutine to each header field in turn.  The callback routine is
536    called with two parameters; the name of the field and a single value.
537    If the header has more than one value, then the routine is called once
538    for each value.
539    
540    =cut
541    
542    sub scan ($&) {
543      my ($self, $sub) = @_;
544      my $sort;
545      $sort = \&_header_cmp if $self->{option}->{sort} eq 'good-practice';
546      $sort = {$a cmp $b} if $self->{option}->{sort} eq 'alphabetic';
547      my @field = @{$self->{field}};
548      if (ref $sort) {
549        @field = sort $sort @{$self->{field}};
550      }
551      for my $field (@field) {
552        next if $field->{name} =~ /^_/;
553        &$sub($field->{name} => $field->{body});
554    }    }
   my $ret = join ("\n", @ret);  
   $ret? $ret."\n": "";  
555  }  }
556    
557  =head2 $self->get_option ($option_name)  # Compare function which makes it easy to sort headers in the
558    # recommended "Good Practice" order.
559    ## taken from HTTP::Header
560    sub _header_cmp
561    {
562      my ($na, $nb) = ($a->{name}, $b->{name});
563        # Unknown headers are assign a large value so that they are
564        # sorted last.  This also helps avoiding a warning from -w
565        # about comparing undefined values.
566        $header_order{$na} = 999 unless defined $header_order{$na};
567        $header_order{$nb} = 999 unless defined $header_order{$nb};
568    
569  Returns value of the option.      $header_order{$na} <=> $header_order{$nb} || $na cmp $nb;
570    }
571    
572  =head2 $self->set_option ($option_name, $option_value)  =head2 $self->stringify ([%option])
573    
574  Set new value of the option.  Returns the C<header> as a string.
575    
576  =cut  =cut
577    
578  sub get_option ($$) {  sub stringify ($;%) {
579    my $self = shift;    my $self = shift;
580    my ($name) = @_;    my %params = @_;
581    $self->{option}->{$name};    my %option = %{$self->{option}};
582      for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
583      my @ret;
584      if ($option{mail_from}) {
585        my $fromline = $self->field ('mail-from');
586        push @ret, 'From '.$fromline if $fromline;
587      }
588      $self->scan (sub {
589        my ($name, $body) = (@_);
590        return unless length $name;
591        return if $option{mail_from} && $name eq 'mail-from';
592        return if !$option{output_bcc} && ($name eq 'bcc' || $name eq 'resent-bcc');
593        my $fbody;
594        if (ref $body) {
595          $fbody = $body->stringify (-format => $option{format});
596        } else {
597          $fbody = $body;
598        }
599        return unless length $fbody;
600        $fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;
601        $fbody =~ s/\x0A(?=[^\x09\x20])/\x0A\x20/g;
602        $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $option{capitalize};
603        push @ret, $name.': '.$self->fold ($fbody);
604      });
605      my $ret = join ("\n", @ret);
606      $ret? $ret."\n": '';
607  }  }
608  sub set_option ($$$) {  *as_string = \&stringify;
609    
610    =head2 $self->option ($option_name, [$option_value])
611    
612    Set/gets new value of the option.
613    
614    =cut
615    
616    sub option ($@) {
617    my $self = shift;    my $self = shift;
618    my ($name, $value) = @_;    if (@_ == 1) {
619    $self->{option}->{$name} = $value;      return $self->{option}->{ shift (@_) };
620    $self;    }
621      while (my ($name, $value) = splice (@_, 0, 2)) {
622        $name =~ s/^-//;
623        $self->{option}->{$name} = $value;
624        if ($name eq 'format') {
625          for my $f (@{$self->{field}}) {
626            if (ref $f->{body}) {
627              $f->{body}->option (-format => $value);
628            }
629          }
630        }
631      }
632  }  }
633    
634  sub field_type ($$;$) {  sub field_type ($$;$) {
# Line 420  sub fold ($$;$) { Line 670  sub fold ($$;$) {
670       # next split a whitespace       # next split a whitespace
671       # 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
672       my $x = "";       my $x = "";
673       $x .= "$1\n    "       $x .= "$1\n "
674         while($string =~ s/^$REG{WSP}*(         while($string =~ s/^$REG{WSP}*(
675                            [^"]{$min,$max}?[\,\;]                            [^"]{$min,$max}?[\,\;]
676                            |[^"]{1,$max}$REG{WSP}                            |[^"]{1,$max}$REG{WSP}
# Line 436  sub fold ($$;$) { Line 686  sub fold ($$;$) {
686    $string;    $string;
687  }  }
688    
689    =head2 $self->clone ()
690    
691    Returns a copy of Message::Header object.
692    
693    =cut
694    
695    sub clone ($) {
696      my $self = shift;
697      my $clone = new Message::Header;
698      for my $name (%{$self->{option}}) {
699        if (ref $self->{option}->{$name} eq 'HASH') {
700          $clone->{option}->{$name} = {%{$self->{option}->{$name}}};
701        } elsif (ref $self->{option}->{$name} eq 'ARRAY') {
702          $clone->{option}->{$name} = [@{$self->{option}->{$name}}];
703        } else {
704          $clone->{option}->{$name} = $self->{option}->{$name};
705        }
706      }
707      for (@{$self->{field}}) {
708        $clone->add ($_->{name}, scalar $_->{body});
709      }
710      $clone;
711    }
712    
713    =head1 NOTE
714    
715    =head2 C<field-name>
716    
717    The header field name is not case sensitive.  To make the life
718    easier for perl users who wants to avoid quoting before the => operator,
719    you can use '_' as a synonym for '-' in header field names
720    (this behaviour can be suppressed by setting
721    C<translate_underscore> option to C<0> value).
722    
723  =head1 EXAMPLE  =head1 EXAMPLE
724    
725    ## Print field list    ## Print field list
# Line 443  sub fold ($$;$) { Line 727  sub fold ($$;$) {
727    use Message::Header;    use Message::Header;
728    my $header = Message::Header->parse ($header);    my $header = Message::Header->parse ($header);
729        
   ## Next sample is better.  
   #for my $field (@$header) {  
   #  print $field->{name}, "\t=> ", $field->{body}, "\n";  
   #}  
     
730    for my $i (0..$#$header) {    for my $i (0..$#$header) {
731      print $header->field_name ($i), "\t=> ", $header->field_body ($i), "\n";      print $header->field_name ($i), "\t=> ", $header->field_body ($i), "\n";
732    }    }
# Line 470  sub fold ($$;$) { Line 749  sub fold ($$;$) {
749    $header->add ('References' => '<hoge.msgid%foo@foo.example>');    $header->add ('References' => '<hoge.msgid%foo@foo.example>');
750    print $header;    print $header;
751    
752    =head1 ACKNOWLEDGEMENTS
753    
754    Some of codes are taken from other modules such as
755    HTTP::Header, Mail::Header.
756    
757  =head1 LICENSE  =head1 LICENSE
758    
759  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.10  
changed lines
  Added in v.1.15
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24