Big Sky

id:tokuhiromが良い物作ってくれたので、それを使ったブログエンジン書いてみた。

MENTA というウェブアプリケーションフレームワークをかいてみた - TokuLog 改めB日記

「CGI 用のウェブアプリケーションフレームワークにはどういうものが最適か」という問いに対する自分なりの解答。

http://d.hatena.ne.jp/tokuhirom/20081111/1226418572

名前は、「MENTOS(メントス)」。

実質コードは以下の量くらい。

sub read_entry {
    my $file = shift;
    my $pubdate = strftime("%y-%m-%d %H:%M:%S", localtime((stat $file)[9])),
    my $content = read_file($file);
    $file =~ s!.*?([^/]+)\.txt$!$1!;
    $content =~ /^([^\n]+)\n\n(.*)/ms;
    return {
        id => $file,
        title => $1,
        pubdate => $pubdate,
        description => $2,
    }
}

# あなたのプログラム
sub do_index {
    my $id = param('id') || '';
    my $data_dir = config()->{application}->{data_dir};

    if ($id =~ /^(\d+)$/) {
        render('entry.html', read_entry("${data_dir}/${id}.txt"));
    } else {
        my @entries;
        for my $file (glob("${data_dir}/*.txt")) {
            push @entries, read_entry($file);
        }
        render('entries.html', \@entries);
    }
}

sub do_edit {
    my $id = param('id') || '';
    my $data_dir = config()->{application}->{data_dir};
    my $msg = '';
    my $entry = {};

    if ($ENV{'REQUEST_METHOD'} eq 'POST') {
        $entry->{id} = param('id') || '';
        $entry->{title} = param('title') || '';
        $entry->{description} = param('description') || '';
        $entry->{title} =~ s!\r!!g;
        $entry->{description} =~ s!\r!!g;
        my $password = param('password') || '';
        my $admin_password = config()->{application}->{password};
        if ($entry->{id} =~ /^(\d+)$/ && $password eq $admin_password) {
            $entry->{id} = time unless $entry->{id};
            utf8::decode($entry->{title});
            utf8::decode($entry->{description});
            write_file("${data_dir}/${id}.txt", $entry->{title}."\n\n".$entry->{description});
            redirect(config()->{application}->{blog_url});
            return;
        } else {
            $msg = 'パスワードが違います';
        }
    } else {
        $entry = read_entry("${data_dir}/${id}.txt") if -f "${data_dir}/${id}.txt";
    }

    render('edit.html', $entry, $msg);
}
MENTAを使ってどれだけ小さなコード量でブログエンジンが出来上がるかを試して見たかっただけなので、ブログと言いながらカテゴリやコメント、トラックバック等はありません。一応編集機能は持ち合わせています。
コードはcodereposのこの辺に置いときますので、適当に弄って遊んで下さい。
暇があれば、id:yappoのYacafiや、id:kazuhoのNanoAでも作ってみたいなぁ。

miyagawaさんがPlaggerのFetchNicoVideoからダウンローダとして抜き出してくれました。

Tatsuhiko Miyagawa / WWW-NicoVideo-Download-0.01 - search.cpan.org
http://search.cpan.org/~miyagawa/WWW-NicoVideo-Download-0.01/

中身はMooseを使ったモダンなコード。eg/fetch-video.plにそのまま使えそうなサンプルまで入っています。
サンプルではTerm::ProgressBarで進捗表示までされて至れり尽くせり。今日はちょっとだけ修正してファイル名をタイトルから名付ける様にしてみました。
といってもWWW::NicoVideo::Downloadではloginが単体で呼び出せられる様になっていますし、user_agentが得られるようになっているのでそれを同じくmiyagawaさん作のWeb::Scraperに渡しただけです。
#!/usr/bin/perl
use strict;
use warnings;
use Encode qw(encode decode_utf8);
use URI;
use Web::Scraper;
use WWW::NicoVideo::Download;
use Term::ProgressBar;

my($email, $password, $video_id) = @ARGV;

my($term, $fh);

my $client = WWW::NicoVideo::Download->new( email => $email, password => $password );
$client->login( $video_id );

my $helper = scraper { process '#subinfo img', title => '@alt' };
$helper->user_agent( $client->user_agent );

my $title = $helper->scrape(
    URI->new("http://www.nicovideo.jp/watch/$video_id")
)->{title} || $video_id;
$title = encode("cp932", decode_utf8($title)) if $^O eq 'MSWin32';

$client->download($video_id, \&cb);

sub cb {
    my($data, $res, $proto) = @_;

    unless ($term && $fh) {
        my $ext = (split '/', $res->header('Content-Type'))[-1] || "flv";
        my $filename = "$title.$ext";
        $filename =~ s![\\/|:<>"?*]!_!g;
        open $fh, ">", $filename or die $!;
        $term = Term::ProgressBar->new( $res->header('Content-Length') );
    }

    $term->update( $term->last_update + length $data );
    print $fh $data;
}
うむ。便利便利。

そういえばWEB+DB PRESS vol47買った。codereposの記事も面白かった。


追記
otsuneさんから、API叩いた方が仕様変更に強いとコメント頂きました。XML::Simple使ってタイトル取る様に修正しました。
#!/usr/bin/perl
use strict;
use warnings;
use Encode qw(encode decode_utf8);
use XML::Simple;
use WWW::NicoVideo::Download;
use Term::ProgressBar;

my($email, $password, $video_id) = @ARGV;

my($term, $fh);

my $client = WWW::NicoVideo::Download->new( email => $email, password => $password );
$client->login( $video_id );

my $res = $client->user_agent->get("http://www.nicovideo.jp/api/getthumbinfo?v=$video_id");
my $title = $video_id;
if ($res->is_success) {
  my $xs = XML::Simple->new;
  my $ref = $xs->XMLin($res->decoded_content);
  $title = $ref->{thumb}->{title} || $video_id;
  $title = encode("cp932", decode_utf8($title)) if $^O eq 'MSWin32';
}

$client->download($video_id, \&cb);

sub cb {
    my($data, $res, $proto) = @_;

    unless ($term && $fh) {
        my $ext = (split '/', $res->header('Content-Type'))[-1] || "flv";
        my $filename = "$title.$ext";
        $filename =~ s![\\/|:<>"?*]!_!g;
        open $fh, ">", $filename or die $!;
        $term = Term::ProgressBar->new( $res->header('Content-Length') );
    }

    $term->update( $term->last_update + length $data );
    print $fh $data;
}


今のところ使い道見つからないけど、面白い。

Chris Grau / Export-Lexical - search.cpan.org

Export::Lexical - Lexically scoped subroutine imports

http://search.cpan.org/dist/Export-Lexical/

SYNOPSISをちょと変えて use strict;
use warnings;
package Foo;

use Export::Lexical;
sub foo :ExportLexical {
    print "foo@_\n" or 1;
}
sub bar :ExportLexical {
    print "bar@_\n" or 1;
}
1;
を使う以下のスクリプト use strict;
use warnings;
use Foo;

no Foo 'foo';

eval { foo(1); } or warn "foo1 is disabled.";
eval { bar(1); } or warn "bar1 is disabled.";

{
    use Foo 'foo';
    no Foo 'bar';

    eval { foo(2); } or warn "foo2 is disabled.";
    eval { bar(2); } or warn "bar2 is disabled.";
}

eval { foo(3); } or warn "foo3 is disabled.";
eval { bar(3); } or warn "bar3 is disabled.";
実行すると foo1 is disabled. at hoge.pl line 7.
bar1
foo2
bar2 is disabled. at hoge.pl line 15.
foo3 is disabled. at hoge.pl line 18.
bar3
こんな動きをする。レキシカルスコープでnoが使える。ただnoとは言えどメソッド自体は定義されてるからstrictでも通るし、eval無しで実行してもエラーにはならない。

面白い。でも使い道が見つからない。