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.8 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

use Carp ();

=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 ($$;%) {
  require Message::MIME::Charset;
  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>0) {   ## Convertion successed
    (value => $t, @o, charset => ($o{charset}=~/\*/?'':$o{charset}));
  } else {      ## Fault
    (value => $s, @o, charset => ($o{current_charset}=~/\*/?'':$o{current_charset}));
  }
}

sub decode_header_string ($$;%) {
  require Message::MIME::EncodedWord;
  require Message::MIME::Charset;
  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 {
  require Message::MIME::Charset;
  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>0) {   ## Convertion successed
    (value => $t, @o, charset => ($o{charset}=~/\*/?'':$o{charset}));
  } else {      ## Fault
    (value => $s, @o, charset => ($o{current_charset}=~/\*/?'':$o{current_charset}));
  }
}

sub decode_body_string {
  require Message::MIME::Charset;
  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 ($$) {
  require Message::MIME::EncodedWord;
  &Message::MIME::EncodedWord::decode_ccontent (@_[1,0]);
}

=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/05/17 05:46:25 $

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