#=====================================================================
#   MIME.pm : MIME Encode module (encoding method only)
#
#   Copyright(c) N.Oishi (BSC CONSULTING CGI-Laboratory).
#
#   e-mail : bigstone@my.email.ne.jp
#   support: http://www.din.or.jp/~bigstone/cgilab/index.html
#
#   THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND
#   ANY EXPRESS OR IMPLIED WARRANTIES ARE DISCLAIMED.
#
#   ver 1.0.5 : updated last on 2005/04/04
#
#=====================================================================
package MIME;

use Symbol;
use strict;
use integer;
use vars qw(
    $VERSION $TIMEZONE $ZONESTR $DEFAULT_CHARSET %DEFAULT_ENCODING
    %ENCODING_METHOD %CONVERT_CHARSET %CONVERT_OPTION %SUFFIX_TYPE
    %SUFFIX_ENCODE @DAY_OF_WEEK @MON_OF_YEAR %MON_OF_YEAR
);
require 'jcode.pl';

#---------------------------------------------------------------------
$TIMEZONE = 9 * 60 * 60;    # Japan is GMT+0900
$ZONESTR  = '+0900';
#---------------------------------------------------------------------

$VERSION  = '1.0.5';

$DEFAULT_CHARSET  = 'ISO-2022-JP';
%DEFAULT_ENCODING = (
    'US-ASCII'    => '7bit',
    'ISO-2022-JP' => '7bit',
    'ISO-8859-1'  => 'quoted-printable',
    'ISO-8859-2'  => 'quoted-printable',
    'ISO-2022-KR' => '7bit',
    'BIG5'        => '8bit',
    'GB-2312'     => '8bit',
    'HZ-GB-2312'  => '7bit',
    'UTF-7'       => '7bit',
    'UTF-8'       => '8bit',
);
%ENCODING_METHOD = (
    'quoted-printable' => sub { encode_quoted($_[0]); },
    'base64'           => sub { encode_base64($_[0], "\n"); },
);
%CONVERT_CHARSET = (
    'ISO-2022-JP' => \&jis,
);
%CONVERT_OPTION = (
    'jis'  => \&jis,
    'euc'  => \&euc,
    'sjis' => \&sjis,
);
%SUFFIX_TYPE = (
    'txt'   => 'text/plain',
    'html'  => 'text/html',
    'htm'   => 'text/html',
    'gif'   => 'image/gif',
    'jpg'   => 'image/jpeg',
    'jpeg'  => 'image/jpeg',
    'png'   => 'image/png',
    'tiff'  => 'image/tiff',
    'tif'   => 'image/tiff',
    'bmp'   => 'image/bmp',
);
%SUFFIX_ENCODE = (
    'Z'   => 'compress',
    'gz'  => 'gzip',
    'hqx' => 'x-hqx',
    'uu'  => 'x-uuencode',
    'z'   => 'x-pack',
    'bz2' => 'x-bzip2',
);
@DAY_OF_WEEK = qw(Sun Mon Tue Wed Thu Fri Sat);
@MON_OF_YEAR = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
@MON_OF_YEAR{ @MON_OF_YEAR } = (1..12);

my $read_media_file = 0;

sub jis  { jcode::jis( $_[0], $_[1], 'z'); }
sub euc  { jcode::euc( $_[0], $_[1], 'z'); }
sub sjis { jcode::sjis($_[0], $_[1], 'z'); }

sub new {
    my $class = shift;
    my $self = {};
    my($k, $v);
    while (($k, $v) = splice(@_, 0, 2)){
        $self->{lc($k)} = $v;
    }
    return bless $self, ref $class || $class;
}

sub encode_message {
    my $self = shift;
    my($parm, $k, $v);
    if(ref($_[0]) eq 'HASH'){
        $parm = shift;
    } else {
        $parm = {};
        while (($k, $v) = splice(@_, 0, 2)){
            $parm->{lc($k)} = $v;
        }
    }
    if($v = $self->{socket}){
        *putstring = *_send_sock;
        delete $parm->{bcc};
    } elsif($v = $self->{sendmail}){
        *putstring = *_send_file;
    } elsif($v = $self->{file}){
        *putstring = *_send_file;
    } else {
        *putstring = *_send_self;
        $self->{encode} = [];
        $v = $self;
    }
    $self->_encode_message($v, $parm) || return undef;
    if(defined $self->{encode}){
        return wantarray ? @{$self->{encode}} : $self->{encode};
    }
    return $self;
}

sub _encode_message {
    my $self = shift;
    my $out  = shift;
    my $parm = shift;
    my $dotskip = $parm->{dotskip} || undef;
    my $charset = $parm->{charset} || $DEFAULT_CHARSET;
    my $convert = $CONVERT_CHARSET{uc($charset)} || undef;
    my(%header, @header, $k, $v);
    foreach $k ('From', 'To', 'Cc', 'Bcc'){
        if($v = $parm->{lc($k)}){
            $v = join(',', @{$v}) if ref $v;
            $v =~ s/[\r\n]//go;
            putstring($out, _encode_address("$k: $v", $charset, $convert)."\n");
        }
    }
    if(defined $parm->{header}){
        while (($k, $v) = splice(@{$parm->{header}}, 0, 2)){
            $v .= "\n" if $v !~ /\n$/so;
            push(@header, join(': ', $k, _encode_envelope($v, $charset, $convert)));
            $header{lc($k)} = 1;
        }
    }
    unless(exists $header{subject}){
        $v = $parm->{subject} || '(none)';
        putstring($out, _encode_envelope("Subject: $v", $charset, $convert)."\n");
    }
    unless(exists $header{date}){
        putstring($out, join('', 'Date: ', time2local(), "\n"));
    }
    unless(exists $header{'message-id'}){
        $v = _message_id($parm->{sender} || $parm->{from});
        putstring($out, "Message-Id: <$v>\n");
    }
    unless(exists $header{'mime-version'}){
        putstring($out, "MIME-Version: 1.0\n");
    }
    foreach (@header){
        putstring($out, $_);
    }
    my(@boundary, $boundary, $type, $charcd, $encode, $textcnv, $textenc);
    my $content = (defined $parm->{content}) ? scalar @{$parm->{content}} : 0;
    my $attach  = (defined $parm->{attach})  ? keys   %{$parm->{attach}}  : 0;
    if($attach > 0){
        if($content > 0 || $attach > 1){
            $boundary = _boundary(10);
            $type = 'mixed';
        }
    } elsif($content > 1){
        $boundary = _boundary(10);
        $type = $parm->{multipart} || 'alternative';
    }
    if($boundary){
        putstring($out, "Content-Type: multipart/$type;\n boundary=\"$boundary\"\n\n");
        putstring($out, "This is multi-part message in MIME format.\n");
    }
    if($type eq 'mixed' && $content > 1){
        putstring($out, "\n--$boundary\n");
        push(@boundary, $boundary);
        $boundary = _boundary(10);
        $type = $parm->{multipart} || 'alternative';
        putstring($out, "Content-Type: multipart/$type;\n boundary=\"$boundary\"\n");
    }
    if($content){
        foreach $content (@{$parm->{content}}){
            $type = $content->{type} || 'text/plain';
            unless($charcd = $content->{charset}){
                if($type =~ m!^(?:text|message)/!oi){
                    $charcd = $charset || 'us-ascii';
                }
            }
            unless($encode = $content->{encode}){
                $encode = $DEFAULT_ENCODING{uc($charcd)} || '7bit';
            }
            $textcnv = $CONVERT_CHARSET{uc($charcd)} || undef;
            $textenc = $ENCODING_METHOD{lc($encode)} || undef;
            if($v = $content->{option}){
                if($v eq 'THRU'){
                    $textcnv = undef;
                    $textenc = undef;
                } elsif($v eq 'NOCONV'){
                    $textcnv = undef;
                } elsif($v eq 'NOENC'){
                    $textenc = undef;
                }
            }
            if($encode eq '7bit' && _is_ascii($content->{message}) == 0){
                unless($textcnv || $textenc){
                    $encode  = 'base64';
                    $textenc = $ENCODING_METHOD{$encode} || undef;
                }
            }
            $type .= "; charset=$charcd" if $charcd;
            if($v = $content->{name}){
                unless(_is_ascii($v)){
                    $v = &$convert($v) if ref $convert;
                    $v = join('', "=?$charset?B?", encode_base64($v, ""), '?=');
                }
                $type .= qq(;\n name="$v");
            }
            putstring($out, "\n--$boundary\n") if $boundary;
            putstring($out, "Content-Type: $type\n");
            putstring($out, "Content-Transfer-Encoding: $encode\n");
            putstring($out, "\n");
            if(ref $content->{message}){
                foreach (@{$content->{message}}){
                    $_ = &$textcnv($_) if ref $textcnv;
                    $_ = &$textenc($_) if ref $textenc;
                    unless($dotskip){
                        s/^\./../o; s/\n\./\n../go;
                    }
                    $_ .= "\n" unless /\n$/so;
                    putstring($out, $_);
                }
            } else {
                $_ = $content->{message};
                $_ = &$textcnv($_) if ref $textcnv;
                $_ = &$textenc($_) if ref $textenc;
                unless($dotskip){
                    s/^\./../o; s/\n\./\n../go;
                }
                $_ .= "\n" unless /\n$/so;
                putstring($out, $_);
            }
        }
        if(@boundary > 0){
            putstring($out, "\n--$boundary--\n");
            $boundary = pop(@boundary);
        }
    }
    if($attach){
        my($fail, $buff, $len, $fh);
        while (($k, $v) = each %{$parm->{attach}}){
            $fh = Symbol::gensym();
            if(open($fh, $v)){
                $type = _guess_media_type($v);
                unless(_is_ascii($k)){
                    $k = &$convert($k) if ref $convert;
                    $k = join('', "=?$charset?B?", encode_base64($k, ""), '?=');
                }
                putstring($out, "\n--$boundary\n") if $boundary;
                putstring($out, "Content-Type: $type;\n name=\"$k\"\n");
                putstring($out, "Content-Transfer-Encoding: base64\n");
                putstring($out, "Content-Disposition: attachment;\n filename=\"$k\"\n");
                putstring($out, "\n");
                binmode($fh);
                while ($len = read($fh, $buff, 57)){
                    unless(putstring($out, encode_base64(substr($buff, 0, $len), "")."\n")){
                        $fail = 1; last;
                    }
                }
                close $fh;
                if($fail){
                    die "Can't output attachment file: $v";
                }
            } else {
                die "File does not exist: $v";
            }
        }
    }
    putstring($out, "\n--$boundary--\n") if $boundary;
    1;
}

sub _encode_address {
    my $str = shift;
    my($charset, $convert) = @_;
    my $n = $str =~ s/\n$//so;
    my $res = "";
    foreach (split(/ *[,;] */, $str)){
        next unless $_;
        $res .= join(',', _encode_envelope($_, $charset, $convert), "\n ");
    }
    $res =~ s/ *,\n +$//so;
    $res .= "\n" if $n;
    $res;
}

sub _encode_envelope {
    my $str = shift;
    my($charset, $convert) = @_;
    my $n = $str =~ s/\n$//so;
    my($res, $fold, $s);
    my $len = 0;
    $str =~ s/^ +//so;
    $str =~ s/ +$//so;
    if(uc($charset) eq 'ISO-2022-JP'){  # support japanese character code only.
        $fold = $CONVERT_OPTION{euc};
    }
    foreach (split(/( *["':()<>] *)/, $str)){
        if(_is_ascii($_)){
            if(($len + length($_)) > 72){
                if($res =~ / $/so || /^ /so){
                    $res .= "\n "; $len = 1;
                }
            } elsif($res =~ /=\?[^=?]+\?B\?[^?]+\?=$/so){
                $res .= "\n "; $len = 1;
            }
            $res .= $_; $len += length($_);
        } else {
            if($len > 13){  # "Subject: Re: " is 13 chars...!?
                $res .= "\n "; $len = 1;
            }
            if($fold){
                $s = &$fold($_);
                while (1){
                    ($_, $s) = _part_string($s, 24);
                    $_ = &$convert($_, 'euc') if ref $convert;
                    $_ = join('', "=?$charset?B?", encode_base64($_, ""), '?=');
                    $res .= $_; $len += length($_);
                    if($s ne ""){
                        $res .= "\n "; $len = 1;
                    } else {
                        last;
                    }
                }
            } else {
                $_ = &$convert($_) if ref $convert;
                $_ = join('', "=?$charset?B?", encode_base64($_, ""), '?=');
                $res .= $_; $len += length($_);
            }
        }
    }
    $res .= "\n" if $n;
    $res;
}

sub _part_string {
    my $str = shift;
    my $len = shift;
    if($len < 1 || length($str) <= $len){
        return ($str, "");
    }
    my $s = substr($str, 0, $len);
    if($s =~ /\x8f$/o || $s =~ tr/\x8e\xa1-\xfe/\x8e\xa1-\xfe/ % 2){
        chop($s); $len--;
    }
    return ($s, substr($str, $len));
}

sub _message_id {
    my $addr = _get_addr($_[0]);
    my($host, $domain) = $addr =~ /^([^@]+)\@(.+)$/o;
    return join('', 'J', time2date('%Y%M%D%h%m%s'), '.', sprintf("%04d", $$), '.', uc($host), '@', $domain);
}

sub _boundary {
    my $size = shift || 10;
    my $b = encode_base64(join('', map chr(rand(256)), 1..$size*3), "");
    $b =~ s/[\W]/X/go;
    return join('_', '---', uc($b), "");
}

sub _is_ascii {
    if(ref($_[0])){
        foreach (@{$_[0]}){
            return 0 if /[^\t\r\n\x20-\x7e]/o;
        }
        return 1;
    } else {
        $_[0] =~ /[^\t\r\n\x20-\x7e]/o ? 0 : 1;
    }
}

sub _get_addr {
    my $s = shift;
    $s =~ s/\n//go;
    $s =~ s/ *\"[^"]*\" *//go;
    $s =~ s/ *\([^)]*\) *//go;
    if($s =~ /< *([^>]+) *>/o){
        $s = $1;
    }
    $s =~ s/^ +//o;
    $s =~ s/ +$//o;
    $s;
}

sub get_encode {
    my $self = shift;
    return undef unless defined $self->{encode};
    return wantarray ? @{$self->{encode}} : $self->{encode};
}

#-----------------------------------------------
#   Alias functions for input/output data
#-----------------------------------------------
sub _send_sock {
    my $sock = shift;
    unless($sock->write(@_)){
        die "Can't send message to socket.";
    }
    1;
}

sub _send_file {
    my $fh = shift;
    unless(print $fh @_){
        die "Can't write to file or pipe: $!";
    }
    1;
}

sub _send_self {
    my $self = shift;
    push(@{$self->{encode}}, @_);
    1;
}

#-----------------------------------------------
#   Media type setup and guess type
#-----------------------------------------------
sub _guess_media_type {
    my $file = shift;
    unless($read_media_file){
        $read_media_file = _read_media_types();
    }
    return undef unless defined $file;
    my($suffix, $ctype, $encode);
    if(($suffix) = $file =~ m!([^./:]+)$!o){
        $ctype  = $SUFFIX_TYPE{$suffix}   || $SUFFIX_TYPE{lc($suffix)};
        $encode = $SUFFIX_ENCODE{$suffix} || $SUFFIX_ENCODE{lc($suffix)};
    }
    $ctype ||= 'application/octet-stream';
    return wantarray ? ($ctype, $encode) : $ctype;
}

sub _add_media_type {
    my($type, @exts) = @_;
    foreach my $ext (@exts){
        $ext =~ s/^\.//o;
        $SUFFIX_TYPE{$ext} = $type;
    }
}

sub _read_media_types {
    my @files = (-f './media.types') ? ('./media.types') : map {"$_/media.types"} @INC;
    my($file, $type, @exts);
    my $fh = Symbol::gensym();
    foreach $file (@files){
        open($fh, "< $file") or next;
        while (<$fh>){
            next if /^ *#/o;
            next if /^ *$/o;
            s/[\s\t]*#.*//o;
            ($type, @exts) = split(/[\s\t]+/o);
            _add_media_type($type, @exts);
        }
        close $fh;
    }
    1;
}

#-----------------------------------------------
#   Time/Date conversion functions
#-----------------------------------------------
sub time2date {
    my($pat, $time, $zone) = @_;
    $time ||= time;
    $zone = $TIMEZONE unless defined $zone;
    my @t = gmtime($time + $zone);
    $t[5] += 1900;
    $t[4] += 1;
    if($pat){
        my %time = (
            'Y' => sprintf("%04d", $t[5]),
            'M' => sprintf("%02d", $t[4]),
            'D' => sprintf("%02d", $t[3]),
            'E' => sprintf("%02d", end_of_month($t[5], $t[4])),
            'h' => sprintf("%02d", $t[2]),
            'm' => sprintf("%02d", $t[1]),
            's' => sprintf("%02d", $t[0]),
            'd' => sprintf("%03d", $t[7]),
            'W' => $DAY_OF_WEEK[$t[6]],
        );
        $time{'y'} = substr($time{'Y'}, 2);
        $pat =~ s/%([DEMYWdhmsy])/$time{$1}/g;
    }
    return $pat || (@t[5, 4, 3, 2, 1, 0, 6, 7]);
}

sub time2local {
    my($time, $zone, $expr) = @_;
    $time ||= time;
    $zone = $TIMEZONE unless defined $zone;
    $expr = $ZONESTR  unless defined $expr;
    my @t = gmtime($time + $zone);
    sprintf("%s, %d %s %04d %02d:%02d:%02d $expr",
        $DAY_OF_WEEK[$t[6]],
        $t[3],
        $MON_OF_YEAR[$t[4]],
        $t[5]+1900,
        $t[2],
        $t[1],
        $t[0]);
}

sub end_of_month {
    my($year, $month) = @_;
    if($month == 2 && is_leap_year($year)){
        return (29);
    }
    (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)[--$month];
}

sub is_leap_year {
    my($year) = @_;
    return undef if(($year % 4) != 0);
    return undef if(($year % 100) == 0 && ($year % 400) != 0);
    1;
}

#-----------------------------------------------
#   Base64/QuotedPrintable/uuencode functions
#-----------------------------------------------
sub encode_base64 {
    my $str = shift;
    my($eol) = @_;
    $eol = "\n" unless defined $eol;
    my $res = "";
    pos($str) = 0;
    while ($str =~ /(.{1,45})/gso){
        $res .= substr(pack('u', $1), 1);
        chop($res);
    }
    $res =~ tr|` -_|AA-Za-z0-9+/|;
    if(my $pad = (3 - length($str) % 3) % 3){
        $res =~ s/.{$pad}$/'=' x $pad/e;
    }
    if(length($eol)){
        $res =~ s/(.{1,76})/$1$eol/g;
    }
    $res;
}

sub encode_quoted {
    my $str = shift;
    $str =~ s/([^ \t\n!-<>-~])/sprintf("=%02X", ord($1))/ego;
    $str =~ s/([ \t]+)$/join('', map { sprintf("=%02X", ord($_)) } split('', $1))/egmo;
    my $break = "";
    while ($str =~ s/(.*?^[^\n]{73}(?:[^=\n]{2}(?![^=\n]{0,1}$)|[^=\n](?![^=\n]{0,2}$)|(?![^=\n]{0,3}$)))//xsmo){
        $break .= "$1=\n";
    }
    return join('', $break, $str);
}

sub uuencode {
    my($dir, $file) = @_;
    my $fh = Symbol::gensym();
    open($fh, "< $dir/$file") or return undef;
    my $str = "begin 666 $file\n";
    my($len, $buff);
    while ($len = read($fh, $buff, 45)){
        $str .= pack("u", substr($buff, 0, $len));
    }
    close($fh);
    $str .= "\x60\nend\n";
    $str;
}

1;

__END__