Planet Perl.jp

雨が降ったら虫はどうなるの？

nobody@example.com (antipop) — 2010-09-08T00:10:27+09:00

気になったので質問してみました。ふるってご回答ください。

雨降りは、虫にとっては大変なことではないでしょうか？特に、蚊や羽虫のような小さな虫にとっては特に。そこで、以下の疑問にお答え願います。

雨粒に直撃されるとダメージを負うのでしょうか？

雨粒に囲まれて地面に叩きつけられるようなことがあるのでしょうか？

叩きつけられた後、水たまりで溺れて死んでしまったりするのでしょうか？

その他、なにか大変なことがあったりするのではないでしょうか？

question:1283769171

PolycomをPerlから操作する

nobody@example.com (antipop) — 2010-09-07T22:28:34+09:00

弊社では、東京オフィスと京都オフィスとを常時、Polycomという、ビデオチャットの高級版みたいなシステムで接続していて、東京・京都間でいつでも距離を感じさせずに自然にコミュニケーションを図れるような仕組みが整備されています。

それは便利な一方、たまに静かであるべき状況で相手側の音声が入って鬱陶しい場合があって、IRCや口頭で、近くにいるひとにマイクのミュートをお願いしたりすることがあります。最近、PolycomのWebインタフェイスから、リモコンのような仕組みでPolycomを操作できることがわかって、それを使ってミュートすればいいじゃないかということになりました。ということはつまりなんかしらのAPIみたいなものがあるんだろうなーと思って見てみたら、案の定あったので、Perlから叩けるようにしてみました。

http://github.com/kentaro/perl-webservice-polycom-remotecontroller

以下のサンプルスクリプトでは、シェルからPolycomの各種操作（カメラの向きをかえたり、音声レベルを上下したりなど、いろいろ）を行えます。

#!/usr/bin/env perl

use strict;
use warnings;
use Config::Pit;
use Term::ReadLine;

use FindBin::libs;
use WebService::Polycom::RemoteController;

my $config = pit_get('polycom.kyoto', require => {
    host     => 'your host for polycom',
    username => 'your username for polycom',
    password => 'your password for polycom',
});

my $polycom = WebService::Polycom::RemoteController->new;
   $polycom->host($config->{host});
   $polycom->username($config->{username});
   $polycom->password($config->{password});

my $term = Term::ReadLine->new('Polycom Controller');

while (defined (my $command = $term->readline('polycom> '))) {
    my $res = $polycom->button($command);
    for my $command (@{$res->commands}) {
        printf "%s: %s\n", $command->is_success ? 'OK' : 'NG', $command->message
    }
}

http://github.com/kentaro/perl-webservice-polycom-remotecontroller/blob/master/eg/controller.pl

これだけでは何がうれしいんだという感じですが、一歩進んで、以下のようなスクリプトを書いて、社内IRCからPolycomコマンドを叩けるようにしてみました（WebService::Polycom::RemoteControllerをラップしたライブラリなどが他にあるけど、社内用なので非公開。以下は雰囲気で）。

#!/usr/bin/env perl

use strict;
use warnings;

use YAML::Syck;
use Encode;
use FindBin;
use UNIVERSAL::require;
use Getopt::Long;

use AnyEvent;
use AnyEvent::IRC::Client;

use lib      "$FindBin::Bin/../lib";
use lib glob "$FindBin::Bin/../modules/*/lib";

my $config_file = "$FindBin::Bin/../config/kyoto.yml";
GetOptions(
    "config=s" => \$config_file,
);

my $config = LoadFile($config_file);
my $polycom_class = $config->{polycom}{class};
$polycom_class->use or die $@;
my $polycom = $polycom_class->new;

my $cv     = AE::cv;
my $client = AnyEvent::IRC::Client->new;
$client->reg_cb(
    connect   => \&on_connect,
    publicmsg => \&on_publicmsg,
);

$client->connect(
    $config->{irc}{server}{host}, $config->{irc}{server}{port}, {
        user     => $config->{irc}{client}{user},
        nick     => $config->{irc}{client}{nick},
        real     => $config->{irc}{client}{real},
        password => $config->{irc}{server}{password},
        timeout  => 60,
    }
);

$cv->recv;

sub on_connect {
    my ($client, $error) = @_;
    if ($error) {
        die $error;
    }
    else {
        for my $channel (@{$config->{irc}{channels}}) {
            $client->send_srv('JOIN', '#'.$channel);
        }
    }
}

sub on_publicmsg {
    my ($client, $channel, $message) = @_;
    if ($message->{params}->[1] =~ /^@{[$config->{irc}{client}{nick}]}:\s+(.+)$/i) {
        my $command = $1;
        chomp $command;
        my $res = $polycom->button($command);
        for my $result (@{$res->commands}) {
            my $reply = sprintf "%s: %s", $result->is_success ? 'OK' : 'NG', $result->message;
            $client->send_chan(
                $channel, 'NOTICE', $channel, encode('iso-2022-jp', $reply)
            );
        }
    }
}

これで、IRCにjoinしてるひとならPolycomを机に向かっていながらにして簡単に操作できて便利になり、生産性の向上を見込めます。

どのバージョンのPolycomにもこのAPIがあるのかなどは知らないです。

Syabusyabu and drinking party at Yamatoji after YAPC::Asia 2010

nobody@example.com (tokuhirom) — 2010-09-07T12:17:15+09:00

http://yapcasia.org/2010/

http://atnd.org/events/7811

Kan Fushihara organize drinking party after YAPC::Asia 2010. Join us!

If you cannot understand how to use atnd.org, contact to us by e-mail to me: tokuhriom at gmail.com.

Let's drink!

YAPC::Asia 2010 のあとに目黒の大和路という、おれらがよくつかってるしゃぶしゃぶ屋で打ち上げをやろうとおもうので、ふるってご参加ください。YAPC に参加してなくて、たんに perl mongers と飲みたいっていうだけの人とかでも OK です。

本日の早朝勉強会の成果: added accessor: Text::MicroTemplate::File->include_path

nobody@example.com (tokuhirom) — 2010-09-06T11:41:21+09:00

0.18
	- added accessor: Text::MicroTemplate::File->include_path

T::MT::File->include_path があると、Plack::App::MicroTemplate みたいなのをつくるときに便利だよねーっということで。

これは read only accessor としているが、これをうわがきすると、キャッシュが混乱するため(まあ、キャッシュをクリアする方向で調整してもいいのだが、そもそもそうそう書換えるもんでもないので read only とした)。

rafl’s Devel::bt is awesome.

nobody@example.com (tokuhirom) — 2010-09-05T09:17:32+09:00

http://frepan.64p.org/~flora/Devel-bt-0.01/lib/Devel/bt.pm

    $ perl -d:bt -MB -e'(bless \(my $o = 0), q{B::SV})->REFCNT'
    #0  0x00007f9c3215ab0e in __libc_waitpid (pid=<value optimized out>, stat_loc=0x7fff4c5ffbe8, options=<value optimized out>) at ../sysdeps/unix/sysv/linux/waitpid.c:32
    #1  0x00007f9c319168c1 in backtrace () at bt.xs:129
    #2  0x00007f9c319168ec in sighandler (sig=11) at bt.xs:135
    #3  <signal handler called>
    #4  0x00007f9c316c8ccf in XS_B__SV_REFCNT (my_perl=0x151c010, cv=0x177bfb8) at B.c:3360
    #5  0x000000000057d5a0 in Perl_pp_entersub (my_perl=0x151c010) at pp_hot.c:2882
    #6  0x000000000051a331 in Perl_runops_debug (my_perl=0x151c010) at dump.c:2049
    #7  0x0000000000454ab0 in S_run_body (my_perl=0x151c010, oldscope=1) at perl.c:2308
    #8  0x0000000000453d78 in perl_run (my_perl=0x151c010) at perl.c:2233
    #9  0x00000000004230fd in main (argc=6, argv=0x7fff4c600788, env=0x7fff4c6007c0) at perlmain.c:117

このように、簡単に、gdb とかつかったことない人でも segv 時の stacktrace がとれる。内部の実装的には、gdb を起動しちゃってるんで、そこが微妙かなあ。

catchsegv とかつかっとけやという話もあるけど。

参考文献:

http://0xcc.net/blog/archives/000067.html

[Perl] Iteration あれこれ

nobody@example.com (ZIGOROu) — 2010-09-05T00:56:48+09:00

sharding やら partitioning とかし始めると段々とその key が特定のノートやパーティションに収まるように分類した上で処理とかしたくなる訳です。

最近、モバゲーのオープンプラットフォームのプロダクト全てで使っている、DBIx-DBHResolver にちょこちょこ新機能を入れたりしてるんですが、これに resolve_node_keys ってメソッドを最近つけたりしました。

#!/usr/bin/perl

use strict;
use warnings;
use feature qw(say);
use Data::Dump qw(dump);
use DBIx::DBHResolver;

my $resolver = DBIx::DBHResolver->new;
$resolver->config(
    +{
        clusters => +{
            TIMELINE =>
              +{ nodes => [qw/TIMELINE001 TIMELINE002/], strategy => 'Key' }
        },
        connect_info => +{
            TIMELINE001 => +{},
            TIMELINE002 => +{},
        }
    }
);

my %node_keys = $resolver->resolve_node_keys( TIMELINE => [ 1 .. 20 ] );
while ( my ( $node, $keys ) = each %node_keys ) {
    say $node;
    say dump $keys;
}

まぁこんな感じで使うんですが、

TIMELINE001
[2, 4, 6, 8, 10, 12, 14, 16, 18, 20]
TIMELINE002
[1, 3, 5, 7, 9, 11, 13, 15, 17, 19]

という出力となります。各ノードに分割アルゴリズムに則った形でノート名とキーの配列として返してくれます。余談ですがこの分割アルゴリズムは現在は Key, Range, List に対応してます。

このキーが今度はまた万単位であってそれらのキーを元に bulk insert するとかそんな処理が出てきたりする訳ですが、毎回のごとく

my @all_values = ( 1 .. 100000 );
my @values;
while ( ( @values = splice(@all_values, 0, 1000) ) > 0 ) {
  ### bulk insert by each @values
}

みたいな処理を書いて居た訳ですがどうにもスマートじゃないなぁと前から思ってました。

でこんな風にしてみるのはどうかなと思い立ったのがこちら。

#!/usr/bin/perl

use strict;
use warnings;
use feature qw(say);

use Array::AsHash;
use Data::Dump qw(dump);
use Data::Util qw(is_scalar_ref is_number);
use Iterator::Simple qw(iterator);
use SQL::Abstract;
use SQL::Abstract::Plugin::InsertMulti;

sub bulk_insert_iterator {
    my ( $values, $size ) = @_;
    $size ||= 100;
    iterator {
        my @next = splice( @$values, 0, $size );
        return unless ( @next > 0 );
        \@next;
    };
}

sub as_sql {
    my ( $stmt, @bind ) = @_;
    for my $v (@bind) {
        if ( is_scalar_ref $v ) {
            $stmt =~ s/\?/%s/;
        }
        elsif ( is_number $v ) {
            $stmt =~ s/\?/%d/;
        }
        else {
            $stmt =~ s/\?/'%s'/;
        }
    }
    sprintf( $stmt, @bind );
}

my $sql = SQL::Abstract->new;
my ( $stmt, @bind );
my %node_keys = (
    PEOPLE001_MASTER => [ map { $_ * 2 } ( 1 .. 25 ) ],
    PEOPLE002_MASTER => [ map { ( $_ * 2 ) - 1 } ( 1 .. 25 ) ]
);
my @cols = qw( id ref_id created_on );

my $ah = Array::AsHash->new( +{ array => [%node_keys] } );

while ( my ( $node, $keys ) = $ah->each ) {
    say $node;
    say '-' x 100;
    my $iter =
      bulk_insert_iterator( [ map { [ 1, $_, \'NOW()' ] } @$keys ], 10 );
    while ( my $values = $iter->next ) {
        ( $stmt, @bind ) = $sql->insert_multi( 'hidek', \@cols, $values );
        say as_sql( $stmt, @bind );
    }
    say '-' x 100;
}

で出力はこんな風になります。

PEOPLE001_MASTER
----------------------------------------------------------------------------------------------------
INSERT INTO hidek ( id, ref_id, created_on ) VALUES ( 1, 2, NOW() ), ( 1, 4, NOW() ), ( 1, 6, NOW() ), ( 1, 8, NOW() ), ( 1, 10, NOW() ), ( 1, 12, NOW() ), ( 1, 14, NOW() ), ( 1, 16, NOW() ), ( 1, 18, NOW() ), ( 1, 20, NOW() )
INSERT INTO hidek ( id, ref_id, created_on ) VALUES ( 1, 22, NOW() ), ( 1, 24, NOW() ), ( 1, 26, NOW() ), ( 1, 28, NOW() ), ( 1, 30, NOW() ), ( 1, 32, NOW() ), ( 1, 34, NOW() ), ( 1, 36, NOW() ), ( 1, 38, NOW() ), ( 1, 40, NOW() )
INSERT INTO hidek ( id, ref_id, created_on ) VALUES ( 1, 42, NOW() ), ( 1, 44, NOW() ), ( 1, 46, NOW() ), ( 1, 48, NOW() ), ( 1, 50, NOW() )
----------------------------------------------------------------------------------------------------
PEOPLE002_MASTER
----------------------------------------------------------------------------------------------------
INSERT INTO hidek ( id, ref_id, created_on ) VALUES ( 1, 1, NOW() ), ( 1, 3, NOW() ), ( 1, 5, NOW() ), ( 1, 7, NOW() ), ( 1, 9, NOW() ), ( 1, 11, NOW() ), ( 1, 13, NOW() ), ( 1, 15, NOW() ), ( 1, 17, NOW() ), ( 1, 19, NOW() )
INSERT INTO hidek ( id, ref_id, created_on ) VALUES ( 1, 21, NOW() ), ( 1, 23, NOW() ), ( 1, 25, NOW() ), ( 1, 27, NOW() ), ( 1, 29, NOW() ), ( 1, 31, NOW() ), ( 1, 33, NOW() ), ( 1, 35, NOW() ), ( 1, 37, NOW() ), ( 1, 39, NOW() )
INSERT INTO hidek ( id, ref_id, created_on ) VALUES ( 1, 41, NOW() ), ( 1, 43, NOW() ), ( 1, 45, NOW() ), ( 1, 47, NOW() ), ( 1, 49, NOW() )
----------------------------------------------------------------------------------------------------

まぁ最初の Array::AsHash は each でも一向に構わない訳ですが、何となく試しに使ってみました。

汎用的な Iterator を作りたいのであれば、Iterator::Simple が一番軽量で汎用的だなーという印象。

How to authenticate with basic auth + htpasswd

nobody@example.com (tokuhirom) — 2010-09-04T13:15:06+09:00

use strict;
use warnings;
use Authen::Htpasswd;
use Plack::Builder;

my $app = sub {
    [200, [], ['OK']]
};

builder {
    my $authen = Authen::Htpasswd->new('user.txt', {encrypt_hash => 'md5'});
    enable 'Auth::Basic',
        authenticator => sub {
            my ($username, $password) = @_;
            my $user = $authen->lookup_user($username);
            return $user && $user->check_password($password);
        };
    $app;
};

tokuhirom.vox.com 移転のおしらせ

nobody@example.com (tokuhirom) — 2010-09-03T19:04:51+09:00

vox がおわるというので tokuhirom.wordpress.com にうつした。

import tool があるので簡単だった。

しかし今後も更新の予定はない。

Data-MessagePack 0.16 だした

nobody@example.com (tokuhirom) — 2010-09-03T19:04:50+09:00

Duselongdouble してるときに、double の文字列表現がちがくなるのでテストがこけるという問題があって、それをなおした。

あと、PP 版の pull request がまかまかさんからきており、review して 2 点ほど追加要望をつけてさしもどし中(お前がやれってはなしなんですが、ちょっと手をつける余裕がなくてすみません)。

というわけで、ぼちぼち PP 版もでるんじゃないかとおもいます。

withoutworldwritables の話

nobody@example.com (tokuhirom) — 2010-09-03T17:51:40+09:00

http://use.perl.org/~cosimo/journal/37554

withoutworldwritables という謎の suffix をつけて CPAN にアップしてる人がいて、だいたいそういうモジュールはクオリティがひくいなあとおもっていたのだけど、この suffix は PAUSE が自動的につけていて、world writable なファイルがふくまれているときに自動的につくものだということを miyagawa さんからおしえていただきました。

Re: Algorithm - 0と1を次々と返す簡単なお仕事

nobody@example.com (tokuhirom) — 2010-09-03T07:33:32+09:00

http://blog.livedoor.jp/dankogai/archives/51512419.html

Perl5.10 なら state がつかえるから、以下のように書けるのではないか。

#!/usr/bin/perl
use 5.010;
use strict;
use warnings;
use Test::More;

sub flipflop {
    state $p = !shift;
    $p = !$p
}

ok !flipflop();
ok flipflop();
ok !flipflop();
ok flipflop();

done_testing;

$hidek->{age}++; #40

nobody@example.com — 2010-09-03T00:03:19+09:00

赤外線通信って本当に危険ですね。こんばんは。 2010年9月2日をもってわたくし、とうとう40歳を迎えました。昨日はmyfinderさん幹事のもと、ダブル成人式と題して30人を超える人に祝って頂きました。たくさんのプレゼントと暖かいお祝いの言葉を頂いて本当に感激でした。中でもgfxさん、hirose31さん、moriyoshiさんという豪華すぎる面々によるLT大会までしていただいて感謝感謝です。というかあれは一おっさんの誕生日だけでやるにはもったいないクオリティだと思います。本当にありがとうございました。あんな大勢の方々に笑顔で祝って頂ける自分は本当に幸せだと思います。本当にありがとうございます。 40歳と言えば不惑ということでこれからも惑わずに楽しく過ごせたらと思います。今後ともよろしくお願い申し上げます！そういえば、出社したらガリガリ君40本とコーラ40本いう粋なプレゼントも待っていました。では、頂いた篠田麻里子の写真集を読みながら40代最初の睡眠に就こうと思います。おやすみなさい。

祝！共著『ソーシャルストリーム・ビジネス』重版決定♪　好評発売中！

nobody@example.com (Kawanet Tech Blog) — 2010-09-01T03:17:00+09:00

川崎がリクルートのメディアテクノロジーラボが執筆した書籍『ソーシャルストリーム・ビジネスTwitter、Facebook、iPhone時代の消費者を巻き込むビジネスの新ルール』の増刷が決定しました！8888!

ウェブリブログに、はてなスターを貼る手順

nobody@example.com (Kawanet Tech Blog) — 2010-09-01T01:19:00+09:00

ウェブリブログに、はてなスターを貼ってみた手順メモ。はてなスターは、最近話題の『いいね！』『Like！』みたいなレイティング・投票機能の一種です。はてなダイヤリーに限らず、他のサイトにも簡単な JavaScript だけで手軽に★機能を追加できます。

DISQUS CommentsのTwitterコメント投稿・表示欄を掲載する手順

nobody@example.com (Kawanet Tech Blog) — 2010-08-28T19:41:00+09:00

TechCrunch でも使われている DISQUS COMMETNS が便利です。JavaScript のコードを貼るだけで、自分のブログやウェブサイトにコメント欄を追加できます。コメントを投稿する人は、Twitter アカウントで認証できるのでラク。（OpenIDも可）投稿されたコメントは、そのまま Twitter で流れる。Twitter 上でその URL について言及された他のツイートも、コメントとして表示してくれる。Twitter のリアルタイム検索ではツイー...

ウェブリブログでトラックバックの表示を削除するスクリプト

nobody@example.com (Kawanet Tech Blog) — 2010-08-28T18:49:00+09:00

トラックバックは死んだと言われて久しいですが、ウェブリブログは「ブログ」サービスなので、今もトラックバック機能が付いています。表示エリアも結構大きい。ときどきは便利なんですが、最近は滅多に使われないので、『トラックバック　（0件）』の表示エリアをまるごと削除してしまうスクリプトを書いてみました。ウェブリブログの表示が少しスッキリします。