/[suikacvs]/test/cvs
Suika

Diff of /test/cvs

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

revision 1.33 by wakaba, Sun Jul 7 00:46:07 2002 UTC revision 1.40 by wakaba, Sat Jul 27 04:44:25 2002 UTC
# Line 41  push @ISA, qw(Message::Field::Structured Line 41  push @ISA, qw(Message::Field::Structured
41      -format     => 'mail-rfc2822',      -format     => 'mail-rfc2822',
42      -header_default_charset     => 'iso-2022-int-1',      -header_default_charset     => 'iso-2022-int-1',
43      -header_default_charset_input       => 'iso-2022-int-1',      -header_default_charset_input       => 'iso-2022-int-1',
44        -hook_init_fill_options     => sub {},
45        -hook_stringify_fill_fields => sub {},
46      -linebreak_strict   => 0,      -linebreak_strict   => 0,
47      -line_length_max    => 60,  ## For folding      -line_length_max    => 60,  ## For folding
48      #ns_default_phuri      #ns_default_phuri
# Line 55  push @ISA, qw(Message::Field::Structured Line 57  push @ISA, qw(Message::Field::Structured
57      #value_type      #value_type
58  );  );
59    
 ## taken from L<HTTP::Header>  
 # "Good Practice" order of HTTP message headers:  
 #    - General-Headers  
 #    - Request-Headers  
 #    - Response-Headers  
 #    - Entity-Headers  
 # (From draft-ietf-http-v11-spec-rev-01, Nov 21, 1997)  
 my @header_order = qw(  
   mail-from x-envelope-from relay-version path status  
   
    cache-control connection date pragma transfer-encoding upgrade trailer via  
   
    accept accept-charset accept-encoding accept-language  
    authorization expect from host  
    if-modified-since if-match if-none-match if-range if-unmodified-since  
    max-forwards proxy-authorization range referer te user-agent  
   
    accept-ranges age location proxy-authenticate retry-after server vary  
    warning www-authenticate  
   
    mime-version  
    allow content-base content-encoding content-language content-length  
    content-location content-md5 content-range content-type  
    etag expires last-modified content-style-type content-script-type  
    link  
   
   xref  
 );  
 my %header_order;  
   
60  =head1 CONSTRUCTORS  =head1 CONSTRUCTORS
61    
62  The following methods construct new C<Message::Header> objects:  The following methods construct new C<Message::Header> objects:
# Line 116  sub _init ($;%) { Line 88  sub _init ($;%) {
88        push @new_fields, ($name => $options{$name});        push @new_fields, ($name => $options{$name});
89      }      }
90    }    }
91      &{ $self->{option}->{hook_init_fill_options} } ($self, $self->{option});
92    $self->_init_by_format ($self->{option}->{format}, $self->{option});    $self->_init_by_format ($self->{option}->{format}, $self->{option});
   # Make alternative representations of @header_order.  This is used  
   # for sorting.  
   my $i = 1;  
   for (@header_order) {  
       $header_order{$_} = $i++ unless $header_order{$_};  
   }  
     
93    $self->add (@new_fields, -parse => $self->{option}->{parse_all})    $self->add (@new_fields, -parse => $self->{option}->{parse_all})
94      if $#new_fields > -1;      if $#new_fields > -1;
95  }  }
# Line 134  sub _init_by_format ($$\%) { Line 100  sub _init_by_format ($$\%) {
100    if ($format =~ /http/) {    if ($format =~ /http/) {
101      $option->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'x-http'};      $option->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'x-http'};
102      if ($format =~ /cgi/) {      if ($format =~ /cgi/) {
103        unshift @header_order, qw(content-type location);        #unshift @header_order, qw(content-type location);
104        $option->{field_sort} = 'good-practice';        $option->{field_sort} = 'good-practice';
105        $option->{use_folding} = 0;        $option->{use_folding} = 0;
106      } else {      } else {
107        $option->{field_sort} = 'good-practice';        $option->{field_sort} = 'good-practice';
108      }      }
109    } else {      ## RFC 822    } elsif ($format =~ /mail|news|mime/) {       ## RFC 822
110      $option->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'x-rfc822'};      $option->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'x-rfc822'};
111    }    }
112    if ($format =~ /uri-url-mailto/) {    if ($format =~ /uri-url-mailto/) {
# Line 298  sub _item_match ($$\$\%\%) { Line 264  sub _item_match ($$\$\%\%) {
264      my %o = %$option; #$o{parse} = 0;      my %o = %$option; #$o{parse} = 0;
265      my %l;      my %l;
266      for (keys %$list) {      for (keys %$list) {
267        my ($s, undef, $v) = $self->_value_to_arrayitem ($_, '', %o);        my ($s, undef, $v) = $self->_value_to_arrayitem ($_, '', \%o);
268        if ($s) {        if ($s) {
269          $l{$v->{name} . ':' . ( $option->{ns} || $v->{ns} ) } = 1;          $l{$v->{name} . ':' . ( $option->{ns} || $v->{ns} ) } = 1;
270        } else {        } else {
# Line 374  sub _parse_value ($$$;%) { Line 340  sub _parse_value ($$$;%) {
340    my %vopt = %{$vtype->[1]} if ref $vtype->[1];    my %vopt = %{$vtype->[1]} if ref $vtype->[1];
341    if ($vpackage eq ':none:') {    if ($vpackage eq ':none:') {
342      return $value;      return $value;
343    } elsif (defined $value) {    } elsif (length $value) {
344      eval "require $vpackage" or Carp::croak qq{<parse>: $vpackage: Can't load package: $@};      eval "require $vpackage" or Carp::croak qq{<parse>: $vpackage: Can't load package: $@};
345      return $vpackage->parse ($value,      return $vpackage->parse ($value,
346        -format   => $self->{option}->{format},        -format   => $self->{option}->{format},
# Line 382  sub _parse_value ($$$;%) { Line 348  sub _parse_value ($$$;%) {
348        -field_name       => $name,        -field_name       => $name,
349      -header_default_charset     => $self->{option}->{header_default_charset},      -header_default_charset     => $self->{option}->{header_default_charset},
350      -header_default_charset_input       => $self->{option}->{header_default_charset_input},      -header_default_charset_input       => $self->{option}->{header_default_charset_input},
351        -internal_charset_name      => $self->{option}->{internal_charset_name},
352        -parse_all        => $self->{option}->{parse_all},        -parse_all        => $self->{option}->{parse_all},
353      %vopt);      %vopt);
354    } else {    } else {
# Line 392  sub _parse_value ($$$;%) { Line 359  sub _parse_value ($$$;%) {
359        -field_name       => $name,        -field_name       => $name,
360      -header_default_charset     => $self->{option}->{header_default_charset},      -header_default_charset     => $self->{option}->{header_default_charset},
361      -header_default_charset_input       => $self->{option}->{header_default_charset_input},      -header_default_charset_input       => $self->{option}->{header_default_charset_input},
362        -internal_charset_name      => $self->{option}->{internal_charset_name},
363        -parse_all        => $self->{option}->{parse_all},        -parse_all        => $self->{option}->{parse_all},
364      %vopt);      %vopt);
365    }    }
# Line 467  sub _value_to_arrayitem ($$$\%) { Line 435  sub _value_to_arrayitem ($$$\%) {
435    if (ref $value eq 'ARRAY') {    if (ref $value eq 'ARRAY') {
436      ($value, %$value_option) = @$value;      ($value, %$value_option) = @$value;
437    }    }
438    my $nsuri = $self->{option}->{ns_default_phuri};    my $default_ns = $option->{ns_default_phuri};
439      my $nsuri = $default_ns;
440    $name =~ s/^$REG{WSP}+//;  $name =~ s/$REG{WSP}+$//;    $name =~ s/^$REG{WSP}+//;  $name =~ s/$REG{WSP}+$//;
441        
442    no strict 'refs';    no strict 'refs';
# Line 475  sub _value_to_arrayitem ($$$\%) { Line 444  sub _value_to_arrayitem ($$$\%) {
444      $nsuri = $value_option->{ns};      $nsuri = $value_option->{ns};
445    } elsif ($option->{ns}) {    } elsif ($option->{ns}) {
446      $nsuri = $option->{ns};      $nsuri = $option->{ns};
447    } elsif (($option->{ns_default_phuri} eq $self->{ns}->{uri2phname}->{'x-http'}    } elsif (($default_ns eq $self->{ns}->{phname2uri}->{'x-http'}
448         && $name =~ s/^([0-9]+)-//)         && $name =~ s/^([0-9]+)-//)
449      || ($name =~ s/^x-http-([0-9]+)-//i)) {     ## Numric namespace prefix, RFC 2774      || ($name =~ s/^x-http-([0-9]+)-//i)) {     ## Numric namespace prefix, RFC 2774
450      my $prefix = 0+$1;      my $prefix = 0+$1;
# Line 484  sub _value_to_arrayitem ($$$\%) { Line 453  sub _value_to_arrayitem ($$$\%) {
453        $self->{ns}->{number2uri}->{ $prefix } = 'urn:x-suika-fam-cx:msgpm:header:x-temp:'.$prefix;        $self->{ns}->{number2uri}->{ $prefix } = 'urn:x-suika-fam-cx:msgpm:header:x-temp:'.$prefix;
454        $nsuri = $self->{ns}->{number2uri}->{ $prefix };        $nsuri = $self->{ns}->{number2uri}->{ $prefix };
455      }      }
456    } elsif (($name =~ s/^([Xx]-[A-Za-z0-9]+|[A-Za-z]*[A-WYZa-wyz0-9][A-Za-z0-9]*)-    } elsif (
457                     ([Xx]-[A-Za-z0-9]+|[A-Za-z0-9]*[A-WYZa-wyz0-9][A-Za-z0-9]*)-//x)      ${ &_NS_uri2package ($default_ns).'::OPTION' }{use_ph_namespace}
458      || $name =~ s/^([Xx]-[A-Za-z0-9]+|[A-Za-z0-9]*[A-WYZa-wyz0-9][A-Za-z0-9]*)-//) {      && (
459           ($name =~ s/^([Xx]-[A-Za-z0-9]+|[A-Za-z]*[A-WYZa-wyz0-9][A-Za-z0-9]*)-
460                        ([Xx]-[A-Za-z0-9]+|[A-Za-z0-9]*[A-WYZa-wyz0-9][A-Za-z0-9]*)-//x)
461         || $name =~ s/^([Xx]-[A-Za-z0-9]+|[A-Za-z0-9]*[A-WYZa-wyz0-9][A-Za-z0-9]*)-//
462        )) {
463      my ($prefix1, $prefix2) = ($1, $2);      my ($prefix1, $prefix2) = ($1, $2);
464      my $original_prefix = $&;  my $one_prefix = 0;      my $original_prefix = $&;  my $one_prefix = 0;
465      unless ($prefix2) {      unless ($prefix2) {
466        $prefix2 = $prefix1;        $prefix2 = $prefix1;
467        $prefix1 = $self->{ns}->{uri2phname}->{ $option->{ns_default_phuri} };        $prefix1 = $self->{ns}->{uri2phname}->{ $default_ns };
468        $one_prefix = 1;        $one_prefix = 1;
469      }      }
470      my $prefix      my $prefix
# Line 500  sub _value_to_arrayitem ($$$\%) { Line 473  sub _value_to_arrayitem ($$$\%) {
473      $self->_ns_load_ph ($prefix);      $self->_ns_load_ph ($prefix);
474      $nsuri = $self->{ns}->{phname2uri}->{ $prefix };      $nsuri = $self->{ns}->{phname2uri}->{ $prefix };
475      unless ($nsuri) {      unless ($nsuri) {
476        $nsuri = $self->{option}->{ns_default_phuri};        $nsuri = $default_ns;
477        $prefix        $prefix
478          = &{ ${ &_NS_uri2package ($nsuri).'::OPTION' }{n11n_prefix} }          = &{ ${ &_NS_uri2package ($nsuri).'::OPTION' }{n11n_prefix} }
479            ($self, &_NS_uri2package ($nsuri), $one_prefix? $prefix2: $prefix1);            ($self, &_NS_uri2package ($nsuri), $one_prefix? $prefix2:
480               $prefix1);
481        $self->_ns_load_ph ($prefix);        $self->_ns_load_ph ($prefix);
482        $nsuri = $self->{ns}->{phname2uri}->{ $prefix };        $nsuri = $self->{ns}->{phname2uri}->{ $prefix };
483        if ($nsuri) {        if ($nsuri) {
484          $name = $prefix2 . '-' . $name unless $one_prefix;          $name = $prefix2 . '-' . $name unless $one_prefix;
485        } else {        } else {
486          $name = $original_prefix . $name;          unless ($one_prefix) {
487          $nsuri = $self->{option}->{ns_default_phuri};            $prefix
488                = &{ ${ &_NS_uri2package ($nsuri).'::OPTION' }{n11n_prefix} }
489                  ($self, &_NS_uri2package ($nsuri),
490                   $self->{ns}->{uri2phname}->{ $default_ns } . '-' . $prefix1);
491              $self->_ns_load_ph ($prefix);
492              $nsuri = $self->{ns}->{phname2uri}->{ $prefix };
493              if ($nsuri) {
494                $name = $prefix2 . '-' . $name;
495              }
496            }
497            unless ($nsuri) {
498              $name = $original_prefix . $name;
499              $nsuri = $default_ns;
500            }
501        }        }
502      }      }
503    }    }
504    $name    $name
505      = &{${&_NS_uri2package ($nsuri).'::OPTION'}{n11n_name}}      = &{ ${ &_NS_uri2package ($nsuri).'::OPTION' }{n11n_name} }
506        ($self, &_NS_uri2package ($nsuri), $name);        ($self, &_NS_uri2package ($nsuri), $name);
507    Carp::croak "$name: invalid field-name"    Carp::croak "$name: invalid field-name"
508      if $option->{field_name_validation}      if $option->{field_name_validation}
509        && $name =~ /$REG{$option->{field_name_unsafe_rule}}/;        && $name =~ /$REG{ $option->{field_name_unsafe_rule} }/;
510    $value = $self->_parse_value ($name => $value, ns => $nsuri)    $value = $self->_parse_value ($name => $value, ns => $nsuri)
511      if $$option{parse} || $$option{parse_all};      if $option->{parse} || $option->{parse_all};
512    $$option{parse} = 0;    $option->{parse} = 0;
513    (1, $name.':'.$nsuri => {name => $name, body => $value, ns => $nsuri});    (1, $name.':'.$nsuri => {name => $name, body => $value, ns => $nsuri});
514  }  }
515  *_add_hash_check = \&_value_to_arrayitem;  *_add_hash_check = \&_value_to_arrayitem;
# Line 619  for each value. Line 606  for each value.
606  =cut  =cut
607    
608  sub _scan_sort ($\@\%) {  sub _scan_sort ($\@\%) {
609      no strict 'refs';
610    my $self = shift;    my $self = shift;
611    my ($array, $option) = @_;    my ($array, $option) = @_;
612    my $sort;    my $nspack = &_NS_uri2package ($self->{option}->{ns_default_phuri});
613    $sort = \&_header_cmp if $option->{field_sort} eq 'good-practice';    my $sort = ${ $nspack.'::OPTION' }{field_sort};
614    $sort = {$a cmp $b} if $option->{field_sort} eq 'alphabetic';    if ($option->{field_sort} eq 'good-practice' && $sort->{'good-practice'}) {
615    return ( sort $sort @$array ) if ref $sort;      return $self->Message::Header::Default::sort_good_practice ($array, $nspack, $option);
616      } elsif ($option->{field_sort} eq 'alphabetic' && $sort->{'alphabetic'}) {
617        ## TODO: How treat namespace prefix?
618        return sort {$a->{name} cmp $b->{name}} @$array;
619      }
620    @$array;    @$array;
621  }  }
622    
# Line 637  sub _n11n_field_name ($$) { Line 629  sub _n11n_field_name ($$) {
629    $s;    $s;
630  }  }
631    
 # Compare function which makes it easy to sort headers in the  
 # recommended "Good Practice" order.  
 ## taken from HTTP::Header  
 sub _header_cmp  
 {  
   my ($na, $nb) = ($a->{name}, $b->{name});  
     # Unknown headers are assign a large value so that they are  
     # sorted last.  This also helps avoiding a warning from -w  
     # about comparing undefined values.  
     $header_order{$na} = 999 unless defined $header_order{$na};  
     $header_order{$nb} = 999 unless defined $header_order{$nb};  
   
     $header_order{$na} <=> $header_order{$nb} || $na cmp $nb;  
 }  
632    
633  =head2 $self->stringify ([%option])  =head2 $self->stringify ([%option])
634    
# Line 663  sub stringify ($;%) { Line 641  sub stringify ($;%) {
641    my %params = @_;    my %params = @_;
642    my %option = %{$self->{option}};    my %option = %{$self->{option}};
643    $option{format} = $params{-format} if $params{-format};    $option{format} = $params{-format} if $params{-format};
644    $self->_init_by_format ($option{format}, \%option);    $self->_init_by_format ($option{format}, \%option)
645        if $self->{option}->{format} ne $option{format};
646    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
647      ## Fill required fields
648        my %exist;
649        for ($self->field_name_list) {$exist{$_} = 1}
650        &{ $option{hook_stringify_fill_fields} } ($self, \%exist, \%option);
651    my @ret;    my @ret;
652    ## RFC 2774 numerical field name prefix    ## RFC 2774 numerical field name prefix
653    my %nprefix;    my %nprefix;
# Line 834  sub _ns_load_ph ($$) { Line 817  sub _ns_load_ph ($$) {
817    my $name = shift;     ## normalized prefix (without HYPHEN-MINUS)    my $name = shift;     ## normalized prefix (without HYPHEN-MINUS)
818    return if $self->{ns}->{phname2uri}->{$name};    return if $self->{ns}->{phname2uri}->{$name};
819    $self->{ns}->{phname2uri}->{$name} = $NS_phname2uri{$name};    $self->{ns}->{phname2uri}->{$name} = $NS_phname2uri{$name};
820    return unless $self->{ns}->{phname2uri}->{$name};    $self->{ns}->{uri2phname}->{ $self->{ns}->{phname2uri}->{$name} } = $name;
   $self->{ns}->{uri2phname}->{$self->{ns}->{phname2uri}->{$name}} = $name;  
821  }  }
822    
823  sub _ns_associate_numerical_prefix ($) {  sub _ns_associate_numerical_prefix ($) {
Legend:
Removed from v.1.33  
changed lines
  Added in v.1.40
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24