Parent Directory
| 
Revision Log
2002-08-16 Wakaba <w@suika.fam.cx> * UTF7.pm: New module.
| 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.1 $=~/\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 unicode-1-1-utf-7/); |
| 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; |