| Current Path : /usr/opt/perl530/lib/site_perl/5.30.2/ADN/ |
FreeBSD hs32.drive.ne.jp 9.1-RELEASE FreeBSD 9.1-RELEASE #1: Wed Jan 14 12:18:08 JST 2015 root@hs32.drive.ne.jp:/sys/amd64/compile/hs32 amd64 |
| Current File : //usr/opt/perl530/lib/site_perl/5.30.2/ADN/MIME.pm |
package ADN::MIME;
#
# MIME.pm:
#
#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
#// use Module
#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
use strict;
use Exporter ();
use vars qw( @ISA @EXPORT @EXPORT_OK $VERSION );
use Jcode;
#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
#// Exporting
#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
@ISA = qw( Exporter );
$VERSION = 1.00;
@EXPORT = qw( HeaderDecode BodyDecode base64decode qpdecode
HeaderEncode BodyEncode base64encode qpencode );
@EXPORT_OK = qw( convert );
#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
#// Module (Decode)
#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
#// ----------------------------------------------------------
#// HeaderDecode
#//
#// 引数 ($target, $conv)
#// $target : 対象文字列
#// $conv : 変換する文字コード
#//
#// 戻値 $target
#// ----------------------------------------------------------
sub HeaderDecode {
my ($target, $conv) = @_;
my $match_mime = '=\?[Ii][Ss][Oo]-2022-[Jj][Pp]\?';
if ($target =~ /$match_mime[Qq]\?/) {
$match_mime .= '[Qq]\?(.+)\?=';
1 while $target =~ s/($match_mime)[ \t]*\n?[ \t]+($match_mime)/$1$3/o;
$target =~ s/$match_mime/convert(qpdecode($1), $conv)/geo;
} elsif ($target =~ /$match_mime[Bb]\?/) {
$match_mime .= '[Bb]\?([0-9a-zA-Z\+\/\=]+)=*\?=';
1 while $target =~ s/($match_mime)[ \t]*\n?[ \t]+($match_mime)/$1$3/o;
$target =~ s/$match_mime/convert(base64decode($1), $conv)/geo;
} else {
$target = convert($target, $conv);
}
$target =~ s/(\x1b[\$\(][BHJ@])+/$1/g;
$target =~ s/(\x1b\$[B@][\x21-\x7e]+)\x1b\$[B@]/$1/g;
$target =~ s/(\x1b\([BHJ][\t\x20-\x7e]+)\x1b\([BHJ]/$1/g;
$target =~ s/^([\t\x20-\x7e]*)\x1b\([BHJ]/$1/g;
return $target;
}
#// ----------------------------------------------------------
#// BodyDecode
#//
#// 引数 ($target, $code)
#// $target : 対象文字列
#// $conv : qp or b64
#//
#// 戻値 $target
#// ----------------------------------------------------------
sub BodyDecode {
my ($target,$code) = @_;
my $cut = 0;
if ($code eq "qp") {
return qpdecode($target);
} else {
$target =~ s/[^0-9a-zA-Z\+\/\=]//g;
$cut = int((length $target)/4)*4;
$target = substr($target, $[, $cut);
return base64decode($target);
}
}
#// ----------------------------------------------------------
#// base64decode
#// ----------------------------------------------------------
sub base64decode {
local($^W) = 0;
my $target = shift;
my %code = (
'A' => '000000', 'B' => '000001', 'C' => '000010', 'D' => '000011',
'E' => '000100', 'F' => '000101', 'G' => '000110', 'H' => '000111',
'I' => '001000', 'J' => '001001', 'K' => '001010', 'L' => '001011',
'M' => '001100', 'N' => '001101', 'O' => '001110', 'P' => '001111',
'Q' => '010000', 'R' => '010001', 'S' => '010010', 'T' => '010011',
'U' => '010100', 'V' => '010101', 'W' => '010110', 'X' => '010111',
'Y' => '011000', 'Z' => '011001',
'a' => '011010', 'b' => '011011', 'c' => '011100', 'd' => '011101',
'e' => '011110', 'f' => '011111', 'g' => '100000', 'h' => '100001',
'i' => '100010', 'j' => '100011', 'k' => '100100', 'l' => '100101',
'm' => '100110', 'n' => '100111', 'o' => '101000', 'p' => '101001',
'q' => '101010', 'r' => '101011', 's' => '101100', 't' => '101101',
'u' => '101110', 'v' => '101111', 'w' => '110000', 'x' => '110001',
'y' => '110010', 'z' => '110011',
'0' => '110100', '1' => '110101', '2' => '110110', '3' => '110111',
'4' => '111000', '5' => '111001', '6' => '111010', '7' => '111011',
'8' => '111100', '9' => '111101', '+' => '111110', '/' => '111111',
);
$target = join('', @code{split(//, $target)});
$target = pack("B".(length($target)>>3<<3), $target);
return $target;
}
#// ----------------------------------------------------------
#// qpdecode
#// ----------------------------------------------------------
sub qpdecode {
my $target = shift;
$target =~ s/^([\s\t]+)//g;
$target =~ s/=\r?\n//g;
$target =~ s/=([0-9A-Fa-f]{2})/pack("C", hex($1))/ge;
return $target;
}
#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
#// Module (Encode)
#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
#// ----------------------------------------------------------
#// HeaderEncode
#//
#// 引数 $target
#//
#// 戻値 $str (MIME B Encode)
#// ----------------------------------------------------------
sub HeaderEncode {
my $target = shift;
my $match_ascii = '\x1b\([BHJ]([\t\x20-\x7e]*)'; #// _headerencode
my $match_jis = '\x1b\$[@B](([\x21-\x7e]{2})*)';
my $match_sjis = '([\x81-\x9f\xe0-\xfc][\x40-\x7e\x80-\xfc])+';
my $match_euc = '([\xa1-\xfe]{2})+';
#// Escape Sequence
my $in = '\x1b\$B';
my $out = '\x1b\(B';
#// Start
my $sjis = 0; my $euc = 0; my $code = '';
$target =~ s/$match_jis/$in$1/go;
$target =~ s/$match_ascii/$out$1/go;
$sjis += length($&) while $target =~ /$match_sjis/go;
$euc += length($&) while $target =~ /$match_euc/go;
if ($sjis == 0 && $euc == 0) { $code = 'none'; }
if ($sjis > $euc) { $code = 'sjis'; }
if ($sjis < $euc) { $code = 'euc'; }
if ($code eq "") { $code = 'euc'; }
$target =~ s/$match_sjis/convert($&,'jis')/geo if ($code eq "sjis");
$target =~ s/$match_euc/convert($&,'jis')/geo if ($code eq "euc");
$target =~ s/(\x1b[\$\(][BHJ@])+/$1/g;
1 while $target =~ s/(\x1b\$[B@][\x21-\x7e]+)\x1b\$[B@]/$1/;
1 while $target =~ s/$match_jis/_headerencode($&, $`, $')/eo;
$target =~ s/$match_ascii/$1/go;
$target =~ s/\s\n$/\n/;
return $target;
}
sub _headerencode {
my ($target, $before, $after) = @_;
my $back = ''; my $forw = ''; my $str = '';
my $blen = 0; my $flen = 0; my $len = 0;
my $limit = 74;
my $match_ascii = '\x1b\([BHJ]([\t\x20-\x7e]*)';
#// MIME head/tail
my $mime_head = '=?ISO-2022-JP?B?';
my $mime_tail = '?=';
#// Escape Sequence
my $in = "\x1b\$B";
my $out = "\x1b\(B";
#// JIS code byte count
my %mimelen = (
8,30, 10,34, 12,34, 14,38, 16,42,
18,42, 20,46, 22,50, 24,50, 26,54,
28,58, 30,58, 32,62, 34,66, 36,66,
38,70, 40,74, 42,74,
);
#// Ready
$before = substr($before, rindex($before, "\n") + 1);
$after = substr($after, 0, index($after, "\n") - $[);
$back = " " unless ($before eq "" ||
$before =~ /[ \t\(]$/);
$forw = " " unless ($after =~ /^\x1b\([BHJ]$/ ||
$after =~ /^\x1b\([BHJ][ \t\)]/);
$blen = length($before);
$flen = length($forw) + length($&) - 3 if ($after =~ /^$match_ascii/o);
$len = length($target);
#// Start
if ($len <= 3) { return ''; }
if ($len > 39 || $blen + $mimelen{$len+3} > $limit) {
if ($limit - $blen < 30) {
$len = 0;
} else {
$len = int(($limit - $blen - 26) / 4) * 2 + 3;
}
if ($len >= 5) {
$str = substr($target, 0, $len) . $out;
$str = base64encode($str);
$str = $mime_head . $str . $mime_tail;
$str = $back . $str . "\n " . $in . substr($target, $len);
} else {
$str = "\n " . $target;
}
} else {
$target .= $out;
$target = base64encode($target);
$target = $back . $mime_head . $target . $mime_tail;
if ($blen + (length $target) + $flen > $limit) {
$str = $target . "\n ";
} else {
#$str = $target . $forw;
$str = $target;
}
}
return $str;
}
#// ----------------------------------------------------------
#// BodyEncode
#//
#// 引数 ($target, $code)
#// $target: 対象文字列
#// $conv: qp or b64
#//
#// 戻値 $target
#// ----------------------------------------------------------
sub BodyEncode {
my ($target, $code) = @_;
my $foldcol = 72; #// length per line
my $size = int($foldcol / 4) * 3;
if ($code eq "qp") {
$target =~ s/\r\n/\n/g; $target =~ s/\r/\n/g;
my $result = '';
my @line = split(/\n/, $target, -1);
my $buf = pop(@line);
foreach (@line) { $result .= qpencode($_) . "\n"; }
if ($buf ne '') {
$result .= qpencode($buf) . "\n";
}
return $result;
} else { #// Base64
my $cut = int((length $target) / $size) * $size;
my $buf = substr($target, $cut+$[);
$target = substr($target, $[, $cut);
$target = base64encode($target);
$target =~ s/.{$foldcol}/$&\n/g;
if ($buf ne '') {
$target .= base64encode($buf);
}
return $target;
}
}
#// ----------------------------------------------------------
#// base64encode
#// ----------------------------------------------------------
sub base64encode {
my %mime = (
'000000' => 'A', '000001' => 'B', '000010' => 'C', '000011' => 'D',
'000100' => 'E', '000101' => 'F', '000110' => 'G', '000111' => 'H',
'001000' => 'I', '001001' => 'J', '001010' => 'K', '001011' => 'L',
'001100' => 'M', '001101' => 'N', '001110' => 'O', '001111' => 'P',
'010000' => 'Q', '010001' => 'R', '010010' => 'S', '010011' => 'T',
'010100' => 'U', '010101' => 'V', '010110' => 'W', '010111' => 'X',
'011000' => 'Y', '011001' => 'Z',
'011010' => 'a', '011011' => 'b', '011100' => 'c', '011101' => 'd',
'011110' => 'e', '011111' => 'f', '100000' => 'g', '100001' => 'h',
'100010' => 'i', '100011' => 'j', '100100' => 'k', '100101' => 'l',
'100110' => 'm', '100111' => 'n', '101000' => 'o', '101001' => 'p',
'101010' => 'q', '101011' => 'r', '101100' => 's', '101101' => 't',
'101110' => 'u', '101111' => 'v', '110000' => 'w', '110001' => 'x',
'110010' => 'y', '110011' => 'z',
'110100' => '0', '110101' => '1', '110110' => '2', '110111' => '3',
'111000' => '4', '111001' => '5', '111010' => '6', '111011' => '7',
'111100' => '8', '111101' => '9', '111110' => '+', '111111' => '/',
);
my @zero = ( "", "00000", "0000", "000", "00", "0" );
my @pad = ( "", "===", "==", "=" );
my $encode = '';
$encode = unpack("B".((length $_[0])<<3), $_[0]);
$encode .= $zero[(length $encode)%6];
$encode =~ s/.{6}/$mime{$&}/go;
return $encode . $pad[(length $encode)%4];
}
#// ----------------------------------------------------------
#// qp64encode
#// ----------------------------------------------------------
sub qpencode {
my $target = shift;
my $qfoldcol = 75; #// chars per line
my $result = ''; my $line = '';
$target =~ s/=/=3D/g;
$target =~ s/\t$/=09/; $target =~ s/\s$/=20/;
$target =~ s/([^!-~ \t])/_qphex($1)/ge;
while (length($target) > $qfoldcol){
$line = substr($target, 0, $qfoldcol-1);
if ($line =~ /=$/){
$line = substr($target, 0, $qfoldcol-2);
$target = substr($target, $qfoldcol-2);
} elsif ($line =~ /=[0-9A-Fa-f]$/){
$line = substr($target, 0, $qfoldcol-3);
$target = substr($target, $qfoldcol-3);
} else {
$target = substr($target, $qfoldcol-1);
}
$result .= "$line=\n";
}
return $result . $target;
}
sub _qphex {
my $target = shift;
$target = '=' . unpack("H2", $target);
$target =~ tr/a-f/A-F/;
return $target;
}
#// ----------------------------------------------------------
#// Japanese Convert Wrap
#// ----------------------------------------------------------
sub convert {
my ($target, $code) = @_;
Jcode::convert(\$target, $code);
return $target;
}
1;