path: root/fml/lib/Mail/Message/Encode.pm

#-*- perl -*-
#
#  Copyright (C) 2002,2003,2004 Ken'ichi Fukamachi
#   All rights reserved. This program is free software; you can
#   redistribute it and/or modify it under the same terms as Perl itself.
#
# $FML: Encode.pm,v 1.16 2003/11/08 05:56:22 fukachan Exp $
#

package Mail::Message::Encode;
use strict;
use vars qw(@ISA @EXPORT @EXPORT_OK $AUTOLOAD);
use Carp;

=head1 NAME

Mail::Message::Encode - encode/decode/charset conversion routines

=head1 SYNOPSIS

=head1 DESCRIPTION

=head1 METHODS

=head2 new()

standard constructor.

=cut


# Descriptions: standard constructor.
#    Arguments: OBJ($self) HASH_REF($args)
# Side Effects: load Encode or Jcode.
# Return Value: OBJ
sub new
{
    my ($self, $args) = @_;
    my ($type) = ref($self) || $self;
    my $me     = {};

    # XXX we do not use Encode yet, so disabled anyway.
    if (0 && $] > 5.008) {
	eval q{ use Encode;};
	croak("cannot load Encode") if $@;
    }
    elsif ($] <= 5.006001) {
	eval q{ use Jcode;};
	croak("cannot load Jcode") if $@;
    }

    # default language
    # XXX 'japanese' includes both Japanese and English.
    $me->{ _language } = 'japanese';

    return bless $me, $type;
}


=head2 detect_code($str)

speculate the code of $str string. $str is checked by
Unicode::Japanese. Unicode::Japanes::getcode() can detect the follogin
code: jis, sjis, euc, utf8, ucs2, ucs4, utf16, utf16-ge, utf16-le,
utf32, utf32-ge, utf32-le, ascii, binary, sjis-imode, sjis-doti,
sjis-jsky.

C<CAUTION>: we handle only Japanese and English.

=cut


# Descriptions: speculate code of $str string.
#    Arguments: OBJ($self) STR($str)
# Side Effects: none
# Return Value: STR
sub detect_code
{
    my ($self, $str) = @_;
    my $lang = $self->{ _language };

    # XXX-TODO: care for non Japanese.
    if ($lang eq 'japanese' || $lang eq 'english') {
	# getcode() can detect the follogin code:
	# jis, sjis, euc, utf8, ucs2, ucs4, utf16, utf16-ge, utf16-le,
	# utf32, utf32-ge, utf32-le, ascii, binary, sjis-imode,
	# sjis-doti, sjis-jsky.
	use Unicode::Japanese;
	my $obj = new Unicode::Japanese;
	return $obj->getcode($str);
    }
    else {
	carp("Mail::Message::Encode: unknown language");
	return 'unknown';
    }
}


# Unicode::Japanese
#           'jis', 'sjis', 'euc', 'utf8', 'ucs2', 'ucs4', 'utf16',
#           'utf16-ge', 'utf16-le', 'utf32', 'utf32-ge',
#           'utf32-le', 'ascii', 'binary', 'sjis-imode', 'sjis-
#           doti', 'sjis-jsky'.
#
# Jcode
#            ascii   Ascii (Contains no Japanese Code)
#            binary  Binary (Not Text File)
#            euc     EUC-JP
#            sjis    SHIFT_JIS
#            jis     JIS (ISO-2022-JP)
#            ucs2    UCS2 (Raw Unicode)
#            utf8    UTF8


=head2 convert($str, $out_code, $in_code)

convert $str to $out_code code.
$in_code is used as a hint.

=head2 convert_str_ref($str_ref, $out_code, $in_code)

convert string reference $str_str to $out_code code.
$in_code is used as a hint.

=cut


# Descriptions: convert $str to $out_code code.
#    Arguments: OBJ($self) STR($str) STR($out_code) STR($in_code)
# Side Effects: none
# Return Value: STR
sub convert
{
    my ($self, $str, $out_code, $in_code) = @_;
    my $status = $self->convert_str_ref(\$str, $out_code, $in_code);
    return $str;
}


# Descriptions: convert string reference $str_str to $out_code code.
#    Arguments: OBJ($self) STR_REF($str_ref) STR($out_code) STR($in_code)
# Side Effects: croak() if input data is invalid.
# Return Value: NUM(1/0)
sub convert_str_ref
{
    my ($self, $str_ref, $out_code, $in_code) = @_;
    my $lang = $self->{ _language };

    unless (ref($str_ref) eq 'SCALAR') {
	croak("convert_str_ref: invalid input data");
    }

    # XXX-TODO: care for non Japanese.
    if ($lang eq 'japanese' || $lang eq 'english') {
	# 1. if the encoding for the given $str_ref is unknown, return ASAP.
	unless (defined $in_code) {
	    $in_code = $self->detect_code($$str_ref);
	    if ($in_code eq 'unknown') {
		return 0;
	    }
	}
	else {
	    # print "1 ok\n";
	}

	# 2. try conversion ! (converted to 'euc' by default).
	if ($in_code) {
	    return $self->_jp_str_ref($str_ref, $out_code, $in_code);
	}
    }
    else {
	croak("Mail::Message::Encode: unknown language");
    }

    return 0;
}


# Descriptions: convert japanese string to $out_code.
#               XXX $in_code must be determined here !
#    Arguments: OBJ($self) STR_REF($str_ref) STR($out_code) STR($in_code)
# Side Effects: none
# Return Value: NUM(1/0)
sub _jp_str_ref
{
    my ($self, $str_ref, $out_code, $in_code) = @_;

    if ($out_code =~ /^(jis|sjis|euc)$|^(jis|sjis|euc)[-_]jp$/i) {
	my $code = $1 || $2;
	$code    =~ tr/A-Z/a-z/;

	use Jcode;
	&Jcode::convert($str_ref, $code, $in_code);

	return 1;
    }
    elsif ($out_code =~ /^(iso2022jp|iso-2022-jp)$/i) {
	use Jcode;
	&Jcode::convert($str_ref, 'jis', $in_code);

	return 1;
    }

    return 0;
}


=head2 run_in_code($proc, $s, $args, $out_code, $in_code)

run $proc($s) under $out_code environment.
So, execute $proc like this.

    my $obj         = new Mail::Message::Encode;
    my $conv_status = $obj->convert_str_ref($s, $out_code, $in_code);

    &$proc($s, $args);

It means run $proc() after $s is converted to $out_code code.

=cut


# Descriptions: run $proc($s) under $out_code environment.
#               It means run $proc() after $s is converted to $out_code code.
#    Arguments: OBJ($self) CODE_REF($proc) STR($s) HASH_REF($args)
#               STR($out_code) STR($in_code)
# Side Effects: none
# Return Value: none
sub run_in_code
{
    my ($self, $proc, $s, $args, $out_code, $in_code) = @_;
    my $proc_status = undef;

    my $obj         = new Mail::Message::Encode;
    my $conv_status = $obj->convert_str_ref($s, $out_code, $in_code);

    # XXX-TODO: validate $proc name regexp.
    eval q{
	$proc_status = &$proc($s, $args);
    };

    if ($conv_status && $out_code) {
	$obj->convert_str_ref($s, $out_code, $in_code);
    }

    return wantarray ? ($conv_status, $proc_status): $conv_status;
}


=head1 UTILITIES

=head2 is_iso2022jp_string($buf)

$buf looks like Japanese or not ?

=cut


# Descriptions: $buf looks like Japanese or not ?
#    Arguments: OBJ($self) STR($buf)
# Side Effects: none
# Return Value: NUM(1 or 0)
sub is_iso2022jp_string
{
    my ($self, $buf) = @_;
    return (not _look_not_iso2022jp_string($buf));
}


# Descriptions: $buf looks like Japanese or not ?
#               based on fml-support: 07020, 07029
#                  Koji Sudo <koji@cherry.or.jp>
#                  Takahiro Kambe <taca@sky.yamashina.kyoto.jp>
#               check the given buffer has unusual Japanese (not ISO-2022-JP)
#    Arguments: STR($buf)
#      History: imported fml 4.0 functions.
# Side Effects: none
# Return Value: NUM(1 or 0)
sub _look_not_iso2022jp_string
{
    my ($buf) = @_;

    # trivial check;
    return 0 unless defined $buf;
    return 0 unless $buf;

    # check 8 bit on
    if ($buf =~ /[\x80-\xFF]/){
        return 1;
    }

    # check SI/SO
    if ($buf =~ /[\016\017]/) {
        return 1;
    }

    # HANKAKU KANA
    if ($buf =~ /\033\(I/) {
        return 1;
    }

    # MSB flag or other control sequences
    if ($buf =~ /[\001-\007\013\015\020-\032\034-\037\177-\377]/) {
        return 1;
    }

    0; # O.K.
}


=head1 BACKWARD COMPATIBILITY

=head2 STR2EUC($str)

convert $str to japanese EUC code.

=head2 STR2JIS($str)

convert $str to japanese JIS code.

=head2 STR2SJIS($str)

convert $str to japanese SJIS code.

=cut


# Descriptions: convert $str to euc.
#    Arguments: STR($str)
# Side Effects: none
# Return Value: STR
sub STR2EUC
{
    my ($str) = @_;
    my $obj = new Mail::Message::Encode;
    $obj->convert( $str, 'euc-jp' );
}


# Descriptions: convert $str to sjis.
#    Arguments: STR($str)
# Side Effects: none
# Return Value: STR
sub STR2SJIS
{
    my ($str) = @_;
    my $obj = new Mail::Message::Encode;
    $obj->convert( $str, 'sjis-jp' );
}


# Descriptions: convert $str to jis.
#    Arguments: STR($str)
# Side Effects: none
# Return Value: STR
sub STR2JIS
{
    my ($str) = @_;
    my $obj = new Mail::Message::Encode;
    $obj->convert( $str, 'jis-jp' );
}


=head1 MIME ENCODE

=head2 encode_mime_string($str, $encode, $out_code, $in_code)

encode string $str to encoding system $encode with output code $out_code.
$in_code is used as a hint.

=cut


# Descriptions: encode string.
#    Arguments: OBJ($self) STR($str) STR($encode) STR($out_code) STR($in_code)
# Side Effects: croak() if language is unknown.
# Return Value: STR
sub encode_mime_string
{
    my ($self, $str, $encode, $out_code, $in_code) = @_;
    my $lang     = $self->{ _language };
    my $str_orig = $str;
    my $str_out  = '';

    # base64 encoding by default.
    $encode ||= 'base64';

    # code by default
    if ($lang eq 'japanese') {
	$out_code ||= 'jis';
	$str = $self->convert($str, $out_code, $in_code);
    }
    else {
	croak("Mail::Message::Encode: unknown language");
    }

    if ($encode eq 'base64') {
	eval q{
	    use IM::Iso2022jp;
	    $str_out = line_iso2022jp_mimefy($str);
	};
    }
    elsif ($encode eq 'qp') {
	eval q{
	    use IM::Iso2022jp;
	    $main::HdrQEncoding = 1;
	    $str_out = line_iso2022jp_mimefy($str);
	    $main::HdrQEncoding = 0;
	};
    }
    else {
	croak("Mail::Message::Encode: unknown encoding");
    }

    return $str_out ? $str_out : $str_orig;
}


=head2 base64($str, $out_code, $in_code)

encode $str by base64 with out code out_code.
$in_code is use as a hint.

=head2 qp($str, $out_code, $in_code)

encode $str by quoted-printable with out code out_code.
$in_code is use as a hint.

=cut


# Descriptions: encode $str by base64.
#    Arguments: OBJ($self) STR($str) STR($out_code) STR($in_code)
# Side Effects: none
# Return Value: STR
sub base64
{
    my ($self, $str, $out_code, $in_code) = @_;
    $self->encode_mime_string($str, 'base64', $out_code, $in_code);
}


# Descriptions: encode $str by quoted-printable.
#    Arguments: OBJ($self) STR($str) STR($out_code) STR($in_code)
# Side Effects: none
# Return Value: STR
sub qp
{
    my ($self, $str, $out_code, $in_code) = @_;
    $self->encode_mime_string($str, 'qp', $out_code, $in_code);
}


=head2 decode_mime_string(string, [$options])

decode a base64/quoted-printable encoded string to a plain message.
The encoding method is automatically detected.

C<$options> is a HASH REFERENCE.
You can specify the charset of the string to return
by $options->{ charset }.

[reference] RFC1554 says:

      reg#  character set      ESC sequence                designated to
      ------------------------------------------------------------------
      6     ASCII              ESC 2/8 4/2      ESC ( B    G0
      42    JIS X 0208-1978    ESC 2/4 4/0      ESC $ @    G0
      87    JIS X 0208-1983    ESC 2/4 4/2      ESC $ B    G0
      14    JIS X 0201-Roman   ESC 2/8 4/10     ESC ( J    G0
      58    GB2312-1980        ESC 2/4 4/1      ESC $ A    G0
      149   KSC5601-1987       ESC 2/4 2/8 4/3  ESC $ ( C  G0
      159   JIS X 0212-1990    ESC 2/4 2/8 4/4  ESC $ ( D  G0
      100   ISO8859-1          ESC 2/14 4/1     ESC . A    G2
      126   ISO8859-7(Greek)   ESC 2/14 4/6     ESC . F    G2

=cut


# Descriptions: decode MIME string.
#    Arguments: OBJ($self) STR($str) STR($out_code) STR($in_code)
# Side Effects: croak() if language is unknown.
# Return Value: STR
sub decode_mime_string
{
    my ($self, $str, $out_code, $in_code) = @_;
    my $lang    = $self->{ _language };
    my $str_out = '';

    unless ($str) { return $str;}

    if ($lang eq 'japanese') {
	eval q{
	    use IM::EncDec;
	    $str_out = mime_decode_string( $str );
	};

	return $str if $@;

	# XXX IM returns "ESC$(B ... " string but
	# XXX mule 2.3 cannot read "ESC$(B ... ESC(B" string as JIS.
	# XXX ng detects it as ASCII.
	# XXX Whereas, w3m looks to be able to read it ?
	$str_out   =~ s/^\e\$\(B/\e\$B/; # make mule read this string.
	$in_code   = $self->detect_code($str_out);
	$out_code |= 'euc-jp'; # euc-jp by default.
    }
    else {
	croak("Mail::Message::Encode: unknown language");
    }

    return $self->convert($str_out, $out_code, $in_code);
}


# Descriptions: decode MIME base64 encoded-string
#    Arguments: OBJ($self) STR($str) STR($out_code) STR($in_code)
# Side Effects: croak() if language is unknown.
# Return Value: STR
sub decode_base64_string
{
    my ($self, $str, $out_code, $in_code) = @_;
    my $lang    = $self->{ _language };
    my $str_out = undef;

    if ($lang eq 'japanese') {
	eval q{
	    use MIME::Base64;
	    $str_out = decode_base64( $str );
	};

	return $str if $@;

	$in_code   = $self->detect_code($str_out);
	$out_code |= 'euc-jp'; # euc-jp by default.
    }
    else {
	croak("Mail::Message::Encode: unknown language");
    }

    return $self->convert($str_out, $out_code, $in_code);
}


# Descriptions: decode MIME quoted-printable encoded-string
#    Arguments: OBJ($self) STR($str) STR($out_code) STR($in_code)
# Side Effects: croak() if language is unknown.
# Return Value: STR
sub decode_qp_string
{
    my ($self, $str, $out_code, $in_code) = @_;
    my $lang    = $self->{ _language };
    my $str_out = undef;

    if ($lang eq 'japanese') {
	eval q{
	    use MIME::QuotedPrint;
	    $str_out = decode_qp( $str );
	};
	return $str if $@;

	$in_code   = $self->detect_code($str_out);
	$out_code |= 'euc-jp'; # euc-jp by default.
    }
    else {
	croak("Mail::Message::Encode: unknown language");
    }

    return $self->convert($str_out, $out_code, $in_code);
}


=head1 DEBUG

=head2 str_dump($str)

=cut


# Descriptions: dump $str as the style by "od -a".
#    Arguments: OBJ($self) STR($str)
# Side Effects: none
# Return Value: none
sub str_dump
{
    my ($self, $str) = @_;

    $| = 1;
    use FileHandle;
    my $th = new FileHandle "|od -a";
    if (defined $th) {
	print $th $str;
	$th->close();
    }
}


#
# debug
#
if ($0 eq __FILE__) {
    $| = 1;

    my $obj = new Mail::Message::Encode;
    my $str = "�ۤ� �Ȥ����Х����ɥ���ץ��������� KERO   �ˣţңϤ����";
    my $str0;

    print "=> test string\n";
    print $str, "\n";

    for my $fp (qw(base64 qp)) {
	print "\n=> $fp\n";
	{
	    my $s0  = $obj->base64($str);
	    my $s1  = $obj->decode_mime_string($s0);
	    my $s2  = $obj->base64($s1);
	    print $s0, "\n";
	    print $s1, "\n";
	    print "   encode/decode/encode == encode ? ";
	    print $s0 eq $s2 ? "ok\n" : "fail.\n";
	}
    }

    print "\n=> str code is <";
    print $obj->detect_code($str), ">\n";

    for my $code (qw(jis sjis euc)) {
	print "\n=> convert_str_ref($code)   \tresult is <";
	$obj->convert_str_ref(\$str, $code);
	print $obj->detect_code($str), ">/";

	{
	    use Jcode;
	    my ($c) = &Jcode::getcode( $str );
	    print "<$c>\n";
	}
    }

    $str0 = STR2EUC( $str );
    print "\n=> STR2EUC  ? = <", $obj->detect_code($str0), ">\n";

    $str0 = STR2SJIS( $str );
    print "\n=> STR2SJIS ? = <", $obj->detect_code($str0), ">\n";

    $str0 = STR2JIS( $str );
    print "\n=> STR2JIS  ? = <", $obj->detect_code($str0), ">\n";
}


=head1 CODING STYLE

See C<http://www.fml.org/software/FNF/> on fml coding style guide.

=head1 AUTHOR

Ken'ichi Fukamachi

=head1 COPYRIGHT

Copyright (C) 2002,2003,2004 Ken'ichi Fukamachi

All rights reserved. This program is free software; you can
redistribute it and/or modify it under the same terms as Perl itself.

=head1 HISTORY

Mail::Message::Encode first appeared in fml8 mailing list driver package.
See C<http://www.fml.org/> for more details.

=cut


1;