perl-mongers.org

日本の Perl ユーザのためのお役立ちサイト

By perl-mongers.org on

みんなで Perl を楽しく使えたらいいね！という目的のもと、perl-mongers.org をはじめます。

perl-mongers.org では、OpenID を持ってる人ならサインインするだけでスグに書けちゃいます。

Perl について書いてみたいことがあるヒトは、まずはこのフォームから今すぐサインイン！（詳細）

ブログ書いて Perl を盛り上げていこう！

（注意：perl-mongers.org の記事は全て Cc-By ライセンスとして公開されます。）

Getopt::Chainでgitライクなsubcommandを処理する

By http://www.hatena.ne.jp/dann/ on | 0 Comments | 0 TrackBacks |

Yokohama.pmでxcezxさんがMonday Moduleのtech talkをされていたので、早速書いてみました。

http://d.hatena.ne.jp/xcezx/

今回紹介するのは、gitのようなsubcommandのoptionを処理してくれるモジュールです。

gitだと、例えば以下のようにcommitサブコマンドにオプションを渡します。このオプションなどをパースしてくれて、簡単に取得できるようにしてくれます。

git.pl init --quiete

git.pl commit -a -m 'Hello'

commands以下にsubcommandの記述を書くと、そのsubcommandのcontextで引数の値などを取得する事ができます。例えば、commitサブコマンドのmオプションの値とかが簡単にとれるようになります。

#!/usr/bin/env perl
use strict;
use warnings;
use Getopt::Chain;
use Perl6::Say;

main();

sub main {
    setup_commands();
}

sub setup_commands {
    Getopt::Chain->process(
        options => [qw/ version /],
        run => sub {
            my $context   = shift;
            my @arguments = @_;
            say $context->local_option('version');
        },

        commands => {
            init => {
                options => [qw/ quiet|q template=s shared=s/],
                run     => ¥&init,
            },
            commit => {
                options => [qw/ auto|a message|m=s /],
                run     => ¥&commit,
            },
        }
    );
}

# sub commands
sub init {
    my $context   = shift;
    my @arguments = @_;

    if($context->local_option('quiet')) {
        say 'Only print error and warning messages.';
    }
    say $context->local_option('template');
}

sub commit {
    my $context   = shift;
    my @arguments = @_;
    say $context->local_option('message');
}

__END__

CatalystとConfig

By tomyhero [livedoor.com] on | 0 Comments | 0 TrackBacks |

こんにちはこんにちは！ tomyheroです！　トミヘロじゃなくて、とぅーまいひーろ　って読むんだよ！

今自分の中で流行ってる、CatalystとConfig周りの実装をこっそり晒そうと思うよ。　

aim

catalystアプリだけじゃなくて、外からでも使えるように実装したほうがいいとおもうんだよ！

MyApp::Config

Config::Multiをシングルトンで、どこでもつかえるようにするよ。　 MyApp::Utils　というので、設定ファイルのパスをとってますね！これについては、後で書くよ！

package MyApp::Config;

use strict;
use warnings;
use Config::Multi;
use MyApp::Utils;
use base 'Class::Singleton';

our $FILES ;
sub _new_instance {
    my $cm = Config::Multi->new(
        {
        dir => MyApp::Utils::path_to('conf')->stringify ,
        app_name    => 'myapp' ,
        extension   => 'yml'
    });
    my $config = $cm->load();
    $FILES = $cm->files;
    return $config;
}
sub files {
    return $FILES;
}

1;

MyApp::Utils

アプリケーションのUtilsモジュールだよ。Catalyst::Utilsだと、カタリスト依存しちゃうから、自分で作っちゃった方が良いと思うよ。 path_toとかのコードは、Catalystを参考にパクると良いと思うよ。

package MyApp::Utils;

use warnings;
use strict;
use Path::Class::Dir;
use Path::Class::File;
use FindBin;

sub home {
    return $ENV{MYAPP_HOME} ||  Path::Class::Dir->new(  $FindBin::Bin, './../' );
}

sub path_to {
    my ( @path ) = @_;
    my $path = Path::Class::Dir->new( &home , @path );
    warn $path;
    if ( -d $path ) { return $path }
    else { return Path::Class::File->new( &home, @path ) }
}

1;

MyApp::Plugin::Config

オレオレコンフィグプラグインを作るよ！

ぶっちゃけ、MyApp::Config　を $c->config にぶっ込んでるだけだよ。

package MyApp::Plugin::Config;

use strict;
use warnings;
use MyApp::Config;
use NEXT;

our $VERSION ='0.02';

sub setup {
    my $c = shift;
    my $config = MyApp::Config->instance();

    if( $c->debug ) {
        my $files = MyApp::Config->files();
        for my $file ( @{$files} ) {
            $c->log->debug( 'Load Config ' . $file );
        }
    }

    $c->config( $config ) ;
    $c->NEXT::setup( @_ );
}

1;

MyApp::Web

カタリストアプリだよ。プラグイン読み込むよ。

package MyApp::Web;

use strict;
use warnings;
use Catalyst::Runtime '5.70';
use Catalyst qw/+MyApp::Plugin::Config/;
our $VERSION = '0.01';
__PACKAGE__->setup;

1;

conf/myapp_web.yml

設定ファイルだよ。

---
name: Config Sample

MyApp::Web::Controller::Root

コンフィグデータが、ちゃんととれてるか表示するよ！

package MyApp::Web::Controller::Root;

use strict;
use warnings;
use base 'Catalyst::Controller';

__PACKAGE__->config->{namespace} = '';

sub default : Private {
    my ( $self, $c ) = @_;
    $c->response->body(  $c->config->{name} );
}

sub end : ActionClass('RenderView') {}

1;

たぶんみえてるんじゃないかな！

おわり

以上だよ。　

ちなみに、 MyApp::Config はどこからでも呼べるから、ガンガン呼ぶと良いと思うよ。多い日も安心だね！

:wq!

HTTP::Asyncで速度アップ

By tomyhero [livedoor.com] on | 0 Comments | 0 TrackBacks |

こんにちは！ tomyhero です！

一つのリクエスト内で、複数のAPIを叩いたり、フィードを読み込んだりすると重くなって行きますよね！　たとえば、複数のアフィリエイト広告APIを叩くときとか！

そういうときは、HTTP::Async を使うと良いと思います！

リクエストの結果を待たないで、次のリクエストを投げてくれます！で、後で回収をおこなうことができます。

サンプルコード

#!/usr/bin/perl 

use HTTP::Async;
use HTTP::Request;
use LWP::UserAgent;
use Data::Dumper;
use Perl6::Say;
use Time::HiRes qw/gettimeofday tv_interval/ ;

# 適当なurl.本来なら別ドメインのサイトが良いと思う。攻撃ぽくなるので。
our @urls = (
    'http://clip.livedoor.com/rss/recent',
    'http://clip.livedoor.com/rss/hot',
    'http://clip.livedoor.com/rss/popular',
);


&normal();
&async();

sub async {
     my $t0 = [gettimeofday];
    my $async = HTTP::Async->new;

    for my $url (@urls) {
        $async->add( HTTP::Request->new( GET => $url ) );
    }

    my @results = ();
    while ( my ( $response, $id ) = $async->wait_for_next_response ) {
        push @results, +{ id => $id, content => $response->content };
    }

    @results = sort { $a->{"id"} cmp $b->{"id"} } @results;

    my $elapsed = tv_interval ( $t0, [gettimeofday]);
    say 'async :'  . $elapsed;
    #warn Dumper \@results;
}

sub normal {
     my $t0 = [gettimeofday];
    my @results = ();
    for my $url (@urls) {
        my $ua = LWP::UserAgent->new;
        my $response = $ua->get('http://search.cpan.org/');
        push @results , $response->content;
    }

    my $elapsed = tv_interval ( $t0, [gettimeofday]);
    say 'normal:' . $elapsed;
#    warn Dumper \@results;
}

結果

ネットワークをかいしてるので、正確ではないですが、目安にはなります。

normal:1.315056
async :0.368374

add_with_opts()　モジュールを使うと、proxyや、timeoutの設定ができたりしますよ。

最後に

早いサイトって良いですよね！　

試してませんが、ParallelUserAgentもいいのかも！　場合によってはforkでもいいのかも！

:wq!

PHP使いによるCatalyst初心者記事

By mumumu.myopenid.com on | 0 Comments | 0 TrackBacks |

mumumu です。普段 PHPを使ってWebアプリケーションを書いたり、C, C++ を書いたりしています。

今回 Atompub サーバを書くことになり、一番まともな実装(Catalyst::Controller::Atompub) がある Perl を使うことにしました。

Catalyst::Controller::Atompub を使うからには当然 Catalyst を使うことになるわけですが、2年振りにPerlを書いたことと、フレームワークの流儀も全く解っていなかったことから結構ハマりました。以下では、それを脈絡なく書いていこうと思います。普段PHP使いだからって石を投げないでくだしあ( ;´Д⊂ヽ

Catalystを学ぶにあたって

「perl Catalyst」でぐぐったところ、まとまった記事がすぐに出てこなかったことから、私は Catalyst::Manual::Tutorial を順に読んでいろいろ試していきましたが、後で調べたらはじめてのCatalyst というマニュアルの翻訳を見つけました。MVCフレームワークに触れたことがある人には、凄くいい資料ではないでしょうか。Catalystクックブックも素晴らしいです。

以下では、こうして学びながら特に引っ掛かった点をピックアップして書いていきます。

Catalystのインストール

環境は Debian GNU/Linux etch を使いました。これには、既にパッケージとして libcatalyst-perl (5.7.006)等が用意されていますが、lazy-people.org の tomyheroさんから

(tomyhero) install Task::Catalyst
(tomyhero) install HTML::Parser
(tomyhero) install Template
(tomyhero) install Encode
(tomyhero) この辺ふるいのはいってると、文字コード周りでgdgdになる。
(tomyhero) FYI

という有難い情報があったので、CPAN から直接インストール(執筆時点での最新版は 5.7014) することにしました。256MBしか割り当てていないバーチャルマシン上での作業なので予想はしてたんですが、上の Task::Catalyst, HTML::Parser, Template, Encode を最新にするのに1時間掛かりました。依存関係でいろいろ聞かれたりしますが、「y」で通して（たぶん）大丈夫です。個人的には XML::LibXML が XML::LibXML::Common を先にインストールしてくれなくてエラーになったりしましたが、もう一度 XML::LibXML::Common -> XML::LibXML の順でインストールし直すと大丈夫でした。

最後に、肝心の Catalyst::Controller::Atompub のインストールです。これに30分。

これは滞りなくいきました。CPANから多数のモジュールをインストールするとなると、非常に時間が掛かるものですが、「y」を押しながら気長に他のことをしましょう。

# perl -MCPAN -e shell
cpan> install Catalyst::Runtime Catalyst::Plugin::ConfigLoader Catalyst::Plugin::Static::Simple Catalyst::Model::DBIC::Schema DBIx::Class::Schema::Loader DBD::SQLite Catalyst::View::TT Catalyst::Controller::Atompub Catalyst::Action::RenderView

インストールが終わったら、プロジェクトを作りましょう。今回は説明のため、Sample というプロジェクトにします。

$ catalyst.pl Sample
(....ディレクトリ構造とか最低限の雛形とかいろんなものが生成される)
$ cd Sample/

プロジェクトを作ったあとは、一応動作確認しておきます。Catalyst には、開発用のWebサーバが用意されています。以下のようにして起動します。

$ script/sample_server.pl
.....  Sampleプロジェクトの情報がずらずらと表示
[info] sample1 powered by Catalyst 5.7014
You can connect to your server at http://example.com:3000

無事起動したら、http://example.com:3000 にブラウザからアクセスしてみましょう。

以下のような画面にアクセスできるはずです。この開発用サーバ起動の操作は何度も使うことになります。

URLルーティング

Webアプリケーションフレームワークを実際に使うにあたって、私がまず関心を持つのはURLルーティング、すなわち「特定のURLに対応した処理をどこに書くか」ということです。Catalystにはこの点で多彩なやり方が用意されており、多少混乱しました。

Catalyst ではコントローラーにURLに対応した処理をサブルーチン(関数)として記述します。まずは適当にコントローラーを生成します。script/sample_create.pl が様々な雛形を自動で生成してくれるようになっていますので、それを利用します。

$ script/sample_create.pl controller hello
 exists "/home/mumumu/Sample/script/../lib/Sample/Controller"
 exists "/home/mumumu/Sample/script/../t"
 created "/home/mumumu/Sample/script/../lib/Sample/Controller/hello.pm"
 created "/home/mumumu/Sample/script/../t/controller_hello.t"

hello コントローラーが追加されました。lib/Sample/Controller/hello.pm を開き、podの部分を除いた(間違っても use strict, use warnings は除かないように！)部分は以下のようになっています。ここでは、sub index ... の部分に注目します。

(lib/Sample/Controller/hello.pm)

package Sample::Controller::hello;

use strict;
use warnings;
use parent 'Catalyst::Controller';

sub index :Path :Args(0) {
    my ( $self, $c ) = @_;

    #
    #    http://example.com/hello/ や http://example.com/hello へのリクエスト
    #    に対して、「Matched Sample::Controller::hello in hello.」を表示する。
    #
    $c->response->body('Matched Sample::Controller::hello in hello.');
}

1;

indexって何か意味あるの？それ以前に :Path とか :Args とか Perlの文法的にアリなの？と調べること2時間。:Path や :Args はアトリビュートと呼ばれる、属性を変更するハンドラを呼び出すためのおまじないみたいですが、ここは黒魔術だと思ってあまりキニシナイことにしました。とりあえず、「:ほげほげ」をサブルーチン名の後に書くことで、ルーティングのやり方を指定できるようです。このほげほげを Catalyst の世界ではアクションと呼ぶようです。

上の「index :Path :Args(0)」のアクション指定は、 Catalyst にビルトインされた特別なアクションで、http://example.com/hello/ や、http://example.com/hello のように、パッケージ名から、Controllerまでの部分を除いたもの(ここではhello) のあとに引数を何も与えなかった場合に呼び出されるアクションらしいです。

また、サブルーチンの引数について説明をしておくと、第1引数 $self は、Sample::Controller::hello オブジェクト(オブジェクト指向でいうところの this) です。第2引数に $c が指定されていますが、これは「コンテキストオブジェクト」というもので、ここからリクエストやレスポンスのオブジェクトはもちろん、データベース操作に使えるModelなど、Webアプリケーションにおける処理に必要な様々なオブジェクトを取り出すことができます。アクション指定をしたサブルーチンの引数には必ずこの $c がついている（はず）ですので、様々な操作が行えるはずです。

私が主に使ったアクションを「ちょっとだけ」以下に並べておきます。正直たくさんあって参りました。

ここでアクション指定をすべて説明はできないので、詳細はマニュアルにあるアクションの一覧を見るとよいと思います。私自身も未だによくわかってないアクションがかなりありますネ(´ー｀; )

package Sample::Controller::hello;
#
#  Path アクション
#  
#  Path の引数の先頭にスラッシュを入れないと、パッケージ名から Controller まで
#  を除いた部分(ここではhello) からの相対URLにマッチする。
#  以下の場合は http://example.com/hello/foo/bar や、
#  http://example.com/hello/foo/bar/baz などのリクエストに対して hoge が呼ば
#  れる。
#  
#  これに対して:Path('/foo/bar') として先頭にスラッシュを入れると、絶対指定となり、
#  http://example.com/foo/bar や、http://example.com/foo/bar/baz などが呼ばれたと
# きに hoge が呼ばれる
#
sub hoge :Path('foo/bar') {
    # ....
}

#
#  Regex アクション
#  
#  パッケージ名に関係なく、マッチするURLを正規表現で指定する
#  以下の場合は、http://example.com/foo/hoge としたときは サブルーチンhoge
#  が呼ばれるが、http://example.com/hoge では呼ばれない
#
sub hoge :Regex('^(\w+?)/hoge') {
    # ....
}

package Sample::Controller::hello;
#
#  Local アクション
#  
#  URLが、必ずパッケージ名から、Controllerまでの部分を除いたもの
#  (ここではhello) で始まり、あとにサブルーチン名が続いたものにマッチすること
#  を指定する。
#
#  以下の場合は、http://example.com/hello/hoge/foo や 
#  http://example.com/hello/hoge としたときに、サブルーチンhoge
#  が呼ばれるが、http://example.com/hoge では呼ばれない
#
sub hoge :Local {
    # ....
}

#
#  default アクション
#
#  どのアクションにもURLがマッチしない場合に呼ばれる。404ページやエラーページ
#  の作成に便利
#
sub default :Private {
    # ....
}

データベース操作

さて、アクション指定をしたサブルーチン内では、マッチしたURLに対して様々な操作ができることがわかりました。URLルーティングに続いて、私が次に関心を持つのは、Webアプリケーションに欠かせないデータベースの操作です。Catalyst ではどうしたらいいのでしょうか？

以下、順を追って説明したいと思います。なお、私は今回 sqlite3 を使いました。

まずはデータベースの構造（スキーマ）です。本当は Atompub 用のスキーマを書きたいのですが、そこは割愛して、説明のための簡単なスキーマを作ります。

$ cd Sample
$ sqlite3 sample.db
SQLite version 3.5.9
Enter ".help" for instructions
sqlite> CREATE TABLE sample (
     ...>   id            INTEGER PRIMARY KEY,
     ...>   sample_text        TEXT
     ...>);
sqlite>

次にデータベースにアクセスするための Model クラスを作ります。Perl では、ORM(Object Relational Mapping) という、DBアクセスを楽にプログラムから行うためのモジュールとして、DBICというものがあります。ここではそれを利用するように指定してクラスを生成します。コントローラーを作ったときと同じく、script/sample_create.pl を使います。

script/sample_create.pl への引数として、いろいろごちゃごちゃと指定していますが、順番に以下の表の通りです。

model	作成対象（model or view or controller)
DB	作成するクラス名（ちゃんと書くとSample::Model::DB）
DBIC::Schema	スーパークラス名（Catalyst::Model::DBIC::Schema）
Sample::Schema	スキーマ情報のクラス名
dbi:SQLite:dbname=sample.db	接続情報

 $ script/sample_create.pl model DB DBIC::Schema Sample::Schema create=static dbi:SQLite:sample.db 
 exists "/home/mumumu/Sample/script/../lib/Sample/Model"
 exists "/home/mumumu/Sample/script/../t"
Dumping manual schema for Sample::Schema to directory /home/mumumu/Sample/script/../lib ...
Schema dump completed.
created "/home/mumumu/Sample/script/../lib/Sample/Model/DB.pm"
created "/home/mumumu/Sample/script/../t/model_DB.t"

いろいろと生成されたようです。具体的には、lib/Sample/Schema/Sample.pm に、テーブルの定義がdumpされてクラスが自動生成されているのがわかると思います。また、lib/Sample/Schema.pm には、スキーマをロードするクラス、そしてlib/Sample/Model/DB.pm には、DBの接続設定が書かれているようです。皆さんの目で確認してみて下さい。

これらを使って、Perlプログラムからレコードを挿入してみます。URLルーティングのところで説明した、hello コントローラーを以下のように書き換えてみます。

(lib/Sample/Controller/hello.pm)

package Sample::Controller::hello;

use strict;
use warnings;
use parent 'Catalyst::Controller';

sub index :Path :Args(0) {
    my ( $self, $c ) = @_;

    #    自動生成した sample スキーマクラスを使って sample_text カラムに
    #    挿入する 
    $c->model('DB::sample')->update_or_create({
        sample_text => 'im catalyst newbie. testing hello!',
    });

    #
    #    http://example.com/hello/ や http://example.com/hello へのリクエスト
    #    に対して、「Matched Sample::Controller::hello in hello.」を表示する。
    #
    $c->response->body('Matched Sample::Controller::hello in hello.');
}

1;

自動生成したクラスは、「$c->model('スキーマ名')->DBアクセスのメソッド」のようにして使います。上記の例では DB::sample がスキーマ名で、 DBアクセスのメソッドとして update_or_create を使っています。とりあえずこの使い方は「おまじない」のようなもの、としておきましょう。

しかし、「DBアクセスのメソッド」は他にもたくさんあるはずです。SELECT や DELETE, UPDATE とか、、それらの詳細については、DBIX::Class::Manual 等を参考にしてみてください。

書き換えたあと、プロジェクトを作り、動作確認したときの要領で開発用サーバを起動し、http://example.com:3000/hello にアクセスしてみましょう。相も変わらず「Matched Sample::Controller::hello in hello.」と表示されるだけですが、データベースの中身は変わっています。ちょっと確かめてみましょう。

$ sqlite3 sample.db
SQLite version 3.5.9
Enter ".help" for instructions
sqlite> select * from sample;
1|im catalyst newbie. testing hello!  <- 挿入されたレコード！
sqlite>

1番のidで、im catalyst newbie. testing hello!　と挿入されているのがわかると思います。これは lib/Sample/Controller/hello.pm の indexアクションに書いたものです。

sqliteに関する注意点

sqlite は単一ファイルにデータベースの情報を格納します。よって、Webサーバ経由でPerlからアクセスする場合は、sqliteコマンドで作ったファイル(ここではsample.db) がWebサーバの権限で読み書きできなければいけません。「Unable to Open Database!」のようなエラーが出る場合は、この点を真っ先に疑うようにしましょう。

また、こうした問題は往々にして sample_server.pl を使った開発サーバにおいてよりも、Apache + mod_perl のような、デプロイ後の環境で往々にして起こりがちです。パーミッションとdbファイルのパスはきちんと確認しておくようにしましょう。

Catalyst と sqlite は面倒な関係にあるようです。lazy-people.org の tomyhero氏は以下のようにIRCで叫んでいました。

 (tomyhero) sqliteで十分ではなくて、sqliteのほうが
 (tomyhero) めんどうなんだお！
 (tomyhero) myssqlとかつかったほうがいいお

その他びっくりしたこと、小さな疑問等（ひとりごと的に）

DBIC と DBIx::Class って同じものかどうか未だに区別がつかない
入力の validate はどこに書けばいいの？と思ったら、validateのフローはばっさりカットされているようだ。型にハマったLazyな方法ないかしら
設定ファイルは 2方式あるらしく、Catalyst::Manual::Tutorial では、Apacheの設定ファイルライクな方式が使われていた。どっちがいいんだろうねーと思いつつ、結局慣れ親しんだyamlに走った
デプロイしてみて、動かすのにこれだけ苦労したのは久しぶりかも。SSLを絡めたらとたんにfastCGIで動かなくなったりとかあったけど、最終的には Apache + mod_perl2 に落ち着いた

とりあえずのおわり

あれ、View はどうしたの？とか、Atompubの記述が全く出てこないぢゃないかとか、いろいろツッコミどころはあるとは思いますが、長くなってきたので今回はこの辺で。。ということで(´ー｀; ) View 以外にも Basic 認証についても結構ひっかかったりしたので、それについても機会があったら書きたいと思います。

最後に、lazy-people.org の皆さんには多くの助言を頂きました。この場を借りて御礼申し上げます。

WWW::Mechanize::Plugin::Web::Scraperでスクレイピングをもっと簡単に

By mattn on | 0 Comments | 0 TrackBacks |

スクレイピングして何すんだと言われましても、スクレイピングがしたくてしょうがないmattnです。

今日、WWW::Mechanize::Plugin::Web::Scraperというcpanモジュールを(otsuneさんのブクマ経由で)見つけました。モジュール名の通り、WWW::MechanizeからWeb::Scraperするプラグインです。

先日書いた「何時でも何処でも携帯で「はてなスター」チェック」では、両方使ってagentを切り替えたりしてましたが、これを使うともっとスマートに書けるようになります。今日は小ネタでソースだけ。

use strict;
use warnings;
use WWW::Mechanize::Pluggable;
use YAML::Syck;

my $username = 'xxxxx';
my $password = 'xxxxx';

my $mech = WWW::Mechanize::Pluggable->new();
$mech->get('http://www.hatena.ne.jp/login?location=http://s.hatena.ne.jp/');
$mech->submit_form(
    form_number => 1,
    fields => {
        name     => $username,
        password => $password,
    }
);
$mech->get("http://s.hatena.ne.jp/$username/report");
my $stars = $mech->scrape('span.entry-title a', 'stars[]',
    { title => 'TEXT', link => '@href' }
);
warn Dump $stars;

いい感じにキレイですね。

CGI.pmのファイルアップローダ

By CL on | 0 Comments | 0 TrackBacks |

今日は、Perlで作るファイルアップローダの基本ルーチンを書いてみようと思います。

最初に某業界のインターネットによるファイル送信の歴史を、僕の主観で書いてみます。関係ないようで、実は関係あるんです。

データ通信入稿の歴史

専用線やISDN Managerなど、インフラにコストをかけないと遠隔地への通信入稿ができない前インターネット時代が終わり、インターネット時代になると、首都圏にある全国ユーザを対象にした印刷サービス業や地方の通販印刷業がまず行ったのはFTPサーバまたはAnonymousFTPサーバを立てデータ通信入稿に利用することだったが、これらはユーザにFTPクライアントを設定してもらう説明のコストが非常に高いという欠点があり、次なる手段として、どこかの業者がWebブラウザによるファイル送信を設置したところ他の業者も同様の仕組みを設置して今に至る。

Webのフォームからのアップロードによって、データ通信入稿がものすごく容易になったのです。

本題行きますね。

Perlでファイル送信

さて、Perlでファイル送信するスクリプトですが、CGI.pmというモジュールは今時標準モジュールなので、これを使うと簡単にできます。

テンポラリファイルが書き込まれるディレクトリの設定

CGI.pmのテンポラリファイルが書き込まれる場所が変更できないと思われている人も多いですけれども、実は変更可能。

僕のコードはこんな感じ。

# -------------------------------------------------
# _set_tempdirectory ( $tempdir ) 
# -------------------------------------------------
# CGI.pm の内部設定の、TMPDIRECTORY を引数に変更する。
# CGI.pm 初期化する前に設定する必要がある
# ていうか、ここら辺アンドキュメンテッドなんじゃねー
# ていうきもしなくもない。後で調べる。 
 
sub _set_tempdirectory{
   
  my $tempdir = shift;
 
  if ($TempFile::TMPDIRECTORY) {
    $TempFile::TMPDIRECTORY = $tempdir; 
  } 
  elsif($CGITempFile::TMPDIRECTORY) {
    $CGITempFile::TMPDIRECTORY = $tempdir;
  }
 
  return;
}

このルーチンを、use CGI; した後、かつ、my $q = CGI->new; する前に実行します。

これ何に役立つかっていうと、アップロードCGI呼び出しの引数によってアップロード先のURLを区別したいときに使います。つまり、アップロード中のステータス、たとえばファイル転送済みの容量表示をしたいときに。

ここで、CGI.pm をよく使っている人は、「my $q = CGI->new; する前なのに、どうやってアップロードCGI呼び出しの引数をとれるの？」って思うかもしれません。そう、おなじみの$q->param('foo')でとれないんです。

しかし、引数とるのに、CGI.pmを使う必要はありません。$ENV{'QUERY_STRING'}をパースしちゃいましょう！ Perl4時代に逆戻りですね！

テンポラリディレクトリにアップロードされたファイルの保存

この手のルーチン作例は、いっぱいWebにあがっているのですが、テンポラリディレクトリにあるファイルを、実際のファイルに保存するルーチンがみんなまちまちで、どれを使っていいか悩みます。

http://perldoc.jp/docs/modules/CGI.pm-2.89/CGI.podだと

   # バイナリ・ファイルをどこか安全なところへコピーします
    open (OUTFILE,">>/usr/local/web/users/feedback");
    while ($bytesread=read($filename,$buffer,1024)) {
       print OUTFILE $buffer;
    }

となっています。これスピード遅くね？

実際、最近の入稿データは余裕で1GBとかありますので、普通のやり方をしてたのでは、アップロード送信終了後の待ち時間がとても長くなりがちです。

とりあえず、僕は、File::Copyモジュールのmoveを使ってみました。これだったら、テンポラリディレクトリと、保存ディレクトリが同じファイルシステム上にあるのならば、一瞬で保存が終わってくれます。

ここで、CGI.pm をよく使っている人は、「moveって、たしか引数としてtarget pathとdestination pathの2つが必要で、ファイルハンドルだと駄目だったよね？」って思うかもしれません。そう、$q->upload('foo')をそのまま使えません。

でも、ちゃんと考えてあって、$q->tmpFileName( $q->upload('foo') )なんてすると、テンポラリファイルのパスが得られちゃうんです。これは便利。

実際には以下のようになります。

use CGI;
use File::Copy;
use File::Basename;

my $upload_dir  = 'upload';      # 保存先のディレクトリ
 
my $q  = CGI->new();             # CGIオブジェクト
my $fh = $q->upload('filename'); # ファイルハンドル兼ファイル名
my $temp_path = $q->tmpFileName($fh); # アップロードされた
                                      #ファイルのフルパス
fileparse_set_fstype('MSDOS');   # WinIE用パス文字設定
my $filename    = basename($fh); # アップロードされたファイルの
                                 # ファイル名
my $upload_path
  = "$upload_dir/$filename";     # 保存先フルパス
 
move ($temp_path, $upload_path)  # File::Copy の moveメソッドで
  or die $!;                     # 移動
close($fh);                      # おまじない

続きを読む以降では、僕が持っている実際のアップロードルーチンのソースが書いてあります。

Continue reading CGI.pmのファイルアップローダ.

何時でも何処でも携帯で「はてなスター」チェック

By mattn on | 3 Comments | 0 TrackBacks |

追記

コメント欄でotsuneさんにご指摘頂きました。scraperのprocess部、LWPの初期化をループ内で行わないようにしました。

やっぱり書いた記事にはてなスターが付くと嬉しいものですよね。出先でちょっとした間にはてなスターが付いているのを見て、ニタニタしたい人もいるかと思います。

でもはてなスターにはモバイルページがありません。しかもスターレポートページを閲覧するにはログインが必要になります。さて今日はモバイル端末から閲覧出来るエゴツール「モバイルはてなスターページ」を作って見たいと思います。

まずスターレポートページを見る為に、WWW::Mechanizeを使ってログインします。ログインページは

http://www.hatena.ne.jp/login?location=http://s.hatena.ne.jp/

となります。セキュリティを考慮されたいならばhttpsにされるのが良いかと思います。以下WWW::Mechanizeでログインする処理になります。

my $username = 'xxxxxxxx';
my $password = 'xxxxxxxx';

my $mech = WWW::Mechanize->new(timeout => 10, agent=>'StarScraper');
$mech->get('http://www.hatena.ne.jp/login?location=http://s.hatena.ne.jp/');
$mech->add_header('Accept-Encoding', 'identity');
my $res = $mech->submit_form(
    form_number => 1,
    fields => {
        name     => $username,
        password => $password,
    }
);

ログイン後の処理はWeb::Scraperでのスクレイピングになります。レシピは以下の通り

my $star_list = scraper {
    process 'span.entry-title',
        'stars[]' => scraper {
            process 'a', title => 'TEXT', link => '@href';
        };
    result 'stars';
};

そして上記mechをWeb::Scraperのuaに設定し、スクレイピングを実行します。

$star_list->user_agent( $mech );

my $u = "http://s.hatena.ne.jp/$username/report";
my $stars = $star_list->scrape( URI->new($u) );

さて、これだけではスターが付けられたURLの一覧しか取得出来ません。そこで、はてなスターAPIを使ってスターのエントリを取得します。はてなスターAPIのエントリ取得URLは以下の通り。

http://s.hatena.ne.jp/entries.json?uri=[URL]

このAPIに上記でスクレイピングしたURLを渡します。

my $ua = LWP::UserAgent->new;
for my $star (@$stars) {
    my $uri = 'http://s.hatena.ne.jp/entries.json?uri=' . URI::Escape::uri_escape($star->{link});
    my $req = HTTP::Request->new(GET => $uri);
    my $res = $ua->request($req);
    $res->is_success or return 0;
    my $json = from_json( $res->content );
    my @sts = @{$json->{entries}->[0]->{stars}};
}

ここで気をつける必要があるのですが、stsの要素はHASHの場合とスカラの場合があり、HASHにはスター情報が、スカラには"☆35☆"といった省略する数値が入っています。これに気をつけて以下の様に処理します。

    for my $st (@sts) {
        if (ref $st eq 'HASH') {
            print '<img src="http://s.hatena.ne.jp/images/star.gif" title="' . $st->{name} . '" />'
        } else {
            printf '<font color="#f4b128">%d</font>', $st;
        }
    }

全体のコードは以下の様になります。

#!/usr/bin/perl

use warnings;
use strict;
use URI;
use Web::Scraper;
use HTML::Entities;
use WWW::Mechanize;
use JSON;

my $username = 'xxxxxxxx';
my $password = 'xxxxxxxx';

my $mech = WWW::Mechanize->new(timeout => 10, agent=>'StarScraper');
$mech->get('http://www.hatena.ne.jp/login?location=http://s.hatena.ne.jp/');
$mech->add_header('Accept-Encoding', 'identity');
my $res = $mech->submit_form(
    form_number => 1,
    fields => {
        name     => $username,
        password => $password,
    }
);

my $star_list = scraper {
    process 'span.entry-title',
        'stars[]' => scraper {
            process 'a', title => 'TEXT', link => '@href';
        };
    result 'stars';
};
$star_list->user_agent( $mech );

print "Content-Type: text/html; charset=utf-8\n\n";
my $u = "http://s.hatena.ne.jp/$username/report";
my $stars = $star_list->scrape( URI->new($u) );
my $ua = LWP::UserAgent->new;
for my $star (@$stars) {
    printf "<a href=\"%s\">%s</a><br />&#x202C;\n", $star->{link}, encode_entities($star->{title});
    my $uri = 'http://s.hatena.ne.jp/entries.json?uri=' . URI::Escape::uri_escape($star->{link});
    my $req = HTTP::Request->new(GET => $uri);
    my $res = $ua->request($req);
    $res->is_success or return 0;
    my $json = from_json( $res->content );
    my @sts = @{$json->{entries}->[0]->{stars}};
    for my $st (@sts) {
        if (ref $st eq 'HASH') {
            print '<img src="http://s.hatena.ne.jp/images/star.gif" title="' . $st->{name} . '" />'
        } else {
            printf '<font color="#f4b128">%d</font>', $st;
        }
    }
    print "<br />\n";
}

携帯片手にニタニタしてみてはどうでしょうか。

strict プラグマについて

By vkgtaro on | 0 Comments | 0 TrackBacks |

友達が以前、日記で「use strict; って何でデフォルトでオンになってないの？」と言うことを書いていたのを見て、そういえばどうしてなんだろうと思ったのを思い出したので、書いてみる。（use すると strict プラグマが効くようになるモジュールとかはありますね。moose とか。そういう需要はあると言うことですよね）

perl を始めた方は、知り合いに勧められて始めた場合、「とにかく use strict; を宣言しておくといいよ」と言われて付けていたり、フリーで配布されてる掲示板スクリプトを改造していて、「use strict; した方が良いっぽい」と思ってやってみたらエラーの嵐でさんざんな目にあったりしてい(る|た)人も多いかと思います。後者は昔の僕ですが。

まぁ、use strict をするとなぜいいのかは tomyhero さんがすでに書いているので、そちらを参照してください。

「use strict; って何でデフォルトでオンになってないの？」

言われてみれば確かに。何でなんでしょうか？
よく Perl を使っていて、Perl の黒魔術的なところも知っている人なら、strict を無効化しないと出来ない処理があることは理解されてますよね。でも、そういうときは "no strict;" として局所的に strict プラグマを無効化出来ることも知っているはず。

デフォルトがオンで必要なところで no strict するのであれば、理にかなってるような気もしますよね。

ただ、ここまではスクリプトやモジュールを書くときの話で、ワンライナーのユーザがデフォルトで use strict オンだと面倒なのかなーとか想像してます。
いちいち my 書くの面倒だよねとか、そんな感じなのかなーとか考えてみたんだけど、どうなんでしょうか？あくまで僕の考えです。

誰か答えを知っていたら教えてください！

追記

tomyhero さんの記事に理由が書いてあったのを突っ込まれました >_<（"もう一つの使い方"ってところ）

感謝というのはいいですよね。なんか色んな人の意見聞いてみたい！

実用！画像でブックマーク数を返すSBMからブックマーク数を数値で取得

By CL on | 0 Comments | 0 TrackBacks |

こんにちは！この前会社のCentOS4のサーバをyumったらPerl5.8.5のパッケージが更新されてしまい、CPANから入れたEncodeモジュールがパッケージのでデグレードしてしまい、メール送信で使っていたencode('MIME-Header-ISO_2022_JP', $foo )が動かなくなって涙目になりました。

さて、前回実用！ Perlで少しでもSBMのブックマーク数を多く見せる - perl-mongers.orgでは、いろいろなソーシャルブックマークサービス（以下SBM）に用意されたWeb APIにアクセスし、ブックマーク数の合計をとるということをやりました。

今回は、SBMから得られる特定URLのブックマーク数が、イメージで得られるタイプの場合、どうやって数値として使えるか、というのをやってみます。本来想定された用途以外の使い方にチャレンジする、という意味では、Hackと言えると思います。

～～～

たとえば、FC2ブックマーク、画像としてブックマーク数を表示できるようになっています。

http://bookmark.fc2.com/image/users/http://perl-mongers.org/

で、

が得られます。

コンピュータが画像から文字を解読するのは大変

SBMから得られる画像に数字が書いてある場合、その画像から数字を認識させるのはかなり困難です。あらかじめ得られる画像データの特徴リストを持っておき、それと照合する、なんてことをすれば簡単になりますが、SBMサービス側の気まぐれで、「画像内の数字をかっこよくしよう」、なんてやられてしまった日には涙目です。

というわけで、画像を解析して数字を得るって言うのはあんまり現実的ではないです。

隠れたところにブックマーク数として採用できるデータが！

さて、画像を解析するのがボツになったので、じゃあどうやって、ブックマーク数の情報を取得するのか、という話なんですけれども、先ほどの

http://bookmark.fc2.com/image/users/http://perl-mongers.org/

にブラウザでアクセスすると、

ブラウザのアドレス欄が、"http://bookmark.fc2.com/icons/00002.png"とかになっていることに注目。つまり、画像表示のために、画像アイコンのURLにリダイレクトされているのです。

このURLの中に、なにやらブックマーク数として採用できそうな文字列が入っているので、これを利用します。

リダイレクト先のURLだけを取得

PerlでHTTPの通信をするときによく使われる、LWP::UserAgentを使います。リクエスト用URLをGETすると、ヘッダに、転送先のURLが入って帰ってくるので、それを正規表現で数字部分だけ取り出し、数値として取り扱います。

下の例では、画像として取得できるサービス一般で使えるようにしてみました。

各ソーシャルブックマークサービス（SBM）のブックマーク数画像表示APIを調べた ::: creazy photograph [creazy.net]

にて、各SBMにて、画像として取得するときのリクエスト用URLと、リダイレクト先のURLが書いてありますので、そのようにやってみます。なお、@niftyクリップと、POOKMARKはこっちで調査して付け加えました。

（2008-07-06 13:06訂正：スクリプトの名前をsmb_img_count.plからsbm_img_count.plに変更。livedoor用画像ファイル取得アドレスがYahoo!用のものになっていたのを訂正。また、動作がわかりやすいように、リダイレクト先のURLを表示するようにし、実行例も変更しました。http://b.hatena.ne.jp/kits/20080706#bookmark-9198443より指摘いただきました。）

Filename: sbm_img_count.pl

use strict;
use warnings;
use LWP::UserAgent;
 
our $sbms = { 
       hatena =>
       {
         proxy   => 'http://b.hatena.ne.jp/entry/image/',
         regexp  => '/(\d+)\.png',
       },
       livedoor =>
       {
         proxy   => 'http://image.clip.livedoor.com/counter/',
         regexp  => '/(\d+)$',
       },
       yahoo =>
       {
         proxy   => 'http://num.bookmarks.yahoo.co.jp/image/large/',
         regexp  => '/(\d+)$',
       },
       buzzurl =>
       {
         proxy   => 'http://api.buzzurl.jp/api/counter/v1/image?url=',
         regexp  => '/(\d+)\.gif',
       },
       fc2 =>
       {
         proxy   => 'http://bookmark.fc2.com/image/users/',
         regexp  => '/(\d+)\.png',
       },
       nifty =>
       {
         proxy   => 'http://api.clip.nifty.com/api/v1/image/counter/',
         regexp  => '/(\d+)\.png',
       },
       pookmark =>
       {
         proxy   => 'http://pookmark.jp/count/',
         regexp  => '/(\d+)$',
       },
};
 
my $url = 'http://perl-mongers.org/';
print 0
    + get_sbm( 'hatena'  , $url )
    + get_sbm( 'livedoor', $url )
    + get_sbm( 'yahoo'   , $url )
    + get_sbm( 'buzzurl' , $url )
    + get_sbm( 'fc2'     , $url )
    + get_sbm( 'nifty'   , $url )
    + get_sbm( 'pookmark', $url );
print "\n";
 
exit;
 
 
sub get_sbm {
  my $service = shift;
  my $url     = shift;
  return get_sbm_imageicon( $service, $url )
}
 
# ブックマーク件数イメージ提供サービスから件数取得
sub get_sbm_imageicon {
  my $servce = shift;
  my $url    = shift;
  our $sbms;
  my $ua = LWP::UserAgent->new();
  $ua->agent('Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)');
  my $method = 'GET';
  #my $method = 'HEAD';
  my $req = HTTP::Request->new( $method,
                                $sbms->{$servce}->{proxy}.$url );
  my $res = $ua->simple_request($req);
  my $location = $res->header('location');
  print "$location\n";
  my $count = 0;
  if ( $location =~ m|$sbms->{$servce}->{regexp}| ) {
    $count = 0 + $1;
  }
  return $count;
}

実行例：

$ sbm_img_count.pl
http://b.hatena.ne.jp/images/users/normal/00134.png
http://image.clip.livedoor.com/img/users/small/00019.png
http://thumbnail.yimg.jp/number/large/7
http://cdn.buzzurl.jp/static/image/num/1.gif
http://bookmark.fc2.com/icons/00002.png
http://clip.nifty.com/images/counter/00000.png
http://pookmark.jp/images/count/3
147
$

便利に使うには、コマンドラインからの入力が@ARGVに入るので、コマンドラインからURLを入れて問い合わせるように改造する、CGI.pmモジュールを使って、URLのクエリーから問い合わせるように改造する、等々できるんじゃないかなと思います。

[続きを読む]以降では、画像でしかブックマーク数の情報を提供していないSBMで、SBM運営会社の代わりに、XML-RPCインターフェースのAPIを用意するというあさっての方向に突っ走ってみます。

Continue reading 実用！画像でブックマーク数を返すSBMからブックマーク数を数値で取得.

デフォルト値のperlらしい指定法

By dankogai [livedoor.com] on | 0 Comments | 0 TrackBacks |

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

のダイジェスト。

Scalarによるデフォルト値

sub num{
    my $num = shift || -1; 
    # ....
}

0や''を入力値として用いたい場合は

sub num{
    my $num = shift;
    $num = -1 if not defined $num;
    # ....
}

Perl 5.10.0 以降なら

sub num{
    my $num = shift // -1;
    # ....
}

Hashによるデフォルト値

以下で一発!

sub conf{
    my %arg = (
        lang => 'perl',
        rank => 1,
        @_ # ここが決め手!           
    );
    # ...
}

オブジェクトをnewしたいなら、以下がお手軽。

package A::Module
sub new{
    my $pkg = shift;
    bless {
        lang => 'perl',
        rank => 1,
        @_
    }, ref $pkg || $pkg;
}

Dan the Perl Monger

Yet Another Perl Mongers

aim