/[suikacvs]/test/cvs
Suika

Diff of /test/cvs

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

revision 1.31 by wakaba, Sat Jul 6 10:30:10 2002 UTC revision 1.34 by wakaba, Mon Jul 8 11:49:18 2002 UTC
# Line 22  push @ISA, qw(Message::Field::Structured Line 22  push @ISA, qw(Message::Field::Structured
22    
23  ## Namespace support  ## Namespace support
24          our %NS_phname2uri;     ## PH-namespace name -> namespace URI          our %NS_phname2uri;     ## PH-namespace name -> namespace URI
25          our %NS_uri2phpackage;  ## namespace URI -> PH-package name          our %NS_uri2package;    ## namespace URI -> Package name
26            our %NS_uri2phpackage;  ## namespace URI -> PH-Package name
27          require Message::Header::Default;       ## Default namespace          require Message::Header::Default;       ## Default namespace
28    
29  ## Initialize of this class -- called by constructors  ## Initialize of this class -- called by constructors
# Line 130  sub _init ($;%) { Line 131  sub _init ($;%) {
131  sub _init_by_format ($$\%) {  sub _init_by_format ($$\%) {
132    my $self = shift;    my $self = shift;
133    my ($format, $option) = @_;    my ($format, $option) = @_;
134      return if $format eq $option->{format};
135    if ($format =~ /http/) {    if ($format =~ /http/) {
136      $option->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'x-http'};      $option->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'x-http'};
137      if ($format =~ /cgi/) {      if ($format =~ /cgi/) {
# Line 139  sub _init_by_format ($$\%) { Line 141  sub _init_by_format ($$\%) {
141      } else {      } else {
142        $option->{field_sort} = 'good-practice';        $option->{field_sort} = 'good-practice';
143      }      }
144    } else {      ## RFC 822    } elsif ($format =~ /mail|news/) {    ## RFC 822
145      $option->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'x-rfc822'};      $option->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'x-rfc822'};
146    }    }
147    if ($format =~ /uri-url-mailto/) {    if ($format =~ /uri-url-mailto/) {
# Line 188  sub parse ($$;%) { Line 190  sub parse ($$;%) {
190    } else {    } else {
191      $header =~ s/\x0D?\x0A$REG{WSP}/\x20/gos if $self->{option}->{use_folding};      $header =~ s/\x0D?\x0A$REG{WSP}/\x20/gos if $self->{option}->{use_folding};
192    }    }
193      my %option = (%{ $self->{option} });
194      $option{parse_all} = 0;
195    for my $field (split /\x0D?\x0A/, $header) {    for my $field (split /\x0D?\x0A/, $header) {
196      if ($field =~ /$REG{M_fromline}/) {      if ($field =~ /$REG{M_fromline}/) {
197        my ($s,undef,$value) = $self->_value_to_arrayitem        my ($s,undef,$value) = $self->_value_to_arrayitem
198          ('mail-from' => $1, $self->{option});          ('mail-from' => $1, \%option);
199        push @{$self->{value}}, $value if $s;        push @{$self->{value}}, $value if $s;
200      } elsif ($field =~ /$REG{M_field}/) {      } elsif ($field =~ /$REG{M_field}/) {
201        my ($name, $body) = ($1, $2);        my ($name, $body) = ($1, $2);
202        $body =~ s/$REG{WSP}+$//;        $body =~ s/$REG{WSP}+$//;
203        my ($s,undef,$value) = $self->_value_to_arrayitem        my ($s,undef,$value) = $self->_value_to_arrayitem
204          ($name => $body, $self->{option});          ($name => $body, \%option);
205        push @{$self->{value}}, $value if $s;        push @{$self->{value}}, $value if $s;
206      } elsif (length $field) {      } elsif (length $field) {
207        my ($s,undef,$value) = $self->_value_to_arrayitem        my ($s,undef,$value) = $self->_value_to_arrayitem
208          ('x-unknown' => $field, $self->{option});          ('x-unknown' => $field, \%option);
209        push @{$self->{value}}, $value if $s;        push @{$self->{value}}, $value if $s;
210      }      }
211    }    }
212    $self->_ns_associate_numerical_prefix;        ## RFC 2774 namespace    $self->_ns_associate_numerical_prefix;        ## RFC 2774 namespace
213      for (@{ $self->{value} }) {
214        no strict 'refs';
215        $_->{name}
216          = &{ ${ &_NS_uri2package ($_->{ns}).'::OPTION' }{n11n_name} }
217          ($self, &_NS_uri2package ($_->{ns}), $_->{name});
218        $_->{body} = $self->_parse_value ($_->{name} => $_->{body}, ns => $_->{ns})
219          if $self->{option}->{parse_all};
220      }
221    $self;    $self;
222  }  }
223    
# Line 287  sub _item_match ($$\$\%\%) { Line 299  sub _item_match ($$\$\%\%) {
299      my %o = %$option; #$o{parse} = 0;      my %o = %$option; #$o{parse} = 0;
300      my %l;      my %l;
301      for (keys %$list) {      for (keys %$list) {
302        my ($s, undef, $v) = $self->_value_to_arrayitem ($_, '', %o);        my ($s, undef, $v) = $self->_value_to_arrayitem ($_, '', \%o);
303        if ($s) {        if ($s) {
304          $l{$v->{name} . ':' . ( $option->{ns} || $v->{ns} ) } = 1;          $l{$v->{name} . ':' . ( $option->{ns} || $v->{ns} ) } = 1;
305        } else {        } else {
# Line 351  sub _parse_value ($$$;%) { Line 363  sub _parse_value ($$$;%) {
363    my $value = shift;  return $value if ref $value;    my $value = shift;  return $value if ref $value;
364    my %option = @_;    my %option = @_;
365    my $vtype; { no strict 'refs';    my $vtype; { no strict 'refs';
366      my $vt = ${&_NS_uri2phpackage ($option{ns}).'::OPTION'}{value_type};      my $vt = ${&_NS_uri2package ($option{ns}).'::OPTION'}{value_type};
367      if (ref $vt) {      if (ref $vt) {
368        $vtype = $vt->{$name} || $vt->{$self->{option}->{_VALTYPE_DEFAULT}};        $vtype = $vt->{$name} || $vt->{$self->{option}->{_VALTYPE_DEFAULT}};
369      }      }
# Line 415  sub namespace_ph_default ($;$) { Line 427  sub namespace_ph_default ($;$) {
427    if (defined $_[0]) {    if (defined $_[0]) {
428      no strict 'refs';      no strict 'refs';
429      $self->{option}->{ns_default_phuri} = $_[0];      $self->{option}->{ns_default_phuri} = $_[0];
430      $self->_ns_load_ph (${&_NS_uri2phpackage ($self->{option}->{ns_default_phuri}).'::OPTION'}{namespace_phname});      $self->_ns_load_ph (${&_NS_uri2package ($self->{option}->{ns_default_phuri}).'::OPTION'}{namespace_phname});
431    }    }
432    $self->{option}->{ns_default_phuri};    $self->{option}->{ns_default_phuri};
433  }  }
# Line 456  sub _value_to_arrayitem ($$$\%) { Line 468  sub _value_to_arrayitem ($$$\%) {
468    if (ref $value eq 'ARRAY') {    if (ref $value eq 'ARRAY') {
469      ($value, %$value_option) = @$value;      ($value, %$value_option) = @$value;
470    }    }
471    my $nsuri = $self->{option}->{ns_default_phuri};    my $default_ns = $option->{ns_default_phuri};
472      my $nsuri = $default_ns;
473    $name =~ s/^$REG{WSP}+//;  $name =~ s/$REG{WSP}+$//;    $name =~ s/^$REG{WSP}+//;  $name =~ s/$REG{WSP}+$//;
474        
475    no strict 'refs';    no strict 'refs';
# Line 464  sub _value_to_arrayitem ($$$\%) { Line 477  sub _value_to_arrayitem ($$$\%) {
477      $nsuri = $value_option->{ns};      $nsuri = $value_option->{ns};
478    } elsif ($option->{ns}) {    } elsif ($option->{ns}) {
479      $nsuri = $option->{ns};      $nsuri = $option->{ns};
480    } elsif (($option->{ns_default_phuri} eq $self->{ns}->{uri2phname}->{'x-http'}    } elsif (($default_ns eq $self->{ns}->{uri2phname}->{'x-http'}
481         && $name =~ s/^([0-9]+)-//)         && $name =~ s/^([0-9]+)-//)
482      || ($name =~ s/^x-http-([0-9]+)-//i)) {     ## Numric namespace prefix, RFC 2774      || ($name =~ s/^x-http-([0-9]+)-//i)) {     ## Numric namespace prefix, RFC 2774
483      my $prefix = 0+$1;      my $prefix = 0+$1;
# Line 473  sub _value_to_arrayitem ($$$\%) { Line 486  sub _value_to_arrayitem ($$$\%) {
486        $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;
487        $nsuri = $self->{ns}->{number2uri}->{ $prefix };        $nsuri = $self->{ns}->{number2uri}->{ $prefix };
488      }      }
489    } elsif (($name =~ s/^([Xx]-[A-Za-z]+|[A-YZa-yz][A-Za-z]*)-    } elsif (
490                         ([Xx]-[A-Za-z]+|[A-YZa-yz][A-Za-z]*)-//x)      ${ &_NS_uri2package ($default_ns).'::OPTION' }{use_ph_namespace}
491      || $name =~ s/^([Xx]-[A-Za-z]+|[A-Za-z]+)-//) {      && (
492           ($name =~ s/^([Xx]-[A-Za-z0-9]+|[A-Za-z]*[A-WYZa-wyz0-9][A-Za-z0-9]*)-
493                        ([Xx]-[A-Za-z0-9]+|[A-Za-z0-9]*[A-WYZa-wyz0-9][A-Za-z0-9]*)-//x)
494         || $name =~ s/^([Xx]-[A-Za-z0-9]+|[A-Za-z0-9]*[A-WYZa-wyz0-9][A-Za-z0-9]*)-//
495        )) {
496      my ($prefix1, $prefix2) = ($1, $2);      my ($prefix1, $prefix2) = ($1, $2);
497      my $original_prefix = $&;  my $one_prefix = 0;      my $original_prefix = $&;  my $one_prefix = 0;
498      unless ($prefix2) {      unless ($prefix2) {
499        $prefix2 = $prefix1;        $prefix2 = $prefix1;
500        $prefix1 = $self->{ns}->{uri2phname}->{ $option->{ns_default_phuri} };        $prefix1 = $self->{ns}->{uri2phname}->{ $default_ns };
501        $one_prefix = 1;        $one_prefix = 1;
502      }      }
503      my $prefix      my $prefix
504        = &{ ${ &_NS_uri2phpackage ($nsuri).'::OPTION' }{n11n_prefix} }        = &{ ${ &_NS_uri2package ($nsuri).'::OPTION' }{n11n_prefix} }
505          ($self, &_NS_uri2phpackage ($nsuri), $prefix1.'-'.$prefix2);          ($self, &_NS_uri2package ($nsuri), $prefix1.'-'.$prefix2);
506      $self->_ns_load_ph ($prefix);      $self->_ns_load_ph ($prefix);
507      $nsuri = $self->{ns}->{phname2uri}->{ $prefix };      $nsuri = $self->{ns}->{phname2uri}->{ $prefix };
508      unless ($nsuri) {      unless ($nsuri) {
509        $nsuri = $self->{option}->{ns_default_phuri};        $nsuri = $default_ns;
510        $prefix        $prefix
511          = &{ ${ &_NS_uri2phpackage ($nsuri).'::OPTION' }{n11n_prefix} }          = &{ ${ &_NS_uri2package ($nsuri).'::OPTION' }{n11n_prefix} }
512            ($self, &_NS_uri2phpackage ($nsuri), $one_prefix? $prefix2: $prefix1);            ($self, &_NS_uri2package ($nsuri), $one_prefix? $prefix2: $prefix1);
513        $self->_ns_load_ph ($prefix);        $self->_ns_load_ph ($prefix);
514        $nsuri = $self->{ns}->{phname2uri}->{ $prefix };        $nsuri = $self->{ns}->{phname2uri}->{ $prefix };
515        if ($nsuri) {        if ($nsuri) {
516          $name = $prefix2 . '-' . $name unless $one_prefix;          $name = $prefix2 . '-' . $name unless $one_prefix;
517        } else {        } else {
518          $name = $original_prefix . $name;          $name = $original_prefix . $name;
519          $nsuri = $self->{option}->{ns_default_phuri};          $nsuri = $default_ns;
520        }        }
521      }      }
522    }    }
523    $name    $name
524      = &{${&_NS_uri2phpackage ($nsuri).'::OPTION'}{n11n_name}}      = &{ ${ &_NS_uri2package ($nsuri).'::OPTION' }{n11n_name} }
525        ($self, &_NS_uri2phpackage ($nsuri), $name);        ($self, &_NS_uri2package ($nsuri), $name);
526    Carp::croak "$name: invalid field-name"    Carp::croak "$name: invalid field-name"
527      if $option->{field_name_validation}      if $option->{field_name_validation}
528        && $name =~ /$REG{$option->{field_name_unsafe_rule}}/;        && $name =~ /$REG{ $option->{field_name_unsafe_rule} }/;
529    $value = $self->_parse_value ($name => $value, ns => $nsuri)    $value = $self->_parse_value ($name => $value, ns => $nsuri)
530      if $$option{parse} || $$option{parse_all};      if $option->{parse} || $option->{parse_all};
531    $$option{parse} = 0;    $option->{parse} = 0;
532    (1, $name.':'.$nsuri => {name => $name, body => $value, ns => $nsuri});    (1, $name.':'.$nsuri => {name => $name, body => $value, ns => $nsuri});
533  }  }
534  *_add_hash_check = \&_value_to_arrayitem;  *_add_hash_check = \&_value_to_arrayitem;
# Line 622  sub _n11n_field_name ($$) { Line 639  sub _n11n_field_name ($$) {
639    my $self = shift;    my $self = shift;
640    my $s = shift;    my $s = shift;
641    $s =~ s/^$REG{WSP}+//; $s =~ s/$REG{WSP}+$//;    $s =~ s/^$REG{WSP}+//; $s =~ s/$REG{WSP}+$//;
642    $s = lc $s unless ${&_NS_uri2phpackage ($self->{option}->{ns_default_phuri}).'::OPTION'}{case_sensible};    $s = lc $s unless ${&_NS_uri2package ($self->{option}->{ns_default_phuri}).'::OPTION'}{case_sensible};
643    $s;    $s;
644  }  }
645    
# Line 661  sub stringify ($;%) { Line 678  sub stringify ($;%) {
678      %nprefix = reverse %{ $self->{ns}->{number2uri} };      %nprefix = reverse %{ $self->{ns}->{number2uri} };
679      my $i = (sort { $a <=> $b } keys %{ $self->{ns}->{number2uri} })[-1] + 1;      my $i = (sort { $a <=> $b } keys %{ $self->{ns}->{number2uri} })[-1] + 1;
680      $i = 10 if $i < 10;      $i = 10 if $i < 10;
681      my $hprefix = ${ &_NS_uri2phpackage      my $hprefix = ${ &_NS_uri2package
682                         ($self->{ns}->{phname2uri}->{'x-http'})                         ($self->{ns}->{phname2uri}->{'x-http'})
683                         .'::OPTION' } {namespace_phname_goodcase};                         .'::OPTION' } {namespace_phname_goodcase};
684      for my $uri (keys %nprefix) {      for my $uri (keys %nprefix) {
# Line 685  sub stringify ($;%) { Line 702  sub stringify ($;%) {
702        return unless length $name;        return unless length $name;
703        return if $option{output_mail_from} && $name eq 'mail-from';        return if $option{output_mail_from} && $name eq 'mail-from';
704        $body = '' if !$option{output_bcc} && $name eq 'bcc';        $body = '' if !$option{output_bcc} && $name eq 'bcc';
705        my $nspackage = &_NS_uri2phpackage ($nsuri);        my $nspackage = &_NS_uri2package ($nsuri);
706        my $oname;        ## Outputed field-name        my $oname;        ## Outputed field-name
707        my $prefix = $nprefix{ $nsuri }        my $prefix = $nprefix{ $nsuri }
708                  || ${$nspackage.'::OPTION'} {namespace_phname_goodcase}                  || ${$nspackage.'::OPTION'} {namespace_phname_goodcase}
709                  || $self->{ns}->{uri2phname}->{ $nsuri };                  || $self->{ns}->{uri2phname}->{ $nsuri };
710        my $default_prefix = ${ &_NS_uri2phpackage ($option{ns_default_phuri})        my $default_prefix = ${ &_NS_uri2package ($option{ns_default_phuri})
711                                .'::OPTION'} {namespace_phname_goodcase};                                .'::OPTION'} {namespace_phname_goodcase};
712        $prefix = '' if $prefix eq $default_prefix;        $prefix = '' if $prefix eq $default_prefix;
713        $prefix =~ s/^\Q$default_prefix\E-//;        $prefix =~ s/^\Q$default_prefix\E-//;
       #$prefix = undef if $nsuri eq $option{ns_default_phuri};  
       #if ($prefix && $prefix eq $nprefix{ $nsuri }) {  ## RFC 2774 prefix  
       #  $prefix = ${ &_NS_uri2phpackage ($self->{ns}->{phname2uri}->{'x-http'})  
       #               .'::OPTION' } {namespace_phname_goodcase} . '-' . $prefix  
       #  unless $option{ns_default_phuri} eq $self->{ns}->{phname2uri}->{'x-http'};  
       #}  
714        my $gc = ${$nspackage.'::OPTION'} {to_be_goodcase};        my $gc = ${$nspackage.'::OPTION'} {to_be_goodcase};
715        if (ref $gc) { $oname = &$gc ($self, $nspackage, $name, \%option) }        if (ref $gc) { $oname = &$gc ($self, $nspackage, $name, \%option) }
716        else { $oname = $name }        else { $oname = $name }
# Line 865  sub _NS_uri2phpackage ($) { Line 876  sub _NS_uri2phpackage ($) {
876    $NS_uri2phpackage{$_[0]}    $NS_uri2phpackage{$_[0]}
877    || $NS_uri2phpackage{$Message::Header::Default::OPTION{namespace_uri}};    || $NS_uri2phpackage{$Message::Header::Default::OPTION{namespace_uri}};
878  }  }
879    sub _NS_uri2package ($) {
880      $NS_uri2package{$_[0]}
881      || $NS_uri2phpackage{$_[0]}
882      || $NS_uri2phpackage{$Message::Header::Default::OPTION{namespace_uri}};
883    }
884    
885  =head2 $self->clone ()  =head2 $self->clone ()
886    
Legend:
Removed from v.1.31  
changed lines
  Added in v.1.34
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24