以下のサブルーチン getEmails で抜き出したテキスト中のメールアドレス一覧を emailToLink が配列で受け取る。getEmails 中の while はヘタすると無限ループに陥る可能性があるので変換対象のテキストで 50個まで抜き出すようにしている。
使用するモジュール
なし
#!/usr/bin/perl
sub getEmails {
my $text = shift;
my @emails;
my $email_regex =
q{(?:[^(¥040)<:>@,;:".¥¥¥¥¥[¥]¥000-¥037¥x80-¥xff]+(?![^(¥040)<:>@,;:".¥¥¥¥}
. q{¥[¥]¥000-¥037¥x80-¥xff])|"[^¥¥¥¥¥x80-¥xff¥n¥015"]*(?:¥¥¥¥[^¥x80-¥xff][}
. q{^¥¥¥¥¥x80-¥xff¥n¥015"]*)*")(?:¥.(?:[^(¥040)<:>@,;:".¥¥¥¥¥[¥]¥000-¥037¥x}
. q{80-¥xff]+(?![^(¥040)<:>@,;:".¥¥¥¥¥[¥]¥000-¥037¥x80-¥xff])|"[^¥¥¥¥¥x80-}
. q{¥xff¥n¥015"]*(?:¥¥¥¥[^¥x80-¥xff][^¥¥¥¥¥x80-¥xff¥n¥015"]*)*"))*@(?:[^(}
. q{¥040)<:>@,;:".¥¥¥¥¥[¥]¥000-¥037¥x80-¥xff]+(?![^(¥040)<:>@,;:".¥¥¥¥¥[¥]¥0}
. q{00-¥037¥x80-¥xff])|¥[(?:[^¥¥¥¥¥x80-¥xff¥n¥015¥[¥]]|¥¥¥¥[^¥x80-¥xff])*}
. q{¥])(?:¥.(?:[^(¥040)<:>@,;:".¥¥¥¥¥[¥]¥000-¥037¥x80-¥xff]+(?![^(¥040)<:>@,}
. q{;:".¥¥¥¥¥[¥]¥000-¥037¥x80-¥xff])|¥[(?:[^¥¥¥¥¥x80-¥xff¥n¥015¥[¥]]|¥¥¥¥[}
. q{^¥x80-¥xff])*¥]))*};
my $i = 0;
while($text =~ /($email_regex)/o && $i++ < 50) {
push(@emails, $1);
$text =~ s/$1/XXXXXXXXXX/g;
}
return @emails;
}
sub emailToLink {
my $text = shift;
my @emails = &getEmails($text);
foreach my $email (@emails) {
$text =~ s/$email/<a href=mailto:$email>$email<¥/>/g;
}
return $text;
}
1;
トラックバック URL:
https://perltips.twinkle.cc/trackback/6