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.9 $=~/\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}|,)*/;
$REG{param_nocomma} = 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{param_free} = qr/(?:[^\x09\x20\x22\x3B\x3C]|$REG{quoted_string}|$REG{angle_quoted})(?:[^\x22\x3B\x3C]|$REG{quoted_string})*/;
$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})?/;
$REG{M_parameter} = qr/($REG{token})=($REG{quoted_string}|[^\x22]*)/;
        ## 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,## BUG: this option MUST be '1'.
        ## parameter parser cannot procede CFWS.
    #encoding_after_encode
    #encoding_before_decode
    #field_param_name
    #field_name
    #format
    #hook_encode_string
    #hook_decode_string
    -parameter_rule     => 'param',
    -parameter_name_case_sensible       => 0,
    -parameter_value_max_length => 78,
    -parameter_value_unsafe_rule        => {'*default'  => 'NON_http_attribute_char'},
    -parse_all  => 0,
    -separator  => '; ',
    -separator_regex    => qr/$REG{FWS};$REG{FWS}/,
    -use_parameter_extension    => 0,
    #value_type
  );
  $self->SUPER::_init (%DEFAULT, %options);
  $self->{param} = [];
  my $fname = $self->_n11n_field_name ($self->{option}->{field_name});
  if ($fname eq 'p3p') {
    $self->{option}->{parameter_rule} = 'param_nocomma';
    $self->{option}->{separator} = ', ';
    $self->{option}->{separator_regex} = qr/$REG{FWS},$REG{FWS}/;
  }
  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{$self->{option}->{parameter_rule}})
             (?:$self->{option}->{separator_regex}|$)}{
    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)});
        } elsif ($p->{is_internal}) {
          $s = $p->{value};
        } 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, [Message::Util::decode_quoted_string ($self, $i->[0]), 
                  {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 = map {## TODO: BUG:
    if ($self->{option}->{parse_all} && $_->[1]->{is_parameter}) {
      $_->[1]->{value} = $self->_parse_value ($_->[0] => $_->[1]->{value});
    }
    $_;
  } @_;
  $self->{param} = \@p;
  $self;
}
*__save_param = \&_save_param;  ## SHOULD NOT BE OVERRIDDEN!

=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->_parse_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 !defined ($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->_parse_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];
}

## TODO: multiple parameters support
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->_parse_value ($name => $param->[1]->{value});
        return $param->[1]->{value};
      } else {
        $param->[1]->{value} 
          = $self->_parse_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->_parse_value ($self->{param}->[$i]->[0] => $newvalue);
    $self->{param}->[$i]->[1]->{value} = $newvalue;
  }
  $self->{param}->[$i]->[1]->{value} 
    = $self->_parse_value 
      ($self->{param}->[$i]->[0] => $self->{param}->[$i]->[1]->{value});
  $self->{param}->[$i]->[1]->{value};
}


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;
  my @ret = ();
  $self->scan (sub {
    my $self = shift;
      my ($n => $v) = @_[0 => 2]; #$_->[1];
      return unless $self->_stringify_params_check (@_[0 => 2]);
      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 ($e{value} eq undef) {
          $value[0] = undef;
        } elsif ($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}->{$n}
                     || $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 ($n, 
              unsafe => 'NON_attribute_char')
            .($encoded?'*':'').'='.$value[0]
              if defined $value[0];
        } else {
          my @new;
          my $name = Message::Util::quote_unsafe_string 
            ($n, 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, 
          $n, type => 'phrase');
        $new = Message::Util::quote_unsafe_string ($e{value}, 
          unsafe => 'NON_http_token_wsp');
      }
      push @ret, $new;
  });
  join $self->{option}->{separator}, @ret;
}
*as_string = \&stringify;

sub _stringify_params_check ($$$) {
  my $self = shift;
  my ($name, $value) = @_;
  1;
}

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($self, $param->[0] => $param->[1]->{value}, $param->[1]);
  }
}

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

Gets option value.

=item $p->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});
      }
    });
  }
}

## value_type: Inherited

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 = $p->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/05/04 06:03:58 $

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