/[suikacvs]/test/cvs
Suika

Diff of /test/cvs

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

revision 1.11 by wakaba, Tue Mar 26 15:19:53 2002 UTC revision 1.14 by wakaba, Wed Apr 3 13:31: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    
# Line 44  when C<stringify>.  (Default = 0) Line 44  when C<stringify>.  (Default = 0)
44    
45  =cut  =cut
46    
47  %DEFAULT = (  my %DEFAULT = (
48    capitalize    => 1,    capitalize    => 1,
49    fold_length   => 70,    fold_length   => 70,
50    field_type    => {':DEFAULT' => 'Message::Field::Unstructured'},    #field_type   => {},
51    mail_from     => -1,    format        => 'mail-rfc2822',
52    output_bcc    => -1,    mail_from     => 0,
53    parse_all     => -1,    output_bcc    => 0,
54      parse_all     => 0,
55      sort  => 'none',
56      translate_underscore  => 1,
57      validate      => 1,
58  );  );
59  my @field_type_Structured = qw(cancel-lock  $DEFAULT{field_type} = {
60    importance mime-version path precedence x-cite          ':DEFAULT'      => 'Message::Field::Unstructured',
61    x-face x-mail-count x-msmail-priority x-priority x-uidl xref);          
62  for (@field_type_Structured)          received        => 'Message::Field::Received',
63            'x-received'    => 'Message::Field::Received',
64            
65            'content-type'  => 'Message::Field::ContentType',
66            'content-disposition'   => 'Message::Field::ContentDisposition',
67            link    => 'Message::Field::ValueParams',
68            archive => 'Message::Field::ValueParams',
69            'x-face-type'   => 'Message::Field::ValueParams',
70            
71            subject => 'Message::Field::Subject',
72            'x-nsubject'    => 'Message::Field::Subject',
73            
74            'list-software' => 'Message::Field::UA',
75            'user-agent'    => 'Message::Field::UA',
76            server  => 'Message::Field::UA',
77            
78            'content-length'        => 'Message::Field::Numval',
79            lines   => 'Message::Field::Numval',
80            'max-forwards'  => 'Message::Field::Numval',
81            'mime-version'  => 'Message::Field::Numval',
82            
83            path    => 'Message::Field::Path',
84    };
85    for (qw(cancel-lock importance   precedence list-id
86      x-face x-mail-count x-msmail-priority x-priority xref))
87    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
88  my @field_type_Address = qw(approved bcc cc delivered-to disposition-notification-to  for (qw(approved bcc cc delivered-to disposition-notification-to envelope-to
89    envelope-to    errors-to fcc from mail-followup-to mail-followup-cc reply-to resent-bcc
   errors-to fcc from mail-followup-to mail-followup-cc mail-from reply-to resent-bcc  
90    resent-cc resent-to resent-from resent-sender return-path    resent-cc resent-to resent-from resent-sender return-path
91    return-receipt-to sender to x-approved x-beenthere    return-receipt-to sender to x-approved x-beenthere
92    x-complaints-to x-envelope-from x-envelope-sender    x-complaints-to x-envelope-from x-envelope-sender
93    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)  
94    {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}
95  my @field_type_Date = qw(date date-received delivery-date expires  for (qw(date date-received delivery-date expires
96    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)  
97    {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}
98  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
99    references resent-message-id see-also supersedes);    references resent-message-id see-also supersedes))
 for (@field_type_MsgID)  
100    {$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'}  
101  for (qw(accept accept-charset accept-encoding accept-language  for (qw(accept accept-charset accept-encoding accept-language
102    content-language    content-language
103    content-transfer-encoding encrypted followup-to keywords newsgroups    content-transfer-encoding encrypted followup-to keywords
104      list-archive list-digest list-help list-owner
105      list-post list-subscribe list-unsubscribe list-url uri newsgroups
106    x-brother x-daughter x-respect x-moe x-syster x-wife))    x-brother x-daughter x-respect x-moe x-syster x-wife))
107    {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}
108  my @field_type_URI = qw(list-archive list-help list-owner  for (qw(content-alias content-base content-location location referer
109    list-post list-subscribe list-unsubscribe uri url x-home-page x-http_referer    url x-home-page x-http_referer
110    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))
111  for (@field_type_URI)    {$DEFAULT{field_type}->{$_} = 'Message::Field::URI'}
112    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}  
113  for (qw(list-id))  ## taken from L<HTTP::Header>
114    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}  # "Good Practice" order of HTTP message headers:
115  for (qw(subject title x-nsubject))  #    - General-Headers
116    {$DEFAULT{field_type}->{$_} = 'Message::Field::Subject'}  #    - Request-Headers
117  for (qw(list-software user-agent server))  #    - Response-Headers
118    {$DEFAULT{field_type}->{$_} = 'Message::Field::UA'}  #    - Entity-Headers
119    # (From draft-ietf-http-v11-spec-rev-01, Nov 21, 1997)
120    my @header_order = qw(
121      mail-from x-envelope-from relay-version path status
122    
123       cache-control connection date pragma transfer-encoding upgrade trailer via
124    
125       accept accept-charset accept-encoding accept-language
126       authorization expect from host
127       if-modified-since if-match if-none-match if-range if-unmodified-since
128       max-forwards proxy-authorization range referer te user-agent
129    
130       accept-ranges age location proxy-authenticate retry-after server vary
131       warning www-authenticate
132    
133       mime-version
134       allow content-base content-encoding content-language content-length
135       content-location content-md5 content-range content-type
136       etag expires last-modified content-style-type content-script-type
137       link
138    
139      xref
140    );
141    my %header_order;
142    
143    sub _init ($;%) {
144      my $self = shift;
145      my %options = @_;
146      $self->{field} = [];
147      $self->{option} = \%DEFAULT;
148      my @new_fields = ();
149      for my $name (keys %options) {
150        if (substr ($name, 0, 1) eq '-') {
151          $self->{option}->{substr ($name, 1)} = $options{$name};
152        } else {
153          push @new_fields, ($name => $options{$name});
154        }
155      }
156      $self->add (@new_fields, -parse => $self->{option}->{parse_all})
157        if $#new_fields > -1;
158      
159      my $format = $self->{option}->{format};
160      if ($format =~ /^cgi/) {
161        unshift @header_order, qw(content-type location);
162        $self->{option}->{sort} = 'good-practice';
163      } elsif ($format =~ /^http/) {
164        $self->{option}->{sort} = 'good-practice';
165      }
166      
167      # Make alternative representations of @header_order.  This is used
168      # for sorting.
169      my $i = 1;
170      for (@header_order) {
171          $header_order{$_} = $i++ unless $header_order{$_};
172      }
173    }
174    
175    =head2 Message::Header->new ([%initial-fields/options])
176    
177    Constructs a new C<Message::Headers> object.  You might pass some initial
178    C<field-name>-C<field-body> pairs and/or options as parameters to the constructor.
179    
180  =head2 Message::Header->new ([%option])  =head3 example
181    
182  Returns new Message::Header instance.  Some options can be   $hdr = new Message::Headers
183  specified as hash.          Date         => 'Thu, 03 Feb 1994 00:00:00 +0000',
184            Content_Type => 'text/html',
185            Content_Location => 'http://www.foo.example/',
186            -format => 'mail-rfc2822'       ## not to be header field
187            ;
188    
189  =cut  =cut
190    
191  sub new ($;%) {  sub new ($;%) {
192    my $class = shift;    my $class = shift;
193    my $self = bless {option => {@_}}, $class;    my $self = bless {}, $class;
194    for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}    $self->_init (@_);
195    $self;    $self;
196  }  }
197    
198  =head2 Message::Header->parse ($header, [%option])  =head2 Message::Header->parse ($header, [%initial-fields/options])
199    
200  Parses given C<header> and return a new Message::Header  Parses given C<header> and constructs a new C<Message::Headers>
201  object.  Some options can be specified as hash.  object.  You might pass some additional C<field-name>-C<field-body> pairs
202    or/and initial options as parameters to the constructor.
203    
204  =cut  =cut
205    
206  sub parse ($$;%) {  sub parse ($$;%) {
207    my $class = shift;    my $class = shift;
208    my $header = shift;    my $header = shift;
209    my $self = bless {option => {@_}}, $class;    my $self = bless {}, $class;
210    for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}    $self->_init (@_);
211    $header =~ s/\x0D?\x0A$REG{WSP}+/\x20/gos;    ## unfold    $header =~ s/\x0D?\x0A$REG{WSP}/\x20/gos;     ## unfold
212    for my $field (split /\x0D?\x0A/, $header) {    for my $field (split /\x0D?\x0A/, $header) {
213      if ($field =~ /$REG{M_fromline}/) {      if ($field =~ /$REG{M_fromline}/) {
214        my $body = $1;        my $body = $1;
215        $body = $self->_field_body ($body, 'mail-from')        $body = $self->_field_body ($body, 'mail-from')
216          if $self->{option}->{parse_all}>0;          if $self->{option}->{parse_all};
217          push @{$self->{field}}, {name => 'mail-from', body => $body};
218        } elsif ($field =~ /$REG{M_field}/) {
219          my ($name, $body) = (lc $1, $2);
220          $name =~ s/$REG{WSP}+$//;
221          $body =~ s/$REG{WSP}+$//;
222          $body = $self->_field_body ($body, $name) if $self->{option}->{parse_all};
223          push @{$self->{field}}, {name => $name, body => $body};
224        }
225      }
226      $self;
227    }
228    
229    sub parse_array ($\@;%) {
230      my $class = shift;
231      my $header = shift;
232      Carp::croak "parse_array: first argument is not an array reference"
233        unless ref $header eq 'ARRAY';
234      my $self = bless {}, $class;
235      $self->_init (@_);
236      while (1) {
237        my $field = shift @$header;
238        while (1) {
239          if ($$header[0] =~ /^$REG{WSP}/) {
240            $field .= shift @$header;
241          } else {last}
242        }
243        $field =~ tr/\x0D\x0A//d;   ## BUG: not safe for bar CR/LF
244        if ($field =~ /$REG{M_fromline}/) {
245          my $body = $1;
246          $body = $self->_field_body ($body, 'mail-from')
247            if $self->{option}->{parse_all};
248        push @{$self->{field}}, {name => 'mail-from', body => $body};        push @{$self->{field}}, {name => 'mail-from', body => $body};
249      } elsif ($field =~ /$REG{M_field}/) {      } elsif ($field =~ /$REG{M_field}/) {
250        my ($name, $body) = (lc $1, $2);        my ($name, $body) = (lc $1, $2);
251        $name =~ s/$REG{WSP}+$//;        $name =~ s/$REG{WSP}+$//;
252        $body =~ s/$REG{WSP}+$//;        $body =~ s/$REG{WSP}+$//;
253        $body = $self->_field_body ($body, $name) if $self->{option}->{parse_all}>0;        $body = $self->_field_body ($body, $name) if $self->{option}->{parse_all};
254        push @{$self->{field}}, {name => $name, body => $body};        push @{$self->{field}}, {name => $name, body => $body};
255      }      }
256        last if $#$header < 0;
257    }    }
258    $self;    $self;
259  }  }
# Line 209  sub _field_body ($$$) { Line 326  sub _field_body ($$$) {
326    unless (ref $body) {    unless (ref $body) {
327      my $type = $self->{option}->{field_type}->{$name}      my $type = $self->{option}->{field_type}->{$name}
328              || $self->{option}->{field_type}->{':DEFAULT'};              || $self->{option}->{field_type}->{':DEFAULT'};
329      eval "require $type";      eval "require $type" or Carp::croak ("_field_body: $type: $@");
330      unless ($body) {      unless ($body) {
331        $body = $type->new (field_name => $name);        $body = $type->new (-field_name => $name,
332            -format => $self->{option}->{format});
333      } else {      } else {
334        $body = $type->parse ($body, field_name => $name);        $body = $type->parse ($body, -field_name => $name,
335            -format => $self->{option}->{format});
336      }      }
337    }    }
338    $body;    $body;
# Line 233  sub field_name_list ($) { Line 352  sub field_name_list ($) {
352    map {$_->{name}} @{$self->{field}};    map {$_->{name}} @{$self->{field}};
353  }  }
354    
355  =head2 $self->add ($field_name, $field_body)  =head2 $self->add ($field-name, $field-body, [$name, $body, ...])
356    
357  Adds an new C<field>.  It is not checked whether  Adds an new C<field>.  It is not checked whether
358  the field which named $field_body is already exist or not.  the field which named $field_body is already exist or not.
359  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.
360    
361    Instead of field name-body pair, you might pass some options.
362    Four options are available for this method.
363    
364    C<-parse>: Parses and validates C<field-body>, and returns
365    C<field-body> object.  (When multiple C<field-body>s are
366    added, returns only last one.)  (Default: C<defined wantarray>)
367    
368    C<-prepend>: New fields are not appended,
369    but prepended to current fields.  (Default: C<0>)
370    
371    C<-translate-underscore>: Do C<field-name> =~ tr/_/-/.  (Default: C<1>)
372    
373    C<-validate>: Checks whether C<field-name> is valid or not.
374    
375  =cut  =cut
376    
377  sub add ($$;$%) {  sub add ($%) {
378    my $self = shift;    my $self = shift;
379    my ($name, $body) = (lc shift, shift);    my %fields = @_;
380    my %option = @_;    my %option = %{$self->{option}};
381    return 0 if $name =~ /$REG{UNSAFE_field_name}/;    $option{parse} = defined wantarray unless defined $option{parse};
382    $body = $self->_field_body ($body, $name);    for (grep {/^-/} keys %fields) {$option{substr ($_, 1)} = $fields{$_}}
383    if ($option{prepend}) {    my $body;
384      unshift @{$self->{field}}, {name => $name, body => $body};    for (grep {/^[^-]/} keys %fields) {
385    } else {      my $name = lc $_;  $body = $fields{$_};
386      push @{$self->{field}}, {name => $name, body => $body};      $name =~ tr/_/-/ if $option{translate_underscore};
387        Carp::croak "add: $name: invalid field-name"
388          if $option{validate} && $name =~ /$REG{UNSAFE_field_name}/;
389        $body = $self->_field_body ($body, $name) if $option{parse};
390        if ($option{prepend}) {
391          unshift @{$self->{field}}, {name => $name, body => $body};
392        } else {
393          push @{$self->{field}}, {name => $name, body => $body};
394        }
395    }    }
396    $body;    $body if $option{parse};
397  }  }
398    
399  =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 406  first one is used and the others are not
406    
407  =cut  =cut
408    
409  sub replace ($$$) {  sub replace ($%) {
410    my $self = shift;    my $self = shift;
411    my ($name, $body) = (lc shift, shift);    my %params = @_;
412    return 0 if $name =~ /$REG{UNSAFE_field_name}/;    my %option = %{$self->{option}};
413    $body = $self->_field_body ($body, $name);    $option{parse} = defined wantarray unless defined $option{parse};
414      for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
415      my (%new_field, $body);
416      for (grep {/^[^-]/} keys %params) {
417        my $name = lc $_;
418        $name =~ tr/_/-/ if $option{translate_underscore};
419        Carp::croak "replace: $name: invalid field-name"
420          if $option{validate} && $name =~ /$REG{UNSAFE_field_name}/;
421        $params{$_} = $self->_field_body ($params{$_}, $name) if $option{parse};
422        $new_field{$name} = $params{$_};
423      }
424    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
425      if ($field->{name} eq $name) {      if (defined $new_field{$field->{name}}) {
426          $body = $new_field {$field->{name}};
427        $field->{body} = $body;        $field->{body} = $body;
428        return $body;        $new_field{$field->{name}} = undef;
429      }      }
430    }    }
431    push @{$self->{field}}, {name => $name, body => $body};    for (keys %new_field) {
432    $body;      push @{$self->{field}}, {name => $_, body => $new_field{$_}};
433      }
434      $body if $option{parse};
435  }  }
436    
437  =head2 $self->delete ($field_name, [$index])  =head2 $self->delete ($field-name, [$name, ...])
438    
439  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.  
440    
441  =cut  =cut
442    
443  sub delete ($$;$) {  sub delete ($@) {
444    my $self = shift;    my $self = shift;
445    my ($name, $index) = (lc shift, shift);    my %delete;
446    my $i = 0;    for (@_) {$delete{lc $_} = 1}
447    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
448      if ($field->{name} eq $name) {      undef $field if $delete{$field->{name}};
       $i++;  
       if ($index == 0 || $i == $index) {  
         undef $field;  
         return $self if $i == $index;  
       }  
     }  
449    }    }
   $self;  
450  }  }
451    
452  =head2 $self->count ([$field_name])  =head2 $self->count ([$field_name])
# Line 329  sub count ($;$) { Line 473  sub count ($;$) {
473    $count;    $count;
474  }  }
475    
476  =head2 $self->stringify ([%option])  =head2 $self->rename ($field-name, $new-name, [$old, $new,...])
477    
478  Returns the C<header> as a string.  Renames C<$field-name> as C<$new-name>.
479    
480  =cut  =cut
481    
482  sub stringify ($;%) {  sub rename ($%) {
483    my $self = shift;    my $self = shift;
484    my %OPT = @_;    my %params = @_;
485    my @ret;    my %option = %{$self->{option}};
486    $OPT{capitalize} ||= $self->{option}->{capitalize};    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
487    $OPT{mail_from} ||= $self->{option}->{mail_from};    my %new_name;
488    $OPT{output_bcc} ||= $self->{option}->{output_bcc};    for (grep {/^[^-]/} keys %params) {
489    push @ret, 'From '.$self->field ('mail-from') if $OPT{mail_from}>0;      my ($old => $new) = (lc $_ => lc $params{$_});
490        $new =~ tr/_/-/ if $option{translate_underscore};
491        Carp::croak "rename: $new: invalid field-name"
492          if $option{validate} && $new =~ /$REG{UNSAFE_field_name}/;
493        $new_name{$old} = $new;
494      }
495    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
496      my $name = $field->{name};      if (length $new_name{$field->{name}}) {
497      next unless $name;        $field->{name} = $new_name{$field->{name}};
498      next if $OPT{mail_from}<0 && $name eq 'mail-from';      }
499      next if $OPT{output_bcc}<0 && ($name eq 'bcc' || $name eq 'resent-bcc');    }
500      my $fbody = scalar $field->{body};    $self if defined wantarray;
501      next unless $fbody;  }
502      $fbody =~ s/\x0D([^\x09\x0A\x20])/\x0D\x20$1/g;  
503      $fbody =~ s/\x0A([^\x09\x20])/\x0A\x20$1/g;  
504      $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $OPT{capitalize};  =item $self->scan(\&doit)
505      push @ret, $name.': '.$self->fold ($fbody);  
506    Apply a subroutine to each header field in turn.  The callback routine is
507    called with two parameters; the name of the field and a single value.
508    If the header has more than one value, then the routine is called once
509    for each value.
510    
511    =cut
512    
513    sub scan ($&) {
514      my ($self, $sub) = @_;
515      my $sort;
516      $sort = \&_header_cmp if $self->{option}->{sort} eq 'good-practice';
517      $sort = {$a cmp $b} if $self->{option}->{sort} eq 'alphabetic';
518      my @field = @{$self->{field}};
519      if (ref $sort) {
520        @field = sort $sort @{$self->{field}};
521      }
522      for my $field (@field) {
523        next if $field->{name} =~ /^_/;
524        &$sub($field->{name} => $field->{body});
525    }    }
   my $ret = join ("\n", @ret);  
   $ret? $ret."\n": "";  
526  }  }
527    
528  =head2 $self->get_option ($option_name)  # Compare function which makes it easy to sort headers in the
529    # recommended "Good Practice" order.
530    ## taken from HTTP::Header
531    sub _header_cmp
532    {
533      my ($na, $nb) = ($a->{name}, $b->{name});
534        # Unknown headers are assign a large value so that they are
535        # sorted last.  This also helps avoiding a warning from -w
536        # about comparing undefined values.
537        $header_order{$na} = 999 unless defined $header_order{$na};
538        $header_order{$nb} = 999 unless defined $header_order{$nb};
539    
540  Returns value of the option.      $header_order{$na} <=> $header_order{$nb} || $na cmp $nb;
541    }
542    
543  =head2 $self->set_option ($option_name, $option_value)  =head2 $self->stringify ([%option])
544    
545  Set new value of the option.  Returns the C<header> as a string.
546    
547  =cut  =cut
548    
549  sub get_option ($$) {  sub stringify ($;%) {
550    my $self = shift;    my $self = shift;
551    my ($name) = @_;    my %params = @_;
552    $self->{option}->{$name};    my %option = %{$self->{option}};
553      for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
554      my @ret;
555      if ($option{mail_from}) {
556        my $fromline = $self->field ('mail-from');
557        push @ret, 'From '.$fromline if $fromline;
558      }
559      $self->scan (sub {
560        my ($name, $body) = (@_);
561        return unless length $name;
562        return if $option{mail_from} && $name eq 'mail-from';
563        return if !$option{output_bcc} && ($name eq 'bcc' || $name eq 'resent-bcc');
564        my $fbody;
565        if (ref $body) {
566          $fbody = $body->stringify (-format => $option{format});
567        } else {
568          $fbody = $body;
569        }
570        return unless length $fbody;
571        $fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;
572        $fbody =~ s/\x0A(?=[^\x09\x20])/\x0A\x20/g;
573        $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $option{capitalize};
574        push @ret, $name.': '.$self->fold ($fbody);
575      });
576      my $ret = join ("\n", @ret);
577      $ret? $ret."\n": '';
578  }  }
579  sub set_option ($$$) {  *as_string = \&stringify;
580    
581    =head2 $self->option ($option_name, [$option_value])
582    
583    Set/gets new value of the option.
584    
585    =cut
586    
587    sub option ($@) {
588    my $self = shift;    my $self = shift;
589    my ($name, $value) = @_;    if (@_ == 1) {
590    $self->{option}->{$name} = $value;      return $self->{option}->{ shift (@_) };
591    $self;    }
592      while (my ($name, $value) = splice (@_, 0, 2)) {
593        $name =~ s/^-//;
594        $self->{option}->{$name} = $value;
595        if ($name eq 'format') {
596          for my $f (@{$self->{field}}) {
597            if (ref $f->{body}) {
598              $f->{body}->option (-format => $value);
599            }
600          }
601        }
602      }
603  }  }
604    
605  sub field_type ($$;$) {  sub field_type ($$;$) {
# Line 436  sub fold ($$;$) { Line 657  sub fold ($$;$) {
657    $string;    $string;
658  }  }
659    
660    =head2 $self->clone ()
661    
662    Returns a copy of Message::Header object.
663    
664    =cut
665    
666    sub clone ($) {
667      my $self = shift;
668      my $clone = new Message::Header;
669      for my $name (%{$self->{option}}) {
670        if (ref $self->{option}->{$name} eq 'HASH') {
671          $clone->{option}->{$name} = {%{$self->{option}->{$name}}};
672        } elsif (ref $self->{option}->{$name} eq 'ARRAY') {
673          $clone->{option}->{$name} = [@{$self->{option}->{$name}}];
674        } else {
675          $clone->{option}->{$name} = $self->{option}->{$name};
676        }
677      }
678      for (@{$self->{field}}) {
679        $clone->add ($_->{name}, scalar $_->{body});
680      }
681      $clone;
682    }
683    
684    =head1 NOTE
685    
686    =head2 C<field-name>
687    
688    The header field name is not case sensitive.  To make the life
689    easier for perl users who wants to avoid quoting before the => operator,
690    you can use '_' as a synonym for '-' in header field names
691    (this behaviour can be suppressed by setting
692    C<translate_underscore> option to C<0> value).
693    
694  =head1 EXAMPLE  =head1 EXAMPLE
695    
696    ## Print field list    ## Print field list
# Line 443  sub fold ($$;$) { Line 698  sub fold ($$;$) {
698    use Message::Header;    use Message::Header;
699    my $header = Message::Header->parse ($header);    my $header = Message::Header->parse ($header);
700        
   ## Next sample is better.  
   #for my $field (@$header) {  
   #  print $field->{name}, "\t=> ", $field->{body}, "\n";  
   #}  
     
701    for my $i (0..$#$header) {    for my $i (0..$#$header) {
702      print $header->field_name ($i), "\t=> ", $header->field_body ($i), "\n";      print $header->field_name ($i), "\t=> ", $header->field_body ($i), "\n";
703    }    }
# Line 470  sub fold ($$;$) { Line 720  sub fold ($$;$) {
720    $header->add ('References' => '<hoge.msgid%foo@foo.example>');    $header->add ('References' => '<hoge.msgid%foo@foo.example>');
721    print $header;    print $header;
722    
723    =head1 ACKNOWLEDGEMENTS
724    
725    Some of codes are taken from other modules such as
726    HTTP::Header, Mail::Header.
727    
728  =head1 LICENSE  =head1 LICENSE
729    
730  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.11  
changed lines
  Added in v.1.14
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24