/[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.30 by wakaba, Thu Jul 4 06:38:21 2002 UTC
# Line 30  push @ISA, qw(Message::Field::Structured Line 30  push @ISA, qw(Message::Field::Structured
30      -_HASH_NAME => 'value',      -_HASH_NAME => 'value',
31      -_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|],
32      -_MEMBERS   => [qw|value|],      -_MEMBERS   => [qw|value|],
     -M_namsepace_prefix_regex => qr/(?!)/,  
33      -_VALTYPE_DEFAULT   => ':default',      -_VALTYPE_DEFAULT   => ':default',
34      -by => 'name',      ## (Reserved for method level option)      -by => 'name',
35      -field_format_pattern       => '%s: %s',      -field_format_pattern       => '%s: %s',
36      -field_name_case_sensible   => 0,      -field_name_case_sensible   => 0,
37      -field_name_unsafe_rule     => 'NON_ftext',      -field_name_unsafe_rule     => 'NON_ftext',
38      -field_name_validation      => 1,   ## Method level option.      -field_name_validation      => 0,
39      -field_sort => 0,      -field_sort => 0,
40      #-format    => 'mail-rfc2822',      -format     => 'mail-rfc2822',
41      -linebreak_strict   => 0,   ## Not implemented completely      -header_default_charset     => 'iso-2022-int-1',
42        -header_default_charset_input       => 'iso-2022-int-1',
43        -linebreak_strict   => 0,
44      -line_length_max    => 60,  ## For folding      -line_length_max    => 60,  ## For folding
45      -ns_default_uri     => $Message::Header::Default::OPTION{namespace_uri},      #ns_default_phuri
46      -output_bcc => 0,      -output_bcc => 0,
47      -output_folding     => 1,      -output_folding     => 1,
48      -output_mail_from   => 0,      -output_mail_from   => 0,
49      #-parse_all => 0,      #parse_all
50      -translate_underscore       => 1,      -translate_underscore       => 1,
51      #-uri_mailto_safe      #uri_mailto_safe
52      -uri_mailto_safe_level      => 4,      -uri_mailto_safe_level      => 4,
53      -use_folding        => 1,      -use_folding        => 1,
54      #-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',  
55  );  );
56    
57  ## taken from L<HTTP::Header>  ## taken from L<HTTP::Header>
# Line 128  sub _init ($;%) { Line 99  sub _init ($;%) {
99    $self->SUPER::_init (%$DEFAULT, %options);    $self->SUPER::_init (%$DEFAULT, %options);
100    $self->{value} = [];    $self->{value} = [];
101    $self->_ns_load_ph ('default');    $self->_ns_load_ph ('default');
   $self->{ns}->{default_phuri} = $self->{ns}->{phname2uri}->{'default'};  
102    $self->_ns_load_ph ('rfc822');    $self->_ns_load_ph ('rfc822');
103    $self->{ns}->{default_phuri} = $self->{ns}->{phname2uri}->{'rfc822'};    $self->{option}->{ns_default_phuri} = $self->{ns}->{phname2uri}->{'rfc822'}
104        unless $self->{option}->{ns_default_phuri};
105        
106      ## For text/rfc822-headers
107      if (ref $options{entity_header}) {
108        $self->{entity_header} = $options{entity_header};
109        delete $options{entity_header};
110      }
111    my @new_fields = ();    my @new_fields = ();
112    for my $name (keys %options) {    for my $name (keys %options) {
113      unless (substr ($name, 0, 1) eq '-') {      unless (substr ($name, 0, 1) eq '-') {
# Line 200  sub parse ($$;%) { Line 176  sub parse ($$;%) {
176    my $class = shift;    my $class = shift;
177    my $header = shift;    my $header = shift;
178    my $self = bless {}, $class;    my $self = bless {}, $class;
179    $self->_init (@_);    ## BUG: don't check linebreak_strict    $self->_init (@_);
180    $header =~ s/\x0D?\x0A$REG{WSP}/\x20/gos if $self->{option}->{use_folding};    if ($self->{option}->{linebreak_strict}) {
181        $header =~ s/\x0D\x0A$REG{WSP}/\x20/gos if $self->{option}->{use_folding};
182      } else {
183        $header =~ s/\x0D?\x0A$REG{WSP}/\x20/gos if $self->{option}->{use_folding};
184      }
185    for my $field (split /\x0D?\x0A/, $header) {    for my $field (split /\x0D?\x0A/, $header) {
186      if ($field =~ /$REG{M_fromline}/) {      if ($field =~ /$REG{M_fromline}/) {
187        my ($s,undef,$value) = $self->_value_to_arrayitem        my ($s,undef,$value) = $self->_value_to_arrayitem
# Line 213  sub parse ($$;%) { Line 193  sub parse ($$;%) {
193        my ($s,undef,$value) = $self->_value_to_arrayitem        my ($s,undef,$value) = $self->_value_to_arrayitem
194          ($name => $body, $self->{option});          ($name => $body, $self->{option});
195        push @{$self->{value}}, $value if $s;        push @{$self->{value}}, $value if $s;
196        } elsif (length $field) {
197          my ($s,undef,$value) = $self->_value_to_arrayitem
198            ('x-unknown' => $field, $self->{option});
199          push @{$self->{value}}, $value if $s;
200      }      }
201    }    }
202    $self;    $self;
# Line 260  sub parse_array ($\@;%) { Line 244  sub parse_array ($\@;%) {
244        my ($s,undef,$value) = $self->_value_to_arrayitem        my ($s,undef,$value) = $self->_value_to_arrayitem
245          ($name => $body, $self->{option});          ($name => $body, $self->{option});
246        push @{$self->{value}}, $value if $s;        push @{$self->{value}}, $value if $s;
247        } elsif (length $field) {
248          my ($s,undef,$value) = $self->_value_to_arrayitem
249            ('x-unknown' => $field, $self->{option});
250          push @{$self->{value}}, $value if $s;
251      }      }
252      last if $#$header < 0;      last if $#$header < 0;
253    }    }
# Line 295  sub _item_match ($$\$\%\%) { Line 283  sub _item_match ($$\$\%\%) {
283        if ($s) {        if ($s) {
284          $l{$v->{name} . ':' . ( $option->{ns} || $v->{ns} ) } = 1;          $l{$v->{name} . ':' . ( $option->{ns} || $v->{ns} ) } = 1;
285        } else {        } else {
286          $l{$v->{name} .':'. ( $option->{ns} || $self->{ns}->{default_phuri} ) } = 1;          $l{$v->{name} .':'. ( $option->{ns} || $self->{option}->{ns_default_phuri} ) } = 1;
287        }        }
288      }      }
289      return 1 if $l{$$i->{name} . ':' . $$i->{ns}};      return 1 if $l{$$i->{name} . ':' . $$i->{ns}};
290      } elsif ($by eq 'ns') {
291        return 1 if $list->{ $$i->{ns} };
292    }    }
293    0;    0;
294  }  }
# Line 314  sub _item_return_value ($\$\%) { Line 304  sub _item_return_value ($\$\%) {
304      ${$_[1]}->{body};      ${$_[1]}->{body};
305    }    }
306  }  }
307    *_add_return_value = \&_item_return_value;
308    *_replace_return_value = \&_item_return_value;
309    
310  ## Returns returned (new created) item value    $name, \%option  ## Returns returned (new created) item value    $name, \%option
311  sub _item_new_value ($$\%) {  sub _item_new_value ($$\%) {
# Line 331  sub _parse_value ($$$;%) { Line 323  sub _parse_value ($$$;%) {
323    my $value = shift;  return $value if ref $value;    my $value = shift;  return $value if ref $value;
324    my %option = @_;    my %option = @_;
325    my $vtype; { no strict 'refs';    my $vtype; { no strict 'refs';
326      $vtype = ${&_NS_uri2phpackage ($option{ns}).'::OPTION'}{value_type};      my $vt = ${&_NS_uri2phpackage ($option{ns}).'::OPTION'}{value_type};
327      if (ref $vtype) { $vtype = $vtype->{$name} }      if (ref $vt) {
328      unless (ref $vtype) { $vtype = $vtype->{$self->{option}->{_VALTYPE_DEFAULT}} }        $vtype = $vt->{$name} || $vt->{$self->{option}->{_VALTYPE_DEFAULT}};
329        }
330      ## For compatiblity.      ## For compatiblity.
331      unless (ref $vtype) { $vtype = $self->{option}->{value_type}->{$name}      unless (ref $vtype) { $vtype = $self->{option}->{value_type}->{$name}
332        || $self->{option}->{value_type}->{$self->{option}->{_VALTYPE_DEFAULT}} }        || $self->{option}->{value_type}->{$self->{option}->{_VALTYPE_DEFAULT}} }
# Line 348  sub _parse_value ($$$;%) { Line 341  sub _parse_value ($$$;%) {
341        -format   => $self->{option}->{format},        -format   => $self->{option}->{format},
342        -field_ns => $option{ns},        -field_ns => $option{ns},
343        -field_name       => $name,        -field_name       => $name,
344        -header_default_charset     => $self->{option}->{header_default_charset},
345        -header_default_charset_input       => $self->{option}->{header_default_charset_input},
346        -parse_all        => $self->{option}->{parse_all},        -parse_all        => $self->{option}->{parse_all},
347      %vopt);      %vopt);
348    } else {    } else {
# Line 356  sub _parse_value ($$$;%) { Line 351  sub _parse_value ($$$;%) {
351        -format   => $self->{option}->{format},        -format   => $self->{option}->{format},
352        -field_ns => $option{ns},        -field_ns => $option{ns},
353        -field_name       => $name,        -field_name       => $name,
354        -header_default_charset     => $self->{option}->{header_default_charset},
355        -header_default_charset_input       => $self->{option}->{header_default_charset_input},
356        -parse_all        => $self->{option}->{parse_all},        -parse_all        => $self->{option}->{parse_all},
357      %vopt);      %vopt);
358    }    }
359  }  }
360    
361    ## Defined for text/rfc822-headers
362    sub entity_header ($;$) {
363      my $self = shift;
364      my $new_header = shift;
365      if (ref $new_header) {
366        $self->{header} = $new_header;
367      }
368      $self->{header};
369    }
370    
371  =head2 $self->field_name_list ()  =head2 $self->field_name_list ()
372    
373  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 386  sub namespace_ph_default ($;$) {
386    my $self = shift;    my $self = shift;
387    if (defined $_[0]) {    if (defined $_[0]) {
388      no strict 'refs';      no strict 'refs';
389      $self->{ns}->{default_phuri} = $_[0];      $self->{option}->{ns_default_phuri} = $_[0];
390      $self->_ns_load_ph (${&_NS_uri2phpackage ($self->{ns}->{default_phuri}).'::OPTION'}{namespace_phname});      $self->_ns_load_ph (${&_NS_uri2phpackage ($self->{option}->{ns_default_phuri}).'::OPTION'}{namespace_phname});
391    }    }
392    $self->{ns}->{default_phuri};    $self->{option}->{ns_default_phuri};
393  }  }
394    
395  =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 428  sub _value_to_arrayitem ($$$\%) {
428    if (ref $value eq 'ARRAY') {    if (ref $value eq 'ARRAY') {
429      ($value, %$value_option) = @$value;      ($value, %$value_option) = @$value;
430    }    }
431    my $nsuri = $self->{ns}->{default_phuri};    my $nsuri = $self->{option}->{ns_default_phuri};
432      
433    no strict 'refs';    no strict 'refs';
434    if ($option->{ns}) {    if ($value_option->{ns}) {
435        $nsuri = $value_option->{ns};
436      } elsif ($option->{ns}) {
437      $nsuri = $option->{ns};      $nsuri = $option->{ns};
438    } elsif ($name =~ s/^([Xx]-[A-Za-z]+|[A-Za-z]+)-//) {    } elsif ($name =~ s/^([Xx]-[A-Za-z]+|[A-Za-z]+)-//) {
439      my $oprefix = $1;      my $oprefix = $1;
# Line 434  sub _value_to_arrayitem ($$$\%) { Line 444  sub _value_to_arrayitem ($$$\%) {
444      $nsuri = $self->{ns}->{phname2uri}->{$prefix};      $nsuri = $self->{ns}->{phname2uri}->{$prefix};
445      unless ($nsuri) {      unless ($nsuri) {
446        $name = $oprefix . '-' . $name;        $name = $oprefix . '-' . $name;
447        $nsuri = $self->{ns}->{default_phuri};        $nsuri = $self->{option}->{ns_default_phuri};
448      }      }
449    }    }
450    $name    $name
# Line 443  sub _value_to_arrayitem ($$$\%) { Line 453  sub _value_to_arrayitem ($$$\%) {
453    Carp::croak "$name: invalid field-name"    Carp::croak "$name: invalid field-name"
454      if $option->{field_name_validation}      if $option->{field_name_validation}
455        && $name =~ /$REG{$option->{field_name_unsafe_rule}}/;        && $name =~ /$REG{$option->{field_name_unsafe_rule}}/;
456    $value = $self->_parse_value ($name => $value, ns => $nsuri) if $$option{parse};    $value = $self->_parse_value ($name => $value, ns => $nsuri)
457        if $$option{parse} || $$option{parse_all};
458    $$option{parse} = 0;    $$option{parse} = 0;
459    (1, $name.':'.$nsuri => {name => $name, body => $value, ns => $nsuri});    (1, $name.':'.$nsuri => {name => $name, body => $value, ns => $nsuri});
460  }  }
# Line 461  first one is used and the others are not Line 472  first one is used and the others are not
472  =cut  =cut
473    
474  sub _replace_hash_shift ($\%$\%) {  sub _replace_hash_shift ($\%$\%) {
475    shift; my $r = shift;  my $n = $_[0]->{name};    shift; my $r = shift;  my $n = $_[0]->{name} . ':' . $_[0]->{ns};
476    if ($$r{$n}) {    if ($$r{$n}) {
477      my $d = $$r{$n};      my $d = $$r{$n};
478      delete $$r{$n};      delete $$r{$n};
# Line 551  sub _scan_sort ($\@\%) { Line 562  sub _scan_sort ($\@\%) {
562  }  }
563    
564  sub _n11n_field_name ($$) {  sub _n11n_field_name ($$) {
565      no strict 'refs';
566    my $self = shift;    my $self = shift;
567    my $s = shift;    my $s = shift;
568    $s =~ s/^$REG{WSP}+//; $s =~ s/$REG{WSP}+$//;    $s =~ s/^$REG{WSP}+//; $s =~ s/$REG{WSP}+$//;
569    $s = lc $s ;#unless $self->{option}->{field_name_case_sensible};    $s = lc $s unless ${&_NS_uri2phpackage ($self->{option}->{ns_default_phuri}).'::OPTION'}{case_sensible};
570    $s;    $s;
571  }  }
572    
# Line 592  sub stringify ($;%) { Line 604  sub stringify ($;%) {
604        my ($name, $body, $nsuri) = ($_[1]->{name}, $_[1]->{body}, $_[1]->{ns});        my ($name, $body, $nsuri) = ($_[1]->{name}, $_[1]->{body}, $_[1]->{ns});
605        return unless length $name;        return unless length $name;
606        return if $option{output_mail_from} && $name eq 'mail-from';        return if $option{output_mail_from} && $name eq 'mail-from';
607        return if !$option{output_bcc} && ($name eq 'bcc' || $name eq 'resent-bcc');        $body = '' if !$option{output_bcc} && $name eq 'bcc';
608        my $nspackage = &_NS_uri2phpackage ($nsuri);        my $nspackage = &_NS_uri2phpackage ($nsuri);
609        my $oname;        ## Outputed field-name        my $oname;        ## Outputed field-name
610        my $prefix = ${$nspackage.'::OPTION'} {namespace_phname_goodcase}        my $prefix = ${$nspackage.'::OPTION'} {namespace_phname_goodcase}
611                  || $self->{ns}->{uri2phname}->{$nsuri};                  || $self->{ns}->{uri2phname}->{$nsuri};
612        $prefix = undef if $nsuri eq $self->{ns}->{default_phuri};        $prefix = undef if $nsuri eq $self->{option}->{ns_default_phuri};
613        my $gc = ${$nspackage.'::OPTION'} {to_be_goodcase};        my $gc = ${$nspackage.'::OPTION'} {to_be_goodcase};
614        if (ref $gc) { $oname = &$gc ($self, $nspackage, $name, \%option) }        if (ref $gc) { $oname = &$gc ($self, $nspackage, $name, \%option) }
615        else { $oname = $name }        else { $oname = $name }
# Line 622  sub stringify ($;%) { Line 634  sub stringify ($;%) {
634        } else {        } else {
635          $fbody = $body;          $fbody = $body;
636        }        }
637        return unless length $fbody;        unless (${$nspackage.'::OPTION'} {field}->{$name}->{empty_body}) {
638            return unless length $fbody;
639          }
640        unless ($option{linebreak_strict}) {        unless ($option{linebreak_strict}) {
641          ## bare \x0D and bare \x0A are unsafe          ## bare \x0D and bare \x0A are unsafe
642          $fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;          $fbody =~ s/\x0D(?=[^\x09\x0A\x20])/\x0D\x20/g;
# Line 708  sub _fold ($$;%) { Line 722  sub _fold ($$;%) {
722    $max = 20 if $max < 20;    $max = 20 if $max < 20;
723        
724    my $l = $option{-initial_length} || 0;    my $l = $option{-initial_length} || 0;
725      $l += length $1 if $string =~ /^([^\x09\x20]+)/;
726    $string =~ s{([\x09\x20][^\x09\x20]+)}{    $string =~ s{([\x09\x20][^\x09\x20]+)}{
727      my $s = $1;      my $s = $1;
728      if ($l + length $s > $max) {      if (($l + length $s) > $max) {
729        $s = "\x0D\x0A\x20" . $s;        $s = "\x0D\x0A\x20" . $s;
730        $l = length ($s) - 2;        $l = 1 + length $s;
731      } else { $l += length $s }      } else { $l += length $s }
732      $s;      $s;
733    }gex;    }gex;
Legend:
Removed from v.1.21  
changed lines
  Added in v.1.30
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24