気になったので質問してみました。ふるってご回答ください。
雨降りは、虫にとっては大変なことではないでしょうか？特に、蚊や羽虫のような小さな虫にとっては特に。そこで、以下の疑問にお答え願います。
- 雨粒に直撃されるとダメージを負うのでしょうか？
- 雨粒に囲まれて地面に叩きつけられるようなことがあるのでしょうか？
- 叩きつけられた後、水たまりで溺れて死んでしまったりするのでしょうか？
- その他、なにか大変なことがあったりするのではないでしょうか？
弊社では、東京オフィスと京都オフィスとを常時、Polycomという、ビデオチャットの高級版みたいなシステムで接続していて、東京・京都間でいつでも距離を感じさせずに自然にコミュニケーションを図れるような仕組みが整備されています。
それは便利な一方、たまに静かであるべき状況で相手側の音声が入って鬱陶しい場合があって、IRCや口頭で、近くにいるひとにマイクのミュートをお願いしたりすることがあります。最近、PolycomのWebインタフェイスから、リモコンのような仕組みでPolycomを操作できることがわかって、それを使ってミュートすればいいじゃないかということになりました。ということはつまりなんかしらのAPIみたいなものがあるんだろうなーと思って見てみたら、案の定あったので、Perlから叩けるようにしてみました。
以下のサンプルスクリプトでは、シェルから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があるのかなどは知らないです。
0.18 - added accessor: Text::MicroTemplate::File->include_path
T::MT::File->include_path があると、Plack::App::MicroTemplate みたいなのをつくるときに便利だよねーっということで。
これは read only accessor としているが、これをうわがきすると、キャッシュが混乱するため(まあ、キャッシュをクリアする方向で調整してもいいのだが、そもそもそうそう書換えるもんでもないので read only とした)。
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 とかつかっとけやという話もあるけど。
参考文献:
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 が一番軽量で汎用的だなーという印象。
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; };
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; };
vox がおわるというので tokuhirom.wordpress.com にうつした。
import tool があるので簡単だった。
しかし今後も更新の予定はない。
あと、PP 版の pull request がまかまかさんからきており、review して 2 点ほど追加要望をつけてさしもどし中(お前がやれってはなしなんですが、ちょっと手をつける余裕がなくてすみません)。
というわけで、ぼちぼち PP 版もでるんじゃないかとおもいます。
http://use.perl.org/~cosimo/journal/37554
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;