Changeset 24901 for lang

Timestamp:

11/26/08 11:23:30 (4 years ago)

Author:

mattn

Message:

big merge from MENTA. X-(

Location:

lang/perl/MENTOS/trunk

Files:

• app/controller/edit.mt (modified) (2 diffs)
• app/controller/edit.pl (modified) (3 diffs)
• app/controller/entries.mt (modified) (2 diffs)
• app/controller/entry.mt (modified) (2 diffs)
• app/controller/index.pl (modified) (2 diffs)
• lib/MENTA.pm (modified) (5 diffs)
• lib/MENTA/CGI.pm (modified) (1 diff)
• lib/MENTA/Context.pm (added)
• lib/MENTA/Dispatch.pm (modified) (2 diffs)
• lib/MENTA/Plugin.pm (modified) (2 diffs)
• lib/MENTA/Response.pm (added)
• lib/MENTA/TemplateLoader.pm (modified) (2 diffs)
• menta.cgi (modified) (3 diffs)
• plugins/blog.pl (modified) (2 diffs)

lang/perl/MENTOS/trunk/app/controller/edit.mt

@@ -1 +1 @@
 ? my ($entry, $message) = @_
-?= render_partial('header.mt', config()->{application}->{title})
+?= render('header.mt', config()->{application}->{title})
                         <div class="entry">
                                 <span class="error"><?= $message ?></span>
@@ -21 +21 @@
                                 </form>
                         </div>
-?= render_partial('footer.mt')
+?= render('footer.mt')

lang/perl/MENTOS/trunk/app/controller/edit.pl

@@ -1 +1 @@
 use MENTA;
-
-load_plugin('blog');
 
 sub do_edit {
     my $id = param('id') || '';
     my $data_dir = data_dir;
-    my $static_dir = static_dir;
+    my $static_dir = docroot . '/static/';
     my $msg = '';
     my $entry = {};
@@ -26 +24 @@
             }
             if ($entry->{description}) {
-                write_file("${data_dir}/${id}.txt", $entry->{title}."\n".$entry->{description});
+                blog_file_write("${data_dir}/${id}.txt", $entry->{title}."\n".$entry->{description});
             } else {
                 unlink("${data_dir}/${id}.txt");
@@ -40 +38 @@
     }
 
-    render('edit.mt', $entry, $msg);
+    render_and_print('edit.mt', $entry, $msg);
 }

lang/perl/MENTOS/trunk/app/controller/entries.mt

@@ -1 +1 @@
 ? my $entries = shift
-?= render_partial('header.mt', config()->{application}->{title})
+?= render('header.mt', config()->{application}->{title})
                 <div class="entries hfeed">
 ? for my $entry (@{$entries}) {
@@ -26 +26 @@
                 <p align="right"><a href="edit">新規編集</a></p>
                 <br />
-?= render_partial('footer.mt')
+?= render('footer.mt')

lang/perl/MENTOS/trunk/app/controller/entry.mt

@@ -1 +1 @@
 ? my $entry = shift
-?= render_partial('header.mt', config()->{application}->{title})
+?= render('header.mt', config()->{application}->{title})
                         <div class="entry hentry">
                                 <a class="entry-title" href="<?= docroot ?>?id=<?= $entry->{id} ?>"><?=r $entry->{title} ?></a><br />
@@ -20 +20 @@
                         </div>
                         <p align="right"><a href="edit?id=<?= $entry->{id} ?>">編集</a></p>
-?= render_partial('footer.mt')
+?= render('footer.mt')

lang/perl/MENTOS/trunk/app/controller/index.pl

@@ -1 +1 @@
 use MENTA;
-
-load_plugin('blog');
 
 sub do_index {
@@ -8 +6 @@
 
     if ($id =~ /^\d+$/) {
-        render('entry.mt', blog_read_entry("${data_dir}/${id}.txt"));
+        render_and_print('entry.mt', blog_read_entry("${data_dir}/${id}.txt"));
     } else {
-        my @entries = sort {$b->{mtime} <=> $a->{mtime}}
-            map { blog_read_entry($_) } glob("${data_dir}/*.txt");
-        render('entries.mt', \@entries);
+                my @entries = sort {$b->{mtime} <=> $a->{mtime}}
+                    map { blog_read_entry("$_") } glob("${data_dir}/*.txt");
+        render_and_print('entries.mt', \@entries);
     }
 }

lang/perl/MENTOS/trunk/lib/MENTA.pm

@@ -5 +5 @@
 use CGI::ExceptionManager;
 use MENTA::Dispatch ();
+use MENTA::Context;
+use CGI::Simple;
+use Class::Trigger qw/BEFORE_OUTPUT/;
 require Encode; # use Encode するとふるい Encode でエラーになるときがあるらしい。2.15 で確認。200810-11-20
 
-our $VERSION = '0.06';
+our $VERSION = '0.07';
 our $REQ;
 our $CONFIG;
-our $REQUIRED;
 our $STASH;
-our $PLUGIN_LOADED;
-BEGIN {
-    $REQUIRED = {};
-}
 
 sub import {
@@ -23 +21 @@
 }
 
+{
+    our $context;
+    sub context { $context }
+    sub run_context {
+        my ($class, $config, $code) = @_;
+        local $context = MENTA::Context->new(
+            config => $config,
+        );
+        $code->();
+    }
+}
+
 package main; # ここ以下の関数はすべてコントローラで呼ぶことができます
 
-sub AUTOLOAD {
-    my $method = our $AUTOLOAD;
-    $method =~ s/.*:://o;
-    (my $prefix = $method) =~ s/_.+//;
-    load_plugin($prefix);
-    return main->can($method)->(@_);
-}
-
-sub config () { $MENTA::CONFIG }
+
+sub config () { MENTA->context->config }
 
 sub run_menta {
     my $config = shift @_;
 
-    local $MENTA::CONFIG = $config;
-    local $MENTA::REQ;
-    local $MENTA::STASH;
-
     CGI::ExceptionManager->run(
         callback => sub {
-            MENTA::Dispatch->dispatch()
+            MENTA->run_context(
+                $config => sub {
+                    MENTA::Dispatch->dispatch()
+                }
+            );
         },
         powered_by => '<strong>MENTA</strong>, Web Application Framework.',
-        (config->{menta}->{fatals_to_browser} ? () : (renderer => sub { "INTERNAL SERVER ERROR!" x 100 }))
+        ($config->{menta}->{fatals_to_browser} ? () : (renderer => sub { "INTERNAL SERVER ERROR!" x 100 }))
     );
 }
@@ -86 +89 @@
 }
 
-sub static_dir {
-    config->{menta}->{static_dir} || 'app/static/'
-}
-
 sub __render_partial {
     my ($tmpl, $tmpldir, @params) = @_;
-    require_once('MENTA/TemplateLoader.pm');
     MENTA::TemplateLoader::__load("$tmpldir/$tmpl", @params);
 }
-sub render_partial {
-    my ($tmpl, @params) = @_;
-    bless \__render_partial($tmpl, controller_dir(), @params), 'MENTA::Template::RawString';
-}
-
-sub detach() { CGI::ExceptionManager::detach(@_) }
-
+
+# テンプレートの一部を描画する
 sub render {
     my ($tmpl, @params) = @_;
-    my $out = render_partial($tmpl, @params);
-    $out = $$out;
-    $out = encode_output($out);
-    print "Content-Type: text/html; charset=" . charset() . "\r\n";
-    print "\r\n";
-    print $out;
-
-    detach;
+    my $out = MENTA::TemplateLoader::__load("@{[ controller_dir() ]}/$tmpl", @params);
+    bless \$out, 'MENTA::Template::RawString';
+}
+
+sub _finish {
+    MENTA->call_trigger('BEFORE_OUTPUT');
+    use bytes;
+    my $res = MENTA->context->res;
+    $res->headers->content_length(bytes::length($res->content));
+    print $res->as_string;
+    CGI::ExceptionManager::detach();
+}
+
+sub render_and_print {
+    my ($tmpl, @params) = @_;
+    MENTA::Util::require_once('MENTA/TemplateLoader.pm');
+    my $out = MENTA::TemplateLoader::__load("@{[ controller_dir() ]}/$tmpl", @params);
+    $out = MENTA::Util::encode_output($out);
+
+    my $res = MENTA->context->res;
+    $res->headers->content_type("text/html; charset=" . MENTA::Util::_charset());
+    $res->content($out);
+
+    _finish();
 }
 
 sub redirect {
     my ($location, ) = @_;
-    print "Status: 302\r\n";
-    print "Location: $location\r\n";
-    print "\r\n";
-
-    detach;
+
+    my $res = MENTA->context->res;
+    $res->header('Status' => 302);
+    $res->header('Location' => $location);
+
+    _finish();
 }
 
 sub finalize {
     my $str = shift;
-    my $content_type = shift || ('text/html; charset=' . charset());
-
-    print "Content-Type: $content_type\r\n";
-    print "\r\n";
-    print $str;
-
-    detach;
-}
-
-sub read_file {
-    my $fname = shift;
-    open my $fh, '<:utf8', $fname or die "${fname} を読み込み用に開けません: $!";
-    my $s = do { local $/; join '', <$fh> };
-    close $fh;
-    $s;
-}
-
-sub write_file {
-    my ($fname, $stuff) = @_;
-    open my $fh, '>:utf8', $fname or die "${fname} を書き込み用に開けません: $!";
-    print $fh $stuff;
-    close $fh;
-}
-
-sub param {
-    my $key = shift;
-
-    unless (defined $MENTA::REQ) {
-        require_once('MENTA/CGI.pm');
-        $MENTA::REQ = CGI::Simple->new();
-    }
-
-    $MENTA::REQ->param($key);
-}
-
-sub upload {
-    unless (defined $MENTA::REQ) {
-        require_once('MENTA/CGI.pm');
-        $MENTA::REQ = CGI::Simple->new();
-    }
-    $MENTA::REQ->upload(@_);
-}
-
-sub require_once {
-    my $path = shift;
-    return if $MENTA::REQUIRED->{$path};
-    require $path;
-    $MENTA::REQUIRED->{$path} = 1;
-}
-
-sub load_plugin {
-    my $plugin = shift;
-    return if $MENTA::PLUGIN_LOADED->{$plugin};
-    my $path = "plugins/${plugin}.pl";
-    require $path;
-    $MENTA::PLUGIN_LOADED->{$plugin}++;
-    my $package = __menta_extract_package($path) || '';
-    no strict 'refs';
-    for (
-        grep { /$plugin/o }
-        grep { defined &{"${package}::$_"} }
-        keys %{"${package}::"}
-    ) {
-        *{"main::$_"} = *{"${package}::$_"}
-    }
-}
-
-sub __menta_extract_package {
-    my $modulefile = shift;
-    open my $fh, '<', $modulefile or die "$modulefile を開けません: $!";
-    my $in_pod = 0;
-    while (<$fh>) {
-        $in_pod = 1 if m/^=\w/;
-        $in_pod = 0 if /^=cut/;
-        next if ( $in_pod || /^=cut/ );    # skip pod text
-        next if /^\s*\#/;
-
-        /^\s*package\s+(.*?)\s*;/ and return $1;
-    }
-    return;
+    my $content_type = shift || ('text/html; charset=' . MENTA::Util::_charset());
+
+    my $res = MENTA->context->res;
+    $res->headers->content_type($content_type);
+    $res->content($str);
+
+    _finish();
+}
+
+sub param        { MENTA->context->request->param(@_) }
+sub upload       { MENTA->context->request->upload(@_) }
+sub mobile_agent { MENTA->context->mobile_agent() }
+
+
+{
+    # プラグインのロード機構
+
+    my $plugin_loaded;
+    my $__menta_extract_package = sub {
+        my $modulefile = shift;
+        open my $fh, '<', $modulefile or die "$modulefile を開けません: $!";
+        my $in_pod = 0;
+        while (<$fh>) {
+            $in_pod = 1 if m/^=\w/;
+            $in_pod = 0 if /^=cut/;
+            next if ( $in_pod || /^=cut/ );    # skip pod text
+            next if /^\s*\#/;
+
+            /^\s*package\s+(.*?)\s*;/ and return $1;
+        }
+        return;
+    };
+    my $_load_plugin = sub {
+        my $plugin = shift;
+        return if $plugin_loaded->{$plugin};
+        my $path = "plugins/${plugin}.pl";
+        require $path;
+        $plugin_loaded->{$plugin}++;
+        my $package = $__menta_extract_package->($path) || '';
+        no strict 'refs';
+        for (
+            grep { /$plugin/ }
+            grep { defined &{"${package}::$_"} }
+            keys %{"${package}::"}
+        ) {
+            *{"main::$_"} = *{"${package}::$_"}
+        }
+    };
+
+    sub AUTOLOAD {
+        my $method = our $AUTOLOAD;
+        $method =~ s/.*:://o;
+        (my $prefix = $method) =~ s/_.+//;
+        die "変な関数よびだしてませんか？: $method" unless $prefix;
+        $_load_plugin->($prefix);
+        return main->can($method)->(@_);
+    }
 }
 
@@ -212 +199 @@
 }
 
-# TODO: CGI にはこのための環境変数ってなかったっけ?
 sub docroot () { $ENV{SCRIPT_NAME} || '' }
 
@@ -230 +216 @@
 }
 
-sub mobile_agent {
-    require_once('HTTP/MobileAgent.pm');
-    $STASH->{'HTTP::MobileAgent'} ||= HTTP::MobileAgent->new();
-}
-
-# HTTP::MobileAgent::Plugin::Charset よりポート。
-# cp932 の方が実績があるので優先させる方針。
-# Shift_JIS とかじゃなくて cp932 にしとかないと、諸問題にひっかかりがちなので注意
-sub _mobile_encoding {
-    my $ma = mobile_agent();
-    return 'utf-8' if $ma->is_non_mobile;
-    return 'utf-8' if $ma->is_docomo && $ma->xhtml_compliant; # docomo の 3G 端末では UTF-8 の表示が保障されている
-    return 'utf-8' if $ma->is_softbank && $ma->is_type_3gc;   # SoftBank 3G の一部端末は CP932 だと絵文字を送ってこない不具合がある
-    return 'cp932';                                           # au は HTTPS のときに UTF-8 だと文字化ける場合がある
-}
-
-# charset に設定する文字列を生成
-sub charset {
-    +{ 'utf-8' => 'UTF-8', cp932 => 'Shift_JIS' }->{_mobile_encoding()};
-}
-
-# HTTP の入り口んとこで decode させる用
-sub decode_input {
-    my ($txt, $fb) = @_;
-    Encode::decode(_mobile_encoding(), $txt, $fb);
-}
-
-# 出力直前んとこで encode させる用
-sub encode_output {
-    my ($txt, $fb) = @_;
-    Encode::encode(_mobile_encoding(), $txt, $fb);
+{
+    package MENTA::Util;
+    # ユーティリティメソッドたち。
+    # これらのメソッドは一般ユーザーはよぶべきではない。
+
+    # HTTP::MobileAgent::Plugin::Charset よりポート。
+    # cp932 の方が実績があるので優先させる方針。
+    # Shift_JIS とかじゃなくて cp932 にしとかないと、諸問題にひっかかりがちなので注意
+    sub _mobile_encoding {
+        my $ma = MENTA->context->mobile_agent();
+        return 'utf-8' if $ma->is_non_mobile;
+        return 'utf-8' if $ma->is_docomo && $ma->xhtml_compliant; # docomo の 3G 端末では UTF-8 の表示が保障されている
+        return 'utf-8' if $ma->is_softbank && $ma->is_type_3gc;   # SoftBank 3G の一部端末は CP932 だと絵文字を送ってこない不具合がある
+        return 'cp932';                                           # au は HTTPS のときに UTF-8 だと文字化ける場合がある
+    }
+
+    # HTTP の入り口んとこで decode させる用
+    sub decode_input {
+        my ($txt, $fb) = @_;
+        Encode::decode(_mobile_encoding(), $txt, $fb);
+    }
+
+    # 出力直前んとこで encode させる用
+    sub encode_output {
+        my ($txt, $fb) = @_;
+        Encode::encode(_mobile_encoding(), $txt, $fb);
+    }
+
+    # charset に設定する文字列を生成
+    sub _charset {
+        +{ 'utf-8' => 'UTF-8', cp932 => 'Shift_JIS' }->{_mobile_encoding()};
+    }
+
+    # 一回ロードしたクラスは二度ロードしないための仕組み。
+    {
+        my $required = {};
+        sub require_once {
+            my $path = shift;
+            return if $required->{$path};
+            require $path;
+            $required->{$path} = 1;
+        }
+    }
 }
 

lang/perl/MENTOS/trunk/lib/MENTA/CGI.pm

@@ -17 +17 @@
               and $self->{'.globals'}->{'NO_UNDEF_PARAMS'};
         $value =~ tr/\000//d if $self->{'.globals'}->{'NO_NULL'};
-        $value = main::decode_input( $value ); # XXX この行だけ変えてる
+        $value = MENTA::Util::decode_input( $value ); # XXX この行だけ変えてる
         push @{ $self->{$param} }, $value;
         unless ( $self->{'.fieldnames'}->{$param} ) {

lang/perl/MENTOS/trunk/lib/MENTA/Dispatch.pm

@@ -31 +31 @@
             }
         } elsif (-f $controller_mt) {
-            my $out = main::__render_partial("${path}.mt", main::controller_dir());
-            $out = main::encode_output($out);
+            MENTA::Util::require_once('MENTA/TemplateLoader.pm');
+            my $tmpldir = main::controller_dir();
+            my $out = MENTA::TemplateLoader::__load("${tmpldir}/${path}.mt", main::controller_dir());
+            $out = MENTA::Util::encode_output($out);
             main::finalize($out);
         } else {
@@ -48 +50 @@
 sub show_static {
     my $path = shift;
+    MENTA::Util::require_once('Cwd.pm');
+    MENTA::Util::require_once('File/Spec.pm');
+    $path = Cwd::realpath($path);
+    my $appdir = Cwd::realpath(File::Spec->catfile(Cwd::cwd(), 'app', 'static'));
+    if (index($path, $appdir) != 0) {
+        die "どうやら攻撃されているようだ: $path";
+    }
     open my $fh, '<', $path or die "ファイルを開けません: ${path}: $!";
     binmode $fh;

lang/perl/MENTOS/trunk/lib/MENTA/Plugin.pm

@@ -1 +1 @@
 package MENTA::Plugin;
+use strict;
+use warnings;
+use utf8;
 
 sub import {
@@ -7 +10 @@
     utf8->import;
 
+    no strict 'refs';
     for (qw/config data_dir/) {
         *{"${pkg}::$_"} = *{"main::$_"}

lang/perl/MENTOS/trunk/lib/MENTA/TemplateLoader.pm

@@ -21 +21 @@
         my $tmplcode = eval $code;
         die $@ if $@;
-        $out = $tmplcode->();
+        $out = $tmplcode->(@params);
         __update_cache($path, $code);
     }
@@ -29 +29 @@
 sub __compile {
     my ($path) = @_;
-    main::require_once('MENTA/Template.pm');
+    MENTA::Util::require_once('MENTA/Template.pm');
+    my $src = do {
+        open my $fh, '<:utf8', $path or die "${path} を読み込み用に開けません: $!";
+        my $s = do { local $/; join '', <$fh> };
+        close $fh;
+        $s;
+    };
     my $t = MENTA::Template->new;
-    $t->parse(main::read_file($path));
+    $t->parse($src);
     $t->build();
     my $code = $t->code();

lang/perl/MENTOS/trunk/menta.cgi

@@ -1 +1 @@
 #!perl
-use lib 'lib', 'extlib';
+BEGIN {
+    unshift @INC, 'lib', 'extlib';
+};
 use MENTA;
 # -- ここまではおまじない --
@@ -13 +15 @@
         # キャッシュディレクトリ
         cache_dir => 'cache',
+        # ブラウザにエラーを表示するかどうか
+        fatals_to_browser => 1,
     },
     # あなたのアプリの設定
@@ -22 +26 @@
     },
 });
+
+# 以下、あなたのプログラム
+

lang/perl/MENTOS/trunk/plugins/blog.pl

@@ -3 +3 @@
 use POSIX qw(strftime);
 
+sub blog_file_write {
+    my ( $fname, $stuff ) = @_;
+    open my $fh, '>:utf8', $fname
+      or die "${fname} を書き込み用に開けません: $!";
+    print $fh $stuff;
+    close $fh;
+}
+
 sub blog_top_url {
-    my $url = $ENV{SCRIPT_NAME};
+    my $url = ::docroot;
     $url =~ s!menta\.cgi!!g;
     $url || '/';
@@ -10 +18 @@
 
 sub blog_read_entry {
-    my ($file, $mode) = @_;
-    my $mtime = (stat $file)[9];
-    my $content = ::read_file($file);
-    my $data_dir = ::data_dir;
-    my $static_dir = ::static_dir;
-    $file =~ s!.*?([^/]+)\.txt$!$1!;
-    my $photo = "${file}.jpg";
+    my ($fname, $mode) = @_;
+    my $mtime = (stat $fname)[9];
+    open my $fh, '<:utf8', $fname
+      or die "${fname} を読み込み用に開けません: $!";
+    my $content = do { local $/; join '', <$fh> };
+    close $fh;
+    my $data_dir = data_dir;
+    my $static_dir = ::docroot . '/static/';
+    $fname =~ s!.*?([^/]+)\.txt$!$1!;
+    my $photo = "${fname}.jpg";
     $photo = '' unless -f "${static_dir}/${photo}";
     my $entry = {
-        id => $file,
+        id => $fname,
         title => '',
         description => '',