喰らえ10年鍛えた俺の test.pl !!

こんにちは、2011年くらいにディレクターになってめっきりPerl書かなくなった id:onishi です。

この記事は Perl5 Advent Calendar 2015 18日目です！

書き捨てのコードを test.pl という単一ファイルに __END__ と共に上に追加し続けて10年。3万行超に成長した俺の test.pl から厳選したコード群を喰らえ、という主旨の記事です。

今日のお品書きはこんな感じです。

( [PR]この目次ははてなブログの目次機能で自動生成しています )

ちなみに、書き捨てのコードから良いものは、プロジェクトのリポジトリに入れたり、~/bin/ に置いたりしています。今日は ~/bin/ に移った厳選処理も紹介しますね。
とにかく test.pl にいろんな処理が書かれているので、日付処理したい、とかメール送りたい、とか思ったらそれっぽい単語でファイル内を検索すると適切なコードスニペットが見つかるので業務効率に繋がっています。

list()

ORM使うほどでもないけどさくっとDB引きたい時の簡易DBIラッパーです。

use DBI;

my $host = {
    user => ['host1', 'user', 'pass'],
    blog => ['host2', 'user', 'pass'],
};

sub dbh {
    my $dbname = shift;
    DBI->connect_cached(
        sprintf(
            'dbi:mysql:database=%s;host=%s',
            $dbname,
            $host->{$dbname}->[0],
        ),
	$host->{$dbname}->[1],
        $host->{$dbname}->[2],
    )
}

sub item {
    my $list = list(@_) or return;
    $list->[0];
}

sub list {
    my ($dbname, $sql, @bind) = @_;
    my $dbh = dbh($dbname);
    my $sth = $dbh->prepare_cached($sql);
    $sth->execute(@bind);
    return $sth->fetchall_arrayref({});
}

こんだけ書いておけば list() と item() で以下みたいなコードが書けます。

my $user = item(
    user => 'SELECT * FROM user WHERE name = ?',
    'onishi'
);

my $entries = list(
    blog => 'SELECT * FROM entry WHERE user_id = ?',
    $user->{user_id},
);

print map { $_->{title} . "\n" } @$entries;

数クエリで済みそうな集計を雑にしたい時に使ってます。

fotolife

フォトストレージサービスはてなフォトライフに簡単にファイルをアップロードするコマンドです。Config::Pit で username, apikey, folder を指定しておきましょう。

$ fotolife ファイル
$ fotolife URL

第一引数にファイルパスかURLを受け取り、自分のフォトライフにアップロードし、アップロード結果を出力します。
結果はこのように、はてなブログ用記法、はてなダイアリー用記法、フォトライフpermalink、画像permlinkをまとめて出力する親切設計です。

$ fotolife some-file.jpg
[f:id:onishi:00000000000000p:plain]
[f:id:onishi:00000000000000p:image]
http://f.hatena.ne.jp/onishi/00000000000000
http://cdn-ak.f.st-hatena.com/images/fotolife/o/onishi/000000/00000000000000.png

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

use Config::Pit;
use FileHandle;
use LWP::Simple 'get';
use XML::Atom::Entry;
use XML::Atom::Client;

my $file = shift;

my $type = $file =~ /(png|gif|bmp)$/i ? lc($1) : 'jpeg';
my $t    = substr($type, 0, 1);
my $ext  = $type eq 'jpeg' ? 'jpg' : $type;
   $type = "image/$type";

my $image;
if ($file =~ m{https?://}) {
    $image = get($file);
} else {
    local $/; # slurp mode
    my $fh = FileHandle->new($file) 
        or die "cannnot open $file: $!";
    $image = $fh->getline;
}

my $config = pit_get("hatena.ne.jp", require => {
    username => 'username',
    apikey   => 'apikey',
    folder   => 'folder',
});
my $username = $config->{username};
my $apikey   = $config->{apikey};
my $folder   = $config->{folder};

my $PostURI = 'http://f.hatena.ne.jp/atom/post';

my $api = XML::Atom::Client->new;
$api->username($username);
$api->password($apikey);

my $entry = XML::Atom::Entry->new;
$entry->content($image);
$entry->content->type($type);
$entry->title('');
my $dc = XML::Atom::Namespace->new(dc => 'http://purl.org/dc/elements/1.1/');
$entry->set($dc, 'subject', $folder) if $folder;
my $EditURI = $api->createEntry($PostURI, $entry) or
  die $api->errstr;

$EditURI =~ /(\d+)/ or die $EditURI;
my $fototime = $1;
my $initial  = substr($username, 0, 1);
my $date     = substr($fototime, 0, 8);
print "[f:id:$username:$fototime$t:plain]\n";
print "[f:id:$username:$fototime$t:image]\n";
print "http://f.hatena.ne.jp/$username/$fototime\n";
print "http://cdn-ak.f.st-hatena.com/images/fotolife/$initial/$username/$date/$fototime.$ext\n";

長い。あと、WSSE認証使ってますけど最近はOAuthでも書けます。
はてなフォトライフAtomAPI

wq

みんな大好き、Web::Query。jQuery ライクに scraping できます。

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

binmode STDOUT, ':utf8';

use Web::Query;

my $url      = shift or die;
my $selector = shift or die;
my $limit    = shift || 0;

my $i;
wq($url)->find($selector)->each(
    sub {
        printf("%s\n", $_->text);
        $limit && ++$i >= $limit and exit;
    }
);

こんな雑なスクリプトを wq という名前でPATHが通ったところに用意しておくと、URLとセレクタを引数にこんな感じで簡易スクレイピングコマンドとして使えます。

$ wq http://www.hatena.ne.jp 'ul#servicelist li' 5
    ブックマーク ネット上にお気に入りを保存できるサービス。ネット上の旬な話題がすぐわかる
    ブログ 書き残そう、あなたの人生の物語。だれでも使いやすく簡単に書ける、はてなの新しいブログ
    B!KUMA “がんばる私”に、ちょっと一息。恋愛、レシピ、おしゃれ、育児など女性が気になる話題をお届け
    ニュース ネットで旬な話題を分かりやすく紹介。地元発の京都情報、ひとこまマンガも楽しめるニュースサイト
    人力検索 調べたいことを誰かが自分の代わりになって調べてくれる人力検索サービス

(はてなトップページから「はてなのサービス」を5件取得する例)

セレクタ指定して取得した数字を別のサービスに投げたりすると便利なんじゃないでしょうか。

punycode

日本語ドメインでイラッとすることが多いので punycode の自動変換をします。

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

use IDNA::Punycode;
use Encode;

binmode STDOUT, ':utf8';

idn_prefix('xn-');

my $word = shift;

if ($word =~ /^xn-/) {
    print join('.', map { decode_punycode(Encode::decode('utf-8', $_)) } split(/[.]/, $word)) . "\n";
} else {
    print join('.', map { encode_punycode(Encode::decode('utf-8', $_)) } split(/[.]/, $word)) . "\n";
}

こんな感じ。

$ punycode xn--wgv71a119e.jp
日本語.jp

$ punycode 日本語.jp
xn--wgv71a119e.jp

イラッとしなくなりました。

statuscode

任意のステータスコードを返すサーバーをさっと建てたいこと、ありますよね！（無い）

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

use HTTP::Daemon;
use HTTP::Status;
use HTTP::Response;

my $d = HTTP::Daemon->new(LocalPort => shift || undef) || die;
print "Please contact me at: ", $d->url, "\n";
while (my $c = $d->accept) {
    while (my $r = $c->get_request) {
        if ($r->method eq 'GET' and $r->url->path =~ m{/(\d+)}) {
            my $code    = $1;
            my $header  = HTTP::Headers->new( 'Content-Type' => 'text/html' );
            my $message = status_message($code) || '';
            my $res     = HTTP::Response->new(
                $code,
                $message,
                $header,
                "<title>$code $message</title><h1>$code $message</h1>"
            );
            $c->send_response($res);
            warn "$code $message\n";
        } else {
            $c->send_error(RC_FORBIDDEN)
        }
    }
    $c->close;
    undef($c);
}

$ statuscode
Please contact me at: http://localhost:53812/

サーバーが立ちます。
http://localhost:port/200 のように任意の数字をパスに指定するとその数字のステータスコードを返します。なんか便利ですね！

結びの言葉

10選くらい挙げたかったのですが、意外と仕事のコードと密なコードが多すぎて紹介できなくて飽きてきたのでここらへんで終わります。
1ファイルを眺めるだけで10年の歴史が眺められて面白かったです。