File Coverage

blib/lib/Encode/MIME/EncWords.pm

Criterion	Covered	Total	%
statement	69	110	62.7
branch	28	78	35.9
condition	10	13	76.9
subroutine	8	10	80.0
pod	5	5	100.0
total	120	216	55.5

# -*- perl -*-

package Encode::MIME::EncWords;
require 5.007003;

use strict;
use warnings;
use Carp qw(croak carp);
use MIME::EncWords;

our $VERSION = '0.03';

# Default of options
my $Config = {
    Charset => 'UTF-8',
    # Encoding => specified by each subclass.
    # Folding => fixes to "\n".
    # Replacement => given by encode()/decode().
    # others => derived from MIME::EncWords:
    map { ($_ => $MIME::EncWords::Config->{$_}) }
	qw(Detect7bit Field Mapping MaxLineLen Minimal)
};

$Encode::Encoding{'MIME-EncWords'} = bless {
    Encoding => 'A',
    Name     => 'MIME-EncWords',
} => __PACKAGE__;

$Encode::Encoding{'MIME-EncWords-B'} = bless {
    Encoding => 'B',
    Name     => 'MIME-EncWords-B',
} => __PACKAGE__;

$Encode::Encoding{'MIME-EncWords-Q'} = bless {
    Encoding => 'Q',
    Name     => 'MIME-EncWords-Q',
} => __PACKAGE__;

$Encode::Encoding{'MIME-EncWords-ISO_2022_JP'} = bless {
    Charset  => 'ISO-2022-JP',
    Encoding => 'B',
    Name     => 'MIME-EncWords-ISO_2022_JP',
} => __PACKAGE__;

use base qw(Encode::Encoding);

sub needs_lines { 1 }
sub perlio_ok   { 0 }

sub decode($$;$) {
    my ($obj, $str, $chk) = @_;

    my %opts = map { ($_ => ($obj->{$_} || $Config->{$_})) }
        qw(Detect7bit Mapping);
    $chk = 0 if ref $chk; # coderef not supported.
    my $repl = ($chk & 4) ? ($chk & ~4 | 1) : $chk;

    local $@;
    my $skip = 0; # for RETURN_ON_ERR
    my $ret = undef;
    pos($str) = 0;
    foreach my $line (
	$str =~ m{ \G (.*?) (?:\r\n|[\r\n]) (?![ \t]) }cgsx,
	substr($str, pos($str))
    ) {
	if (defined $ret) {
	    $ret .= "\n" unless $skip;
	} else {
	    $ret = '';
	}
	if ($skip) {
	    $_[1] .= "\n";
	    $_[1] .= $line;
	    next;
	}
	next unless length $line;

	my @words = MIME::EncWords::decode_mimewords($line, %opts);
	if ($@) { # broken MIME encoding.
	    croak $@ if $chk & 1;   # DIE_ON_ERR
	    carp $@ if $chk & 2;    # WARN_ON_ERR
	    if ($chk & 4) {         # RETURN_ON_ERR
		$_[1] = $line;
		$skip = 1;
		next;
	    }
	}
	for (my $i = 0; $i <= $#words; $i++) {
	    my $word = $words[$i];
	    my $cset = MIME::Charset->new(($word->[1] || 'US-ASCII'),
					  Mapping => $opts{Mapping});
	    if (! $cset->decoder) { # unknown charset or ``8BIT''.
		$@ = 'Unknown charset "'.$cset->as_string.'"';
		croak $@ if $chk & 1;
		carp $@ if $chk & 2;
		if ($chk & 4) {
		    # already decoded... re-encoding
		    $_[1] =
			MIME::EncWords::encode_mimewords([splice @words, $i],
							 Encoding => 'B',
							 Folding => '',
							 MaxLineLen => -1);
		    $skip = 1;
		    last;
		}
		$ret .= Encode::decode("ISO-8859-1", $word->[0], 0); #FIXME

		next;
	    }
	    eval {
		$ret .= $cset->decode($word->[0], $repl);
	    };
	    if ($@) {
		$@ =~ s/ at .+? line \d+[.\n]*$//;
		croak $@ if $chk & 1;
		carp $@ if $chk & 2;
		if ($chk & 4) {
		    # already decoded... re-encoding
		    $_[1] =
			MIME::EncWords::encode_mimewords([splice @words, $i],
							 Encoding => 'B',
							 Folding => '',
							 MaxLineLen => -1);
		    $skip = 1;
		    last;
		}
	    }
	}
    }

    if ($chk & 4) { # RETURN_ON_ERR
	$_[1] = '' unless $skip;
    } elsif ($chk) { # ! LEAVE_SRC
	$_[1] = $ret unless $chk & 8;
    }
    return $ret;
}

sub encode($$;$) {
    my ($obj, $str, $chk) = @_;

    my %opts = map { ($_ => ($obj->{$_} || $Config->{$_})) }
        qw(Charset Detect7bit Encoding Field Mapping MaxLineLen Minimal);
    $opts{Charset} ||= 'UTF-8';
    $opts{Folding} = "\n";
    $chk = 0 if ref $chk; # coderef not supported.
    my $repl = ($chk & 4) ? ($chk & ~4 | 1) : $chk;

    $str = Encode::decode('ISO-8859-1', $str)
        if ! Encode::is_utf8($str) and $str =~ /[^\x00-\x7F]/;

    local $@;
    my $skip = 0; # for RETURN_ON_ERR
    my $ret = undef;
    pos($str) = 0;
    foreach my $line (
        $str =~ m{ \G (.*?) (?:\r\n|[\r\n]) (?![ \t]) }cgsx,
        substr($str, pos($str))
    ) {
	if (defined $ret) {
	    $ret .= "\n" unless $skip;
	} else {
	    $ret = '';
	}
	if ($skip) {
	    $_[1] .= "\n";
	    $_[1] .= $line;
	    next;
	}
	next unless length $line;

	eval {
	    $ret .= MIME::EncWords::encode_mimewords($line, %opts,
						     Replacement => $repl);
	};
	if ($@) {
	    $@ =~ s/ at .+? line \d+[.\n]*$//;
	    croak $@ if $chk & 1;   # DIE_ON_ERR
	    carp $@ if $chk & 2;    # WARN_ON_ERR
	    if ($chk & 4) {         # RETURN_ON_ERR
		$_[1] = $line;
		$skip = 1;
		next;
	    }
	}
    }

    if ($chk & 4) { # RETURN_ON_ERR
	$_[1] = '' unless $skip;
    } elsif ($chk) { # ! LEAVE_SRC
	$_[1] = '' unless $chk & 8; # FIXME:spec?
    }
    return $ret;
}

sub config {
    my $klass = shift if scalar @_ % 2;
    my %opts = @_;
    foreach my $key (keys %opts) {
        croak "Unknown config option: $key" unless exists $Config->{$key};
        $Config->{$key} = $opts{$key};
    }
}

1;
__END__