/[suikacvs]/messaging/manakai/lib/Message/Field/Params.pm
Suika

Diff of /messaging/manakai/lib/Message/Field/Params.pm

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

revision 1.13 by wakaba, Sun Jun 16 10:42:06 2002 UTC revision 1.14 by wakaba, Sun Jun 23 12:10:16 2002 UTC
# Line 10  package Message::Field::Params; Line 10  package Message::Field::Params;
10  use strict;  use strict;
11  require 5.6.0;  require 5.6.0;
12  use re 'eval';  use re 'eval';
13  use vars qw(@ISA %REG $VERSION);  use vars qw(%DEFAULT @ISA %REG $VERSION);
14  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};  $VERSION=do{my @r=(q$Revision$=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
15  require Message::Util;  require Message::Util;
16  require Message::Field::Structured;  require Message::Field::Structured;
# Line 21  use overload '""' => sub { $_[0]->string Line 21  use overload '""' => sub { $_[0]->string
21               '.=' => sub { $_[0]->add ($_[1], ['', value => 1]); $_[0] },               '.=' => sub { $_[0]->add ($_[1], ['', value => 1]); $_[0] },
22               fallback => 1;               fallback => 1;
23    
24  *REG = \%Message::Util::REG;  %REG = %Message::Util::REG;
25  ## Inherited: comment, quoted_string, domain_literal, angle_quoted  ## Inherited: comment, quoted_string, domain_literal, angle_quoted
26          ## WSP, FWS, atext, atext_dot, token, attribute_char          ## WSP, FWS, atext, atext_dot, token, attribute_char
27          ## S_encoded_word          ## S_encoded_word
# Line 42  $REG{M_parameter_name} = qr/($REG{attrib Line 42  $REG{M_parameter_name} = qr/($REG{attrib
42  $REG{M_parameter_extended_value} = qr/([^']*)'([^']*)'($REG{token}*)/;  $REG{M_parameter_extended_value} = qr/([^']*)'([^']*)'($REG{token}*)/;
43          ## as defined by RFC 2231, but more naive.          ## as defined by RFC 2231, but more naive.
44    
45    %DEFAULT = (
46  =head1 CONSTRUCTORS          -_HASH_NAME     => 'param',
   
 The following methods construct new objects:  
   
 =over 4  
   
 =cut  
   
 ## Initialize of this class -- called by constructors  
 sub _init ($;%) {  
   my $self = shift;  
   my %options = @_;  
   my %DEFAULT = (  
47      -delete_fws => 1,## BUG: this option MUST be '1'.      -delete_fws => 1,## BUG: this option MUST be '1'.
48          ## parameter parser cannot procede CFWS.          ## parameter parser cannot procede CFWS.
49      #encoding_after_encode      #encoding_after_encode
# Line 73  sub _init ($;%) { Line 61  sub _init ($;%) {
61      -parse_all  => 0,      -parse_all  => 0,
62      -separator  => '; ',      -separator  => '; ',
63      -separator_regex    => qr/$REG{FWS};$REG{FWS}/,      -separator_regex    => qr/$REG{FWS};$REG{FWS}/,
64        -use_comment        => 1,
65      -use_parameter_extension    => 0,      -use_parameter_extension    => 0,
66      #value_type      #value_type
67    );  );
68    
69    =head1 CONSTRUCTORS
70    
71    The following methods construct new objects:
72    
73    =over 4
74    
75    =cut
76    
77    ## Initialize of this class -- called by constructors
78    sub _init ($;%) {
79      my $self = shift;
80      my %options = @_;
81    $self->SUPER::_init (%DEFAULT, %options);    $self->SUPER::_init (%DEFAULT, %options);
82    $self->{param} = [];    $self->{param} = [];
83    my $fname = $self->{option}->{field_name};    my $fname = $self->{option}->{field_name};
# Line 90  sub _init ($;%) { Line 92  sub _init ($;%) {
92    } elsif ($self->{option}->{format} =~ /^http/) {    } elsif ($self->{option}->{format} =~ /^http/) {
93      $self->{option}->{encoding_before_decode} = 'iso-8859-1';      $self->{option}->{encoding_before_decode} = 'iso-8859-1';
94      $self->{option}->{encoding_after_decode} = 'iso-8859-1';      $self->{option}->{encoding_after_decode} = 'iso-8859-1';
95    }    }     ## TODO: news-usefor -> x-junet8
 }  
   
 ## Initialization for new () method.  
 sub _initialize_new ($;%) {  
   ## Nothing to do  
 }  
   
 ## Initialization for parse () method.  
 sub _initialize_parse ($;%) {  
   ## Nothing to do  
96  }  }
97    
98  =item $p = Message::Field::Params->new ([%options])  =item $p = Message::Field::Params->new ([%options])
# Line 110  to the constructor. Line 102  to the constructor.
102    
103  =cut  =cut
104    
105  sub new ($;%) {  ## Inherited
   my $self = shift->SUPER::new (@_);  
   $self->_initialize_new (@_);  
   $self;  
 }  
106    
107  =item $p = Message::Field::Params->parse ($field-body, [%options])  =item $p = Message::Field::Params->parse ($field-body, [%options])
108    
# Line 128  sub parse ($$;%) { Line 116  sub parse ($$;%) {
116    my $self = bless {}, $class;    my $self = bless {}, $class;
117    my $body = shift;    my $body = shift;
118    $self->_init (@_);    $self->_init (@_);
119    $self->_initialize_parse (@_);    $body = Message::Util::delete_comment ($body)
120    $body = Message::Util::delete_comment ($body);      if $self->{option}->{use_comment};
121    $body = $self->_delete_fws ($body) if $self->{option}->{delete_fws};    $body = $self->_delete_fws ($body) if $self->{option}->{delete_fws};
122    my @b = ();    my @b = ();
123    $body =~ s{$REG{FWS}($REG{$self->{option}->{parameter_rule}})    $body =~ s{$REG{FWS}($REG{$self->{option}->{parameter_rule}})
# Line 176  sub _restore_param ($@) { Line 164  sub _restore_param ($@) {
164            my %s = &{$self->{option}->{hook_decode_string}} ($self, $s,            my %s = &{$self->{option}->{hook_decode_string}} ($self, $s,
165                  language => $p->{language}, charset => $p->{charset},                  language => $p->{language}, charset => $p->{charset},
166                  type => 'parameter/encoded');                  type => 'parameter/encoded');
167              if ($p->{charset} && !$s{charset}) {
168                $p->{charset_to_be} = $p->{charset};        ## Original charset
169              }
170            ($s, $p->{charset}, $p->{language}) = (@s{qw(value charset language)});            ($s, $p->{charset}, $p->{language}) = (@s{qw(value charset language)});
171          } elsif ($p->{is_internal}) {          } elsif ($p->{is_internal}) {
172            $s = $p->{value};            $s = $p->{value};
# Line 187  sub _restore_param ($@) { Line 178  sub _restore_param ($@) {
178            ($s, $p->{charset}, $p->{language}) = (@s{qw(value charset language)});            ($s, $p->{charset}, $p->{language}) = (@s{qw(value charset language)});
179          }          }
180          push @ret, [$i->[0], {value => $s, language => $p->{language},          push @ret, [$i->[0], {value => $s, language => $p->{language},
181                                charset => $p->{charset}, is_parameter => 1}];                                charset => $p->{charset},
182                                  charset_to_be => $p->{charset_to_be},
183                                  is_parameter => 1}];
184        } else {        } else {
185          $part{$i->[0]}->[$p->{seq}] = {          $part{$i->[0]}->[$p->{seq}] = {
186          value => scalar Message::Util::unquote_if_quoted_string ($p->{value}),          value => scalar Message::Util::unquote_if_quoted_string ($p->{value}),
# Line 212  sub _restore_param ($@) { Line 205  sub _restore_param ($@) {
205      } @{$part{$name}};      } @{$part{$name}};
206      my %s = &{$self->{option}->{hook_decode_string}} ($self, $t,      my %s = &{$self->{option}->{hook_decode_string}} ($self, $t,
207                  type => 'parameter/encoded');                  type => 'parameter/encoded');
208      ($t,@part{$name}->[0]->{qw(charset language)})=(@s{qw(value charset language)});            if ($part{$name}->[0]->{charset} && !$s{charset}) {   ## Original charset
209                $part{$name}->[0]->{charset_to_be} = $part{$name}->[0]->{charset};
210              }
211        ($t,@{$part{$name}->[0]}{qw(charset language)})=(@s{qw(value charset language)});
212      push @ret, [$name, {value => $t, charset => $part{$name}->[0]->{charset},      push @ret, [$name, {value => $t, charset => $part{$name}->[0]->{charset},
213                            charset_to_be => $part{$name}->[0]->{charset_to_be},
214                          language => $part{$name}->[0]->{language},                          language => $part{$name}->[0]->{language},
215                          is_parameter => 1}];                          is_parameter => 1}];
216    }    }
# Line 268  value (1/0, see example above). Line 265  value (1/0, see example above).
265    
266  =cut  =cut
267    
268  sub add ($$;$%) {  sub _add_hash_check ($$$\%) {
269      my $self = shift;
270      my ($name, $value, $option) = @_;
271      my $value_option = {};
272      if (ref $value eq 'ARRAY') {
273        ($value, %$value_option) = @$value;
274      }
275      if ($value_option->{value}) { ## Non-value parameter
276        $name = $self->_parse_value ('*novalue' => $name) if $$option{parse};
277        return (1, $name => [$name, {is_parameter => 0}]);
278      }
279        if ($$option{validate} && !$value_option->{value}
280         && $name =~ /^$REG{NON_http_attribute_char}$/) {
281          if ($$option{dont_croak}) {
282            return (0);
283          } else {
284            Carp::croak qq{add: $name: Invalid parameter name};
285          }
286        $value = $self->_parse_value ($name => $value) if $$option{parse};
287      }
288      (1, $name => [$name => {value => $value, is_parameter => 1,
289                    charset_to_be => $value_option->{charset},
290                    language => $value_option->{language},
291                    }]);
292    }
293    
294    
295    sub Xadd ($$;$%) {
296    my $self = shift;    my $self = shift;
297    my %gp = @_;    my %gp = @_;
298    my %option = %{$self->{option}};    my %option = %{$self->{option}};
# Line 373  sub parameter ($$;$%) { Line 397  sub parameter ($$;$%) {
397        }        }
398      }      }
399    }    }
400    @ret;    wantarray? @ret: undef;
401  }  }
402    
403  sub parameter_name ($$;$) {  sub parameter_name ($$;$) {
# Line 428  sub stringify ($;%) { Line 452  sub stringify ($;%) {
452        if ($v->{is_parameter}) {        if ($v->{is_parameter}) {
453          my ($encoded, @value) = (0, '');          my ($encoded, @value) = (0, '');
454          my (%e) = &{$self->{option}->{hook_encode_string}} ($self,          my (%e) = &{$self->{option}->{hook_encode_string}} ($self,
455            $v->{value}, current_charset => $v->{charset}, language => $v->{language},            $v->{value}, charset => $v->{charset_to_be},
456              current_charset => $v->{charset}, language => $v->{language},
457            type => 'parameter');            type => 'parameter');
458          if (!defined $e{value}) {          if (!defined $e{value}) {
459            $value[0] = undef;            $value[0] = undef;
Legend:
Removed from v.1.13  
changed lines
  Added in v.1.14
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24