/[suikacvs]/test/cvs
Suika

Diff of /test/cvs

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

revision 1.15 by wakaba, Fri Apr 5 14:56:26 2002 UTC revision 1.19 by wakaba, Wed May 15 07:31:28 2002 UTC
# Line 51  The following methods construct new C<Me Line 51  The following methods construct new C<Me
51    
52  =over 4  =over 4
53    
54    =cut
55    
56  ## Initialize  ## 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 71  $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',          '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',
123                    
124          'list-software' => 'Message::Field::UA',          'list-software' => 'Message::Field::UA',
125          'user-agent'    => 'Message::Field::UA',          'user-agent'    => 'Message::Field::UA',
126            'resent-user-agent'     => 'Message::Field::UA',
127          server  => 'Message::Field::UA',          server  => 'Message::Field::UA',
128                    
129            ## A message id
130            'content-id'    => 'Message::Field::MsgID',
131            'message-id'    => 'Message::Field::MsgID',
132            'resent-message-id'     => 'Message::Field::MsgID',
133            
134          ## Numeric value          ## Numeric value
135          'content-length'        => 'Message::Field::Numval',          'content-length'        => 'Message::Field::Numval',
136          lines   => 'Message::Field::Numval',          lines   => 'Message::Field::Numval',
137          'max-forwards'  => 'Message::Field::Numval',          'max-forwards'  => 'Message::Field::Numval',
138          'mime-version'  => 'Message::Field::Numval',          'mime-version'  => 'Message::Field::Numval',
139          'x-jsmail-priority'     => 'Message::Field::Numval',          'x-jsmail-priority'     => 'Message::Field::Numval',
140            'x-mail-count'  => 'Message::Field::Numval',
141            'x-ml-count'    => 'Message::Field::Numval',
142          'x-priority'    => 'Message::Field::Numval',          'x-priority'    => 'Message::Field::Numval',
143                    
144          path    => 'Message::Field::Path',          path    => 'Message::Field::Path',
145  };  };
146  for (qw(cancel-lock importance   precedence list-id  for (qw(archive cancel-lock content-features content-md5
147    x-face x-mail-count x-msmail-priority x-priority xref))    disposition-notification-options encoding
148      importance injector-info
149      pics-label posted-and-mailed precedence list-id message-type
150      original-recipient priority x-list-id
151      sensitivity status x-face x-msmail-priority xref))
152    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
153  for (qw(approved bcc cc complaints-to          ## Not supported yet, but to be supported...
154            # x-list: unstructured, ml name
155    for (qw(abuse-reports-to apparently-to approved approved-by bcc cc complaints-to
156    delivered-to disposition-notification-to envelope-to    delivered-to disposition-notification-to envelope-to
157    errors-to fcc from mail-followup-to mail-followup-cc    errors-to  from mail-copies-to mail-followup-to mail-reply-to
158    mail-reply-to    notice-requested-upon-delivery-to read-receipt-to register-mail-reply-requested-by
159    notice-requested-upon-delivery-to reply-to resent-bcc    reply-to resent-bcc
160    resent-cc resent-to resent-from resent-sender return-path    resent-cc resent-to resent-from resent-sender return-path
161    return-receipt-to sender to x-approved x-beenthere    return-receipt-to return-receipt-requested-to sender to x-abuse-reports-to
162      x-admin x-approved x-beenthere x-confirm-reading-to
163    x-complaints-to x-envelope-from x-envelope-sender    x-complaints-to x-envelope-from x-envelope-sender
164    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
165    {$DEFAULT{field_type}->{$_} = 'Message::Field::Address'}    x-rcpt-to x-sender x-x-sender))
166  for (qw(date date-received delivery-date expires    {$DEFAULT{field_type}->{$_} = 'Message::Field::Addresses'}
167    expire-date nntp-posting-date posted reply-by resent-date x-tcup-date))  for (qw(client-date date date-received delivery-date expires
168      expire-date nntp-posting-date posted posted-date received-date
169      reply-by resent-date
170      x-originalarrivaltime x-tcup-date))
171    {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Date'}
172  for (qw(article-updates client-date content-id in-reply-to message-id  for (qw(article-updates in-reply-to
173    references resent-message-id see-also supersedes))    obsoletes references replaces see-also supersedes))
174    {$DEFAULT{field_type}->{$_} = 'Message::Field::MsgID'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::MsgIDs'}
175  for (qw(accept accept-charset accept-encoding accept-language  for (qw(accept accept-charset accept-encoding accept-language
176    content-language    content-language
177    content-transfer-encoding encrypted followup-to keywords    content-transfer-encoding encrypted followup-to keywords
178    list-archive list-digest list-help list-owner    list-archive list-digest list-help list-owner
179    list-post list-subscribe list-unsubscribe list-url uri newsgroups    list-post list-subscribe list-unsubscribe list-url uri newsgroups
180    x-brother x-daughter x-respect x-moe x-syster x-wife))    posted-to))
181    {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}
182    for (qw(x-brother x-boss x-classmate x-daughter x-dearfriend x-favoritesong
183      x-friend x-me
184      x-moe x-respect
185      x-sublimate x-son x-sister x-wife))
186      {$DEFAULT{field_type}->{$_} = 'Message::Field::CSV'}  ## NOT M::F::XMOE!
187  for (qw(content-alias content-base content-location location referer  for (qw(content-alias content-base content-location location referer
188    url x-home-page x-http_referer    url x-home-page x-http_referer
189    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))
190    {$DEFAULT{field_type}->{$_} = 'Message::Field::URI'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::URI'}
191    
192    my %header_goodcase = (
193            'article-i.d.'  => 'Article-I.D.',
194            'content-id'    => 'Content-ID',
195            'content-md5'   => 'Content-MD5',
196            'content-sgml-entity'   => 'Content-SGML-Entity',
197            etag    => 'ETag',
198            fax     => 'FAX',
199            'pics-label'    => 'PICS-Label',
200            'list-url'      => 'List-URL',
201            'list-id'       => 'List-ID',
202            'message-id'    => 'Message-ID',
203            'mime-version'  => 'MIME-Version',
204            'nic'   => 'NIC',
205            'nntp-posting-date'     => 'NNTP-Posting-Date',
206            'nntp-posting-host'     => 'NNTP-Posting-Host',
207            'resent-message-id'     => 'Resent-Message-ID',
208            te      => 'TE',
209            url     => 'URL',
210            'www-authenticate'      => 'WWW-Authenticate',
211            'x-dearfriend'  => 'X-DearFriend',
212            'x-mime-autoconverted'  => 'X-MIME-Autoconverted',
213            'x-nntp-posting-date'   => 'X-NNTP-Posting-Date',
214            'x-nntp-posting-host'   => 'X-NNTP-Posting-Host',
215            'x-uri' => 'X-URI',
216            'x-url' => 'X-URL',
217    );
218    $DEFAULT{capitalize} = sub {
219      my $self = shift;
220      my $name = shift;
221      if ($header_goodcase{$name}) {
222        return $header_goodcase{$name};
223      }
224      $name =~ s/(?:^|-)cgi-/uc $&/ge;
225      $name =~ s/(?:^|-)[a-z]/uc $&/ge;
226      $name;
227    };
228    
229  ## taken from L<HTTP::Header>  ## taken from L<HTTP::Header>
230  # "Good Practice" order of HTTP message headers:  # "Good Practice" order of HTTP message headers:
231  #    - General-Headers  #    - General-Headers
# Line 168  sub _init ($;%) { Line 269  sub _init ($;%) {
269        push @new_fields, ($name => $options{$name});        push @new_fields, ($name => $options{$name});
270      }      }
271    }    }
272    $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';  
   }  
     
273    # Make alternative representations of @header_order.  This is used    # Make alternative representations of @header_order.  This is used
274    # for sorting.    # for sorting.
275    my $i = 1;    my $i = 1;
276    for (@header_order) {    for (@header_order) {
277        $header_order{$_} = $i++ unless $header_order{$_};        $header_order{$_} = $i++ unless $header_order{$_};
278    }    }
279      
280      $self->add (@new_fields, -parse => $self->{option}->{parse_all})
281        if $#new_fields > -1;
282    }
283    
284    sub _init_by_format ($$\%) {
285      my $self = shift;
286      my ($format, $option) = @_;
287      if ($format =~ /rfc822/) {
288        $header_goodcase{bcc} = 'bcc';
289        $header_goodcase{cc} = 'cc';
290        $header_goodcase{'resent-bcc'} = 'Resent-bcc';
291        $header_goodcase{'resent-cc'} = 'Resent-cc';
292      } elsif ($format =~ /cgi/) {
293        unshift @header_order, qw(content-type location);
294        $option->{sort} = 'good-practice';
295        $option->{fold} = 0;
296      } elsif ($format =~ /http/) {
297        $option->{sort} = 'good-practice';
298      }
299      if ($format =~ /uri-url-mailto/) {
300        $option->{output_bcc} = 0;
301        $option->{capitalize} = 0;
302        $option->{field_format_pattern} = '%s=%s';
303        $option->{fold} = sub {
304          $_[1] =~ s/([^:@+\$A-Za-z0-9\-_.!~*])/sprintf('%%%02X', ord $1)/ge;
305          $_[1];
306        };
307      }
308  }  }
309    
310  =item Message::Header->new ([%initial-fields/options])  =item Message::Header->new ([%initial-fields/options])
# Line 222  sub parse ($$;%) { Line 342  sub parse ($$;%) {
342    my $class = shift;    my $class = shift;
343    my $header = shift;    my $header = shift;
344    my $self = bless {}, $class;    my $self = bless {}, $class;
345    $self->_init (@_);    $self->_init (@_);    ## BUG: don't check linebreak_strict
346    $header =~ s/\x0D?\x0A$REG{WSP}/\x20/gos;     ## unfold    $header =~ s/\x0D?\x0A$REG{WSP}/\x20/gos;     ## unfold
347    for my $field (split /\x0D?\x0A/, $header) {    for my $field (split /\x0D?\x0A/, $header) {
348      if ($field =~ /$REG{M_fromline}/) {      if ($field =~ /$REG{M_fromline}/) {
# Line 265  sub parse_array ($\@;%) { Line 385  sub parse_array ($\@;%) {
385          $field .= shift @$header;          $field .= shift @$header;
386        } else {last}        } else {last}
387      }      }
388      $field =~ tr/\x0D\x0A//d;   ## BUG: not safe for bar CR/LF      if ($self->{option}->{linebreak_strict}) {
389          $field =~ s/\x0D\x0A//g;
390        } else {
391          $field =~ tr/\x0D\x0A//d;
392        }
393      if ($field =~ /$REG{M_fromline}/) {      if ($field =~ /$REG{M_fromline}/) {
394        my $body = $1;        my $body = $1;
395        $body = $self->_field_body ($body, 'mail-from')        $body = $self->_field_body ($body, 'mail-from')
# Line 357  sub _field_body ($$$) { Line 481  sub _field_body ($$$) {
481              || $self->{option}->{field_type}->{':DEFAULT'};              || $self->{option}->{field_type}->{':DEFAULT'};
482      eval "require $type" or Carp::croak ("_field_body: $type: $@");      eval "require $type" or Carp::croak ("_field_body: $type: $@");
483      unless ($body) {      unless ($body) {
484        $body = $type->new (-field_name => $name,        $body = $type->new (-field_name => $name,
485          -format => $self->{option}->{format});          -format => $self->{option}->{format},
486            -parse_all => $self->{option}->{parse_all});
487      } else {      } else {
488        $body = $type->parse ($body, -field_name => $name,        $body = $type->parse ($body, -field_name => $name,
489          -format => $self->{option}->{format});          -format => $self->{option}->{format},
490            -parse_all => $self->{option}->{parse_all});
491      }      }
492    }    }
493    $body;    $body;
# Line 381  sub field_name_list ($) { Line 507  sub field_name_list ($) {
507    map {$_->{name}} @{$self->{field}};    map {$_->{name}} @{$self->{field}};
508  }  }
509    
510  =head2 $self->add ($field-name, $field-body, [$name, $body, ...])  =item $hdr->add ($field-name, $field-body, [$name, $body, ...])
511    
512  Adds an new C<field>.  It is not checked whether  Adds some field name/body pairs.  Even if there are
513  the field which named $field_body is already exist or not.  one or more fields named given C<$field-name>,
514  If you don't want duplicated C<field>s, use C<replace> method.  given name/body pairs are ADDed.  Use C<replace>
515    to remove same-name-fields.
516    
517  Instead of field name-body pair, you might pass some options.  Instead of field name-body pair, you might pass some options.
518  Four options are available for this method.  Four options are available for this method.
# Line 407  sub add ($%) { Line 534  sub add ($%) {
534    my $self = shift;    my $self = shift;
535    my %fields = @_;    my %fields = @_;
536    my %option = %{$self->{option}};    my %option = %{$self->{option}};
537    $option{parse} = defined wantarray unless defined $option{parse};    $option{parse} = 1 if defined wantarray;
538    for (grep {/^-/} keys %fields) {$option{substr ($_, 1)} = $fields{$_}}    for (grep {/^-/} keys %fields) {$option{substr ($_, 1)} = $fields{$_}}
539    my $body;    my $body;
540    for (grep {/^[^-]/} keys %fields) {    for (grep {/^[^-]/} keys %fields) {
# Line 471  Deletes C<field> named as $field_name. Line 598  Deletes C<field> named as $field_name.
598    
599  sub delete ($@) {  sub delete ($@) {
600    my $self = shift;    my $self = shift;
601    my %delete;    my %delete;  for (@_) {$delete{lc $_} = 1}
   for (@_) {$delete{lc $_} = 1}  
602    for my $field (@{$self->{field}}) {    for my $field (@{$self->{field}}) {
603      undef $field if $delete{$field->{name}};      undef $field if $delete{$field->{name}};
604    }    }
# Line 579  sub stringify ($;%) { Line 705  sub stringify ($;%) {
705    my $self = shift;    my $self = shift;
706    my %params = @_;    my %params = @_;
707    my %option = %{$self->{option}};    my %option = %{$self->{option}};
708      $option{format} = $params{-format} if $params{-format};
709      $self->_init_by_format ($option{format}, \%option);
710    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
711    my @ret;    my @ret;
712    if ($option{mail_from}) {    my $_stringify = sub {
713      my $fromline = $self->field ('mail-from');        my ($name, $body) = (@_);
714      push @ret, 'From '.$fromline if $fromline;        return unless length $name;
715    }        return if $option{mail_from} && $name eq 'mail-from';
716    $self->scan (sub {        return if !$option{output_bcc} && ($name eq 'bcc' || $name eq 'resent-bcc');
717      my ($name, $body) = (@_);        if ($option{format} =~ /uri-url-mailto/) {
718      return unless length $name;          return if ((   $option{uri_mailto_safe}->{$name}
719      return if $option{mail_from} && $name eq 'mail-from';               || $option{uri_mailto_safe}->{':default'})
720      return if !$option{output_bcc} && ($name eq 'bcc' || $name eq 'resent-bcc');                < $option{uri_mailto_safe_level});
721      my $fbody;          if ($name eq 'to') {
722      if (ref $body) {            $body = $self->field ('to');
723        $fbody = $body->stringify (-format => $option{format});            return unless ref $body && $body->have_group;
724      } else {          }
725        $fbody = $body;        }
726          my $fbody;
727          if (ref $body) {
728            $fbody = $body->stringify (-format => $option{format});
729          } else {
730            $fbody = $body;
731          }
732          return unless length $fbody;
733          unless ($option{linebreak_strict}) {
734            ## bare \x0D and bare \x0A are unsafe
735            $fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;
736            $fbody =~ s/\x0A(?=[^\x09\x20])/\x0A\x20/g;
737          } else {
738            $fbody =~ s/\x0D\x0A(?=[^\x09\x20])/\x0D\x0A\x20/g;
739          }
740          if (ref $option{capitalize}) {
741            $name = &{$option{capitalize}} ($self, $name);
742          } elsif ($option{capitalize}) {
743            $name =~ s/((?:^|-)[a-z])/uc($1)/ge;
744          }
745          if (ref $option{fold}) {
746            $fbody = &{$option{fold}} ($self, $fbody);
747          } elsif ($option{fold}) {
748            $fbody = $self->_fold ($fbody);
749          }
750          push @ret, sprintf $option{field_format_pattern}, $name, $fbody;
751        };
752      if ($option{format} =~ /uri-url-mailto-to/) {
753        if ($self->field_exist ('to')) {
754          my $to = $self->field ('to');
755          unless ($to->have_group) {
756            my $fbody = $to->stringify (-format => $option{format});
757            return &{$option{fold}} ($self, $fbody);
758          }
759      }      }
760      return unless length $fbody;      '';
761      $fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;    } elsif ($option{format} =~ /uri-url-mailto/) {
762      $fbody =~ s/\x0A(?=[^\x09\x20])/\x0A\x20/g;      $self->scan ($_stringify);
763      $name =~ s/((?:^|-)[a-z])/uc($1)/ge if $option{capitalize};      my $ret = join ('&', @ret);
764      push @ret, $name.': '.$self->fold ($fbody);      $ret;
765    });    } else {
766    my $ret = join ("\n", @ret);      if ($option{mail_from}) {
767    $ret? $ret."\n": '';        my $fromline = $self->field ('mail-from');
768          push @ret, 'From '.$fromline if $fromline;
769        }
770        $self->scan ($_stringify);
771        my $ret = join ("\n", @ret);
772        $ret? $ret."\n": '';
773      }
774  }  }
775  *as_string = \&stringify;  *as_string = \&stringify;
776    
# Line 652  sub _delete_empty_field ($) { Line 819  sub _delete_empty_field ($) {
819    $self;    $self;
820  }  }
821    
822  sub fold ($$;$) {  sub _fold ($$;$) {
823    my $self = shift;    my $self = shift;
824    my $string = shift;    my $string = shift;
825    my $len = shift || $self->{option}->{fold_length};    my $len = shift || $self->{option}->{fold_length};
Legend:
Removed from v.1.15  
changed lines
  Added in v.1.19
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24