File Coverage

blib/lib/MIME/EcoEncode/Param.pm

Criterion	Covered	Total	%
statement	243	379	64.1
branch	107	220	48.6
condition	12	27	44.4
subroutine	7	7	100.0
pod	0	4	0.0
total	369	637	57.9

# Copyright (C) 2013 MURATA Yasuhisa
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

package MIME::EcoEncode::Param;

use 5.008005;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);
our @EXPORT_OK = qw($VERSION);
our @EXPORT = qw(mime_eco_param mime_deco_param);
our $VERSION = '0.95';

our $HEAD; # head string
our $HTL;  # head + tail length
our $LF;   # line feed
our $BPL;  # bytes per line
our $UTF8;
our $REG_W;

sub mime_eco_param {
    my $str = shift;

    return '' unless defined $str;
    return '' if $str eq '';

    my ($trailing_crlf) = ($str =~ /(\x0d?\x0a|\x0d)$/);
    $str =~ tr/\n\r//d;
    if ($str =~ /^\s*$/) {
       return $trailing_crlf ? $str . $trailing_crlf : $str;
    }

    my $charset = shift || 'UTF-8';

    our $HEAD; # head string

    my $cs;
    my $type; # 0: RFC 2231, 1: "Q", 2: "B"
    if ($charset =~ /^([-0-9A-Za-z_]+)(\'[^\']*\')?$/i) {
	$cs = lc($1);
	$type = 0;
	$HEAD = $2 ? $charset : $charset . "''";
    }
    elsif ($charset =~ /^([-0-9A-Za-z_]+)(\*[^\?]*)?(\?[QB])?$/i) {
	$cs = lc($1);
	if (defined $3) {
	    $type = (lc($3) eq '?q') ? 1 : 2;
	    $HEAD = '=?' . $charset . '?';
	}
	else {
	    $type = 2;
	    $HEAD = '=?' . $charset . '?B?';
	}
    }
    else { # invalid option
	return undef;
    }

    our $HTL;  # head + tail length
    our $LF  = shift || "\n"; # line feed
    our $BPL = shift || 76;   # bytes per line
    our $UTF8 = 1;
    our $REG_W = qr/(.)/;

    my $jp = 0;
    my $np;

    $HTL = length($HEAD) + 2;

    if ($cs ne 'utf-8') {
	$UTF8 = 0;
	if ($cs eq 'iso-2022-jp') {
	    $jp = 1;
	}
	elsif ($cs eq 'shift_jis') {
	    # range of 2nd byte : [\x40-\x7e\x80-\xfc]
	    $REG_W = qr/([\x81-\x9f\xe0-\xfc]?.)/;
	}
	elsif ($cs eq 'gb2312') { # Simplified Chinese
	    # range of 2nd byte : [\xa1-\xfe]
	    $REG_W = qr/([\xa1-\xfe]?.)/;
	}
	elsif ($cs eq 'euc-kr') { # Korean
	    # range of 2nd byte : [\xa1-\xfe]
	    $REG_W = qr/([\xa1-\xfe]?.)/;
	}
	elsif ($cs eq 'big5') { # Traditional Chinese
	    # range of 2nd byte : [\x40-\x7e\xa1-\xfe]
	    $REG_W = qr/([\x81-\xfe]?.)/;
	}
	else { # Single Byte (Latin, Cyrillic, ...)
	    ;
	}
    }

    $str =~ s/^(\s*)//; # leading whitespace
    my $sps = $1;
    my ($param, $value) = split('=', $str, 2);

    unless (defined $value) {
        return $trailing_crlf ? $str . $trailing_crlf : $str;
    }

    my $quote = 0;

    if ($value =~ s/^\s*"(.*)"$/$1/) {
        $quote = 1;
    }
    if ($value eq '') {
        return $trailing_crlf ? $str . $trailing_crlf : $str;
    }

    my $result = "$sps$param=";
    my $v_len = length($value);
    my $ll_len = length($result);

    if (!$quote && $value !~ /[^\w!#\$&\+-\.\^`\{\|}~]/) { # regular token
        if ($type or $ll_len + $v_len <= $BPL) {
            $result .= $value;
            return $trailing_crlf ? $result . $trailing_crlf : $result;
        }

        my $n = 0;
        my $c;
        my $p_str;

        $result = "$sps$param\*0=";
        $ll_len += 2;
        while ($value =~ /(.)/g) {
            $c = $1;
            if ($ll_len + 1 > $BPL) {
                $n++;
                $p_str = " $param\*$n=";
                $result .= "$LF$p_str$c";
                $ll_len = 1 + length($p_str);
            }
            else {
                $result .= $c;
                $ll_len++;
            }
        }
        return $trailing_crlf ? $result . $trailing_crlf : $result;
    }
    if ($quote && $value !~ /[^\t\x20-\x7e]/) { # regular quoted-string
        if ($type or $ll_len + $v_len + 2 <= $BPL) {
            $result .= "\"$value\"";
            return $trailing_crlf ? $result . $trailing_crlf : $result;
        }

        my $n = 0;
        my $vc;
        my $vc_len;
        my $p_str;

        $result = "$sps$param\*0=\"";
        $ll_len += 3;
        while ($value =~ /(\\.|.)/g) {
            $vc = $1;
            $vc_len = length($vc);
            if ($ll_len + $vc_len + 1 > $BPL) {
                $n++;
                $p_str = " $param\*$n=\"";
                $result .= "\"$LF$p_str$vc";
                $ll_len = $vc_len + length($p_str);
            }
            else {
                $result .= $vc;
                $ll_len += $vc_len;
            }
        }
        $result .= '"';
        return $trailing_crlf ? $result . $trailing_crlf : $result;
    }

    #
    # extended parameter (contain regular parameter)
    #

    if ($jp) {
	if ($type == 0) {
	    return param_enc_jp($param, $value, $sps, $trailing_crlf, $quote);
	}

	if ($type == 1) { # "Q" encoding
	    require MIME::EcoEncode::JP_Q;
	    $MIME::EcoEncode::JP_Q::HEAD  = $HEAD;
	    $MIME::EcoEncode::JP_Q::HTL   = $HTL;
	    $MIME::EcoEncode::JP_Q::LF    = $LF;
	    $MIME::EcoEncode::JP_Q::BPL   = $BPL;
	    $MIME::EcoEncode::JP_Q::MODE  = 0;

	    my $enc =
		MIME::EcoEncode::JP_Q::add_ew_jp_q($value,
						   length($result) + 1,
						   \$np, 1, 1);
	    if ($enc eq ' ') {
		$enc =
		    MIME::EcoEncode::JP_Q::add_ew_jp_q($value, 2, \$np, 1);
		$result .= "$LF \"$enc\"";
	    }
	    else {
		$result .= "\"$enc\"";
	    }
	    return $trailing_crlf ? $result . $trailing_crlf : $result;
	}
	else { # "B" encoding
	    require MIME::EcoEncode::JP_B;
	    $MIME::EcoEncode::JP_B::HEAD  = $HEAD;
	    $MIME::EcoEncode::JP_B::HTL   = $HTL;
	    $MIME::EcoEncode::JP_B::LF    = $LF;
	    $MIME::EcoEncode::JP_B::BPL   = $BPL;

	    my $enc =
		MIME::EcoEncode::JP_B::add_ew_jp_b($value,
						   length($result) + 1,
						   \$np, 1, 1);
	    if ($enc eq ' ') {
		$enc =
		    MIME::EcoEncode::JP_B::add_ew_jp_b($value, 2, \$np, 1);
		$result .= "$LF \"$enc\"";
	    }
	    else {
		$result .= "\"$enc\"";
	    }
	    return $trailing_crlf ? $result . $trailing_crlf : $result;
	}
    }

    if ($type == 0) {
	return param_enc($param, $value, $sps, $trailing_crlf, $quote);
    }
    if ($type == 1) { # "Q" encoding
	require MIME::EcoEncode;
        $MIME::EcoEncode::HEAD  = $HEAD;
        $MIME::EcoEncode::HTL   = $HTL;
        $MIME::EcoEncode::LF    = $LF;
        $MIME::EcoEncode::BPL   = $BPL;
        $MIME::EcoEncode::REG_W = $REG_W;

        my $enc =
	    MIME::EcoEncode::add_ew_q($value, length($result) + 1,
                                         \$np, 1, 1);
        if ($enc eq ' ') {
            $enc =
		MIME::EcoEncode::add_ew_q($value, 2, \$np, 1);
            $result .= "$LF \"$enc\"";
        }
        else {
            $result .= "\"$enc\"";
        }
        return $trailing_crlf ? $result . $trailing_crlf : $result;
    }
    else { # "B" encoding
	require MIME::EcoEncode;
        $MIME::EcoEncode::HEAD  = $HEAD;
        $MIME::EcoEncode::HTL   = $HTL;
        $MIME::EcoEncode::LF    = $LF;
        $MIME::EcoEncode::BPL   = $BPL;
        $MIME::EcoEncode::REG_W = $REG_W;

        my $enc =
	    MIME::EcoEncode::add_ew_b($value, length($result) + 1,
                                         \$np, 1, 1);
        if ($enc eq ' ') {
            $enc =
		MIME::EcoEncode::add_ew_b($value, 2, \$np, 1);
            $result .= "$LF \"$enc\"";
        }
        else {
            $result .= "\"$enc\"";
        }
        return $trailing_crlf ? $result . $trailing_crlf : $result;
    }
}


sub param_enc {
    my $param = shift;
    my $value = shift;
    my $sps = shift;
    my $trailing_crlf = shift;
    my $quote = shift;

    my $result;
    my $ll_len;

    our $UTF8;
    our $REG_W;
    our $HEAD;

    $value = "\"$value\"" if $quote;
    my $vstr = $value;

    $value =~ s/([^\w!#\$&\+-\.\^`\{\|}~])/
        sprintf("%%%X",ord($1))/egox;

    $result = "$sps$param\*=$HEAD";
    if (length($result) + length($value) <= $BPL) {
        $result .= $value;
        return $trailing_crlf ? $result . $trailing_crlf : $result;
    }

    my $n = 0;
    my $nn = 1;
    my $w1;
    my $p_str;
    my $w;
    my $w_len;
    my $chunk = '';
    my $ascii = 1;

    $result = "$sps$param\*0\*=$HEAD";
    $ll_len = length($result);

    utf8::decode($vstr) if $UTF8; # UTF8 flag on

    while ($vstr =~ /$REG_W/g) {
        $w1 = $1;
	utf8::encode($w1) if $UTF8; # UTF8 flag off
        $w_len = length($w1); # size of one character

        $value =~ /((?:%..|.){$w_len})/g;
        $w = $1;
        $w_len = length($w);

        $ascii = 0 if $w_len > 1;

        # 1 is ';'
        if ($ll_len + $w_len + 1 > $BPL) {
            $p_str = " $param\*$nn\*=";
            if ($ascii) {
                if ($n == 0) {
                    $result = "$sps$param\*0=$HEAD$chunk$w;";
                }
                else {
                    $result .= "$LF $param\*$n=$chunk$w;";
                }
                $ll_len = length($p_str);
                $chunk = '';
            }
            else {
                if ($n == 0) {
                    $result = "$result$chunk;";
                }
                else {
                    $result .= "$LF $param\*$n\*=$chunk;";
                }
                $ll_len = length($p_str) + $w_len;
                $chunk = $w;
            }
            $ascii = 1 if $w_len == 1;
            $n = $nn;
            $nn++;
        }
        else {
            $chunk .= $w;
            $ll_len += $w_len;
        }
    }
    if ($ascii) {
        if ($chunk eq '') {
            chop($result);
        }
        else {
            $result .= "$LF $param\*$n=$chunk";
        }
    }
    else {
        $result .= "$LF $param\*$n\*=$chunk";
    }
    return $trailing_crlf ? $result . $trailing_crlf : $result;
}


sub param_enc_jp {
    my $param = shift;
    my $value = shift;
    my $sps = shift;
    my $trailing_crlf = shift;
    my $quote = shift;

    my $result;
    my $ll_len;

    our $HEAD;

    $value = "\"$value\"" if $quote;
    my $vstr = $value;

    $value =~ s/([^\w!#\$&\+-\.\^`\{\|}~])/
        sprintf("%%%X",ord($1))/egox;

    $result = "$sps$param\*=$HEAD";
    if (length($result) + length($value) <= $BPL) {
        $result .= $value;
        return $trailing_crlf ? $result . $trailing_crlf : $result;
    }

    my $n = 0;
    my $nn = 1;
    my $p_str;
    my $ascii = 1;

    my $ee_str = '%1B%28B';
    my $ee_len = 7;

    my $vstr_len = length($vstr);

    my $k_in = 0; # ascii: 0, zen: 1 or 2, han: 9
    my $k_in_bak = 0;
    my $ec;
    my ($w, $w_len) = ('', 0);
    my ($chunk, $chunk_len) = ('', 0);
    my ($w1, $w1_bak);
    my $enc_len;

    $vstr =~ s/\e\(B$//;
    $result = "$sps$param\*0\*=$HEAD";
    $ll_len = length($result);

    while ($vstr =~ /\e(..)|./g) {
        $ec = $1;
        $value =~ /(%1B(?:%..|.)(?:%..|.)|(?:%..|.))/g;
        $w1 = $1;
        $w .= $w1;
        if (defined $ec) {
            $w1_bak = $w1;
            if ($ec eq '(B') {
                $k_in = 0;
            }
            elsif ($ec eq '$B') {
                $k_in = 1;
            }
            else {
                $k_in = 9;
            }
            next;
        }
        else {
            if ($k_in == 1) {
                $k_in = 2;
                next;
            }
            elsif ($k_in == 2) {
                $k_in = 1;
            }
        }
        $w_len = length($w);
        $enc_len = $w_len + ($k_in ? $ee_len : 0);
        $ascii = 0 if $w_len > 1;

        # 1 is ';'
        if ($ll_len + $enc_len + 1 > $BPL) {
            $p_str = " $param\*$nn\*=";
            if ($ascii) {
                if ($n == 0) {
                    $result = "$sps$param\*0=$HEAD$chunk$w;";
                }
                else {
                    $result .= "$LF $param\*$n=$chunk$w;";
                }
                $ll_len = length($p_str);
                $chunk = '';
            }
            else {
                if ($k_in_bak) {
                    $chunk .= $ee_str;
                    if ($k_in) {
                        if ($k_in_bak == $k_in) {
                            $w = $w1_bak . $w;
                            $w_len += length($w1_bak);
                        }
                    }
                    else {
                        $w = $w1;
                        $w_len = length($w1);
                    }
                }
                if ($n == 0) {
                    $result = "$result$chunk;";
                }
                else {
                    $result .= "$LF $param\*$n\*=$chunk;";
                }
                $ll_len = length($p_str) + $w_len;
                $chunk = $w;
            }
            $ascii = 1 if $w_len == 1;
            $n = $nn;
            $nn++;
        }
        else {
            $chunk .= $w;
            $ll_len += $w_len;
        }
        $k_in_bak = $k_in;
        $w = '';
        $w_len = 0;
    }
    if ($ascii) {
        if ($chunk eq '') {
            chop($result);
        }
        else {
            $result .= "$LF $param\*$n=$chunk";
        }
    }
    else {
        $chunk .= $ee_str if $k_in_bak;
        $result .= "$LF $param\*$n\*=$chunk";
    }
    return $trailing_crlf ? $result . $trailing_crlf : $result;
}


sub mime_deco_param {
    my $str = shift;
    if ((!defined $str) || $str eq '') {
        return ('') x 5 if wantarray;
        return '';
    }

    my ($trailing_crlf) = ($str =~ /(\x0d?\x0a|\x0d)$/);
    $str =~ tr/\n\r//d;
    if ($str =~ /^\s*$/) {
        return ($trailing_crlf ? $str . $trailing_crlf : $str,
                ('') x 4) if wantarray;
        return $trailing_crlf ? $str . $trailing_crlf : $str;
    }

    $str =~ s/^(\s*)//; # leading whitespace
    my $sps = $1;

    my $result = '';
    my ($param, $value, $charset, $lang);
    my ($param0, $value0, $charset0, $lang0) = ('') x 4;

    my $bq_on = shift; # "B/Q" decode ON/OFF
    $bq_on = 1 unless defined $bq_on;

    if ($bq_on) {
	$str =~ /([^=]*)=\s*"(.*?[^\\])"\s*/;
	($param, $value) = ($1, $2);

	my $reg_ew =
	    qr{^
	       =\?
	       ([-0-9A-Za-z_]+)                         # charset
	       (?:\*([A-Za-z]{1,8}                      # language
		       (?:-[A-Za-z]{1,8})*))?           # (RFC 2231 section 5)
	       \?
	       (?:
		   [Bb]\?([0-9A-Za-z\+\/]+={0,2})\?=    # "B" encoding
	       |
		   [Qq]\?([\x21-\x3e\x40-\x7e]+)\?=     # "Q" encoding
	       )}x;

	if ($value and $value =~ qr/$reg_ew(\s|$)/) { # "B" or "Q"
	    ($charset0, $lang0) = ($1, $2);
	    $lang0 = '' unless defined $lang0;
	    $param0 = $param;

	    require MIME::Base64;
	    MIME::Base64->import();

	    require MIME::QuotedPrint;
	    MIME::QuotedPrint->import();

	    my ($b_enc, $q_enc);

	    for my $w (split /\s+/, $value) {
		if ($w =~ qr/$reg_ew$/o) {
		    ($charset, $lang, $b_enc, $q_enc) = ($1, $2, $3, $4);
		    if (defined $q_enc) {
			$q_enc =~ tr/_/ /;
			$value0 .= decode_qp($q_enc);
		    }
		    else {
			$value0 .= decode_base64($b_enc);
		    }
		}
	    }
	    if (lc($charset0) eq
		'iso-2022-jp') { # remove redundant ESC sequences
		$value0 =~ s/(\e..)([^\e]+)\e\(B(?=\1)/$1$2\n/g;
		$value0 =~ s/\n\e..//g;
		$value0 =~ s/\e\(B(\e..)/$1/g;
	    }
	    $result = "$sps$param0=\"$value0\"";
	    if (wantarray) {
		return ($trailing_crlf ? $result . $trailing_crlf : $result,
			$param0, $charset0, $lang0, $value0);
	    }
	    return $trailing_crlf ? $result . $trailing_crlf : $result;
	}
    }

    my ($param0_init, $cs_init, $quote) = (0) x 3;
    my %params;

    while ($str =~ /([^=]*)=(\s*".*?[^\\]";?|\S*)\s*/g) {
        ($param, $value) = ($1, $2);
        $value =~ s/;$//;
        if ($value =~ s/^\s*"(.*)"$/$1/) {
            $quote = 1;
        }
        if ($param =~ s/\*$//) {
            if (!$cs_init) {
                if ($value =~ /^(.*?)'(.*?)'(.*)/) {
                    ($charset0, $lang0, $value) = ($1, $2, $3);
                }
                $cs_init = 1;
            }
            $value =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/pack('H2', $1)/eg;
        }
        if (!$param0_init) {
            $param =~ s/\*0$//;
            $param0 = $param;
            $param0_init = 1;
        }
        $params{$param} = $value;
    }

    my $n = keys %params;

    $result = ($n == 0) ? "$sps$str" : "$sps$param0=";
    $value0 = $params{$param0};
    $value0 = '' unless defined $value0;
    if ($n > 1) {
        for (my $i = 1; $i < $n; $i++) {
            $value = $params{$param0 . "\*$i"};
            $value0 .= $value if defined $value;
        }
    }
    if (lc($charset0) eq 'iso-2022-jp') { # remove redundant ESC sequences
        $value0 =~ s/(\e..)([^\e]+)\e\(B(?=\1)/$1$2\n/g;
        $value0 =~ s/\n\e..//g;
        $value0 =~ s/\e\(B(\e..)/$1/g;
    }
    $result .= ($quote ? "\"$value0\"" : $value0);
    if (wantarray) {
        if (!$cs_init and $quote) {
            $value0 =~ s/\\(.)/$1/g;
        }
        return ($trailing_crlf ? $result . $trailing_crlf : $result,
                $param0, $charset0, $lang0, $value0);
    }
    return $trailing_crlf ? $result . $trailing_crlf : $result;
}

1;