#	メーリングリストのmboxアーカイブからレス関係を抽出するプログラム
#		author		yoji-o
#		first edit	2006-10-12
#		last edit	2007-11-15
#
#		◇入力
#			mbox形式のメールアーカイブ
#		◇出力
#			関係リスト、もしくは、Pajek形式データ
#
#		◇使用法
#			コマンドラインで、以下のコマンドをたたく(要 Perl 5 以上)
#			perl getRelation.pl [filename1,filename2,...]
#			
#		◇引数
#			filename1...	mboxファイル、指定しなければ標準入力から読み込む
#					複数指定した場合は、mboxをマージしてから読み込む
#

#use strict;
#use warnings;

#変数宣言
my %mapping_email_msgid;	#メッセージIDからメールアドレスを得るための対応ハッシュ
my %relation;			#レス関係の対応ハッシュ(2次元ハッシュ)
my %mail2mail;			#同一人物のメールアドレスを一致させるための対応表
my $filename;			#引数に与えられたファイル名を保存する

my @fromNameList;		#名前一致チェック用
my @fromMailBeforeAt;	#@以前の一致チェック用
my @fromNameMail;		#そのメールアドレス

my %parentnum;			#親記事を作成した数

my $mailsplitter = '^From ';	#メールの区切りを示す正規表現
my $mail_rexp = '[a-zA-Z0-9\.\-\_\+]+\@[a-zA-Z0-9\.\-\_]+';	#メールの正規表現
my $mid_rexp  = '[a-zA-Z0-9\.\-\_]+\@[a-zA-Z0-9\.\-\_]+';	#Message-Idの正規表現

#ここから
&parse();			#parseする
&listResult();			#関係一覧を表示(デバッグ用)
&listResultForPajek();		#Pajek形式データとして出力
exit;


################################################################################
#以下サブルーチン群

#===============================================================================
#parse
#	mailboxをparseする
sub parse {
	my $fromMail;		#差出人メールアドレス
	my $fromName;		#From行から抽出した名前
	my $message_id;		#メッセージID
	my $in_reply_to;	#返信元メッセージID
	my $flag = -1;
	
	#データがファイルで与えられた場合、ファイルに出力するためファイル名を覚えておく
	if($ARGV[0]) {
		$filename = $ARGV[0];
	}

	while (<>) {

		#前処理
		#改行除去
		chomp $_;
		#スパム対策メールアドレス偽装を解除
		$_ =~ s/ at /@/ig;

		#以下はゴミ処理
		#「"」を除去
		$_ =~ s/"//g;
		#「%」を除去
		$_ =~ s/%//g;
		#末尾のスペースを除去
		$_ =~ s/\s*$//; # 後方一致
		#末尾の「,」の除去
		$_ =~ s/,+$//;
		# 連続する<または>の除去
		$_ =~ s/<+/</g;
		$_ =~ s/>+/>/g;
		#↓以下の2つの処理については注意が必要．全期間のMLを目視で確認(byまえし)したところ" >，] "が名前の中で使われていたりした事例は
		#　なく，以降にゴミが多く見受けられたので思い切って切り捨てました．前よりかはむしろメールアドレスの抽出の精度が上がったと思います
		#　")"についてはML(主にApache)によってはFrom行の名前の中でも利用されることがあるので，ここでは処理しません
		#　※以下の2つの処理は，Apache・GIMP・Netscapeを対象にした場合に有効と考えてください（その場限りの対処の仕方で申し訳ありませんm(_ _)m）
		# 「>」以降を除去
		$_ =~ s/>.*/>/;
		# 「]」以降を除去
		$_ =~ s/].*/]>/;
		# 末尾の =20 または =0D の削除	※" >，] "以降を除去しているので，この部分は不要かもしれない
		$_ =~ s/(\=20)|(\=0D)$//;

		#メールの区切りがあれば
		if ($_ =~ /$mailsplitter/) {
			#Fromから始まる1つのメールの履歴から，Message-Id，In-Reply-To，From行にある名前(formName)とメールアドレス(formMail)が
			#抽出できればメールのレス関係をハッシュ変数に追加
			unless($flag == 0 || $flag == -1) {

			#ハッシュにほうりこむ前に大文字を小文字で統一する
			$fromName = lc($fromName);
			$fromMail = lc($fromMail);
			$message_id = lc($message_id);
			$in_reply_to = lc($in_reply_to) ;

			&addHash($fromName, $fromMail, $message_id, $in_reply_to);
			}
			
			#reset
			$fromMail = "";
			$fromName = "";
			$message_id = "";
			$in_reply_to = "";
			$flag = -1;
			
			next;
		}

		#Message-Id行であれば
		if ($_ =~ /^Message-Id:/i) {
			#メッセージIDを抽出
			$_ =~ s/^(.*?)\s*($mid_rexp)/$2/;
			# message-idの形式に適したデータが入っているか確認する　※Null値や形式に適さないゴミは無視
			if($2 ne ""){
				#Apache,GIMPのmessage_idの多くは < > で囲まれているため
				$_ =~ s/<//;
				$_ =~ s/>//;
				$message_id = $_;
			}
		}

		#In-Reply-To行であれば
		elsif ($_ =~ /^In-Reply-To:/i) {
			#返信元メッセージIDを抽出
			$_ =~ s/^(.*?)\s*($mid_rexp)/$2/;
			# in-reply-toの形式に適したデータが入っているか確認する　※Null値や形式に適さないゴミは無視
			if($2 ne ""){
				#Apache,GIMPのin_reply_toの多くは < > で囲まれているため
				$_ =~ s/<//;
				$_ =~ s/>//;
				$in_reply_to = $_;
			}
		}

		#From行であれば
		elsif ($_ =~ /^From:.+\@.+/i) {
			#メールアドレスを抽出
			#rogi algorithm(too bad)
			#$_ =~ s/^.+?($mail_rexp).*$/$1/;

			#From：の部分の除去
			$_ =~ s/^From:(\s*\t*)?//i;

			#「 at 」を「@」に変更	※特にGIMPで多く見受けられる
			$_ =~ s/ at /\@/;

			#名前＋<メールアドレス>　の形式についての処理　※主にApache？
			#標準形  "Yamamoto Taro <ytaro@aa.com>"
			if ($_ =~ /^(.+?)\s*<($mail_rexp)>/) { 
				$flag = 1;
				$fromName = $_;
				$fromName =~ s/^(.+?)\s*<($mail_rexp)>/$1/;
				$fromMail = $_;
				$fromMail =~ s/^(.+?)\s*<($mail_rexp)>/$2/;
			}
			#FromName の不足 "<ytaro@aa.com>"
			elsif ($_ =~ /^<($mail_rexp)>/){
				$flag = 2;
				$fromName = "";
				$fromMail = $_;
				$fromMail =~ s/^<($mail_rexp)>/$1/;
			}
			#$FromName の不足＋<>の不足 "ytaro@aa.com"
			elsif ($_ =~ /^($mail_rexp)$/) {
				$flag = 3;
				$fromName = "";
				$fromMail = $_;
				$fromMail =~ s/^($mail_rexp)$/$1/;
			}
			#mailto形式 "Yamamoto Taro [mailto:ytaro@aa.com]"
			elsif ($_ =~ /^(.+?)\s*\[mailto:\s*($mail_rexp)\]/) {
				$flag = 4;
				$fromName = $_;
				$fromName =~ s/^(.+?)\s*\[mailto:\s*($mail_rexp)\]/$1/;
				$fromMail = $_;
				$fromMail =~ s/^(.+?)\s*\[mailto:\s*($mail_rexp)\]/$2/;
				#原因はよく分からないけどfromName，formMailともに末に > がついてしまう(？)ので除去
				$fromName =~ s/>//;
				$fromMail =~ s/>//;
			}

			#名前＋(メールアドレス)　の形式についての処理　※主にGIMP？
			#標準形 "Yamamoto Taro (ytaro@aa.com)"
			elsif ($_ =~ /^(.+?)\s*\(($mail_rexp)\)$/) { 
				$flag = 5;
				$fromName = $_;
				$fromName =~ s/^(.+?)\s*\(($mail_rexp)\)$/$1/;
				$fromMail = $_;
				$fromMail =~ s/^(.+?)\s*\(($mail_rexp)\)$/$2/;
			}
			#標準形の逆パターン(アドレスが先) "ytaro@aa.com (Yamamoto Taro)"
			elsif ($_ =~ /^($mail_rexp)\s*\((.*)\)$/) { 
				$flag = 6;
				$fromName = $_;
				$fromName =~ s/^($mail_rexp)\s*\((.*)\)$/$2/;
				$fromMail = $_;
				$fromMail =~ s/^($mail_rexp)\s*\((.*)\)$/$1/;
			}
			#mailto形式+<>表記 "Yamamoto Taro <mailto:ytaro@aa.com>"
			elsif ($_ =~ /^(.+?)\s*<mailto:\s*($mail_rexp)>/) {
				$flag = 7;
				$fromName = $_;
				$fromName =~ s/^(.+?)\s*<mailto:\s*($mail_rexp)>/$1/;
				$fromMail = $_;
				$fromMail =~ s/^(.+?)\s*<mailto:\s*($mail_rexp)>/$2/;
			}
			#htmlの "a class" 表記
			elsif ($_ =~ /^(.+?)\s*\[*<a class\=.* href\=mailto:($mail_rexp)>/) {
				$flag = 8;
				$fromName = $_;
				$fromName =~ s/^(.+?)\s*\[*<a class\=.* href\=mailto:($mail_rexp)>/$1/;
				$fromMail = $_;
				$fromMail =~ s/^(.+?)\s*\[*<a class\=.* href\=mailto:($mail_rexp)>/$2/;
			}
			#SMTP形式 "Yamamoto Taro [SMTP:ytaro@aa.com]"		※ろぎが追加した新しい条件その1
			elsif ($_ =~ /^(.+?)\s*\[SMTP:\s*($mail_rexp)\]/) {
				$flag = 9;
				$fromName = $_;
				$fromName =~ s/^(.+?)\s*\[SMTP:\s*($mail_rexp)\]/$1/;
				$fromMail = $_;
				$fromMail =~ s/^(.+?)\s*\[SMTP:\s*($mail_rexp)\]/$2/;
				#原因はよく分からないけどfromName，formMailともに末に > がついてしまう(？)ので除去
				$fromName =~ s/>//;
				$fromMail =~ s/>//;
			}
			#名前+<+(名前)表記  "Yamamoto Taro <ytaro@aa.com (Yamamoto Taro)"		※ろぎが追加した新しい条件その2
			#メールアドレスが< >で閉じていない場合で，かつ，再度名前が出てくる場合
			elsif ($_ =~ /^(.+?)\s*<($mail_rexp)\s*\(.+?\)$/) { 
				$flag = 10;
				$fromName = $_;
				$fromName =~ s/^(.+?)\s*<($mail_rexp)\s*\(.+?\)$/$1/;
				$fromMail = $_;
				$fromMail =~ s/^(.+?)\s*<($mail_rexp)\s*\(.+?\)$/$2/;
			}
			#その他のゴミ　もしくは抽出しきれなかったもの
			else {
				$flag = 0;
			}

			#後処理(この辺の正規表現はもう一度チェックしたほうがいい)
			#記号の削除
			$fromName =~ s/"|,|'//g; #need more check
			#ISO 等の文字列削除
			#↑それほど大きな問題でもないので今はスルー
			if ($fromName =~ /^\=/) { # 文字エンコード系
				$fromName =~ s/\=*\?\=$//; # 文末の ?= を削除
				$fromName =~ s/^\=.+\?//g; # コード指定を削除
				$fromName =~ s/\=\w\w//g;  # 特殊文字の削除
				$fromName =~ s/\= //g;  # 特殊文字の削除
				$fromName =~ s/\_/ /g; # アンダーバーをスペースに
				#↑これどういう場合に使われるのだろう・・・
				#連続するスペースの削除
				$fromName =~ s/\s+/ /g;
			}
			#さらに記号の削除 (ISO等の文字を削除後に残るごみを削除する)
			$fromName =~ s/\(|\)|\-|\=|\*|//g;
		}
		
	}
	#最後の1つはハッシュに追加されないのでここであらため処理する

	#ハッシュにほうりこむ前に大文字を小文字で統一する
	$fromName = lc($fromName);
	$fromMail = lc($fromMail);
	$message_id = lc($message_id);
	$in_reply_to = lc($in_reply_to) ;

	&addHash($fromName, $fromMail, $message_id, $in_reply_to);

}


#===============================================================================
#	addHash
#		1つのメールのレス関係をハッシュに追加する
sub addHash {
	#引数を変数に格納
	my ($fromName, $fromMail, $message_id, $in_reply_to) = ($_[0], $_[1], $_[2], $_[3]);
	
	#最後の改行を取り除く
	#おそらく改行は既にないけど
	#chomp $fromMail;
	#chomp $message_id;
	#chomp $in_reply_to;

	###################### 同一人物判定処理 ######################
	
	#条件1：同一メールアドレスなら同一人物
	#条件2：From行の名前が一致&&メールの@以前が同一なら同一人物

	#同一人物判定のための前処理
	#$fromNameにはNullまたはスペースが入っている場合がある　それぞれに対応した条件分岐するのがめんどいのでスペースはここで削除
	$fromName =~ s/\s*//g; 

	#メールアドレスの@以前だけを抽出	(条件2の同一人物の判定で必要)
	#mailの@以前を抽出
	my $mailBeforeAt = $fromMail;
	$mailBeforeAt =~ s/^(.+?)\@.*/$1/;

	#Message-IDとメールアドレスをマッピングさせる
	$mapping_email_msgid{"$message_id"} = $fromMail;
	#print "mapped $message_id = $fromMail\n";

	#追加するメールアドレスはひとまずそのまま同一メールアドレスに変化させるマッピングを作る
	$mail2mail{$fromMail} = $fromMail;


	#↓ここから同一人物の特定作業開始
	#過去に同一人物（名前が同じかつ@以前が同じ）がいれば，そのマッピングに上書きする
	for(my $i = 0; $i < scalar(@fromNameList); $i++) {
		#条件1の処理：同一メールアドレスなら同一人物と判断する
		if ($fromMail eq $fromNameMail[$i]) {
			$mail2mail{$fromMail} = $fromNameMail[$i];
			last;
		}
		#条件2の処理：From行の名前が一致&&メールの@以前が同一なら同一人物と判断する
		#ただし，From行の名前が空白で一致することのないように，空白でない場合のみを対象とする
		elsif ($fromName ne "") {
			#名前が一致するかチェック	
			if($fromName eq $fromNameList[$i]) {
				#一致すれば@以前が同じかチェック
				if($mailBeforeAt eq $fromMailBeforeAt[$i]) {
					#さらに一致すれば同一人物とみなす
					$mail2mail{$fromMail} = $fromNameMail[$i];
					last;
				}
			}
		}
	}

	#次のメール用に現メールのマッピングを保存
	push @fromNameList, $fromName;
	push @fromMailBeforeAt, $mailBeforeAt;
	push @fromNameMail, $fromMail;

	###################### 同一人物判定処理ここまで ######################
	
	
	#レスメールの場合
	if ($in_reply_to) {
		#関係を追加
		my $a = $mail2mail{$mapping_email_msgid{"$message_id"}};
		my $b = $mail2mail{$mapping_email_msgid{"$in_reply_to"}};
		$relation{$a}{$b}++;
		#print "add ", $mapping_email_msgid{"$message_id"}, " -> ",
		#	$mapping_email_msgid{"$in_reply_to"}, "\n";
	}
	else {
		#親記事数をインクリメント
		$parentnum{"$fromMail"}++;
	}
	
}


#===============================================================================
#	listResult
#		結果を一覧表示する
sub listResult {
	#関係一覧を表示
	#while ((my $key, my $value) = each %relation) {
	#	print "$key -> $value\n";
	#}
	foreach my $firstkey (keys %relation) {
		while (my ($secondkey, $value) = each %{$relation{$firstkey}}) {
			print "$firstkey -> $secondkey : $value\n";
			#print "$firstkey\t$secondkey\t$value\n";
		}
	}
}


#===============================================================================
#	listResultForPajek
#		結果をPajek形式フォーマットで出力する
#		※ただし，cluファイルはそれほど必要でないのでコメントアウトしてる
sub listResultForPajek {
	my $count;		#ノード数
	my %number;		#ノードメールアドレスとノード番号の対応
	my $fh;			#結果出力先ファイルハンドル
	my $fh_clu;		#パーティション出力用ファイルハンドル
	
	#ファイルが引数で与えられたら、そのファイル名に.netをつけて保存
	if ($filename) {
		open DATA, ">$filename.net" or die "cannot open savefile.";
		$fh = DATA;
		
		#パーティションファイル生成(引数がファイルで与えられた場合のみ)
		open CLU, ">$filename.clu" or die "cannot open partition savefile.";
		$fh_clu = CLU;
	}
	else {
		$fh = STDOUT;
	}
	
	
	#ノードデータ
	#ノードデータ
	foreach my $eachMail (values %mapping_email_msgid) {
		#空白アドレスでなく、かつまだナンバリングしていなければ
		if ($eachMail ne "" && $number{"$eachMail"} eq "") {
			#$mail2mailで変換されない（＝ユニークアドレス）なら
			if($mail2mail{"$eachMail"} eq $eachMail) {
				#ナンバリングする
				$number{"$eachMail"} = ++$count;
			}
		}
	}
	print $fh "*Vertices $count\n";
	print $fh_clu "*Vertices $count\n" if ($fh_clu);
	
	#ノード番号でメールアドレスをソート
	my @vertices = sort {$number{$a} <=> $number{$b}} keys %number;
	foreach (@vertices) {
		print $fh "$number{$_} \"$_\"\n";
		if ($fh_clu) {
			if ($parentnum{$_}) {
				print $fh_clu "$parentnum{$_}\n";
			}
			else {
				print $fh_clu "0\n";
			}
		}
		#print $fh_clu "\n" if ($fh_clu);
	}
	
	#有向グラフデータ
	print $fh "*Arcs\n";
	foreach my $firstkey (keys %relation) {
		while (my ($secondkey, $value) = each %{$relation{$firstkey}}) {
			# message_idやin_reply_toの情報だけあっても肝心のfromNameやfromMailの情報が欠損している場合が考えられる
			# だから，$eachMailが "" の場合は除く
			# メールアドレスがない人はここで切り捨てる
			unless($number{$firstkey} eq "" || $number{$secondkey} eq ""){
				if($firstkey ne "" && $secondkey ne "") {
					# 自己ループは削除
					unless($firstkey eq $secondkey){
						print $fh "$number{$firstkey} $number{$secondkey} $value\n";
					}
				}
			}
		}
	}

	if ($filename) {
		close $fh;
		print "output to $filename.net\n";
		close $fh_clu;
		# 今回はcluファイルは不要なのでOutputしない	Outputする場合はコメントアウトで
		#print "output to $filename.clu\n";
	}
	
}

#eof