/[suikacvs]/test/cvs
Suika

Diff of /test/cvs

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

revision 1.3 by wakaba, Wed Mar 13 14:47:07 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   => {},
59      format        => 'mail-rfc2822',
60    mail_from     => 0,    mail_from     => 0,
61      output_bcc    => 0,
62      parse_all     => 0,
63      sort  => 'none',
64      translate_underscore  => 1,
65      validate      => 1,
66  );  );
67    $DEFAULT{field_type} = {
68            ':DEFAULT'      => 'Message::Field::Unstructured',
69            
70            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'}
100    for (qw(approved bcc cc complaints-to
101      delivered-to disposition-notification-to envelope-to
102      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
106      return-receipt-to sender to x-approved x-beenthere
107      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))
109      {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}
110    for (qw(date date-received delivery-date expires
111      expire-date nntp-posting-date posted reply-by resent-date x-tcup-date))
112      {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}
113    for (qw(article-updates client-date content-id in-reply-to message-id
114      references resent-message-id see-also supersedes))
115      {$DEFAULT{field_type}->{$_} = 'Message::Field::MsgID'}
116    for (qw(accept accept-charset accept-encoding accept-language
117      content-language
118      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))
122      {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}
123    for (qw(content-alias content-base content-location location referer
124      url x-home-page x-http_referer
125      x-info x-pgp-key x-ml-url x-uri x-url x-web))
126      {$DEFAULT{field_type}->{$_} = 'Message::Field::URI'}
127    
128    ## taken from L<HTTP::Header>
129    # "Good Practice" order of HTTP message headers:
130    #    - General-Headers
131    #    - Request-Headers
132    #    - Response-Headers
133    #    - 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      xref
155    );
156    my %header_order;
157    
158    sub _init ($;%) {
159      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  =head2 Message::Header->new ([%option])  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  Returns new Message::Header instance.  Some options can be  Example:
196  specified as hash.  
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        push @{$self->{field}}, {name => 'mail-from', body => $1};        my $body = $1;
230          $body = $self->_field_body ($body, 'mail-from')
231            if $self->{option}->{parse_all};
232          push @{$self->{field}}, {name => 'mail-from', body => $body};
233      } elsif ($field =~ /$REG{M_field}/) {      } elsif ($field =~ /$REG{M_field}/) {
234        my ($name, $body) = ($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        push @{$self->{field}}, {name => lc $name, body => $body};        $body = $self->_field_body ($body, $name) if $self->{option}->{parse_all};
238          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 106  sub field ($$) { Line 303  sub field ($$) {
303    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
304      if ($field->{name} eq $name) {      if ($field->{name} eq $name) {
305        unless (wantarray) {        unless (wantarray) {
306            $field->{body} = $self->_field_body ($field->{body}, $name);
307          return $field->{body};          return $field->{body};
308        } else {        } else {
309            $field->{body} = $self->_field_body ($field->{body}, $name);
310          push @ret, $field->{body};          push @ret, $field->{body};
311        }        }
312      }      }
313    }    }
314      if ($#ret < 0) {
315        return $self->add ($name);
316      }
317    @ret;    @ret;
318  }  }
319    
320    sub field_exist ($$) {
321      my $self = shift;
322      my $name = lc shift;
323      my @ret;
324      for my $field (@{$self->{field}}) {
325        return 1 if ($field->{name} eq $name);
326      }
327      0;
328    }
329    
330  =head2 $self->field_name ($index)  =head2 $self->field_name ($index)
331    
332  Returns C<field-name> of $index'th C<field>.  Returns C<field-name> of $index'th C<field>.
# Line 131  sub field_name ($$) { Line 343  sub field_name ($$) {
343  }  }
344  sub field_body ($$) {  sub field_body ($$) {
345    my $self = shift;    my $self = shift;
346    $self->{field}->[shift]->{body};    my $i = shift;
347      $self->{field}->[$i]->{body}
348       = $self->_field_body ($self->{field}->[$i]->{body}, $self->{field}->[$i]->{name});
349      $self->{field}->[$i]->{body};
350    }
351    
352    sub _field_body ($$$) {
353      my $self = shift;
354      my ($body, $name) = @_;
355      unless (ref $body) {
356        my $type = $self->{option}->{field_type}->{$name}
357                || $self->{option}->{field_type}->{':DEFAULT'};
358        eval "require $type" or Carp::croak ("_field_body: $type: $@");
359        unless ($body) {
360          $body = $type->new (-field_name => $name,
361            -format => $self->{option}->{format});
362        } else {
363          $body = $type->parse ($body, -field_name => $name,
364            -format => $self->{option}->{format});
365        }
366      }
367      $body;
368  }  }
369    
370  =head2 $self->field_name_list ()  =head2 $self->field_name_list ()
# Line 148  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    return 0 if $name =~ /$REG{UNSAFE_field_name}/;    my %option = %{$self->{option}};
410    push @{$self->{field}}, {name => $name, body => $body};    $option{parse} = defined wantarray unless defined $option{parse};
411    $self;    for (grep {/^-/} keys %fields) {$option{substr ($_, 1)} = $fields{$_}}
412      my $body;
413      for (grep {/^[^-]/} keys %fields) {
414        my $name = lc $_;  $body = $fields{$_};
415        $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 if $option{parse};
426  }  }
427    
428  =head2 $self->relace ($field_name, $field_body)  =head2 $self->relace ($field_name, $field_body)
# Line 174  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      $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 $self;        $new_field{$field->{name}} = undef;
458      }      }
459    }    }
460    push @{$self->{field}}, {name => $name, body => $body};    for (keys %new_field) {
461    $self;      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 237  sub count ($;$) { Line 502  sub count ($;$) {
502    $count;    $count;
503  }  }
504    
505    =head2 $self->rename ($field-name, $new-name, [$old, $new,...])
506    
507    Renames C<$field-name> as C<$new-name>.
508    
509    =cut
510    
511    sub rename ($%) {
512      my $self = shift;
513      my %params = @_;
514      my %option = %{$self->{option}};
515      for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
516      my %new_name;
517      for (grep {/^[^-]/} keys %params) {
518        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}}) {
525        if (length $new_name{$field->{name}}) {
526          $field->{name} = $new_name{$field->{name}};
527        }
528      }
529      $self if defined wantarray;
530    }
531    
532    
533    =item $self->scan(\&doit)
534    
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      }
555    }
556    
557    # 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        $header_order{$na} <=> $header_order{$nb} || $na cmp $nb;
570    }
571    
572  =head2 $self->stringify ([%option])  =head2 $self->stringify ([%option])
573    
574  Returns the C<header> as a string.  Returns the C<header> as a string.
# Line 245  Returns the C<header> as a string. Line 577  Returns the C<header> as a string.
577    
578  sub stringify ($;%) {  sub stringify ($;%) {
579    my $self = shift;    my $self = shift;
580    my %OPT = @_;    my %params = @_;
581      my %option = %{$self->{option}};
582      for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
583    my @ret;    my @ret;
584    $OPT{capitalize} ||= $self->{option}->{capitalize};    if ($option{mail_from}) {
585    $OPT{mail_from} ||= $self->{option}->{mail_from};      my $fromline = $self->field ('mail-from');
586    push @ret, 'From '.$self->field ('mail-from') if $OPT{mail_from};      push @ret, 'From '.$fromline if $fromline;
   for my $field (@{$self->{field}}) {  
     my $name = $field->{name};  
     next unless $field->{name};  
     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});  
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);    my $ret = join ("\n", @ret);
606    $ret? $ret."\n": "";    $ret? $ret."\n": '';
607  }  }
608    *as_string = \&stringify;
609    
610  =head2 $self->get_option ($option_name)  =head2 $self->option ($option_name, [$option_value])
   
 Returns value of the option.  
   
 =head2 $self->set_option ($option_name, $option_value)  
611    
612  Set new value of the option.  Set/gets new value of the option.
613    
614  =cut  =cut
615    
616  sub get_option ($$) {  sub option ($@) {
617    my $self = shift;    my $self = shift;
618    my ($name) = @_;    if (@_ == 1) {
619    $self->{option}->{$name};      return $self->{option}->{ shift (@_) };
620      }
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  sub set_option ($$$) {  
634    sub field_type ($$;$) {
635    my $self = shift;    my $self = shift;
636    my ($name, $value) = @_;    my $field_name = shift;
637    $self->{option}->{$name} = $value;    my $new_field_type = shift;
638    $self;    if ($new_field_type) {
639        $self->{option}->{field_type}->{$field_name} = $new_field_type;
640      }
641      $self->{option}->{field_type}->{$field_name}
642      || $self->{option}->{field_type}->{':DEFAULT'};
643  }  }
644    
645  sub _delete_empty_field ($) {  sub _delete_empty_field ($) {
# Line 311  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 327  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 334  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 361  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.3  
changed lines
  Added in v.1.15

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24