カテゴリー: perl

#isucon 4 予選に参加しました(スコア 37513)

@memememomo (uchiko) と onihsiと@cs_sonar(僕)で参加しました。
チーム名は「京都スイーツ」です。
結果としては本戦出場はできそうにないスコアで残念でした・・・。
(2014/10/06 追記。失格になってました。)

以下備忘録です。

インスタンス立ち上げ

AMI-IDをゲットしてインスタンスの立ち上げ。
全員にそれぞれ検証環境を用意する事を前日話していたのでインスタンス台数は4で一気に立ち上げ。
一つを本番用、他3つをメンバー用。

perlに切り替え

superviserd stopしてもrubyのアプリが立ち上がったままだったので
なんでやと思いながらも躊躇なくkill -killした。
無事perlで立ち上がってベンチ実行してスタートダッシュ成功。
一瞬でも1位がとれて、「優勝したあ!isucon優勝!」とあほみたいに騒ぐ。

ベンチを回すコマンド作成

ベンチマークツールの実行コマンド(特にapiキーあり)がいろいろ面倒なので

/bin/ben (ベンチテスト用)
/bin/benben (ベンチ+スコア送信用)

という名のシェルスクリプトを作る。
benben でスコア報告ベンチが走るのでちょっと楽。
ただ、これにより、「べんべんいく?」「とりあえずべんしよう」とかはたから見たら異様な会話に。

git(bitbucket)を使う

gitはbitbucketのプライベートリポジトリを使った。
このあたりの設定をmemememomoがやってくれた。

vim

memememomoが秘伝のvim設定を投入。

ログ解析

アクセスのパターンを確認できればいいかと簡易のアクセス解析ツールを使った。
前日にぐぐって見つけたvisitorsというもの。

cd /usr/local/src
wget http://www.hping.org/visitors/visitors-0.7.tar.gz
tar zxvf visitors-0.7.tar.gz
make
./visitors -A -o text /var/log/nginx/access_log
* Different pages requested: 4
1)    /: 4160
2)    /login: 2284
3)    /mypage: 440
4)    /report: 6

え、urlこんだけ!?

nginxの設定

nginxの設定が必要最低限だったので修正。
ついでに静的ファイルはnginxから返すようにやっておいた。

worker_processes 8;
events {
worker_connections  10000;
}
http {
sendfile        on;
include       mime.types;
upstream app {
server 127.0.0.1:8080;
keepalive 1000000;
}
server {
location /images {
alias /home/isucon/webapp/public/images;
}
location /stylesheets {
alias /home/isucon/webapp/public/stylesheets;
}
location = /favicon.ico {
log_not_found off;
alias /home/isucon/webapp/public/favicon.ico;
}
location / {
proxy_pass http://app;
}
}
}

mysqlの設定

mysqlも必要最低限だったので設定

[mysqld]
datadir=/var/lib/mysql
socket=/var/lib/mysql/mysql.sock
symbolic-links=0
max_allowed_packet=300M
skip-name-resolve
innodb_flush_log_at_trx_commit = 0
innodb_additional_mem_pool_size=40M
innodb_log_buffer_size=32M
innodb_log_file_size=256M
innodb_buffer_pool_size=3600M
max_connections = 2048
max_connect_errors = 10000
tmp_table_size=134217728
max_heap_table_size = 134217728
key_buffer_size = 512M
table_cache=2048
sort_buffer_size = 1M
read_buffer_size = 1M
read_rnd_buffer_size = 4M
myisam_sort_buffer_size = 1M
thread_cache_size = 128
thread_concurrency = 8
[mysqld_safe]
log-error=/var/log/mysqld.log
pid-file=/var/run/mysqld/mysqld.pid

ネットワークやサーバー制限まわりの設定

このあたりでつまずくのは時間が勿体ないので、あらかじめ上限をあげておきました。
(ですので、ローカルポート枯渇などではひっかかってないです)

iptablesをOFF
ipconntracとか出て時間をくいたくないので念のため。

/etc/init.d/iptables stop
chkconfig iptables off
chkconfig iptables --list
iptables -F

sysctl.conf の設定
この設定はvarnishの公式に「varnish使うならこんな設定まじおすすめ」みたいに紹介されてたもの。

net.ipv4.ip_local_port_range = 10240 65000
net.core.rmem_max=16777216
net.core.wmem_max=16777216
net.ipv4.tcp_rmem=4096 87380 16777216
net.ipv4.tcp_wmem=4096 65536 16777216
net.ipv4.tcp_tw_recycle = 1
net.ipv4.tcp_fin_timeout = 3
net.core.netdev_max_backlog = 30000
net.ipv4.tcp_no_metrics_save=1
net.core.somaxconn = 262144
net.ipv4.tcp_syncookies = 0
net.ipv4.tcp_max_orphans = 262144
net.ipv4.tcp_max_syn_backlog = 262144
net.ipv4.tcp_synack_retries = 2
net.ipv4.tcp_syn_retries = 2
net.ipv4.tcp_max_tw_buckets = 56384

ファイルディスクリプタでも時間をくいたくないのでlimits.confを設定。

*               hard    nofile             65535
*               soft    nofile             65535

ここまでやってみてスコアは2500とあまりかわらず。
MySQLボトルネックなのはわかっていたのでボトルネックがうつった時に効果を発揮してくれるでしょう

インデックスを張る

onihsiがインデックスを張ってくれました

ALTER TABLE `isu4_qualifier`.`login_log`
ADD INDEX `ip` (`ip` ASC),
ADD INDEX `login` (`login` ASC),
ADD INDEX `user_id-succeeded` (`user_id` ASC, `succeeded` ASC),
ADD INDEX `ip-succeeded` (`ip` ASC, `succeeded` ASC),
ADD INDEX `succeede-user_id` (`succeeded` ASC, `user_id` ASC);

これと上記のインフラ周りの修正でスコアは20000くらいになった。

banのユーザをredisでカウントするようにした

ipアドレス と ユーザー名を各々キーにしてログイン失敗で

    $self->redis->incr($ip);
$self->redis->incr($user->{id});

みたくインクリメント
ログイン成功で

    $self->redis->set($user->{id}, 0);
$self->redis->set($ip, 0);

ゼロに戻す

これでip_bunnedの確認とかが

sub ip_banned {
my ($self, $ip) = @_;
return undef unless $ip;
my $count = $self->redis->get($ip) || 0;
return $self->config->{ip_ban_threshold} <= $count;
};

となる
でも/reportsの修正は怖かったのでlogin_logへのINSERTはそのまま。
こんな修正をmemememomoがばばーとやってくれた。

でも24000。あんまりのびなくてあるぇえええ?ってなる。

セッションの管理をメモリで行うようにした

@memememomoがベンチ回すと「max Open files」的なエラーが出るというので見てみると
/tmp内にあるセッションファイルがものごっつい量になっていた。
これ以上ファイルが書き込めないという状態になっていて1ディレクトリの上限ファイル数でも叩いてたのかな。(あんまり調べてない)
こんだけファイルができるくらいだからセッション書き込みにおけるディスクIOも問題となっているに違いない事に気づいて
memememomoにセッションをメモリで管理するように変更してもらった。

Plack::Session::Store::Cache
Cache::FastMmap
CHI

redis使うよりもこっちの修正のほうが効いて
たぶんここらへんで32000
いや、まぁここがボトルネックで解消した結果redis修正が生きた、という可能性もありますが。

平文のパスワード

このときベンチではもうほとんどがアプリの負荷だったのでどこかアプリで重いとこないかを探した。
プロファイルしようかともmemememomoが悩んでたんですが
calculate_password_hashって明らかに重いだろ、、、という事でここをなんとかする事に。

元のinitialのsqlデータやtsvデータには元passwordが平文で書かれてたのでこれを入れちゃえば
calculate_password_hash使わなくてよくなる。
usersテーブルをコピーしてusers_pwを作成。
ここのpassword_hashに平文のパスワードを入れて、平文のパスワードで認証するようにした。
これでなんか重そうな雰囲気のcalculate_password_hashを呼ばなくてよくなった。

終わり

ベンチ中topをなにげなく眺めてると、memememomoの秘伝のvimがCPU20~30%も消費してる事を発見。
vimを落としたベンチで
Score 37513 の最高スコアを送信してend

無駄だったこと1

/のエラー文言部分だけを別URLにしてindex.txからSSIで読むようにした。
これにより/をnginxでキャッシュできたんだけど、速くなるわけなかった。
ssi処理のぶん遅くなっただけで意味がなくて元に戻した。
なんでこれで早くなると思ったのか思い返したら謎。

無駄だったこと2

ログイン失敗数等を別テーブルで持たせてSQLの負荷軽減をした。
Redisでカウントする事にしたのでこの修正も無駄になった。

やりたかったこと1

すべてのデータをredisに入れてmysqlと決別したかった。
でも過去の経験から普段やったことない作業をやると泥沼化が見えてるのでやらない事にした。
具体的にはreportsの部分に手を入れるのが怖かったのと、redis力が不安だった

反省会

反省会の焼肉屋でTOPページのindexをエラー文言別に静的に用意しておいてnginxがCookieで振り分けると早くなりそうという案が出た。
他の人のブログでもそんな改修があって、これについては気づきが足りなかったなぁと悔しい思いに。
実際この作業をやっても43000点くらいまでしか伸びなかったのですが、
これをやってたら本戦にもしかしたら出れたかもと思うとうぎゃーとなりました。

最後に

最後になりましたが、isuconには今回でもう4回も参加させていただいており、
企画/運営/協賛されておりますLINE/cookpad/DATAHOTEL/Amazonの皆様にはほんとうに感謝しております。
ありがとうございます!

本戦出場者が決定しました!

http://isucon.net/archives/40576269.html

京都スイーツはギリギリだめでした。。。と思って読み進めると、失格してました。

・「京都スイーツ」チームは、 /mypage にログインユーザ名が表示されていないため、表示崩れとみなし、失格といたしました。

調べてみると SELECT * を書き換える時に必要なカラムが漏れてた模様。
どちらにしてもスコア足りてなかったので結果は同じですが失格は悲しい。
一応チェックされるほどの上位にいけたということで許して下さい、、、と会社に言い訳。

ここまでチェックするって運営さんはすごく大変だったろうな、、、と改めて感謝の気持ちでいっぱいです。
今年も楽しい問題、ありがとうございました。

isucon#3 オンライン予選を総合4位で暫定通過しました

isucon#3 オンライン予選2日目に、
@memememomoと「進撃の超大型パティスリー兄弟」として参加してきました。
現在はまだ暫定ではありますが、2日目の1位(総合4位)で予選通過予定とのことです。

過去に isucon#1, isucon#2 と参加してきて、
思ったような結果を残せなかったので、今回は非常に嬉しいです。
チューニング内容的には普通のことしかしておらず、その辺りは他のひとの方が大分詳しい印象。
3度目の挑戦ならではの対策などについて書いてみました。

事前準備

事前に決めていた対応方針は以下のようなものです。
・使用する言語は、Perl(@memememomoの強い要請により)
・2人で並行作業は行わず(インフラ/プログラムで担当分けせず)すべてダブルチェック対応
ボトルネックへの対応に集中する
方針がブレるとisuconの熱気にやられておかしな方向に進んでしまうため、
対策の方針を決めるのは僕たちにとっては重要でした。

当日の朝は、Lingrのログを見たり、AWSのSecurityGroupを作ったりしてました。
また、一日目の上位スコアは公開されていたので、
予選通過ラインは1万点くらいだろうと見積もることもできました。

isuconスタート

git導入して初期準備は完了。
README.mdを読む。
workloadオプションは、ダブルチェックで間違った認識に着地。
なので一回も使ってません。

環境作ったり、システム確認したりで、
チューニングに着手したのは、11:00頃でした。
無駄に指差しダブルチェックしててかなり時間をロスしていたと思います。
初期スコアは、700点くらい。
このときすでに1位は2,000〜3,000点くらいだったと思います。

初期状態ではMySQLボトルネックになっていたので、
スロークエリを改善したり、インデックス貼ったり、
プロキシサーバをapacheからvarnishに変更したり。
この時点でスコアは2,500くらいでトップ10圏外でした。

また、最初からnginxが入っていて怪し過ぎたので
完全削除してインストールし直しました。
isuconでは予め用意されているものはワナにしか見えません。
静的ファイルをnginxに任せて、スコアは若干上がったと思います。

その後、地味にSQLを改善し続けて、
14時過ぎにスコアは3,800くらいとなり、
ここでようやくtop10に入りました。

その後もひたすら普通にSQLの改善を続けて、
15時頃にスコアは4,600くらいに。

そして、残り3時間

予選2日目は、1日目よりも他チームのスコアの伸びが早かったと思います。
この時点でトップはすでに2万を超えていましたし、
僕たちはトップ10から外れていました。
2日目のtop10のスコアは1万を超えてくるかもしれないという不安が過ります。
そろそろ、何らかのブレークスルーを出さなければ負ける時間帯だと思えてきました。
アプリ側でまだまだ改善すべき処理は残っていたのですが、
ワナに掛かってもまだ時間のあるこのタイミングでの
フロントでのキャッシュ対応に切り替えました。
想像以上にキャッシュ対策が上手くハマり、FAILを出しつつも24,000くらいのスコアで一気にトップに。
さらにキャッシュの調整を加え、30,000を超えました。
オンライン予選では、AMIの提出までが勝負なので、
実際にベンチを走らせることができる18:00までに、
もろもろのテストを行うことにしました。
AMIを作成し、他アカウントでインスタンス起動/ベンチ実行。
スコアも問題ないことを確認しました。
そして無事に予選終了。

まとめ

ボトルネック対応に集中したのが良かったと思います。
ダメなところもありましたが、指差しダブルチェックもいい感じでした。
初動が遅かったので本戦ではスピーディに対応したい。
SQLの改善では既存スキーマから大幅に変えることはしませんでしたが、
そのおかげで着実にスコアは上がったものの、
微増といった感じだったので、もっと思い切って変えてもよかったなと思っています。

最後になりましたが、isuconには今回で3回も参加させていただいており、
企画/運営をされておりますLINE/面白法人カヤック/DATAHOTELの皆様には
ほんとうに感謝しております。ありがとうございます!

isucon3 予選で敗退しました(うさぎ工房)

isuconは初回からずっと出ているのでこれで3回目。

いつもは同僚の@shokiri @memememomo (Uchiko) 、僕、の3人で出場するのですが
お互いの予定の折り合いがつかず、僕は出場できない可能性が出てきました。
でも僕はどうしても出場したい・・・!

そこで、いつもの社内メンバーは「進撃の超大型パティスリー兄弟」
僕は一人ソロ活動で社外の友人(@gom_oh)や元社員(ttoz)を誘って「うさぎ工房」として予選登録しました。

僕自身がOps側である所や、メンバーのプログラマPerlPSGI/Plackは初めて触る二人だったので
集まって過去ISUCONで自家製ISUCONしたり、クエリ最適化について勉強したりといった準備をしました。

結果はスコア的には5300でfinish。見事敗退となりました。

ちなみに弊社の本チームである「進撃の超大型パティスリー兄弟」チーム側は
なんと総合4位で予選通過!さすがです!
若干悔しさもあるけど、弊社から本戦にいく人がいて、本当に嬉しかったです。おめでとうございます!
そちら側の詳細はきっと彼らが記事にしてくれるはず。本戦でもばっちり頑張ってください!

こちらの記事は点数の低い僕らがやった事なので、
アンチパターンとして楽しんでいただければ。

最終構成

最終的には varnish perl mysql とちょっとだけmemcached の構成でした。

phpMyAdminを立ち上げる

まず、MySQL関連の操作でphpMyAdminしか使えない僕はphp5.5をソースコンパイル
ビルドインサーバーとして立ち上げました。これ便利ですね

/usr/local/lib/php -S 0.0.0.0:3000

my.cnfを設定

APIキー登録して初回ベンチが確認する。たしか800くらいでした。
初回ベンチですぐにDBボトルネックとわかったので、my.cnfを以下に変更。
(ええ、もちろん find / -name my.cnf しました。)

key_buffer = 512M
max_allowed_packet = 10M
table_open_cache = 10240
sort_buffer_size = 1M
read_buffer_size = 1M
read_rnd_buffer_size = 4M
myisam_sort_buffer_size = 1M
thread_cache_size = 128
query_cache_type= ON
query_cache_size= 16M
thread_concurrency = 8
innodb_flush_log_at_trx_commit = 0
innodb_file_per_table
innodb_additional_mem_pool_size=40M
innodb_log_buffer_size=32M
innodb_log_file_size=256M
innodb_buffer_pool_size=8000M
max_connections = 2048
max_connect_errors = 10000
tmp_table_size=1342177280
max_heap_table_size = 1342177280

インデックスを張りました

最終的にはcreated_atとか使ってなかったので無駄だった。

ALTER TABLE `memos` ADD INDEX ( `created_at` ) ;
ALTER TABLE `memos` ADD INDEX ( `user` ) ;

ここらへんで1500くらいだったかな。

フロントエンドはVarnish

フロントエンドはVarnishを使用。
編集や削除はされないようだったので、なんとかリクエストヘッダの値から「ログインしているか否か」を判別して全体キャッシュできないか考えてましたが、リクエストヘッダで判断できる材料がなく、また、Plackとか全然わからないのでヘッダーの修正とかはできませんでした。

結局フロントエンド側での大規模なキャッシュは僕の力では厳しそうだったので
静的ファイルだけvarnishでキャッシュ。設定の主要部分だけだけど以下のような感じ。

backend web1 {
.host = "127.0.0.1";
.port = "5000";
}
sub vcl_recv {
set req.backend = web1;
if (req.url ~ "\.(jpg|png|gif|css|js|ico)$") {
return (lookup);
}
return (pass);
}
sub vcl_fetch {
set beresp.ttl = 86000s;
return (deliver);
}

スキーマとかSQLの改修

ここらへんで2500くらいだったかな。
この時でもDBボトルネックはまだまだ明らかでしたので
ここでメンバーの@gom_ohがDBに以下の改修を行いました。

内容は公開IDの一覧だけのテーブルを作ってtopページやrecentページのDB負荷を削減する、といった感じの修正となります。

CREATE TABLE `public_id` (
`memo_id` int(11) NOT NULL,
PRIMARY KEY (`memo_id`)
) ENGINE=InnoDB DEFAULT CHARSET=utf8;'

public_idというmemosテーブルでパブリックに公開しているだけのmemo_id一覧を入れるテーブルを作成しました。
それから、ベンチ実行後のスクリプトで現在公開中である記事のIDをインサート

INSERT INTO public_id (memo_id) SELECT id FROM memos WHERE is_private = 0 ORDER BY id DESC;

上記は初期スクリプトで実行。

#公開ページの総数
SELECT count(*) FROM memos WHERE is_private=0SELECT count(memo_id) FROM public_id
#TOPページ
SELECT * FROM memos WHERE is_private=0 ORDER BY created_at DESC, id DESC LIMIT 100SELECT m.id, u.username, m.created_at, m.content
FROM memos m
JOIN (
SELECT p.memo_id
FROM public_id p
ORDER BY p.memo_id DESC
LIMIT 100
) t
ON m.id = t.memo_id
JOIN users u
ON u.id = m.user;
#recentページ
SELECT * FROM memos WHERE is_private=0 ORDER BY created_at DESC, id DESC LIMIT 100 OFFSET %d", $page * 100

SELECT m.id, u.username, m.created_at, m.content
        FROM memos m
        JOIN (
          SELECT p.memo_id
          FROM public_id p
          ORDER BY p.memo_id DESC
          LIMIT 100 OFFSET %d
        ) t
        ON m.id = t.memo_id
        JOIN users u
        ON u.id = m.user',
        $page * 100);

これでスコアが5000くらいになりました。

Markdownの結果をmemcacheでキャッシュ

その他はMarkdownの処理が重かったので、ここだけmemcacheでキャッシュとか、ちまちまして5300くらいに。
まんまとポート11211につないでましたが。

あとどこかのタイミングでStarmanからStarletに変更しましたがスコア的に動きはなし。
最終的にはまだまだDBがボトルネックなまま5300でフィニッシュとなりました。

感想

初日に「1位の人とか人間なの?」と思ってたのですが、
2日目の弊社メンバーが1位に輝いてて、出先からの発表見てのけぞった。
どんな事をしたのか聞くのが楽しみです。

競技中も楽しかったのですが、普段なかなか会えない友達や元同僚と集まって
お菓子ほおばりながら共通の目的をもって取り組んだ時間が勉強になったし楽しかった。
特に普段は他の二人にまかせていた所を本腰を入れて取り組まないといけない状態だったので、
今まで以上にソースを見たりDB構造を見たり、という部分に入っていけたのがよかったです。

反省点としては、

[READMEをしっかり読んで意識を共有しておけばよかった]
workloadがAMI提出時のコマンド入力で気づきました。「ただボトルネック調査の為に負荷を大きくできる」くらいの認識しか持ってなくて(んなわけないのに)、、、試せる事はちゃんと試すべきでした。結果、一度もWorkloadを変更してなかった!!

[とりあえずperlだろみたいな雰囲気になってた。]
やりたい事をちゃんとやれる言語でやる道も検討したらよかったと。PHPで着実なボトルネック修正で予選抜けたところもあってそう思いました。「こうしたら早くなりそう!」→「Perl、、というかPlackって奴でどうやんの。」→「わからん」、のコンボが多かった。

ISUCONは参加者は楽しいけど、運営の方々は本当に大変そうで少し申し訳ない気持ちに。
運営の皆様本当にありがとうございました。

そして「進撃の超大型パティスリー兄弟」、本戦がんばれー!

おまけ

終了後に本番ベンチが解放されていたのでWorkload 5くらいでまわした結果

Result:   SUCCESS
RawScore: 8285.3
Fails:    0
Score:    8285.3
[OK] 結果を管理サーバに送信しました

ちょっとあがった。

メールを大量にテスト受信するサーバを作ってみた話

とにかく大量のメールを受信するだけサーバが欲しかったのでPerlで作ってみました。

Net::Server::Mail::SMTP + Parallel::Preforkを使ったプリフォーク型サーバにしました。
Net::Server::Mail::SMTPSMTPコマンドそれぞれの処理を書き、
Parallel::Preforkでプリフォークの制御を行っています。

以下がサーバのプログラムになります。
プログラムの構成としては、Starletのコードを参考にしています。

package TestMailReceiver;
use strict;
use warnings;
use IO::Socket::INET;
use Parallel::Prefork;
use Net::Server::Mail::SMTP;
use Socket qw(IPPROTO_TCP TCP_NODELAY);
sub new {
my ($class, %args) = @_;
my $self = bless {
host        => $args{host} || 0,
port        => $args{port} || 25,
max_workers => $args{max_workers} || 10,
};
$self;
}
sub setup_listener {
my $self = shift;
$self->{listen_sock} ||= IO::Socket::INET->new(
Listen    => SOMAXCONN,
LocalPort => $self->{port},
LocalAddr => $self->{host},
Proto     => 'tcp',
ReuseAddr => 1,
) or die "failed to listen to port $self->{port}:$!";
if ($^O eq 'linux') {
setsockopt($self->{listen_sock}, IPPROTO_TCP, 9, 1)
and $self->{_using_defer_accept} = 1;
}
}
sub accept_loop {
my ($self, $max_reqs_per_child) = @_;
my $proc_req_count = 0;
while (! defined $max_reqs_per_child || $proc_req_count < $max_reqs_per_child) {
if (my $conn = $self->{listen_sock}->accept) {
$self->{_is_deferred_accept} = $self->{_using_defer_accept};
$conn->blocking(0)
or die "failed to set socket to nonblocking mode:$!";
$conn->setsockopt(IPPROTO_TCP, TCP_NODELAY, 1)
or die "setsockopt(TCP_NODELAY) failed:$!";
$proc_req_count++;
my $smtp = Net::Server::Mail::SMTP->new( 'socket' => $conn );
$smtp->set_callback( 'RCPT' => sub { return (1) } );
$smtp->set_callback( 'DATA' => sub { return (1, 250, 'message queued') });
$smtp->process;
$conn->close;
}
}
}
sub run {
my ($self) = @_;
$self->setup_listener();
if ($self->{max_workers} != 0) {
# use Parallel::Prefork
my %pm_args = (
max_workers => $self->{max_workers},
trap_signals => {
TERM => 'TERM',
HUP  => 'TERM',
},
);
my $pm = Parallel::Prefork->new(\%pm_args);
while ($pm->signal_received !~ /^(TERM|USR1)$/) {
$pm->start and next;
$self->accept_loop();
$pm->finish;
}
} else {
# run directly, mainly for debugging
local $SIG{TERM} = sub { exit 0; };
while (1) {
$self->accept_loop();
}
}
}
1;
package main;
my $server = TestMailReceiver->new(
host => '',
port => 25,
max_workers => 200,
);
$server->run;

メールを受信してファイル書き込まずに捨てるだけのサーバです。
メールをファイルに書き出す処理など、普通のサーバで行われる処理を全部無くしているので、
大量のメールを受信してもだいぶ軽い動作になりました。

TODOとしては、テストでメール受信統計などを取ることができるようになればいいなと思ってます。

以下、主に使っているモジュールについての解説です。

Net::Server::Mail::SMTP

Net::Server::Mail::SMTPSMTPプロトコルを実装したモジュールです。
Net::Server::Mail::SMTPを使えば、自前のSMTPサーバを簡単に作ることができます。
HELO, MAIL, RCPT, DATAなどのコマンドに対する処理をコールバックの形で書きます。

use strict;
use warnings;
use utf8;
use IO::Socket::INET;
use Net::Server::Mail::SMTP;
my @local_domains = qw(example.com example.org localhost);
my $msgid = 1;
sub add_queue {
return $msgid++;
}
my $server = IO::Socket::INET->new(
Listen => 1,
LocalPort => 2500,
);
my $conn;
while ($conn = $server->accept) {
my $smtp = Net::Server::Mail::SMTP->new(
socket => $conn,
);
# HELOコマンドの処理
$smtp->set_callback(
HELO => sub {
my ($session, $hostname) = @_;
if ($hostname eq 'localhost') {
return (0, 553, q(I don't like this hostname, try again.));
}
return 1;
},
);
# RCPTコマンドの処理
$smtp->set_callback(
RCPT => sub {
my ($session, $recipient) = @_;
my $domain;
if ($recipient =~ /@(.*)\s*$/) {
$domain = $1;
}
if (not defined $domain) {
return (0, 513, 'Syntax error.');
}
elsif (not(grep $domain eq $_, @local_domains)) {
return (0, 554, "$recipient: Recipient address rejected: Relay access denied");
}
return (1);
}
);
# DATAコマンドの処理
$smtp->set_callback(
DATA => sub {
my ($session, $data) = @_;
my $sender = $session->get_sender();
my @recipients = $session->get_recipients();
return (0, 554, 'Error: no valid recipients') unless @recipients;
# キューに追加。add_queueは自前で実装する必要がある
my $msgid = add_queue($sender, \@recipients, $data) or return(0);
return (1, 250, "message queued $msgid");
}
);
$smtp->process();
$conn->close();
}

このコードを実行し、以下のようにtelnetで繋いで各コマンドの動作を確かめると、
意図したレスポンスがサーバから返ってくることが確認できます。

$ telnet localhost 2500
Trying 127.0.0.1...
Connected to localhost.
Escape character is '^]'.
220 debian2 SMTP Net::Server::Mail (Perl) Service ready
HELO localhost
553 I don't like this hostname, try again.
HELO hogehoge
250 Requested mail action okay, completed
MAIL FROM: 
250 sender hogehoge@example.com OK
RCPT TO: 
554 hogehoge@example.net: Recipient address rejected: Relay access denied
RCPT TO: 
250 recipient hogehoge@example.com OK
DATA
354 Start mail input; end with .
test
.
250 message queued 1
quit
221 debian2 Service closing transmission channel
Connection closed by foreign host.

テストでSMTPサーバを作成したい場合などに便利ですね。

自動テストのためにメールサーバを一時的に起動する

Parallel::Prefork

Parallel::Preforkはプリフォークサーバを書くためのモジュールです。
似た名前で似た使い方をするParallel::ForkManagerというモジュールがありますが、
Parallel::Preforkはシグナル管理が可能になっています。

たとえば次のようなプリフォーク型Echoサーバを書くことができます(あんま有用ではないですが)。

use strict;
use warnings;
use utf8;
use IO::Socket::INET;
use Parallel::Prefork;
sub MaxRequestsPerChild() { 100 }
my $listen_sock = IO::Socket::INET->new(
Listen => 5,
LocalAddr => '0.0.0.0:5000',
Proto  => 'tcp',
) or die $!;
my $pm = Parallel::Prefork->new({
max_workers => 10,
trap_signals => {
TERM => 'TERM',
HUP  => 'TERM',
}
});
while ($pm->signal_received ne 'TERM') {
# ワーカープロセス生成処理
$pm->start and next;
#### ここからワーカープロセス処理
# 1ワーカーがリクエストを受け付ける数
my $reqs_before_exit = MaxRequestsPerChild;
$SIG{TERM} = sub { $reqs_before_exit = 0 };
while ($reqs_before_exit-- > 0) {
if (my $conn = $listen_sock->accept()) {
while (my $str = ) {
print $conn "$reqs_before_exit($$): ".$str;
}
$conn->close;
}
}
# ワーカープロセスの終了処理
$pm->finish;
}
# 子プロセス待ち受け
$pm->wait_all_children;

このサーバを実行して、psコマンドで確認してみると「max_workersで設定した数値 + 親プロセス」分のプロセスが存在していることが確認できます。

$ perl prefork_echo.pl &
$ ps a | grep prefork_echo.pl
3963 pts/3    S      0:00 perl prefork_echo.pl
3964 pts/3    S      0:00 perl prefork_echo.pl
3965 pts/3    S      0:00 perl prefork_echo.pl
3966 pts/3    S      0:00 perl prefork_echo.pl
3968 pts/3    S      0:00 perl prefork_echo.pl
3969 pts/3    S      0:00 perl prefork_echo.pl
3970 pts/3    S      0:00 perl prefork_echo.pl
3971 pts/3    S      0:00 perl prefork_echo.pl
3972 pts/3    S      0:00 perl prefork_echo.pl
3973 pts/3    S      0:00 perl prefork_echo.pl
3983 pts/3    S      0:00 perl prefork_echo.pl
4085 pts/3    S+     0:00 grep prefork_echo

また、telnetを用いて接続も確認できます。

$ telnet localhost 5000
Trying 127.0.0.1...
Connected to localhost.
Escape character is '^]'.
test
99(3967): test
test1
99(3967): test1
test2
99(3967): test2```
何回か繋ぎ直すと、異なるプロセスが対応する様子が確認できます。
pstreeなどで親プロセスの番号を調べて、SIGTERMを送るとサーバを終了させることができます。

$ kill -TERM 3963

このように簡単にプリフォークサーバを書けるようになっています。
<h2><span style="color: #2196f3">まとめ</span></h2>
メール送信系のシステムをテストする場合は、Net::Server::Mail::SMTPで受信サーバを書くのがとても良いです。
また、プリフォークサーバを書きたい場合は、Parallel::Preforkがとても便利です。
このようなツールを書くのに便利なモジュールがあって、やっぱりCPANは素晴らしいですね。
<h2><span style="color: #2196f3">参考</span></h2>
・Net::SMTP vs. Email::Send(er)?
<a href="http://blog.azumakuniyuki.org/2011/08/netsmtp-vs-emailsender.html">http://blog.azumakuniyuki.org/2011/08/netsmtp-vs-emailsender.html</a>
・Parallel::Prefork - Perl でマルチプロセスなサーバを書く方法
<a href="http://labs.cybozu.co.jp/blog/kazuho/archives/2008/04/parallel-prefork.php">http://labs.cybozu.co.jp/blog/kazuho/archives/2008/04/parallel-prefork.php</a>

Perlに関する情報の調べ方・集め方

Perlに関する情報の調べ方や集め方、有益なサイトや書籍などをまとめてみました。

Perl入門に関する情報

サンプルコードによるPerl入門(サイト)

http://d.hatena.ne.jp/perlcodesample/

サンプルコードがたくさんあってとても分かりやすいサイトです。
現代的なPerlの書き方が学べます。

以下の目次ページを上から順番に読めば、すぐにPerlの全体像はつかめると思います。
http://d.hatena.ne.jp/perlcodesample/20091221/1260183022

Perl入学式(勉強会)

http://www.perl-entrance.org/

Perlの基本を学び、Webアプリケーションを作るまでを目標にした勉強会です。
自分で手を動かしながらの勉強会なので身につきやすいです。
2013年は大阪と東京でそれぞれ全6回を予定しているそうです。

Webサービスのつくり方 ~「新しい」を生み出すための33のエッセイ(書籍)

http://yusukebe.com/archives/20121113/091343.html

「ボケて」をPerlで開発した@yusukebeさんの本です。
アイディアを形にする方法が学べます。
Perl中心の本ではないですが、Perlで何ができるかを知ることができます。

Perlの最新情報

Perlの最新情報を得る方法には、次のような方法があります。

Perlをよく使っている人のTwitterやブログを購読する

Perlをよく使っている人たちが発信する情報はとても有益です。
Twitterやブログを購読して読んでいれば、自然とPerlの動向などが分かるようになります。
Perlをよく使っている人たちはPerl関連のイベントで発表していることが多いので、
イベントページなどから見つけましょう。

例えばYAPC::Asiaのページから見つけることができます。
http://yapcasia.org/2012/talk

以下の様なまとめもあります。
■今すぐフォローすべきPerl界のスーパーエンジニア
http://d.hatena.ne.jp/sugyan/20110616/1308203734

Perl関連のイベントに参加する

イベントに参加すると自分が知らないことをたくさん知ることができます。
インターネットや書籍だけだと、自分の興味や問題の範囲のみに無意識的に偏ってしまいます。
イベントだと自分が調べないような分野の話も聞くようになるので、とても勉強になります。

いくつかイベント情報を上げておきます。

YAPC::Asia
http://yapcasia.org/
年に一回日本で開催されるPerlのイベントです。
豪華ゲストが来ます。

■PMグループ
http://www.pm.org/groups/japan.html
地域ごとに集まって定期的(不定期?)に勉強会や情報交換会などを行います。

Perl Begginers
http://www.perl-beginners.org/
参加したことないので雰囲気は知らないですが、質疑応答が多めに取られている勉強会でしょうか。

Perlの書籍

読みやすい本をご紹介します。

Perl CPANモジュールガイド

http://www.amazon.co.jp/dp/486267108X

よく使われていて便利なモジュールが紹介されている本です。
Cpanサイトで検索しても何を使ったらいいのか分からない場合、
この本を参考にすると良いでしょう。

もっと自在にサーバを使い倒す 業務に役立つPerl

http://www.amazon.co.jp/dp/4774150258

Perlの現代的な書き方、ログデータの加工、Webフレームワークの使い方など、
実践的なPerlの使い方を学ぶことができます。

Webサービスのつくり方 ~「新しい」を生み出すための33のエッセイ

http://www.amazon.co.jp/dp/4774154075

PerlでWebAPIを利用したりフレームワークを使ってサービスを作ったりする雰囲気が学べます。

Perlスティング ハンドブック

http://www.amazon.co.jp/dp/B00A5Q6EM2

Perlでテストを書くときのノウハウを知ることができます。
どんなテストモジュールを使ったら良いのか、どのようにテストを書いたら良いのかを学ぶことができます。

Plack Handbook

http://www.amazon.co.jp/dp/B009Z30LRA

PlackベースのWebフレームワークを扱う場合に知っておいたほうが良い内容です。

ググりにくいこと

正規表現について

■実践で役立つPerl正規表現 完全解説
http://d.hatena.ne.jp/perlcodesample/20100827/1278596435

正規表現の解説。

Perl正規表現チュートリアル
http://perldoc.jp/docs/perl/5.16.1/perlretut.pod

長めのチュートリアル

Perl正規表現のリファレンス
http://perldoc.jp/docs/perl/5.16.1/perlreref.pod

記号の意味を知りたいとき。

特殊変数について

$|とか$!とかの意味を知りたい場合。

Perl で定義済みの変数
http://perldoc.jp/docs/perl/5.16.1/perlvar.pod

ブラウザページ内検索をすれば、引っかかるでしょう。

■perldocコマンド
以下のように「-v」オプションで調べることができます。

perldoc -v $.

Perlのコンテキストについて

Perlを書いていると次のような部分で引っかかることがあります。

  • スカラー変数($hoge)と配列変数(@hoge)のどちらを使うか
  • 関数の引数の渡し方
  • 関数の返り値の受け取り方

これらは様々なパターンがあるので、Perlを普段から書いていないと迷ってしまいます。

Perlには「コンテキスト」という考えがあります。
コンテキストを理解すれば、すべてのパターンを覚えなくとも、上であげたことが大体わかるようになってきます。

コンテキストとは

コンテキストは、次の二種類あります。

  • スカラーコンテキスト
  • リストコンテキスト

スカラーコンテキストとは以下のようなものが書かれている場所をいいます。

1         # 数値
'hoge'    # 文字列
$hoge     # スカラー変数
\@hoge    # リファレンス

リストコンテキストとは以下のようなものが書かれている場所をいいます。

@array    # 配列
%hash     # ハッシュ
(1, 2)    # リスト

Perlプログラムを書いているときは、どちらのコンテキストになっているのかを意識するようにします。

代入

代入では、左辺と右辺がそれぞれどちらのコンテキストになっているのかを意識します。
ほとんどの場合は、同じコンテキストになるようにします。

左辺も右辺もスカラーコンテキストの場合。

# 左辺がスカラー、右辺もスカラー
my $a = 'test';
my $b = $a;

左辺も右辺もリストコンテキストの場合。

# 左辺がリスト、右辺もリスト
my @a = (1, 2, 3);
my @b = @a;
my ($a, $b) = (1, 2);
my ($a, $b) = @list;
my %a = (a =&gt; 1, b =&gt; 2);
my %b = %a;

配列とハッシュは共にリストコンテキストになるので、相互代入することができます。
実は、Perlのハッシュで使われている「=>」は、「,(コンマ)」と等価です。

my @a = (a =&gt; 1, b =&gt; 2);  # -&gt; ('a', 1, 'b', 2)
my %b = @a                 # -&gt; (a =&gt; 1, b =&gt; 2)
my %a = ('a', 1, 'b', 2);  # -&gt; (a =&gt; 1, b =&gt; 2) ※順番は保持されない

リファレンスはスカラー値なので、スカラー変数で受け取ります。

# 配列リファレンス
my $array_ref = \@a;
# ハッシュリファレンス
my $hash_ref = \%a;
# 無名配列リファレンス
my $array_ref = [1, 2, 3, 4];
# 無名ハッシュリファレンス
my $hash_ref = { a =&gt; 1, b =&gt; 2 };

配列リファレンスをデリファレンスすると、リストコンテキストになるので、配列変数で受け取ります。
ハッシュのリファレンスも同じです。

# デリファレンス後はリストコンテキストなので、配列変数で受け取る
my @a = @{ $array_ref };
my %a = %{ $hash_ref };

for文

for文のカッコの中はリストコンテキストになるので、リストを渡すようにします。

for my $a ( 1, 2, 3 ) {}
for my $a ( @array ) {}
for my $a ( @{ $array_ref } ) {}

関数

関数の引数は、無名配列変数の「@_」で受け取られます。
左辺がリストコンテキストである場合の代入だと考えると良いでしょう。

func($a, $b);
sub func {
my ($a, $b) = @_;
}

配列リファレンスを引数にする場合。

func($a, \@list);
sub func {
my ($a, $list_ref) = @_;
my @list = @{ $list_ref };
}

関数の返り値を受け取る場合も、返り値のコンテキストを意識します。

# 文字列を返す(返り値はスカラーコンテキスト)
sub func1 {
return 'a';
}
my $result = $func1();
# 配列を返す(返り値はリストコンテキスト)
sub func2 {
my @list = (1, 2, 3);
return @list;
}
my @result = func2();
my ($a, $b, $c) = func2();
# 配列リファレンスを返す(返り値はスカラーコンテキスト)
sub func3 {
my @list = (1, 2, 3);
return \@list;
}
my $result = func3();

wantarrayを使うと、関数呼び出し側のコンテキストによって、
返り値のコンテキストを変更することができます。

sub func1 {
my @a = (1, 2, 3, 4);
if (wantarray) {
return @a;
} else {
return \@a;
}
}
# リストコンテキストで受け取る
my @list = func1();
# スカラーコンテキストで受け取る
my $list = func1();

参考ページ

この他にも色々なパターンや例外があるので、後は以下のようなページを参考にして下さい。
コンテキストがわかっていれば、それぞれのパターンについても覚えやすくなるのではないかと思います。

perlbrewで構築するモダンなPerl環境

ダンPerl環境構築方法をご紹介したいと思います。
perlbrewは、ホームディレクトリに複数のperlをインストールして切り替えをしてくれるツールです。

perlbrewのインストール

以下のようなコマンドを実行すると、prebrewをインストールできます。

$ curl -kL http://install.perlbrew.pl | bash

perlbrewのインストール方法はいくつかあります。
他の方法は以下のサイトを参照して下さい。

http://perlbrew.pl/

perlbrewコマンドを使うためにインストールされたコマンドにパスを通す設定が必要です。
bashならbashrcに以下のような設定を書くと良いでしょう。

source ~/perl5/perlbrew/etc/bashrc

perlbrewでPerlをインストール

以下のコマンドで、利用できるPerlのバージョンを確認できます。

perlbrew available

現時点では以下の様なリストが表示されました。

perl-5.17.6
perl-5.16.2
perl-5.14.3
perl-5.12.5
perl-5.10.1
perl-5.8.9
perl-5.6.2
perl5.005_04
perl5.004_05
perl5.003_07

最新版をインストールするとよいでしょう。
注意点としては、
5.xxのxxの部分が奇数のバージョンは開発版であり、
また5.xx.0はバグがある可能性が高いので、
正式に使うのであれば、これらのバージョンを避けたほうがよいでしょう。

今回は、5.16.2をインストールします。

インストールは次のコマンドでできます。

$ perlbrew install 5.16.2

インストールは少し時間がかかります。
テストを省略しても支障がない場合は、次のコマンドでインストールすると、少し早く完了します。

$ perlbrew install --notest 5.16.2

perlbrewでPerlを切り替え

次のコマンドで、インストールしたPerlを確認することができます。

$ perlbrew list
perl-5.16.2
````
Perlを切り替える場合は、次のコマンドで行えます。

$ perlbrew switch 5.16.2

もう一度perlbrew listで確認してみましょう。

$ perlbrew list
* perl-5.16.2

行の最初に米印がついているバージョンが、現在選択しているPerlです。
whichコマンドでperlコマンドのフルパスを確認してみましょう。

$ which perl
/home/uchiyama/perl5/perlbrew/perls/perl-5.16.2/bin/perl

ホームディレクトリにインストールしたPerlが使われるようになっていると思います。
<h2><span style="color: #2196f3">cpanmをインストール</span></h2>
ついでにCPANモジュールをインストールするコマンドであるcpanmもインストールしましょう。
perlbrewのコマンドでインストールできます。

$ perlbrew install-cpanm

これでcpanmコマンドが使えるようになります。
ホームディレクトリにモジュールがインストールされるようになっているので、root権限はいりません。
また、好きなモジュールを入れても全体に影響を及ぼすことはありません。
<h2><span style="color: #2196f3">cronでの使い方</span></h2>
perlbrewで入れたPerlをcronで実行するとき、いくつか設定する必要があります。
まず、次のようなシェルスクリプトを用意します。
env.sh

!/bin/sh

export HOME=/home/uchiyama
source ~/perl5/perlbrew/etc/bashrc
perlbrew use perl-5.16.2

exec “$@”

そして、crontabの設定で次のような感じで記述します。
          • /home/uchiyama/env.sh perl /home/uchiyama/hoge.pl > /tmp/hoge 2>&1
以上のようにに設定することで、perlbrewでインストールされたPerlが使われるようになります。
普通に実行してしまうと、システムに標準で入っているPerlの方で実行されてしまうので注意して下さい。
<strong>参考</strong>
<a href="http://blog.riywo.com/2012/05/26/005232" title="http://blog.riywo.com/2012/05/26/005232" target="_blank">http://blog.riywo.com/2012/05/26/005232</a>
<h2><span style="color: #2196f3">まとめ</span></h2>
perlbrewでperl環境を作る方法をご紹介しました。
共有環境の場合、ホームディレクトリにperlがインストールされていると安心感があります。
Perlを使うときはぜひこの方法で環境構築してみてください。

CGIプログラムをPlack::Testでテストする

以下のようなCGIプログラムのテストを書きたいとします。

 
fizzbuzz.cgi

#!/usr/bin/perl
use strict;
use warnings;
use CGI;
my $q = CGI-&gt;new;
my $number = $q-&gt;param('number');
unless (defined $number) {
print $q-&gt;header(
-status =&gt; 200,
-type =&gt; 'text/plain; charset=utf8',
);
print "Please set number";
exit;
}
my $result = '';
if ($number % 3 == 0) {
$result .= 'Fizz';
}
if ($number % 5 == 0) {
$result .= 'Buzz';
}
$result ||= $number;
print $q-&gt;header(
-status =&gt; 200,
-type =&gt; 'text/plain; charset=utf8',
);
print $result;

ロジックが一緒に書かれているので、Test::Moreでテストしづらいですね。
こんなときはCGIプログラムをPSGIアプリに変換し、
Plack::Testでテストすると楽です。

 

PSGIアプリに変換するにはPlack::App::CGIBinを使って、
以下の内容のapp.psgiを作成します。

#!/usr/bin/perl                                                                                                                                            
use strict;
use warnings;
use File::Basename;
use Plack::Builder;
use Plack::App::CGIBin;
my $basedir = dirname(__FILE__);
builder {
mount '/' =&gt;
Plack::App::CGIBin-&gt;new( root =&gt; $basedir, exec_cb =&gt; sub { 1 } )-&gt;to_app;
};

これでめでたくCGIプログラムはPSGIアプリになりました。
普通のPSGIアプリと同様に、plackupコマンドなどで実行できるようになります。

$ plackup app.psgi

ブラウザなどで「http://localhost:5000/fizzbuzz.cgi?number=1」にアクセスすると実行できます。
 

PSGIアプリは、Plack::Testでテストすることができます。
先ほどのCGIプログラムのテストは、次のように書くことができます。

use strict;
use warnings;
use Test::More;
use Plack::Test;use HTTP::Request::Common;
use Plack::Loader;
use Plack::Util ();
my $app = Plack::Util::load_psgi('app.psgi');
test_psgi $app, sub {
my $cb = shift;
my $res;
$res = $cb-&gt;(GET "/fizzbuzz.cgi?number=1");
is $res-&gt;code, '200';
is $res-&gt;content, '1';
$res = $cb-&gt;(GET "/fizzbuzz.cgi?number=2");
is $res-&gt;code, '200';
is $res-&gt;content, '2';
$res = $cb-&gt;(GET "/fizzbuzz.cgi?number=3");
is $res-&gt;code, '200';
is $res-&gt;content, 'Fizz';
$res = $cb-&gt;(GET "/fizzbuzz.cgi?number=4");
is $res-&gt;code, '200';
is $res-&gt;content, '4';
$res = $cb-&gt;(GET "/fizzbuzz.cgi?number=5");
is $res-&gt;code, '200';
is $res-&gt;content, 'Buzz';
$res = $cb-&gt;(GET "/fizzbuzz.cgi?number=15");
is $res-&gt;code, '200';
is $res-&gt;content, 'FizzBuzz';
};
done_testing();

書きやすいですね。

自動テストのためにメールサーバを一時的に起動する

メール本体を組み立てるロジックとメール送信部分が結合しているようなシステムを自動テストする際に、
一時的に立ち上がるメールサーバが欲しくなります。
また、メールサーバにどんなメールが届くのかをチェックできると嬉しいですね。

Test::TCPとNet::Server::Mail::SMTPを使えば、これを実現できます。

Test::TCPは、開いているポートをスキャンして、サーバ側のコードとクライアント側のコードを実行してくれるモジュールです。
Net::Server::Mail::SMTPは、メールサーバを簡単に書けるようにしてくれるモジュールです。各SMTPコマンドに対して処理を書くことができます。

この2つのモジュールを組み合わせれば、以下のようにテストを書くことができます。

 

use strict;
use warnings;
use Test::More;
use Test::TCP;
use Net::SMTP;
use Net::Server::Mail::SMTP;
use Email::MIME;
use Email::Address::Loose;
use Email::MIME::MobileJP::Parser;
my $from = 'test-from@example.com';
my $to   = 'test-to@example.com';
my $body = 'test-body';
my $mime = Email::MIME-&gt;create(
header =&gt; [
From =&gt; $from,
To   =&gt; $to,
Subject =&gt; 'test-subject'
],
attributes =&gt; {
content_type =&gt; 'text/plain',
charset      =&gt; 'ISO-2022-JP',
encoding     =&gt; '7bit',
},
body =&gt; $body
);
test_tcp(
client =&gt; sub {
my $port = shift;
eval {
my $smtp = Net::SMTP-&gt;new(
Host =&gt; 'localhost',
Port =&gt; $port,
Hello =&gt; '[localhost]'
);
$smtp-&gt;mail('test-from@example.com');
$smtp-&gt;to('test-to@example.com');
$smtp-&gt;data();
$smtp-&gt;datasend($mime-&gt;as_string);
$smtp-&gt;quit;
};
if ($@) {
warn $@;
}
},
server =&gt; sub {
my $port = shift;
my $sock = IO::Socket::INET-&gt;new(
LocalAddr =&gt; '127.0.0.1',
LocalPort =&gt; $port,
Proto     =&gt; 'tcp',
Listen    =&gt; 1,
) or die "Cannot open server socket: $!";
# チェック用のリクエストが来るのでパスする                                                                                  
$sock-&gt;accept();
while (my $remote = $sock-&gt;accept()) {
eval {
my $smtp = Net::Server::Mail::SMTP-&gt;new('socket' =&gt; $remote);
$smtp-&gt;set_callback(
'RCPT' =&gt; sub {
my $sess = shift;
my $rcpt = shift;
my ($email) = Email::Address::Loose-&gt;parse($rcpt);
my $domain = $email-&gt;host;
return (0, 513, 'Syntax error.') unless $domain;
return 1;
}
);
$smtp-&gt;set_callback(
'DATA' =&gt; sub {
my $sess = shift;
my $data = shift;
my $mail = Email::MIME::MobileJP::Parser-&gt;new($data);
my $from = $mail-&gt;from();
my $body = $mail-&gt;mail-&gt;body;
is $from-&gt;address, 'test-from@example.com';
like $body, qr/test-body/;
return (1, 250, 'message queued');
}
);
$smtp-&gt;process();
};
if ($@) {
warn $@;
$remote-&gt;close();
}
}
}
);
done_testing;

Test::TCPは、serverに記述されたメールサーバが起動したあとに、clientに記述されたプログラムを実行してくれるようになっています。
便利ですね。

© SEEDS Co.,Ltd.