unknownplace.org

Travis は Github 連携の CI サービスで、結構前に Perl にも対応しているので最近更新したレポジトリには基本的に .travis.yml を置いて便利に使わせていただいていたのですが、 いままで使っていた設定だとtravis上でうまくテストが通らなくなってしまった。

今まで使っていた方法は、まず gfx 考案の Makefile.PL をベースに Makefile.PL をこんなかんじで書く：

use strict;
use warnings;

BEGIN {
    my @devmods = qw(
        Module::Install::AuthorTests
        Module::Install::ReadmeFromPod
        Module::Install::Repository
    );
    my @not_available;

    eval qq{use inc::Module::Install; 1;} or push @not_available, 'inc::Module::Install';
    for my $mod (@devmods) {
        eval qq{require $mod} or push @not_available, $mod;
    }
    if (@not_available) {
        print qq{# The following modules are not available.\n};
        print qq{# `$^X $0 | cpanm` will install them:\n};
        print $_, "\n" for @not_available;
        print "\n";
        exit -1;
    }
}

use inc::Module::Install;

name 'Test-RedisServer';
all_from 'lib/Test/RedisServer.pm';

test_requires 'Redis';
test_requires 'Test::More' => '0.86';
test_requires 'Test::TCP'  => '1.17';

requires 'perl'       => '5.008001';
requires 'File::Temp' => '0.19'; # newdir
requires 'Any::Moose' => '0.18';

readme_from 'lib/Test/RedisServer.pm';
author_tests 'xt';
auto_set_repository;

WriteAll;

こうすると perl Makefile.PL | cpanm で必要な Module::Install モジュールが入るので、.travis.yml を

language: "perl"
before_install:
    - perl Makefile.PL | cpanm

こんな感じにするだけでOK。でした。前までは。

.travis.yml はこのままでいいんですが、最近の Module::Install は use inc::Module::Install したときに

include /Users/typester/dev/Test-RedisServer/inc/Module/Install.pm

みたいのを標準出力に出力するので、それが cpanm に渡ってしまいおかしなことになっている模様。

苦肉の策として

    {
        local *STDOUT;
        eval qq{use inc::Module::Install; 1;} or push @not_available, 'inc::Module::Install';
    }

みたいのを入れてしのいだ。

最終的な Makefile.PL はこちら。 Travis のときは author_tests 走らないようにとかもしてある。

tl;dr - 通常のHookではなくPubSubHubbubのほうのHookを使えばGithubのすべてのイベントをひとつのWebHookで受け取ることができる。

Github の WebHook ではレポジトリの更新しか受け取れず、issue とかも受け取れたら便利なのになーと思いつつ API ドキュメントを見てみると Hook を API から登録したりすることができるようになっていた。 だがこれは所詮は Web から登録できる Hook をいじるもので、このリストにあるものしか登録できない。 また、それぞれの Hook について登録できるイベントはリストで定義されている物に制限されているようで、たとえば WebHook だと push イベントしか設定することはできないみたい。（API 経由でも設定できなかった）

一方、それとは別に用意されている PubSubHubbub の Hook をつかうと、どうやら一つの WebHook URL に任意のイベントを送ることができるようだ。

やり方は簡単で、https://github.com/typester/p5-UV の push イベントを http://unknownplace.org/webhook で受け取りたいとすると、

$ curl -u typester -i \
  https://api.github.com/hub \
  -F "hub.mode=subscribe" \
  -F "hub.topic=https://github.com/typester/p5-UV/events/push" \
  -F "hub.callback=http://unknownplace.org/webhook"

というような感じで API をたたけば登録完了。これで指定した URL に対してイベントが送られてくるようになる。 他のイベントも受け取りたいというときは、これを受け取りたいイベント分繰り返せば良い。

Hook に送られてくるのは JSON だが、デフォルトだと通常の WebHook と同じように payload={json} みたいな形で送られてくる。 ドキュメントによれば、-H "Accept: application/json" を上のリクエストにつけるか、イベントタイプを https://github.com/typester/p5-UV/events/push.json みたいに .json を加えてやるかすると、生の JSON が POST されるようになるらしい。が、僕は今までの WebHook スクリプトを流用したのでこれはためしていない。

登録した Hook の一覧は普通の Hook API で、

$ curl -u typester -i https://api.github.com/repos/typester/p5-UV/hooks

このようにするとで取得可能っぽい。僕の場合は WebHook と同じ分類で（イベントだけが複数ある）リストに載っていたが、生 JSON を受け取るように設定していた場合どのように載るのかは不明。

WebHook スクリプトは以下のような通知を受け取ったら IRC に投げる、みたいのを使っている。

#!/usr/bin/env perl

use strict;
use warnings;
use utf8;

use Twiggy::Server;
use Getopt::Long;
use File::chdir;
use Encode;

use AnyEvent;
use AnyEvent::IRC::Client;
use Log::Minimal;

use Plack;
use Plack::Request;
use JSON::XS;

my $conf = {
    irc => {
        server   => 'irc.example.com',
        port     => 6667,
        ssl      => 1,
        channel  => '#example-project',
        nick     => 'github',
    },

    commit_hook => sub {
        my ($branch) = @_;

        if ($branch eq 'develop') {
            local $CWD = '/path/to/project';
            system 'git', qw!--git-dir=.git pull!;
            system 'curl', 'http://127.0.0.1:8080/jenkins-ci/job/project/build';
        }
    },
};

GetOptions(
    \my %option,
    qw/host=s port=i/,
);
$option{host} ||= '0.0.0.0';
$option{port} ||= 5000;

my $cv = AnyEvent->condvar;

my $irc = AnyEvent::IRC::Client->new;
$irc->enable_ssl if $conf->{irc}{ssl};

my $connector = sub {
    $irc->connect($conf->{irc}{server}, $conf->{irc}{port}, {
        nick => $conf->{irc}{nick},
        $conf->{irc}{password} ? (password => $conf->{irc}{password}) : (),
    });
};

$irc->reg_cb(
    registered => sub {
        my ($irc) = @_;
        $irc->send_srv( JOIN => $conf->{irc}{channel} );
    },

    disconnect => sub {
        warnf 'IRC Disconnected: %s', $_[1];
        $connector->();
    },

    debug_send => sub {
        my ($irc, $command, @params) = @_;
        debugf '> %s %s', $command, join ' ', @params;
    },
    debug_recvd => sub {
        my ($irc, $msg) = @_;
        debugf '< %s', $msg;
    },
);
$connector->();

my $app = sub {
    my $req = Plack::Request->new(shift);

    if ($req->method eq 'POST' and my $payload = $req->param('payload')) {
        my $json    = decode_json($payload);
        my $channel = $conf->{irc}{channel};

        if ($json->{commits}) {
            # push event
            (my $branch = $json->{ref}) =~ s!refs/heads/!!;

            if ($channel) {
                for my $commit (@{ $json->{commits} }) {
                    $irc->send_srv(
                        NOTICE => $channel,
                        encode_utf8 sprintf '%s committed to %s "%s" %s',
                        $commit->{author}{username} || $commit->{author}{name}, $branch,
                        $commit->{message}, $commit->{url},
                    );
                }

                my $hook = $conf->{commit_hook};
                $hook->($branch) if $hook;
            }
        }
        elsif (my $issue = $json->{issue}) {
            my $sender = $json->{sender};

            if (my $comment = $json->{comment}) {
                # issue comment event
                my ($body) = $comment->{body} =~ /^(.*\S.*)$/m;

                $irc->send_srv(
                    NOTICE => $channel,
                    encode_utf8 sprintf '%s commented issue #%d %s %s',
                    $sender->{login}, $issue->{number}, $body || '', $issue->{html_url},
                );
            }
            else {
                # issues event
                $irc->send_srv(
                    NOTICE => $channel,
                    encode_utf8 sprintf '%s %s issue #%d %s %s',
                    $sender->{login}, $json->{action}, $issue->{number}, $issue->{title}, $issue->{html_url},
                );
            }
        }

        return [200, [], ['']];
    }

    return [403, [], ['Forbidden']];
};

AnyEvent::post_detect {
    if ($AnyEvent::MODEL eq 'AnyEvent::Impl::EV') {
        no warnings 'once';
        $EV::DIED = sub { $cv->croak($@) };
    }
};

my $server = Twiggy::Server->new(%option);
$server->register_service($app);

$cv->recv;

現在 push, issues, issue-comment イベントを受け取ってる。 issues とれるとやっぱりだいぶ良い感じ。 あと pullreq 多用しているプロジェクトだとそのイベントもあるので通知させるようにすると捗りそう。

最近 Redis ずいてるわけですが、redis-server は

$ redis-server /path/to/redis.conf

or

$ cat redis.conf | redis-server -

みたいな形式でしか起動できず、これをがんばって exec してテスト用とかに使うコードを3回くらい書いたところで面倒になってモジュール化しました。

Daisuke Murase / Test-RedisServer - search.cpan.org

基本的に Test::mysqld のパクりなのでサクッとかけました。kazuho++

linux のコマンドラインから、wi-fi の情報をつかって位置情報を得る - tokuhirom's blog.

を見て、面白そうだと思ったのでそのMac版。MacでコマンドラインからWiFiスポットをスキャンするのは、

/System/Library/PrivateFrameworks/Apple80211.framework/Versions/A/Resources/airport -s

でいけます。ってことで、

use strict;
use warnings;
use utf8;
use 5.012;

use JSON;
use LWP::UserAgent;

my @addresses = do {
    my @lines = split /\n/, qx{/System/Library/PrivateFrameworks/Apple80211.framework/Versions/A/Resources/airport -s};
    shift @lines;

    my @r;
    push @r, (split /\s+/, $_)[2] for @lines;

    @r;
};

my $query = encode_json({
    version          => '1.1.0',
    host             => 'maps.google.com',
    request_address  => JSON::true,
    address_language => 'ja_JP',
    wifi_towers      => [
        map +{
            mac_address     => $_,
            signal_strength => 8,
            age             => 0,
        }, @addresses,
    ],
});

my $ua  = LWP::UserAgent->new;
my $res = $ua->post('http://www.google.com/loc/json', Content => $query);
$res->is_success or die $res->status_line;

use YAML;
warn Dump decode_json($res->content);

ってな感じでOKです！

Sub::Rate - Rate based sub dispatcher generator - metacpan.org

確率に応じて処理を振り分けたいというような要件をカジュアルにクリアできる感じになっております。

たとえばいわゆるガチャ的なものを考えたときに、

my $rate = Sub::Rate->new( max_rate => 100 );

$rate->add( 0.1, sub { say 'Super rare' }); # 0.1 %
$rate->add( 3,   sub { say 'Rare' });       # 3 %

$rate->add( default => sub { 'Normal' });   # 残り

my $func = $rate->generate;

みたいな感じで関数を生成できて、この生成した $func は呼ぶと確率に応じて登録された関数を呼び出してくれる、というようなもの。

母数となる数字（max_rate）をあらかじめ設定しておいて、そのうちどのくらいの率かというのを関数ごとに指定するインタフェースのモジュールが欲しかったんだけど見つけられなかったので。（検索ワードが悪いという説もある…）

今頃なにを言っているのかという感じだが、Basic認証ごしにGyazoクローンに画像アップロードしたいという要求があったので、ちょろっと書いてみた。

https://github.com/typester/Gyazo-Mac

Downloads からバイナリも落とせるようにしておいた。

初回起動、もしくはOption押しながらの起動で設定画面が出るので、適当に情報を入力して閉じたら、あとは普通のGyazoクライアントと同じように使える。

誰かいかしたアイコンつくってください。

AnyEvent を利用する際に注意する必要があることに、コールバック中で発生した例外の処理方法がバックエンドに任されている（＝例外処理の方法がバックエンドによってちがう）、というのが挙げられる。

Impl::Perl では例外は単純に rethrow されるため、プログラム中で例外が発生したり die したりすると普通にプロセスは終了する。 しかし、Impl::EV の場合、デフォルトでは例外はキャッチされ標準エラーに出力されるものの、そのまま処理は続行されてしまう。

以下のような1秒タイマーをまわしてタイマーが発火したらアプリを終了する、というようなコードがあったとき、

use strict;
use warnings;

use AnyEvent;

my $cv = AnyEvent->condvar;

my $t; $t = AnyEvent->timer(
    after => 1,
    cb    => sub {
        undef $t;

        die;

        $cv->send;
    },
);

print "Backend: ", AnyEvent::detect(), "\n";

$cv->recv;

Impl::Perl な環境ではこれは期待通り動作するが、Impl::EV の場合は刺さってしまう。

例外が起きてもそのまま継続する、というのがデフォルト動作なのはどういうわけなのかよくわからないが、手元で Impl::Perl で開発していて本番で Impl::EV とかで動かすとこの違いによってはまることはかなりありそう。

この挙動を変えるためには EV の例外処理を上書きするようにすれば良い。 AnyEvent では post_detect というものでバックエンドモジュールが決まったときのフックを差し込める。それをつかって、

AnyEvent::post_detect {
    if ($AnyEvent::MODEL eq 'AnyEvent::Impl::EV') {
        no warnings 'once';
        $EV::DIED = sub { $cv->croak($@) };
    }
};

このようなコードを入れておけばまぁいいんだとおもう。EV のドキュメントにも書かれているが、$EV::DIED で例外処理を上書きすることはできるのだが、この関数内で発生した例外は無視するそうなので（これどうなのｗ）、例外を rethrow するというようなことはできない。なのでこのようにどっかに condvar を置いておいてそれの croak を呼ぶというようなことをする必要がある。

See also:

• AnyEventドキュメント、ERROR AND EXCEPTION HANDLING の項
• EVドキュメント、$EV::DIED

Xcode4.2くらい（？） からデフォルトになった clang だとビルドがこけるので、

$ perl Makefile.PL CC=gcc

などとして gcc でビルドするようにすれば普通に入ります。

都市伝説だと思われていた Diablo3 がなんと発売された。

発売日が決まってからというもの同僚が執拗に誘ってくるので、しょうがないのでインストールすることにしたが、 どうも Diablo3 は case-sensitive (大文字小文字を区別) なファイルシステムにインストールできないらしい。

ディスクイメージ内にインストールすることで回避できないか、とかいろいろやってみたがうまくいかないので Time Machine 復元を利用して無理矢理ファイルシステムを変更した。

手順は以下を参考にした。

joshua stein: restoring case-sensitive hfs+ volumes with time machine

OS X インストーラで起動して、希望のファイルシステムに初期化したあと、rsync で自前でバックアップをコピー、っていう手法。

インストーラに rsync は含まれていないんだけど、バックアップデータが rsync をもっているからそこのを使う、ってのはなかなか面白い。

この記事にもあるようにバックアップを rsync したあと、インストーラの /dev も別途 rsync しないとシステムは起動しないので注意が必要。

あと大文字小文字違いのファイルを持っている場合、それらが失われる覚悟も必要。

というわけで無事に遊べるようになった。

flymakeで読んでいるシンタックスチェックコマンドが無限ループに陥って困り、@fujiwaraに相談したところ。daemontoolsについてくるsoftlimitコマンドでタイムアウトするようにするといいと教えてもらった fujiwara++

$ softlimit -t 1 perl -e 'while(1){}'
zsh: cpu limit exceeded  softlimit -t 1 perl -e 'while(1){}'

便利ですね。とりあえずperlのflymake設定を

(defun flymake-perl-init ()
  (let* ((temp-file (flymake-init-create-temp-buffer-copy
                     'flymake-create-temp-inplace))
         (local-file (file-relative-name
                      temp-file
                      (file-name-directory buffer-file-name))))
    (list "softlimit" (list "-t" "3" "perl" "-wc" local-file))))

みたいにしておいた。まぁ perl -wc で無限ループとか滅多にないと思いますが。