blog.nomadscafe.jp

CatalystのCatalyst::Plugin::Static::SimpleとCatalyst::Plugin::Session(::State::Cookie)の相性が悪い。最悪の場合セッションキーが消されてしまう。

原因はprepare_actionの実行順で、解決策としてはプラグインのロードの順番なのだが、

use Catalyst qw/Static::Simple　Session/

とした場合、
prepare_actionはStatic::Simpleの方が先に実行される。ところがStatic::Simpleのprepare_actionは、

return $c->NEXT::ACTUAL::prepare_action(@_);

で終わるため、Sessionではなく、SUPER:: prepare_action（つまり、、、Catalyst:: prepare_action？）と同じ事になってしまい、Sessionをロードするための、Session:: prepare_actionが読み出されなくなってしまう。

解決策はプラグインのロードの順番で、

use Catalyst qw/Session Static::Simple/

とすればいい。ドキュメントにも書いてありました。

This can be helpful by skipping session cookie checks for example. Or, if you want some plugins to run even on static files, list them before Static::Simple.

ただし、その「session cookie checks」のskipが原因だったのですが。

かなり悩んでしまった。

実際の問題点は、Catalyst::Plugin::Sessionのdump_theseかなぁ

 $c->sessionid
        ? ( [ "Session ID" => $c->sessionid ], [ Session => $c->session ], )
        : ()

Catalyst::Plugin::Session::State::Cookieでsessionidが設定されているから、「$c->session」が実行されてしまい、sessionメソッドの中でgenerate_session_idしてしまうと。修正するなら、

 $c->sessionid && $c->{session}
        ? ( [ "Session ID" => $c->sessionid ], [ Session => $c->session ], )
        : ()

かなぁ。。

投稿者: かぜぶろ 日時: 22:23 | パーマリンク

ドワンゴがひろゆき氏とはじめた。ニワンゴ
Itmediaに「ドワンゴは、ひろゆき氏と組んで何を始めるのか (1/3)」
という記事がでています。

これ、かなり面白いんじゃないかと思うのです。

ケータイでぱどタウンをみれるような機能を作れという圧力はず〜とあるのですが、ケータイのブラウザを使ったサービスなんてつくったところで苦労に対しての効果ってあまり期待できないんじゃないかと思っていたりします。ケータイで利用するコミュニティサービスとしては如何にしてケータイメールと勝負するかというのがポイントで、ケータイのブラウザがメインではハナから負けているんじゃないかという気がしてます。

んで、ニワンゴ。「メールでリクエストしてメールでレスポンスを返す」というが基本。
データを蓄積していけばステートフルな通信を装うこともできそうだし、アイディア次第ではいろんなことができそうな気がする。

ツンデレモードとか、いう言葉が頭に浮かんでしまった。。

投稿者: かぜぶろ 日時: 12:34 | パーマリンク | トラックバック (1)

CPANのindexerが復活したようなので午前中にアップしたData::Page::Navigationもでてくるようになりました。

関連エントリー
1st Data::Pageとページナビゲーション
2nd Data::Page::Navigation　いい感じのページナビゲーション

使い方は、

use Data::Page::Navigation;

とuseするだけです。
あとは普通に

my $pager = Data::Page->new(100,10,2);

とData::Pageのオブジェクトを生成します。すると、表示するページ番号のリストをつくるpages_in_navigationメソッドが使えるようになってます。

my @list = $pager->pages_in_navigation();

Catalystでの例ですが、Class::DBI::PagerやDBIx::Classと一緒に使えるので、

use Data::Page::Navigation;

sub default : Private {
    my ( $self, $c ) = @_;
    $c->stash->{entries}=MyApp::Model::DBIC::Entry->search();
    $c->stash->{template} = 'list.tt.html';
    $c->forward('View::TT');
}

などとコントローラーの方は今まで通りに書くだけで、テンプレート中で

[% pager = c.stash.entries.pager %]
[% FOREACH num = pager.pages_in_navigation %]
[% IF num == pager.current_page %][% num %][% ELSE %]<a href="/list?page=[% num %]">[% num %]</a>[% END %]
[% END %]

とpages_in_navigationメソッドが使えます。

ちょっと便利。

投稿者: かぜぶろ 日時: 23:25 | パーマリンク | トラックバック (1)

http://search.cpan.org/recent
をみる限り、24日からCPANの更新が止まっているようだ。

どうしたのだろう。

投稿者: かぜぶろ 日時: 12:47 | パーマリンク | コメント (2)

実験でいろいろとやるうちに、

use Catalyst qw/-Debug Static::Simple Config::YAML FormValidator::Simple
    Session Session::Store::FastMmap Session::State::Cookie 
    Authentication Authentication::Credential::TypeKey/;

SessionとAuthentication関連が長いし大杉。
すっきりと書ける方法ないですかねぇ。

CatalystでTypeKey認証をする、Catalyst::Plugin::Authentication::Credential::TypeKeyは以下のような形で使用できる。
CPANにあがっていない場合はこちらのページからたどると入手できるはず。

use Catalyst qw/Authentication Authentication::Credential::TypeKey/;#セッションもあるといい

sub do_login : Local {
    my ( $self, $c ) = @_;
    $c->authenticate_typekey;
    $c->res->redirect('/');
}

sub login : Local {
    my ( $self, $c ) = @_;
    $c->res->redirect('https://www.typekey.com/t/typekey/login?t=' . 
    	$c->config->{authentication}{typekey}{token} . '&_return=' . $c->uri_for('/do_login'));
}

typekeyの認証がVer.　1.1ではうまく行かないらしいので、設定で

authentication:
    typekey:
        version: 1
        token: **
    use_session: 1

などとする必要があるらしい。

と書いていたら、さきほどmiyagawaさんがCatalystのMLで発言されていて、

But let me admit that there was a little funkiness when I first tried
the authentication using v1.1 and I believe it was related to
need_email part. Can you explicitly supply need_email=0 or 1 in the
original login URL for TypeKey and see what happens?

とも書いているのであとで試すことにしよう。

追記：
リダイレクトのリクエスト文字列にv=1.1を入れればOK

$c->res->redirect('https://www.typekey.com/t/typekey/login?t=' . 
    $c->config->{authentication}{typekey}{token} . '&v=1.1&_return=' . $c->uri_for('/do_login'));

でいけました。もちろんconfigの「version: 1」もなしです。

投稿者: かぜぶろ 日時: 01:04 | パーマリンク | コメント (2) | トラックバック (1)

Data::Pageとページナビゲーションのコードを微妙にリファクタリング。
Time::Piece::MySQLのようにプラグイン的な使い方ができたらいいかなぁに対応。

Data::Page::Navigationと名前をつけてみたけどどうだろう。

使い方は

use Data::Page::Navigation;
my $total_entries=30;
my $entries_per_page = 5;
my $pages_per_navigation = 5;

Data::Page->pages_per_navigation($pages_per_navigation);

my $pager = Data::Page->new(
    $total_entries,
    $entries_per_page,
    $current_page
);
my @list = $pager->pages_in_navigation($pages_per_navigation);

Data::Page::Navigationをロードしておけば、Data::Pageに、pages_per_navigationとpages_in_navigationが追加されるようになってます。

↓ソース

package Data::Page::Navigation;

use strict;
use warnings;
our $VERSION='0.01';
use Data::Page;

package Data::Page;

use base qw(Class::Data::Inheritable);

__PACKAGE__->mk_classdata('pages_per_navigation'=>10);

sub pages_in_navigation(){
    my $self = shift;
    
    my $pages_per_navigation = shift || $self->pages_per_navigation || 0;
    return ($self->first_page..$self->last_page) if $pages_per_navigation >= $self->last_page;
    
    my $prev = $self->current_page - 1;
    my $next = $self->current_page + 1;
    my @ret = ($self->current_page);
    my $i=0;
    while(@ret < $pages_per_navigation){
        if($i%2){
            unshift(@ret,$prev) if $self->first_page <= $prev;
            --$prev;
        }else{
            push(@ret,$next) if $self->last_page >= $next;
            $next++;
        }
        $i++;
    }
    return @ret;
}


1;

投稿者: かぜぶろ 日時: 12:15 | パーマリンク | コメント (2)

Scaffoldなどではすでに使われているのだけど、FormValidator::Simple(Data::FormValidator)とDBIx::Class::WebForm(Class::DBIの場合はClass::DBI::FromForm)、この組み合わせはヤバいね。非常に楽ができてしまう。

研究中のCatalystアプリの部分だけど、タイトルと、内容、時間(年〜秒まで6つのフォーム)があって、それをDBに入れる場合、

    my $result = $c->form(
        title=>[qw/NOT_BLANK/],
        text=>[qw/ANY/],
        {created_on=>[qw/d_year d_month d_day d_hour d_min d_sec/]}=>[qw/NOT_BLANK DATETIME/]
    );
    $c->detach('default') if $c->form->has_error;
    
    my $entry = MyApp::Model::DBIC::Entry->create_from_form($result);

これで確認も保存もできてしまう。　ちなみにテーブル定義は↓です。

create table entry(
    id int unsigned not null auto_increment,
    title varchar(250) not null,
    text text,
    created_on datetime not null
);

アップデートの場合は、

    my $entry = MyApp::Model::DBIC::Entry->find($c->req->params->{entry});
    $c->req->params->{id}=$c->stash->{entry}->id;#データベース上はIDなので
    my $result = $c->form(
        id=>[qw/ANY/],
        title=>[qw/NOT_BLANK/],
        text=>[qw/ANY/],
        {created_on=>[qw/d_year d_month d_day d_hour d_min d_sec/]}=>[qw/NOT_BLANK DATETIME/]
    );
    $c->detach('default') if $c->form->has_error;
    
    $entry->update_from_form($result);

こうやって書ける。

WebFormをLoaderと同時に使う場合(CatalystのヘルパーでModelクラスをつくった時など)のWebFormの追加の方法は、

__PACKAGE__->config(
    dsn           => '**',
    user          => '**',
    password      => '**',
    additional_base_classes   => 'DBIx::Class::WebForm',
    options       => {},
    relationships => 1
);

で行ける模様。
ValidatorとO/Rマッパーの連携のすばらしさを実感。

投稿者: かぜぶろ 日時: 21:44 | パーマリンク | コメント (4)

検索などで多くのページがヒットしたときの、ページナビゲーション

<< 3 4 5 6 *7 8 9 10 11 12 >>

の部分をうまく扱って、100ページ分とかあっても、前後のページのみ表示するモジュールを探していたんだけど、良いのが見つからない。
Data::Pagesetというのがあるんだけど、思ったのと違う。

トータルエントリーが30、1ページ5つのエントリーとして、ナビゲーションのリンクは4つとした場合に、Data::Pagesetでは、

ページ1の場合 *1,  2,  3,  4
ページ2の場合  1, *2,  3,  4
ページ3の場合  1,  2, *3,  4
ページ4の場合  1,  2,  3, *4
ページ5の場合 *5,  6
ページ6の場合  5, *6   

となってしまいます。*がついているところは現在のページを表してます。
希望としては、

ページ1の場合 *1,  2,  3,  4
ページ2の場合  1, *2,  3,  4
ページ3の場合  2, *3,  4,  5
ページ4の場合  3, *4,  5,  6
ページ5の場合  3,  4, *5,  6
ページ6の場合  3,  4,  5, *6  

こうなってほしいのです。

Data::Pagesetの場合のソースは↓

foreach my $current_page (1..6){
    my $pageset = Data::Pageset->new({
        total_entries=>$total_entries,
        entries_per_page=>$entries_per_page,
        current_page=>$current_page,
        pages_per_set=>$pages_per_set,
    });
    print join ",", "p$current_page",map {sprintf("% 3s",($_ == $current_page) ?
 "*$_" : $_)} @{$pageset->pages_in_set};
    print "\n";
} 

Data::Page::Pagesetというのもあるけど、ちょっと違う。

んで、思った通りのモジュールが見当たらないので、ちょっとひどい実装だけど自分で組んでみた。

Data::Pageを継承して、pages_in_setメソッドを追加しています。モジュール名も適当。

package DataPageSet;

use strict;
use warnings;
use base qw(Data::Page);

__PACKAGE__->mk_accessors(qw(pages_per_set));

sub new {
  my $class = shift;
  my $self  = {};
  bless($self, $class);

  my ($total_entries, $entries_per_page, $current_page, $pages_per_set) = @_;
  $self->total_entries($total_entries       || 0);
  $self->entries_per_page($entries_per_page || 10);
  $self->current_page($current_page         || 1);
  $self->pages_per_set($pages_per_set || 10);
  return $self;
}

sub pages_in_set(){
    my $self = shift;
    my $pages_per_set　= shift;	
	
    $pages_per_set ||= $self->pages_per_set || 10;
    return ($self->first_page..$self->last_page) if $pages_per_set >= $self->last_page;
	
    my $prev = $self->current_page - 1;
    my $next = $self->current_page + 1;
    my @ret = ($self->current_page);
    my $i=0;
    while(@ret < $pages_per_set){
        if($i%2){
            unshift(@ret,$prev) if $self->first_page <= $prev;
            --$prev;
        }else{
            push(@ret,$next) if $self->last_page >= $next;
            $next++;
        }
        $i++;
    }
    return @ret;
}

1;

全くヒドい実装だが、とりあえず動く。
使い方は、Data::Pageと同じ形で四つ目の引数に1ページのナビゲーションのリンクの数を書く。
初期値は10で、pages_per_setでも変更ができる。

foreach my $current_page (1..6){
    my $pageset = DataPageSet->new(
        $total_entries,
        $entries_per_page,
        $current_page,
        $pages_per_set
    );
    print join ",", "p$current_page",map {sprintf("% 3s",($_ == $current_page) ? "*$_" : $_)} $pageset->pages_in_set;
    print "\n";
}

これの結果は

p1, *1,  2,  3,  4
p2,  1, *2,  3,  4
p3,  2, *3,  4,  5
p4,  3, *4,  5,  6
p5,  3,  4, *5,  6
p6,  3,  4,  5, *6  

となって思った通り動いてくれました。

もうすこしましな実装と、Time::Piece::MySQLのようにプラグイン的な使い方ができたらいいかなぁと思う。

投稿者: かぜぶろ 日時: 21:25 | パーマリンク

DBIx::ClassやFormValidator::Simple::Plugin::DBIC::Uniqueをつかってみる。ネタはTropy。Tropyは簡単で良い。

完成品は↓ここで。特に外見で変わったところはありません。
http://nomadscafe.jp/dbiccaropy/dbiccaropy.cgi/

DBIx::Class(0.03003)なんだけど、自分の環境(CentOS 4.2)だとmake testで失敗する。

Failed Test            Stat Wstat Total Fail  Failed  List of Failed
-------------------------------------------------------------------------------
t/basicrels/16joins.t     1   256    22    1   4.55%  18
t/helperrels/16joins.t    1   256    22    1   4.55%  18    

これとtest途中にDBD::SQLiteのエラーも吐く。とりあえずforce installで入れました。

CGI::Application::Plugin::FormValidator::SimpleをFormValidator::Simpleの0.10で追加されたmessge handling機能に対応させる為に、

    if (exists $params{messages}){
        FormValidator::Simple->set_messages($params{messages});
    }

これを25行目あたりに追加しました。patchの形じゃなくてすみません。

現在動いている以前作成したTropyクローン、Caropyと大体同じなのですが、目立った変更点などを書いていきます。

現在のCaropyのソースと、今回のテストTropyのソース。

validatorのオプションに以下を設定

$self->validator(
	plugins=>[qw/DBIC::Unique/],
	messages=>'etc/validator_messages.yml',
	options=>{
		dbic_base_class=>'DBICCaropy'
	}
);

エラーメッセージは外部ファイル"etc/validator_messages.yml"に保存。中身はこれになります。
DBIC::Uniqueも使うという目的があったので、ページタイトルがユニークなのを確認することにしました。
create時には、

$self->form(
	title=>['NOT_BLANK',[qw/DBIC_UNIQUE Entry title/]]
);

update時には

$self->form(
	title=>['NOT_BLANK'],
	{unique_title=>[qw/id title/]}=>[[qw/DBIC_UNIQUE Entry !id title/]]
);

という確認をしています。

ModelとなるクラスのDBICCaropy::Entryでは、randomの取得の為に

sub find_random {
	shift->search_literal('1 ORDER BY RAND() LIMIT 1')->first;
}

を追加した。意外なほど動いた。

あとは、retrieveからfindへの変更をしたぐらいで、簡単に動くものはつくれました。
DBIx::Classについては、Class::DBIと違いを感じるところまで行ってない。もうすこし調べないとな。

投稿者: かぜぶろ 日時: 17:33 | パーマリンク | コメント (3) | トラックバック (2)

次世代テクノロジーセミナーシリーズ
ライブドアが提供する“オープンソーステクノロジーの最前線”ライブドアを支えるエンジニアがその秘訣を公開

12月13日って普通の日なんですけど、申し込んでしまいました。
これも重要な機会だと思うので行きます。

申込の返事のメールがまだなかったりするんだけど大丈夫かな。。。

投稿者: かぜぶろ 日時: 22:30 | パーマリンク

Class::DBIでobejctやreferenceを保存の続き。
どんぞこ日記さんのところで紹介されてるData::Serializerを採用した。ソースは追記に貼付けてます。

Data::Serializerを使ったので、Serializeに使うモジュールをいくつか選択できて、暗号化、圧縮、エンコード等ができるようになります。暗号化は便利かも。

使い方は前回と同じだけど、Data::Serializerのconfig用のserialize_configメソッドがついて

package Foo;
use base 'Class::DBI';
use Class::DBI::Plugin::SerializeColumn;
__PACKAGE__->columns(All => qw/id title props/);
__PACKAGE__->serialize_column('props');
__PACKAGE__->serialize_config(
    serializer=>'Storable',
    encoding=>'b64'
);

package main;
Foo->create({
    id=>1,title=>'foo',
    props=>{a=>1,b=>[qw/2 3 4/]}
})

my $foo=Foo->retirieve(1);
$foo->props->{a};#1
$foo->props->{b}->[0];#2

という感じ。

package Class::DBI::Plugin::SerializeColumn;

use 5.006;
use strict;
use warnings;
use Data::Serializer;
use vars qw($VERSION);
$VERSION='0.02';

sub import {
    my $class = shift;
    my $pkg   = caller(0);
    
    $pkg->mk_classdata('__serialize_config'=>{});
    $pkg->mk_classdata('__serialize_column'=>[]);

    my $before_create_update_callback=sub{
        my $self = shift;
        my $serializer = Data::Serializer->new(%{$self->serialize_config});
        foreach my $column (@{$self->serialize_column}){
            my $ref=$self->_attrs($column) || next;
            my $freeze=$serializer->serialize($ref);
            $self->_attribute_set($column,$freeze);
        }
    };
    my $select_callback=sub{
        my $self = shift;
        my $serializer = Data::Serializer->new(%{$self->serialize_config});
        foreach my $column (@{$self->serialize_column}){
            my $freeze=$self->_attrs($column) || next;
            my $ref=$serializer->deserialize($freeze);
            $self->_attribute_store($column,$ref);
        }
    };
    
    $pkg->add_trigger('before_create',$before_create_update_callback);
    $pkg->add_trigger('before_update',$before_create_update_callback);
    $pkg->add_trigger('select',$select_callback);
    
    no strict 'refs';
    *{"$pkg\::serialize_column"} =  \&serialize_column;
    *{"$pkg\::serialize_config"} =  \&serialize_config;
}

sub serialize_column{
    my $class = shift;
    if(@_ >0){
        push(@{$class->__serialize_column},shift);
    }
    return $class->__serialize_column;
}

sub serialize_config{
    my $class = shift;
    my $config = $class->__serialize_config;
    my %config = (%{$config},@_);
    $class->__serialize_config(\%config);
}

1;

投稿者: かぜぶろ 日時: 14:00 | パーマリンク | トラックバック (1)

「Class::DBI で疑似的カラム」をちょっと機能強化で書いたモジュールをもとにClass::DBI でobejctやreferenceをシームレスに保存できるプラグインを書いてみた。

使い方

package My::Film;
use base 'Class::DBI';
use Class::DBI::Plugin::SerializeColumn;
__PACKAGE__->columns(All => qw/id title props/);
__PACKAGE__->serialize_column('props');

などとクラスを書いて、

My::Film->create({
    id=>1,
    title=>'四月物語',
    props =>{year=> 1998,director=>'岩井俊二'}
});

とできるし、

my $film = My::Film->retrieve(1);
$film->props->{director};#岩井俊二
$film->props->{cast}=[qw/松たか子 田辺誠一 加藤和彦 藤井かほり/];
$film->update;

こういうこともできると思う。

もうすこし方法ないのか探しているんだけど、↓追記にソース貼付け

package Class::DBI::Plugin::SerializeColumn;

use 5.006;
use strict;
use warnings;
use UNIVERSAL::require;
use vars qw($VERSION);
$VERSION='0.01';

sub import {
	my $class = shift;
	my $pkg   = caller(0);
	
	$pkg->mk_classdata('column_serializer'=>'Storable');
	$pkg->mk_classdata('__serialize_column'=>[]);

	my $before_create_update_callback=sub{
		my $self = shift;
		foreach my $column (@{$self->serialize_column}){
			my $ref=$self->_attrs($column) || next;
			my $freeze=$self->_serialize_column_freeze($ref);
			$self->_attribute_set($column,$freeze);
		}
	};
	my $select_callback=sub{
		my $self = shift;
		foreach my $column (@{$self->serialize_column}){
			my $freeze=$self->_attrs($column) || next;
			my $ref=$self->_serialize_column_thaw($freeze);
			$self->_attribute_store($column,$ref);
		}
	};
	
	$pkg->add_trigger('before_create',$before_create_update_callback);
	$pkg->add_trigger('before_update',$before_create_update_callback);
	$pkg->add_trigger('select',$select_callback);
	
	no strict 'refs';
	*{"$pkg\::serialize_column"} =  \&serialize_column;
	*{"$pkg\::_column_serializer"} = \&_column_serializer;
	*{"$pkg\::_serialize_column_freeze"} = \&_serialize_column_freeze;
	*{"$pkg\::_serialize_column_thaw"} =  \&_serialize_column_thaw;
}

sub serialize_column{
	my $class = shift;
	if(@_ >0){
		push(@{$class->__serialize_column},shift);
	}
	return $class->__serialize_column;
}

sub _column_serializer{
	my $self = shift;
	my $serializer = "Class::DBI::Plugin::SerializeColumn::" . $self->column_serializer;
	$serializer->require;
	return $self->_croak(qq(couldn't load serializer "$serializer" : ) . $@) if $@;
	return $serializer;
}

sub _serialize_column_freeze{
	my($self, $var) = @_;
	my $serializer = $self->_column_serializer;
	my $freeze;
	eval{
		$freeze=$serializer->freeze($var);
	};
	return $self->_croak(qq(couldn't freeze data : ) . $@) if $@;
	return $freeze;
}

sub _serialize_column_thaw{
	my($self, $freeze) = @_;
	my $serializer = $self->_column_serializer;
	my $thaw;
	eval{
		$thaw=$serializer->thaw($freeze);
	};
	return $self->_croak(qq(couldn't thaw data $freeze: ) . $@) if $@;
	return $thaw;
}

1;

投稿者: かぜぶろ 日時: 17:43 | パーマリンク

本日オープンのぱどタウンの33番目の横浜マリンブルータウンのトップページに、なぜか横浜市長の中田宏氏のコメントがあります。
記念スクリーンショット。

こんな顔だっけ？

投稿者: かぜぶろ 日時: 12:32 | パーマリンク

nipotanさんの「Class::DBI で疑似的カラムを扱う」で(自演)紹介されてるClass::DBI::Plugin::PseudoColumnsなんですが、ObjectやHASHをStorableでSerializeしてデータベースに突っ込む方法を便利にできるプラグインとしてちょっと気になった。

ただ、２つほど弱点があって

• create/insert時に使えない
• SerializeがData::Dumperオンリー

このあたりが解決されると使いやすいと思うのでいじってみた。

podを書いてないんだけど、ソース一式はこちら→Class-DBI-Plugin-SerializeColumns-0.01.tar.gz。なかなかうまく動かなくていろいろ変更しているうちにソースコードは派手に変わっています。

使い方はPseudoColumnsと同じで、

create table movies (
    id    int primary key,
    title    varchar(255),
    serialized    blob
);

というテーブルで、

package My::Film;
use base 'Class::DBI';
use Class::DBI::Plugin::SerializeColumns;
__PACKAGE__->table('Movies');
__PACKAGE__->columns(All => qw/id title serialized/);
__PACKAGE__->serialize_columns(serialized=>qw/year director/);

というクラスを作って、使う。

My::Film->create({
    id=>1,
    title=>'四月物語',
    year=>'1998',
    director=>'岩井俊二'
});

createして、

my $film = My::Film->retrieve(1);
$film-> year #1998

と動くはず。

Serializerは、Class::DBI::Plugin::SerializeColumns::Serializerにthawとfreezeの２つの関数を作成しておいて、

__PACKAGE__->columns_serializer('Serializer');

とすると利用できるハズ。未テスト。
なにも指定しなければStorableが使われる。

はまったのは、Class::DBIにStorable::freezeなデータを渡す部分。

package My::Film;
use strict;
use warnings;
use base 'Class::DBI';
__PACKAGE__->table('Movies');
__PACKAGE__->columns(All => qw/id title serialized/);

を用意して、

{
    My::Film->create({
        id=>1,
        title=>'四月物語',
        serialized=>Storable::freeze({year=>1998,director=>'岩井俊二'})
    });
}
{
    my $film = My::Film->retrieve(1);
    my $ref = Storable::thaw($film->serialized);
    print $ref->{year},"\n";
}

これが動かない。「$film->serialized」が保存しようとしたものと違う。

とりあえず、katoさんのCatalyst::Plugin::Session::ManagerのStorage::CDBIを参考にbase64で対応したけどまだ調べる必要がありそうです。

投稿者: かぜぶろ 日時: 00:25 | パーマリンク | トラックバック (1)

id:naoyaさんが書いている

インデックスをかけてるテーブルでも、結局ランダムなので全件捜査してから値を返す。プライマリーキーに対して rand() する場合でも O(1) ではないのですよね。なんか回避する方法があったりするのかな

order by rand()は最近知った方です。
通常ランダムで返す必要がある場合データベースではなくプログラム側で、2度SQLを発行してます。

my ($count) = $dbh->selectrow_array('select count(*) from table');
my $offset = int rand $count;
my $ret = $dbh->selectrow_hashref('select * from table limit ?,1',{},$offset);

これで対応してました。
やっていることは、id:jazzanovaさんと同じような感じ。
速いのかどうかはちょっとわかりません。

投稿者: かぜぶろ 日時: 11:39 | パーマリンク

FormValidator::Simpleがバージョン0.10でMESSAGE HANDLING機能が追加されたのでさっそく試してみた。

想定するフォームは、以前試した時と同じ

<form>
メールアドレス:<input name="mail" type="text" id="mail" size="20" /><br /> 
パスワード:<input name="password" type="password" id="password" size="20" /><br />
もう一度パスワード:<input name="password_confirmation" type="password" id="password_confirmation" size="20" /><br />
パスワードは半角英数字5文字〜32文字
</form>

で行いました。

エラーメッセージの設定には、set_messagesを使う。

FormValidator::Simple->set_messages({
        action1=>{
            mail=>{
                NOT_BLANK=>'メールアドレスを入力してください',
                EMAIL=>'メールアドレスが正しくありません',
            },
            password=>{
                NOT_BLANK=>'パスワードを入力してください',
                DEFAULT=>'パスワードは英数字5文字〜32文字で入力してください'
            },
            password_confirmation=>{
                DEFAULT=>'パスワードが一致しません'
            }
        }
});

「action1」はあとでメッセージ取得用のキーとなっています。
この状態で今までと同じようにcheckをする。

my $result = FormValidator::Simple->check($q=>[
    mail=>['NOT_BLANK','EMAIL'],
    password=>['NOT_BLANK','ASCII',['LENGTH',5,32]],
    {password_confirmation=>[qw/password password_confirmation/]}=>['DUPLICATION']
]);

エラーメッセージの取得＆表示は、

my $messages = $result->messages('action1');#arrayref
foreach my $message ( @$messages ) {
    print $message, "\n";
}

とするとできる。

エラーメッセージは外部ファイルにYAML形式で設定する事もできる。shebang!のikebeさんのところで紹介されていたテクニックに近い。「action1」のところのキーを活用すれば、エラーメッセージを１つの外部ファイルにまとめられそう。メッセージのソースからの分離はおそらくハゲシク便利。

試しに、CGI::Applicationをつかった動くものをつくった。ソースはこちら。

CGI::Application::Plugin::FormValidator::Simpleの場合、set_messagesは、以下で設定できる。

$self->validator->set_messages({
        action1=>{
            mail=>{
            ・・・・
});

追記：
本家にもエントリーがされました。今回速かったのはCPANでアップデートしたときに0.10って想定外の数字(内容にも)がでたので驚いた勢いです。

投稿者: かぜぶろ 日時: 19:27 | パーマリンク | コメント (3)

このサーバがKerel Panicで落ちてました。
どうしてだろう。

とりあえず、CentOSの新しいKernelがでているので
2.6.9-11.EL → 2.6.9-22.EL
へアップデート

投稿者: かぜぶろ 日時: 20:13 | パーマリンク

CGI.pmでtext/xmlなPOSTデータを読みたい場合、

my $q = CGI->new;
$q->param('POSTDATA')

で読める。いままで知りませんでした。

正確には、x-www-form-urlencoded や multipart/form-dataではない場合に、POSTデータはPOSTDATAで読み出せる。ソースでは、

# YL: Begin Change for XML handler 10/19/2001
    if ($meth eq 'POST'
        && defined($ENV{'CONTENT_TYPE'})
        && $ENV{'CONTENT_TYPE'} !~ m|^application/x-www-form-urlencoded|
	&& $ENV{'CONTENT_TYPE'} !~ m|^multipart/form-data| ) {
        my($param) = 'POSTDATA' ;
        $self->add_parameter($param) ;
      push (@{$self->{$param}},$query_string);
      undef $query_string ;
    }
# YL: End Change for XML handler 10/19/2001

このようになっている。CGI.pmのcgi_docs.htmlにも書いてありました。

これを使うとAjaxやFlashのXMLリクエストの取得がスムーズだし、Web APIがCGI.pmを使っていても書けそうだ。

投稿者: かぜぶろ 日時: 23:59 | パーマリンク

いまいち不安定なんだけどMacのFTPソフト新定番のCyberduckがバージョンアップ。2.5.1になりました。
changelogに

[Feature] Universal Binary

なんていうのがあるので、すでにIntel Mac Readyですね。

ただ、Panther(10.3.9)でDrag & Dropでのアップロードができません。ってことで使えません。
なので2.5に戻しました。

追記：
Cyberduckのforumに

I have replaced the current 2.5.1 build which is now Version 2.5.1 (15/11/2005 08:16 PM) (2.5.1).
It should fix the spinning beachball issue when connecting and also has some better checks when to allow moving files by drag and drop.

とありました。さっそくDL＆インストール。何事もなかったかのように動きました。

投稿者: かぜぶろ 日時: 12:27 | パーマリンク

はてなブックマークでちらりと見かけたid:hidedenさんのこのエントリー。すでにプログラムな視点からはSawaさんが議論されていますが、斜めからの意見としてはCGI.pmを継承してまで漢字コードの変換をする必要性を考える事が必要かなと思う。

一般的なブラウザならば、ページのエンコーディングとPOST/GETのリクエスト文字列のエンコーディングは同じ（ハズ）です。Perlでプログラムを作るのであれば、EUC-JPまたは最近であればUTF-8でコーディングしていると思います。プログラムからの出力も同じエンコーディングで行えばまったく問題ありません。わざわざJcodeを挟み込んだりすると漢字コードの判断ミスがおきて逆に文字化けしてしまうこともあるでしょう。

しかし、一般的なブラウザではない携帯電話の場合、ページのエンコーディングはShift_JIS、サーバサイドの文字コードはEUCなどとするのが通常の流れだと思います。その時は仕方がないので「現在のエンコーディングを指定」しつつ変換するのが良いでしょう。フレームワークを使うのも手です。

例によってCGI::Applicationならば、

package MyApp;

use strict;
use base qw(CGI::Application);
use Jcode;

sub cgiapp_init{
    my $self = shift;
    $self->header_props(-charset=>'Shift_JIS');
}

sub cgiapp_prerun{
    my $self = shift;
    #Sledge::Charset::Shift_JISを参考
    for my $p ($self->query->param) {
        my @v = map { Jcode->new($_, 'sjis')->h2z->euc } $self->query->param($p);
        $self->query->param($p,@v);
    }
}

sub cgiapp_postrun{
    my $self = shift;
    my $bodyref = shift;
    $$bodyref = Jcode->new($$bodyref,'euc')->sjis;
}
1;

動作確認はしていませんが、こんな感じでしょうか。

携帯電話ならJcodeよりUnicode::Japaneseの方が魅力的なメソッドが並んでおります。

投稿者: かぜぶろ 日時: 19:59 | パーマリンク | コメント (1) | トラックバック (3)

CatalystやSledgeというrichなFrameworkの話題が多いですが、シンプルなCGI::Applicationもまだまだ弄りがいありますよ。と前置き。

以前、CGI::Applicationでpost_dispatchで書いたCGI::Application::Plugin::Dispatchはすでに仕事でもデモでも使ってますが、1つ弱点があります。それはAUTOLOADを使っているのでAUTOLOADが使えない事です。なのでCaropyでは使用できませんでした。

そこでid:tociyukiさんのCatalyst解体やCGI::Application::Plugin::AutoRunmodeを参考に書き直してみた。

package CGI::Application::Plugin::AutoDispatch;

use strict;
use warnings;
use base qw(Exporter);
our $VERSION = '0.01';

sub import{
    my $caller = scalar(caller);
    $caller->add_callback('prerun', \&_prerun_autodispatch);
    goto &Exporter::import;
}

sub _prerun_autodispatch{
    my $self = shift;
    my $pkg = ref($self);

    my %post_actions;
    my %actions;
    
    no strict 'refs';
    foreach my $sym ( values  %{$pkg . '::'} ){
        if (*{$sym}{CODE}){
            my $name = *{$sym}{NAME};
            if($name =~ /^post_dispatch_([a-z0-9]+)$/){
                $post_actions{$1} = $name;
            }elsif($name =~ /^dispatch_([a-z0-9]+)$/){
                $actions{$1} = $name;
            }
        }
    }
    use strict 'refs';
    
    if(lc($self->query->request_method) eq 'post'){
    	%actions = (%actions,%post_actions);
    }
    %actions = (%actions,$self->run_modes);
    $self->run_modes(%actions);
}

1;

使い方は、

package MyApp;
use strict;
use base qw(CGI::Application);
use CGI::Application::Plugin::AutoDispatch;
sub setup{
    my $self = shift;
    $self->start_mode('foo');
}
sub dispatch_foo{
}
sub dispatch_bar{
}
1;

dispatch_[a-z0-9]+、またはpost_dispatch_[a-z0-9]+の形でメソッドを定義しておくと、run_modesを書かなくても、prerunで

foo=>dispatch_foo,
bar=>dispatch_bar

を設定します。run_modesを書くとそちらが優先されます。

ちなみにCatalystの最新5.51ではDispatcherが大きく書き変わって上のような方法をとっていないようにみえる。Catalystはソースが難しい。

投稿者: かぜぶろ 日時: 17:16 | パーマリンク

Googleが始めたアクセス解析「Google Analytics」をさっそく導入してみた。

月間アクセスが500万ページビューまでは無料で解析できるほか、アドワーズ広告のアカウントを取得していれば無制限で利用可能だ。

（ITmediaから引用）解析の機能もあわせて通常の個人利用にはハイスペック過ぎです。

このページのソースをみればすぐにわかるけど、

<script src="https://www.google-analytics.com/urchin.js" type="text/javascript">
</script>
<script type="text/javascript">
_uacct = "XX-XXXX-X";
urchinTracker();
</script>

というコードをHTMLに追加することでアクセスを集計するみたいです。
コードを貼り付けてから１２時間ぐらいで最初のアクセス統計がみれるらしいので待つのみ。

投稿者: かぜぶろ 日時: 14:19 | パーマリンク | トラックバック (3)

CGI::ApplicationでもCatalyst風にStashエントリーのはてなブックマークでハテナオヤさんに

TT Plugin と組み合わせて stash->{template} にテンプレートをセットして出力されるようにしてもいいかもですね。

とのコメントもらったので反応。

たぶん、CGI::Application::Plugin::TTのTEMPLATE_NAME_GENERATORでできる。

sub setup{
    my $self = shift;
    $self->tt_config(
        TEMPLATE_NAME_GENERATOR=>sub{shift->stash->{template} || ""}
    );
}
sub do_index{
    my $self = shift;
    $self->stash->{template}="index.tt";
    $self->tt_process();#空でOK
}

よりCatalystからのコピペが楽になる。
ただ「tt_process」の呼び出しがあるのでそれほど変わりがないと思われますがいかがでしょう。

投稿者: かぜぶろ 日時: 23:16 | パーマリンク

CGI::ApplicationでもCatalyst風にStashで書いた、CGI::Application::Plugin::StashをCPANにアップしました。エントリー時からはまったくコード自体は変わってないです。

これが初CPANアップです。PAUSEでアップロードをして、実際CPAN Searchで出てくるまで1時間ぐらいドキドキしましたが無事表示されてよかった。小さなモジュールではありますがCPAN Authorになることができました。正直ちょっとうれしいです。けど、これに満足せず一歩一歩精進していきたいと思います。

これからの課題

• 技術の向上
• 英語。今回はほとんどコピペ
• 役に立つモジュールとその英語の説明

英語はネック。（じゃぁ日本語で書けと言われてうまく書けるかも自信ないorz）

まずはCGI::Application::Dispatch::BuildURIの作者の金子さんが書いている

つたなくて、語彙が乏しくても、自分で英文を考えて組み立てられるようにトレーニングしたほうが良いと思ったし、やっていくうちに英文を書くことじたいが面白くなってきたからです。

これを目指そうと思います。

投稿者: かぜぶろ 日時: 00:31 | パーマリンク

11月08日のはてな技術勉強会をみた。
内容はid:jkodoさんのPerlのattributesの発表。活用例がそんなに思いつかないですが勉強になります。

attributesの活用例として、

• Catalyst
• mod_perl 2.0
• miyagawaさんのAttribute::Protected

あたりがあげられてます。

フレームワークでの活用例としては、CGI::ApplicationでもCGI::Application::Plugin::AutoRunmodeとして実装がされていたりします。

package MyApp;
use base 'CGI::Application';
use CGI::Application::Plugin::AutoRunmode;
sub do_index : StartRunmode {
                # do something here
}
sub do_foo : Runmode {

}
1;

う〜む。あまりうれしくないような気もする。
Catalyst風にRegexpとかPathとか書けたら便利(使い道がある)？

投稿者: かぜぶろ 日時: 20:47 | パーマリンク

ActionScriptでJSONみたいな事ができたらいいのに、できません。

FlashのActionScriptでも、Objectは、

var my_obj:Object={
     foo:'bar',
     aaa:'bbb'
}
trace(my_obj.foo);

のように書けたりします。

そこで、Ajaxで受信テキストをeval()で囲みJSON化(?)するように、

var my_str:String="{foo:'bar',aaa:'bbb'}";
var my_obj:Object=eval(my_str);
trace(my_obj.foo);

とやってみたけど、undefinedが出力されるだけでした。

残念。

XMLめんどくさいんだもんなぁ。

投稿者: かぜぶろ 日時: 20:59 | パーマリンク | コメント (4)

毎晩VACUUM を行っているのだが、PostgreSQLの速度が極端に低下したことがあって、VACUUM FULLを行ったところ復旧した事がありました。それ以降、「定期的にサービスを停止してVACUUM FULLを行う」ということを話しているのを聞くんだけど実際のところどうなのか調べた。

間違っている事があれば指摘してください。

長いけどドキュメントから引用。

標準形式の VACUUM は、ディスク容量を安定状態の使用量のレベルで維持することを目的に最もよく使用されます。標準形式では、古いタプルを探し、その領域をそのテーブル内で再利用できるように変更します。 しかし、テーブルファイルを縮小させ、オペレーティングシステムにディスク容量を返却するといった難しいことは行ないません。ディスク容量をオペレーティングシステムに返却する必要がある場合は、VACUUM FULL コマンドを使用して下さい。 しかし、すぐに再度割り当てる必要があるディスク容量をリリースするポイントは何でしょうか?更新頻度の激しいテーブルの保守においては、不定期の VACUUM FULL よりも適切な頻度で標準の VACUUM の方がよりよい方法です。

適切な頻度で標準の VACUUM の方がよいとあって、次の段落でも

定常的なバキューム処理には、VACUUM FULL ではなく、普通の VACUUM を使用して下さい。

とある。

つまり、「VACUUM FULL」は通常やることではないと。いつ必要なのかと言えば、ディスク容量が増えすぎてしまったときと考えればいいのかな。自信ないけど。

そうであるならば、「ディスク容量」を監視すればいいと思う。増加のラインを見極めることができたら良いかな。ディスク容量の監視は、

du -sm /var/lib/pgsql/|perl -e '<>=~/^(\d+)/;print $1'

こんなようなコマンドで、SNMPとかを活用してグラフ化していったら良いと思われ。
毎日VACUUMをやっていれば極端に増え続けることがないだろうけど、、、。

これとは別に「ANALYZE」も実行すべきでしょうか？

投稿者: かぜぶろ 日時: 19:20 | パーマリンク

CGI::AppでTropyを作る過程で思いついたプラグイン。
CGI::AppでもCatalystでも同じ感じでアプリが組めたら便利かなと思う。

package CGI::Application::Plugin::Stash;

use strict;
use warnings;
use vars qw($VERSION @EXPORT);
require Exporter;

@EXPORT = qw(stash);
$VERSION = '0.01';

sub import { goto &Exporter::import }

sub stash{
    my $self = shift;
    
    # First use?  Create new __PARAMS!
    $self->{__PARAMS} = {} unless (exists($self->{__PARAMS}));
    
    if (@_) {
        my $stash = @_ > 1 ? {@_} : $_[0];
        while ( my ( $key, $val ) = each %$stash ) {
            $self->{__PARAMS}->{$key} = $val;
        }
    }
    
    return $self->{__PARAMS};
}

1;

このコードはまだ試していないんだけど、

$self->param('foo','yada');
$self->stash->{foo} = 'yada';

の結果は同じハズ。

あとでCaropyに組込んでみよう。

CGI::Application::Plugin::FormValidator::SimpleもCatalystと同じように使えていい感じです。
Ver. 0.01で気になったvalidatorのSkipについて作者のmiyashita氏にお願いしたところすぐに対応していただきました。さらに便利になりました。ありがとうございます。

追記。
Caropyにつかってみた。
テンプレート中で、

[% c.param('entry').title | html %]

ではなく、

[% c.stash.entry.title | html %]

と書ける。微妙にいい感じ。

追記。
CPANにアップしました。

投稿者: かぜぶろ 日時: 10:54 | パーマリンク

Tropyが面白い。しかも勉強用にちょうどいいサイズ。
クローンがいくつか既にあるけど、ハテナオヤさんがCatalystでつくったので、CGI::Applicationでもやってみた。

http://nomadscafe.jp/caropy/caropy.cgi
ネーミングセンスないけど、CGI::Application::TropyなのでCaropyとしてみた。

ソースはこちらから見れます。
依存するモジュールは以下です。

• CGI::Application::Plugin::TT
• CGI::Application::Plugin::FormValidator::Simple
• CGI::Application::Plugin::Redirect
• Class::DBI::Sweet

Primaryキーの生成にはData::UUIDを使用してます。Class::DBI::Sweetでは

__PACKAGE__->sequence('uuid');

とするだけで、B2D6F920-4E96-11DA-B910-F626E881DC08のようなIDを生成してくれます。
それとClass::DBI::mysqlの機能のretrieve_randomが欲しかったので、

__PACKAGE__->add_constructor(_retrieve_random => '1 ORDER BY RAND() LIMIT 1');
sub retrieve_random { shift->_retrieve_random->first }

これをコピーして使いました。

投稿者: かぜぶろ 日時: 16:44 | パーマリンク | トラックバック (2)

Shibuya.pm #6行ってきました。
内容は各所にまとめられているのですが、個人的には、

• haskellはすげぇ、haskellが使える人はすげぇ
• Catalystをメタフレームワークと俺フレームワークを

ってところでしょうか。

haskellは挑戦しようと思わないがどんなものなのか知りたくはなる。なんと言っても世界最強。ICFPにPerlで参加された澤さんにhaskellのキモさ語っていただいたがなかなかイメージが掴めないorz。道は遠い。

Catalystは加藤亮さんのプレゼンが非常に為になった。Catalystは「触媒」であってCPANモジュールをつなげるメタフレームワークだと、その上でアプリケーション作成における制約を自分で作っていくことが重要。その為のプラグインやHelperスクリプトの開発は非常に簡単。俺Controllerや俺scaffold、俺Helperスクリプトを作ると使い回すのが吉。

naoyaさんはいい人でした。また東京行きます。はてな勉強会参加させてください。

東京に行きたいと少し思うようになってきた。
少なくてもKRPにいては駄目だと。

投稿者: かぜぶろ 日時: 23:46 | パーマリンク

Time::Piece関連のことを連続して書いてますが、Time::Pieceを使う場合タイトルもインスパイアさせていただいたのみまくし日記の2003年の記事、Time::Piece の罠は目を通しておいた方がいいかもしれません。

試すと、

use Time::Piece;
my $time = time;
my @lt = localtime $time;
my $tp = Time::Piece->strptime(
	sprintf("%04d-%02d-%02d %02d:%02d:%02d",$lt[5]+1900,$lt[4]+1,@lt[3,2,1,0]),
	"%Y-%m-%d %T"
);
print $time,"\n";#A
print $tp->epoch,"\n";#B

BがAより32400秒速くなります
epochの値はgtimeな値で、9時間分大きな数字です。

DateTimeも便利そう。ただCPAN一発でインストールされるんだけど、依存が多いのはちょっと×

投稿者: かぜぶろ 日時: 00:47 | パーマリンク