/[suikacvs]/test/cvs
Suika

Diff of /test/cvs

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

revision 1.14 by wakaba, Wed Apr 3 13:31:36 2002 UTC revision 1.18 by wakaba, Tue May 14 13:50:11 2002 UTC
# Line 14  use strict; Line 14  use strict;
14  use vars qw($VERSION %REG);  use vars qw($VERSION %REG);
15  $VERSION = '1.00';  $VERSION = '1.00';
16  use Carp ();  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    =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 = (  my %DEFAULT = (
58    capitalize    => 1,    capitalize    => 1,
59      fold  => 1,
60    fold_length   => 70,    fold_length   => 70,
61      field_format_pattern  => '%s: %s',
62    #field_type   => {},    #field_type   => {},
63    format        => 'mail-rfc2822',    format        => 'mail-rfc2822',
64      linebreak_strict      => 0,
65    mail_from     => 0,    mail_from     => 0,
66    output_bcc    => 0,    output_bcc    => 0,
67    parse_all     => 0,    parse_all     => 0,
68    sort  => 'none',    sort  => 'none',
69    translate_underscore  => 1,    translate_underscore  => 1,
70      uri_mailto_safe       => {
71            ## 1 all (no check)     2 no trace & bcc & from
72            ## 3 no sender's info   4 (default) (currently not used)
73            ## 5 only a few
74            ':default'      => 4,
75            'cc'    => 4,
76            'bcc'   => 1,
77            'body'  => 1,
78            'comment'       => 5,
79            'content-id'    => 1,
80            'date'  => 1,
81            'from'  => 1,
82            'keywords'      => 5,
83            'list-id'       => 1,
84            'mail-from'     => 1,
85            'message-id'    => 1,
86            'received'      => 1,
87            'resent-bcc'    => 1,
88            'resent-date'   => 1,
89            'resent-from'   => 1,
90            'resent-sender' => 1,
91            'return-path'   => 1,
92            'sender'        => 1,
93            'subject'       => 5,
94            'summary'       => 5,
95            'to'    => 4,
96            'user-agent'    => 3,
97            'x-face'        => 2,
98            'x-mailer'      => 3,
99            'x-nsubject'    => 5,
100            'x-received'    => 1,
101            'x400-received' => 1,
102            },
103      uri_mailto_safe_level => 4,
104    validate      => 1,    validate      => 1,
105  );  );
106  $DEFAULT{field_type} = {  $DEFAULT{field_type} = {
# Line 63  $DEFAULT{field_type} = { Line 110  $DEFAULT{field_type} = {
110          'x-received'    => 'Message::Field::Received',          'x-received'    => 'Message::Field::Received',
111                    
112          'content-type'  => 'Message::Field::ContentType',          'content-type'  => 'Message::Field::ContentType',
113          'content-disposition'   => 'Message::Field::ContentDisposition',          p3p     => 'Message::Field::Params',
114            'auto-submitted'        => 'Message::Field::ValueParams',
115            'content-disposition'   => 'Message::Field::ValueParams',
116          link    => 'Message::Field::ValueParams',          link    => 'Message::Field::ValueParams',
117          archive => 'Message::Field::ValueParams',          archive => 'Message::Field::ValueParams',
118          'x-face-type'   => 'Message::Field::ValueParams',          'x-face-type'   => 'Message::Field::ValueParams',
119            'x-mozilla-draft-info'  => 'Message::Field::ValueParams',
120                    
121          subject => 'Message::Field::Subject',          subject => 'Message::Field::Subject',
122          'x-nsubject'    => 'Message::Field::Subject',          'x-nsubject'    => 'Message::Field::Subject',
# Line 75  $DEFAULT{field_type} = { Line 125  $DEFAULT{field_type} = {
125          'user-agent'    => 'Message::Field::UA',          'user-agent'    => 'Message::Field::UA',
126          server  => 'Message::Field::UA',          server  => 'Message::Field::UA',
127                    
128            ## A message id
129            'content-id'    => 'Message::Field::MsgID',
130            'message-id'    => 'Message::Field::MsgID',
131            'resent-message-id'     => 'Message::Field::MsgID',
132            
133            ## Numeric value
134          'content-length'        => 'Message::Field::Numval',          'content-length'        => 'Message::Field::Numval',
135          lines   => 'Message::Field::Numval',          lines   => 'Message::Field::Numval',
136          'max-forwards'  => 'Message::Field::Numval',          'max-forwards'  => 'Message::Field::Numval',
137          'mime-version'  => 'Message::Field::Numval',          'mime-version'  => 'Message::Field::Numval',
138            'x-jsmail-priority'     => 'Message::Field::Numval',
139            'x-mail-count'  => 'Message::Field::Numval',
140            'x-ml-count'    => 'Message::Field::Numval',
141            'x-priority'    => 'Message::Field::Numval',
142                    
143          path    => 'Message::Field::Path',          path    => 'Message::Field::Path',
144  };  };
145  for (qw(cancel-lock importance   precedence list-id  for (qw(archive cancel-lock content-features content-md5
146    x-face x-mail-count x-msmail-priority x-priority xref))    disposition-notification-options encoding
147      importance injector-info
148      pics-label posted-and-mailed precedence list-id message-type
149      original-recipient priority x-list-id
150      sensitivity status x-face x-msmail-priority xref))
151    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
152  for (qw(approved bcc cc delivered-to disposition-notification-to envelope-to          ## Not supported yet, but to be supported...
153    errors-to fcc from mail-followup-to mail-followup-cc reply-to resent-bcc          # x-list: unstructured, ml name
154    for (qw(abuse-reports-to apparently-to approved approved-by bcc cc complaints-to
155      delivered-to disposition-notification-to envelope-to
156      errors-to  from mail-copies-to mail-followup-to mail-reply-to
157      notice-requested-upon-delivery-to read-receipt-to register-mail-reply-requested-by
158      reply-to resent-bcc
159    resent-cc resent-to resent-from resent-sender return-path    resent-cc resent-to resent-from resent-sender return-path
160    return-receipt-to sender to x-approved x-beenthere    return-receipt-to return-receipt-requested-to sender to x-abuse-reports-to
161      x-admin x-approved
162      x-beenthere
163      x-confirm-reading-to
164    x-complaints-to x-envelope-from x-envelope-sender    x-complaints-to x-envelope-from x-envelope-sender
165    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
166      x-rcpt-to x-sender x-x-sender))
167    {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}
168  for (qw(date date-received delivery-date expires  for (qw(client-date date date-received delivery-date expires
169    expire-date nntp-posting-date posted reply-by resent-date x-tcup-date))    expire-date nntp-posting-date posted posted-date received-date
170      reply-by resent-date
171      x-originalarrivaltime x-tcup-date))
172    {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}
173  for (qw(article-updates client-date content-id in-reply-to message-id  for (qw(article-updates in-reply-to
174    references resent-message-id see-also supersedes))    obsoletes references replaces see-also supersedes))
175    {$DEFAULT{field_type}->{$_} = 'Message::Field::MsgID'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::MsgIDs'}
176  for (qw(accept accept-charset accept-encoding accept-language  for (qw(accept accept-charset accept-encoding accept-language
177    content-language    content-language
178    content-transfer-encoding encrypted followup-to keywords    content-transfer-encoding encrypted followup-to keywords
179    list-archive list-digest list-help list-owner    list-archive list-digest list-help list-owner
180    list-post list-subscribe list-unsubscribe list-url uri newsgroups    list-post list-subscribe list-unsubscribe list-url uri newsgroups
181    x-brother x-daughter x-respect x-moe x-syster x-wife))    posted-to))
182    {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}
183    for (qw(x-brother x-boss x-classmate x-daughter x-dearfriend x-favoritesong
184      x-friend x-me
185      x-moe x-respect
186      x-sublimate x-son x-sister x-wife))
187      {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}  ## NOT M::F::XMOE!
188  for (qw(content-alias content-base content-location location referer  for (qw(content-alias content-base content-location location referer
189    url x-home-page x-http_referer    url x-home-page x-http_referer
190    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))
191    {$DEFAULT{field_type}->{$_} = 'Message::Field::URI'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::URI'}
192    
193    my %header_goodcase = (
194            'article-i.d.'  => 'Article-I.D.',
195            'content-id'    => 'Content-ID',
196            'content-md5'   => 'Content-MD5',
197            'content-sgml-entity'   => 'Content-SGML-Entity',
198            etag    => 'ETag',
199            fax     => 'FAX',
200            'pics-label'    => 'PICS-Label',
201            'list-url'      => 'List-URL',
202            'list-id'       => 'List-ID',
203            'message-id'    => 'Message-ID',
204            'mime-version'  => 'MIME-Version',
205            'nic'   => 'NIC',
206            'nntp-posting-date'     => 'NNTP-Posting-Date',
207            'nntp-posting-host'     => 'NNTP-Posting-Host',
208            'resent-message-id'     => 'Resent-Message-ID',
209            te      => 'TE',
210            url     => 'URL',
211            'www-authenticate'      => 'WWW-Authenticate',
212            'x-dearfriend'  => 'X-DearFriend',
213            'x-mime-autoconverted'  => 'X-MIME-Autoconverted',
214            'x-nntp-posting-date'   => 'X-NNTP-Posting-Date',
215            'x-nntp-posting-host'   => 'X-NNTP-Posting-Host',
216            'x-uri' => 'X-URI',
217            'x-url' => 'X-URL',
218    );
219    $DEFAULT{capitalize} = sub {
220      my $self = shift;
221      my $name = shift;
222      if ($header_goodcase{$name}) {
223        return $header_goodcase{$name};
224      }
225      $name =~ s/(?:^|-)cgi-/uc $&/ge;
226      $name =~ s/(?:^|-)[a-z]/uc $&/ge;
227      $name;
228    };
229    
230  ## taken from L<HTTP::Header>  ## taken from L<HTTP::Header>
231  # "Good Practice" order of HTTP message headers:  # "Good Practice" order of HTTP message headers:
232  #    - General-Headers  #    - General-Headers
# Line 153  sub _init ($;%) { Line 270  sub _init ($;%) {
270        push @new_fields, ($name => $options{$name});        push @new_fields, ($name => $options{$name});
271      }      }
272    }    }
273    $self->add (@new_fields, -parse => $self->{option}->{parse_all})    $self->_init_by_format ($self->{option}->{format}, $self->{option});
     if $#new_fields > -1;  
     
   my $format = $self->{option}->{format};  
   if ($format =~ /^cgi/) {  
     unshift @header_order, qw(content-type location);  
     $self->{option}->{sort} = 'good-practice';  
   } elsif ($format =~ /^http/) {  
     $self->{option}->{sort} = 'good-practice';  
   }  
     
274    # Make alternative representations of @header_order.  This is used    # Make alternative representations of @header_order.  This is used
275    # for sorting.    # for sorting.
276    my $i = 1;    my $i = 1;
277    for (@header_order) {    for (@header_order) {
278        $header_order{$_} = $i++ unless $header_order{$_};        $header_order{$_} = $i++ unless $header_order{$_};
279    }    }
280      
281      $self->add (@new_fields, -parse => $self->{option}->{parse_all})
282        if $#new_fields > -1;
283    }
284    
285    sub _init_by_format ($$\%) {
286      my $self = shift;
287      my ($format, $option) = @_;
288      if ($format =~ /rfc822/) {
289        $header_goodcase{bcc} = 'bcc';
290        $header_goodcase{cc} = 'cc';
291        $header_goodcase{'resent-bcc'} = 'Resent-bcc';
292        $header_goodcase{'resent-cc'} = 'Resent-cc';
293      } elsif ($format =~ /cgi/) {
294        unshift @header_order, qw(content-type location);
295        $option->{sort} = 'good-practice';
296        $option->{fold} = 0;
297      } elsif ($format =~ /http/) {
298        $option->{sort} = 'good-practice';
299      }
300      if ($format =~ /uri-url-mailto/) {
301        $option->{output_bcc} = 0;
302        $option->{capitalize} = 0;
303        $option->{field_format_pattern} = '%s=%s';
304        $option->{fold} = sub {
305          $_[1] =~ s/([^:@+\$A-Za-z0-9\-_.!~*])/sprintf('%%%02X', ord $1)/ge;
306          $_[1];
307        };
308      }
309  }  }
310    
311  =head2 Message::Header->new ([%initial-fields/options])  =item Message::Header->new ([%initial-fields/options])
312    
313  Constructs a new C<Message::Headers> object.  You might pass some initial  Constructs a new C<Message::Headers> object.  You might pass some initial
314  C<field-name>-C<field-body> pairs and/or options as parameters to the constructor.  C<field-name>-C<field-body> pairs and/or options as parameters to the constructor.
315    
316  =head3 example  Example:
317    
318   $hdr = new Message::Headers   $hdr = new Message::Headers
319          Date         => 'Thu, 03 Feb 1994 00:00:00 +0000',          Date         => 'Thu, 03 Feb 1994 00:00:00 +0000',
# Line 195  sub new ($;%) { Line 331  sub new ($;%) {
331    $self;    $self;
332  }  }
333    
334  =head2 Message::Header->parse ($header, [%initial-fields/options])  =item Message::Header->parse ($header, [%initial-fields/options])
335    
336  Parses given C<header> and constructs a new C<Message::Headers>  Parses given C<header> and constructs a new C<Message::Headers>
337  object.  You might pass some additional C<field-name>-C<field-body> pairs  object.  You might pass some additional C<field-name>-C<field-body> pairs
# Line 207  sub parse ($$;%) { Line 343  sub parse ($$;%) {
343    my $class = shift;    my $class = shift;
344    my $header = shift;    my $header = shift;
345    my $self = bless {}, $class;    my $self = bless {}, $class;
346    $self->_init (@_);    $self->_init (@_);    ## BUG: don't check linebreak_strict
347    $header =~ s/\x0D?\x0A$REG{WSP}/\x20/gos;     ## unfold    $header =~ s/\x0D?\x0A$REG{WSP}/\x20/gos;     ## unfold
348    for my $field (split /\x0D?\x0A/, $header) {    for my $field (split /\x0D?\x0A/, $header) {
349      if ($field =~ /$REG{M_fromline}/) {      if ($field =~ /$REG{M_fromline}/) {
# Line 226  sub parse ($$;%) { Line 362  sub parse ($$;%) {
362    $self;    $self;
363  }  }
364    
365    =item Message::Header->parse_array (\@header, [%initial-fields/options])
366    
367    Parses given C<header> and constructs a new C<Message::Headers>
368    object.  Same as C<Message::Header-E<lt>parse> but this method
369    is given an array reference.  You might pass some additional
370    C<field-name>-C<field-body> pairs or/and initial options
371    as parameters to the constructor.
372    
373    =cut
374    
375  sub parse_array ($\@;%) {  sub parse_array ($\@;%) {
376    my $class = shift;    my $class = shift;
377    my $header = shift;    my $header = shift;
# Line 240  sub parse_array ($\@;%) { Line 386  sub parse_array ($\@;%) {
386          $field .= shift @$header;          $field .= shift @$header;
387        } else {last}        } else {last}
388      }      }
389      $field =~ tr/\x0D\x0A//d;   ## BUG: not safe for bar CR/LF      if ($self->{option}->{linebreak_strict}) {
390          $field =~ s/\x0D\x0A//g;
391        } else {
392          $field =~ tr/\x0D\x0A//d;
393        }
394      if ($field =~ /$REG{M_fromline}/) {      if ($field =~ /$REG{M_fromline}/) {
395        my $body = $1;        my $body = $1;
396        $body = $self->_field_body ($body, 'mail-from')        $body = $self->_field_body ($body, 'mail-from')
# Line 258  sub parse_array ($\@;%) { Line 408  sub parse_array ($\@;%) {
408    $self;    $self;
409  }  }
410    
411    =back
412    
413    =head1 METHODS
414    
415  =head2 $self->field ($field_name)  =head2 $self->field ($field_name)
416    
417  Returns C<field-body> of given C<field-name>.  Returns C<field-body> of given C<field-name>.
# Line 328  sub _field_body ($$$) { Line 482  sub _field_body ($$$) {
482              || $self->{option}->{field_type}->{':DEFAULT'};              || $self->{option}->{field_type}->{':DEFAULT'};
483      eval "require $type" or Carp::croak ("_field_body: $type: $@");      eval "require $type" or Carp::croak ("_field_body: $type: $@");
484      unless ($body) {      unless ($body) {
485        $body = $type->new (-field_name => $name,        $body = $type->new (-field_name => $name,
486          -format => $self->{option}->{format});          -format => $self->{option}->{format},
487            -parse_all => $self->{option}->{parse_all},
488            field_name => $name, format => $self->{option}->{format});
489      } else {      } else {
490        $body = $type->parse ($body, -field_name => $name,        $body = $type->parse ($body, -field_name => $name,
491          -format => $self->{option}->{format});          -format => $self->{option}->{format},
492            -parse_all => $self->{option}->{parse_all},
493             field_name => $name,format => $self->{option}->{format});
494      }      }
495    }    }
496    $body;    $body;
# Line 352  sub field_name_list ($) { Line 510  sub field_name_list ($) {
510    map {$_->{name}} @{$self->{field}};    map {$_->{name}} @{$self->{field}};
511  }  }
512    
513  =head2 $self->add ($field-name, $field-body, [$name, $body, ...])  =item $hdr->add ($field-name, $field-body, [$name, $body, ...])
514    
515  Adds an new C<field>.  It is not checked whether  Adds some field name/body pairs.  Even if there are
516  the field which named $field_body is already exist or not.  one or more fields named given C<$field-name>,
517  If you don't want duplicated C<field>s, use C<replace> method.  given name/body pairs are ADDed.  Use C<replace>
518    to remove same-name-fields.
519    
520  Instead of field name-body pair, you might pass some options.  Instead of field name-body pair, you might pass some options.
521  Four options are available for this method.  Four options are available for this method.
# Line 378  sub add ($%) { Line 537  sub add ($%) {
537    my $self = shift;    my $self = shift;
538    my %fields = @_;    my %fields = @_;
539    my %option = %{$self->{option}};    my %option = %{$self->{option}};
540    $option{parse} = defined wantarray unless defined $option{parse};    $option{parse} = 1 if defined wantarray;
541    for (grep {/^-/} keys %fields) {$option{substr ($_, 1)} = $fields{$_}}    for (grep {/^-/} keys %fields) {$option{substr ($_, 1)} = $fields{$_}}
542    my $body;    my $body;
543    for (grep {/^[^-]/} keys %fields) {    for (grep {/^[^-]/} keys %fields) {
# Line 412  sub replace ($%) { Line 571  sub replace ($%) {
571    my %option = %{$self->{option}};    my %option = %{$self->{option}};
572    $option{parse} = defined wantarray unless defined $option{parse};    $option{parse} = defined wantarray unless defined $option{parse};
573    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
574    my (%new_field, $body);    my (%new_field);
575    for (grep {/^[^-]/} keys %params) {    for (grep {/^[^-]/} keys %params) {
576      my $name = lc $_;      my $name = lc $_;
577      $name =~ tr/_/-/ if $option{translate_underscore};      $name =~ tr/_/-/ if $option{translate_underscore};
# Line 421  sub replace ($%) { Line 580  sub replace ($%) {
580      $params{$_} = $self->_field_body ($params{$_}, $name) if $option{parse};      $params{$_} = $self->_field_body ($params{$_}, $name) if $option{parse};
581      $new_field{$name} = $params{$_};      $new_field{$name} = $params{$_};
582    }    }
583      my $body = (%new_field)[-1];
584    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
585      if (defined $new_field{$field->{name}}) {      if (defined $new_field{$field->{name}}) {
586        $body = $new_field {$field->{name}};        $field->{body} = $new_field {$field->{name}};
       $field->{body} = $body;  
587        $new_field{$field->{name}} = undef;        $new_field{$field->{name}} = undef;
588      }      }
589    }    }
# Line 442  Deletes C<field> named as $field_name. Line 601  Deletes C<field> named as $field_name.
601    
602  sub delete ($@) {  sub delete ($@) {
603    my $self = shift;    my $self = shift;
604    my %delete;    my %delete;  for (@_) {$delete{lc $_} = 1}
   for (@_) {$delete{lc $_} = 1}  
605    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
606      undef $field if $delete{$field->{name}};      undef $field if $delete{$field->{name}};
607    }    }
# Line 550  sub stringify ($;%) { Line 708  sub stringify ($;%) {
708    my $self = shift;    my $self = shift;
709    my %params = @_;    my %params = @_;
710    my %option = %{$self->{option}};    my %option = %{$self->{option}};
711      $option{format} = $params{-format} if $params{-format};
712      $self->_init_by_format ($option{format}, \%option);
713    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
714    my @ret;    my @ret;
715    if ($option{mail_from}) {    my $_stringify = sub {
716      my $fromline = $self->field ('mail-from');        my ($name, $body) = (@_);
717      push @ret, 'From '.$fromline if $fromline;        return unless length $name;
718    }        return if $option{mail_from} && $name eq 'mail-from';
719    $self->scan (sub {        return if !$option{output_bcc} && ($name eq 'bcc' || $name eq 'resent-bcc');
720      my ($name, $body) = (@_);        if ($option{format} =~ /uri-url-mailto/) {
721      return unless length $name;          return if ((   $option{uri_mailto_safe}->{$name}
722      return if $option{mail_from} && $name eq 'mail-from';               || $option{uri_mailto_safe}->{':default'})
723      return if !$option{output_bcc} && ($name eq 'bcc' || $name eq 'resent-bcc');                < $option{uri_mailto_safe_level});
724      my $fbody;          if ($name eq 'to') {
725      if (ref $body) {            $body = $self->field ('to');
726        $fbody = $body->stringify (-format => $option{format});            return unless ref $body && $body->have_group;
727      } else {          }
728        $fbody = $body;        }
729          my $fbody;
730          if (ref $body) {
731            $fbody = $body->stringify (-format => $option{format});
732          } else {
733            $fbody = $body;
734          }
735          return unless length $fbody;
736          unless ($option{linebreak_strict}) {
737            ## bare \x0D and bare \x0A are unsafe
738            $fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;
739            $fbody =~ s/\x0A(?=[^\x09\x20])/\x0A\x20/g;
740          } else {
741            $fbody =~ s/\x0D\x0A(?=[^\x09\x20])/\x0D\x0A\x20/g;
742          }
743          if (ref $option{capitalize}) {
744            $name = &{$option{capitalize}} ($self, $name);
745          } elsif ($option{capitalize}) {
746            $name =~ s/((?:^|-)[a-z])/uc($1)/ge;
747          }
748          if (ref $option{fold}) {
749            $fbody = &{$option{fold}} ($self, $fbody);
750          } elsif ($option{fold}) {
751            $fbody = $self->_fold ($fbody);
752          }
753          push @ret, sprintf $option{field_format_pattern}, $name, $fbody;
754        };
755      if ($option{format} =~ /uri-url-mailto-to/) {
756        if ($self->field_exist ('to')) {
757          my $to = $self->field ('to');
758          unless ($to->have_group) {
759            my $fbody = $to->stringify (-format => $option{format});
760            return &{$option{fold}} ($self, $fbody);
761          }
762      }      }
763      return unless length $fbody;      '';
764      $fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;    } elsif ($option{format} =~ /uri-url-mailto/) {
765      $fbody =~ s/\x0A(?=[^\x09\x20])/\x0A\x20/g;      $self->scan ($_stringify);
766      $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $option{capitalize};      my $ret = join ('&', @ret);
767      push @ret, $name.': '.$self->fold ($fbody);      $ret;
768    });    } else {
769    my $ret = join ("\n", @ret);      if ($option{mail_from}) {
770    $ret? $ret."\n": '';        my $fromline = $self->field ('mail-from');
771          push @ret, 'From '.$fromline if $fromline;
772        }
773        $self->scan ($_stringify);
774        my $ret = join ("\n", @ret);
775        $ret? $ret."\n": '';
776      }
777  }  }
778  *as_string = \&stringify;  *as_string = \&stringify;
779    
# Line 623  sub _delete_empty_field ($) { Line 822  sub _delete_empty_field ($) {
822    $self;    $self;
823  }  }
824    
825  sub fold ($$;$) {  sub _fold ($$;$) {
826    my $self = shift;    my $self = shift;
827    my $string = shift;    my $string = shift;
828    my $len = shift || $self->{option}->{fold_length};    my $len = shift || $self->{option}->{fold_length};
Legend:
Removed from v.1.14  
changed lines
  Added in v.1.18
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24