| 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 | |