Encode/Unicode/UTF7.pm

require 5.7.3;
package Encode::Unicode::UTF7;
use strict;
use vars qw(%OPTION $VERSION);
$VERSION=do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
use base qw(Encode::Encoding);
require MIME::Base64;
__PACKAGE__->Define (qw/utf-7 utf7 unicode-2-0-utf-7 unicode-2-0-utf7 x-unicode-2-0-utf7 cp65000 unicode-1-1-utf-7 csunicode11utf7/);
## BUG: Unicode-1-1-UTF-7 is actually not suitable.  (We need Unicode 1.1 support.)

$OPTION{encode_o_set} = 1;

sub encode ($$;$) {
  my ($obj, $str, $chk) = @_;
  my $encode_reg = qr#[^\x09\x0A\x0D\x20A-Za-z0-9'(),-./:?]#;
  $encode_reg = qr~[^\x09\x0A\x0D\x20A-Za-z0-9'(),-./:?!"#\$%&*;<=>@\[\]^_`{|}]~
    unless $OPTION{encode_o_set};
  $str =~ s{ ((?:$encode_reg)+) }{
    my $s = $1;
    unless ($s eq '+') {
      $s = MIME::Base64::encode_base64 (Encode::encode ('UTF-16BE', $s));
      $s =~ tr/=\x0A\x0D/A/d;
    } else {
      $s = '';
    }
    '+'.$s.'-';
  }goex;
  Encode::_utf8_off ($str);
  $_[1] = '' if $chk;
  return $str;
}

sub decode ($$;$) {
  my ($obj, $str, $chk) = @_;
  $str =~ s{\+([A-Za-z0-9+/]*)([^A-Za-z0-9+/]|$)}{
    my ($b, $d) = ($1, $2);
    if (length $b) {
      $b .= '=' x (4 - (length ($b) % 4));
      $b =~ s/====$//;  $b =~ s/AA$/==/;  $b =~ s/A$/=/;
      $b = Encode::decode ('UTF-16BE', MIME::Base64::decode_base64 ($b));
    } else {
      $b = '+';
    }
    $d = '' if $d eq '-';
    $b.$d;
  }goex;
  Encode::_utf8_on ($str);
  $_[1] = '' if $chk;
  return $str;
}

package Encode::Unicode::UTF7::IMAP;
use vars qw($VERSION);
$VERSION = $Encode::Unicode::UTF7::VERSION;
use base qw(Encode::Encoding);
#require MIME::Base64;
__PACKAGE__->Define (qw/utf7-imap utf-7-imap utf-7-for-imap x-imap4-modified-utf7/);

sub encode ($$;$) {
  my ($obj, $str, $chk) = @_;
  $str =~ s{ ([^\x20-\x25\x27-\x7E]+) }{
    my $s = $1;
    unless ($s eq '&') {
      $s = MIME::Base64::encode_base64 (Encode::encode ('UTF-16BE', $s));
      $s =~ tr#/=\x0A\x0D#,A#d;
    } else {
      $s = '';
    }
    '&'.$s.'-';
  }goex;
  Encode::_utf8_off ($str);
  $_[1] = '' if $chk;
  return $str;
}

sub decode ($$;$) {
  my ($obj, $str, $chk) = @_;
  $str =~ s{&([A-Za-z0-9+,]*)-}{
    my $b = $1;
    if (length $b) {
      $b .= '=' x (4 - (length ($b) % 4));
      $b =~ s/====$//;  $b =~ s/AA$/==/;  $b =~ s/A$/=/;
      $b =~ tr#,#/#;
      $b = Encode::decode ('UTF-16BE', MIME::Base64::decode_base64 ($b));
    } else {
      $b = '&';
    }
    $b;
  }goex;
  Encode::_utf8_on ($str);
  $_[1] = '' if $chk;
  return $str;
}

1;
__END__

=head1 NAME

Encode::Unicode::UTF7 --- Encode/decode of UTF-7 and IMAP4 modified UTF-7

=head1 EXAMPLE

  use Encode;
  my $s = "some string in utf-8 (to be converted to utf-\x{4E03})";
  print encode ('utf-7', $s);   # ... utf-+TgMA-
  print encode ('utf7-imap', $s);       # ... utf-&TgMA-
  
  my $b = q(A+ImIDkQ. +ZeVnLIqe-);
  print decode ('utf-7', $b);   # A<!=><Alpha> <ni><hon><go>

=head1 LICENSE

Copyright 2002 Wakaba E<lt>w@suika.fam.cxE<gt>.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.

=cut

# $Date: 2002/09/15 04:15:51 $
### UTF7.pm ends here
1	wakaba	1.1	require 5.7.3;
2			package Encode::Unicode::UTF7;
3			use strict;
4			use vars qw(%OPTION $VERSION);
5	wakaba	1.3	$VERSION=do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
6	wakaba	1.1	use base qw(Encode::Encoding);
7			require MIME::Base64;
8	wakaba	1.2	__PACKAGE__->Define (qw/utf-7 utf7 unicode-2-0-utf-7 unicode-2-0-utf7 x-unicode-2-0-utf7 cp65000 unicode-1-1-utf-7 csunicode11utf7/);
9	wakaba	1.1	## BUG: Unicode-1-1-UTF-7 is actually not suitable. (We need Unicode 1.1 support.)
10
11			$OPTION{encode_o_set} = 1;
12
13			sub encode ($$;$) {
14			my ($obj, $str, $chk) = @_;
15			my $encode_reg = qr#[^\x09\x0A\x0D\x20A-Za-z0-9'(),-./:?]#;
16			$encode_reg = qr~[^\x09\x0A\x0D\x20A-Za-z0-9'(),-./:?!"#\$%&*;<=>@\[\]^_`{\|}]~
17			unless $OPTION{encode_o_set};
18			$str =~ s{ ((?:$encode_reg)+) }{
19			my $s = $1;
20			unless ($s eq '+') {
21			$s = MIME::Base64::encode_base64 (Encode::encode ('UTF-16BE', $s));
22			$s =~ tr/=\x0A\x0D/A/d;
23			} else {
24			$s = '';
25			}
26			'+'.$s.'-';
27			}goex;
28			Encode::_utf8_off ($str);
29			$_[1] = '' if $chk;
30			return $str;
31			}
32
33			sub decode ($$;$) {
34			my ($obj, $str, $chk) = @_;
35			$str =~ s{\+([A-Za-z0-9+/]*)([^A-Za-z0-9+/]\|$)}{
36			my ($b, $d) = ($1, $2);
37			if (length $b) {
38			$b .= '=' x (4 - (length ($b) % 4));
39			$b =~ s/====$//; $b =~ s/AA$/==/; $b =~ s/A$/=/;
40			$b = Encode::decode ('UTF-16BE', MIME::Base64::decode_base64 ($b));
41			} else {
42			$b = '+';
43			}
44			$d = '' if $d eq '-';
45			$b.$d;
46			}goex;
47			Encode::_utf8_on ($str);
48			$_[1] = '' if $chk;
49			return $str;
50			}
51
52			package Encode::Unicode::UTF7::IMAP;
53			use vars qw($VERSION);
54			$VERSION = $Encode::Unicode::UTF7::VERSION;
55			use base qw(Encode::Encoding);
56			#require MIME::Base64;
57			__PACKAGE__->Define (qw/utf7-imap utf-7-imap utf-7-for-imap x-imap4-modified-utf7/);
58
59			sub encode ($$;$) {
60			my ($obj, $str, $chk) = @_;
61			$str =~ s{ ([^\x20-\x25\x27-\x7E]+) }{
62			my $s = $1;
63			unless ($s eq '&') {
64			$s = MIME::Base64::encode_base64 (Encode::encode ('UTF-16BE', $s));
65			$s =~ tr#/=\x0A\x0D#,A#d;
66			} else {
67			$s = '';
68			}
69			'&'.$s.'-';
70			}goex;
71			Encode::_utf8_off ($str);
72			$_[1] = '' if $chk;
73			return $str;
74			}
75
76			sub decode ($$;$) {
77			my ($obj, $str, $chk) = @_;
78			$str =~ s{&([A-Za-z0-9+,]*)-}{
79			my $b = $1;
80			if (length $b) {
81			$b .= '=' x (4 - (length ($b) % 4));
82			$b =~ s/====$//; $b =~ s/AA$/==/; $b =~ s/A$/=/;
83			$b =~ tr#,#/#;
84			$b = Encode::decode ('UTF-16BE', MIME::Base64::decode_base64 ($b));
85			} else {
86			$b = '&';
87			}
88			$b;
89			}goex;
90			Encode::_utf8_on ($str);
91			$_[1] = '' if $chk;
92			return $str;
93			}
94
95			1;
96			__END__
97
98			=head1 NAME
99
100			Encode::Unicode::UTF7 --- Encode/decode of UTF-7 and IMAP4 modified UTF-7
101
102			=head1 EXAMPLE
103
104			use Encode;
105			my $s = "some string in utf-8 (to be converted to utf-\x{4E03})";
106			print encode ('utf-7', $s); # ... utf-+TgMA-
107			print encode ('utf7-imap', $s); # ... utf-&TgMA-
108
109			my $b = q(A+ImIDkQ. +ZeVnLIqe-);
110			print decode ('utf-7', $b); # A<!=><Alpha> <ni><hon><go>
111
112			=head1 LICENSE
113
114	wakaba	1.3	Copyright 2002 Wakaba E<lt>w@suika.fam.cxE<gt>.
115	wakaba	1.1
116			This program is free software; you can redistribute it and/or modify
117			it under the terms of the GNU General Public License as published by
118			the Free Software Foundation; either version 2 of the License, or
119			(at your option) any later version.
120
121			This program is distributed in the hope that it will be useful,
122			but WITHOUT ANY WARRANTY; without even the implied warranty of
123			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
124			GNU General Public License for more details.
125
126			You should have received a copy of the GNU General Public License
127			along with this program; see the file COPYING. If not, write to
128			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
129			Boston, MA 02111-1307, USA.
130
131			=cut
132
133	wakaba	1.3	# $Date: 2002/09/15 04:15:51 $
134	wakaba	1.1	### UTF7.pm ends here