File Coverage

lib/Email/MIME/Creator/ISO_2022_JP.pm

Criterion	Covered	Total	%
statement	61	62	98.3
branch	13	16	81.2
condition	5	8	62.5
subroutine	11	11	100.0
pod	2	2	100.0
total	92	99	92.9

package Email::MIME::Creator::ISO_2022_JP;

use strict;
use warnings;
use Email::MIME;
use Encode;
use Sub::Install 'reinstall_sub';

BEGIN {
  if ( $Encode::VERSION < 2.11 ) {
    require Encode::compat::MIME::Header::ISO_2022_JP;
  }
}

our $VERSION = '0.02';

sub import {
  my $class = shift;

  if (!$class->can('create_utf8')) {
    for my $method (qw(create header_str_set)) {
      reinstall_sub({
        as   => "${method}_utf8",
        into => $class,
        code => \&{"Email::MIME::${method}"},
      });
    }
  }
  for my $method (qw(create header_str_set)) {
    reinstall_sub({
      as   => $method,
      into => "Email::MIME",
      code => \&{"${class}\::${method}_iso_2022_jp"},
    });
  }

  unless (grep /^$class/, @Email::MIME::ISA) {
    push @Email::MIME::ISA, $class;
  }
}

sub unimport {
  my $class = shift;

  if ($class->can('create_utf8')) {
    for my $method (qw(create header_str_set)) {
      reinstall_sub({
        as   => $method,
        into => "Email::MIME",
        code => \&{"${class}\::${method}_utf8"},
      });
    }
  }
}

sub create_iso_2022_jp {
  my ($class, %args) = @_;

  if (exists $args{header_str}) {
    $args{attributes}{charset} ||= 'ISO-2022-JP';

    my @headers = @{ delete $args{header_str} };
    $args{header} ||= [];
    pop @headers if @headers % 2 == 1;
    while (my ($key, $value) = splice @headers, 0, 2) {
      push @{$args{header}},
        ( $key => Encode::encode('MIME-Header-ISO_2022_JP', $value) );
    }
  }
  if (exists $args{body_str}) {
    $args{attributes}{charset}  ||= 'ISO-2022-JP';
    $args{attributes}{encoding} ||= '7bit';
  }

  my $email = $class->create_utf8(%args);  # i.e. original create

  my $remove; $remove = sub {
    my ($email) = @_;

    my @parts = $email->parts;
    return if $email eq $parts[0]; # avoid recursion

    foreach my $part (@parts) {
      $part->header_set(Date => ());
      $part->header_set('MIME-Version' => ());
      $remove->($part);
    }
    $email->parts_set(\@parts);
  };
  $remove->($email);

  return $email;
}

sub header_str_set_iso_2022_jp {
  my ($self, $name, @vals) = @_;

  my @values = map { Encode::encode('MIME-Header-ISO_2022_JP', $_, 1)  } @vals;

  $self->header_set($name => @values);
}

1;

__END__