Perl で、メールアドレスの自動リンクをする

以下のサブルーチン getEmails で抜き出したテキスト中のメールアドレス一覧を emailToLink が配列で受け取る。getEmails 中の　while はヘタすると無限ループに陥る可能性があるので変換対象のテキストで 50個まで抜き出すようにしている。

使用するモジュール 


なし
#!/usr/bin/perl sub getEmails { 
my $text = shift;
my @emails;

my $email_regex =
  q{(?:[^(¥040)&lt:>@,;:".¥¥¥¥¥[¥]¥000-¥037¥x80-¥xff]+(?![^(¥040)&lt:>@,;:".¥¥¥¥}
. q{¥[¥]¥000-¥037¥x80-¥xff])|"[^¥¥¥¥¥x80-¥xff¥n¥015"]*(?:¥¥¥¥[^¥x80-¥xff][}
. q{^¥¥¥¥¥x80-¥xff¥n¥015"]*)*")(?:¥.(?:[^(¥040)&lt:>@,;:".¥¥¥¥¥[¥]¥000-¥037¥x}
. q{80-¥xff]+(?![^(¥040)&lt:>@,;:".¥¥¥¥¥[¥]¥000-¥037¥x80-¥xff])|"[^¥¥¥¥¥x80-}
. q{¥xff¥n¥015"]*(?:¥¥¥¥[^¥x80-¥xff][^¥¥¥¥¥x80-¥xff¥n¥015"]*)*"))*@(?:[^(}
. q{¥040)&lt:>@,;:".¥¥¥¥¥[¥]¥000-¥037¥x80-¥xff]+(?![^(¥040)&lt:>@,;:".¥¥¥¥¥[¥]¥0}
. q{00-¥037¥x80-¥xff])|¥[(?:[^¥¥¥¥¥x80-¥xff¥n¥015¥[¥]]|¥¥¥¥[^¥x80-¥xff])*}
. q{¥])(?:¥.(?:[^(¥040)&lt:>@,;:".¥¥¥¥¥[¥]¥000-¥037¥x80-¥xff]+(?![^(¥040)&lt:>@,}
. 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;
参考リンク：

admin

Tags

Comments