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