/[suikacvs]/test/cvs
Suika

Diff of /test/cvs

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

revision 1.30 by wakaba, Thu Jul 4 06:38:21 2002 UTC revision 1.32 by wakaba, Sat Jul 6 11:37:01 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 99  sub _init ($;%) { Line 100  sub _init ($;%) {
100    $self->SUPER::_init (%$DEFAULT, %options);    $self->SUPER::_init (%$DEFAULT, %options);
101    $self->{value} = [];    $self->{value} = [];
102    $self->_ns_load_ph ('default');    $self->_ns_load_ph ('default');
103    $self->_ns_load_ph ('rfc822');    $self->_ns_load_ph ('x-rfc822');
104    $self->{option}->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'rfc822'}    $self->_ns_load_ph ('x-http');
105      $self->{option}->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'x-rfc822'}
106      unless $self->{option}->{ns_default_phuri};      unless $self->{option}->{ns_default_phuri};
107        
108    ## For text/rfc822-headers    ## For text/rfc822-headers
# Line 129  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    if ($format =~ /cgi/) {    if ($format =~ /http/) {
135      unshift @header_order, qw(content-type location);      $option->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'x-http'};
136      $option->{field_sort} = 'good-practice';      if ($format =~ /cgi/) {
137      $option->{use_folding} = 0;        unshift @header_order, qw(content-type location);
138    } elsif ($format =~ /http/) {        $option->{field_sort} = 'good-practice';
139      $option->{field_sort} = 'good-practice';        $option->{use_folding} = 0;
140        } else {
141          $option->{field_sort} = 'good-practice';
142        }
143      } else {      ## RFC 822
144        $option->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'x-rfc822'};
145    }    }
146    if ($format =~ /uri-url-mailto/) {    if ($format =~ /uri-url-mailto/) {
147      $option->{output_bcc} = 0;      $option->{output_bcc} = 0;
# Line 182  sub parse ($$;%) { Line 189  sub parse ($$;%) {
189    } else {    } else {
190      $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};
191    }    }
192      my %option = (%{ $self->{option} });
193      $option{parse_all} = 0;
194    for my $field (split /\x0D?\x0A/, $header) {    for my $field (split /\x0D?\x0A/, $header) {
195      if ($field =~ /$REG{M_fromline}/) {      if ($field =~ /$REG{M_fromline}/) {
196        my ($s,undef,$value) = $self->_value_to_arrayitem        my ($s,undef,$value) = $self->_value_to_arrayitem
197          ('mail-from' => $1, $self->{option});          ('mail-from' => $1, \%option);
198        push @{$self->{value}}, $value if $s;        push @{$self->{value}}, $value if $s;
199      } elsif ($field =~ /$REG{M_field}/) {      } elsif ($field =~ /$REG{M_field}/) {
200        my ($name, $body) = ($1, $2);        my ($name, $body) = ($1, $2);
201        $body =~ s/$REG{WSP}+$//;        $body =~ s/$REG{WSP}+$//;
202        my ($s,undef,$value) = $self->_value_to_arrayitem        my ($s,undef,$value) = $self->_value_to_arrayitem
203          ($name => $body, $self->{option});          ($name => $body, \%option);
204        push @{$self->{value}}, $value if $s;        push @{$self->{value}}, $value if $s;
205      } elsif (length $field) {      } elsif (length $field) {
206        my ($s,undef,$value) = $self->_value_to_arrayitem        my ($s,undef,$value) = $self->_value_to_arrayitem
207          ('x-unknown' => $field, $self->{option});          ('x-unknown' => $field, \%option);
208        push @{$self->{value}}, $value if $s;        push @{$self->{value}}, $value if $s;
209      }      }
210    }    }
211      $self->_ns_associate_numerical_prefix;        ## RFC 2774 namespace
212      for (@{ $self->{value} }) {
213        no strict 'refs';
214        $_->{name}
215          = &{ ${ &_NS_uri2package ($_->{ns}).'::OPTION' }{n11n_name} }
216          ($self, &_NS_uri2package ($_->{ns}), $_->{name});
217        $_->{body} = $self->_parse_value ($_->{name} => $_->{body}, ns => $_->{ns})
218          if $self->{option}->{parse_all};
219      }
220    $self;    $self;
221  }  }
222    
# Line 251  sub parse_array ($\@;%) { Line 269  sub parse_array ($\@;%) {
269      }      }
270      last if $#$header < 0;      last if $#$header < 0;
271    }    }
272      $self->_ns_associate_numerical_prefix;        ## RFC 2774 namespace
273    $self;    $self;
274  }  }
275    
# Line 276  sub _item_match ($$\$\%\%) { Line 295  sub _item_match ($$\$\%\%) {
295    my ($by, $i, $list, $option) = @_;    my ($by, $i, $list, $option) = @_;
296    return 0 unless ref $$i;  ## Already removed    return 0 unless ref $$i;  ## Already removed
297    if ($by eq 'name') {    if ($by eq 'name') {
298      my %o = %$option; $o{parse} = 0;      my %o = %$option; #$o{parse} = 0;
299      my %l;      my %l;
300      for (keys %$list) {      for (keys %$list) {
301        my ($s, undef, $v) = $self->_value_to_arrayitem ($_, '', %o);        my ($s, undef, $v) = $self->_value_to_arrayitem ($_, '', %o);
# Line 289  sub _item_match ($$\$\%\%) { Line 308  sub _item_match ($$\$\%\%) {
308      return 1 if $l{$$i->{name} . ':' . $$i->{ns}};      return 1 if $l{$$i->{name} . ':' . $$i->{ns}};
309    } elsif ($by eq 'ns') {    } elsif ($by eq 'ns') {
310      return 1 if $list->{ $$i->{ns} };      return 1 if $list->{ $$i->{ns} };
311      } elsif ($by eq 'http-ns-define') {
312        if ($$i->{ns} eq $self->{ns}->{phname2uri}->{'x-http'}
313         || $$i->{ns} eq $self->{ns}->{phname2uri}->{'x-http-c'}) {
314          my $n = $$i->{name};
315          if ($n eq 'opt' || $n eq 'c-opt' || $n eq 'man' || $n eq 'c-man') {
316            $option->{parse} = 0;
317            $$i->{body} = $self->_parse_value ($$i->{name} => $$i->{body}, ns => $$i->{ns});
318            for my $j (0..$$i->{body}->count-1) {
319              return 1 if $list->{ ($$i->{body}->value ($j))[0]->value };
320            }
321          }
322        }
323    }    }
324    0;    0;
325  }  }
# Line 309  sub _item_return_value ($\$\%) { Line 340  sub _item_return_value ($\$\%) {
340    
341  ## Returns returned (new created) item value    $name, \%option  ## Returns returned (new created) item value    $name, \%option
342  sub _item_new_value ($$\%) {  sub _item_new_value ($$\%) {
343      my ($s,undef,$value) = $_[0]->_value_to_arrayitem    my $self = shift;
344          ($_[1] => '', $_[2]);    my ($name, $option) = @_;
345      if ($option->{by} eq 'http-ns-define') {
346        my $value = $self->_parse_value (opt => '', ns => $self->{ns}->{phname2uri}->{'x-http'});
347        ($value->value (0))[0]->value ($name);
348        {name => 'opt', body => $value, ns => $self->{ns}->{phname2uri}->{'x-http'}};
349      } else {
350        my ($s,undef,$value) = $self->_value_to_arrayitem
351            ($name => '', $option);
352      $s? $value: undef;      $s? $value: undef;
353      }
354  }  }
355    
356    
# Line 323  sub _parse_value ($$$;%) { Line 362  sub _parse_value ($$$;%) {
362    my $value = shift;  return $value if ref $value;    my $value = shift;  return $value if ref $value;
363    my %option = @_;    my %option = @_;
364    my $vtype; { no strict 'refs';    my $vtype; { no strict 'refs';
365      my $vt = ${&_NS_uri2phpackage ($option{ns}).'::OPTION'}{value_type};      my $vt = ${&_NS_uri2package ($option{ns}).'::OPTION'}{value_type};
366      if (ref $vt) {      if (ref $vt) {
367        $vtype = $vt->{$name} || $vt->{$self->{option}->{_VALTYPE_DEFAULT}};        $vtype = $vt->{$name} || $vt->{$self->{option}->{_VALTYPE_DEFAULT}};
368      }      }
# Line 387  sub namespace_ph_default ($;$) { Line 426  sub namespace_ph_default ($;$) {
426    if (defined $_[0]) {    if (defined $_[0]) {
427      no strict 'refs';      no strict 'refs';
428      $self->{option}->{ns_default_phuri} = $_[0];      $self->{option}->{ns_default_phuri} = $_[0];
429      $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});
430    }    }
431    $self->{option}->{ns_default_phuri};    $self->{option}->{ns_default_phuri};
432  }  }
# Line 429  sub _value_to_arrayitem ($$$\%) { Line 468  sub _value_to_arrayitem ($$$\%) {
468      ($value, %$value_option) = @$value;      ($value, %$value_option) = @$value;
469    }    }
470    my $nsuri = $self->{option}->{ns_default_phuri};    my $nsuri = $self->{option}->{ns_default_phuri};
471      $name =~ s/^$REG{WSP}+//;  $name =~ s/$REG{WSP}+$//;
472        
473    no strict 'refs';    no strict 'refs';
474    if ($value_option->{ns}) {    if ($value_option->{ns}) {
475      $nsuri = $value_option->{ns};      $nsuri = $value_option->{ns};
476    } elsif ($option->{ns}) {    } elsif ($option->{ns}) {
477      $nsuri = $option->{ns};      $nsuri = $option->{ns};
478    } elsif ($name =~ s/^([Xx]-[A-Za-z]+|[A-Za-z]+)-//) {    } elsif (($option->{ns_default_phuri} eq $self->{ns}->{uri2phname}->{'x-http'}
479      my $oprefix = $1;         && $name =~ s/^([0-9]+)-//)
480        || ($name =~ s/^x-http-([0-9]+)-//i)) {     ## Numric namespace prefix, RFC 2774
481        my $prefix = 0+$1;
482        $nsuri = $self->{ns}->{number2uri}->{ $prefix };
483        unless ($nsuri) {
484          $self->{ns}->{number2uri}->{ $prefix } = 'urn:x-suika-fam-cx:msgpm:header:x-temp:'.$prefix;
485          $nsuri = $self->{ns}->{number2uri}->{ $prefix };
486        }
487      } elsif (($name =~ s/^([Xx]-[A-Za-z]+|[A-YZa-yz][A-Za-z]*)-
488                           ([Xx]-[A-Za-z]+|[A-YZa-yz][A-Za-z]*)-//x)
489        || $name =~ s/^([Xx]-[A-Za-z]+|[A-Za-z]+)-//) {
490        my ($prefix1, $prefix2) = ($1, $2);
491        my $original_prefix = $&;  my $one_prefix = 0;
492        unless ($prefix2) {
493          $prefix2 = $prefix1;
494          $prefix1 = $self->{ns}->{uri2phname}->{ $option->{ns_default_phuri} };
495          $one_prefix = 1;
496        }
497      my $prefix      my $prefix
498        = &{${&_NS_uri2phpackage ($nsuri).'::OPTION'}{n11n_prefix}}        = &{ ${ &_NS_uri2package ($nsuri).'::OPTION' }{n11n_prefix} }
499          ($self, &_NS_uri2phpackage ($nsuri), $oprefix);          ($self, &_NS_uri2package ($nsuri), $prefix1.'-'.$prefix2);
500      $self->_ns_load_ph ($prefix);      $self->_ns_load_ph ($prefix);
501      $nsuri = $self->{ns}->{phname2uri}->{$prefix};      $nsuri = $self->{ns}->{phname2uri}->{ $prefix };
502      unless ($nsuri) {      unless ($nsuri) {
       $name = $oprefix . '-' . $name;  
503        $nsuri = $self->{option}->{ns_default_phuri};        $nsuri = $self->{option}->{ns_default_phuri};
504          $prefix
505            = &{ ${ &_NS_uri2package ($nsuri).'::OPTION' }{n11n_prefix} }
506              ($self, &_NS_uri2package ($nsuri), $one_prefix? $prefix2: $prefix1);
507          $self->_ns_load_ph ($prefix);
508          $nsuri = $self->{ns}->{phname2uri}->{ $prefix };
509          if ($nsuri) {
510            $name = $prefix2 . '-' . $name unless $one_prefix;
511          } else {
512            $name = $original_prefix . $name;
513            $nsuri = $self->{option}->{ns_default_phuri};
514          }
515      }      }
516    }    }
517    $name    $name
518      = &{${&_NS_uri2phpackage ($nsuri).'::OPTION'}{n11n_name}}      = &{${&_NS_uri2package ($nsuri).'::OPTION'}{n11n_name}}
519        ($self, &_NS_uri2phpackage ($nsuri), $name);        ($self, &_NS_uri2package ($nsuri), $name);
520    Carp::croak "$name: invalid field-name"    Carp::croak "$name: invalid field-name"
521      if $option->{field_name_validation}      if $option->{field_name_validation}
522        && $name =~ /$REG{$option->{field_name_unsafe_rule}}/;        && $name =~ /$REG{$option->{field_name_unsafe_rule}}/;
# Line 566  sub _n11n_field_name ($$) { Line 633  sub _n11n_field_name ($$) {
633    my $self = shift;    my $self = shift;
634    my $s = shift;    my $s = shift;
635    $s =~ s/^$REG{WSP}+//; $s =~ s/$REG{WSP}+$//;    $s =~ s/^$REG{WSP}+//; $s =~ s/$REG{WSP}+$//;
636    $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};
637    $s;    $s;
638  }  }
639    
# Line 599  sub stringify ($;%) { Line 666  sub stringify ($;%) {
666    $self->_init_by_format ($option{format}, \%option);    $self->_init_by_format ($option{format}, \%option);
667    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
668    my @ret;    my @ret;
669      ## RFC 2774 numerical field name prefix
670      my %nprefix;
671      {no strict 'refs';
672        %nprefix = reverse %{ $self->{ns}->{number2uri} };
673        my $i = (sort { $a <=> $b } keys %{ $self->{ns}->{number2uri} })[-1] + 1;
674        $i = 10 if $i < 10;
675        my $hprefix = ${ &_NS_uri2package
676                           ($self->{ns}->{phname2uri}->{'x-http'})
677                           .'::OPTION' } {namespace_phname_goodcase};
678        for my $uri (keys %nprefix) {
679          if ($nprefix{ $uri } < 10) {
680            $nprefix{ $uri } = $i++;
681          }
682          my $nsfs = $self->item ($uri, -by => 'http-ns-define');
683          for my $i (0..$nsfs->count-1) {
684            my $nsf = ($nsfs->value ($i))[0];
685            if ($nsf->value eq $uri) {
686              $nsf->replace (ns => $nprefix{ $uri });
687              $nprefix{ $uri } = $hprefix . '-' . $nprefix{ $uri };
688              last;
689            }
690          }
691        }
692      }
693    my $_stringify = sub {    my $_stringify = sub {
694      no strict 'refs';      no strict 'refs';
695        my ($name, $body, $nsuri) = ($_[1]->{name}, $_[1]->{body}, $_[1]->{ns});        my ($name, $body, $nsuri) = ($_[1]->{name}, $_[1]->{body}, $_[1]->{ns});
696        return unless length $name;        return unless length $name;
697        return if $option{output_mail_from} && $name eq 'mail-from';        return if $option{output_mail_from} && $name eq 'mail-from';
698        $body = '' if !$option{output_bcc} && $name eq 'bcc';        $body = '' if !$option{output_bcc} && $name eq 'bcc';
699        my $nspackage = &_NS_uri2phpackage ($nsuri);        my $nspackage = &_NS_uri2package ($nsuri);
700        my $oname;        ## Outputed field-name        my $oname;        ## Outputed field-name
701        my $prefix = ${$nspackage.'::OPTION'} {namespace_phname_goodcase}        my $prefix = $nprefix{ $nsuri }
702                  || $self->{ns}->{uri2phname}->{$nsuri};                  || ${$nspackage.'::OPTION'} {namespace_phname_goodcase}
703        $prefix = undef if $nsuri eq $self->{option}->{ns_default_phuri};                  || $self->{ns}->{uri2phname}->{ $nsuri };
704          my $default_prefix = ${ &_NS_uri2package ($option{ns_default_phuri})
705                                  .'::OPTION'} {namespace_phname_goodcase};
706          $prefix = '' if $prefix eq $default_prefix;
707          $prefix =~ s/^\Q$default_prefix\E-//;
708        my $gc = ${$nspackage.'::OPTION'} {to_be_goodcase};        my $gc = ${$nspackage.'::OPTION'} {to_be_goodcase};
709        if (ref $gc) { $oname = &$gc ($self, $nspackage, $name, \%option) }        if (ref $gc) { $oname = &$gc ($self, $nspackage, $name, \%option) }
710        else { $oname = $name }        else { $oname = $name }
# Line 743  sub _ns_load_ph ($$) { Line 838  sub _ns_load_ph ($$) {
838    $self->{ns}->{uri2phname}->{$self->{ns}->{phname2uri}->{$name}} = $name;    $self->{ns}->{uri2phname}->{$self->{ns}->{phname2uri}->{$name}} = $name;
839  }  }
840    
841    sub _ns_associate_numerical_prefix ($) {
842      my $self = shift;
843      $self->scan (sub {shift;
844        my $f = shift;  return unless $f->{name};
845        if ($f->{ns} eq $self->{ns}->{phname2uri}->{'x-http'}
846         || $f->{ns} eq $self->{ns}->{phname2uri}->{'x-http-c'}) {
847          my $fn = $f->{name};
848          if ($fn eq 'opt' || $fn eq 'man') {
849            $f->{body} = $self->_parse_value ($fn => $f->{body}, ns => $f->{ns});
850            for ($f->{body}->value (0..$f->{body}->count-1)) {
851              my ($nsuri, $number) = ($_->value, $_->item ('ns'));
852              if ($number && $nsuri) {
853                $self->{ns}->{number2uri}->{ $number } = $nsuri;
854              }
855            }
856          }
857        }
858      });
859      $self->scan (sub {shift;
860        my $f = shift;
861        if ($f->{ns} =~ /urn:x-suika-fam-cx:msgpm:header:x-temp:([0-9]+)$/ && $self->{ns}->{number2uri}->{ $1 }) {
862          $f->{ns} = $self->{ns}->{number2uri}->{ $1 };
863        }
864      });
865    }
866    
867    ## $package_name = Message::Header::_NS_uri2phpackage ($nsuri)
868    ## (For internal use of Message::* modules)
869  sub _NS_uri2phpackage ($) {  sub _NS_uri2phpackage ($) {
870    $NS_uri2phpackage{$_[0]}    $NS_uri2phpackage{$_[0]}
871    || $NS_uri2phpackage{$Message::Header::Default::OPTION{namespace_uri}};    || $NS_uri2phpackage{$Message::Header::Default::OPTION{namespace_uri}};
872  }  }
873    sub _NS_uri2package ($) {
874      $NS_uri2package{$_[0]}
875      || $NS_uri2phpackage{$_[0]}
876      || $NS_uri2phpackage{$Message::Header::Default::OPTION{namespace_uri}};
877    }
878    
879  =head2 $self->clone ()  =head2 $self->clone ()
880    
Legend:
Removed from v.1.30  
changed lines
  Added in v.1.32
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24