[Summary view] [Print] [Text view]

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