/[suikacvs]/test/cvs
Suika

Diff of /test/cvs

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

revision 1.21 by wakaba, Sun May 26 01:20:09 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 30  push @ISA, qw(Message::Field::Structured Line 31  push @ISA, qw(Message::Field::Structured
31      -_HASH_NAME => 'value',      -_HASH_NAME => 'value',
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|],
     -M_namsepace_prefix_regex => qr/(?!)/,  
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      => 1,   ## Method level option.      -field_name_validation      => 0,
40      -field_sort => 0,      -field_sort => 0,
41      #-format    => 'mail-rfc2822',      -format     => 'mail-rfc2822',
42      -linebreak_strict   => 0,   ## Not implemented completely      -header_default_charset     => 'iso-2022-int-1',
43        -header_default_charset_input       => 'iso-2022-int-1',
44        -linebreak_strict   => 0,
45      -line_length_max    => 60,  ## For folding      -line_length_max    => 60,  ## For folding
46      -ns_default_uri     => $Message::Header::Default::OPTION{namespace_uri},      #ns_default_phuri
47      -output_bcc => 0,      -output_bcc => 0,
48      -output_folding     => 1,      -output_folding     => 1,
49      -output_mail_from   => 0,      -output_mail_from   => 0,
50      #-parse_all => 0,      #parse_all
51      -translate_underscore       => 1,      -translate_underscore       => 1,
52      #-uri_mailto_safe      #uri_mailto_safe
53      -uri_mailto_safe_level      => 4,      -uri_mailto_safe_level      => 4,
54      -use_folding        => 1,      -use_folding        => 1,
55      #-value_type      #value_type
 );  
   
 $DEFAULT{-value_type} = {  
         ':default'      => ['Message::Field::Unstructured'],  
           
         p3p     => ['Message::Field::Params'],  
         link    => ['Message::Field::ValueParams'],  
           
         'list-software' => ['Message::Field::UA'],  
         'user-agent'    => ['Message::Field::UA'],  
         server  => ['Message::Field::UA'],  
 };  
 for (qw(pics-label list-id status))  
   {$DEFAULT{-value_type}->{$_} = ['Message::Field::Structured']}  
         ## Not supported yet, but to be supported...  
         # x-list: unstructured, ml name  
 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',  
56  );  );
57    
58  ## taken from L<HTTP::Header>  ## taken from L<HTTP::Header>
# Line 128  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}->{default_phuri} = $self->{ns}->{phname2uri}->{'default'};    $self->_ns_load_ph ('x-rfc822');
104    $self->_ns_load_ph ('rfc822');    $self->_ns_load_ph ('x-http');
105    $self->{ns}->{default_phuri} = $self->{ns}->{phname2uri}->{'rfc822'};    $self->{option}->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'x-rfc822'}
106        unless $self->{option}->{ns_default_phuri};
107        
108      ## For text/rfc822-headers
109      if (ref $options{entity_header}) {
110        $self->{entity_header} = $options{entity_header};
111        delete $options{entity_header};
112      }
113    my @new_fields = ();    my @new_fields = ();
114    for my $name (keys %options) {    for my $name (keys %options) {
115      unless (substr ($name, 0, 1) eq '-') {      unless (substr ($name, 0, 1) eq '-') {
# Line 153  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/) {    return if $format eq $option->{format};
135      unshift @header_order, qw(content-type location);    if ($format =~ /http/) {
136      $option->{field_sort} = 'good-practice';      $option->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'x-http'};
137      $option->{use_folding} = 0;      if ($format =~ /cgi/) {
138    } elsif ($format =~ /http/) {        unshift @header_order, qw(content-type location);
139      $option->{field_sort} = 'good-practice';        $option->{field_sort} = 'good-practice';
140          $option->{use_folding} = 0;
141        } else {
142          $option->{field_sort} = 'good-practice';
143        }
144      } elsif ($format =~ /mail|news/) {    ## RFC 822
145        $option->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'x-rfc822'};
146    }    }
147    if ($format =~ /uri-url-mailto/) {    if ($format =~ /uri-url-mailto/) {
148      $option->{output_bcc} = 0;      $option->{output_bcc} = 0;
# Line 200  sub parse ($$;%) { Line 184  sub parse ($$;%) {
184    my $class = shift;    my $class = shift;
185    my $header = shift;    my $header = shift;
186    my $self = bless {}, $class;    my $self = bless {}, $class;
187    $self->_init (@_);    ## BUG: don't check linebreak_strict    $self->_init (@_);
188    $header =~ s/\x0D?\x0A$REG{WSP}/\x20/gos if $self->{option}->{use_folding};    if ($self->{option}->{linebreak_strict}) {
189        $header =~ s/\x0D\x0A$REG{WSP}/\x20/gos if $self->{option}->{use_folding};
190      } else {
191        $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;
206        } elsif (length $field) {
207          my ($s,undef,$value) = $self->_value_to_arrayitem
208            ('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
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 260  sub parse_array ($\@;%) { Line 263  sub parse_array ($\@;%) {
263        my ($s,undef,$value) = $self->_value_to_arrayitem        my ($s,undef,$value) = $self->_value_to_arrayitem
264          ($name => $body, $self->{option});          ($name => $body, $self->{option});
265        push @{$self->{value}}, $value if $s;        push @{$self->{value}}, $value if $s;
266        } elsif (length $field) {
267          my ($s,undef,$value) = $self->_value_to_arrayitem
268            ('x-unknown' => $field, $self->{option});
269          push @{$self->{value}}, $value if $s;
270      }      }
271      last if $#$header < 0;      last if $#$header < 0;
272    }    }
273      $self->_ns_associate_numerical_prefix;        ## RFC 2774 namespace
274    $self;    $self;
275  }  }
276    
# Line 288  sub _item_match ($$\$\%\%) { Line 296  sub _item_match ($$\$\%\%) {
296    my ($by, $i, $list, $option) = @_;    my ($by, $i, $list, $option) = @_;
297    return 0 unless ref $$i;  ## Already removed    return 0 unless ref $$i;  ## Already removed
298    if ($by eq 'name') {    if ($by eq 'name') {
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 {
306          $l{$v->{name} .':'. ( $option->{ns} || $self->{ns}->{default_phuri} ) } = 1;          $l{$v->{name} .':'. ( $option->{ns} || $self->{option}->{ns_default_phuri} ) } = 1;
307        }        }
308      }      }
309      return 1 if $l{$$i->{name} . ':' . $$i->{ns}};      return 1 if $l{$$i->{name} . ':' . $$i->{ns}};
310      } elsif ($by eq 'ns') {
311        return 1 if $list->{ $$i->{ns} };
312      } elsif ($by eq 'http-ns-define') {
313        if ($$i->{ns} eq $self->{ns}->{phname2uri}->{'x-http'}
314         || $$i->{ns} eq $self->{ns}->{phname2uri}->{'x-http-c'}) {
315          my $n = $$i->{name};
316          if ($n eq 'opt' || $n eq 'c-opt' || $n eq 'man' || $n eq 'c-man') {
317            $option->{parse} = 0;
318            $$i->{body} = $self->_parse_value ($$i->{name} => $$i->{body}, ns => $$i->{ns});
319            for my $j (0..$$i->{body}->count-1) {
320              return 1 if $list->{ ($$i->{body}->value ($j))[0]->value };
321            }
322          }
323        }
324    }    }
325    0;    0;
326  }  }
# Line 314  sub _item_return_value ($\$\%) { Line 336  sub _item_return_value ($\$\%) {
336      ${$_[1]}->{body};      ${$_[1]}->{body};
337    }    }
338  }  }
339    *_add_return_value = \&_item_return_value;
340    *_replace_return_value = \&_item_return_value;
341    
342  ## Returns returned (new created) item value    $name, \%option  ## Returns returned (new created) item value    $name, \%option
343  sub _item_new_value ($$\%) {  sub _item_new_value ($$\%) {
344      my ($s,undef,$value) = $_[0]->_value_to_arrayitem    my $self = shift;
345          ($_[1] => '', $_[2]);    my ($name, $option) = @_;
346      if ($option->{by} eq 'http-ns-define') {
347        my $value = $self->_parse_value (opt => '', ns => $self->{ns}->{phname2uri}->{'x-http'});
348        ($value->value (0))[0]->value ($name);
349        {name => 'opt', body => $value, ns => $self->{ns}->{phname2uri}->{'x-http'}};
350      } else {
351        my ($s,undef,$value) = $self->_value_to_arrayitem
352            ($name => '', $option);
353      $s? $value: undef;      $s? $value: undef;
354      }
355  }  }
356    
357    
# Line 331  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      $vtype = ${&_NS_uri2phpackage ($option{ns}).'::OPTION'}{value_type};      my $vt = ${&_NS_uri2package ($option{ns}).'::OPTION'}{value_type};
367      if (ref $vtype) { $vtype = $vtype->{$name} }      if (ref $vt) {
368      unless (ref $vtype) { $vtype = $vtype->{$self->{option}->{_VALTYPE_DEFAULT}} }        $vtype = $vt->{$name} || $vt->{$self->{option}->{_VALTYPE_DEFAULT}};
369        }
370      ## For compatiblity.      ## For compatiblity.
371      unless (ref $vtype) { $vtype = $self->{option}->{value_type}->{$name}      unless (ref $vtype) { $vtype = $self->{option}->{value_type}->{$name}
372        || $self->{option}->{value_type}->{$self->{option}->{_VALTYPE_DEFAULT}} }        || $self->{option}->{value_type}->{$self->{option}->{_VALTYPE_DEFAULT}} }
# Line 348  sub _parse_value ($$$;%) { Line 381  sub _parse_value ($$$;%) {
381        -format   => $self->{option}->{format},        -format   => $self->{option}->{format},
382        -field_ns => $option{ns},        -field_ns => $option{ns},
383        -field_name       => $name,        -field_name       => $name,
384        -header_default_charset     => $self->{option}->{header_default_charset},
385        -header_default_charset_input       => $self->{option}->{header_default_charset_input},
386        -parse_all        => $self->{option}->{parse_all},        -parse_all        => $self->{option}->{parse_all},
387      %vopt);      %vopt);
388    } else {    } else {
# Line 356  sub _parse_value ($$$;%) { Line 391  sub _parse_value ($$$;%) {
391        -format   => $self->{option}->{format},        -format   => $self->{option}->{format},
392        -field_ns => $option{ns},        -field_ns => $option{ns},
393        -field_name       => $name,        -field_name       => $name,
394        -header_default_charset     => $self->{option}->{header_default_charset},
395        -header_default_charset_input       => $self->{option}->{header_default_charset_input},
396        -parse_all        => $self->{option}->{parse_all},        -parse_all        => $self->{option}->{parse_all},
397      %vopt);      %vopt);
398    }    }
399  }  }
400    
401    ## Defined for text/rfc822-headers
402    sub entity_header ($;$) {
403      my $self = shift;
404      my $new_header = shift;
405      if (ref $new_header) {
406        $self->{header} = $new_header;
407      }
408      $self->{header};
409    }
410    
411  =head2 $self->field_name_list ()  =head2 $self->field_name_list ()
412    
413  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 379  sub namespace_ph_default ($;$) { Line 426  sub namespace_ph_default ($;$) {
426    my $self = shift;    my $self = shift;
427    if (defined $_[0]) {    if (defined $_[0]) {
428      no strict 'refs';      no strict 'refs';
429      $self->{ns}->{default_phuri} = $_[0];      $self->{option}->{ns_default_phuri} = $_[0];
430      $self->_ns_load_ph (${&_NS_uri2phpackage ($self->{ns}->{default_phuri}).'::OPTION'}{namespace_phname});      $self->_ns_load_ph (${&_NS_uri2package ($self->{option}->{ns_default_phuri}).'::OPTION'}{namespace_phname});
431    }    }
432    $self->{ns}->{default_phuri};    $self->{option}->{ns_default_phuri};
433  }  }
434    
435  =item $hdr->add ($field-name, $field-body, [$name, $body, ...])  =item $hdr->add ($field-name, $field-body, [$name, $body, ...])
# Line 421  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->{ns}->{default_phuri};    my $default_ns = $option->{ns_default_phuri};
472      my $nsuri = $default_ns;
473      $name =~ s/^$REG{WSP}+//;  $name =~ s/$REG{WSP}+$//;
474      
475    no strict 'refs';    no strict 'refs';
476    if ($option->{ns}) {    if ($value_option->{ns}) {
477        $nsuri = $value_option->{ns};
478      } elsif ($option->{ns}) {
479      $nsuri = $option->{ns};      $nsuri = $option->{ns};
480    } elsif ($name =~ s/^([Xx]-[A-Za-z]+|[A-Za-z]+)-//) {    } elsif (($default_ns eq $self->{ns}->{uri2phname}->{'x-http'}
481      my $oprefix = $1;         && $name =~ s/^([0-9]+)-//)
482        || ($name =~ s/^x-http-([0-9]+)-//i)) {     ## Numric namespace prefix, RFC 2774
483        my $prefix = 0+$1;
484        $nsuri = $self->{ns}->{number2uri}->{ $prefix };
485        unless ($nsuri) {
486          $self->{ns}->{number2uri}->{ $prefix } = 'urn:x-suika-fam-cx:msgpm:header:x-temp:'.$prefix;
487          $nsuri = $self->{ns}->{number2uri}->{ $prefix };
488        }
489      } elsif (
490        ${ &_NS_uri2package ($default_ns).'::OPTION' }{use_ph_namespace}
491        && (
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);
497        my $original_prefix = $&;  my $one_prefix = 0;
498        unless ($prefix2) {
499          $prefix2 = $prefix1;
500          $prefix1 = $self->{ns}->{uri2phname}->{ $default_ns };
501          $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), $oprefix);          ($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        $name = $oprefix . '-' . $name;        $nsuri = $default_ns;
510        $nsuri = $self->{ns}->{default_phuri};        $prefix
511            = &{ ${ &_NS_uri2package ($nsuri).'::OPTION' }{n11n_prefix} }
512              ($self, &_NS_uri2package ($nsuri), $one_prefix? $prefix2: $prefix1);
513          $self->_ns_load_ph ($prefix);
514          $nsuri = $self->{ns}->{phname2uri}->{ $prefix };
515          if ($nsuri) {
516            $name = $prefix2 . '-' . $name unless $one_prefix;
517          } else {
518            $name = $original_prefix . $name;
519            $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) if $$option{parse};    $value = $self->_parse_value ($name => $value, ns => $nsuri)
530    $$option{parse} = 0;      if $option->{parse} || $option->{parse_all};
531      $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 461  first one is used and the others are not Line 545  first one is used and the others are not
545  =cut  =cut
546    
547  sub _replace_hash_shift ($\%$\%) {  sub _replace_hash_shift ($\%$\%) {
548    shift; my $r = shift;  my $n = $_[0]->{name};    shift; my $r = shift;  my $n = $_[0]->{name} . ':' . $_[0]->{ns};
549    if ($$r{$n}) {    if ($$r{$n}) {
550      my $d = $$r{$n};      my $d = $$r{$n};
551      delete $$r{$n};      delete $$r{$n};
# Line 551  sub _scan_sort ($\@\%) { Line 635  sub _scan_sort ($\@\%) {
635  }  }
636    
637  sub _n11n_field_name ($$) {  sub _n11n_field_name ($$) {
638      no strict 'refs';
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 $self->{option}->{field_name_case_sensible};    $s = lc $s unless ${&_NS_uri2package ($self->{option}->{ns_default_phuri}).'::OPTION'}{case_sensible};
643    $s;    $s;
644  }  }
645    
# Line 587  sub stringify ($;%) { Line 672  sub stringify ($;%) {
672    $self->_init_by_format ($option{format}, \%option);    $self->_init_by_format ($option{format}, \%option);
673    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}    for (grep {/^-/} keys %params) {$option{substr ($_, 1)} = $params{$_}}
674    my @ret;    my @ret;
675      ## RFC 2774 numerical field name prefix
676      my %nprefix;
677      {no strict 'refs';
678        %nprefix = reverse %{ $self->{ns}->{number2uri} };
679        my $i = (sort { $a <=> $b } keys %{ $self->{ns}->{number2uri} })[-1] + 1;
680        $i = 10 if $i < 10;
681        my $hprefix = ${ &_NS_uri2package
682                           ($self->{ns}->{phname2uri}->{'x-http'})
683                           .'::OPTION' } {namespace_phname_goodcase};
684        for my $uri (keys %nprefix) {
685          if ($nprefix{ $uri } < 10) {
686            $nprefix{ $uri } = $i++;
687          }
688          my $nsfs = $self->item ($uri, -by => 'http-ns-define');
689          for my $i (0..$nsfs->count-1) {
690            my $nsf = ($nsfs->value ($i))[0];
691            if ($nsf->value eq $uri) {
692              $nsf->replace (ns => $nprefix{ $uri });
693              $nprefix{ $uri } = $hprefix . '-' . $nprefix{ $uri };
694              last;
695            }
696          }
697        }
698      }
699    my $_stringify = sub {    my $_stringify = sub {
700      no strict 'refs';      no strict 'refs';
701        my ($name, $body, $nsuri) = ($_[1]->{name}, $_[1]->{body}, $_[1]->{ns});        my ($name, $body, $nsuri) = ($_[1]->{name}, $_[1]->{body}, $_[1]->{ns});
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        return if !$option{output_bcc} && ($name eq 'bcc' || $name eq 'resent-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 = ${$nspackage.'::OPTION'} {namespace_phname_goodcase}        my $prefix = $nprefix{ $nsuri }
708                  || $self->{ns}->{uri2phname}->{$nsuri};                  || ${$nspackage.'::OPTION'} {namespace_phname_goodcase}
709        $prefix = undef if $nsuri eq $self->{ns}->{default_phuri};                  || $self->{ns}->{uri2phname}->{ $nsuri };
710          my $default_prefix = ${ &_NS_uri2package ($option{ns_default_phuri})
711                                  .'::OPTION'} {namespace_phname_goodcase};
712          $prefix = '' if $prefix eq $default_prefix;
713          $prefix =~ s/^\Q$default_prefix\E-//;
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 622  sub stringify ($;%) { Line 735  sub stringify ($;%) {
735        } else {        } else {
736          $fbody = $body;          $fbody = $body;
737        }        }
738        return unless length $fbody;        unless (${$nspackage.'::OPTION'} {field}->{$name}->{empty_body}) {
739            return unless length $fbody;
740          }
741        unless ($option{linebreak_strict}) {        unless ($option{linebreak_strict}) {
742          ## bare \x0D and bare \x0A are unsafe          ## bare \x0D and bare \x0A are unsafe
743          $fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;          $fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;
# Line 708  sub _fold ($$;%) { Line 823  sub _fold ($$;%) {
823    $max = 20 if $max < 20;    $max = 20 if $max < 20;
824        
825    my $l = $option{-initial_length} || 0;    my $l = $option{-initial_length} || 0;
826      $l += length $1 if $string =~ /^([^\x09\x20]+)/;
827    $string =~ s{([\x09\x20][^\x09\x20]+)}{    $string =~ s{([\x09\x20][^\x09\x20]+)}{
828      my $s = $1;      my $s = $1;
829      if ($l + length $s > $max) {      if (($l + length $s) > $max) {
830        $s = "\x0D\x0A\x20" . $s;        $s = "\x0D\x0A\x20" . $s;
831        $l = length ($s) - 2;        $l = 1 + length $s;
832      } else { $l += length $s }      } else { $l += length $s }
833      $s;      $s;
834    }gex;    }gex;
# Line 728  sub _ns_load_ph ($$) { Line 844  sub _ns_load_ph ($$) {
844    $self->{ns}->{uri2phname}->{$self->{ns}->{phname2uri}->{$name}} = $name;    $self->{ns}->{uri2phname}->{$self->{ns}->{phname2uri}->{$name}} = $name;
845  }  }
846    
847    sub _ns_associate_numerical_prefix ($) {
848      my $self = shift;
849      $self->scan (sub {shift;
850        my $f = shift;  return unless $f->{name};
851        if ($f->{ns} eq $self->{ns}->{phname2uri}->{'x-http'}
852         || $f->{ns} eq $self->{ns}->{phname2uri}->{'x-http-c'}) {
853          my $fn = $f->{name};
854          if ($fn eq 'opt' || $fn eq 'man') {
855            $f->{body} = $self->_parse_value ($fn => $f->{body}, ns => $f->{ns});
856            for ($f->{body}->value (0..$f->{body}->count-1)) {
857              my ($nsuri, $number) = ($_->value, $_->item ('ns'));
858              if ($number && $nsuri) {
859                $self->{ns}->{number2uri}->{ $number } = $nsuri;
860              }
861            }
862          }
863        }
864      });
865      $self->scan (sub {shift;
866        my $f = shift;
867        if ($f->{ns} =~ /urn:x-suika-fam-cx:msgpm:header:x-temp:([0-9]+)$/ && $self->{ns}->{number2uri}->{ $1 }) {
868          $f->{ns} = $self->{ns}->{number2uri}->{ $1 };
869        }
870      });
871    }
872    
873    ## $package_name = Message::Header::_NS_uri2phpackage ($nsuri)
874    ## (For internal use of Message::* modules)
875  sub _NS_uri2phpackage ($) {  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.21  
changed lines
  Added in v.1.34
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24