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.4 $=~/\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{uri_literal} = qr/\x3C[\x09\x20\x21\x23-\x3B\x3D\x3F-\x5B\x5D\x5F\x61-\x7A\x7E]*\x3E/;

$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{http_token} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\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{uri_literal})(?:$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_http_token} = qr/[^\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
$REG{NON_http_token_wsp} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
$REG{NON_attribute_char} = qr/[^\x21\x23-\x24\x26\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]/;
$REG{NON_http_attribute_char} = qr/[^\x21\x23-\x24\x26\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
        ## Yes, C<attribute-char> does not appear in HTTP spec.


%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,
  value_type    => {'*DEFAULT'  => [':none:']},
);

## Initialization for both C<new ()> and C<parse ()> methods.
sub _initialize ($;%) {$_[0]}

=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 ();
  $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 ();
  $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_http_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_http_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_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];
  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, %vopt);
  } else {
    eval "require $vtype";
    return $vtype->new (%vopt);
  }
}

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_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}) {
            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_http_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_http_attribute_char');
            }
          } else {
            $value[0] = $self->_quote_unsafe_string 
              ($e{value}, unsafe => 'NON_http_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_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 = $self->_quote_unsafe_string ($e{value}, 
          unsafe => 'NON_http_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';
  $option{unsafe_regex} ||= $REG{$option{unsafe}};
  if ($string =~ /$option{unsafe_regex}/ || $string =~ /$REG{WSP}$REG{WSP}+/) {
    $string =~ s/([\x22\x5C])([\x21-\x7E])?/"\x5C$1".(defined $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;
}

## Unquote C<DQOUTE> and C<quoted-pair> if it is itself a
## C<quoted-string>.  (Do nothing if it is MULTIPLE
## C<quoted-string>"S".)
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{uri_literal}|$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/26 05:31:55 $

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