1 | package Encode::MIME::Header::ISO_2022_JP;
|
---|
2 |
|
---|
3 | use strict;
|
---|
4 | use base qw(Encode::MIME::Header);
|
---|
5 |
|
---|
6 | $Encode::Encoding{'MIME-Header-ISO_2022_JP'}
|
---|
7 | = bless {encode => 'B', bpl => 76, Name => 'MIME-Header-ISO_2022_JP'}
|
---|
8 | => __PACKAGE__;
|
---|
9 |
|
---|
10 | use constant HEAD => '=?ISO-2022-JP?B?';
|
---|
11 | use constant TAIL => '?=';
|
---|
12 |
|
---|
13 | use Encode::CJKConstants qw(%RE);
|
---|
14 |
|
---|
15 | our $VERSION = do { my @r = (q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
|
---|
16 |
|
---|
17 |
|
---|
18 | # I owe the below codes totally to
|
---|
19 | # Jcode by Dan Kogai & http://www.din.or.jp/~ohzaki/perl.htm#JP_Base64
|
---|
20 |
|
---|
21 | sub encode {
|
---|
22 | my $self = shift;
|
---|
23 | my $str = shift;
|
---|
24 |
|
---|
25 | utf8::encode($str) if( Encode::is_utf8($str) );
|
---|
26 | Encode::from_to($str, 'utf8', 'euc-jp');
|
---|
27 |
|
---|
28 | my($trailing_crlf) = ($str =~ /(\n|\r|\x0d\x0a)$/o);
|
---|
29 |
|
---|
30 | $str = _mime_unstructured_header($str, $self->{bpl});
|
---|
31 |
|
---|
32 | not $trailing_crlf and $str =~ s/(\n|\r|\x0d\x0a)$//o;
|
---|
33 |
|
---|
34 | return $str;
|
---|
35 | }
|
---|
36 |
|
---|
37 |
|
---|
38 | sub _mime_unstructured_header {
|
---|
39 | my ($oldheader, $bpl) = @_;
|
---|
40 | my $crlf = $oldheader =~ /\n$/;
|
---|
41 | my($header, @words, @wordstmp, $i) = ('');
|
---|
42 |
|
---|
43 | $oldheader =~ s/\s+$//;
|
---|
44 |
|
---|
45 | @wordstmp = split /\s+/, $oldheader;
|
---|
46 |
|
---|
47 | for ($i = 0; $i < $#wordstmp; $i++){
|
---|
48 | if( $wordstmp[$i] !~ /^[\x21-\x7E]+$/ and $wordstmp[$i + 1] !~ /^[\x21-\x7E]+$/){
|
---|
49 | $wordstmp[$i + 1] = "$wordstmp[$i] $wordstmp[$i + 1]";
|
---|
50 | }
|
---|
51 | else{
|
---|
52 | push(@words, $wordstmp[$i]);
|
---|
53 | }
|
---|
54 | }
|
---|
55 |
|
---|
56 | push(@words, $wordstmp[-1]);
|
---|
57 |
|
---|
58 | for my $word (@words){
|
---|
59 | if ($word =~ /^[\x21-\x7E]+$/) {
|
---|
60 | $header =~ /(?:.*\n)*(.*)/;
|
---|
61 | if (length($1) + length($word) > $bpl) {
|
---|
62 | $header .= "\n $word";
|
---|
63 | }
|
---|
64 | else{
|
---|
65 | $header .= $word;
|
---|
66 | }
|
---|
67 | }
|
---|
68 | else{
|
---|
69 | $header = _add_encoded_word($word, $header, $bpl);
|
---|
70 | }
|
---|
71 |
|
---|
72 | $header =~ /(?:.*\n)*(.*)/;
|
---|
73 |
|
---|
74 | if(length($1) == $bpl){
|
---|
75 | $header .= "\n ";
|
---|
76 | }
|
---|
77 | else {
|
---|
78 | $header .= ' ';
|
---|
79 | }
|
---|
80 | }
|
---|
81 |
|
---|
82 | $header =~ s/\n? $//mg;
|
---|
83 |
|
---|
84 | $crlf ? "$header\n" : $header;
|
---|
85 | }
|
---|
86 |
|
---|
87 |
|
---|
88 | sub _add_encoded_word {
|
---|
89 | my($str, $line, $bpl) = @_;
|
---|
90 | my $result = '';
|
---|
91 |
|
---|
92 | while( length($str) ){
|
---|
93 | my $target = $str;
|
---|
94 | $str = '';
|
---|
95 |
|
---|
96 | if(length($line) + 22 + ($target =~ /^(?:$RE{EUC_0212}|$RE{EUC_C})/o) * 8 > $bpl){
|
---|
97 | $line =~ s/[ \t\n\r]*$/\n/;
|
---|
98 | $result .= $line;
|
---|
99 | $line = ' ';
|
---|
100 | }
|
---|
101 |
|
---|
102 | while(1){
|
---|
103 | my $iso_2022_jp = $target;
|
---|
104 | Encode::from_to($iso_2022_jp, 'euc-jp', 'iso-2022-jp');
|
---|
105 |
|
---|
106 | my $encoded
|
---|
107 | = HEAD . MIME::Base64::encode_base64($iso_2022_jp, '') . TAIL;
|
---|
108 |
|
---|
109 | if(length($encoded) + length($line) > $bpl){
|
---|
110 | $target =~ s/($RE{EUC_0212}|$RE{EUC_KANA}|$RE{EUC_C}|$RE{ASCII})$//o;
|
---|
111 | $str = $1 . $str;
|
---|
112 | }
|
---|
113 | else{
|
---|
114 | $line .= $encoded;
|
---|
115 | last;
|
---|
116 | }
|
---|
117 | }
|
---|
118 |
|
---|
119 | }
|
---|
120 |
|
---|
121 | $result . $line;
|
---|
122 | }
|
---|
123 |
|
---|
124 |
|
---|
125 | 1;
|
---|
126 | __END__
|
---|
127 |
|
---|