lib/Message/Util.pm


=head1 NAME

Message::Util -- Utilities for Message::* Perl modules.

=head1 DESCRIPTION

Useful functions for Message::* Perl modules.
This module is only intended for internal use.
But some can be useful for general use.

=cut

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

use Carp ();
require Message::MIME::EncodedWord;
require Message::MIME::Charset;

=head1 REGEXPS (%Message::Util::REG)

=head2 Naming Rules

  key = *(prefix) [format] token-name
  
  prefix = 'M_' ;; With matching "(" ")"s
         / 'S_' ;; Simple (not strict) expression
         / 'NON_'       ;; Negative character class
  format = E<lt>specification id, such as C<http>E<gt>  ;; if necessary
  token-name = E<lt>BNF name =~ tr/-/_/E<gt>

=cut

        $REG{MATCH_NONE} = qr/(?!)/;
        $REG{MATCH_ALL} = qr/[\x00-\xFF]/;
## Whitespace
        $REG{WSP} = qr/[\x09\x20]/;
        $REG{FWS} = qr/[\x09\x20]*/;    ## not same as 2822's
## Basic structure
        $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{angle_quoted} = qr/\x3C[\x09\x20\x21\x23-\x3B\x3D\x3F-\x5B\x5D\x5F\x61-\x7A\x7E]*\x3E/;
        
        $REG{M_quoted_string} = qr/\x22((?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*)\x22/;
        $REG{M_comment} = qr/\x28((?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]|(??{$REG{comment}}))*)\x29/;
        $REG{M_domain_literal} = qr/\x5B((?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x5A\x5E-\xFF])*)\x5D/;

=head2 tokens

 atext          NON_atext       822.atext
 atext_dot      NON_atext_dot   822.atext / "."
                NON_atext_dot_wsp       822.atext / "." / WSP
 http_token     NON_http_token  http.token
                NON_http_token_wsp      http.token / WSP
 attribute_char         rfc2231.attribute-char
                NON_http_attribute_char http.token AND rfc2231.attribute-char

=cut

        $REG{atext} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\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{atext_dot_wsp} = qr/[\x09\x20\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
        $REG{atext_dot8} = qr/[\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E\x80-\xFF]+/;
        $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{NON_atext} = qr/[^\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
        $REG{NON_atext_wsp} = qr/[^\x09\x20\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_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]/;
        $REG{NON_http_attribute_char_wsp} = qr/[^\x09\x20\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.
        
        $REG{dot_atom} = qr/$REG{atext}(?:$REG{FWS}\x2E$REG{FWS}$REG{atext})*/;
        $REG{dot_atom_dot} = qr/$REG{atext_dot}(?:$REG{FWS}\x2E$REG{FWS}$REG{atext_dot})*/;
        $REG{dot_word} = qr/(?:$REG{atext}|$REG{quoted_string})(?:$REG{FWS}\x2E$REG{FWS}(?:$REG{atext}|$REG{quoted_string}))*/;
        $REG{dot_word_dot} = qr/(?:$REG{atext_dot}|$REG{quoted_string})(?:$REG{FWS}\x2E$REG{FWS}(?:$REG{atext_dot}|$REG{quoted_string}))*/;
        $REG{phrase} = qr/(?:$REG{atext}|$REG{quoted_string})(?:$REG{atext}|$REG{quoted_string}|\.|$REG{FWS})*/;
                ## RFC 822 phrase (not strict)

        #$REG{domain} = qr/(?:$REG{dot_atom}|$REG{domain_literal})/;
        $REG{domain} = qr/(?:$REG{dot_atom_dot}|$REG{domain_literal})/;
        #$REG{addr_spec} = qr/$REG{dot_word}$REG{FWS}\x40$REG{FWS}$REG{domain}/;
        $REG{addr_spec} = qr/$REG{dot_word_dot}$REG{FWS}\x40$REG{FWS}$REG{domain}/;
        $REG{msg_id} = qr/<$REG{FWS}$REG{addr_spec}$REG{FWS}>/;
        
        $REG{M_addr_spec} = qr/($REG{dot_word_dot})$REG{FWS}\x40$REG{FWS}($REG{domain})/;
        
        $REG{date_time} = qr/(?:[A-Za-z]+$REG{FWS},$REG{FWS})?[0-9]+$REG{WSP}*[A-Za-z]+$REG{WSP}*[0-9]+$REG{WSP}+[0-9]+$REG{FWS}:$REG{WSP}*[0-9]+(?:$REG{FWS}:$REG{WSP}*[0-9]+)?$REG{FWS}(?:[A-Za-z]+|[+-]$REG{WSP}*[0-9]+)/;
        $REG{asctime} = qr/[A-Za-z]+$REG{WSP}*[A-Za-z]+$REG{WSP}*[0-9]+$REG{WSP}+[0-9]+$REG{FWS}:$REG{WSP}*[0-9]+$REG{FWS}:$REG{WSP}*[0-9]+$REG{WSP}+[0-9]+/;

## MIME encoded-word
        $REG{M_encoded_word} = qr/=\x3F($REG{attribute_char})(?:\x2A($REG{attribute_char}))?\x3F($REG{attribute_char})\x3F([\x21-\x3E\x40-\x7E]+)\x3F=/;
        $REG{S_encoded_word} = qr/=\x3F$REG{atext_dot}\x3F=/;
        #$REG{S_encoded_word_comment} = qr/=\x3F[\x21-\x27\x2A-\x5B\x5D-\x7E]+\x3F=/;
                ## not used anywhere

=head1 STRUCTURED FIELD FUNCTIONS

=over 4

=item $nocomment:-) = Message::Util::delete_comment ($string)

Gets rid of all C<comment>s.  Inserts a SP instead.

=cut

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

sub delete_wsp ($) {
  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 remove_meaningless_wsp ($) {
  my $body = shift;
  $body =~ s{($REG{quoted_string}|$REG{domain_literal})|$REG{WSP}+}{
    $1 || '';
  }gex;
  $body;
}

sub wsps_to_sp ($) {
  my $body = shift;
  $body =~ s{($REG{quoted_string}|$REG{domain_literal})|$REG{WSP}+}{
    $1 || ' ';
  }gex;
  $body;
}

=item $unquoted = Message::Util::unquote_ccontent ($string)

Unquotes C<quoted-pair> in C<comment>s.

=cut

sub unquote_ccontent ($) {
  my $comment = shift;
  $comment =~ s{$REG{M_comment}}{
    my $ctext = $1;
    $ctext =~ s/\x5C([\x00-\xFF])/$1/g;
    '('.$ctext.')';
  }goex;
  $comment;
}

=item $unquoted = Message::Util::unquote_quoted_string ($string)

Unquotes C<quoted-pair> in C<quoted-string>s and
unquotes C<quoted-string> (or gets rid of C<DQUOTE>s).

=cut

sub unquote_quoted_string ($) {
  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;
}

=item Message::Util::unquote_if_quoted_string ($string)

Unquotes if and only if given string is A C<quoted-string>.
This function returns two value, (C<$unquoted-string>, 
C<$was-quoted-string?>).

=cut

sub unquote_if_quoted_string ($) {
  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;
}

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

=item $quoted = Message::Util::quote_unsafe_string ($string)

Quotes string itself by C<DQUOTES> if it contains of
I<unsafe> character.

Default I<unsafe> is defined as E<lt>not ( atom / "." / %x09 / %x20 ) E<gt>.

=cut

sub quote_unsafe_string ($;%) {
  my $string = shift;
  my %option = @_;
  $option{unsafe} ||= 'NON_atext_dot';
  $option{unsafe_regex} = $option{unsafe} if $option{unsafe} =~ /^\(\?-xism:/;
  $option{unsafe_regex} ||= qr/$REG{$option{unsafe}}|$REG{WSP}$REG{WSP}|^$REG{WSP}|$REG{WSP}$/;
  my $r = qr/([\x22\x5C])([\x21-\x7E])?/;
  $r = qr/([\x22\x5C])/ if $option{strict};     ## usefor-article
  if ($string =~ /$option{unsafe_regex}/) {
    $string =~ s/$r/"\x5C$1".(defined $2?"\x5C$2":'')/ge;
    $string = '"'.$string.'"';
  }
  $string;
}

sub quote_unsafe_domain ($) {
  my $string = shift;
  if ($string =~ /^\[[^\[\]]+\]$/) {
    # 
  } elsif ($string =~ /$REG{NON_atext_dot}/ || $string =~ /^\.|\.$/) {
    $string =~ s/([\x5B-\x5D])/\x5C$1/g;
    $string = '['.$string.']';
  }
  $string;
}

sub remove_wsp ($) {
  my $s = shift;
  $s =~ s{($REG{quoted_string}|$REG{domain_literal}|$REG{angle_quoted})|$REG{WSP}+}{
    $1
  }gex;
  $s;
}

=item $Message::Util::make_clone ($parent)

Returns clone.

=cut

sub make_clone ($) {
  my $s = shift;
  if (ref $s eq 'ARRAY') {
    $s = [map {make_clone ($_)} @$s];
  } elsif (ref $s eq 'HASH') {
    $s = {map {make_clone ($_)} (%$s)};
  } elsif (ref $s && ref $s ne 'CODE' && ref $s ne 'Regexp') {
    $s = $s->clone;
  }
  $s;
}

=head1 ENCODER and DECODER

=over 4

=item Message::Util::encode_header_string ($yourself, $string, [%options])

=cut

sub encode_header_string ($$;%) {
  my $yourself = shift; my $s = shift; my %o = @_;
  $o{charset} ||= $yourself->{option}->{encoding_after_encode};
  $o{charset} = Message::MIME::Charset::name_normalize ($o{charset});
  $o{current_charset} = Message::MIME::Charset::name_normalize ($o{current_charset});
  my ($t,%r) = Message::MIME::Charset::encode ($o{charset}, $s);
  my @o = (language => $o{language});
  if ($r{success}) {    ## Convertion succeed
    $o{charset} = $r{charset} if $r{charset};
    (value => $t, @o, charset => ($o{charset}=~/\*/?'':$o{charset}));
  } else {      ## Fault
    (value => $s, @o, charset => ($o{current_charset}=~/\*/?'':$o{current_charset}));
  }
}

sub decode_header_string ($$;%) {
  my $yourself = shift; my $s = shift; my %o = @_;
  $o{charset} ||= $yourself->{option}->{encoding_before_decode};
  $o{charset} = Message::MIME::Charset::name_normalize ($o{charset});
  my ($t, $r);  ## decoded-text, success?
  if ($o{type} !~ /quoted|encoded|domain|word/) {
    my (@s, @r);
    $s =~ s{\G($REG{FWS}(?:\x5C[\x00-\xFF]
      |[\x00-\x08\x0A-\x0C\x0E\x0F\x21-\x5B\x5D-\xFF])+|$REG{WSP}+$)}
      { push @s, $& }goex;
    for my $i (0..$#s) {
      if ($s[$i] =~ /^($REG{FWS})$REG{M_encoded_word}$/) {
        my ($t, $w) = ('', $1);
        ($t, $r[$i]) = (Message::MIME::EncodedWord::_decode_eword ($2, $3, $4, $5));
        if ($r[$i]) {
          $s[$i] = $t;
          if ($i == 0 || $r[$i-1] == 0) {
            $s[$i] = $w.$s[$i];
          }
        }
      } else {
        my ($u, $q) = ($s[$i], 0);
        $u =~ s/\x5C([\x00-\xFF])/$1/g;
        ($u,$q) = Message::MIME::Charset::decode ($o{charset}, $u);
        $s[$i] = $u if $q;
      }
    }
    $t = join '', @s;  $r = 1;
  } else {
    ($t,$r) = Message::MIME::Charset::decode ($o{charset}, $s);
  }
  $r ? (value => $t, language => $o{language}): ## suceess
  (value => $s, language => $o{language},
   charset => ($o{charset}=~/\*/?'':$o{charset}));      ## fault
}

sub encode_body_string {
  my $yourself = shift; my $s = shift; my %o = @_;
  $o{charset} ||= $yourself->{option}->{encoding_after_encode};
  $o{charset} = Message::MIME::Charset::name_normalize ($o{charset});
  $o{current_charset} = Message::MIME::Charset::name_normalize ($o{current_charset});
  my ($t,%r) = Message::MIME::Charset::encode ($o{charset}, $s);
  my @o = ();
  if ($r{success}) {    ## Convertion successed
    $o{charset} = $r{charset} if $r{charset};
    (value => $t, @o, charset => ($o{charset} =~ /\*/? '': $o{charset}));
  } else {      ## fault
    (value => $s, @o, charset => ($o{current_charset}=~/\*/?'':$o{current_charset}));
  }
}

sub decode_body_string {
  my $yourself = shift; my $s = shift; my %o = @_;
  $o{charset} ||= $yourself->{option}->{encoding_before_decode};
  $o{charset} = Message::MIME::Charset::name_normalize ($o{charset});
  my ($t,$r) = Message::MIME::Charset::decode ($o{charset}, $s);
  $r>0 ? (value => $t): ## suceess
  (value => $s,
   charset => ($o{charset}=~/\*/?'':$o{charset}));      ## fault
}

=item Message::Util::decode_quoted_string ($yourself, $quoted-string)

Returns unquoted and decoded a given C<quoted-string>
or a string containing one or multiple C<quoted-string>s.

=cut

sub decode_quoted_string ($$;%) {
  my $yourself = shift;
  my $quoted_string = shift;
  my %option = @_;
  $option{type} ||= 'phrase';
  $quoted_string =~ s{$REG{M_quoted_string}|([^\x22]+)}{
    my ($qtext, $t) = ($1, $2);
    if (length $t) {
      $t =~ s/$REG{WSP}+/\x20/g;
      my %s = &{$yourself->{option}->{hook_decode_string}}
        ($yourself, $t, type => $option{type},
        charset => $option{charset});
      $s{value};
    } else {
      $qtext =~ s/\x5C([\x00-\xFF])/$1/g;
      my %s = &{$yourself->{option}->{hook_decode_string}}
        ($yourself, $qtext, type => $option{type}.'/quoted',
        charset => $option{charset});
      $s{value};
    }
  }goex;
  $quoted_string;
}

=item Message::Util::encode_qcontent ($yourself, $string)

Encodes (by C<hook_encode_string> of C<$yourself-E<gt>{option}>)
C<qcontent> (content of C<quoted-string>) within C<$string>.

=cut

sub encode_qcontent ($$) {
  my $yourself = shift;
  my $quoted_strings = shift;
  $quoted_strings =~ s{$REG{M_quoted_string}}{
    my ($qtext) = ($1);
      $qtext =~ s/\x5C([\x00-\xFF])/$1/g;
      my %s = &{$yourself->{option}->{hook_encode_string}} ($yourself, $qtext,
                type => 'phrase/quoted');
      $s{value} =~ s/([\x22\x5C])([\x20-\xFF])?/"\x5C$1".($2?"\x5C$2":'')/ge;
      '"'.$s{value}.'"';
  }goex;
  $quoted_strings;
}

=item Message::Util::decode_qcontent ($yourself, $string)

Decodes (by C<hook_decode_string> of C<$yourself-E<gt>{option}>)
C<qcontent> (content of C<quoted-string>) within C<$string>.

=cut

sub decode_qcontent ($$) {
  my $yourself = shift;
  my $quoted_string = shift;
  $quoted_string =~ s{$REG{M_quoted_string}}{
    my ($qtext) = ($1);
      $qtext =~ s/\x5C([\x00-\xFF])/$1/g;
      my %s = &{$yourself->{option}->{hook_decode_string}} ($yourself, $qtext,
                type => 'phrase/quoted');
      $s{value} =~ s/([\x22\x5C])([\x20-\xFF])?/"\x5C$1".($2?"\x5C$2":'')/ge;
      '"'.$s{value}.'"';
  }goex;
  $quoted_string;
}

=item @comments = Message::Util::comment_to_array ($youtself, $comments)

Replaces C<comment>s to C< > (a SP), decodes C<ccontent>s,
and returns them as array.

=cut

sub comment_to_array ($$) {
  my $yourself = shift;
  my $body = shift;
  my @r = ();
  $body =~ s{($REG{quoted_string}|$REG{domain_literal})|$REG{M_comment}}{
    my ($o, $c) = ($1, $2);
    if ($o) {$o}
    else {
      push @r, decode_ccontent ($yourself, $c);
      ' ';
    }
  }gex;
  @r;
}

sub delete_comment_to_array ($$;%) {
  my $yourself = shift;
  my $body = shift;
  my %option = @_;
  my $areg = ''; $areg = '|'.$REG{angle_quoted} if $option{-use_angle_quoted};
  my @r = ();
  $body =~ s{($REG{quoted_string}|$REG{domain_literal}$areg)|$REG{M_comment}}{
    my ($o, $c) = ($1, $2);
    if ($o) {$o}
    else {
      push @r, decode_ccontent ($yourself, $c);
      ' ';
    }
  }gex;
  ($body, @r);
}

=item Message::Util::encode_ccontent ($yourself, $ccontent)

Encodes C<ccontent> (content of C<comment>).

=cut

sub encode_ccontent ($$) {
  my $yourself = shift;
  my $ccontent = shift;
  my %f = &{$yourself->{option}->{hook_encode_string}} ($yourself, 
            $ccontent, type => 'ccontent');
  $f{value} =~ s/([\x28\x29\x5C]|\x3D\x3F)([\x21-\x7E])?/"\x5C$1".(defined $2?"\x5C$2":'')/ge;
  $f{value};
}

=item Message::Util::decode_ccontent ($yourself, $ccontent)

Decodes C<ccontent> (content of C<comment>).

=cut

sub decode_ccontent ($$) {
  Message::MIME::EncodedWord::decode_ccontent (@_);
}


=head1 LICENSE

Copyright 2002 wakaba E<lt>[email protected]<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/06/01 05:40:55 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4	wakaba	1.4	Message::Util -- Utilities for Message::* Perl modules.
5	wakaba	1.1
6			=head1 DESCRIPTION
7
8	wakaba	1.4	Useful functions for Message::* Perl modules.
9			This module is only intended for internal use.
10			But some can be useful for general use.
11	wakaba	1.1
12			=cut
13
14			package Message::Util;
15	wakaba	1.4	require 5.6.0;
16	wakaba	1.1	use strict;
17	wakaba	1.4	use re 'eval';
18	wakaba	1.1	use vars qw(%REG $VERSION);
19	wakaba	1.12	$VERSION=do{my @r=(q$Revision: 1.11 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
20	wakaba	1.1
21	wakaba	1.5	use Carp ();
22	wakaba	1.12	require Message::MIME::EncodedWord;
23			require Message::MIME::Charset;
24	wakaba	1.1
25	wakaba	1.5	=head1 REGEXPS (%Message::Util::REG)
26	wakaba	1.4
27	wakaba	1.5	=head2 Naming Rules
28	wakaba	1.4
29	wakaba	1.5	key = *(prefix) [format] token-name
30
31			prefix = 'M_' ;; With matching "(" ")"s
32			/ 'S_' ;; Simple (not strict) expression
33			/ 'NON_' ;; Negative character class
34			format = E<lt>specification id, such as C<http>E<gt> ;; if necessary
35			token-name = E<lt>BNF name =~ tr/-/_/E<gt>
36
37			=cut
38
39	wakaba	1.6	$REG{MATCH_NONE} = qr/(?!)/;
40			$REG{MATCH_ALL} = qr/[\x00-\xFF]/;
41	wakaba	1.5	## Whitespace
42			$REG{WSP} = qr/[\x09\x20]/;
43	wakaba	1.7	$REG{FWS} = qr/[\x09\x20]*/; ## not same as 2822's
44	wakaba	1.5	## Basic structure
45			$REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]\|(??{$REG{comment}}))*\x29/;
46			$REG{quoted_string} = qr/\x22(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*\x22/;
47			$REG{domain_literal} = qr/\x5B(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x5A\x5E-\xFF])*\x5D/;
48			$REG{angle_quoted} = qr/\x3C[\x09\x20\x21\x23-\x3B\x3D\x3F-\x5B\x5D\x5F\x61-\x7A\x7E]*\x3E/;
49
50			$REG{M_quoted_string} = qr/\x22((?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*)\x22/;
51			$REG{M_comment} = qr/\x28((?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]\|(??{$REG{comment}}))*)\x29/;
52	wakaba	1.7	$REG{M_domain_literal} = qr/\x5B((?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x5A\x5E-\xFF])*)\x5D/;
53	wakaba	1.5
54			=head2 tokens
55
56			atext NON_atext 822.atext
57			atext_dot NON_atext_dot 822.atext / "."
58			NON_atext_dot_wsp 822.atext / "." / WSP
59			http_token NON_http_token http.token
60			NON_http_token_wsp http.token / WSP
61			attribute_char rfc2231.attribute-char
62	wakaba	1.6	NON_http_attribute_char http.token AND rfc2231.attribute-char
63	wakaba	1.5
64			=cut
65
66			$REG{atext} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
67			$REG{atext_dot} = qr/[\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
68	wakaba	1.7	$REG{atext_dot_wsp} = qr/[\x09\x20\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
69			$REG{atext_dot8} = qr/[\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E\x80-\xFF]+/;
70	wakaba	1.6	$REG{token} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]+/;
71	wakaba	1.5	$REG{http_token} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+/;
72			$REG{attribute_char} = qr/[\x21\x23-\x24\x26\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]+/;
73
74	wakaba	1.7	$REG{NON_atext} = qr/[^\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
75			$REG{NON_atext_wsp} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
76	wakaba	1.5	$REG{NON_atext_dot} = qr/[^\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
77			$REG{NON_atext_dot_wsp} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
78	wakaba	1.6	$REG{NON_token} = qr/[^\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]/;
79	wakaba	1.5	$REG{NON_http_token} = qr/[^\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
80			$REG{NON_http_token_wsp} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
81	wakaba	1.6	$REG{NON_attribute_char} = qr/[^\x21\x23-\x24\x26\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]/;
82			$REG{NON_http_attribute_char} = qr/[^\x21\x23-\x24\x26\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
83	wakaba	1.8	$REG{NON_http_attribute_char_wsp} = qr/[^\x09\x20\x21\x23-\x24\x26\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
84	wakaba	1.6	## Yes, C<attribute-char> does not appear in HTTP spec.
85	wakaba	1.5
86			$REG{dot_atom} = qr/$REG{atext}(?:$REG{FWS}\x2E$REG{FWS}$REG{atext})*/;
87	wakaba	1.7	$REG{dot_atom_dot} = qr/$REG{atext_dot}(?:$REG{FWS}\x2E$REG{FWS}$REG{atext_dot})*/;
88	wakaba	1.5	$REG{dot_word} = qr/(?:$REG{atext}\|$REG{quoted_string})(?:$REG{FWS}\x2E$REG{FWS}(?:$REG{atext}\|$REG{quoted_string}))*/;
89	wakaba	1.7	$REG{dot_word_dot} = qr/(?:$REG{atext_dot}\|$REG{quoted_string})(?:$REG{FWS}\x2E$REG{FWS}(?:$REG{atext_dot}\|$REG{quoted_string}))*/;
90	wakaba	1.5	$REG{phrase} = qr/(?:$REG{atext}\|$REG{quoted_string})(?:$REG{atext}\|$REG{quoted_string}\|\.\|$REG{FWS})*/;
91			## RFC 822 phrase (not strict)
92
93	wakaba	1.7	#$REG{domain} = qr/(?:$REG{dot_atom}\|$REG{domain_literal})/;
94			$REG{domain} = qr/(?:$REG{dot_atom_dot}\|$REG{domain_literal})/;
95			#$REG{addr_spec} = qr/$REG{dot_word}$REG{FWS}\x40$REG{FWS}$REG{domain}/;
96			$REG{addr_spec} = qr/$REG{dot_word_dot}$REG{FWS}\x40$REG{FWS}$REG{domain}/;
97			$REG{msg_id} = qr/<$REG{FWS}$REG{addr_spec}$REG{FWS}>/;
98
99			$REG{M_addr_spec} = qr/($REG{dot_word_dot})$REG{FWS}\x40$REG{FWS}($REG{domain})/;
100
101			$REG{date_time} = qr/(?:[A-Za-z]+$REG{FWS},$REG{FWS})?[0-9]+$REG{WSP}[A-Za-z]+$REG{WSP}[0-9]+$REG{WSP}+[0-9]+$REG{FWS}:$REG{WSP}[0-9]+(?:$REG{FWS}:$REG{WSP}[0-9]+)?$REG{FWS}(?:[A-Za-z]+\|[+-]$REG{WSP}*[0-9]+)/;
102			$REG{asctime} = qr/[A-Za-z]+$REG{WSP}[A-Za-z]+$REG{WSP}[0-9]+$REG{WSP}+[0-9]+$REG{FWS}:$REG{WSP}[0-9]+$REG{FWS}:$REG{WSP}[0-9]+$REG{WSP}+[0-9]+/;
103
104	wakaba	1.5	## MIME encoded-word
105			$REG{M_encoded_word} = qr/=\x3F($REG{attribute_char})(?:\x2A($REG{attribute_char}))?\x3F($REG{attribute_char})\x3F([\x21-\x3E\x40-\x7E]+)\x3F=/;
106			$REG{S_encoded_word} = qr/=\x3F$REG{atext_dot}\x3F=/;
107			#$REG{S_encoded_word_comment} = qr/=\x3F[\x21-\x27\x2A-\x5B\x5D-\x7E]+\x3F=/;
108			## not used anywhere
109	wakaba	1.4
110			=head1 STRUCTURED FIELD FUNCTIONS
111
112			=over 4
113
114	wakaba	1.5	=item $nocomment:-) = Message::Util::delete_comment ($string)
115	wakaba	1.4
116			Gets rid of all C<comment>s. Inserts a SP instead.
117
118			=cut
119
120			sub delete_comment ($) {
121			my $body = shift;
122	wakaba	1.5	$body =~ s{($REG{quoted_string}\|$REG{domain_literal}\|$REG{angle_quoted})\|$REG{comment}}{
123	wakaba	1.4	my $o = $1; $o? $o : ' ';
124			}gex;
125			$body;
126			}
127
128	wakaba	1.7	sub delete_wsp ($) {
129			my $body = shift;
130			$body =~ s{($REG{quoted_string}\|$REG{domain_literal})\|((?:$REG{token}\|$REG{S_encoded_word})(?:$REG{WSP}+(?:$REG{token}\|$REG{S_encoded_word}))+)\|$REG{WSP}+}{
131			my ($o,$p) = ($1,$2);
132			if ($o) {$o}
133			elsif ($p) {$p=~s/$REG{WSP}+/\x20/g;$p}
134			else {''}
135			}gex;
136			$body;
137			}
138
139			sub remove_meaningless_wsp ($) {
140			my $body = shift;
141			$body =~ s{($REG{quoted_string}\|$REG{domain_literal})\|$REG{WSP}+}{
142			$1 \|\| '';
143			}gex;
144			$body;
145			}
146
147	wakaba	1.8	sub wsps_to_sp ($) {
148			my $body = shift;
149			$body =~ s{($REG{quoted_string}\|$REG{domain_literal})\|$REG{WSP}+}{
150			$1 \|\| ' ';
151			}gex;
152			$body;
153			}
154
155	wakaba	1.5	=item $unquoted = Message::Util::unquote_ccontent ($string)
156	wakaba	1.4
157			Unquotes C<quoted-pair> in C<comment>s.
158
159			=cut
160
161			sub unquote_ccontent ($) {
162			my $comment = shift;
163			$comment =~ s{$REG{M_comment}}{
164			my $ctext = $1;
165			$ctext =~ s/\x5C([\x00-\xFF])/$1/g;
166			'('.$ctext.')';
167			}goex;
168			$comment;
169			}
170
171	wakaba	1.5	=item $unquoted = Message::Util::unquote_quoted_string ($string)
172	wakaba	1.4
173			Unquotes C<quoted-pair> in C<quoted-string>s and
174			unquotes C<quoted-string> (or gets rid of C<DQUOTE>s).
175
176			=cut
177
178			sub unquote_quoted_string ($) {
179			my $quoted_string = shift;
180			$quoted_string =~ s{$REG{M_quoted_string}}{
181			my $qtext = $1;
182			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
183			$qtext;
184			}goex;
185			$quoted_string;
186			}
187
188	wakaba	1.5	=item Message::Util::unquote_if_quoted_string ($string)
189
190			Unquotes if and only if given string is A C<quoted-string>.
191			This function returns two value, (C<$unquoted-string>,
192			C<$was-quoted-string?>).
193
194			=cut
195
196			sub unquote_if_quoted_string ($) {
197			my $quoted_string = shift; my $isq = 0;
198			$quoted_string =~ s{^$REG{M_quoted_string}$}{
199			my $qtext = $1;
200			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
201			$isq = 1;
202			$qtext;
203			}goex;
204			wantarray? ($quoted_string, $isq): $quoted_string;
205			}
206
207	wakaba	1.7	sub unquote_if_domain_literal ($) {
208			my $quoted_string = shift; my $isq = 0;
209			$quoted_string =~ s{^$REG{M_domain_literal}$}{
210			my $qtext = $1;
211			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
212			$isq = 1;
213			$qtext;
214			}goex;
215			wantarray? ($quoted_string, $isq): $quoted_string;
216			}
217
218	wakaba	1.5	=item $quoted = Message::Util::quote_unsafe_string ($string)
219	wakaba	1.4
220			Quotes string itself by C<DQUOTES> if it contains of
221			I<unsafe> character.
222
223			Default I<unsafe> is defined as E<lt>not ( atom / "." / %x09 / %x20 ) E<gt>.
224
225			=cut
226
227	wakaba	1.5	sub quote_unsafe_string ($;%) {
228	wakaba	1.4	my $string = shift;
229	wakaba	1.5	my %option = @_;
230			$option{unsafe} \|\|= 'NON_atext_dot';
231	wakaba	1.6	$option{unsafe_regex} = $option{unsafe} if $option{unsafe} =~ /^\(\?-xism:/;
232	wakaba	1.7	$option{unsafe_regex} \|\|= qr/$REG{$option{unsafe}}\|$REG{WSP}$REG{WSP}\|^$REG{WSP}\|$REG{WSP}$/;
233			my $r = qr/([\x22\x5C])([\x21-\x7E])?/;
234			$r = qr/([\x22\x5C])/ if $option{strict}; ## usefor-article
235	wakaba	1.6	if ($string =~ /$option{unsafe_regex}/) {
236	wakaba	1.7	$string =~ s/$r/"\x5C$1".(defined $2?"\x5C$2":'')/ge;
237	wakaba	1.4	$string = '"'.$string.'"';
238			}
239			$string;
240			}
241
242	wakaba	1.7	sub quote_unsafe_domain ($) {
243			my $string = shift;
244			if ($string =~ /^\[[^\[\]]+\]$/) {
245			#
246			} elsif ($string =~ /$REG{NON_atext_dot}/ \|\| $string =~ /^\.\|\.$/) {
247			$string =~ s/([\x5B-\x5D])/\x5C$1/g;
248			$string = '['.$string.']';
249			}
250			$string;
251			}
252
253			sub remove_wsp ($) {
254			my $s = shift;
255			$s =~ s{($REG{quoted_string}\|$REG{domain_literal}\|$REG{angle_quoted})\|$REG{WSP}+}{
256			$1
257			}gex;
258			$s;
259			}
260
261	wakaba	1.5	=item $Message::Util::make_clone ($parent)
262
263			Returns clone.
264
265			=cut
266
267			sub make_clone ($) {
268			my $s = shift;
269	wakaba	1.7	if (ref $s eq 'ARRAY') {
270			$s = [map {make_clone ($_)} @$s];
271			} elsif (ref $s eq 'HASH') {
272			$s = {map {make_clone ($_)} (%$s)};
273	wakaba	1.9	} elsif (ref $s && ref $s ne 'CODE' && ref $s ne 'Regexp') {
274	wakaba	1.5	$s = $s->clone;
275			}
276			$s;
277			}
278
279	wakaba	1.4	=head1 ENCODER and DECODER
280
281			=over 4
282
283			=item Message::Util::encode_header_string ($yourself, $string, [%options])
284
285			=cut
286
287	wakaba	1.2	sub encode_header_string ($$;%) {
288	wakaba	1.3	my $yourself = shift; my $s = shift; my %o = @_;
289			$o{charset} \|\|= $yourself->{option}->{encoding_after_encode};
290	wakaba	1.1	$o{charset} = Message::MIME::Charset::name_normalize ($o{charset});
291			$o{current_charset} = Message::MIME::Charset::name_normalize ($o{current_charset});
292	wakaba	1.11	my ($t,%r) = Message::MIME::Charset::encode ($o{charset}, $s);
293	wakaba	1.1	my @o = (language => $o{language});
294	wakaba	1.12	if ($r{success}) { ## Convertion succeed
295	wakaba	1.11	$o{charset} = $r{charset} if $r{charset};
296	wakaba	1.1	(value => $t, @o, charset => ($o{charset}=~/\*/?'':$o{charset}));
297			} else { ## Fault
298			(value => $s, @o, charset => ($o{current_charset}=~/\*/?'':$o{current_charset}));
299			}
300			}
301
302	wakaba	1.2	sub decode_header_string ($$;%) {
303	wakaba	1.3	my $yourself = shift; my $s = shift; my %o = @_;
304			$o{charset} \|\|= $yourself->{option}->{encoding_before_decode};
305	wakaba	1.1	$o{charset} = Message::MIME::Charset::name_normalize ($o{charset});
306	wakaba	1.5	my ($t, $r); ## decoded-text, success?
307	wakaba	1.7	if ($o{type} !~ /quoted\|encoded\|domain\|word/) {
308	wakaba	1.5	my (@s, @r);
309	wakaba	1.8	$s =~ s{\G($REG{FWS}(?:\x5C[\x00-\xFF]
310			\|[\x00-\x08\x0A-\x0C\x0E\x0F\x21-\x5B\x5D-\xFF])+\|$REG{WSP}+$)}
311			{ push @s, $& }goex;
312	wakaba	1.5	for my $i (0..$#s) {
313			if ($s[$i] =~ /^($REG{FWS})$REG{M_encoded_word}$/) {
314			my ($t, $w) = ('', $1);
315			($t, $r[$i]) = (Message::MIME::EncodedWord::_decode_eword ($2, $3, $4, $5));
316			if ($r[$i]) {
317			$s[$i] = $t;
318			if ($i == 0 \|\| $r[$i-1] == 0) {
319			$s[$i] = $w.$s[$i];
320			}
321			}
322			} else {
323			my ($u, $q) = ($s[$i], 0);
324			$u =~ s/\x5C([\x00-\xFF])/$1/g;
325			($u,$q) = Message::MIME::Charset::decode ($o{charset}, $u);
326			$s[$i] = $u if $q;
327			}
328			}
329			$t = join '', @s; $r = 1;
330			} else {
331			($t,$r) = Message::MIME::Charset::decode ($o{charset}, $s);
332			}
333			$r ? (value => $t, language => $o{language}): ## suceess
334	wakaba	1.1	(value => $s, language => $o{language},
335			charset => ($o{charset}=~/\*/?'':$o{charset})); ## fault
336			}
337
338			sub encode_body_string {
339	wakaba	1.3	my $yourself = shift; my $s = shift; my %o = @_;
340			$o{charset} \|\|= $yourself->{option}->{encoding_after_encode};
341	wakaba	1.1	$o{charset} = Message::MIME::Charset::name_normalize ($o{charset});
342			$o{current_charset} = Message::MIME::Charset::name_normalize ($o{current_charset});
343	wakaba	1.11	my ($t,%r) = Message::MIME::Charset::encode ($o{charset}, $s);
344	wakaba	1.1	my @o = ();
345	wakaba	1.11	if ($r{success}) { ## Convertion successed
346			$o{charset} = $r{charset} if $r{charset};
347			(value => $t, @o, charset => ($o{charset} =~ /\*/? '': $o{charset}));
348			} else { ## fault
349	wakaba	1.1	(value => $s, @o, charset => ($o{current_charset}=~/\*/?'':$o{current_charset}));
350			}
351			}
352
353			sub decode_body_string {
354	wakaba	1.3	my $yourself = shift; my $s = shift; my %o = @_;
355			$o{charset} \|\|= $yourself->{option}->{encoding_before_decode};
356	wakaba	1.1	$o{charset} = Message::MIME::Charset::name_normalize ($o{charset});
357			my ($t,$r) = Message::MIME::Charset::decode ($o{charset}, $s);
358			$r>0 ? (value => $t): ## suceess
359			(value => $s,
360			charset => ($o{charset}=~/\*/?'':$o{charset})); ## fault
361			}
362
363	wakaba	1.5	=item Message::Util::decode_quoted_string ($yourself, $quoted-string)
364
365			Returns unquoted and decoded a given C<quoted-string>
366			or a string containing one or multiple C<quoted-string>s.
367
368			=cut
369
370	wakaba	1.7	sub decode_quoted_string ($$;%) {
371	wakaba	1.5	my $yourself = shift;
372			my $quoted_string = shift;
373	wakaba	1.7	my %option = @_;
374			$option{type} \|\|= 'phrase';
375	wakaba	1.5	$quoted_string =~ s{$REG{M_quoted_string}\|([^\x22]+)}{
376			my ($qtext, $t) = ($1, $2);
377			if (length $t) {
378	wakaba	1.8	$t =~ s/$REG{WSP}+/\x20/g;
379	wakaba	1.5	my %s = &{$yourself->{option}->{hook_decode_string}}
380	wakaba	1.7	($yourself, $t, type => $option{type},
381			charset => $option{charset});
382	wakaba	1.5	$s{value};
383			} else {
384			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
385			my %s = &{$yourself->{option}->{hook_decode_string}}
386	wakaba	1.7	($yourself, $qtext, type => $option{type}.'/quoted',
387			charset => $option{charset});
388	wakaba	1.5	$s{value};
389			}
390			}goex;
391			$quoted_string;
392			}
393
394	wakaba	1.4	=item Message::Util::encode_qcontent ($yourself, $string)
395
396			Encodes (by C<hook_encode_string> of C<$yourself-E<gt>{option}>)
397			C<qcontent> (content of C<quoted-string>) within C<$string>.
398
399			=cut
400
401			sub encode_qcontent ($$) {
402			my $yourself = shift;
403			my $quoted_strings = shift;
404			$quoted_strings =~ s{$REG{M_quoted_string}}{
405			my ($qtext) = ($1);
406			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
407			my %s = &{$yourself->{option}->{hook_encode_string}} ($yourself, $qtext,
408			type => 'phrase/quoted');
409			$s{value} =~ s/([\x22\x5C])([\x20-\xFF])?/"\x5C$1".($2?"\x5C$2":'')/ge;
410			'"'.$s{value}.'"';
411			}goex;
412			$quoted_strings;
413			}
414
415			=item Message::Util::decode_qcontent ($yourself, $string)
416
417			Decodes (by C<hook_decode_string> of C<$yourself-E<gt>{option}>)
418			C<qcontent> (content of C<quoted-string>) within C<$string>.
419
420			=cut
421
422			sub decode_qcontent ($$) {
423			my $yourself = shift;
424			my $quoted_string = shift;
425			$quoted_string =~ s{$REG{M_quoted_string}}{
426			my ($qtext) = ($1);
427			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
428			my %s = &{$yourself->{option}->{hook_decode_string}} ($yourself, $qtext,
429			type => 'phrase/quoted');
430			$s{value} =~ s/([\x22\x5C])([\x20-\xFF])?/"\x5C$1".($2?"\x5C$2":'')/ge;
431			'"'.$s{value}.'"';
432			}goex;
433			$quoted_string;
434			}
435
436			=item @comments = Message::Util::comment_to_array ($youtself, $comments)
437
438			Replaces C<comment>s to C< > (a SP), decodes C<ccontent>s,
439			and returns them as array.
440
441			=cut
442
443			sub comment_to_array ($$) {
444			my $yourself = shift;
445			my $body = shift;
446			my @r = ();
447			$body =~ s{($REG{quoted_string}\|$REG{domain_literal})\|$REG{M_comment}}{
448			my ($o, $c) = ($1, $2);
449			if ($o) {$o}
450			else {
451			push @r, decode_ccontent ($yourself, $c);
452			' ';
453			}
454			}gex;
455			@r;
456			}
457
458	wakaba	1.8	sub delete_comment_to_array ($$;%) {
459	wakaba	1.7	my $yourself = shift;
460			my $body = shift;
461	wakaba	1.8	my %option = @_;
462			my $areg = ''; $areg = '\|'.$REG{angle_quoted} if $option{-use_angle_quoted};
463	wakaba	1.7	my @r = ();
464	wakaba	1.8	$body =~ s{($REG{quoted_string}\|$REG{domain_literal}$areg)\|$REG{M_comment}}{
465	wakaba	1.7	my ($o, $c) = ($1, $2);
466			if ($o) {$o}
467			else {
468			push @r, decode_ccontent ($yourself, $c);
469			' ';
470			}
471			}gex;
472			($body, @r);
473			}
474
475	wakaba	1.4	=item Message::Util::encode_ccontent ($yourself, $ccontent)
476
477			Encodes C<ccontent> (content of C<comment>).
478
479			=cut
480
481			sub encode_ccontent ($$) {
482			my $yourself = shift;
483			my $ccontent = shift;
484			my %f = &{$yourself->{option}->{hook_encode_string}} ($yourself,
485			$ccontent, type => 'ccontent');
486	wakaba	1.9	$f{value} =~ s/([\x28\x29\x5C]\|\x3D\x3F)([\x21-\x7E])?/"\x5C$1".(defined $2?"\x5C$2":'')/ge;
487	wakaba	1.4	$f{value};
488			}
489
490			=item Message::Util::decode_ccontent ($yourself, $ccontent)
491
492			Decodes C<ccontent> (content of C<comment>).
493
494			=cut
495
496			sub decode_ccontent ($$) {
497	wakaba	1.12	Message::MIME::EncodedWord::decode_ccontent (@_);
498	wakaba	1.4	}
499
500	wakaba	1.10
501	wakaba	1.1	=head1 LICENSE
502
503			Copyright 2002 wakaba E<lt>[email protected]<gt>.
504
505			This program is free software; you can redistribute it and/or modify
506			it under the terms of the GNU General Public License as published by
507			the Free Software Foundation; either version 2 of the License, or
508			(at your option) any later version.
509
510			This program is distributed in the hope that it will be useful,
511			but WITHOUT ANY WARRANTY; without even the implied warranty of
512			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
513			GNU General Public License for more details.
514
515			You should have received a copy of the GNU General Public License
516			along with this program; see the file COPYING. If not, write to
517			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
518			Boston, MA 02111-1307, USA.
519
520			=head1 CHANGE
521
522			See F<ChangeLog>.
523	wakaba	1.12	$Date: 2002/06/01 05:40:55 $
524	wakaba	1.1
525			=cut
526
527			1;