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	require 5.7.3;
2	package Encode::Unicode::UTF7;
3	use strict;
4	use vars qw(%OPTION $VERSION);
5	$VERSION=do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
6	use base qw(Encode::Encoding);
7	require MIME::Base64;
8	__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	## 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	Copyright 2002 Wakaba E<lt>w@suika.fam.cxE<gt>.
115
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	# $Date: 2002/09/15 04:15:51 $
134	### UTF7.pm ends here