Perl/フレームワーク（MVC）/Sledge/Apache2(mod_perl2)＋UTF8 - ありんく tech-wiki

だいたい193日前に更新最終更新日時: 2010-02-28 (日) 17:01:04 193日前

現在の位置

FrontPage > Perl > フレームワーク（MVC） > Sledge > Apache2(mod_perl2)＋UTF8

はてなブックマーク - ありんく tech-wiki

Perl/フレームワーク（MVC）/Sledge

SledgeのApache2（mod_perl2）対応＋UTF8 †

Sledgeをmod_perl2に対応させ、且つUTF8にも対応させます。

Sledge自体はCompatを通さず、mod_perl2のみを利用し、UTF8コードを前提としています。

既存部分からの変更点 †

SledgeのUTF8化について †

Bundle::Sledge::I18Nをインスパイアし、Apache2に対応した環境を作ります。

Apache2の対応について †

おいぬま日報(不定期) - Apache2 + mod_perl2.0.1 + Sledge-1.11をインスパイアしました。

Dispatcherについて †

Sledge::Dispatcherを元にApache2(mod_perl2)のAPIに対応させます。

使い方 †

mod_perl2設定例 †

httpd.conf †

<Location />
  SetHandler perl-script
  PerlResponseHandler Sledge::Dispatcher::Apache2::Properties
  PerlSetVar SledgeMapFile /path/to/map.props
</Location>

startup.plはApache1の書式をそのまま踏襲（PerlPostConfigRequire?で読み込むとうまいこといかなかったので。）

PerlRequire /path/to/app/conf/startup.pl
<Perl>
  BEGIN {
      use lib qw(/path/to/app/lib);
  }
</Perl>

startup.plの詳細については
iandeth. - モジュールをuseした際のメモリ使用量(増加量)を調べてみるを参照。

startup.pl時の動的モジュール読み込みについては
startup.plに書いておいた方が良い事。（マツモブログ）を参照。

WebアプリケーションのPagesクラス †

既定クラスをSledge::Pages::Apache2::I18Nに設定します。

※Compatではないので、ソースコードレベルでmod_perl2での動作が前提になります。

package App::Pages;

use utf8;
use strict;
use warnings;
use base qw(Sledge::Pages::Apache2::I18N);

use Sledge::Authorizer::Null;
use Sledge::Charset::UTF8::I18N;
use Sledge::SessionManager::Cookie;
use Sledge::Session::Memcached::Fast;
use Sledge::Template::TT::I18N;
use Template::Stash::ForceUTF8;
・
・
・

ソースコード †

Apache2のAPIに対応させている以外の部分は既存のコードを利用しています。

Sledge::Pages †

Sledge::Pages::Apache2::I18N †

Apache->request

は

Apache2::RequestUtil->request

に変更になっている。

package Sledge::Pages::Apache2::I18N;

use utf8;
use strict;
use warnings;
use vars qw($VERSION);
$VERSION = '0.01';

use base qw(Sledge::Pages::Base);

use Sledge::Request::Apache2::I18N;
use Apache2::RequestUtil;

sub create_request {
    my($self, $r) = @_;
    return Sledge::Request::Apache2::I18N->new($r || Apache2::RequestUtil->request);
}

1;

Sledge::Request †

Sledge::Request::Apache2::I18N †

package Sledge::Request::Apache2::I18N;

use utf8;
use warnings;
use strict;
use vars qw($VERSION);
$VERSION = '0.01';

use base qw(Class::Accessor::Fast);
__PACKAGE__->mk_accessors(qw(req));

use vars qw($AUTOLOAD);
use Sledge::Request::Apache2::I18N::Upload;
use Apache2::Request;
use Apache2::Upload;
use Encode;

sub new {
    my($class, $r) = @_;
    bless { req => Apache2::Request->new($r) }, $class;
}

sub upload {
    my $self = shift;
    Sledge::Request::Apache2::I18N::Upload->new($self, @_);
}

sub param {
    my $self = shift;
    if ( @_ == 0) {
        return map { $self->_decode_param($_) } $self->req->param;
    } elsif ( @_ == 1) {
        my @value = map { $self->_decode_param($_) } $self->req->param($_[0]);
        return wantarray ? @value : $value[0];
    } else {
        my ($key, $param) = @_;
        if (ref $param eq 'ARRAY') {
            $param = [map { $self->_encode_param($_) } @$param];
            return $self->req->param( $key, $param);
        } elsif ( ! ref $param ) {
            return $self->req->param($_[0], $self->_encode_param($_[1]));
        } else {
            return $self->req->param(@_);
        }
    }
}

sub _decode_param {
    my ($self, $val) = @_;
    return Encode::is_utf8($val)
           ? $val
           : Encode::decode('utf-8', $val);
}

sub _encode_param {
    my ($self, $val) = @_;
    return Encode::is_utf8($val)
           ? Encode::encode('utf-8', $val)
           : $val;
}

sub send_http_header {
    my $self = shift;
    my $type = shift;
    $self->req->content_type($type) if($type);
}

sub header_in {
    my $self = shift;
    $self->req->headers_in->get($_[0]);
}

sub header_out {
    my($self, $key, @v) = @_;
    if($key eq 'Content-Length'){
        $self->req->set_content_length(shift @v);
    }elsif($key =~ /^(?:Set-Cookie|Location)$/){
        $self->req->err_headers_out->add($key => $_) for @v;
    }elsif($key ne 'Content-Type'){
        $self->req->content_type(shift @v);
    }else{
        $self->req->headers_out->add($key => $_) for @v;
    }
}

sub DESTROY { }

sub AUTOLOAD {
    my $self = shift;
    (my $meth = $AUTOLOAD) =~ s/.*:://;
    $self->req->$meth(@_);
}

1;

Sledge::Request::Apache2::I18N::Upload †

package Sledge::Request::Apache2::I18N::Upload;

use utf8;
use warnings;
use strict;
use vars qw($VERSION);
$VERSION = '0.01';

use base qw(Class::Accessor::Fast);
__PACKAGE__->mk_accessors(qw(upload));

use vars qw($AUTOLOAD);

sub new {
    my $class = shift;
    my $r   = shift;
    my @upload = $r->req->upload(@_);
    my @list;
    for (@upload) {
        next unless $_->size;
        my $self = bless {upload => $_}, $class;
        push @list, $self;
    }
    return wantarray ? @list : shift @list;
}

sub DESTROY { }

sub AUTOLOAD {
    my $self = shift;
    (my $meth = $AUTOLOAD) =~ s/.*:://;
    $self->upload->$meth(@_);
}

1;

Sledge::Dispatcher †

Sledge::Dispatcher::Apache2 †

ほとんどがSledge::Dispatcherのコードのママなのですが

Apache2の定数に書き換えや、handlerの記述をApache2の方式に変更しています。

package Sledge::Dispatcher::Apache2;

use strict;
use warnings;
use vars qw($VERSION);
$VERSION = 0.01;

use Apache2::Const -compile => qw(OK DECLINED);
use Apache2::Log;

use File::Basename;
use Sledge::Exceptions;

use vars qw($DEBUG);
$DEBUG = 0;

my %loaded;

sub debug {
    my ($r, $args) = @_;
    chomp($args);
    $r->log->warn($args) if $DEBUG;
}

sub _load_module {
    my($class, $r, $module) = @_;
    debug($r, "loading $module");
    return if $loaded{$module};

    no strict 'refs';
    eval "require $module";
    if ($@ && $@ !~ /Can't locate/) {
        debug($r, "error loading $module: $@");
        die $@;
    } elsif ($@) {
        debug($r, "erorr loading $module: $@");
    }
    $loaded{$module} = 1;
}

sub null_method { }

sub determine {
    my($class, $r) = @_;

    # we can ignore extensions!
    my $ext = $r->dir_config('SledgeExtension') || '.cgi';

    # for static .html
    my $static = $r->dir_config('SledgeStaticExtension') || '.html';

    # determine directory and page name
    my($page, $dir, $suf) = File::Basename::fileparse($r->uri, $ext, $static);

    # don't match with $ext and $static
    if (index($page, '.') >= 0) {
            #debug($r, "$page doesn't match with $ext and $static");
            debug($r, "$page doesn't match with ".$static);
        return;
    }

    # <Location /foo>: /foo/bar => /bar
    (my $location = $r->location) =~ s!/$!!;
    $dir =~ s/^$location// if $location;
    $dir =~ s!/$!!;                # remove trailing slash

    my $loadclass = $class->do_determine($r, $dir);
    return $loadclass, $page, $suf eq $static, ($page eq '' && $suf eq '');
}

sub handler : method {
    my($class, $r) = @_; ## $r equal Apache2::RequestUtil->request

    my($loadclass, $page, $is_static, $slash) = $class->determine($r);
    unless ($loadclass) {
        debug($r, "Can't determine loadclass");
        return Apache2::Const::DECLINED;
    };

    debug($r, "loadclass is $loadclass, page is $page");

    $class->_load_module($r, $loadclass);

    my $no_static = uc($r->dir_config('SledgeDispatchStatic') || 'On') eq 'OFF';
    if ($is_static && !$class->_generated($loadclass, $page)) {
        debug($r, 'static method, but not yet auto-generated');
        if ($no_static || $loadclass->can("dispatch_$page")) {
            debug($r, "dispatch_$page exists, but access is $page.html");
            return Apache2::Const::DECLINED;
        } else {
            $class->_generate_method($r, $loadclass, $page);
        }
    } elsif ($slash) {
        my @indexes = $r->dir_config('SledgeDirectoryIndex') ?
            split(/\s+/, $r->dir_config('SledgeDirectoryIndex')) : 'index';
        debug($r, "indexes: ", join(",", @indexes));
        for my $index (@indexes) {
            if ($loadclass->can("dispatch_$index")) {
                debug($r, "$loadclass can do $index");
                $page = $index;
                last;
            }
        }
        $page ||= $indexes[0];
        debug($r, "page is $page");

        if (!$loadclass->can("dispatch_$page")) {
            if ($no_static) {
                debug($r, "access to slash, but no_static is on");
                return Apache2::Const::DECLINED;
            }
            $class->_generate_method($r, $loadclass, $page);
        }
    } elsif (!$is_static && $class->_generated($loadclass, $page)) {
        debug($r, "access to dynamic after static method $page made");
        return Apache2::Const::DECLINED;
    }

    unless ($loadclass->can("dispatch_$page")) {
        debug($r, "$loadclass can't do $page");
        return Apache2::Const::DECLINED;
    }

    debug($r, "ok now loading $loadclass - $page");
    $loadclass->new->dispatch($page);

    return Apache2::Const::OK;
}

my %generated;

sub _generate_method {
    my($class, $r, $loadclass, $page) = @_;
    debug($r, "generating $page on $loadclass");
    no strict 'refs';
    if (-e $loadclass->guess_filename($page)) {
        *{"$loadclass\::dispatch_$page"} = \&null_method;
        $generated{$loadclass, $page} = 1;
    }
}

sub _generated {
    my($class, $loadclass, $page) = @_;
    return $generated{$loadclass, $page};
}

sub do_determine { Sledge::Exception::AbstractMethod->throw }

1;

Sledge::Dispatcher::Apache2::Properties †

ベースになるモジュールの変更や、APIをApacheからApache2の呼び出し方式に変更をしています。

package Sledge::Dispatcher::Apache2::Properties;

use strict;
use warnings;
require Sledge::Dispatcher::Apache2;
use base qw(Sledge::Dispatcher::Apache2);

use Apache2::ServerUtil;
use Data::Properties;
use FileHandle;
use UNIVERSAL::require;

my %Cache;

sub load_property {
    my($class, $r, $path) = @_;
    if (!$Cache{$path} ||
        ($class->_reload($r) && ($Cache{$path}->[1] < _mtime($path)))) {
        my $props  = Data::Properties->new;
        my $handle = FileHandle->new($path) or
            Sledge::Exception::PropertiesNotFound->throw("$path: $!");
        $props->load($handle);
        $class->init_modules($props);
        $Cache{$path} = [ $props, _mtime($path) ];
    }
    return $Cache{$path}->[0];
}

sub _reload {
    my($class, $r) = @_;
    my $reload = $r->dir_config('SledgeMapReload');
    return !(defined $reload && uc($reload) eq 'OFF');
}

sub init_modules {
    my($class, $props) = @_;
    for my $name ($props->property_names) {
        my $module = $props->get_property($name);
        $module->require or die $UNIVERSAL::require::ERROR;
    }
}

sub _mtime { (stat(shift))[9] }

sub do_determine {
    my($class, $r, $dir) = @_;

    # load property file
    my $map_path = $r->dir_config('SledgeMapFile')
        or Sledge::Exception::MapFileUndefined->throw;
    my $props = $class->load_property($r, Apache2::ServerUtil::server_root_relative($r->pool, $map_path));

    return $props->get_property($dir) || $props->get_property("$dir/");
}

1;

mod_perl2のリンク集 †

ドキュメント †

おいぬま日報(不定期) - Apache2 + mod_perl2.0.1 + Sledge-1.11
- SledgeをApache2で動かした方
mod_perl 2.0 Documentation（英語）
- 数少ないmod_perl2のドキュメント。mod_perl1とのAPIでの相違点などを調べる
mod_perl クイックリファレンス
- こちらは日本語版。mod_perl1と2の相違点などが明確。
mod_perl環境下による高速化 SourceForge?.JP

参考リンク †

mod_perl2 インストール
- Apache2のhttpd.conf周りの設定が詳しい
MENTA（mod_perl2に対応しました）
- handerに渡しているので、コードを読むと勉強になります。
10分で完了、mod_perl 2.0 で Hello, World! （naoyaのはてなダイアリー）
- コンテンツハンドラを作るまでの流れ。
mod_perl 2.0.4 httpd.conf 設定メモ
mod_perl 2.0 の Server Life CycleCommentsAdd Star
- mod_perl2の設定についての詳細
Perlを最適化する - コードから、できる限り余分なものを削り取る
- http://www.ibm.com/developerworks/jp/linux/library/l-optperl/
- mod_perl に限った話しではありませんが、PerlでのWebアプリを作るという部分で有用なTIPSが多いです。