| 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/MailParse.pm |
package ADN::MailParse;
#
# MailParse.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( );
@EXPORT_OK = qw( );
#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
#// Constructor
#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
sub new {
my $class = shift;
my $self = {};
bless $self, $class;
return $self;
}
#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
#// Module (Parse)
#// -=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
#// ----------------------------------------------------------
#// header
#//
#// 引数 ($self, @header, \@mail)
#// $self : クラスオブジェクト
#// @header : メールヘッダ (正規表現可能)
#// \@mail : 対象 1 メール全文
#//
#// 戻値
#// @header : 該当ヘッダの値
#// ----------------------------------------------------------
sub header {
my $self = shift; my $ref = pop; my @header0 = @_;
#// ----------------------------------------------------------
#// Ready
#// ----------------------------------------------------------
my $header = {};
foreach (@header0) {
$_ =~ tr/A-Z/a-z/;
if ($_ =~ /Mother/i) {
$header->{'in-reply-to'} = '';
$header->{'references'} = '';
} else {
$header->{$_} = '';
}
}
#// ----------------------------------------------------------
#// Parse
#// ----------------------------------------------------------
my $list = ''; my $item = ''; my $count = 0; my @received = ();
foreach my $line (@$ref) {
$line =~ s/\r//g;
last if ($line =~ /^\n$/);
if ($line =~ /^([0-9a-zA-Z\-]+): (.+)/) {
if ($count == 1) {
if ($list =~ /Received/i) {
push(@received, _convert($header->{$list}, 1));
} else {
$header->{$list} = _convert($header->{$list}, 1);
}
}
$count = 0;
$list = $1; $list =~ s/: //; $list =~ tr/A-Z/a-z/;
$item = $2;
if (exists $header->{$list}) {
$count = 1;
$header->{$list} = ($list =~ /Received/i) ? $line : $item;
}
} else {
if (exists $header->{$list}) { $header->{$list} .= $line; }
}
}
#// ----------------------------------------------------------
#// Push
#// ----------------------------------------------------------
my @header = ();
foreach (@header0) {
$_ =~ tr/A-Z/a-z/;
if ($_ =~ /Received/i) {
push(@header, \@received);
} else {
my $item = $header->{$_};
if ($_ =~ /Message-Id/i) {
$item =~ s/^(.+)</</g; $item =~ s/>(.+)$/>/g;
}
if ($_ =~ /Mother/i) {
my $check0 = $header->{'in-reply-to'};
$check0 =~ s/^(.+)<//g;
$check0 =~ s/>(.+)$//g;
$check0 =~ s/[<>]//g;
$check0 =~ s/^(\s+)//g;
$check0 =~ s/(\s+)$//g;
if ($check0 eq '' || $check0 =~ /\d\d:\d\d/) {
my $check1 = $header->{'references'};
$check1 =~ s/[<>]/ /g;
$check1 =~ s/^(\s+)//g;
$check1 =~ s/(\s+)$//g;
$check1 =~ s/(\s+)/ /g;
my @check = split(/ /, $check1);
$item = pop(@check);
} else {
$item = $check0;
}
}
push(@header, $item);
}
}
return @header;
}
#// ----------------------------------------------------------
#// body
#//
#// 引数 ($self, $mail)
#// $self : クラスオブジェクト
#// $mail : 対象 1 メール全文 (配列リファレンス)
#//
#// 戻値 ($body, $file, $show, $mime, $code, $count)
#// $body : テキスト本文
#// $file : 添付ファイル システム名 (配列リファレンス)
#// $show : 添付ファイル 実表示名 (配列リファレンス)
#// $mime : 添付ファイル 実体 (配列リファレンス)
#// $code : 添付ファイル エンコード (配列リファレンス)
#// $count : 添付ファイル 個数
#// ----------------------------------------------------------
sub body {
my ($self, $ref) = @_;
my $file0 = ''; my $show0 = ''; my $code0 = '';
my $check0 = 0; #my $text0 = 0;
my $body_set = 0; my $body = ''; my $boundary = '';
foreach my $line (@$ref) {
$line =~ s/\r//g;
if ($line =~ /^\n$/) { $body_set = 1; }
if ($body_set == 1) {
next if ($line =~ /^This is a multi([\-part]+)([ MIME]+)message/);
=comment
ここで改良した _body に入れる。
(\$body, \@file, \@show, \@mime, \@code, $count) = _body(\$body, \@file, \@show, \@mime, \@code, $count); のような感じ。
=cut
Jcode::convert(\$line, 'euc');
$body .= $line;
$body =~ s/^\n//;
} else {
if ($line =~ /^Content-Transfer-Encoding: /i) {
$code0 = _encoding($line);
}
if ($line =~ /name([\*\=]+)(.+)/i && $check0 != 1) {
$line = $2; $line =~ s/\"//g;
$file0 = _convert($line, 1);
$show0 = $file0;
if ($file0 =~ /[\xa1-\xf4][\xa1-\xfe]/ ||
$file0 =~ /\x8e[\xa1-\xdf]/)
{
$file0 =~ s/(.+)\.(\w+)$/attach0\.$2/;
}
$file0 =~ tr/ /_/; $check0 = 1;
}
if ($line =~ /boundary\=/i) {
$boundary = _boundary($line);
}
}
}
_body($body, $boundary, $file0, $show0, $code0);
}
sub _body {
my ($line0, $attach, $file0, $show0, $code0) = @_;
my @line = split(/\n/, $line0);
my $line = ''; my $body = ''; my $body0 = ''; my $attach1 = '';
my $count = 0; my $flag = 0; my $check = 0;
my $text = 0; my $html = 0; my $mail = 0; my $type = '';
my $file = ''; my $show = ''; my $mime = ''; my $code = '';
my @file = (); my @show = (); my @mime = (); my @code = ();
if ($file0 ne "") {
push(@file, $file0);
push(@show, $show0);
push(@code, $code0);
$file = $file0; $show = $show0;
$code = $code0; $text = 1;
$flag = 2; $count += 1;
}
foreach $line (@line) {
$line .= "\n";
if ($line eq "--$attach\n") {
if ($file eq "") {
if ($code ne "") {
$body0 = ADN::MIME::BodyDecode($body0, $code);
$body0 = _convert($body0, 0);
}
$body .= $body0; $body0 = '';
} else {
$mime =~ s/\n$//g;
push(@mime, $mime);
$file = $show = $mime = $code = '';
$text = $html = $mail = $check = 0;
}
$flag = 1;
#if ($attach1 ne '') { $attach = $attach1; $attach1 = ''; }
}
#// Plain Text
if ($flag == 0) { $body .= $line; }
#// In Header of boundray
if ($flag == 1) {
if ($line =~ /^Content-/) { $check = 0; }
if ($check == 1) { $file .= _convert($line, 1); }
if ($line =~ /^Content-Type: text\/plain/i) { $text = 1; }
if ($line =~ /^Content-Type: Message\/Rfc822/i) { $mail = 1; }
if ($line =~ /^Content-Type: text\/html/i) { $html = 1; }
if ($line =~ /Content-Type: ([0-9a-zA-Z]+)\/([0-9a-zA-Z]+);/) {
$type = $2; $type =~ tr/A-Z/a-z/;
}
if ($line =~ /^Content-Transfer-Encoding: /i) {
$code = _encoding($line);
}
if ($line =~ /name=["](.+)/i && $check == 0 && $file eq '') {
$file = $1;
$file = _convert($file, 1);
$check = 1;
}
if ($line =~ /name\*(["=]+)(.+)/i && $check == 0 && $file eq '') {
$file = $2;
$file = ADN::Utility::urldecode($file);
$file =~ s/(.+)\'\'(.+)/$2/;
Jcode::convert(\$file, 'euc');
$check = 2;
}
if ($line =~ /boundary\=/i) {
$attach1 = $attach;
$attach = _boundary($line);
}
#// before attach
if ($line =~ /^\n$/) {
$flag = 2;
#// filename
$file =~ s/[\" ]//g;
$show = $file;
if ($file =~ /[\xa1-\xf4][\xa1-\xfe]/ ||
$file =~ /\x8e[\xa1-\xdf]/)
{
my $ext = '';
if ($file =~ /(.+)\.(\w+)$/) {
$ext .= '.' . $2;
} else {
$ext .= '.' . $type;
$ext =~ s/\.$//;
}
$file = 'attach' . $count . $ext;
}
if ($line eq '') { $show = $file = 'attach' . $count; }
#// html, mail
if ($file eq '' && $html == 1) {
$show = $file = "file_html$count";
}
if ($file eq '' && $mail == 1) {
$show = $file = "file_mail$count";
}
if ($file ne '') {
push(@file, $file);
push(@show, $show);
push(@code, $code);
$count += 1;
}
}
}
#// Join
if ($flag == 2) {
if ($line =~ /^\n$/) {
next unless ($text == 1 || $html == 1 || $mail == 1);
}
if ($line eq "--$attach--\n") {
if ($file eq "") {
if ($code ne "") {
$body0 = ADN::MIME::BodyDecode($body0, $code);
$body0 = _convert($body0, 0);
}
$body .= $body0; $body0 = '';
} else {
$mime =~ s/\n$//g;
push(@mime, $mime);
$file = $show = $mime = $code = '';
$text = $html = $mail = $check = 0;
}
if ($attach1 ne '') {
$attach = $attach1; $attach1 = '';
$flag = 1;
}
} else {
if ($file eq "") {
$body0 .= $line;
$body0 =~ s/^\n//g;
} else {
$mime .= $line;
$mime =~ s/^\n//g;
}
}
}
}
#// Final
$body =~ s/^\n//; $body =~ s/\n$//;
if ($mime ne "") {
$mime =~ s/\n$//g;
push(@mime, $mime);
}
if ($code0 ne "") {
$body = ADN::MIME::BodyDecode($body, $code0);
$body = _convert($body, 0);
}
return ($body, \@file, \@show, \@mime, \@code, $count);
}
#// ----------------------------------------------------------
#// Convert
#// ----------------------------------------------------------
sub _convert {
my $line = $_[0];
my $mode = 0; $mode = $_[1];
$line =~ s/^(\s+)/ /g; $line =~ s/(\t+)/ /g;
if ($mode == 1) {
$line = ADN::MIME::HeaderDecode($line, 'euc');
$line =~ s/(\t+)//g;
$line =~ s/[\r\n]//g;
} else {
Jcode::convert(\$line, 'euc');
$line =~ s/(\t+)//g;
}
return $line;
}
sub _boundary {
my $line = shift; my $boundary = '';
$boundary = _convert($line,0);
$boundary =~ s/(.+)boundary\=(.+)/$2/i;
$boundary =~ s/['"]//g;
$boundary =~ s/^(\s+)//g;
$boundary =~ s/(\s+)$//g;
return $boundary;
}
sub _encoding {
my $line = shift; my $code = '';
if ($line =~ /base64/i) { $code = 'b64'; }
if ($line =~ /quoted/i) { $code = 'qp'; }
return $code;
}
1;