Message/Field/Params.pm


=head1 NAME

Message::Field::Params --- Perl module for Internet message
field body consist of parameters, such as C<Content-Type:> field

=cut

package Message::Field::Params;
use strict;
require 5.6.0;
use re 'eval';
use vars qw(@ISA %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Util;
require Message::Field::Structured;
push @ISA, qw(Message::Field::Structured);

use overload '""' => sub { $_[0]->stringify },
             '0+' => sub { $_[0]->count },
             '.=' => sub { $_[0]->add ($_[1], ['', value => 1]); $_[0] },
             fallback => 1;

*REG = \%Message::Util::REG;
## Inherited: comment, quoted_string, domain_literal, angle_quoted
        ## WSP, FWS, atext, atext_dot, token, attribute_char
        ## S_encoded_word
        ## M_quoted_string

$REG{param} = qr/(?:$REG{atext_dot}|$REG{quoted_string}|$REG{angle_quoted})(?:$REG{atext_dot}|$REG{quoted_string}|$REG{WSP}|,)*/;
        ## more naive C<parameter>.  (Comma is allowed for RFC 1049)
$REG{parameter} = qr/$REG{token}=(?:$REG{token}|$REG{quoted_string})?/;
        ## as defined by RFC 2045, not RFC 2231.

$REG{M_parameter} = qr/($REG{token})=($REG{token}|$REG{quoted_string})?/;
        ## as defined by RFC 2045, not RFC 2231.
$REG{M_parameter_name} = qr/($REG{attribute_char}+)(?:\*([0-9]+)(\*)?|(\*))/;
        ## as defined by RFC 2231.
$REG{M_parameter_extended_value} = qr/([^']*)'([^']*)'($REG{token}*)/;
        ## as defined by RFC 2231, but more naive.


=head1 CONSTRUCTORS

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 = (
    -delete_fws => 1,
    #encoding_after_encode      ## Inherited
    #encoding_before_decode     ## Inherited
    #format     ## Inherited
    #hook_encode_string ## Inherited
    #hook_decode_string ## Inherited
    -parameter_name_case_sensible       => 0,
    -parameter_value_max_length => 78,
    -parameter_value_unsafe_rule        => {'*default'  => 'NON_http_attribute_char'},
    -parse_all  => 0,
    -use_parameter_extension    => 0,
    -value_type => {'*default'  => [':none:']},
  );
  $self->SUPER::_init (%DEFAULT, %options);
  $self->{param} = [];
  if ($self->{option}->{format} =~ /^http-sip/) {
    $self->{option}->{encoding_before_decode} = 'utf-8';
    $self->{option}->{encoding_after_decode} = 'utf-8';
  } elsif ($self->{option}->{format} =~ /^http/) {
    $self->{option}->{encoding_before_decode} = 'iso-8859-1';
    $self->{option}->{encoding_after_decode} = 'iso-8859-1';
  }
}

## Initialization for new () method.
sub _initialize_new ($;%) {
  ## Nothing to do
}

## Initialization for parse () method.
sub _initialize_parse ($;%) {
  ## Nothing to do
}

=item $p = Message::Field::Params->new ([%options])

Constructs a new object.  You might pass some options as parameters 
to the constructor.

=cut

sub new ($;%) {
  my $self = shift->SUPER::new (@_);
  $self->_initialize_new (@_);
  $self;
}

=item $p = Message::Field::Params->parse ($field-body, [%options])

Constructs a new object with given field body.  You might pass 
some options as parameters to the constructor.

=cut

sub parse ($$;%) {
  my $class = shift;
  my $self = bless {}, $class;
  my $body = shift;
  $self->_init (@_);
  $self->_initialize_parse (@_);
  $body = Message::Util::delete_comment ($body);
  $body = $self->_delete_fws ($body) if $self->{option}->{delete_fws};
  my @b = ();
  $body =~ s{$REG{FWS}($REG{param})$REG{FWS}(?:;$REG{FWS}|$)}{
    my $param = $1;
    push @b, $self->_parse_param ($param);
  }goex;
  @b = $self->_restore_param (@b);
  $self->_save_param (@b);
  $self;
}

sub _parse_param ($$) {
  my $self = shift;
  my $param = shift;
  if ($param =~ /^$REG{M_parameter}$/) {
    my ($name, $value) = ($self->_n11n_param_name ($1), $2);
    my ($seq, $isencoded, $charset, $lang) = (-1, 0, '', '');
    if ($name =~ /^$REG{M_parameter_name}$/) {
      ($name, $seq, $isencoded) = ($1, $4?-1:$2, ($3||$4)?1:0);
    }
    if ($isencoded && $value =~ /^$REG{M_parameter_extended_value}$/) {
      ($charset, $lang, $value) = ($1, $2, $3);
    }
    return [$name, {value => $value, seq => $seq, is_encoded => $isencoded,
                    charset => $charset, language => $lang, is_parameter => 1}];
  } else {
    return [$param, {is_parameter => 0}];
  }
}

sub _restore_param ($@) {
  my $self = shift;
  my @p = @_;
  my @ret;
  my %part;
  for my $i (@p) {
    if ($i->[1]->{is_parameter}) {
      my $p = $i->[1];
      if ($p->{seq}<0) {
        my $s = $p->{value};
        if ($p->{is_encoded}) {
          $s =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/eg;
          my %s = &{$self->{option}->{hook_decode_string}} ($self, $s,
                language => $p->{language}, charset => $p->{charset},
                type => 'parameter/encoded');
          ($s, $p->{charset}, $p->{language}) = (@s{qw(value charset language)});
        } else {
          my $q = 0;
          ($s,$q) = Message::Util::unquote_if_quoted_string ($p->{value});
          my %s = &{$self->{option}->{hook_decode_string}} ($self, $s,
                type => ($q?'parameter/quoted':'parameter'));
          ($s, $p->{charset}, $p->{language}) = (@s{qw(value charset language)});
        }
        push @ret, [$i->[0], {value => $s, language => $p->{language},
                              charset => $p->{charset}, is_parameter => 1}];
      } else {
        $part{$i->[0]}->[$p->{seq}] = {
        value => scalar Message::Util::unquote_if_quoted_string ($p->{value}),
        language => $p->{language}, charset => $p->{charset},
        is_encoded => $p->{is_encoded}};
      }
    } else {
      my $q = 0;
      ($i->[0], $q) = Message::Util::unquote_if_quoted_string ($i->[0]);
      my %s = &{$self->{option}->{hook_decode_string}} ($self, $i->[0],
                type => ($q?'phrase/quoted':'phrase'));
      push @ret, [$s{value}, {is_parameter => 0}];
    }
  }
  for my $name (keys %part) {
    my $t = join '', map {
      my $v = $_;
      my $s = $v->{value};
      $s =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/eg if $v->{is_encoded};
      $s;
    } @{$part{$name}};
    my %s = &{$self->{option}->{hook_decode_string}} ($self, $t,
                type => 'parameter/encoded');
    ($t,@part{$name}->[0]->{qw(charset language)})=(@s{qw(value charset language)});
    push @ret, [$name, {value => $t, charset => $part{$name}->[0]->{charset},
                        language => $part{$name}->[0]->{language}, 
                        is_parameter => 1}];
  }
  @ret;
}

sub _save_param ($@) {
  my $self = shift;
  my @p = @_;
  $self->{param} = \@p;
  $self;
}

=back

=head1 METHODS

=over 4

=item $p->add ($name => [$value], [$name => $value,...])

Adds parameter name=value pair.

  Example:
    $p->add (title => 'foo of bar');    ## title="foo of bar"
    $p->add (subject => 'hogehoge, foo');       ## subject*=''hogehoge%2C%20foo
    $p->add (foo => ['bar', language => 'en'])  ## foo*='en'bar
    $p->add ('text/plain', ['', value => 1])    ## text/plain

This method returns array reference of (name, {value => value, attribute...}).

Available options: charset (charset name), language (language tag),
value (1/0, see example above).

=cut

sub add ($$;$%) {
  my $self = shift;
  my %gp = @_;
  my %option = %{$self->{option}};
  for (grep {/^-/} keys %gp) {$option{substr ($_, 1)} = $gp{$_}}
  $option{parse} = 1 if defined wantarray;
  my $p;
  for (grep {/^[^-]/} keys %gp) {
    my ($name, $value, %po) = ($self->_n11n_param_name ($_));
    if (ref $gp{$_}) {($value, %po) = @{$gp{$_}}} else {$value = $gp{$_}}
    $p = [$name, {value => $value, charset => $po{charset},
                   is_parameter => 1, language => $po{language}}];
    $p->[1]->{is_parameter} = 0 if !$value && $po{value};
    Carp::croak "add: \$name contains of non-attribute-char: $name"
      if $p->[1]->{is_parameter} && $name =~ /$REG{NON_http_attribute_char}/;
    $p->[1]->{value} = $self->_param_value ($name => $p->[1]->{value})
      if $option{parse};
    if ($option{prepend}) {
      unshift @{$self->{param}}, $p;
    } else {
      push @{$self->{param}}, $p;
    }
  }
  $p->[1]->{is_parameter}? $p->[1]->{value}: $p->[0];
}

sub replace ($%) {
  my $self = shift;
  my %gp = @_;
  my %option = %{$self->{option}};
  for (grep {/^-/} keys %gp) {$option{substr ($_, 1)} = $gp{$_}}
  $option{parse} = 1 if defined wantarray;
  my $p;
  for (grep {/^[^-]/} keys %gp) {
    my ($name, $value, %po) = ($self->_n11n_param_name ($_));
    if (ref $gp{$_}) {($value, %po) = @{$gp{$_}}} else {$value = $gp{$_}}
    $p = [$name, {value => $value, charset => $po{charset},
                  is_parameter => 1, language => $po{language}}];
    $p->[1]->{is_parameter} = 0 if !$value && $po{value};
    Carp::croak "replace: \$name contains of non-attribute-char: $name"
      if $p->[1]->{is_parameter} && $name =~ /$REG{NON_http_attribute_char}/;
    $p->[1]->{value} = $self->_param_value ($name => $p->[1]->{value})
      if $option{parse};
    my $f = 0;
    for my $param (@{$self->{param}}) {
      if ($param->[0] eq $name) {$param = $p; $f = 1}
    }
    push @{$self->{param}}, $p unless $f == 1;
  }
  $p->[1]->{is_parameter}? $p->[1]->{value}: $p->[0];
}

sub delete ($$;%) {
  my $self = shift;
  my ($name, $index) = ($self->_n11n_param_name (shift), shift);
  my $i = 0;
  for my $param (@{$self->{param}}) {
    if ($param->[0] eq $name) {
      $i++;
      if ($index == 0 || $i == $index) {
        undef $param;
        return $self if $i == $index;
      }
    }
  }
  $self;
}

sub count ($;$%) {
  my $self = shift;
  my $name = $self->_n11n_param_name (shift);
  unless ($name) {
    $self->_delete_empty ();
    return $#{$self->{param}}+1;
  }
  my $count = 0;
  for my $param (@{$self->{param}}) {
    if ($param->[0] eq $name) {
      $count++;
    }
  }
  $count;
}


sub parameter ($$;$%) {
  my $self = shift;
  my $name = $self->_n11n_param_name (shift);
  my $newvalue = shift;
  return $self->replace ($name => $newvalue,@_) if defined $newvalue;
  my @ret;
  for my $param (@{$self->{param}}) {
    if ($param->[0] eq $name) {
      unless (wantarray) {
        $param->[1]->{value} 
          = $self->_param_value ($name => $param->[1]->{value});
        return $param->[1]->{value};
      } else {
        $param->[1]->{value} 
          = $self->_param_value ($name => $param->[1]->{value});
        push @ret, $param->[1]->{value};
      }
    }
  }
  @ret;
}

sub parameter_name ($$;$) {
  my $self = shift;
  my $i = shift;
  my $newname = shift;
  if ($newname) {
    return 0 if $newname =~ /$REG{NON_http_attribute_char}/;
    $self->{param}->[$i]->[0] = $newname;
  }
  $self->{param}->[$i]->[0];
}
sub parameter_value ($$;$) {
  my $self = shift;
  my $i = shift;
  my $newvalue = shift;
  if ($newvalue) {
    $newvalue = $self->_param_value ($self->{param}->[$i]->[0] => $newvalue);
    $self->{param}->[$i]->[1]->{value} = $newvalue;
  }
  $self->{param}->[$i]->[1]->{value} 
    = $self->_param_value 
      ($self->{param}->[$i]->[0] => $self->{param}->[$i]->[1]->{value});
  $self->{param}->[$i]->[1]->{value};
}

## Hook called before returning C<value>.
## $self->_param_value ($name, $value);
sub _param_value ($$$) {
  my $self = shift;
  my $name = shift || '*default';
  my $value = shift;
  my $vtype = $self->{option}->{value_type}->{$name}->[0]
      || $self->{option}->{value_type}->{'*default'}->[0];
  my %vopt; %vopt = %{$self->{option}->{value_type}->{$name}->[1]} 
    if ref $self->{option}->{value_type}->{$name}->[1];
  if (ref $value) {
    return $value;
  } elsif ($vtype eq ':none:') {
    return $value;
  } elsif ($value) {
    eval "require $vtype";
    return $vtype->parse ($value, -format => $self->{option}->{format},
      -field_body => $self->{option}->{field_body}, %vopt);
  } else {
    eval "require $vtype";
    return $vtype->new (-format => $self->{option}->{format},
      -field_body => $self->{option}->{field_body}, %vopt);
  }
}

sub _delete_empty ($) {
  my $self = shift;
  $self->{param} = [grep {length $_} @{$self->{param}}];
}


=item $field-body = $p->stringify ()

Returns C<field-body> as a string.

=cut

sub stringify ($;%) {
  my $self = shift;
  my %o = @_;
  my %option = %{$self->{option}};
  for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
  $self->_delete_empty;
  join '; ',
    map {
      my $v = $_->[1];
      my $new = '';
      if ($v->{is_parameter}) {
        my ($encoded, @value) = (0, '');
        my (%e) = &{$self->{option}->{hook_encode_string}} ($self, 
          $v->{value}, current_charset => $v->{charset}, language => $v->{language},
          type => 'parameter');
        if ($option{use_parameter_extension} && ($e{charset} || $e{language} 
                           || $e{value} =~ /[\x00\x0D\x0A\x80-\xFF]/)) {
          my ($charset, $lang);
          $encoded = 1;
          ($charset, $lang) = ($e{charset}, $e{language});
          ## Note: %-quoting for charset and for language is not allowed.
          ## But charset name can be included non-sttribute-char such as "'".
          ## How can we treat this?
          $charset =~ s/($REG{NON_http_attribute_char})/sprintf('%%%02X', ord $1)/ge;
          $lang =~ s/($REG{NON_http_attribute_char})/sprintf('%%%02X', ord $1)/ge;
          if (length $e{value} > $option{parameter_value_max_length}) {
            for my $i (0..length ($e{value})/$option{parameter_value_max_length}) {
              $value[$i] = substr ($e{value}, $i*$option{parameter_value_max_length},
                                     $option{parameter_value_max_length});
            }
          } else {$value[0] = $e{value}}
          for my $i (0..$#value) {
            $value[$i] =~ 
              s/($REG{NON_http_attribute_char})/sprintf('%%%02X', ord $1)/ge;
          }
          $value[0] = "${charset}'${lang}'".$value[0];
        } elsif (length $e{value} == 0) {
          $value[0] = '""';
        } else {
          if ($option{use_parameter_extension} 
              && length $e{value} > $option{parameter_value_max_length}) {
            for my $i (0..length ($e{value})/$option{parameter_value_max_length}) {
              $value[$i] = Message::Util::quote_unsafe_string 
                (substr ($e{value}, $i*$option{parameter_value_max_length},
                    $option{parameter_value_max_length}), 
                    unsafe => 'NON_http_attribute_char');
            }
          } else {
            my $unsafe = $self->{option}->{parameter_value_unsafe_rule}->{$_->[0]}
                     || $self->{option}->{parameter_value_unsafe_rule}->{'*default'};
            $value[0] = Message::Util::quote_unsafe_string 
              ($e{value}, unsafe => $unsafe);
          }
        }
        ## Note: quoted-string for parameter name is not allowed.
        ## But it is better than output bare non-atext.
        if ($#value == 0) {
          $new = 
            Message::Util::quote_unsafe_string ($_->[0], 
              unsafe => 'NON_attribute_char')
            .($encoded?'*':'').'='.$value[0];
        } else {
          my @new;
          my $name = Message::Util::quote_unsafe_string 
            ($_->[0], unsafe => 'NON_http_attribute_char');
          for my $i (0..$#value) {
            push @new, $name.'*'.$i.($encoded?'*':'').'='.$value[$i];
          }
          $new = join '; ', @new;
        }
      } else {
        my %e = &{$self->{option}->{hook_encode_string}} ($self, 
          $_->[0], type => 'phrase');
        $new = Message::Util::quote_unsafe_string ($e{value}, 
          unsafe => 'NON_http_token_wsp');
      }
      $new;
    } @{$self->{param}}
  ;
}
*as_string = \&stringify;

sub scan ($&) {
  my ($self, $sub) = @_;
  #my $sort;
  #$sort = \&_header_cmp if $self->{option}->{sort} eq 'good-practice';
  #$sort = {$a cmp $b} if $self->{option}->{sort} eq 'alphabetic';
  my @param = @{$self->{param}};
  #if (ref $sort) {
  #  @field = sort $sort @{$self->{param}};
  #}
  for my $param (@param) {
    &$sub($param->[0] => $param->[1]->{value}, $param->[1]);
  }
}

=item $option-value = $ua->option ($option-name)

Gets option value.

=item $csv->option ($option-name, $option-value, ...)

Set option value(s).  You can pass multiple option name-value pair
as parameter when setting.

=cut

sub option ($;$%) {
  my $self = shift;
  my $format = $self->{option}->{format};
  $self->SUPER::option (@_);
  if ($format ne $self->{option}->{format}) {
    $self->scan (sub {
      if (ref $_[1]) {
        $_[1]->option (-format => $self->{option}->{format});
      }
    });
  }
}

sub value_type ($;$$%) {
  my $self = shift;
  my $name = shift || '*default';
  my $new_value_type = shift;
  if ($new_value_type) {
    $self->{option}->{value_type}->{$name} = []
      unless ref $self->{option}->{value_type}->{$name};
    $self->{option}->{value_type}->{$name}->[0] = $new_value_type;
  }
  if (ref $self->{option}->{value_type}->{$name}) {
    $self->{option}->{value_type}->{$name}->[0]
      || $self->{option}->{value_type}->{'*default'}->[0];
  } else {
    $self->{option}->{value_type}->{'*default'}->[0];
  }
}

sub value_unsafe_rule ($$;$%) {
  my $self = shift;
  if (@_ == 1) {
    return $self->{option}->{parameter_value_unsafe_rule}->{ $_[0] };
  }
  while (my ($name, $value) = splice (@_, 0, 2)) {
    $name = $self->_n11n_param_name ($name);
    $self->{option}->{parameter_value_unsafe_rule}->{$name} = $value;
  }
}

=item $clone = $ua->clone ()

Returns a copy of the object.

=cut

sub clone ($) {
  my $self = shift;
  $self->_delete_empty;
  my $clone = $self->SUPER::clone;
  $clone->{param} = Message::Util::make_clone ($self->{param});
  $clone->{value_type} = Message::Util::make_clone ($self->{value_type});
  $clone;
}

sub _delete_fws ($$) {
  my $self = shift;
  my $body = shift;
  $body =~ s{($REG{quoted_string}|$REG{domain_literal})|((?:$REG{token}|$REG{S_encoded_word})(?:$REG{WSP}+(?:$REG{token}|$REG{S_encoded_word}))+)|$REG{WSP}+}{
    my ($o,$p) = ($1,$2);
    if ($o) {$o}
    elsif ($p) {$p=~s/$REG{WSP}+/\x20/g;$p}
    else {''}
  }gex;
  $body;
}

sub _n11n_param_name ($$) {
  my $self = shift;
  my $s = shift;
  $s = lc $s unless $self->{option}->{parameter_name_case_sensible};
  $s;
}

=head1 LICENSE

Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.

=head1 CHANGE

See F<ChangeLog>.
$Date: 2002/04/01 05:32:15 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4	wakaba	1.7	Message::Field::Params --- Perl module for Internet message
5			field body consist of parameters, such as C<Content-Type:> field
6	wakaba	1.1
7			=cut
8
9			package Message::Field::Params;
10			use strict;
11			require 5.6.0;
12			use re 'eval';
13	wakaba	1.7	use vars qw(@ISA %REG $VERSION);
14			$VERSION=do{my @r=(q$Revision: 1.6 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
15	wakaba	1.3	require Message::Util;
16	wakaba	1.7	require Message::Field::Structured;
17			push @ISA, qw(Message::Field::Structured);
18
19			use overload '""' => sub { $_[0]->stringify },
20			'0+' => sub { $_[0]->count },
21			'.=' => sub { $_[0]->add ($_[1], ['', value => 1]); $_[0] },
22			fallback => 1;
23
24			*REG = \%Message::Util::REG;
25			## Inherited: comment, quoted_string, domain_literal, angle_quoted
26			## WSP, FWS, atext, atext_dot, token, attribute_char
27			## S_encoded_word
28			## M_quoted_string
29	wakaba	1.1
30	wakaba	1.7	$REG{param} = qr/(?:$REG{atext_dot}\|$REG{quoted_string}\|$REG{angle_quoted})(?:$REG{atext_dot}\|$REG{quoted_string}\|$REG{WSP}\|,)*/;
31	wakaba	1.1	## more naive C<parameter>. (Comma is allowed for RFC 1049)
32			$REG{parameter} = qr/$REG{token}=(?:$REG{token}\|$REG{quoted_string})?/;
33			## as defined by RFC 2045, not RFC 2231.
34
35			$REG{M_parameter} = qr/($REG{token})=($REG{token}\|$REG{quoted_string})?/;
36			## as defined by RFC 2045, not RFC 2231.
37			$REG{M_parameter_name} = qr/($REG{attribute_char}+)(?:\([0-9]+)(\)?\|(\*))/;
38			## as defined by RFC 2231.
39			$REG{M_parameter_extended_value} = qr/([^'])'([^'])'($REG{token}*)/;
40			## as defined by RFC 2231, but more naive.
41
42
43	wakaba	1.7	=head1 CONSTRUCTORS
44	wakaba	1.5
45	wakaba	1.7	The following methods construct new objects:
46	wakaba	1.1
47	wakaba	1.7	=over 4
48	wakaba	1.1
49			=cut
50
51	wakaba	1.7	## Initialize of this class -- called by constructors
52			sub _init ($;%) {
53			my $self = shift;
54			my %options = @_;
55			my %DEFAULT = (
56			-delete_fws => 1,
57			#encoding_after_encode ## Inherited
58			#encoding_before_decode ## Inherited
59			#format ## Inherited
60			#hook_encode_string ## Inherited
61			#hook_decode_string ## Inherited
62			-parameter_name_case_sensible => 0,
63			-parameter_value_max_length => 78,
64			-parameter_value_unsafe_rule => {'*default' => 'NON_http_attribute_char'},
65			-parse_all => 0,
66			-use_parameter_extension => 0,
67			-value_type => {'*default' => [':none:']},
68			);
69			$self->SUPER::_init (%DEFAULT, %options);
70			$self->{param} = [];
71			if ($self->{option}->{format} =~ /^http-sip/) {
72			$self->{option}->{encoding_before_decode} = 'utf-8';
73			$self->{option}->{encoding_after_decode} = 'utf-8';
74			} elsif ($self->{option}->{format} =~ /^http/) {
75			$self->{option}->{encoding_before_decode} = 'iso-8859-1';
76			$self->{option}->{encoding_after_decode} = 'iso-8859-1';
77			}
78	wakaba	1.1	}
79
80			## Initialization for new () method.
81			sub _initialize_new ($;%) {
82	wakaba	1.7	## Nothing to do
83			}
84
85			## Initialization for parse () method.
86			sub _initialize_parse ($;%) {
87			## Nothing to do
88			}
89
90			=item $p = Message::Field::Params->new ([%options])
91
92			Constructs a new object. You might pass some options as parameters
93			to the constructor.
94
95			=cut
96
97			sub new ($;%) {
98			my $self = shift->SUPER::new (@_);
99			$self->_initialize_new (@_);
100			$self;
101	wakaba	1.1	}
102
103	wakaba	1.7	=item $p = Message::Field::Params->parse ($field-body, [%options])
104	wakaba	1.1
105	wakaba	1.7	Constructs a new object with given field body. You might pass
106			some options as parameters to the constructor.
107	wakaba	1.1
108			=cut
109
110			sub parse ($$;%) {
111			my $class = shift;
112	wakaba	1.7	my $self = bless {}, $class;
113	wakaba	1.1	my $body = shift;
114	wakaba	1.7	$self->_init (@_);
115			$self->_initialize_parse (@_);
116			$body = Message::Util::delete_comment ($body);
117			$body = $self->_delete_fws ($body) if $self->{option}->{delete_fws};
118	wakaba	1.1	my @b = ();
119			$body =~ s{$REG{FWS}($REG{param})$REG{FWS}(?:;$REG{FWS}\|$)}{
120			my $param = $1;
121			push @b, $self->_parse_param ($param);
122			}goex;
123			@b = $self->_restore_param (@b);
124			$self->_save_param (@b);
125			$self;
126			}
127
128			sub _parse_param ($$) {
129			my $self = shift;
130			my $param = shift;
131			if ($param =~ /^$REG{M_parameter}$/) {
132	wakaba	1.7	my ($name, $value) = ($self->_n11n_param_name ($1), $2);
133	wakaba	1.1	my ($seq, $isencoded, $charset, $lang) = (-1, 0, '', '');
134			if ($name =~ /^$REG{M_parameter_name}$/) {
135			($name, $seq, $isencoded) = ($1, $4?-1:$2, ($3\|\|$4)?1:0);
136			}
137			if ($isencoded && $value =~ /^$REG{M_parameter_extended_value}$/) {
138			($charset, $lang, $value) = ($1, $2, $3);
139			}
140			return [$name, {value => $value, seq => $seq, is_encoded => $isencoded,
141			charset => $charset, language => $lang, is_parameter => 1}];
142			} else {
143			return [$param, {is_parameter => 0}];
144			}
145			}
146
147			sub _restore_param ($@) {
148			my $self = shift;
149			my @p = @_;
150			my @ret;
151			my %part;
152			for my $i (@p) {
153			if ($i->[1]->{is_parameter}) {
154			my $p = $i->[1];
155			if ($p->{seq}<0) {
156			my $s = $p->{value};
157			if ($p->{is_encoded}) {
158			$s =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/eg;
159	wakaba	1.3	my %s = &{$self->{option}->{hook_decode_string}} ($self, $s,
160			language => $p->{language}, charset => $p->{charset},
161			type => 'parameter/encoded');
162			($s, $p->{charset}, $p->{language}) = (@s{qw(value charset language)});
163	wakaba	1.1	} else {
164	wakaba	1.3	my $q = 0;
165	wakaba	1.7	($s,$q) = Message::Util::unquote_if_quoted_string ($p->{value});
166	wakaba	1.3	my %s = &{$self->{option}->{hook_decode_string}} ($self, $s,
167			type => ($q?'parameter/quoted':'parameter'));
168			($s, $p->{charset}, $p->{language}) = (@s{qw(value charset language)});
169	wakaba	1.1	}
170			push @ret, [$i->[0], {value => $s, language => $p->{language},
171			charset => $p->{charset}, is_parameter => 1}];
172			} else {
173			$part{$i->[0]}->[$p->{seq}] = {
174	wakaba	1.7	value => scalar Message::Util::unquote_if_quoted_string ($p->{value}),
175	wakaba	1.1	language => $p->{language}, charset => $p->{charset},
176			is_encoded => $p->{is_encoded}};
177			}
178	wakaba	1.3	} else {
179			my $q = 0;
180	wakaba	1.7	($i->[0], $q) = Message::Util::unquote_if_quoted_string ($i->[0]);
181	wakaba	1.3	my %s = &{$self->{option}->{hook_decode_string}} ($self, $i->[0],
182			type => ($q?'phrase/quoted':'phrase'));
183	wakaba	1.6	push @ret, [$s{value}, {is_parameter => 0}];
184	wakaba	1.3	}
185	wakaba	1.1	}
186			for my $name (keys %part) {
187			my $t = join '', map {
188			my $v = $_;
189			my $s = $v->{value};
190			$s =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/chr(hex($1))/eg if $v->{is_encoded};
191			$s;
192			} @{$part{$name}};
193	wakaba	1.3	my %s = &{$self->{option}->{hook_decode_string}} ($self, $t,
194			type => 'parameter/encoded');
195			($t,@part{$name}->[0]->{qw(charset language)})=(@s{qw(value charset language)});
196	wakaba	1.1	push @ret, [$name, {value => $t, charset => $part{$name}->[0]->{charset},
197			language => $part{$name}->[0]->{language},
198			is_parameter => 1}];
199			}
200			@ret;
201			}
202
203			sub _save_param ($@) {
204			my $self = shift;
205			my @p = @_;
206			$self->{param} = \@p;
207			$self;
208			}
209
210	wakaba	1.7	=back
211
212			=head1 METHODS
213
214			=over 4
215
216			=item $p->add ($name => [$value], [$name => $value,...])
217	wakaba	1.1
218			Adds parameter name=value pair.
219
220			Example:
221	wakaba	1.7	$p->add (title => 'foo of bar'); ## title="foo of bar"
222			$p->add (subject => 'hogehoge, foo'); ## subject*=''hogehoge%2C%20foo
223			$p->add (foo => ['bar', language => 'en']) ## foo*='en'bar
224			$p->add ('text/plain', ['', value => 1]) ## text/plain
225	wakaba	1.1
226			This method returns array reference of (name, {value => value, attribute...}).
227
228			Available options: charset (charset name), language (language tag),
229			value (1/0, see example above).
230
231			=cut
232
233			sub add ($$;$%) {
234			my $self = shift;
235	wakaba	1.7	my %gp = @_;
236			my %option = %{$self->{option}};
237			for (grep {/^-/} keys %gp) {$option{substr ($_, 1)} = $gp{$_}}
238			$option{parse} = 1 if defined wantarray;
239			my $p;
240			for (grep {/^[^-]/} keys %gp) {
241			my ($name, $value, %po) = ($self->_n11n_param_name ($_));
242			if (ref $gp{$_}) {($value, %po) = @{$gp{$_}}} else {$value = $gp{$_}}
243			$p = [$name, {value => $value, charset => $po{charset},
244			is_parameter => 1, language => $po{language}}];
245			$p->[1]->{is_parameter} = 0 if !$value && $po{value};
246			Carp::croak "add: \$name contains of non-attribute-char: $name"
247			if $p->[1]->{is_parameter} && $name =~ /$REG{NON_http_attribute_char}/;
248			$p->[1]->{value} = $self->_param_value ($name => $p->[1]->{value})
249			if $option{parse};
250			if ($option{prepend}) {
251			unshift @{$self->{param}}, $p;
252			} else {
253			push @{$self->{param}}, $p;
254			}
255	wakaba	1.1	}
256	wakaba	1.7	$p->[1]->{is_parameter}? $p->[1]->{value}: $p->[0];
257	wakaba	1.1	}
258	wakaba	1.7
259			sub replace ($%) {
260	wakaba	1.1	my $self = shift;
261	wakaba	1.7	my %gp = @_;
262			my %option = %{$self->{option}};
263			for (grep {/^-/} keys %gp) {$option{substr ($_, 1)} = $gp{$_}}
264			$option{parse} = 1 if defined wantarray;
265			my $p;
266			for (grep {/^[^-]/} keys %gp) {
267			my ($name, $value, %po) = ($self->_n11n_param_name ($_));
268			if (ref $gp{$_}) {($value, %po) = @{$gp{$_}}} else {$value = $gp{$_}}
269			$p = [$name, {value => $value, charset => $po{charset},
270			is_parameter => 1, language => $po{language}}];
271			$p->[1]->{is_parameter} = 0 if !$value && $po{value};
272			Carp::croak "replace: \$name contains of non-attribute-char: $name"
273			if $p->[1]->{is_parameter} && $name =~ /$REG{NON_http_attribute_char}/;
274			$p->[1]->{value} = $self->_param_value ($name => $p->[1]->{value})
275			if $option{parse};
276			my $f = 0;
277			for my $param (@{$self->{param}}) {
278			if ($param->[0] eq $name) {$param = $p; $f = 1}
279	wakaba	1.1	}
280	wakaba	1.7	push @{$self->{param}}, $p unless $f == 1;
281	wakaba	1.1	}
282	wakaba	1.7	$p->[1]->{is_parameter}? $p->[1]->{value}: $p->[0];
283	wakaba	1.1	}
284
285			sub delete ($$;%) {
286			my $self = shift;
287	wakaba	1.7	my ($name, $index) = ($self->_n11n_param_name (shift), shift);
288	wakaba	1.1	my $i = 0;
289			for my $param (@{$self->{param}}) {
290			if ($param->[0] eq $name) {
291			$i++;
292			if ($index == 0 \|\| $i == $index) {
293			undef $param;
294			return $self if $i == $index;
295			}
296			}
297			}
298			$self;
299			}
300
301			sub count ($;$%) {
302			my $self = shift;
303	wakaba	1.7	my $name = $self->_n11n_param_name (shift);
304	wakaba	1.1	unless ($name) {
305			$self->_delete_empty ();
306			return $#{$self->{param}}+1;
307			}
308			my $count = 0;
309			for my $param (@{$self->{param}}) {
310			if ($param->[0] eq $name) {
311			$count++;
312			}
313			}
314			$count;
315			}
316
317
318	wakaba	1.7	sub parameter ($$;$%) {
319	wakaba	1.1	my $self = shift;
320	wakaba	1.7	my $name = $self->_n11n_param_name (shift);
321	wakaba	1.1	my $newvalue = shift;
322	wakaba	1.7	return $self->replace ($name => $newvalue,@_) if defined $newvalue;
323	wakaba	1.1	my @ret;
324			for my $param (@{$self->{param}}) {
325			if ($param->[0] eq $name) {
326			unless (wantarray) {
327	wakaba	1.3	$param->[1]->{value}
328			= $self->_param_value ($name => $param->[1]->{value});
329	wakaba	1.1	return $param->[1]->{value};
330			} else {
331	wakaba	1.3	$param->[1]->{value}
332			= $self->_param_value ($name => $param->[1]->{value});
333	wakaba	1.1	push @ret, $param->[1]->{value};
334			}
335			}
336			}
337			@ret;
338			}
339
340			sub parameter_name ($$;$) {
341			my $self = shift;
342			my $i = shift;
343			my $newname = shift;
344			if ($newname) {
345	wakaba	1.4	return 0 if $newname =~ /$REG{NON_http_attribute_char}/;
346	wakaba	1.1	$self->{param}->[$i]->[0] = $newname;
347			}
348			$self->{param}->[$i]->[0];
349			}
350			sub parameter_value ($$;$) {
351			my $self = shift;
352			my $i = shift;
353			my $newvalue = shift;
354			if ($newvalue) {
355			$newvalue = $self->_param_value ($self->{param}->[$i]->[0] => $newvalue);
356			$self->{param}->[$i]->[1]->{value} = $newvalue;
357			}
358			$self->{param}->[$i]->[1]->{value}
359			= $self->_param_value
360			($self->{param}->[$i]->[0] => $self->{param}->[$i]->[1]->{value});
361			$self->{param}->[$i]->[1]->{value};
362			}
363
364			## Hook called before returning C<value>.
365			## $self->_param_value ($name, $value);
366	wakaba	1.5	sub _param_value ($$$) {
367			my $self = shift;
368	wakaba	1.7	my $name = shift \|\| '*default';
369	wakaba	1.5	my $value = shift;
370	wakaba	1.6	my $vtype = $self->{option}->{value_type}->{$name}->[0]
371	wakaba	1.7	\|\| $self->{option}->{value_type}->{'*default'}->[0];
372	wakaba	1.5	my %vopt; %vopt = %{$self->{option}->{value_type}->{$name}->[1]}
373			if ref $self->{option}->{value_type}->{$name}->[1];
374			if (ref $value) {
375			return $value;
376			} elsif ($vtype eq ':none:') {
377			return $value;
378			} elsif ($value) {
379			eval "require $vtype";
380	wakaba	1.7	return $vtype->parse ($value, -format => $self->{option}->{format},
381			-field_body => $self->{option}->{field_body}, %vopt);
382	wakaba	1.5	} else {
383			eval "require $vtype";
384	wakaba	1.7	return $vtype->new (-format => $self->{option}->{format},
385			-field_body => $self->{option}->{field_body}, %vopt);
386	wakaba	1.5	}
387			}
388	wakaba	1.1
389			sub _delete_empty ($) {
390			my $self = shift;
391	wakaba	1.7	$self->{param} = [grep {length $_} @{$self->{param}}];
392	wakaba	1.1	}
393
394
395	wakaba	1.7	=item $field-body = $p->stringify ()
396	wakaba	1.1
397	wakaba	1.7	Returns C<field-body> as a string.
398	wakaba	1.1
399			=cut
400
401			sub stringify ($;%) {
402			my $self = shift;
403	wakaba	1.7	my %o = @_;
404			my %option = %{$self->{option}};
405			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
406			$self->_delete_empty;
407	wakaba	1.1	join '; ',
408			map {
409			my $v = $_->[1];
410			my $new = '';
411			if ($v->{is_parameter}) {
412			my ($encoded, @value) = (0, '');
413	wakaba	1.3	my (%e) = &{$self->{option}->{hook_encode_string}} ($self,
414			$v->{value}, current_charset => $v->{charset}, language => $v->{language},
415			type => 'parameter');
416	wakaba	1.7	if ($option{use_parameter_extension} && ($e{charset} \|\| $e{language}
417	wakaba	1.3	\|\| $e{value} =~ /[\x00\x0D\x0A\x80-\xFF]/)) {
418	wakaba	1.1	my ($charset, $lang);
419			$encoded = 1;
420	wakaba	1.3	($charset, $lang) = ($e{charset}, $e{language});
421	wakaba	1.1	## Note: %-quoting for charset and for language is not allowed.
422			## But charset name can be included non-sttribute-char such as "'".
423			## How can we treat this?
424	wakaba	1.4	$charset =~ s/($REG{NON_http_attribute_char})/sprintf('%%%02X', ord $1)/ge;
425			$lang =~ s/($REG{NON_http_attribute_char})/sprintf('%%%02X', ord $1)/ge;
426	wakaba	1.7	if (length $e{value} > $option{parameter_value_max_length}) {
427			for my $i (0..length ($e{value})/$option{parameter_value_max_length}) {
428			$value[$i] = substr ($e{value}, $i*$option{parameter_value_max_length},
429			$option{parameter_value_max_length});
430	wakaba	1.1	}
431	wakaba	1.3	} else {$value[0] = $e{value}}
432	wakaba	1.1	for my $i (0..$#value) {
433	wakaba	1.4	$value[$i] =~
434			s/($REG{NON_http_attribute_char})/sprintf('%%%02X', ord $1)/ge;
435	wakaba	1.1	}
436			$value[0] = "${charset}'${lang}'".$value[0];
437	wakaba	1.3	} elsif (length $e{value} == 0) {
438	wakaba	1.1	$value[0] = '""';
439			} else {
440	wakaba	1.7	if ($option{use_parameter_extension}
441			&& length $e{value} > $option{parameter_value_max_length}) {
442			for my $i (0..length ($e{value})/$option{parameter_value_max_length}) {
443			$value[$i] = Message::Util::quote_unsafe_string
444			(substr ($e{value}, $i*$option{parameter_value_max_length},
445			$option{parameter_value_max_length}),
446	wakaba	1.4	unsafe => 'NON_http_attribute_char');
447	wakaba	1.1	}
448			} else {
449	wakaba	1.7	my $unsafe = $self->{option}->{parameter_value_unsafe_rule}->{$_->[0]}
450			\|\| $self->{option}->{parameter_value_unsafe_rule}->{'*default'};
451			$value[0] = Message::Util::quote_unsafe_string
452			($e{value}, unsafe => $unsafe);
453	wakaba	1.1	}
454			}
455			## Note: quoted-string for parameter name is not allowed.
456			## But it is better than output bare non-atext.
457			if ($#value == 0) {
458			$new =
459	wakaba	1.7	Message::Util::quote_unsafe_string ($_->[0],
460			unsafe => 'NON_attribute_char')
461	wakaba	1.1	.($encoded?'*':'').'='.$value[0];
462			} else {
463			my @new;
464	wakaba	1.7	my $name = Message::Util::quote_unsafe_string
465	wakaba	1.4	($_->[0], unsafe => 'NON_http_attribute_char');
466	wakaba	1.1	for my $i (0..$#value) {
467			push @new, $name.''.$i.($encoded?'':'').'='.$value[$i];
468			}
469			$new = join '; ', @new;
470			}
471			} else {
472	wakaba	1.3	my %e = &{$self->{option}->{hook_encode_string}} ($self,
473			$_->[0], type => 'phrase');
474	wakaba	1.7	$new = Message::Util::quote_unsafe_string ($e{value},
475	wakaba	1.4	unsafe => 'NON_http_token_wsp');
476	wakaba	1.1	}
477			$new;
478			} @{$self->{param}}
479			;
480			}
481	wakaba	1.7	*as_string = \&stringify;
482	wakaba	1.1
483	wakaba	1.7	sub scan ($&) {
484			my ($self, $sub) = @_;
485			#my $sort;
486			#$sort = \&_header_cmp if $self->{option}->{sort} eq 'good-practice';
487			#$sort = {$a cmp $b} if $self->{option}->{sort} eq 'alphabetic';
488			my @param = @{$self->{param}};
489			#if (ref $sort) {
490			# @field = sort $sort @{$self->{param}};
491			#}
492			for my $param (@param) {
493			&$sub($param->[0] => $param->[1]->{value}, $param->[1]);
494			}
495			}
496
497			=item $option-value = $ua->option ($option-name)
498	wakaba	1.1
499	wakaba	1.7	Gets option value.
500
501			=item $csv->option ($option-name, $option-value, ...)
502
503			Set option value(s). You can pass multiple option name-value pair
504			as parameter when setting.
505	wakaba	1.1
506			=cut
507
508	wakaba	1.7	sub option ($;$%) {
509	wakaba	1.1	my $self = shift;
510	wakaba	1.7	my $format = $self->{option}->{format};
511			$self->SUPER::option (@_);
512			if ($format ne $self->{option}->{format}) {
513			$self->scan (sub {
514			if (ref $_[1]) {
515			$_[1]->option (-format => $self->{option}->{format});
516			}
517			});
518	wakaba	1.1	}
519			}
520
521	wakaba	1.7	sub value_type ($;$$%) {
522	wakaba	1.1	my $self = shift;
523	wakaba	1.7	my $name = shift \|\| '*default';
524			my $new_value_type = shift;
525			if ($new_value_type) {
526			$self->{option}->{value_type}->{$name} = []
527			unless ref $self->{option}->{value_type}->{$name};
528			$self->{option}->{value_type}->{$name}->[0] = $new_value_type;
529			}
530			if (ref $self->{option}->{value_type}->{$name}) {
531			$self->{option}->{value_type}->{$name}->[0]
532			\|\| $self->{option}->{value_type}->{'*default'}->[0];
533			} else {
534			$self->{option}->{value_type}->{'*default'}->[0];
535	wakaba	1.1	}
536			}
537
538	wakaba	1.7	sub value_unsafe_rule ($$;$%) {
539	wakaba	1.1	my $self = shift;
540	wakaba	1.7	if (@_ == 1) {
541			return $self->{option}->{parameter_value_unsafe_rule}->{ $_[0] };
542			}
543			while (my ($name, $value) = splice (@_, 0, 2)) {
544			$name = $self->_n11n_param_name ($name);
545			$self->{option}->{parameter_value_unsafe_rule}->{$name} = $value;
546			}
547	wakaba	1.1	}
548
549	wakaba	1.7	=item $clone = $ua->clone ()
550	wakaba	1.1
551	wakaba	1.7	Returns a copy of the object.
552	wakaba	1.1
553			=cut
554
555	wakaba	1.7	sub clone ($) {
556	wakaba	1.1	my $self = shift;
557	wakaba	1.7	$self->_delete_empty;
558			my $clone = $self->SUPER::clone;
559			$clone->{param} = Message::Util::make_clone ($self->{param});
560			$clone->{value_type} = Message::Util::make_clone ($self->{value_type});
561			$clone;
562	wakaba	1.1	}
563
564			sub _delete_fws ($$) {
565			my $self = shift;
566			my $body = shift;
567	wakaba	1.3	$body =~ s{($REG{quoted_string}\|$REG{domain_literal})\|((?:$REG{token}\|$REG{S_encoded_word})(?:$REG{WSP}+(?:$REG{token}\|$REG{S_encoded_word}))+)\|$REG{WSP}+}{
568			my ($o,$p) = ($1,$2);
569			if ($o) {$o}
570			elsif ($p) {$p=~s/$REG{WSP}+/\x20/g;$p}
571			else {''}
572	wakaba	1.1	}gex;
573			$body;
574			}
575
576	wakaba	1.7	sub _n11n_param_name ($$) {
577			my $self = shift;
578			my $s = shift;
579			$s = lc $s unless $self->{option}->{parameter_name_case_sensible};
580			$s;
581			}
582
583	wakaba	1.1	=head1 LICENSE
584
585			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
586
587			This program is free software; you can redistribute it and/or modify
588			it under the terms of the GNU General Public License as published by
589			the Free Software Foundation; either version 2 of the License, or
590			(at your option) any later version.
591
592			This program is distributed in the hope that it will be useful,
593			but WITHOUT ANY WARRANTY; without even the implied warranty of
594			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
595			GNU General Public License for more details.
596
597			You should have received a copy of the GNU General Public License
598			along with this program; see the file COPYING. If not, write to
599			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
600			Boston, MA 02111-1307, USA.
601
602			=head1 CHANGE
603
604			See F<ChangeLog>.
605	wakaba	1.7	$Date: 2002/04/01 05:32:15 $
606	wakaba	1.1
607			=cut
608
609			1;