/[suikacvs]/test/cvs
Suika

Diff of /test/cvs

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

revision 1.29 by wakaba, Wed Jul 3 23:39:15 2002 UTC revision 1.41 by wakaba, Sun Jul 28 00:31:38 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 31  push @ISA, qw(Message::Field::Structured Line 32  push @ISA, qw(Message::Field::Structured
32      -_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|],
33      -_MEMBERS   => [qw|value|],      -_MEMBERS   => [qw|value|],
34      -_VALTYPE_DEFAULT   => ':default',      -_VALTYPE_DEFAULT   => ':default',
35      -by => 'name',      ## (Reserved for method level option)      -by => 'name',
36      -field_format_pattern       => '%s: %s',      -field_format_pattern       => '%s: %s',
37      -field_name_case_sensible   => 0,      -field_name_case_sensible   => 0,
38      -field_name_unsafe_rule     => 'NON_ftext',      -field_name_unsafe_rule     => 'NON_ftext',
39      -field_name_validation      => 0,      -field_name_validation      => 0,
40      -field_sort => 0,      -field_sort => 0,
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      -linebreak_strict   => 0,   ## Not implemented completely      -hook_init_fill_options     => sub {},
45        -hook_stringify_fill_fields => sub {},
46        -linebreak_strict   => 0,
47      -line_length_max    => 60,  ## For folding      -line_length_max    => 60,  ## For folding
48      #ns_default_phuri      #ns_default_phuri
49      -output_bcc => 0,      -output_bcc => 0,
50      -output_folding     => 1,      -output_folding     => 1,
51      -output_mail_from   => 0,      -output_mail_from   => 0,
52      #-parse_all => 0,      #parse_all
53      -translate_underscore       => 1,      -translate_underscore       => 1,
54      #-uri_mailto_safe      #uri_mailto_safe
55      -uri_mailto_safe_level      => 4,      -uri_mailto_safe_level      => 4,
56      -use_folding        => 1,      -use_folding        => 1,
57      #-value_type      #value_type
58  );  );
59    
 $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',  
 );  
   
 ## 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 124  sub _init ($;%) { Line 72  sub _init ($;%) {
72    $self->SUPER::_init (%$DEFAULT, %options);    $self->SUPER::_init (%$DEFAULT, %options);
73    $self->{value} = [];    $self->{value} = [];
74    $self->_ns_load_ph ('default');    $self->_ns_load_ph ('default');
75    $self->_ns_load_ph ('rfc822');    $self->_ns_load_ph ('x-rfc822');
76    $self->{option}->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'rfc822'}    $self->_ns_load_ph ('x-http');
77      $self->{option}->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'x-rfc822'}
78      unless $self->{option}->{ns_default_phuri};      unless $self->{option}->{ns_default_phuri};
79        
80    ## For text/rfc822-headers    ## For text/rfc822-headers
# Line 139  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 154  sub _init ($;%) { Line 97  sub _init ($;%) {
97  sub _init_by_format ($$\%) {  sub _init_by_format ($$\%) {
98    my $self = shift;    my $self = shift;
99    my ($format, $option) = @_;    my ($format, $option) = @_;
100    if ($format =~ /cgi/) {    if ($format =~ /http/) {
101      unshift @header_order, qw(content-type location);      $option->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'x-http'};
102      $option->{field_sort} = 'good-practice';      if ($format =~ /cgi/) {
103      $option->{use_folding} = 0;        #unshift @header_order, qw(content-type location);
104    } elsif ($format =~ /http/) {        $option->{field_sort} = 'good-practice';
105      $option->{field_sort} = 'good-practice';        $option->{use_folding} = 0;
106        } else {
107          $option->{field_sort} = 'good-practice';
108        }
109      } elsif ($format =~ /mail|news|mime/) {       ## RFC 822
110        $option->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'x-rfc822'};
111    }    }
112    if ($format =~ /uri-url-mailto/) {    if ($format =~ /uri-url-mailto/) {
113      $option->{output_bcc} = 0;      $option->{output_bcc} = 0;
# Line 207  sub parse ($$;%) { Line 155  sub parse ($$;%) {
155    } else {    } else {
156      $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};
157    }    }
158      my %option = (%{ $self->{option} });
159      $option{parse_all} = 0;
160    for my $field (split /\x0D?\x0A/, $header) {    for my $field (split /\x0D?\x0A/, $header) {
161      if ($field =~ /$REG{M_fromline}/) {      if ($field =~ /$REG{M_fromline}/) {
162        my ($s,undef,$value) = $self->_value_to_arrayitem        my ($s,undef,$value) = $self->_value_to_arrayitem
163          ('mail-from' => $1, $self->{option});          ('mail-from' => $1, \%option);
164        push @{$self->{value}}, $value if $s;        push @{$self->{value}}, $value if $s;
165      } elsif ($field =~ /$REG{M_field}/) {      } elsif ($field =~ /$REG{M_field}/) {
166        my ($name, $body) = ($1, $2);        my ($name, $body) = ($1, $2);
167        $body =~ s/$REG{WSP}+$//;        $body =~ s/$REG{WSP}+$//;
168        my ($s,undef,$value) = $self->_value_to_arrayitem        my ($s,undef,$value) = $self->_value_to_arrayitem
169          ($name => $body, $self->{option});          ($name => $body, \%option);
170        push @{$self->{value}}, $value if $s;        push @{$self->{value}}, $value if $s;
171      } elsif (length $field) {      } elsif (length $field) {
172        my ($s,undef,$value) = $self->_value_to_arrayitem        my ($s,undef,$value) = $self->_value_to_arrayitem
173          ('x-unknown' => $field, $self->{option});          ('x-unknown' => $field, \%option);
174        push @{$self->{value}}, $value if $s;        push @{$self->{value}}, $value if $s;
175      }      }
176    }    }
177      $self->_ns_associate_numerical_prefix;        ## RFC 2774 namespace
178      for (@{ $self->{value} }) {
179        no strict 'refs';
180        $_->{name}
181          = &{ ${ &_NS_uri2package ($_->{ns}).'::OPTION' }{n11n_name} }
182          ($self, &_NS_uri2package ($_->{ns}), $_->{name});
183        $_->{body} = $self->_parse_value ($_->{name} => $_->{body}, ns => $_->{ns})
184          if $self->{option}->{parse_all};
185      }
186    $self;    $self;
187  }  }
188    
# Line 276  sub parse_array ($\@;%) { Line 235  sub parse_array ($\@;%) {
235      }      }
236      last if $#$header < 0;      last if $#$header < 0;
237    }    }
238      $self->_ns_associate_numerical_prefix;        ## RFC 2774 namespace
239    $self;    $self;
240  }  }
241    
# Line 301  sub _item_match ($$\$\%\%) { Line 261  sub _item_match ($$\$\%\%) {
261    my ($by, $i, $list, $option) = @_;    my ($by, $i, $list, $option) = @_;
262    return 0 unless ref $$i;  ## Already removed    return 0 unless ref $$i;  ## Already removed
263    if ($by eq 'name') {    if ($by eq 'name') {
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 314  sub _item_match ($$\$\%\%) { Line 274  sub _item_match ($$\$\%\%) {
274      return 1 if $l{$$i->{name} . ':' . $$i->{ns}};      return 1 if $l{$$i->{name} . ':' . $$i->{ns}};
275    } elsif ($by eq 'ns') {    } elsif ($by eq 'ns') {
276      return 1 if $list->{ $$i->{ns} };      return 1 if $list->{ $$i->{ns} };
277      } elsif ($by eq 'http-ns-define') {
278        if ($$i->{ns} eq $self->{ns}->{phname2uri}->{'x-http'}
279         || $$i->{ns} eq $self->{ns}->{phname2uri}->{'x-http-c'}) {
280          my $n = $$i->{name};
281          if ($n eq 'opt' || $n eq 'c-opt' || $n eq 'man' || $n eq 'c-man') {
282            $option->{parse} = 0;
283            $$i->{body} = $self->_parse_value ($$i->{name} => $$i->{body}, ns => $$i->{ns});
284            for my $j (0..$$i->{body}->count-1) {
285              return 1 if $list->{ ($$i->{body}->value ($j))[0]->value };
286            }
287          }
288        }
289    }    }
290    0;    0;
291  }  }
# Line 334  sub _item_return_value ($\$\%) { Line 306  sub _item_return_value ($\$\%) {
306    
307  ## Returns returned (new created) item value    $name, \%option  ## Returns returned (new created) item value    $name, \%option
308  sub _item_new_value ($$\%) {  sub _item_new_value ($$\%) {
309      my ($s,undef,$value) = $_[0]->_value_to_arrayitem    my $self = shift;
310          ($_[1] => '', $_[2]);    my ($name, $option) = @_;
311      if ($option->{by} eq 'http-ns-define') {
312        my $value = $self->_parse_value (opt => '', ns => $self->{ns}->{phname2uri}->{'x-http'});
313        ($value->value (0))[0]->value ($name);
314        {name => 'opt', body => $value, ns => $self->{ns}->{phname2uri}->{'x-http'}};
315      } else {
316        my ($s,undef,$value) = $self->_value_to_arrayitem
317            ($name => '', $option);
318      $s? $value: undef;      $s? $value: undef;
319      }
320  }  }
321    
322    
# Line 348  sub _parse_value ($$$;%) { Line 328  sub _parse_value ($$$;%) {
328    my $value = shift;  return $value if ref $value;    my $value = shift;  return $value if ref $value;
329    my %option = @_;    my %option = @_;
330    my $vtype; { no strict 'refs';    my $vtype; { no strict 'refs';
331      my $vt = ${&_NS_uri2phpackage ($option{ns}).'::OPTION'}{value_type};      my $vt = ${&_NS_uri2package ($option{ns}).'::OPTION'}{value_type};
332      if (ref $vt) {      if (ref $vt) {
333        $vtype = $vt->{$name} || $vt->{$self->{option}->{_VALTYPE_DEFAULT}};        $vtype = $vt->{$name} || $vt->{$self->{option}->{_VALTYPE_DEFAULT}};
334      }      }
# Line 360  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 368  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 378  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 412  sub namespace_ph_default ($;$) { Line 394  sub namespace_ph_default ($;$) {
394    if (defined $_[0]) {    if (defined $_[0]) {
395      no strict 'refs';      no strict 'refs';
396      $self->{option}->{ns_default_phuri} = $_[0];      $self->{option}->{ns_default_phuri} = $_[0];
397      $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});
398    }    }
399    $self->{option}->{ns_default_phuri};    $self->{option}->{ns_default_phuri};
400  }  }
# Line 453  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}+$//;
441        
442    no strict 'refs';    no strict 'refs';
443    if ($value_option->{ns}) {    if ($value_option->{ns}) {
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 ($name =~ s/^([Xx]-[A-Za-z]+|[A-Za-z]+)-//) {    } elsif (($default_ns eq $self->{ns}->{phname2uri}->{'x-http'}
448      my $oprefix = $1;         && $name =~ s/^([0-9]+)-//)
449        || ($name =~ s/^x-http-([0-9]+)-//i)) {     ## Numric namespace prefix, RFC 2774
450        my $prefix = 0+$1;
451        $nsuri = $self->{ns}->{number2uri}->{ $prefix };
452        unless ($nsuri) {
453          $self->{ns}->{number2uri}->{ $prefix } = 'urn:x-suika-fam-cx:msgpm:header:x-temp:'.$prefix;
454          $nsuri = $self->{ns}->{number2uri}->{ $prefix };
455        }
456      } elsif (
457        ${ &_NS_uri2package ($default_ns).'::OPTION' }{use_ph_namespace}
458        && (
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);
464        my $original_prefix = $&;  my $one_prefix = 0;
465        unless ($prefix2) {
466          $prefix2 = $prefix1;
467          $prefix1 = $self->{ns}->{uri2phname}->{ $default_ns };
468          $one_prefix = 1;
469        }
470      my $prefix      my $prefix
471        = &{${&_NS_uri2phpackage ($nsuri).'::OPTION'}{n11n_prefix}}        = &{ ${ &_NS_uri2package ($nsuri).'::OPTION' }{n11n_prefix} }
472          ($self, &_NS_uri2phpackage ($nsuri), $oprefix);          ($self, &_NS_uri2package ($nsuri), $prefix1.'-'.$prefix2);
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        $name = $oprefix . '-' . $name;        $nsuri = $default_ns;
477        $nsuri = $self->{option}->{ns_default_phuri};        $prefix
478            = &{ ${ &_NS_uri2package ($nsuri).'::OPTION' }{n11n_prefix} }
479              ($self, &_NS_uri2package ($nsuri), $one_prefix? $prefix2:
480               $prefix1);
481          $self->_ns_load_ph ($prefix);
482          $nsuri = $self->{ns}->{phname2uri}->{ $prefix };
483          if ($nsuri) {
484            $name = $prefix2 . '-' . $name unless $one_prefix;
485          } else {
486            unless ($one_prefix) {
487              $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_uri2phpackage ($nsuri).'::OPTION'}{n11n_name}}      = &{ ${ &_NS_uri2package ($nsuri).'::OPTION' }{n11n_name} }
506        ($self, &_NS_uri2phpackage ($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 566  sub rename ($%) { Line 595  sub rename ($%) {
595    $self if defined wantarray;    $self if defined wantarray;
596  }  }
597    
598    sub resent_item ($$$;%) {
599      my $self = shift;
600      my ($index, $item_name, %option) = @_;
601      ## TODO: implement this
602    }
603    
604  =item $self->scan(\&doit)  =item $self->scan(\&doit)
605    
# Line 577  for each value. Line 611  for each value.
611  =cut  =cut
612    
613  sub _scan_sort ($\@\%) {  sub _scan_sort ($\@\%) {
614      no strict 'refs';
615    my $self = shift;    my $self = shift;
616    my ($array, $option) = @_;    my ($array, $option) = @_;
617    my $sort;    my $nspack = &_NS_uri2package ($self->{option}->{ns_default_phuri});
618    $sort = \&_header_cmp if $option->{field_sort} eq 'good-practice';    my $sort = ${ $nspack.'::OPTION' }{field_sort};
619    $sort = {$a cmp $b} if $option->{field_sort} eq 'alphabetic';    if ($option->{field_sort} eq 'good-practice' && $sort->{'good-practice'}) {
620    return ( sort $sort @$array ) if ref $sort;      return $self->Message::Header::Default::sort_good_practice ($array, $nspack, $option);
621      } elsif ($option->{field_sort} eq 'alphabetic' && $sort->{'alphabetic'}) {
622        ## TODO: How treat namespace prefix?
623        return sort {$a->{name} cmp $b->{name}} @$array;
624      }
625    @$array;    @$array;
626  }  }
627    
# Line 591  sub _n11n_field_name ($$) { Line 630  sub _n11n_field_name ($$) {
630    my $self = shift;    my $self = shift;
631    my $s = shift;    my $s = shift;
632    $s =~ s/^$REG{WSP}+//; $s =~ s/$REG{WSP}+$//;    $s =~ s/^$REG{WSP}+//; $s =~ s/$REG{WSP}+$//;
633    $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};
634    $s;    $s;
635  }  }
636    
 # 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;  
 }  
637    
638  =head2 $self->stringify ([%option])  =head2 $self->stringify ([%option])
639    
# Line 621  sub stringify ($;%) { Line 646  sub stringify ($;%) {
646    my %params = @_;    my %params = @_;
647    my %option = %{$self->{option}};    my %option = %{$self->{option}};
648    $option{format} = $params{-format} if $params{-format};    $option{format} = $params{-format} if $params{-format};
649    $self->_init_by_format ($option{format}, \%option);    $self->_init_by_format ($option{format}, \%option)
650        if $self->{option}->{format} ne $option{format};
651    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
652      ## Fill required fields
653        my %exist;
654        for ($self->field_name_list) {$exist{$_} = 1}
655        &{ $option{hook_stringify_fill_fields} } ($self, \%exist, \%option);
656    my @ret;    my @ret;
657      ## RFC 2774 numerical field name prefix
658      my %nprefix;
659      {no strict 'refs';
660        %nprefix = reverse %{ $self->{ns}->{number2uri} };
661        my $i = (sort { $a <=> $b } keys %{ $self->{ns}->{number2uri} })[-1] + 1;
662        $i = 10 if $i < 10;
663        my $hprefix = ${ &_NS_uri2package
664                           ($self->{ns}->{phname2uri}->{'x-http'})
665                           .'::OPTION' } {namespace_phname_goodcase};
666        for my $uri (keys %nprefix) {
667          if ($nprefix{ $uri } < 10) {
668            $nprefix{ $uri } = $i++;
669          }
670          my $nsfs = $self->item ($uri, -by => 'http-ns-define');
671          for my $i (0..$nsfs->count-1) {
672            my $nsf = ($nsfs->value ($i))[0];
673            if ($nsf->value eq $uri) {
674              $nsf->replace (ns => $nprefix{ $uri });
675              $nprefix{ $uri } = $hprefix . '-' . $nprefix{ $uri };
676              last;
677            }
678          }
679        }
680      }
681    my $_stringify = sub {    my $_stringify = sub {
682      no strict 'refs';      no strict 'refs';
683        my ($name, $body, $nsuri) = ($_[1]->{name}, $_[1]->{body}, $_[1]->{ns});        my ($name, $body, $nsuri) = ($_[1]->{name}, $_[1]->{body}, $_[1]->{ns});
684        return unless length $name;        return unless length $name;
685        return if $option{output_mail_from} && $name eq 'mail-from';        return if $option{output_mail_from} && $name eq 'mail-from';
686        return if !$option{output_bcc} && ($name eq 'bcc' || $name eq 'resent-bcc');        $body = '' if !$option{output_bcc} && $name eq 'bcc';
687        my $nspackage = &_NS_uri2phpackage ($nsuri);        my $nspackage = &_NS_uri2package ($nsuri);
688        my $oname;        ## Outputed field-name        my $oname;        ## Outputed field-name
689        my $prefix = ${$nspackage.'::OPTION'} {namespace_phname_goodcase}        my $prefix = $nprefix{ $nsuri }
690                  || $self->{ns}->{uri2phname}->{$nsuri};                  || ${$nspackage.'::OPTION'} {namespace_phname_goodcase}
691        $prefix = undef if $nsuri eq $self->{option}->{ns_default_phuri};                  || $self->{ns}->{uri2phname}->{ $nsuri };
692          my $default_prefix = ${ &_NS_uri2package ($option{ns_default_phuri})
693                                  .'::OPTION'} {namespace_phname_goodcase};
694          $prefix = '' if $prefix eq $default_prefix;
695          $prefix =~ s/^\Q$default_prefix\E-//;
696        my $gc = ${$nspackage.'::OPTION'} {to_be_goodcase};        my $gc = ${$nspackage.'::OPTION'} {to_be_goodcase};
697        if (ref $gc) { $oname = &$gc ($self, $nspackage, $name, \%option) }        if (ref $gc) { $oname = &$gc ($self, $nspackage, $name, \%option) }
698        else { $oname = $name }        else { $oname = $name }
# Line 659  sub stringify ($;%) { Line 717  sub stringify ($;%) {
717        } else {        } else {
718          $fbody = $body;          $fbody = $body;
719        }        }
720        return unless length $fbody;        unless (${$nspackage.'::OPTION'} {field}->{$name}->{empty_body}) {
721            return unless length $fbody;
722          }
723        unless ($option{linebreak_strict}) {        unless ($option{linebreak_strict}) {
724          ## bare \x0D and bare \x0A are unsafe          ## bare \x0D and bare \x0A are unsafe
725          $fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;          $fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;
# Line 762  sub _ns_load_ph ($$) { Line 822  sub _ns_load_ph ($$) {
822    my $name = shift;     ## normalized prefix (without HYPHEN-MINUS)    my $name = shift;     ## normalized prefix (without HYPHEN-MINUS)
823    return if $self->{ns}->{phname2uri}->{$name};    return if $self->{ns}->{phname2uri}->{$name};
824    $self->{ns}->{phname2uri}->{$name} = $NS_phname2uri{$name};    $self->{ns}->{phname2uri}->{$name} = $NS_phname2uri{$name};
825    return unless $self->{ns}->{phname2uri}->{$name};    $self->{ns}->{uri2phname}->{ $self->{ns}->{phname2uri}->{$name} } = $name;
826    $self->{ns}->{uri2phname}->{$self->{ns}->{phname2uri}->{$name}} = $name;  }
827    
828    sub _ns_associate_numerical_prefix ($) {
829      my $self = shift;
830      $self->scan (sub {shift;
831        my $f = shift;  return unless $f->{name};
832        if ($f->{ns} eq $self->{ns}->{phname2uri}->{'x-http'}
833         || $f->{ns} eq $self->{ns}->{phname2uri}->{'x-http-c'}) {
834          my $fn = $f->{name};
835          if ($fn eq 'opt' || $fn eq 'man') {
836            $f->{body} = $self->_parse_value ($fn => $f->{body}, ns => $f->{ns});
837            for ($f->{body}->value (0..$f->{body}->count-1)) {
838              my ($nsuri, $number) = ($_->value, $_->item ('ns'));
839              if ($number && $nsuri) {
840                $self->{ns}->{number2uri}->{ $number } = $nsuri;
841              }
842            }
843          }
844        }
845      });
846      $self->scan (sub {shift;
847        my $f = shift;
848        if ($f->{ns} =~ /urn:x-suika-fam-cx:msgpm:header:x-temp:([0-9]+)$/ && $self->{ns}->{number2uri}->{ $1 }) {
849          $f->{ns} = $self->{ns}->{number2uri}->{ $1 };
850        }
851      });
852  }  }
853    
854    ## $package_name = Message::Header::_NS_uri2phpackage ($nsuri)
855    ## (For internal use of Message::* modules)
856  sub _NS_uri2phpackage ($) {  sub _NS_uri2phpackage ($) {
857    $NS_uri2phpackage{$_[0]}    $NS_uri2phpackage{$_[0]}
858    || $NS_uri2phpackage{$Message::Header::Default::OPTION{namespace_uri}};    || $NS_uri2phpackage{$Message::Header::Default::OPTION{namespace_uri}};
859  }  }
860    sub _NS_uri2package ($) {
861      $NS_uri2package{$_[0]}
862      || $NS_uri2phpackage{$_[0]}
863      || $NS_uri2phpackage{$Message::Header::Default::OPTION{namespace_uri}};
864    }
865    
866  =head2 $self->clone ()  =head2 $self->clone ()
867    
Legend:
Removed from v.1.29  
changed lines
  Added in v.1.41
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24