Message/Field/Params.pm


=head1 NAME

Message::Field::Params Perl module

=head1 DESCRIPTION

Perl module for parameters field body (such as C<Content-Type:>).

=cut

package Message::Field::Params;
use strict;
require 5.6.0;
use re 'eval';
use vars qw(%DEFAULT %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Util;
use Carp;
use overload '@{}' => sub {shift->_delete_empty()->{param}},
             '""' => sub {shift->stringify};

$REG{WSP} = qr/[\x09\x20]/;
$REG{FWS} = qr/[\x09\x20]*/;

$REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]+|(??{$REG{comment}}))*\x29/;
$REG{quoted_string} = qr/\x22(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*\x22/;
$REG{domain_literal} = qr/\x5B(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x5A\x5E-\xFF])*\x5D/;
$REG{atext} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2F-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
$REG{atext_dot} = qr/[\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
$REG{token} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]+/;
$REG{attribute_char} = qr/[\x21\x23-\x24\x26\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]+/;
$REG{S_encoded_word} = qr/=\x3F$REG{atext_dot}\x3F=/;

$REG{param} = qr/(?:$REG{atext_dot}|$REG{quoted_string})(?:$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_quoted_string} = qr/\x22((?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*)\x22/;
$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.

$REG{NON_atext} = qr/[^\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
$REG{NON_atext_dot} = qr/[^\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
$REG{NON_atext_dot_wsp} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
$REG{NON_token} = qr/[^\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]/;
$REG{NON_token_wsp} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]/;
$REG{NON_attribute_char} = qr/[^\x21\x23-\x24\x26\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]/;


%DEFAULT = (
  delete_fws    => 1,
  encoding_after_encode => '*default',
  encoding_before_decode        => '*default',
  hook_encode_string    => #sub {shift; (value => shift, @_)},
        \&Message::Util::encode_header_string,
  hook_decode_string    => #sub {shift; (value => shift, @_)},
        \&Message::Util::decode_header_string,
  parameter_value_max   => 78,
  use_parameter_extension       => -1,
);

=head2 Message::Field::Params->new ([%option])

Returns new Message::Field::Params.  Some options can be given as hash.

=cut

sub new ($;%) {
  my $class = shift;
  my $self = bless {option => {@_}}, $class;
  $self->_initialize_new ();
  for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
  $self;
}

## Initialization for new () method.
sub _initialize_new ($;%) {
  my $self = shift;
  #for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
}

=head2 Message::Field::Params->parse ($nantara, [%option])

Parse Message::Field::Params and new ContentType instance.  
Some options can be given as hash.

=cut

sub parse ($$;%) {
  my $class = shift;
  my $body = shift;
  my $self = bless {option => {@_}}, $class;
  $self->_initialize_parse ();
  for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
  $body = $self->_delete_comment ($body);
  $body = $self->_delete_fws ($body) if $self->{option}->{delete_fws}>0;
  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;
}

## Initialization for parse () method.
sub _initialize_parse ($;%) {
  my $self = shift;
  #for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
}

sub _parse_param ($$) {
  my $self = shift;
  my $param = shift;
  if ($param =~ /^$REG{M_parameter}$/) {
    my ($name, $value) = (lc $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) = $self->_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 => $self->_unquote_if_quoted_string ($p->{value}),
        language => $p->{language}, charset => $p->{charset},
        is_encoded => $p->{is_encoded}};
      }
    } else {
      my $q = 0;
      ($i->[0], $q) = $self->_unquote_if_quoted_string ($i->[0]);
      my %s = &{$self->{option}->{hook_decode_string}} ($self, $i->[0],
                type => ($q?'phrase/quoted':'phrase'));
      ($i->[0]) = ($s{value});
      push @ret, $i
    }
  }
  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;
}

=head2 $self->add ($name, [$value]. [%option]

Adds parameter name=value pair.

  Example:
    $self->add (title => 'foo of bar'); ## title="foo of bar"
    $self->add (subject => 'hogehoge, foo');    ## subject*=''hogehoge%2C%20foo
    $self->add (foo => 'bar', language => 'en') ## foo*='en'bar
    $self->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 ($name, $value, %option) = (lc shift, shift, @_);
  my $p = [$name, {value => $value, charset => $option{charset},
                   is_parameter => 1, language => $option{language}}];
  $p->[1]->{is_parameter} = 0 if !$value && $option{value}>0;
  croak "add: \$name contains of non-attribute-char: $name"
     if $p->[1]->{is_parameter} && $name =~ /$REG{NON_attribute_char}/;
  $p->[1]->{value} = $self->_param_value ($name => $p->[1]->{value});
  if ($option{prepend}) {
    unshift @{$self->{param}}, $p;
  } else {
    push @{$self->{param}}, $p;
  }
  $p;
}
sub replace ($$;$%) {
  my $self = shift;
  my ($name, $value, %option) = (lc shift, shift, @_);
  for my $param (@{$self->{param}}) {
    if ($param->[0] eq $name) {
      $param->[1] = {value => $value, charset => $option{charset},
                     is_parameter => 1, language => $option{language}};
      $param->[1]->{is_parameter} = 0 if !$value && $option{value}>0;
      $param->[1]->{value} = $self->_param_value ($name => $param->[1]->{value});
      return $param;
    }
  }
  my $p = [$name, {value => $value, charset => $option{charset},
                   is_parameter => 1, language => $option{language}}];
  $p->[1]->{is_parameter} = 0 if !$value && $option{value}>0;
  croak "replace: \$name contains of non-attribute-char: $name"
    if $p->[1]->{is_parameter} && $name =~ /$REG{NON_attribute_char}/;
  $p->[1]->{value} = $self->_param_value ($name => $p->[1]->{value});
  push @{$self->{param}}, $p;
  $p;
}

sub delete ($$;%) {
  my $self = shift;
  my ($name, $index) = (lc 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) = (lc 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 = lc shift;
  my $newvalue = shift;
  return $self->replace ($name => $newvalue,@_)->[1]->{value} 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_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 ($$$) {$_[2]}

sub _delete_empty ($) {
  my $self = shift;
  my @ret;
  for my $param (@{$self->{param}}) {
    push @ret, $param if $param->[0];
  }
  $self->{param} = \@ret;
  $self;
}


=head2 $self->stringify ([%option])

Returns Message::Field::Params as a string.

=head2 $self->as_string ([%option])

An alias of C<stringify>.

=cut

sub stringify ($;%) {
  my $self = shift;
  my %option = @_;
  my $use_xparam = $option{use_parameter_extension} 
            || $self->{option}->{use_parameter_extension};
  $option{parameter_value_max} 
            ||= $self->{option}->{parameter_value_max};
  $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 ($use_xparam>0 && ($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_attribute_char})/sprintf('%%%02X', ord $1)/ge;
          $lang =~ s/($REG{NON_attribute_char})/sprintf('%%%02X', ord $1)/ge;
          if (length $e{value} > $option{parameter_value_max}) {
            for my $i (0..length ($e{value})/$option{parameter_value_max}) {
              $value[$i] = substr ($e{value}, $i*$option{parameter_value_max},
                                                   $option{parameter_value_max});
            }
          } else {$value[0] = $e{value}}
          for my $i (0..$#value) {
            $value[$i] =~ s/($REG{NON_attribute_char})/sprintf('%%%02X', ord $1)/ge;
          }
          $value[0] = "${charset}'${lang}'".$value[0];
        } elsif (length $e{value} == 0) {
          $value[0] = '""';
        } else {
          if ($use_xparam>0 && length $e{value} > $option{parameter_value_max}) {
            for my $i (0..length ($e{value})/$option{parameter_value_max}) {
              $value[$i] = $self->_quote_unsafe_string 
                (substr ($e{value}, $i*$option{parameter_value_max},
                    $option{parameter_value_max}), unsafe => 'NON_attribute_char');
            }
          } else {
            $value[0] = $self->_quote_unsafe_string 
              ($e{value}, unsafe => 'NON_attribute_char');
          }
        }
        ## Note: quoted-string for parameter name is not allowed.
        ## But it is better than output bare non-atext.
        if ($#value == 0) {
          $new = 
            $self->_quote_unsafe_string ($_->[0], unsafe => 'NON_attribute_char')
            .($encoded?'*':'').'='.$value[0];
        } else {
          my @new;
          my $name = $self->_quote_unsafe_string 
            ($_->[0], unsafe => 'NON_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 = $self->_quote_unsafe_string ($e{value}, unsafe => 'NON_token_wsp');
      }
      $new;
    } @{$self->{param}}
  ;
}
sub as_string ($;%) {shift->stringify (@_)}

=head2 $self->option ($option_name)

Returns/set (new) value of the option.

=cut

sub option ($$;$) {
  my $self = shift;
  my ($name, $newval) = @_;
  if ($newval) {
    $self->{option}->{$name} = $newval;
  }
  $self->{option}->{$name};
}

sub _quote_unsafe_string ($$;%) {
  my $self = shift;
  my $string = shift;
  my %option = @_;
  $option{unsafe} ||= 'NON_atext_dot';
  if ($string =~ /$REG{$option{unsafe}}/ || $string =~ /$REG{WSP}$REG{WSP}+/) {
    $string =~ s/([\x22\x5C])([\x20-\xFF])?/"\x5C$1".($2?"\x5C$2":'')/ge;
    $string = '"'.$string.'"';
  }
  $string;
}

=head2 $self->_unquote_quoted_string ($string)

Unquote C<quoted-string>.  Get rid of C<DQUOTE>s and
C<REVERSED SOLIDUS> included in C<quoted-pair>.
This method is intended for internal use.

=cut

sub _unquote_quoted_string ($$) {
  my $self = shift;
  my $quoted_string = shift;
  $quoted_string =~ s{$REG{M_quoted_string}}{
    my $qtext = $1;
    $qtext =~ s/\x5C([\x00-\xFF])/$1/g;
    $qtext;
  }goex;
  $quoted_string;
}

sub _unquote_if_quoted_string ($$) {
  my $self = shift;
  my $quoted_string = shift;  my $isq = 0;
  $quoted_string =~ s{^$REG{M_quoted_string}$}{
    my $qtext = $1;
    $qtext =~ s/\x5C([\x00-\xFF])/$1/g;
    $isq = 1;
    $qtext;
  }goex;
  wantarray? ($quoted_string, $isq): $quoted_string;
}

=head2 $self->_delete_comment ($field_body)

Remove all C<comment> in given strictured C<field-body>.
This method is intended for internal use.

=cut

sub _delete_comment ($$) {
  my $self = shift;
  my $body = shift;
  $body =~ s{($REG{quoted_string}|$REG{domain_literal})|$REG{comment}}{
    my $o = $1;  $o? $o : ' ';
  }gex;
  $body;
}

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;
}

=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/03/23 11:41:36 $

=cut

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