/[suikacvs]/test/cvs
Suika

Diff of /test/cvs

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

revision 1.17 by wakaba, Sun Apr 21 04:28:46 2002 UTC revision 1.18 by wakaba, Tue May 14 13:50:11 2002 UTC
# Line 61  my %DEFAULT = ( Line 61  my %DEFAULT = (
61    field_format_pattern  => '%s: %s',    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 75  $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            p3p     => 'Message::Field::Params',
114          'auto-submitted'        => 'Message::Field::ValueParams',          'auto-submitted'        => 'Message::Field::ValueParams',
115          'content-disposition'   => 'Message::Field::ValueParams',          '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 88  $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          ## Numeric value
134          'content-length'        => 'Message::Field::Numval',          'content-length'        => 'Message::Field::Numval',
135          lines   => 'Message::Field::Numval',          lines   => 'Message::Field::Numval',
# Line 104  for (qw(archive cancel-lock content-feat Line 146  for (qw(archive cancel-lock content-feat
146    disposition-notification-options encoding    disposition-notification-options encoding
147    importance injector-info    importance injector-info
148    pics-label posted-and-mailed precedence list-id message-type    pics-label posted-and-mailed precedence list-id message-type
149    original-recipient priority    original-recipient priority x-list-id
150    sensitivity status x-face x-msmail-priority xref))    sensitivity status x-face x-msmail-priority xref))
151    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}    {$DEFAULT{field_type}->{$_} = 'Message::Field::Structured'}
152          ## Not supported yet, but to be supported...          ## Not supported yet, but to be supported...
153            # x-list: unstructured, ml name
154  for (qw(abuse-reports-to apparently-to approved approved-by bcc cc complaints-to  for (qw(abuse-reports-to apparently-to approved approved-by bcc cc complaints-to
155    delivered-to disposition-notification-to envelope-to    delivered-to disposition-notification-to envelope-to
156    errors-to  from mail-copies-to mail-followup-to mail-reply-to    errors-to  from mail-copies-to mail-followup-to mail-reply-to
# Line 122  for (qw(abuse-reports-to apparently-to a Line 165  for (qw(abuse-reports-to apparently-to a
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))    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 posted-date reply-by resent-date    expire-date nntp-posting-date posted posted-date received-date
170      reply-by resent-date
171    x-originalarrivaltime x-tcup-date))    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    obsoletes references replaces 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    posted-to    posted-to))
   x-brother x-daughter x-respect x-moe x-syster x-wife))  
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 185  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';  
     $self->{option}->{fold} = 0;  
   } 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  =item Message::Header->new ([%initial-fields/options])  =item Message::Header->new ([%initial-fields/options])
# Line 240  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 283  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 376  sub _field_body ($$$) { Line 483  sub _field_body ($$$) {
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          , field_name => $name, format => $self->{option}->{format});          -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});           field_name => $name,format => $self->{option}->{format});
494      }      }
495    }    }
# Line 428  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 599  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      $fbody = $self->_fold ($fbody) if $self->{option}->{fold};      $ret;
768      push @ret, sprintf $self->{option}->{field_format_pattern}, $name, $fbody;    } else {
769    });      if ($option{mail_from}) {
770    my $ret = join ("\n", @ret);        my $fromline = $self->field ('mail-from');
771    $ret? $ret."\n": '';        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    
Legend:
Removed from v.1.17  
changed lines
  Added in v.1.18
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24