/[suikacvs]/test/cvs
Suika

Diff of /test/cvs

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

revision 1.26 by wakaba, Sun Jun 16 10:45:54 2002 UTC revision 1.31 by wakaba, Sat Jul 6 10:30:10 2002 UTC
# Line 31  push @ISA, qw(Message::Field::Structured Line 31  push @ISA, qw(Message::Field::Structured
31      -_METHODS   => [qw|field field_exist field_type add replace count delete subject id is|],      -_METHODS   => [qw|field field_exist field_type add replace count delete subject id is|],
32      -_MEMBERS   => [qw|value|],      -_MEMBERS   => [qw|value|],
33      -_VALTYPE_DEFAULT   => ':default',      -_VALTYPE_DEFAULT   => ':default',
34      -by => 'name',      ## (Reserved for method level option)      -by => 'name',
35      -field_format_pattern       => '%s: %s',      -field_format_pattern       => '%s: %s',
36      -field_name_case_sensible   => 0,      -field_name_case_sensible   => 0,
37      -field_name_unsafe_rule     => 'NON_ftext',      -field_name_unsafe_rule     => 'NON_ftext',
38      -field_name_validation      => 1,   ## Method level option.      -field_name_validation      => 0,
39      -field_sort => 0,      -field_sort => 0,
40      #-format    => 'mail-rfc2822',      -format     => 'mail-rfc2822',
41      -linebreak_strict   => 0,   ## Not implemented completely      -header_default_charset     => 'iso-2022-int-1',
42        -header_default_charset_input       => 'iso-2022-int-1',
43        -linebreak_strict   => 0,
44      -line_length_max    => 60,  ## For folding      -line_length_max    => 60,  ## For folding
45      #ns_default_phuri      #ns_default_phuri
46      -output_bcc => 0,      -output_bcc => 0,
47      -output_folding     => 1,      -output_folding     => 1,
48      -output_mail_from   => 0,      -output_mail_from   => 0,
49      #-parse_all => 0,      #parse_all
50      -translate_underscore       => 1,      -translate_underscore       => 1,
51      #-uri_mailto_safe      #uri_mailto_safe
52      -uri_mailto_safe_level      => 4,      -uri_mailto_safe_level      => 4,
53      -use_folding        => 1,      -use_folding        => 1,
54      #-value_type      #value_type
 );  
   
 $DEFAULT{-value_type} = {  
         ':default'      => ['Message::Field::Unstructured'],  
           
         p3p     => ['Message::Field::Params'],  
         link    => ['Message::Field::ValueParams'],  
           
         'user-agent'    => ['Message::Field::UA'],  
         server  => ['Message::Field::UA'],  
 };  
 for (qw(date expires))  
   {$DEFAULT{-value_type}->{$_} = ['Message::Field::Date']}  
 for (qw(accept accept-charset accept-encoding accept-language uri))  
   {$DEFAULT{-value_type}->{$_} = ['Message::Field::CSV']}  
 for (qw(location referer))  
   {$DEFAULT{-value_type}->{$_} = ['Message::Field::URI']}  
   
 my %header_goodcase = (  
         'article-i.d.'  => 'Article-I.D.',  
         etag    => 'ETag',  
         'pics-label'    => 'PICS-Label',  
         te      => 'TE',  
         url     => 'URL',  
         'www-authenticate'      => 'WWW-Authenticate',  
55  );  );
56    
57  ## taken from L<HTTP::Header>  ## taken from L<HTTP::Header>
# Line 122  sub _init ($;%) { Line 99  sub _init ($;%) {
99    $self->SUPER::_init (%$DEFAULT, %options);    $self->SUPER::_init (%$DEFAULT, %options);
100    $self->{value} = [];    $self->{value} = [];
101    $self->_ns_load_ph ('default');    $self->_ns_load_ph ('default');
102    $self->_ns_load_ph ('rfc822');    $self->_ns_load_ph ('x-rfc822');
103    $self->{option}->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'rfc822'}    $self->_ns_load_ph ('x-http');
104      $self->{option}->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'x-rfc822'}
105      unless $self->{option}->{ns_default_phuri};      unless $self->{option}->{ns_default_phuri};
106        
107      ## For text/rfc822-headers
108      if (ref $options{entity_header}) {
109        $self->{entity_header} = $options{entity_header};
110        delete $options{entity_header};
111      }
112    my @new_fields = ();    my @new_fields = ();
113    for my $name (keys %options) {    for my $name (keys %options) {
114      unless (substr ($name, 0, 1) eq '-') {      unless (substr ($name, 0, 1) eq '-') {
# Line 147  sub _init ($;%) { Line 130  sub _init ($;%) {
130  sub _init_by_format ($$\%) {  sub _init_by_format ($$\%) {
131    my $self = shift;    my $self = shift;
132    my ($format, $option) = @_;    my ($format, $option) = @_;
133    if ($format =~ /cgi/) {    if ($format =~ /http/) {
134      unshift @header_order, qw(content-type location);      $option->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'x-http'};
135      $option->{field_sort} = 'good-practice';      if ($format =~ /cgi/) {
136      $option->{use_folding} = 0;        unshift @header_order, qw(content-type location);
137    } elsif ($format =~ /http/) {        $option->{field_sort} = 'good-practice';
138      $option->{field_sort} = 'good-practice';        $option->{use_folding} = 0;
139        } else {
140          $option->{field_sort} = 'good-practice';
141        }
142      } else {      ## RFC 822
143        $option->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'x-rfc822'};
144    }    }
145    if ($format =~ /uri-url-mailto/) {    if ($format =~ /uri-url-mailto/) {
146      $option->{output_bcc} = 0;      $option->{output_bcc} = 0;
# Line 194  sub parse ($$;%) { Line 182  sub parse ($$;%) {
182    my $class = shift;    my $class = shift;
183    my $header = shift;    my $header = shift;
184    my $self = bless {}, $class;    my $self = bless {}, $class;
185    $self->_init (@_);    ## BUG: don't check linebreak_strict    $self->_init (@_);
186    $header =~ s/\x0D?\x0A$REG{WSP}/\x20/gos if $self->{option}->{use_folding};    if ($self->{option}->{linebreak_strict}) {
187        $header =~ s/\x0D\x0A$REG{WSP}/\x20/gos if $self->{option}->{use_folding};
188      } else {
189        $header =~ s/\x0D?\x0A$REG{WSP}/\x20/gos if $self->{option}->{use_folding};
190      }
191    for my $field (split /\x0D?\x0A/, $header) {    for my $field (split /\x0D?\x0A/, $header) {
192      if ($field =~ /$REG{M_fromline}/) {      if ($field =~ /$REG{M_fromline}/) {
193        my ($s,undef,$value) = $self->_value_to_arrayitem        my ($s,undef,$value) = $self->_value_to_arrayitem
# Line 213  sub parse ($$;%) { Line 205  sub parse ($$;%) {
205        push @{$self->{value}}, $value if $s;        push @{$self->{value}}, $value if $s;
206      }      }
207    }    }
208      $self->_ns_associate_numerical_prefix;        ## RFC 2774 namespace
209    $self;    $self;
210  }  }
211    
# Line 265  sub parse_array ($\@;%) { Line 258  sub parse_array ($\@;%) {
258      }      }
259      last if $#$header < 0;      last if $#$header < 0;
260    }    }
261      $self->_ns_associate_numerical_prefix;        ## RFC 2774 namespace
262    $self;    $self;
263  }  }
264    
# Line 290  sub _item_match ($$\$\%\%) { Line 284  sub _item_match ($$\$\%\%) {
284    my ($by, $i, $list, $option) = @_;    my ($by, $i, $list, $option) = @_;
285    return 0 unless ref $$i;  ## Already removed    return 0 unless ref $$i;  ## Already removed
286    if ($by eq 'name') {    if ($by eq 'name') {
287      my %o = %$option; $o{parse} = 0;      my %o = %$option; #$o{parse} = 0;
288      my %l;      my %l;
289      for (keys %$list) {      for (keys %$list) {
290        my ($s, undef, $v) = $self->_value_to_arrayitem ($_, '', %o);        my ($s, undef, $v) = $self->_value_to_arrayitem ($_, '', %o);
# Line 303  sub _item_match ($$\$\%\%) { Line 297  sub _item_match ($$\$\%\%) {
297      return 1 if $l{$$i->{name} . ':' . $$i->{ns}};      return 1 if $l{$$i->{name} . ':' . $$i->{ns}};
298    } elsif ($by eq 'ns') {    } elsif ($by eq 'ns') {
299      return 1 if $list->{ $$i->{ns} };      return 1 if $list->{ $$i->{ns} };
300      } elsif ($by eq 'http-ns-define') {
301        if ($$i->{ns} eq $self->{ns}->{phname2uri}->{'x-http'}
302         || $$i->{ns} eq $self->{ns}->{phname2uri}->{'x-http-c'}) {
303          my $n = $$i->{name};
304          if ($n eq 'opt' || $n eq 'c-opt' || $n eq 'man' || $n eq 'c-man') {
305            $option->{parse} = 0;
306            $$i->{body} = $self->_parse_value ($$i->{name} => $$i->{body}, ns => $$i->{ns});
307            for my $j (0..$$i->{body}->count-1) {
308              return 1 if $list->{ ($$i->{body}->value ($j))[0]->value };
309            }
310          }
311        }
312    }    }
313    0;    0;
314  }  }
# Line 323  sub _item_return_value ($\$\%) { Line 329  sub _item_return_value ($\$\%) {
329    
330  ## Returns returned (new created) item value    $name, \%option  ## Returns returned (new created) item value    $name, \%option
331  sub _item_new_value ($$\%) {  sub _item_new_value ($$\%) {
332      my ($s,undef,$value) = $_[0]->_value_to_arrayitem    my $self = shift;
333          ($_[1] => '', $_[2]);    my ($name, $option) = @_;
334      if ($option->{by} eq 'http-ns-define') {
335        my $value = $self->_parse_value (opt => '', ns => $self->{ns}->{phname2uri}->{'x-http'});
336        ($value->value (0))[0]->value ($name);
337        {name => 'opt', body => $value, ns => $self->{ns}->{phname2uri}->{'x-http'}};
338      } else {
339        my ($s,undef,$value) = $self->_value_to_arrayitem
340            ($name => '', $option);
341      $s? $value: undef;      $s? $value: undef;
342      }
343  }  }
344    
345    
# Line 355  sub _parse_value ($$$;%) { Line 369  sub _parse_value ($$$;%) {
369        -format   => $self->{option}->{format},        -format   => $self->{option}->{format},
370        -field_ns => $option{ns},        -field_ns => $option{ns},
371        -field_name       => $name,        -field_name       => $name,
372        -header_default_charset     => $self->{option}->{header_default_charset},
373        -header_default_charset_input       => $self->{option}->{header_default_charset_input},
374        -parse_all        => $self->{option}->{parse_all},        -parse_all        => $self->{option}->{parse_all},
375      %vopt);      %vopt);
376    } else {    } else {
# Line 363  sub _parse_value ($$$;%) { Line 379  sub _parse_value ($$$;%) {
379        -format   => $self->{option}->{format},        -format   => $self->{option}->{format},
380        -field_ns => $option{ns},        -field_ns => $option{ns},
381        -field_name       => $name,        -field_name       => $name,
382        -header_default_charset     => $self->{option}->{header_default_charset},
383        -header_default_charset_input       => $self->{option}->{header_default_charset_input},
384        -parse_all        => $self->{option}->{parse_all},        -parse_all        => $self->{option}->{parse_all},
385      %vopt);      %vopt);
386    }    }
387  }  }
388    
389    ## Defined for text/rfc822-headers
390    sub entity_header ($;$) {
391      my $self = shift;
392      my $new_header = shift;
393      if (ref $new_header) {
394        $self->{header} = $new_header;
395      }
396      $self->{header};
397    }
398    
399  =head2 $self->field_name_list ()  =head2 $self->field_name_list ()
400    
401  Returns list of all C<field-name>s.  (Even if there are two  Returns list of all C<field-name>s.  (Even if there are two
# Line 429  sub _value_to_arrayitem ($$$\%) { Line 457  sub _value_to_arrayitem ($$$\%) {
457      ($value, %$value_option) = @$value;      ($value, %$value_option) = @$value;
458    }    }
459    my $nsuri = $self->{option}->{ns_default_phuri};    my $nsuri = $self->{option}->{ns_default_phuri};
460      $name =~ s/^$REG{WSP}+//;  $name =~ s/$REG{WSP}+$//;
461        
462    no strict 'refs';    no strict 'refs';
463    if ($value_option->{ns}) {    if ($value_option->{ns}) {
464      $nsuri = $value_option->{ns};      $nsuri = $value_option->{ns};
465    } elsif ($option->{ns}) {    } elsif ($option->{ns}) {
466      $nsuri = $option->{ns};      $nsuri = $option->{ns};
467    } elsif ($name =~ s/^([Xx]-[A-Za-z]+|[A-Za-z]+)-//) {    } elsif (($option->{ns_default_phuri} eq $self->{ns}->{uri2phname}->{'x-http'}
468      my $oprefix = $1;         && $name =~ s/^([0-9]+)-//)
469        || ($name =~ s/^x-http-([0-9]+)-//i)) {     ## Numric namespace prefix, RFC 2774
470        my $prefix = 0+$1;
471        $nsuri = $self->{ns}->{number2uri}->{ $prefix };
472        unless ($nsuri) {
473          $self->{ns}->{number2uri}->{ $prefix } = 'urn:x-suika-fam-cx:msgpm:header:x-temp:'.$prefix;
474          $nsuri = $self->{ns}->{number2uri}->{ $prefix };
475        }
476      } elsif (($name =~ s/^([Xx]-[A-Za-z]+|[A-YZa-yz][A-Za-z]*)-
477                           ([Xx]-[A-Za-z]+|[A-YZa-yz][A-Za-z]*)-//x)
478        || $name =~ s/^([Xx]-[A-Za-z]+|[A-Za-z]+)-//) {
479        my ($prefix1, $prefix2) = ($1, $2);
480        my $original_prefix = $&;  my $one_prefix = 0;
481        unless ($prefix2) {
482          $prefix2 = $prefix1;
483          $prefix1 = $self->{ns}->{uri2phname}->{ $option->{ns_default_phuri} };
484          $one_prefix = 1;
485        }
486      my $prefix      my $prefix
487        = &{${&_NS_uri2phpackage ($nsuri).'::OPTION'}{n11n_prefix}}        = &{ ${ &_NS_uri2phpackage ($nsuri).'::OPTION' }{n11n_prefix} }
488          ($self, &_NS_uri2phpackage ($nsuri), $oprefix);          ($self, &_NS_uri2phpackage ($nsuri), $prefix1.'-'.$prefix2);
489      $self->_ns_load_ph ($prefix);      $self->_ns_load_ph ($prefix);
490      $nsuri = $self->{ns}->{phname2uri}->{$prefix};      $nsuri = $self->{ns}->{phname2uri}->{ $prefix };
491      unless ($nsuri) {      unless ($nsuri) {
       $name = $oprefix . '-' . $name;  
492        $nsuri = $self->{option}->{ns_default_phuri};        $nsuri = $self->{option}->{ns_default_phuri};
493          $prefix
494            = &{ ${ &_NS_uri2phpackage ($nsuri).'::OPTION' }{n11n_prefix} }
495              ($self, &_NS_uri2phpackage ($nsuri), $one_prefix? $prefix2: $prefix1);
496          $self->_ns_load_ph ($prefix);
497          $nsuri = $self->{ns}->{phname2uri}->{ $prefix };
498          if ($nsuri) {
499            $name = $prefix2 . '-' . $name unless $one_prefix;
500          } else {
501            $name = $original_prefix . $name;
502            $nsuri = $self->{option}->{ns_default_phuri};
503          }
504      }      }
505    }    }
506    $name    $name
# Line 562  sub _scan_sort ($\@\%) { Line 618  sub _scan_sort ($\@\%) {
618  }  }
619    
620  sub _n11n_field_name ($$) {  sub _n11n_field_name ($$) {
621      no strict 'refs';
622    my $self = shift;    my $self = shift;
623    my $s = shift;    my $s = shift;
624    $s =~ s/^$REG{WSP}+//; $s =~ s/$REG{WSP}+$//;    $s =~ s/^$REG{WSP}+//; $s =~ s/$REG{WSP}+$//;
# Line 598  sub stringify ($;%) { Line 655  sub stringify ($;%) {
655    $self->_init_by_format ($option{format}, \%option);    $self->_init_by_format ($option{format}, \%option);
656    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
657    my @ret;    my @ret;
658      ## RFC 2774 numerical field name prefix
659      my %nprefix;
660      {no strict 'refs';
661        %nprefix = reverse %{ $self->{ns}->{number2uri} };
662        my $i = (sort { $a <=> $b } keys %{ $self->{ns}->{number2uri} })[-1] + 1;
663        $i = 10 if $i < 10;
664        my $hprefix = ${ &_NS_uri2phpackage
665                           ($self->{ns}->{phname2uri}->{'x-http'})
666                           .'::OPTION' } {namespace_phname_goodcase};
667        for my $uri (keys %nprefix) {
668          if ($nprefix{ $uri } < 10) {
669            $nprefix{ $uri } = $i++;
670          }
671          my $nsfs = $self->item ($uri, -by => 'http-ns-define');
672          for my $i (0..$nsfs->count-1) {
673            my $nsf = ($nsfs->value ($i))[0];
674            if ($nsf->value eq $uri) {
675              $nsf->replace (ns => $nprefix{ $uri });
676              $nprefix{ $uri } = $hprefix . '-' . $nprefix{ $uri };
677              last;
678            }
679          }
680        }
681      }
682    my $_stringify = sub {    my $_stringify = sub {
683      no strict 'refs';      no strict 'refs';
684        my ($name, $body, $nsuri) = ($_[1]->{name}, $_[1]->{body}, $_[1]->{ns});        my ($name, $body, $nsuri) = ($_[1]->{name}, $_[1]->{body}, $_[1]->{ns});
685        return unless length $name;        return unless length $name;
686        return if $option{output_mail_from} && $name eq 'mail-from';        return if $option{output_mail_from} && $name eq 'mail-from';
687        return if !$option{output_bcc} && ($name eq 'bcc' || $name eq 'resent-bcc');        $body = '' if !$option{output_bcc} && $name eq 'bcc';
688        my $nspackage = &_NS_uri2phpackage ($nsuri);        my $nspackage = &_NS_uri2phpackage ($nsuri);
689        my $oname;        ## Outputed field-name        my $oname;        ## Outputed field-name
690        my $prefix = ${$nspackage.'::OPTION'} {namespace_phname_goodcase}        my $prefix = $nprefix{ $nsuri }
691                  || $self->{ns}->{uri2phname}->{$nsuri};                  || ${$nspackage.'::OPTION'} {namespace_phname_goodcase}
692        $prefix = undef if $nsuri eq $self->{option}->{ns_default_phuri};                  || $self->{ns}->{uri2phname}->{ $nsuri };
693          my $default_prefix = ${ &_NS_uri2phpackage ($option{ns_default_phuri})
694                                  .'::OPTION'} {namespace_phname_goodcase};
695          $prefix = '' if $prefix eq $default_prefix;
696          $prefix =~ s/^\Q$default_prefix\E-//;
697          #$prefix = undef if $nsuri eq $option{ns_default_phuri};
698          #if ($prefix && $prefix eq $nprefix{ $nsuri }) {  ## RFC 2774 prefix
699          #  $prefix = ${ &_NS_uri2phpackage ($self->{ns}->{phname2uri}->{'x-http'})
700          #               .'::OPTION' } {namespace_phname_goodcase} . '-' . $prefix
701          #  unless $option{ns_default_phuri} eq $self->{ns}->{phname2uri}->{'x-http'};
702          #}
703        my $gc = ${$nspackage.'::OPTION'} {to_be_goodcase};        my $gc = ${$nspackage.'::OPTION'} {to_be_goodcase};
704        if (ref $gc) { $oname = &$gc ($self, $nspackage, $name, \%option) }        if (ref $gc) { $oname = &$gc ($self, $nspackage, $name, \%option) }
705        else { $oname = $name }        else { $oname = $name }
# Line 633  sub stringify ($;%) { Line 724  sub stringify ($;%) {
724        } else {        } else {
725          $fbody = $body;          $fbody = $body;
726        }        }
727        return unless length $fbody;        unless (${$nspackage.'::OPTION'} {field}->{$name}->{empty_body}) {
728            return unless length $fbody;
729          }
730        unless ($option{linebreak_strict}) {        unless ($option{linebreak_strict}) {
731          ## bare \x0D and bare \x0A are unsafe          ## bare \x0D and bare \x0A are unsafe
732          $fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;          $fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;
# Line 719  sub _fold ($$;%) { Line 812  sub _fold ($$;%) {
812    $max = 20 if $max < 20;    $max = 20 if $max < 20;
813        
814    my $l = $option{-initial_length} || 0;    my $l = $option{-initial_length} || 0;
815    $string =~ s{((?:^|[\x09\x20])[^\x09\x20]+)}{    $l += length $1 if $string =~ /^([^\x09\x20]+)/;
816      $string =~ s{([\x09\x20][^\x09\x20]+)}{
817      my $s = $1;      my $s = $1;
818      if ($l + length $s > $max) {      if (($l + length $s) > $max) {
819        $s = "\x0D\x0A\x20" . $s;        $s = "\x0D\x0A\x20" . $s;
820        $l = length ($s) - 2;        $l = 1 + length $s;
821      } else { $l += length $s }      } else { $l += length $s }
822      $s;      $s;
823    }gex;    }gex;
# Line 739  sub _ns_load_ph ($$) { Line 833  sub _ns_load_ph ($$) {
833    $self->{ns}->{uri2phname}->{$self->{ns}->{phname2uri}->{$name}} = $name;    $self->{ns}->{uri2phname}->{$self->{ns}->{phname2uri}->{$name}} = $name;
834  }  }
835    
836    sub _ns_associate_numerical_prefix ($) {
837      my $self = shift;
838      $self->scan (sub {shift;
839        my $f = shift;  return unless $f->{name};
840        if ($f->{ns} eq $self->{ns}->{phname2uri}->{'x-http'}
841         || $f->{ns} eq $self->{ns}->{phname2uri}->{'x-http-c'}) {
842          my $fn = $f->{name};
843          if ($fn eq 'opt' || $fn eq 'man') {
844            $f->{body} = $self->_parse_value ($fn => $f->{body}, ns => $f->{ns});
845            for ($f->{body}->value (0..$f->{body}->count-1)) {
846              my ($nsuri, $number) = ($_->value, $_->item ('ns'));
847              if ($number && $nsuri) {
848                $self->{ns}->{number2uri}->{ $number } = $nsuri;
849              }
850            }
851          }
852        }
853      });
854      $self->scan (sub {shift;
855        my $f = shift;
856        if ($f->{ns} =~ /urn:x-suika-fam-cx:msgpm:header:x-temp:([0-9]+)$/ && $self->{ns}->{number2uri}->{ $1 }) {
857          $f->{ns} = $self->{ns}->{number2uri}->{ $1 };
858        }
859      });
860    }
861    
862    ## $package_name = Message::Header::_NS_uri2phpackage ($nsuri)
863    ## (For internal use of Message::* modules)
864  sub _NS_uri2phpackage ($) {  sub _NS_uri2phpackage ($) {
865    $NS_uri2phpackage{$_[0]}    $NS_uri2phpackage{$_[0]}
866    || $NS_uri2phpackage{$Message::Header::Default::OPTION{namespace_uri}};    || $NS_uri2phpackage{$Message::Header::Default::OPTION{namespace_uri}};
Legend:
Removed from v.1.26  
changed lines
  Added in v.1.31
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24