タグ別アーカイブ: ライブラリ

Mojoliciousのバンドルファイルを整理するプラグイン

 

Mojoliciousのエラー画面で使われている画像やJSやCSS。リバースプロキシを拡張子などのホワイトリストで記述すると、これらのバンドルファイルがプロキシを通過せずに404エラーになってしまう。具体的にはこういうケース。

RewriteEngine on
RewriteRule ^(.*(.(html|htm|xml))|/)$ http://localhost:3000$1 [L,P,QSA]

バンドルファイルはなぜかpublic直下にちりばめられているため、記述しづらい。それにファイル名が衝突してることに気付かずハマりそう。そこで、バンドルファイルがあたかも単一ディレクトリにまとまってるかのように装うプラグインMojolicious-Plugin-UnmessifyBundleです。

sub startup {

    my $self = shift;

    # Mojolicious
    $self->plugin(unmessify_bundle => {prefix => 'mojolicious-bundle'});
}

# Mojolicious::Lite
plugin unmessify_bundle => {prefix => 'mojolicious-bundle'};

これを使うと例えばバンドルされたjqueryは/mojolicious-bundle/js/jquery.jsでアクセスできます。エラーページのHTMLソースも適当に書き換えられます。

すると、バンドルファイルをワンライナーでホワイトリスト入りさせることができるのです。

    RewriteEngine on
    RewriteRule ^(.*(.(html|htm|xml))|/)$ http://localhost:3000$1 [L,P,QSA]
    RewriteRule ^/mojolicious-bundle(/.+)$ http://localhost:3000$1 [L,P,QSA]

前回以上にニーズのなさそうなネタでした。

 

MojoliciousアプリにPlack::Middlewareをプラグインするプラグイン

レスポンスフィルター系のPlack::Middleware::*をMojoliciousのafter_dispachフックにねじ込むプラグインMojolicious-Plugin-PlackMiddlewareです。そんなニーズない?

MojoX::Tusuで古いウェブサイトを移植するとき、/mobile/なんてディレクトリがあったら、「Plack-Middleware-ForceCharset」で強制的にShift_JISで出力するとかしたい。現状でもソースでauto_detectするオプションがあるからいいんだけど、明示的にしたい。

enable_ifっぽい判定もできるようにしたので、きっとできると思う。

use MojoX::Util::ResponseFilter 'enable';

sub startup {

    my $self = shift;

    $self->plugin('plack_middleware', [
        'Plack::Middleware::Some1',
        'Plack::Middleware::Some2', {arg1 => 'some_vale'},
        'Plack::Middleware::ForceCharset', sub {
            my $c = shift;
            if (ルートが/mobile/だったら) {
                return 1;
            }
        }, {charset => 'Shift_JIS'},
    ]);
}

 

CSSでいじれるディレクトリツリーの生成スクリプト

ブログ記事にディレクトリーツリーを掲載しようと思ったんだけど、treeコマンドの出力は味気ないので、CSSでいじりやすくHTML出力できるperlスクリプトをチョー適当に作った。本来の仕事が進まない。

[2011.6.22]ソート追加

 

use strict;
use warnings;
use utf8;
use Getopt::Long;

    my %args = ('L' => 10);
    GetOptions(%args, 'L=s');
    my ($dir) = @ARGV;
    &loopDir($dir || '.', 0);
    exit;

    sub loopDir {
        my ($dir, $depth) = @_;
        chdir($dir) || die "Cannot chdir to $dir\n";
        opendir(my $dh, ".");
        my @entries = sort {$a cmp $b} grep {substr($_,0,1) ne '.'} readdir($dh);
        closedir($dh);
        if (scalar @entries) {
            print "<ul>\n";
            for my $f (@entries) {
                if (-d $f) {
                    print qq{<li class="dir">\n};
                    print qq{$f\n};
                    if ($depth < $args{L} - 1) {
                        loopDir($f, $depth + 1);
                    }
                    print qq{</li>n};
                } elsif (-f $f) {
                    print qq{<li class="file">$f</li>\n};
                }
            }
            print "</ul>\n";
        }
        chdir("..");
    }
  • crypt.pl
  • ddsn_get.sh
  • memo.txt
  • ffmpeg
    • 02.3gp
    • 02a.wav
    • 01a.3gp
    • 01a.wav
    • 02a.3gp
    • 2ch.mp3
    • test.3g2
    • brave
      • 01_2.avi.filepart
    • 01.3gp

 

CSSもかなりテキトー。

.directoryTree {
    padding:10px;
    border:1px solid #aaa;
    background-color:#fffbf0;
}
    .directoryTree ul ul {
        padding:0;
        margin-left:0;
        margin-bottom:0.5em;
        padding-bottom: 0 !important;
        border-left:3px solid #ddd;
    }
    .directoryTree li {
        margin-left:0 !important;
        padding-left:30px !important;
        vertical-align:bottom;
        background-repeat:no-repeat;
        background-position:10px 0;
        list-style:none;
    }
        .directoryTree li.dir {
            background-image:url(./images/xiao_icon/40.png);
            margin-bottom:0.5em;
        }
            .directoryTree li.dir > ul {
                margin-left:-1em;
            }
        .directoryTree li.file {
            background-image:url(./images/xiao_icon/21.png);
        }

Mojoliciousにウェブ制作をデプロイする

「ウェブアプリ開発」と「ウェブ制作」って別のジャンルなのかなあ。主に受託のコーポレートウェブ制作を生業にしていると流行りのウェブアプリケーションフレームワーク的なものにあまり馴染めない。まるで別世界の出来事のようだ。これって何となくURLディスパッチに対する発想の違いな気がしたので、Mojoliciousのディスパッチャを豪快に差し替えて、ウェブ制作を「デプロイ」できるようにした。apache風のディスパッチャをMojoliciousに登録する「MojoX::Tusu」。

  • リクエストパスはサーバーのディレクトリ階層を意味する。
  • テンプレートもstaticファイルもpublic_htmlに突っ込む。
  • server-parsedの対象は拡張子で決める。
  • apacheのDirectoryIndexに相当する機能。
  • apacheのErrorDocumentに相当する機能。
  • otherのread権限のないファイルへのアクセスは403エラー。
  • apacheを真似てディレクトリfooへのアクセスはfoo/にリダイレクトしてみた。

Mojoliciousルートにpublic_htmlを作り、手元にあったいくつかの静的サイトデータを突っ込んだところ、ビルトインサーバー, CGI, hypnotoad上で今までどおり動作しました。そして、PHPで言えば「AddType application/x-httpd-php .html」としたのと似た状態になり、htmlファイル内の好きなところに動的コンテンツを挿入できるという訳です。ただし、念のため先に書いておくと、Mojoliciousの標準のテンプレート命名規則(index.html.epとか)がMojoX::Tusuの差し替えたディスパッチャの方針と合致しないため、今のところepやeplは使えません。epRendererあたりをそっくり差し替えれば行けそうですが、とりあえず僕のお気に入りのテンプレートエンジン「Text::PSTemplate」でお楽しみください。

MojoX::Tusuを用いたMojoliciousアプリは下記のようになります。とりあえずrouteは必要ありません。

use MojoX::Tusu;
use strict;
use warnings;
use base 'Mojolicious';

sub startup {
    my $self = shift;
    my $tusu = MojoX::Tusu->new($self);
}

URLディスパッチに関しては内部的に下記のようなことをやってます。リクエストパスがテンプレートの在り処を意味するという訳です。ちなみにname('')としているのはテンプレート名が空(/へのアクセス)のとき、自動生成されたroute名がテンプレート名になってしまうからなのです。

$app->routes
    ->route('/:template', template => qr{.*})
    ->name('')
    ->to(cb => sub {$_[0]->render(handler => 'tusu')});

URLディスパッチルールが昔ながらのルールに乗っ取っているので、mojolicious rootが必要な場合意外はテンプレート内にurl_forと書く必要はありません。デザイナーさんが使うオーサリングソフトとの親和性も高いです。リンクパスの表記を巡っては、ここ1年くらいhtmlのbaseタグを活用して乗り切ってきたのですが、いろいろ面倒を抱え込むことにもなってやめたという経緯もあります。なお、このデフォルトのrouteは初回のon_processフックで登録してるので、startup内でルートが登録されればそちらが優先されます。

ドキュメントルート。内部的にはこうです。

$app->static->root('public_html');
$app->renderer->root('public_html');

Mojoliciousのデフォルトディスパッチャはstaticファイルを先に存在確認するようになってます。テンプレートとstaticを同じディレクトリに詰め込むと、全てstaticとして扱われてしまうので、フロントディスパッチャを組み直しています。デフォルトでは.htmlと.htmと.xmlだけテンプレートとして処理し、それ以外はstatic。ただし、DirectoryIndexの適用やパーミッションのチェックなどをして、エラーを返したりもします。なお、スクリプトファイルがあるとソースが見えちゃうので、リバースプロキシなりhtaccessなりで排除しないといけません。

お問い合わせフォームを作りたくなったら、もちろんrouteを追加することもできます。

sub startup {
    my $self = shift;
    my $tusu = MojoX::Tusu->new($self);
    my $r = $self->routes;
    $r->route('/inquiry/')->via('post')->to(cb => sub {
        ### メール送るとか
    })
}

ただし、MojoX::Tusu方式では、routeはあくまでディレクトリであって、inqueryコントローラーを意味しないってのは譲れないルールなのです。実際、/inquiry/へのアクセスの際には先ず/inquiry/index.htmlの存在確認がなされます。

 

public_html直下にindex.cgiを置いてCGIモードでも動かせます。その場合は

RewriteCond %{REQUEST_FILENAME} ((.(html|htm|xml))|/)$
RewriteRule ^(.*)$ index.cgi/$1 [QSA,L]

としておけば動くと思います。また、この場合、public_html内に既設のcgiやphpがあるとそのまま動くので、放っておきたい過去の遺物がある場合に便利です。

また、稼働中のサイトの一部のディレクトリにMojoX::Tusuを導入したい場合は、仮想的なドキュメントルートを作ってmojoliciousルートを跨ぎます。

RewriteEngine On
RewriteBase /path/to/root/
RewriteCond %{REQUEST_URI} ((.(html|htm|xml))|/)$
RewriteCond %{REQUEST_FILENAME} !index.cgi
RewriteRule ^(.*)$ public_html/index.cgi/$1 [QSA,L]
RewriteCond %{REQUEST_FILENAME} !index.cgi
RewriteCond %{REQUEST_FILENAME} !public_html
RewriteRule ^(.*)$ public_html/$1 [QSA,L]

とすれば、外からは/path/to/root/a/b.htmlと見える物が/path/to/root/public_html/index.cgi/a/b.htmlを指すようになる、はず。mod_rewriteはちょっと自身なし。

 

MojoX::TusuはhtmlファイルをText::PSTemplateを使ってレンダリングするので、こんな感じでHTMLを拡張できます。

<html>
    <div>
        <% include('copyright.html') %>
    </div>

MojoX::Tusu(というかMojolicious)はテンプレートエラーをプリティに表示してくれるので、デザイナーさんでも作業しやすい。

 

 

 

 

あと、MojoX::Tusuは独自にプラグインとコンポーネントという仕組みも提供していて、いろいろ拡張できます。

つづく

Text::PSTemplateをrequireできるようにした

 

Text::PSTemplateをrequireで使えるようにしました。

Twitter上でPerlのAttribute::Handlerが過去の遺物だということを知ってしまった。大好きだったのに。。いや今でも好き。動けば問題ないのでAttributeは使っていく。

Text::PSTemplateではプラグインクラスでTplExportアトリビュートを指定したサブルーチンを検出してテンプレートオブジェクトに設定するため、CHECKフェーズでキューにシンボル名を登録し、実行フェーズで実際のテンプレートオブジェクトに登録する手順にしてました。CHECKフェーズを利用しているため、必然的にプラグインはuseしなければなりませんでした。ただ、流行りのフレームワークなど色々見てまわってみると、どうやらテンプレートエンジンはrequireで使えないと話しにならないっぽい。なのでできるようにした。

何をしたかというと、Attribute::Handlerの呼び出しフェーズをBEGINに変えました。BEGINフェーズではシンボルテーブルが未完成のため、ハンドラの引数でサブルーチンのシンボル名を受け取ろうと思っても中途半端な結果にしかならないっぽい。なので、BEGINフェーズで確実に取得できるコードリファレンスをキューに登録しておき、プラグイン機構の決まりで最初に確実に実行されるnewコンストラクタ内でプラグインパッケージのシンボルテーブルとリファレンスを照合し、シンボル名を得るという手順にしてみた。

汎用的に書き直すと、こんなことをした。attr1アトリビュートを定義する例。

package SomeClassBase;
use strict;
use warnings;
use Attribute::Handlers;

    my %_attr1_cue;
    my %_attr_fixed;

    ### ---
    ### Constractor
    ### ---
    sub new {

        my ($class, @args) = (@_);
        my $self = bless {}, $class;

        if (! $_attr_fixed{$class}) {
            $class->_fix_attr1_cue;
            $_attr_fixed{$class} = 1;
        }
        $class->_do_attr1_specific_process();

        return $self;
    }

    sub ATTR1 : ATTR(BEGIN) {

        my($pkg, undef, $ref, undef, $data, undef) = @_;
        push(@{$_attr1_cue{$pkg}}, [$ref, $data ? {@$data} : {}]);
    }

    sub _fix_attr1_cue {

        my $class = shift;
        if (my $cue = $_attr1_cue{$class}) {
            my $tbl = _get_sub_syms($class);
            for my $entry (@$cue) {
                $entry->[2] = $tbl->{$entry->[0]};
            }
        }
    }

    sub _get_sub_syms {

        my ($pkg) = @_;
        no strict 'refs';
        my $out = {};
        my $sym_tbl = %{"$pkg::"};
        for my $key (keys %$sym_tbl) {
            if (exists &{$sym_tbl->{$key}}) {
                $out->{&{$sym_tbl->{$key}}} = $key;
            }
        }
        return $out;
    }

    sub _do_attr1_specific_process {
        my $class = shift;
        for my $cue (@{$_attr1_cue{$class}}) {
            my ($ref, $data, $sym) = @{$cue};
            # do something
        }
    }

これで例外なく動くのかどうかまだ自信ないけど、今のところは問題なさげ。このやり方はnewコンストラクタが必ず、かつ自動的に呼ばれるようなケースでしか使えそうもない。それ以外の場合はアトリビュート自体使うべきでないのかもしれない。

Perl製の小悪魔テンプレートエンジン「Text::PSTemplate」

 

小悪魔はうそです。Perl製のテンプレートエンジンを再発明しました。「Text::PSTemplate」です。

ひたすら変数や関数を書き込むのがメインのテンプレートエンジンです。ore_blog_ore_format_list1(category => 'fuck')みたいなアプリ固有の関数を作って、制御構造はそっちでやるのが手っ取り早いと思ってます。とはいえ、コアプラグインってものがあって、if文、each文、switch文、if_in_array文などの制御構文、ファイルのinclude、Django風テンプレート継承などの機能も使えます。あと、PHPのテンプレートエンジンDwooの機能を少しだけ移植してみたサンプルプラグインもあります。

PurePerlで依存モジュールもたぶんClass::C3くらいです依存モジュール特になし。少なくともPerl5.8.8以降では動きます。5年前から使ってますがアルファバージョンです。APIは変更するかもしれません。POD書きかけ。

以下、テンプレートの書式。

Masonっぽいタグが基本なので、エディタのMasonモードで開くといい感じにハイライトしてくれます。なお、デリミタは変更可能です。

<% ... %>

変数。

<% $var %>

関数。

<% html_escape($var) %>

関数の引数はPerlのまんまです。プラグインの設計次第で配列やファットカンマもいけます。

<% your_func($var, 'something') %>
<% your_func(name1 => $var, name2 => 'something') %>

関数は入れ子にできます。内側には&が必要。

<% your_func(&your_func($var)) %>

if文。関数はブロック内でも使え、外側のスコープの変数は継承され、内側から参照できます。

<% if_equals($var, 1)<<THEN,ELSE %>
    <% $var %> is 1.
<% THEN %>
    <% your_func($var2) %>
<% ELSE %>

構文と言っても、中身は単なる関数です。関数内でタグに後続するブロックを取得するAPIがあるので、それを使用すれば何となく制御構文っぽい感じに見えます。ちなみにブロックの名前は処理内容には無関係で、出現順だけが意味を持ちます。今のところ。

<% your_control($var)<<FOO,BAR %>
    block argument1
<% FOO %>
    block argument2
<% BAR %>

ファイル挿入。includeは入れ子にでき、例によって変数は継承されます。

<% include('path/to/file.txt') %>

テンプレート内に書かれたパス名はデフォルトではそのままPerlのopenに渡されますが、ファイル名の整形のためのコールバックをロジック側で指定することができるので、例えば、常に現在のテンプレートからの相対パスで指定できるようにしたり、基底ディレクトリを指定したり、.htmlは省略可にしたり、予めファイルの有無をチェックしたり、などできます。

テンプレート継承構文。Djangoのドキュメントを真似た例です。

こちらがbase.html

<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
    "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
    <link rel="stylesheet" href="style.css" />
    <title><% placeholder('title')<<DEFAULT %>My amazing site<% DEFAULT %></title>
</head>

<body>
    <div id="sidebar">
        <% placeholder('sidebar')<<DEFAULT %>
        <ul>
            <li><a href="/">Home</a></li>
            <li><a href="/blog/">Blog</a></li>
        </ul>
        <% DEFAULT %>
    </div>

    <div id="content">
        <% placeholder('content')<<DEFAULT %><% DEFAULT %>
    </div>
</body>
</html>

extends構文で継承します。

<% extends('base.html')<<EXTENDS %>
    <% block('title')<<BLOCK %>My amazing blog<% BLOCK %>
    <% block('content')<<BLOCK %>
    <% each($blog_entries, 'entry')<<ENTRIES %>
        <h2><% $entry->{title} %></h2>
        <p><% $entry->{body} %></p>
    <% ENTRIES %>
    <% BLOCK %>
<% EXTENDS %>

下記はif_equals文を含むプラグインの実装例です。引数とブロック指定の2ウェイのインターフェースです。

package SomeModule;
use strict;
use warnings;
use base qw(Text::PSTemplate::PluginBase);
use Text::PSTemplate;

    sub if_equals : TplExport {

        my ($self, $target, $value, $then, $else) = @_;

        my $tpl = Text::PSTemplate->new;

        if ($target eq $value) {
            if ($then) {
                return $then;
            } elsif (my $inline = Text::PSTemplate::inline_data(0)) {
                return $tpl->parse($inline);
            }
        } else {
            if ($else) {
                return $else;
            } elsif (my $inline = Text::PSTemplate::inline_data(1)) {
                return $tpl->parse($inline);
            }
        }
        return;
    }

PluginBaseを継承するとTplExportアトリビュートを指定できるようになります。TplExportなサブルーチンはテンプレート関数と一対一に対応します。if文などの制御構文も実際はサブルーチンなので同じです。また、PluginBaseは同梱のClass::FileCacheable::Liteというクラスを継承していて、関数毎にファイルキャッシュをすることもできます。db_record_listなんて関数を作ったらFileCacheableアトリビュートを付与するとよいです。

このプラグインは下記のようにアクティベートできます。

use Text::PSTemplate::Plugable;
use SomePlugin; # 必要なくなった

my $tpl = Text::PSTemplate::Plugable->new;
$tpl->plug('SomePlugin',''); # 第二引数で名前空間を指定できます
my $parsed = $tpl->parse_file('path/to/file');

基底クラスのText::PSTemplateを継承したPlugableがプラグイン機能を拡張した使いやすいクラスなので、通常これを使います。

Class::FileCacheable::LiteなるPerlモジュールを作った

 

Class::FileCacheableです。PODです。

何にも気にせず作ったOOPスタイルのモジュールに、後から手軽にキャッシュ機構を導入できます。

package RemoteContentGetter;
use strict;
use warnings;
use base 'Class::FileCacheable::Lite';
use LWP::Simple;

    sub new {
        my ($class, $url) = @_;
        return bless {url => $url}, $class;
    }

    sub get_url : FileCacheable {
        my $self = shift;
        return LWP::Simple::get($self->{url});
    }

    sub file_cache_expire {
        my ($self, $timestamp) = @_;
        if (time() - $timestamp > 86400) {
            return 1;
        }
    }

    sub file_cache_options {
        my $self = shift;
        return {
            namespace => 'Test',
            cache_root => 't/cache',
            default_key => $self->{url},
        };
    }

やることは、

  • Cache::FileCacheable::Liteを継承する
  • 必要ならfile_cache_expireメソッドをオーバーライドし、キャッシュの失効条件を指定する。
  • 必要ならfile_cache_optionsメソッドをオーバーライドし、オプションを明示する。
  • 対象のメソッドにFileCacheableアトリビュートを付与する。

以上です。

オプション指定などはCache::FileCacheとほぼ同じです。というか、Cache::FileCacheに依存したClass::FileCacheableってのを作ったんだけど重すぎたので、ファイル操作まで自前でやる本モジュールができたのでした。っていうか、実はこのモジュールは何年も前からひそかに使っていて、すごく気に入っていたので、今回、ちゃんとテスト書いてアップしてみた次第。継承ツリーを汚さない、MixInバージョンも作りたい。

SQL::OOPなるPerlモジュールです

SQL::OOPです。Perlです。

ORマッパーとか難しくてよくわかりません。SQL::Abstractの書式が難しすぎて覚えれません。OOPスタイルのSQLジェネレータも色々あるようですが、あまり気に入ったものがなかった。

SQL::OOPはオブジェクト指向なインターフェースでSQL::Abstractライクな結果を得るものです。簡単なことは難しく、難しいことは簡単にできます。ここ1年くらいでいくつかのプロジェクトで使ってるけど、今のところ問題なさげ。

詳しくはpodを参照ください。

例1

my $select = SQL::OOP::Select->new();
$select->set(
    $select->ARG_FIELDS => '*',
    $select->ARG_FROM   => 'table',
    $select->ARG_WHERE  => sub {
        my $where = SQL::OOP::Where->new;
        return $where->and(
            $where->cmp('=', 'a', 1),
            $where->cmp('=', 'b', 1),
        )
    },
);

こうなります。改行とインデントはフェイクです。

SELECT
    *
FROM
    table
WHERE
    "a" = ? AND "b" = ?

例2

こんな使い方しないってもの含めて、結構何でもできます。

my $select = SQL::OOP::Select->new();
$select->set(
    $select->ARG_FIELDS => SQL::OOP->new(q{"ky1", "ky2", *}),
    $select->ARG_FROM   => q("tbl1", "tbl2", "tbl3"),
    $select->ARG_WHERE  => sub {
        my $where = SQL::OOP::Where->new();
        return $where->and(
            $where->cmp('>=', 'hoge1', 'hoge1'),
            $where->cmp('=', 'hoge2', 'hoge2'),
            $where->or(
                $where->cmp('=', 'hoge3', 'hoge3'),
                $where->cmp('=', 'hoge4', 'hoge4'),
                $where->between('price', 10, 20),
                $where->is_null('vprice'),
                SQL::OOP->new('a = b'),
                'a = b',
                SQL::OOP->new('c = ? ?', ['code1', 'code2']),
                $where->between('price', 10, 20),
            ),
            $where->or(
                $where->cmp('=', 'hoge3', undef),
                $where->cmp('=', 'hoge4', undef),
            ),
        )
    },
    $select->ARG_ORDERBY => SQL::OOP::Order->abstract([['hoge1', 1], ['hoge2']]),
    $select->ARG_LIMIT  => 11315,
    $select->ARG_OFFSET => 1,
);

こうなります。

SELECT
    "ky1", "ky2", *
FROM
    "tbl1", "tbl2", "tbl3"
WHERE
    "hoge1" >= ?
    AND
    "hoge2" = ?
    AND
    (
        "hoge3" = ?
        OR
        "hoge4" = ?
        OR
        "price" BETWEEN ? AND ?
        OR
        "vprice" IS NULL
        OR
        a = b
        OR
        a = b
        OR
        c = ? ?
        OR
        "price"
        BETWEEN ? AND ?
    )
ORDER BY
    "hoge1" DESC, "hoge2"
LIMIT
    11315
OFFSET
    1

ところで、setメソッドなどの引数が変態的な書式になってますが、これはタイポをコンパイルエラーにさせるのと、入力補完するためです。