2011-04-04

Iterator::GruopedRange 0.02 Released

Perl CPAN

さて、ちょっとしたことからタイトルのようなモジュールを書いて見ました。Iterator::GroupedRange モジュールは簡単に説明すると、リストまたは別の(複数行ずつ返す)イテレータから指定行数分まとめて列挙するというモジュールです。

0.01 で SYNOPSIS を思いっきり間違えてたので、正しいものをこちらに。*1

use Iterator::GroupedRange;

my @ds = (
  [ 1 .. 6 ],
  [ 7 .. 11 ],
  [ 11 .. 25 ],
);

my $i1 = Iterator::GroupedRange->new( sub { shift @ds; }, 10 );
$i1->next; # [ 1 .. 10 ]
$i1->next; # [ 11 .. 20 ]
$i1->next; # [ 21 .. 25 ]

my $i2 = Iterator::GroupedRange->new( [ 1 .. 25 ], 10 );
$i2->next; # [ 1 .. 10 ]
$i2->next; # [ 11 .. 20 ]
$i2->next; # [ 21 .. 25 ]

例えばこんな風に使います。

my $ids = $dbh_friend->selectcol_arrayref('SELECT friend_user_id FROM friends WHERE user_id = ?', +{ Columns => [1] }, 10028);
my $iterator = Iterator::GroupedRange->new( $ids, 1000 );
my @rs;
while ( $iterator->has_next ) {
  my $ranged_ids = $iterator->next;
  push(@rs, $dbh_owneres->selectcol_arrayref(
    sprintf('SELECT owner_user_id FROM user_application WHERE application_id = ? AND owner_user_id IN (%s)', substr('?,' x @$ranged_ids, 0, -1)),
    +{ Columns => [1], },
    @$ranged_ids,
  ));
}

ちなみに下記のように、やろうと思えばこれらの入れ子なんかも出来ます。

sub installed_users_iterator {
  my ($self, $uids) = @_;
  my $uids_iterator = Iterator::GroupedRange->new( $uids, 1000 );
  my $dbh = $self->dbh;
  return Iterator::GroupedRange->new(sub {
    return [] unless ( $uids_iterator->has_next );
    my $ranged_uids = $uids_iterator->next;
    $dbh->selectcol_arrayref( "SELECT ...", +{ Columns => [1] }, @$ranged_uids );
  }, 1000);
}

この例だと selectcol_arrayref() の実行結果が1000レコードに満たない配列リファレンスが返って来たとしても、高々1000件ずつ取得出来る Iterator を返すと言う感じです。

つまりこれ何のために作ったかと言うと、分割可能なクエリを物理的に異なるDBなどに対して順番にぶつけていくような処理に使えるかなと思って書いた次第です。その際に出来る限りクエリの発行回数を減らす為に書いてみた訳です。

と言うわけでドキュメントが無くてだいぶ酷い状態ですけど、よろしければご利用下さいませ。

*1:そして今気づいたけど method に関する POD が無かったことに気づいた＞＜

2010-03-14

XML::Writer

Perl CPAN

今まで使ったこと無かったけど、これは便利だ。

#!/usr/bin/perl

use strict;
use warnings;

use IO::String;
use XML::Beautify;
use XML::Writer;

my $osns   = 'http://ns.opensocial.org/2008/opensocial';
my $buffer = IO::String->new;
my $writer = XML::Writer->new(
    NAMESPACES => 1,
    ENCODING   => 'utf-8',
    OUTPUT     => $buffer,
    PREFIX_MAP => +{ $osns => '', }
);

my $response = +{
    startIndex   => 1,
    itemsPerPage => 2,
    totalResults => 100,
    entry        => [
        +{
            id     => '34KJDCSKJN2HHF0DW20394',
            name   => +{ unstructured => 'Jane Doe', },
            gender => 'female',
        },
        +{
            id     => 'VMK92BFH3DNWRYX39673DF',
            name   => +{ unstructured => 'John Smith', },
            gender => 'male',
        },
    ],
};

$writer->startTag( [ $osns, 'response' ] );

render_xml( $writer, $response );

$writer->endTag( [ $osns, 'response' ] );
$writer->end;

my $formatter = XML::Beautify->new();
$formatter->indent_str('  ');

my $xml = $formatter->beautify($buffer->string_ref);
print $xml;

$buffer->close;

sub render_xml {
    my ( $writer, $data ) = @_;

    for my $field ( keys %$data ) {
        my $val = $data->{$field};
        if ( ref $val eq 'HASH' ) {
            $writer->startTag($field);
            render_xml( $writer, $data->{$field} );
            $writer->endTag($field);
        }
        elsif ( ref $val eq 'ARRAY' ) {
            for my $entry (@$val) {
                $writer->startTag('entry');
                $writer->startTag('person');

                render_xml( $writer, $entry );

                $writer->endTag('person');
                $writer->endTag('entry');
            }
        }
        else {
            $writer->startTag($field);
            $writer->characters($val);
            $writer->endTag($field);
        }
    }
}

みたいなコードを書くと、

<response xmlns="http://ns.opensocial.org/2008/opensocial">
  <entry>
    <person>
      <name>
        <unstructured>Jane Doe</unstructured>
      </name>
      <id>34KJDCSKJN2HHF0DW20394</id>
      <gender>female</gender>
    </person>
  </entry>
  <entry>
    <person>
      <name>
        <unstructured>John Smith</unstructured>
      </name>
      <id>VMK92BFH3DNWRYX39673DF</id>
      <gender>male</gender>
    </person>
  </entry>
  <startIndex>1</startIndex>
  <itemsPerPage>2</itemsPerPage>
  <totalResults>100</totalResults>
</response>

って感じで出力される。

2009-11-12

今日の SQL::Abstract

Perl CPAN SQL

SELECT * FROM hogehoge WHERE hoge_flags & 2 = 0;

みたいのを作りたい場合、

use strict;
use warnings;

use Data::Dump qw(dump);
use SQL::Abstract;

my $sql = SQL::Abstract->new;
my ($stmt, @bind) = $sql->select("hogehoge", ["*"], +{ hoge_flags => \[ "& ? = ?", 2, 0 ] });

とかで出来る。

もうここまで来ると変な呪文みたいだ。

2009-03-19

DBD::Mock を使ったテスト

Perl CPAN Test

DBD::Mock は DBI のドライバの一つで、DBI を使ったプログラムで意図的な状態を作る事が出来ます。
と言う訳でメモ程度に書いて行きます。

データベースハンドルの取得

use strict;
use warnings;

use Test::More;
use DBI;

plan tests => 3;

my $dbh = DBI->connect('dbi:Mock:', '', '', +{ AutoCommit => 0, RaiseError => 1 });

ok($dbh, 'Create database handle');
isa_ok($dbh, 'DBI:db');
is($dbh->{Driver}->{Name}, 'Mock', 'Driver information');

で、普通に Database Handle が取れます。

SELECT してる箇所

事前に mock_add_resultset を定義しておくと任意の resultset を返す事が出来ます。

#!/usr/bin/perl

use strict;
use warnings;

use Test::More;
use DBI;

plan tests => 2;

my @records = (
    [1, 'zigorou'],
    [2, 'kazuho'],
    [3, 'yappo'],
    [4, 'tokuhirom'],
    [5, 'hidek'],
    [6, 'typester'],
);

my %user_data = (
    sql     => q|SELECT user_id, nickname FROM user_data WHERE user_status = ?|,
    results => [
        [qw/user_id nickname/],
        @records,
    ],
);

my $dbh = DBI->connect('dbi:Mock:', '', '', +{ AutoCommit => 0, RaiseError => 1, });
$dbh->{mock_add_resultset} = \%user_data;

my $sth = $dbh->prepare($user_data{sql});
isa_ok($sth, 'DBI::st');
$sth->execute(1);
is_deeply($sth->fetchall_arrayref, \@records, 'resultset');

INSERT, UPDATE, DELETE とか

$sth->rows で返って来る件数を指定するのも mock_add_resultset で定義出来ます。

#!/usr/bin/perl

use strict;
use warnings;

use Test::More;
use DBI;

plan tests => 2;

my %user_data = (
    sql     => q|INSERT INTO user_data(nickname) VALUES(?)|,
    results => [
        [qw/rows/],
        [],
    ],
);

my $dbh = DBI->connect('dbi:Mock:', '', '', +{ AutoCommit => 0, RaiseError => 1, });
$dbh->{mock_add_resultset} = \%user_data;

my $sth = $dbh->prepare($user_data{sql});
isa_ok($sth, 'DBI::st');
$sth->execute('zigorou');
is_deeply($sth->rows, 1, 'affected rows');
$dbh->commit;

追記1 (2009-03-25T17:23:01+09:00)

DBI::connect(), DBI::st->prepare(), DBI::st->execute() でわざと失敗する例

use Test::More;
use Test::Exception;
use Carp;
use DBI;

plan tests => 9;

my $drh = DBI->install_driver('Mock');
isa_ok($drh, 'DBI::dr');

dies_ok(
    sub {
        local $drh->{mock_connect_fail} = 1;
        my $dbh = DBI->connect('dbi:Mock:', '', '', +{ AutoCommit => 0, RaiseError => 1, }) || croak(q|Cannot connect mock database|);
    }, 'mock_connect_fail on'
);

lives_ok(
    sub {
        local $drh->{mock_connect_fail} = 0;
        my $dbh = DBI->connect('dbi:Mock:', '', '', +{ AutoCommit => 0, RaiseError => 1, }) || croak(q|Cannot connect mock database|);
    }, 'mock_connect_fail off'
);

my $dbh = DBI->connect('dbi:Mock:', '', '', +{ AutoCommit => 0, RaiseError => 1, }) || croak(q|Cannot connect mock database|);

isa_ok($dbh, 'DBI::db');

lives_ok(
    sub {
        local $dbh->{mock_can_prepare} = 1;
        my $sth = $dbh->prepare(q|SELECT * FROM foo;|);
    },
    'mock_can_prepare on'
);

dies_ok(
    sub {
        local $dbh->{mock_can_prepare} = 0;
        my $sth = $dbh->prepare(q|SELECT * FROM foo;|);
    },
    'mock_can_prepare off'
);

my $sth = $dbh->prepare(q|SELECT * FROM foo;|);

isa_ok($sth, 'DBI::st');

lives_ok(
    sub {
        local $dbh->{mock_can_execute} = 1;
        $sth->execute();
    },
    'mock_can_execute on'
);

dies_ok(
    sub {
        local $dbh->{mock_can_execute} = 0;
        $sth->execute();
    },
    'mock_can_execute off'
);

まとめ

とりあえず上手い事、データベース処理を差し替えてあげて DBD::Mock のデータベースハンドルを作ってやって、外側から resultset を定義してあげたりすると、いい感じでテストを実行出来ます。

また他にも様々な機能を持っていて、意図的に commit 失敗とかそういう状況を作れるみたいなので、網羅的にテストする事が可能だと思います。

Sub::Exporter の collectors

Perl CPAN

Sub::Exporter の collectors だけ良く分からなくて、

を見たんだけど、その部分の解説とコードが中途半端で意味が良く分かりませんでした。

そんな訳で Google 先生に聞いたところ、

http://googlewhacks.blogspot.com/2007/12/pittsburgh-perl-workshop1crafting.html

から、

Crafting Custom Interfaces with Sub::Exporter

Crafting Custom Interfaces with Sub::Exporter

View more presentations from Ricardo Signes. (tags: perl programming)

が見つかったので読んでみるとやっと理解出来た件。Collectors に関しては 191 ページ目くらいから。*1

まぁ詳細はスライドに delegate するとして、サンプルを書いてみると。

package String::Truncate;

use strict;
use warnings;

use YAML;
use Perl6::Say;
use Sub::Exporter -setup => +{
    exports => [
        trunc => \'_build_trunc',
    ],
    collectors => [ qw(defaults custom) ],
};

sub trunc {
    my ($str, $length) = @_;
    substr($str, 0, $length);
}

sub _build_trunc {
    my ($class, $name, $arg, $col) = @_;

    say Dump +{
        name => $name,
        arg => $arg,
        col => $col,
    };
    
    return sub {
        my ($str, $length) = @_;
        $length ||= $arg->{length};
        trunc($str, $length);
    };
}

package main;

use Perl6::Say;

String::Truncate->import(
    'defaults' => +{ length => 4, foo => 3, bar => 5, },
    'custom' => +{ length => 7, foo => 1, bar => 2, },
    'trunc' => undef,
    'trunc' => +{ length => 10, -as => 'trunc10' },
);

say trunc("My name is ZIGOROu.", 4);
say trunc10("My name is ZIGOROu.");

まぁ実行すると、$arg, $col の意味が分かるはず。

$arg は export したいシンボルの隣にある HASHREF の内容が入ってる
$col は collectors の名前ごとに指定した HASHREF の内容が入ってる

ってだけですね。

確かに、上手く使うとコードがすっきりしそう。ウマー。

ちなみに collectors は bootstrap 的なメソッドを実行するとかそういう使い方も出来るので、Tutorial, Cookbook は何となく眺めてみるといいかもです。
でもさっきのスライドが一番良いと思いますw

*1:300 ページを超えるスライド！

2008-12-11

URI::Template 0.14_01 は draft-03 相当

Perl CPAN

まぁ DEVELOPER RELEASE ですけども、URI::Template 0.14_01 は draft-03 相当みたい。

新しく出来るようになったこと

id:n_shuyo に、

draft-03 でしかないくせに、RESTful本の作者からは「HTML5 に入るかも」と(過度の？)期待を得ているのだが、実のところ draft-03 は結構プログラマブルだったりと無闇に高機能。

ムダに高機能と DIS られている複数の operator が使えるようになってます。

#!/usr/bin/perl

use strict;
use warnings;

use Perl6::Say;
use URI::Template;

my $template = URI::Template->new("http://example.com{-prefix|/|pathes}?{-join|&|foo,bar}");

say $template->process( pathes => [qw/a b c/], foo => "fooooo", bar => "barrrr" );

とかやると、

http://example.com/a/b/c?foo=fooooo&bar=barrrr

ってなる。

出来なくなってること

実際の URI に対してマッチする URI Template がある場合に、どの変数にどうマッチしたかを調べる deparse メソッドが無くなった。

これが出来ると出来ないだとだいぶ違うんだけどなぁ。

Params::Coerce のメモ

Perl CPAN

Params::Coerce の使い方が良く分からなかったので試してみました。

追記 (2008-06-09T18:22:10+09:00)

と言うか、すぐに間違えに気づいたので内容を大幅に書き換え（ぉぃ

Params::Coerce とは

特定のクラスのインスタンスから違うクラスのインスタンスへ変換する枠組みを提供するモジュールです。

coerce の使い方

変換元に __as_Dest_Class メソッドを定義する方法

例えば Path::Class::File オブジェクトを URI オブジェクトに変換したいって場合に次のような書き方が出来ます。

package Path::Class::File;

use URI;

sub __as_URI {
    my $self = shift;
    URI->new('file://' . $self->absolute);
}

package main;

use Data::Dump qw(dump);
use Params::Coerce qw();
use Path::Class qw();
use Perl6::Say;

my $file = Path::Class::file('.', 'test.pl');
my $uri = Params::Coerce::coerce('URI', $file);

say dump $uri;

変換元のオブジェクト、つまりここでは Path::Class::File に __as_Class_Name と言ったメソッドを定義しておくと、Class::Name 型のオブジェクトへの変換ルールを定義出来て、この型変換部は、Params::Coerce::coerce()関数で上手い事ディスパッチしてくれるみたいです。

変換先に __from_Src_Class メソッドを定義する方法

Path::Class::File -> URI への変換の際に、先ほどは Path::Class::File にメソッドを生やして定義したけど、逆に変換先のクラスである URI にメソッドを生やす方式でも変換可能です。

package URI;

use URI;
use Params::Coerce qw(from);

sub __from_Path_Class_File {
    my ($self, $file) = @_;
    URI->new('file://' . $file->absolute);
}

package main;

use Data::Dump qw(dump);
use Path::Class qw();
use Perl6::Say;

my $file = Path::Class::file('.', 'test.pl');
my $uri = Params::Coerce::coerce('URI', $file);

say dump $uri;

使う側からすれば、Path::Class::Fileに(__as_Dest_Class)変換ルールがあろうとも、URIに(__from_Src_Class)変換ルールがあろうとも coerce で指定した変換先のクラス名を指定しておけば変換可能です。

URI 専用の coerce を作りたい

前の例とほとんど変わらない。

package Path::Class::File;

use URI;

sub __as_URI {
    my $self = shift;
    URI->new('file://' . $self->absolute);
}

package main;

use Data::Dump qw(dump);
# use Params::Coerce qw();
use Params::Coerce '_URI' => 'URI';
use Path::Class qw();
use Perl6::Say;

my $file = Path::Class::file('.', 'test.pl');
# my $uri = Params::Coerce::coerce('URI', $file);
my $uri = _URI($file);

say dump $uri;

コメントアウトの直後が改変点。結果は同じになる。
これは当たり前だけど、__from_Path_Class_File を URI に定義したケースでも同じ結果になる。

from の使い方

変換先クラスに変換用のディスパッチメソッドとなるfromを生やす方法です。

package URI;

use URI;
use Params::Coerce qw(from);

sub __from_Path_Class_File {
    my ($self, $file) = @_;
    URI->new('file://' . $file->absolute);
}

package main;

use Data::Dump qw(dump);
use Path::Class qw();
use Perl6::Say;

my $file = Path::Class::file('.', 'test.pl');
my $uri = URI->from($file);

say dump $uri;

URI->from で対応している変換を行う事が出来ます。

まとめ

Params::Coerce を使うとオブジェクトの変換ルールを上手い事定義出来る枠組みが出来る。

基本的には変換元に __as_Target_Class
または変換先に __from_Src_Class

と言ったメソッドのいずれかを定義しておくと、Params::Coerce::coerce() によってシームレスなオブジェクト型変換を行う事が出来る。

また特定のオブジェクトへの変換だけを制御するメソッドを定義出来る。(例だと _URI メソッド)
さらに変換先クラスにて変換元オブジェクトを受け付けるディスパッチメソッドとして from を import する事が出来る。

日向夏特殊応援部隊

俺様向けメモ

Iterator::GruopedRange 0.02 Released

XML::Writer

今日の SQL::Abstract

DBD::Mock を使ったテスト

データベースハンドルの取得

SELECT してる箇所

INSERT, UPDATE, DELETE とか

追記1 (2009-03-25T17:23:01+09:00)

まとめ

SEE ALSO

Sub::Exporter の collectors

URI::Template 0.14_01 は draft-03 相当

新しく出来るようになったこと

出来なくなってること

SEE ALSO

Params::Coerce のメモ

追記 (2008-06-09T18:22:10+09:00)

Params::Coerce とは

coerce の使い方

変換元に __as_Dest_Class メソッドを定義する方法

変換先に __from_Src_Class メソッドを定義する方法

URI 専用の coerce を作りたい

from の使い方

まとめ