Commit | Line | Data |
---|---|---|
920dae64 AT |
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 |