ホーム

へぼい日記

Acme::Coro::Sukeをリリースしました

  • 投稿者: chiba
  • 2009/10/12 月曜日 15:44:51
  • perl

多分、5人以上の人が思いついたけどあまりのくだらなさに作成を断念したといううわさのAcme::Coro::Sukeを先ほどCPANにリリースしました。(githubにもあげてあります)

これは、Coroのasyncと基本的には同じ動作をするbenzoというブロック定義ができるようになるもので、benzoブロックにCoroがスレッドを切り替えるたびに、「うわぁ…べんぞうさんの中…すごくあったかいナリぃ… 」とコロちゃんが囁やいてくれるモジュールです。
一番簡単な使い方は以下のようになります。

use Coro;
use Acme::Coro::Suke;
benzo {
};
cede;

enjoy Acme::Coro::Suke!

CPANに上げる三つめのモジュールがAcmeモジュールというのはこれはひどい。

はてなブックマーク - Acme::Coro::Sukeをリリースしました

Re: PSGI Implのsendfileについて

  • 投稿者: chiba
  • 2009/10/7 水曜日 15:29:06
  • perl

PSGI Implのsendfileについてですが、自分の今のところのイメージを書いておくです。

on Plack::Server

  • $res->[2]がGLOBだったら fileno($res->[2])して sendfile に fd を渡す
  • $res->[2]->can(‘fileno’) が生えてたら、$res->[2]->filenoからfdを取って使う
  • $res->[2]->can(‘path’) が生えてたら、$res->[2]->pathからファイルパスを取って使う

$env->{psgix.sendfile}を使わない以外は一緒

on app

realfileをserveしたい時は

  • GLOBを返す
  • ->pathを生やしたIO-Handle-likeなオブジェクトを返す

の二種類の方法があって、後者のほうがあらゆるサーバで最適化される可能性がある。かといって前者だからといってクライアントに届くresponseが変わることはないと期待される。後者において->filenoの実体のファイルと->pathが違うものだった場合の動作は未定義。

on middleware

  • Plack::Middleware::XSendfile
    responseから->pathが取れる場合にはそれをヘッダのX-Sendfileにセットするようなmiddleware。これのpsgix.sendfileサポートを無くしたやつのイメージ。
    X-Sendfileヘッダをセットする場合というのはbackendがlightyの場合とかだと思うけど、それをセットしていいかどうかはPlackは知り得ない。かといってappでセットしていて必要のない時に外にファイルPATHが出ていくものいくない。というわけでappでは->path付きオブジェクトを返すだけにして、このmiddlewareをbackendにあわせて付けたり外したりする。Plack::Server::*のsendfile(2)サポートとかとはまったく関係無い。
  • Plack::Middleware::GuessPath
    GLOBからファイルPathを推測して->path付きのオブジェクトに変換しちゃうMiddleware。マルチプラットフォーム対応が課題。Plack::Middleware::XSendfileより先に実行する。Plack::Server::*のsendfile(2)サポートとも関係する。


追記(10/7 17:24): 大体ここに書いてある感じで追加されたみたいです。詳しくは本家specのchangesetをご覧ください。Plack::Middleware::XSendfileも追加されたみたいです。miyagawaさん仕事ハヤス、、、。

はてなブックマーク - Re: PSGI Implのsendfileについて

ファイルPATHを覚えているfhを作成できるIO::File::WithPathをリリース

  • 投稿者: chiba
  • 1:49:30
  • perl

Plackのsendfileサポート関連を追いかけてて、Plack::Server::Apache2でsendfileサポートされてない理由がfhからファイル名を取るベストな方法がないというわけで、gist: 200797みたいなパッチを書いて#http-engineとかに張り付けたけどそれlinuxでしか動かないよねみたいなことで日本の恥を晒してしまったりしてたわけですが、その中でIO::File::WithPathみたいなのがあればいいよねと話がでていたので作ってみました。

CPANgithubにあげてあります。

使い方はこんな感じ。

    my $fh = IO::File::WithPath->new('/path/to/file');
    print $fh->path; # /path/to/fileがとれるよ
    print $fh->getline; # IO::Handleとしても扱える
    print <$fh>; # もちろんGLOBとしても

Plackのappでは

    return ['200', [], IO::File::WithPath->new('/path/to/file')];

みたいな使い方を想定していますが、Plack::Server側はこのモジュールを使うことが前提というわけではなくて、duck typingで->pathがあるオブジェクトであればそのpathを(使える条件であれば)使うようになる予定だと思います。

あと、純粋なfhからpathを取るマルチプラットフォーム対応なモジュールもできれば欲しいよねというところ。windowsはかなり無理っぽい。

はてなブックマーク - ファイルPATHを覚えているfhを作成できるIO::File::WithPathをリリース

Plack::Requestからのhostのとりかた

  • 投稿者: chiba
  • 2009/9/30 水曜日 21:42:21
  • perl

Plack::Requestにhost無いなぁ。と思って勢い余ってforkしてコミットまでしてしまったのですが、#perl-casual@freenodeで呟いたところyappoさんから

$req->uri->host

もしくはURIオブジェクトの作成コストが気になるなら($req->uriは遅延作成なので)

$req->env->{HTTP_HOST}

でいいじゃんと言われました。確かにその通りですね。

はてなブックマーク - Plack::Requestからのhostのとりかた

Wassrのyapcasia2009チャンネルの発言をIRCに投稿するボットをYAPC::Asiaの二日目向けに作った

  • 投稿者: chiba
  • 2009/9/10 木曜日 23:47:54
  • perl

twitterの#yapcasia2009ハッシュタグがスクリーンに晒されるのが個人的に非常にツボだったので、wassrのyapcasia2009チャンネルに発言するとirc.freenode.orgの#yapc.asia-jaに投稿するボットも作ってみました。
wassrにはstreaming APIはないようなので5秒ごとにpollingしちゃってます。いいんでしょうか。
参考文献(つうかほぼパクリ):
Twitterのハッシュタグ付き発言をIRCに投稿するボットをYAPC::Asia向けに作った

以下コード

#!/usr/bin/perl
use strict;
use warnings;

use AnyEvent::IRC::Client;
use Net::Wassr;
use Encode ();
use Storable;

my $channel = '#yapc.asia-ja';
my $interval = 5;
my $wassr_channel = 'yapcasia2009';

my $wassr = Net::Wassr->new(
    user   => 'nihen',
    passwd => '*****',
);



my $cv = AnyEvent->condvar;
my $pc = AnyEvent::IRC::Client->new;


my $send_message = -e 'send_message' ? retrieve('send_message') : {};
$SIG{INT} = $SIG{TERM} = sub {
    $pc->disconnect('bye');
    store $send_message, 'send_message';
    exit;
};

$pc->reg_cb(
    connect => sub {
        my ( $pc, $err ) = @_;
        if ( defined $err ) {
            warn $err;
            return;
        }
    },
    registered => sub {
        my ( $self ) = @_;
        print "registerd!\n";
        $pc->enable_ping(60);
    },
    disconnect => sub {
        print "disconnected: $_[1]!\n";
    }
);
$pc->send_srv('JOIN', $channel);
$pc->send_chan($channel, 'NOTICE', $channel, 'hi');
$pc->connect('irc.freenode.org', 6667, {
    nick => 'wassr_bot',
    user => 'wassr_bot',
    real => 'wassr_bot',
});

my $w = AnyEvent->timer(after => $interval, interval => $interval, cb => sub {
    my $time_line = $wassr->channel_timeline('name_en=' . $wassr_channel);
    if ( !$time_line || ref $time_line ne 'ARRAY' ) {
        return;
    }

    foreach my $message ( @{$time_line} ) {
        next if $send_message->{$message->{rid}};

        $send_message->{$message->{rid}} = 1;

        $pc->send_chan($channel, 'NOTICE', $channel, Encode::encode('utf-8', $message->{user}->{login_id} . ': ' . $message->{body}));
    }
});


$cv->wait;
はてなブックマーク - Wassrのyapcasia2009チャンネルの発言をIRCに投稿するボットをYAPC::Asiaの二日目向けに作った

YAPC::Asia2009の参加トークをわかりやすくするグリモン作ったよ

  • 投稿者: chiba
  • 2009/9/9 水曜日 14:40:35
  • perl

さて、明日からついにYAPC::Asiaが始まりますね。皆さんは参加されるトークをすでに決められたでしょうか?

参加するトークの詳細ページ(ex.Welcome)でadd to personal scheduleを行うと参加トークの管理ができるようになっているみたいです。ただこれがスケジュール上では確認できなくてちょっと不便だなーと思ったのでわかりやすくするぐりもんを作ってみました。

yapcasia2009myschedule.user.js

です。いれるとスケジュールの表示がこうなります。あ、ログインした状態じゃないと表示されないです。

らくだのマークがわかりやすくて印刷用にも最適ですね!

では、YAPC::Asia会場でお会いしましょうです。

はてなブックマーク - YAPC::Asia2009の参加トークをわかりやすくするグリモン作ったよ

mysqlでskip-character-set-client-handshakeはもう使わないほうがいいと思われ

  • 投稿者: chiba
  • 2009/8/27 木曜日 16:51:43
  • mysql | perl

skip-character-set-client-handshake を [mysqld] セクションに追記すると、クライアントがどんな文字コード設定をもっていようが問答無用で character_set_* を (_system をのぞいて) すべて同じ値に統一してくれる
http://d.hatena.ne.jp/a666666/20090826/1251270979

ふーむ。

skip-character-set-client-handshakeを薦める文書がネット上にはやたら転がってるんだけど、これには大きな落とし穴がある。

たしかに表示されるcharacter_set_*は統一されるかもしれないがこれはあくまでもサーバー側の認識であってクライアント(libmysqlclient)がcharsetをどう認識しているかというのとは関係ないのだ。で、実はlibmysqlclientが認識しているcharsetはcharacter_set_clientとは必ずしも一致しているわけではなくて、これを絶対的に一致させるには以前のエントリでも紹介したがhttp://www.klab.jp/media/mysql/index6.htmlの図3:クライアント側文字コードの指定チャートが参考になる。

skip-character-set-client-handshakeをしただけだと結局libmysqlclientが認識しているcharsetはクライアント側のコンパイル時のcharset(デフォルトではlatin-1)になる。ここで実際に送信するcharsetと乖離が起これば当然組み合わせによってはSQLインジェクションの脆弱性が発生する。id:a666666氏のmysqlはutf8でコンパイルしてujisを送信ということなので脆弱性はなさそうだが(あったら誰か教えてください)、例えばcp932を送信するのであれば以前のエントリと同様に(反対方向だけど)”\xe3\x81\x95\x5c”等が危険な文字列になる。これをlibmysqlclientはUTF-8として認識してエスケープするので”\xe3\x81\x95\x5c\x5c”になるが、サーバー側ではcp932と認識するので”\xe3\x81″ “\x95\x5c” “\x5c”と分割されてしまうという感じだ。

そもそもskip-character-set-client-handshakeなんてのはmysql4.0からの移行組用の臨時救済措置で作られたものだろうし、こんなものを使うことを前提に運用するのはやめたほうがいい。よくいわれている文字コードの変換処理をさせたくない、ということであればフィールドの文字コードと通信の文字コードを統一しておけばいいだけでしょう。

はてなブックマーク - mysqlでskip-character-set-client-handshakeはもう使わないほうがいいと思われ

FormValidator::NestedをCPANにアップしました

  • 投稿者: chiba
  • 2009/8/18 火曜日 21:00:36
  • perl

知人にCPAN Authorになると宣言してから8年、やっとこさなりました。もちろんCPANにアップするだけなら誰だってできるので質の高いモジュールをアップできるように今後は心がけていきたいと思います。

で、初めてアップしたのがFormValidator::Nestedです。

これは、FormValidator::SimpleFormValidator::LiteFormValidator::LazyWayなんかを参考に作られたFormValidatorです。

上記のモジュール達との主な違いといえる特長は、

  • ネストしたパラメータを扱える
  • 配列なパラメータを扱える
  • profileを継承できる

あたりになるかと思います。

profileはとりあえず今はymlで書いて、そのファイルの置かれたbaseディレクトリを指定してそこからの相対PATHがkeyになるという感じです。(FormValidator::Nested::ProfileProviderの実装を増やすことでここは柔軟に対応可能な予定)

params:
  mail:
    name: メールアドレス
    validators:
      - Blank#not_blank
      - Email#email
      - String#max_length:
          max: 100

といった感じのprofileをhoge.ymlとかでprofileディレクトリに保存して

use FormValidator::Nested;
use Class::Param;

my $req = Class::Param->new({mail => 'hoge'});
my $fvt = FormValidator::Nested->new({
    profile_provider => FormValidator::Nested::ProfileProvider::YAML->new({
        dir => 'profile',
    }),
});
my $res = $fvt->validate($req, 'hoge');
if ( $res->has_error ) {
    my $error_param_ref = $res->error_params;
    while ( my ( $key, $error_params ) = %{$error_param_ref} ) {
        foreach my $error_param ( @{$error_params} ) {
            warn $error_param->key . ':' . $error_param->msg;
        }
    }
}

といったコードを実行すると、「mail:メールアドレスの形式が正しくありません」といったwarningが出力されるみたいな使い方ですね。

ネストしたパラメータを扱えるというのはどういうことかというと、

params:
  user:
    name: ユーザ
    nest: hoge

で、huga.ymlを作って(さきほどのhoge.ymlは残したまま)

use FormValidator::Nested;
use Class::Param;

my $req = Class::Param->new({ user => {mail => 'hoge'} });
my $fvt = FormValidator::Nested->new({
    profile_provider => FormValidator::Nested::ProfileProvider::YAML->new({
        dir => 'profile',
    }),
});
my $res = $fvt->validate($req, 'huga');
if ( $res->has_error ) {
    my $error_param_ref = $res->error_params;
    while ( my ( $key, $error_params ) = %{$error_param_ref} ) {
        foreach my $error_param ( @{$error_params} ) {
            warn $error_param->key . ':' . $error_param->msg;
        }
    }
}

とやると「user[mail]:メールアドレスの形式が正しくありません」みたいなwarningになります。ちなみにネストしたパラメータてのはCGI::Expandやそれを利用してるC::P::Params::Nestedなんかの利用を想定してます。Ajaxで動的なフォームを作ったりすると必要になる場面がありますよね。

さらに、配列なパラメータが扱えるというのは

params:
  mail:
    name: メールアドレス
    array: 1
    validators:
      - Blank#not_blank
      - Email#email
      - String#max_length:
          max: 100

とかでbaz.ymlを作っておいて

use FormValidator::Nested;
use Class::Param;

my $req = Class::Param->new({ mail => ['nihen@megabbs.com', 'hoge'] });
my $fvt = FormValidator::Nested->new({
    profile_provider => FormValidator::Nested::ProfileProvider::YAML->new({
        dir => 'profile',
    }),
});
my $res = $fvt->validate($req, 'baz');
if ( $res->has_error ) {
    my $error_param_ref = $res->error_params;
    while ( my ( $key, $error_params ) = %{$error_param_ref} ) {
        foreach my $error_param ( @{$error_params} ) {
            warn $error_param->key . ':' . $error_param->msg;
        }
    }
}

とやるとやはり「mail:メールアドレスの形式が正しくありません」となるという感じです。

あとは、継承ができるという件ですが

extends: hoge
params:
  name:
    name: 名前
    validators:
      - Blank#not_blank
      - String#max_length:
          max: 100

といったprofileを書くとhoge.ymlとHash::Mergeで結合されたprofileが使われるという感じです。Hash::MergeのbehaviorはFormValidator::Nested::ProfileProviderで指定しています。(あー$behaviorはourにしといたほうがいいかな。)

まぁ、こんなところです。ちとPODがぜんぜん書けていないのでこのエントリの内容も含めそのうちPODは書き足しておきます。それまではtディレクトリの中とかをあさってもらうとsampleになるものが一通りそろってるはずです。

あ、それとcodereposにもhttp://svn.coderepos.org/share/lang/perl/FormValidator-Nested/であげてあるのでパッチ等はこちらでいただけるとうれしいです。(まだgithubに移行してない奴)

あーあとfilterも同じymlでかける(ProfileProviderを共有できる)なんて機能もあります。

params:
  tel:
    filters:
      - String#remove_hyphen
      - String#alnum_z2h
    validators:
      - String#between_length:
          min: 10
          max: 11

ま、こんな感じ。

はてなブックマーク - FormValidator::NestedをCPANにアップしました

メールヘッダからaddr-specを抜き出す正規表現(修正版)

  • 投稿者: chiba
  • 2009/8/10 月曜日 3:32:01
  • perl

Email::AddressParserを使うと、前エントリで問題にしてたdisplay-nameやcomment中にaddr-specみたいなのが現れるmailboxからの正しいaddr-specの抽出ができるみたいで、ちょっとやる気をなくしてたんですが一応足を突っ込んだ限りは修正しておこうということで、前エントリの問題の修正版。

複数のマッチが同一キャプチャにあるとどうしても駄目なのでmailboxの正規表現で複数回マッチさせる方針に変更。

mailboxの正規表現生成スクリプト

my $CR = qq{\\x0D};
my $LF = qq{\\x0A};
my $CRLF = qq{(?:\\x0D\\x0A)};
my $VCHAR = qq{[\\x21-\\x7E]};
my $WSP = qq{[\\x20\\x09]};


my $obs_NO_WS_CTL = qq{(?<obs_NO_WS_CTL>[\\x01-\\x08\\x0B\\x0C\\x0E-\\x1F\\x7F])};
my $obs_ctext = qq{(?&obs_NO_WS_CTL)};
my $obs_qtext = qq{(?&obs_NO_WS_CTL)};
my $obs_qp = qq{(?:\\\\(?:\\x00|(?&obs_NO_WS_CTL)|$LF|$CR))};
my $obs_FWS = qq{(?:$WSP+(?:$CRLF$WSP+)*)};

my $FWS = qq{(?<FWS>(?:$WSP*$CRLF)?$WSP+|$obs_FWS)};
my $ctext = qq{(?<ctext>[\\x21-\\x27\\x2A-\\x5B\\x5D-\\x7E]|$obs_ctext)};
my $quoted_pair = qq{(?<quoted_pair>\\\\(?:$VCHAR|$WSP)|$obs_qp)};
my $ccontent = qq{(?:(?&ctext)|(?&quoted_pair)|(?&comment))};
my $comment = qq{(?<comment>\\((?:(?&FWS)?$ccontent)*(?&FWS)?\\))};
my $CFWS = qq{(?<CFWS>(?:(?&FWS)?(?&comment))+(?&FWS)?|(?&FWS))};

my $atext = qq{(?<atext>[A-Za-z0-9!#\$%&'*+\\-/=?^_`{|}~])};
my $atom = qq{(?<atom>(?&CFWS)?(?&atext)+(?&CFWS)?)};
my $dot_atom_text = qq{(?:(?&atext)+(?:\\.(?&atext)+)*)};
my $dot_atom = qq{(?<dot_atom>(?&CFWS)?$dot_atom_text(?&CFWS)?)};

my $qtext = qq{(?:[\\x21\\x23-\\x5B\\x5D-\\x7E]|$obs_qtext)};
my $qcontent = qq{(?:$qtext|(?&quoted_pair))};
my $quoted_string = qq{(?<quoted_string>(?&CFWS)?"(?:(?&FWS)?$qcontent)*(?&FWS)?"(?&CFWS)?)};
my $obs_dtext = qq{(?:(?&obs_NO_WS_CTL)|(?&quoted_pair))};
my $dtext = qq{(?:[\\x21-\\x5A\\x5E-\\x7E]|$obs_dtext)};
my $domain_literal = qq{(?:(?&CFWS)?\\[(?:(?&FWS)?$dtext)*(?&FWS)?\\](?&CFWS)?)};

my $word = qq{(?<word>(?&atom)|(?&quoted_string))};
my $obs_local_part = qq{(?:(?&word)(?:\\.(?&word))*)};
my $obs_domain = qq{(?:(?&atom)(?:\\.(?&atom))*)};
my $local_part = qq{(?:(?&dot_atom)|(?&quoted_string)|$obs_local_part)};
my $domain = qq{(?<domain>(?&dot_atom)|$domain_literal|$obs_domain)};


# addr_specを名前付きキャプチャ化
my $addr_spec = qq{(?<addr_spec>$local_part\@(?&domain))};


my $obs_phrase = qq{(?:(?&word)(?:(?&word)|\\.|(?&CFWS))*)};
my $phrase = qq{(?:(?&word)+|$obs_phrase)};
my $display_name = $phrase;

my $obs_domain_list = qq{(?:(?:(?&CFWS)|,)*\@(?&domain)(?:,(?&CFWS)?\@(?&domain))*)};
my $obs_route = qq{(?:$obs_domain_list:)};
my $obs_angle_addr = qq{(?:(?&CFWS)?<$obs_route$addr_spec>(?&CFWS))};
my $angle_addr = qq{(?:(?&CFWS)?<$addr_spec>(?&CFWS)?|$obs_angle_addr)};
my $name_addr = qq{(?:$display_name?$angle_addr)};
my $mailbox = qq{(?<mailbox>$name_addr|$addr_spec)};

my @name_captures = qw/
    obs_NO_WS_CTL FWS ctext quoted_pair comment CFWS atext atom
    dot_atom quoted_string word domain mailbox
/;
my %tmp_name_captures = map { $_ => 1 } @name_captures;
my $last_count = keys %tmp_name_captures;
while ( keys %tmp_name_captures ) {
    foreach my $name_capture ( keys %tmp_name_captures ) {
        my $re = eval "\$$name_capture";
        $mailbox =~ s/(\(\?\&$name_capture\))/$re/;
        if ( $1 ) {
            delete $tmp_name_captures{$name_capture};
        }
    }
    last if $last_count == keys %tmp_name_captures;
    $last_count = keys %tmp_name_captures;
}

return qr/$mailbox/;
}

で、生成される正規表現が以下。全面的に名前付きキャプチャを使って書き直してあるので、正規表現自体も短くなってます。パフォーマンスも若干アップ。

(?<mailbox>(?:(?:(?<word>(?<atom>(?&CFWS)?(?&atext)+(?&CFWS)?)|(?&quoted_string))+|(?:(?&word)(?:(?&word)|\.|(?<CFWS>(?:(?<FWS>(?:[\x20\x09]*(?:\x0D\x0A))?[\x20\x09]+|(?:[\x20\x09]+(?:(?:\x0D\x0A)[\x20\x09]+)*))?(?<comment>\((?:(?&FWS)?(?:(?<ctext>[\x21-\x27\x2A-\x5B\x5D-\x7E]|(?&obs_NO_WS_CTL))|(?<quoted_pair>\\(?:[\x21-\x7E]|[\x20\x09])|(?:\\(?:\x00|(?&obs_NO_WS_CTL)|\x0A|\x0D)))|(?&comment)))*(?&FWS)?\)))+(?&FWS)?|(?&FWS)))*))?(?:(?&CFWS)?<(?<addr_spec>(?:(?<dot_atom>(?&CFWS)?(?:(?<atext>[A-Za-z0-9!#0&'*+\-/=?^_`{|}~])+(?:\.(?&atext)+)*)(?&CFWS)?)|(?<quoted_string>(?&CFWS)?"(?:(?&FWS)?(?:(?:[\x21\x23-\x5B\x5D-\x7E]|(?<obs_NO_WS_CTL>[\x01-\x08\x0B\x0C\x0E-\x1F\x7F]))|(?&quoted_pair)))*(?&FWS)?"(?&CFWS)?)|(?:(?&word)(?:\.(?&word))*))@(?<domain>(?&dot_atom)|(?:(?&CFWS)?\[(?:(?&FWS)?(?:[\x21-\x5A\x5E-\x7E]|(?:(?&obs_NO_WS_CTL)|(?&quoted_pair))))*(?&FWS)?\](?&CFWS)?)|(?:(?&atom)(?:\.(?&atom))*)))>(?&CFWS)?|(?:(?&CFWS)?<(?:(?:(?:(?&CFWS)|,)*@(?&domain)(?:,(?&CFWS)?@(?&domain))*):)(?<addr_spec>(?:(?&dot_atom)|(?&quoted_string)|(?:(?&word)(?:\.(?&word))*))@(?&domain))>(?&CFWS))))|(?<addr_spec>(?:(?&dot_atom)|(?&quoted_string)|(?:(?&word)(?:\.(?&word))*))@(?&domain)))

addr-specを取得する関数は、複数用と単数用でこんな感じ。From, ToはmultiをSenderはoneを使うといいと思います。

sub addr_specs_multi {
    my $input_from = shift;

    my @addr_specs = ();
    while ( $input_from =~ /$mailbox/go ) {
        foreach my $addr_spec ( @{$-{addr_spec}} ) {
            push @addr_specs, $addr_spec if defined($addr_spec);
        }
    }
    return \@addr_specs;
}
sub addr_specs_one {
    my $input_sendr = shift;

    if ( $input_sendr =~ /$mailbox/o ) {
        foreach my $addr_spec ( @{$-{addr_spec}} ) {
            return $addr_spec if defined($addr_spec);
        }
    }
    else {
        return;
    }
}

まーしかし、Email::AddressParser使えばいいと思いますです。正規表現ではなくXSで字句解析を行っているようで速度も断然早いです。また、コメントの削除も行ってくれます。
webチェックや汎用テキストからの抽出は以前のエントリの正規表現でmailboxを対象としたaddr-specの抜き出しはEmail::AddressParserを使うという使い分けがベストかと思われます。

2009/08/10 15:32 $atextのとこのエスケープ処理を修正

はてなブックマーク - メールヘッダからaddr-specを抜き出す正規表現(修正版)

メールヘッダからaddr-specを抜き出す正規表現

  • 投稿者: chiba
  • 2009/8/8 土曜日 18:13:56
  • perl

同じ場所のキャプチャに2回以上マッチした場合に最後にマッチしたものしかとれない問題があった(‘From: <hoge@example.com>,<hoge2@example.com>,<hoge3@example.com>’とか)のでちと、現在修正を考え中。なかなか難しいなぁ。

以前、メールアドレス(addr-spec)の正規表現をポストしたのですが、あれはweb入力のチェックや汎用的なテキストからの抜き出しを前提としており、メールヘッダからのaddr-specの抽出には向いていません。

例えば、「From: "hoge@example.com" <foo@example.com>」
というFromヘッダに対して前述の正規表現を適用すると「hoge@example.com」が抽出されてしまい、
これは正しいaddr-specではありません。正しいaddr-specは「foo@example.com」になるからです。

そこで、From Sender Toの各ヘッダ対象の正規表現を作成し、そこからaddr-specを抜き出す正規表現と関数を作成しました。以下に示します。

my $CR = qq{\\x0D};
my $LF = qq{\\x0A};
my $CRLF = qq{(?:\\x0D\\x0A)};
my $VCHAR = qq{[\\x21-\\x7E]};
my $WSP = qq{[\\x20\\x09]};

my $obs_NO_WS_CTL = qq{[\\x01-\\x08\\x0B\\x0C\\x0E-\\x1F\\x7F]};
my $obs_ctext = $obs_NO_WS_CTL;
my $obs_qtext = $obs_NO_WS_CTL;
my $obs_qp = qq{(?:\\\\(?:\\x00|$obs_NO_WS_CTL|$LF|$CR))};
my $obs_FWS = qq{(?:$WSP+(?:$CRLF$WSP+)*)};

my $FWS = qq{(?:(?:$WSP*$CRLF)?$WSP+|$obs_FWS)};
my $ctext = qq{(?:[\\x21-\\x27\\x2A-\\x5B\\x5D-\\x7E]|$obs_ctext)};
my $quoted_pair = qq{(?:\\\\(?:$VCHAR|$WSP)|$obs_qp)};
my $ccontent = qq{(?:$ctext|$quoted_pair|(?-1))};
my $comment = qq{(\\((?:$FWS?$ccontent)*$FWS?\\))};
my $CFWS = qq{(?:(?:$FWS?$comment)+$FWS?|$FWS)};

my $atext = qq{[A-Za-z0-9!#$%&'*+\\-/=?^_`{|}~]};
my $atom = qq{(?:$CFWS?$atext+$CFWS?)};
my $dot_atom_text = qq{(?:$atext+(?:\\.$atext+)*)};
my $dot_atom = qq{(?:$CFWS?$dot_atom_text$CFWS?)};

my $qtext = qq{(?:[\\x21\\x23-\\x5B\\x5D-\\x7E]|$obs_qtext)};
my $qcontent = qq{(?:$qtext|$quoted_pair)};
my $quoted_string = qq{(?:$CFWS?"(?:$FWS?$qcontent)*$FWS?"$CFWS?)};

my $obs_dtext = qq{(?:$obs_NO_WS_CTL|$quoted_pair)};
my $dtext = qq{(?:[\\x21-\\x5A\\x5E-\\x7E]|$obs_dtext)};
my $domain_literal = qq{(?:$CFWS?\\[(?:$FWS?$dtext)*$FWS?\\]$CFWS?)};

my $word = qq{(?:$atom|$quoted_string)};
my $obs_local_part = qq{(?:$word(?:\\.$word)*)};
my $obs_domain = qq{(?:$atom(?:\\.$atom)*)};
my $local_part = qq{(?:$dot_atom|$quoted_string|$obs_local_part)};
my $domain = qq{(?:$dot_atom|$domain_literal|$obs_domain)};

# ここまで大崎さんのhttp://www.din.or.jp/~ohzaki/mail_regex.htm#RFCを参照

# addr_specを名前付きキャプチャ化
my $addr_spec = qq{(?<addr_spec>$local_part\@$domain)};


my $obs_phrase = qq{(?:$word(?:$word|\\.|$CFWS)*)};
my $phrase = qq{(?:$word+|$obs_phrase)};
my $display_name = $phrase;

my $obs_domain_list = qq{(?:(?:$CFWS|,)*\@$domain(?:,$CFWS?\@$domain)*)};
my $obs_route = qq{(?:$obs_domain_list:)};
my $obs_angle_addr = qq{(?:$CFWS?<$obs_route$addr_spec>$CFWS)};
my $angle_addr = qq{(?:$CFWS?<$addr_spec>$CFWS?|$obs_angle_addr)};
my $name_addr = qq{(?:$display_name?$angle_addr)};
my $mailbox = qq{(?:$name_addr|$addr_spec)};

my $obs_mbox_list = qq{(?:(?:$CFWS?,)*$mailbox(?:,(?:$mailbox|$CFWS)?)*)};

my $mailbox_list = qq{(?:$mailbox(?:,$mailbox)*|$obs_mbox_list)};

my $obs_group_list = qq{(?:(?:$CFWS?,)+$CFWS?)};
my $group_list = qq{(?:$mailbox_list|$CFWS|$obs_group_list)};
my $group = qq{(?:$display_name:$group_list?;$CFWS?)};
my $address = qq{(?:$mailbox|$group)};
my $obs_addr_list = qq{(?:(?:$CFWS?,)*$address(?:,(?:$CFWS|$address)?)*)};
my $address_list = qq{(?:$address(?:,$address)|$obs_addr_list)};

my $from = qq{From:$mailbox_list(?:$CR$LF)?};
my $sender = qq{Sender:$mailbox(?:$CR$LF)?};
my $to = qq{To:$address_list(?:$CR$LF)?};

sub addr_specs_from_from {
    my $input_from = shift;

    if ( $input_from =~ /\A$from\z/ ) {
        my @addr_specs = ();
        foreach my $addr_spec ( @{$-{addr_spec}} ) {
            push @addr_specs, $addr_spec if defined($addr_spec);
        }
        return \@addr_specs;
    }
    else {
        return;
    }
}
sub addr_specs_from_sender {
    my $input_sendr = shift;

    if ( $input_sendr =~ /\A$sender\z/ ) {
        foreach my $addr_spec ( @{$-{addr_spec}} ) {
            return $addr_spec if defined($addr_spec);
        }
    }
    else {
        return;
    }
}
sub addr_specs_from_to {
    my $input_to = shift;

    if ( $input_to =~ /\A$to\z/ ) {
        my @addr_specs = ();
        foreach my $addr_spec ( @{$-{addr_spec}} ) {
            push @addr_specs, $addr_spec if defined($addr_spec);
        }
        return \@addr_specs;
    }
    else {
        return;
    }
}

今回は対象がメールのヘッダなので、コメントやobsoleteなsyntaxについてもRFC完全準拠になっています。

確認は下記ようになコードで可能です。

use Data::Dumper;
print Dumper addr_specs_from_from('From: "hoge@example.com" (aaa (hoge) ) <foo@example.com>, <foo2@example.com>,foo3@example.com');
print Dumper addr_specs_from_sender('Sender: "hoge@example.com" (aaa (hoge) ) <foo@example.com>');
print Dumper addr_specs_from_to('To: "hoge@example.com" (aaa (hoge) ) <foo1@example.com>, <foo2@example.com>');

の結果は

$VAR1 = [
          'foo@example.com',
          'foo2@example.com',
          'foo3@example.com'
        ];
$VAR1 = 'foo@example.com';
$VAR1 = [
          'foo1@example.com',
          'foo2@example.com'
        ];

となります。

尚、Fromヘッダに複数のmailboxが指定されている場合には、Senderヘッダに単一のmailboxを指定することが必須(MUST)とされています(RFC5322 3.6.2)ので、addr_specs_from_fromから複数のaddr-specが帰ってきた場合はにaddr_specs_from_senderにSenderヘッダを渡すという利用がベストと思われます。

最後に、大崎さんに習って最終的な正規表現を晒そうかと思ったのですがFromのものが269,514バイトとかいうアホみたいな容量になったのでやめておきます。冗長なクラスタ化を避ければもうちょい短くはなるんでしょうが・・・。ひどいですね。ちなみにToヘッダはもっとひどくと1,394,979バイトです。1Mbyte突破してますw当然パフォーマンスも酷いもんです。実用にほぼ耐えません。名前付きキャプチャを全面的に使って書きなおすと正規表現自体は短くなりそうですがパフォーマンスはどうなんでしょうかね。うーむ。

尚、抽出できたaddr-specにはまだaddr-spec自体のコメントも残っている可能性があります。これを除去する方法はまた別のお話。

はてなブックマーク - メールヘッダからaddr-specを抜き出す正規表現

1 2 3 4 5 6 7 8 9

ホーム

検索
フィード
メタ情報

ページの上部に戻る