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.4 $=~/\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

## Whitespace
        $REG{WSP} = qr/[\x09\x20]/;
        $REG{FWS} = qr/[\x09\x20]*/;
## 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/;

=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

=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{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/[^\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_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{dot_atom} = qr/$REG{atext}(?:$REG{FWS}\x2E$REG{FWS}$REG{atext})*/;
        $REG{dot_word} = qr/(?:$REG{atext}|$REG{quoted_string})(?:$REG{FWS}\x2E$REG{FWS}(?:$REG{atext}|$REG{quoted_string}))*/;
        $REG{phrase} = qr/(?:$REG{atext}|$REG{quoted_string})(?:$REG{atext}|$REG{quoted_string}|\.|$REG{FWS})*/;
                ## RFC 822 phrase (not strict)

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

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

=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';
  if ($string =~ /$REG{$option{unsafe}}/ || $string =~ /$REG{WSP}$REG{WSP}+/) {
    $string =~ s/([\x22\x5C])([\x21-\x7E])?/"\x5C$1".(defined $2?"\x5C$2":'')/ge;
    $string = '"'.$string.'"';
  }
  $string;
}

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

Returns clone.

=cut

sub make_clone ($) {
  my $s = shift;
  if (ref $s eq 'ARRAY' || ref $s eq 'HASH') {
    $s = map {make_clone ($_)} @$s;
  } elsif (ref $s) {
    $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/ && $o{type} !~ /encoded/) {
    my (@s, @r);
    $s =~ s{\G(?:($REG{FWS}(?:\x5C[\x00-\xFF]
      |[\x00-\x08\x0A-\x0C\x0E\x0F\x21-\x5B\x5D-\xFF])+))}
      { push @s, $1 || $2 }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::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) = 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;
  $quoted_string =~ s{$REG{M_quoted_string}|([^\x22]+)}{
    my ($qtext, $t) = ($1, $2);
    if (length $t) {
      my %s = &{$yourself->{option}->{hook_decode_string}}
        ($yourself, $t, type => 'phrase');
      $s{value};
    } else {
      $qtext =~ s/\x5C([\x00-\xFF])/$1/g;
      my %s = &{$yourself->{option}->{hook_decode_string}}
        ($yourself, $qtext, type => 'phrase/quoted');
      $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;
}

=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])([\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/04/05 14:56:26 $

=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.5	$VERSION=do{my @r=(q$Revision: 1.4 $=~/\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			## Whitespace
38			$REG{WSP} = qr/[\x09\x20]/;
39			$REG{FWS} = qr/[\x09\x20]*/;
40			## Basic structure
41			$REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]\|(??{$REG{comment}}))*\x29/;
42			$REG{quoted_string} = qr/\x22(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*\x22/;
43			$REG{domain_literal} = qr/\x5B(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x5A\x5E-\xFF])*\x5D/;
44			$REG{angle_quoted} = qr/\x3C[\x09\x20\x21\x23-\x3B\x3D\x3F-\x5B\x5D\x5F\x61-\x7A\x7E]*\x3E/;
45
46			$REG{M_quoted_string} = qr/\x22((?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x21\x23-\x5B\x5D-\xFF])*)\x22/;
47			$REG{M_comment} = qr/\x28((?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]\|(??{$REG{comment}}))*)\x29/;
48
49			=head2 tokens
50
51			atext NON_atext 822.atext
52			atext_dot NON_atext_dot 822.atext / "."
53			NON_atext_dot_wsp 822.atext / "." / WSP
54			http_token NON_http_token http.token
55			NON_http_token_wsp http.token / WSP
56			attribute_char rfc2231.attribute-char
57
58			=cut
59
60			$REG{atext} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
61			$REG{atext_dot} = qr/[\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]+/;
62			$REG{http_token} = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+/;
63			$REG{attribute_char} = qr/[\x21\x23-\x24\x26\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7E]+/;
64
65			$REG{NON_atext} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D\x2F\x30-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
66			$REG{NON_atext_dot} = qr/[^\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
67			$REG{NON_atext_dot_wsp} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D-\x39\x3D\x3F\x41-\x5A\x5E-\x7E]/;
68			$REG{NON_http_token} = qr/[^\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
69			$REG{NON_http_token_wsp} = qr/[^\x09\x20\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
70
71			$REG{dot_atom} = qr/$REG{atext}(?:$REG{FWS}\x2E$REG{FWS}$REG{atext})*/;
72			$REG{dot_word} = qr/(?:$REG{atext}\|$REG{quoted_string})(?:$REG{FWS}\x2E$REG{FWS}(?:$REG{atext}\|$REG{quoted_string}))*/;
73			$REG{phrase} = qr/(?:$REG{atext}\|$REG{quoted_string})(?:$REG{atext}\|$REG{quoted_string}\|\.\|$REG{FWS})*/;
74			## RFC 822 phrase (not strict)
75
76			## MIME encoded-word
77			$REG{M_encoded_word} = qr/=\x3F($REG{attribute_char})(?:\x2A($REG{attribute_char}))?\x3F($REG{attribute_char})\x3F([\x21-\x3E\x40-\x7E]+)\x3F=/;
78			$REG{S_encoded_word} = qr/=\x3F$REG{atext_dot}\x3F=/;
79			#$REG{S_encoded_word_comment} = qr/=\x3F[\x21-\x27\x2A-\x5B\x5D-\x7E]+\x3F=/;
80			## not used anywhere
81	wakaba	1.4
82			=head1 STRUCTURED FIELD FUNCTIONS
83
84			=over 4
85
86	wakaba	1.5	=item $nocomment:-) = Message::Util::delete_comment ($string)
87	wakaba	1.4
88			Gets rid of all C<comment>s. Inserts a SP instead.
89
90			=cut
91
92			sub delete_comment ($) {
93			my $body = shift;
94	wakaba	1.5	$body =~ s{($REG{quoted_string}\|$REG{domain_literal}\|$REG{angle_quoted})\|$REG{comment}}{
95	wakaba	1.4	my $o = $1; $o? $o : ' ';
96			}gex;
97			$body;
98			}
99
100	wakaba	1.5	=item $unquoted = Message::Util::unquote_ccontent ($string)
101	wakaba	1.4
102			Unquotes C<quoted-pair> in C<comment>s.
103
104			=cut
105
106			sub unquote_ccontent ($) {
107			my $comment = shift;
108			$comment =~ s{$REG{M_comment}}{
109			my $ctext = $1;
110			$ctext =~ s/\x5C([\x00-\xFF])/$1/g;
111			'('.$ctext.')';
112			}goex;
113			$comment;
114			}
115
116	wakaba	1.5	=item $unquoted = Message::Util::unquote_quoted_string ($string)
117	wakaba	1.4
118			Unquotes C<quoted-pair> in C<quoted-string>s and
119			unquotes C<quoted-string> (or gets rid of C<DQUOTE>s).
120
121			=cut
122
123			sub unquote_quoted_string ($) {
124			my $quoted_string = shift;
125			$quoted_string =~ s{$REG{M_quoted_string}}{
126			my $qtext = $1;
127			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
128			$qtext;
129			}goex;
130			$quoted_string;
131			}
132
133	wakaba	1.5	=item Message::Util::unquote_if_quoted_string ($string)
134
135			Unquotes if and only if given string is A C<quoted-string>.
136			This function returns two value, (C<$unquoted-string>,
137			C<$was-quoted-string?>).
138
139			=cut
140
141			sub unquote_if_quoted_string ($) {
142			my $quoted_string = shift; my $isq = 0;
143			$quoted_string =~ s{^$REG{M_quoted_string}$}{
144			my $qtext = $1;
145			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
146			$isq = 1;
147			$qtext;
148			}goex;
149			wantarray? ($quoted_string, $isq): $quoted_string;
150			}
151
152			=item $quoted = Message::Util::quote_unsafe_string ($string)
153	wakaba	1.4
154			Quotes string itself by C<DQUOTES> if it contains of
155			I<unsafe> character.
156
157			Default I<unsafe> is defined as E<lt>not ( atom / "." / %x09 / %x20 ) E<gt>.
158
159			=cut
160
161	wakaba	1.5	sub quote_unsafe_string ($;%) {
162	wakaba	1.4	my $string = shift;
163	wakaba	1.5	my %option = @_;
164			$option{unsafe} \|\|= 'NON_atext_dot';
165			if ($string =~ /$REG{$option{unsafe}}/ \|\| $string =~ /$REG{WSP}$REG{WSP}+/) {
166			$string =~ s/([\x22\x5C])([\x21-\x7E])?/"\x5C$1".(defined $2?"\x5C$2":'')/ge;
167	wakaba	1.4	$string = '"'.$string.'"';
168			}
169			$string;
170			}
171
172	wakaba	1.5	=item $Message::Util::make_clone ($parent)
173
174			Returns clone.
175
176			=cut
177
178			sub make_clone ($) {
179			my $s = shift;
180			if (ref $s eq 'ARRAY' \|\| ref $s eq 'HASH') {
181			$s = map {make_clone ($_)} @$s;
182			} elsif (ref $s) {
183			$s = $s->clone;
184			}
185			$s;
186			}
187
188	wakaba	1.4	=head1 ENCODER and DECODER
189
190			=over 4
191
192			=item Message::Util::encode_header_string ($yourself, $string, [%options])
193
194			=cut
195
196	wakaba	1.2	sub encode_header_string ($$;%) {
197	wakaba	1.1	require Message::MIME::Charset;
198	wakaba	1.3	my $yourself = shift; my $s = shift; my %o = @_;
199			$o{charset} \|\|= $yourself->{option}->{encoding_after_encode};
200	wakaba	1.1	$o{charset} = Message::MIME::Charset::name_normalize ($o{charset});
201			$o{current_charset} = Message::MIME::Charset::name_normalize ($o{current_charset});
202			my ($t,$r) = Message::MIME::Charset::encode ($o{charset}, $s);
203			my @o = (language => $o{language});
204			if ($r>0) { ## Convertion successed
205			(value => $t, @o, charset => ($o{charset}=~/\*/?'':$o{charset}));
206			} else { ## Fault
207			(value => $s, @o, charset => ($o{current_charset}=~/\*/?'':$o{current_charset}));
208			}
209			}
210
211	wakaba	1.2	sub decode_header_string ($$;%) {
212	wakaba	1.1	require Message::MIME::EncodedWord;
213			require Message::MIME::Charset;
214	wakaba	1.3	my $yourself = shift; my $s = shift; my %o = @_;
215			$o{charset} \|\|= $yourself->{option}->{encoding_before_decode};
216	wakaba	1.1	$o{charset} = Message::MIME::Charset::name_normalize ($o{charset});
217	wakaba	1.5	my ($t, $r); ## decoded-text, success?
218			if ($o{type} !~ /quoted/ && $o{type} !~ /encoded/) {
219			my (@s, @r);
220			$s =~ s{\G(?:($REG{FWS}(?:\x5C[\x00-\xFF]
221			\|[\x00-\x08\x0A-\x0C\x0E\x0F\x21-\x5B\x5D-\xFF])+))}
222			{ push @s, $1 \|\| $2 }goex;
223			for my $i (0..$#s) {
224			if ($s[$i] =~ /^($REG{FWS})$REG{M_encoded_word}$/) {
225			my ($t, $w) = ('', $1);
226			($t, $r[$i]) = (Message::MIME::EncodedWord::_decode_eword ($2, $3, $4, $5));
227			if ($r[$i]) {
228			$s[$i] = $t;
229			if ($i == 0 \|\| $r[$i-1] == 0) {
230			$s[$i] = $w.$s[$i];
231			}
232			}
233			} else {
234			my ($u, $q) = ($s[$i], 0);
235			$u =~ s/\x5C([\x00-\xFF])/$1/g;
236			($u,$q) = Message::MIME::Charset::decode ($o{charset}, $u);
237			$s[$i] = $u if $q;
238			}
239			}
240			$t = join '', @s; $r = 1;
241			} else {
242			($t,$r) = Message::MIME::Charset::decode ($o{charset}, $s);
243			}
244			$r ? (value => $t, language => $o{language}): ## suceess
245	wakaba	1.1	(value => $s, language => $o{language},
246			charset => ($o{charset}=~/\*/?'':$o{charset})); ## fault
247			}
248
249			sub encode_body_string {
250			require Message::MIME::Charset;
251	wakaba	1.3	my $yourself = shift; my $s = shift; my %o = @_;
252			$o{charset} \|\|= $yourself->{option}->{encoding_after_encode};
253	wakaba	1.1	$o{charset} = Message::MIME::Charset::name_normalize ($o{charset});
254			$o{current_charset} = Message::MIME::Charset::name_normalize ($o{current_charset});
255			my ($t,$r) = Message::MIME::Charset::encode ($o{charset}, $s);
256			my @o = ();
257			if ($r>0) { ## Convertion successed
258			(value => $t, @o, charset => ($o{charset}=~/\*/?'':$o{charset}));
259			} else { ## Fault
260			(value => $s, @o, charset => ($o{current_charset}=~/\*/?'':$o{current_charset}));
261			}
262			}
263
264			sub decode_body_string {
265			require Message::MIME::EncodedWord;
266			require Message::MIME::Charset;
267	wakaba	1.3	my $yourself = shift; my $s = shift; my %o = @_;
268			$o{charset} \|\|= $yourself->{option}->{encoding_before_decode};
269	wakaba	1.1	$o{charset} = Message::MIME::Charset::name_normalize ($o{charset});
270			my ($t,$r) = Message::MIME::Charset::decode ($o{charset}, $s);
271			$r>0 ? (value => $t): ## suceess
272			(value => $s,
273			charset => ($o{charset}=~/\*/?'':$o{charset})); ## fault
274			}
275
276	wakaba	1.5	=item Message::Util::decode_quoted_string ($yourself, $quoted-string)
277
278			Returns unquoted and decoded a given C<quoted-string>
279			or a string containing one or multiple C<quoted-string>s.
280
281			=cut
282
283			sub decode_quoted_string ($$) {
284			my $yourself = shift;
285			my $quoted_string = shift;
286			$quoted_string =~ s{$REG{M_quoted_string}\|([^\x22]+)}{
287			my ($qtext, $t) = ($1, $2);
288			if (length $t) {
289			my %s = &{$yourself->{option}->{hook_decode_string}}
290			($yourself, $t, type => 'phrase');
291			$s{value};
292			} else {
293			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
294			my %s = &{$yourself->{option}->{hook_decode_string}}
295			($yourself, $qtext, type => 'phrase/quoted');
296			$s{value};
297			}
298			}goex;
299			$quoted_string;
300			}
301
302	wakaba	1.4	=item Message::Util::encode_qcontent ($yourself, $string)
303
304			Encodes (by C<hook_encode_string> of C<$yourself-E<gt>{option}>)
305			C<qcontent> (content of C<quoted-string>) within C<$string>.
306
307			=cut
308
309			sub encode_qcontent ($$) {
310			my $yourself = shift;
311			my $quoted_strings = shift;
312			$quoted_strings =~ s{$REG{M_quoted_string}}{
313			my ($qtext) = ($1);
314			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
315			my %s = &{$yourself->{option}->{hook_encode_string}} ($yourself, $qtext,
316			type => 'phrase/quoted');
317			$s{value} =~ s/([\x22\x5C])([\x20-\xFF])?/"\x5C$1".($2?"\x5C$2":'')/ge;
318			'"'.$s{value}.'"';
319			}goex;
320			$quoted_strings;
321			}
322
323			=item Message::Util::decode_qcontent ($yourself, $string)
324
325			Decodes (by C<hook_decode_string> of C<$yourself-E<gt>{option}>)
326			C<qcontent> (content of C<quoted-string>) within C<$string>.
327
328			=cut
329
330			sub decode_qcontent ($$) {
331			my $yourself = shift;
332			my $quoted_string = shift;
333			$quoted_string =~ s{$REG{M_quoted_string}}{
334			my ($qtext) = ($1);
335			$qtext =~ s/\x5C([\x00-\xFF])/$1/g;
336			my %s = &{$yourself->{option}->{hook_decode_string}} ($yourself, $qtext,
337			type => 'phrase/quoted');
338			$s{value} =~ s/([\x22\x5C])([\x20-\xFF])?/"\x5C$1".($2?"\x5C$2":'')/ge;
339			'"'.$s{value}.'"';
340			}goex;
341			$quoted_string;
342			}
343
344			=item @comments = Message::Util::comment_to_array ($youtself, $comments)
345
346			Replaces C<comment>s to C< > (a SP), decodes C<ccontent>s,
347			and returns them as array.
348
349			=cut
350
351			sub comment_to_array ($$) {
352			my $yourself = shift;
353			my $body = shift;
354			my @r = ();
355			$body =~ s{($REG{quoted_string}\|$REG{domain_literal})\|$REG{M_comment}}{
356			my ($o, $c) = ($1, $2);
357			if ($o) {$o}
358			else {
359			push @r, decode_ccontent ($yourself, $c);
360			' ';
361			}
362			}gex;
363			@r;
364			}
365
366			=item Message::Util::encode_ccontent ($yourself, $ccontent)
367
368			Encodes C<ccontent> (content of C<comment>).
369
370			=cut
371
372			sub encode_ccontent ($$) {
373			my $yourself = shift;
374			my $ccontent = shift;
375			my %f = &{$yourself->{option}->{hook_encode_string}} ($yourself,
376			$ccontent, type => 'ccontent');
377			$f{value} =~ s/([\x28\x29\x5C])([\x21-\x7E])?/"\x5C$1".(defined $2?"\x5C$2":'')/ge;
378			$f{value};
379			}
380
381			=item Message::Util::decode_ccontent ($yourself, $ccontent)
382
383			Decodes C<ccontent> (content of C<comment>).
384
385			=cut
386
387			sub decode_ccontent ($$) {
388			require Message::MIME::EncodedWord;
389			&Message::MIME::EncodedWord::decode_ccontent (@_[1,0]);
390			}
391
392	wakaba	1.1	=head1 LICENSE
393
394			Copyright 2002 wakaba E<lt>[email protected]<gt>.
395
396			This program is free software; you can redistribute it and/or modify
397			it under the terms of the GNU General Public License as published by
398			the Free Software Foundation; either version 2 of the License, or
399			(at your option) any later version.
400
401			This program is distributed in the hope that it will be useful,
402			but WITHOUT ANY WARRANTY; without even the implied warranty of
403			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
404			GNU General Public License for more details.
405
406			You should have received a copy of the GNU General Public License
407			along with this program; see the file COPYING. If not, write to
408			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
409			Boston, MA 02111-1307, USA.
410
411			=head1 CHANGE
412
413			See F<ChangeLog>.
414	wakaba	1.5	$Date: 2002/04/05 14:56:26 $
415	wakaba	1.1
416			=cut
417
418			1;