Changeset 24551 for lang/perl/NanoA

Timestamp:

11/21/08 15:13:04 (5 years ago)

Author:

kazuho

Message:

support for application-level plugin installation, prioritized plugin execution, update docs

Location:

lang/perl/NanoA/trunk

Files:

• app/system/tutorial.mt (modified) (4 diffs)
• lib/NanoA.pm (modified) (7 diffs)
• plugin/mobile.pm (modified) (1 diff)
• plugin/session.pm (modified) (2 diffs)

lang/perl/NanoA/trunk/app/system/tutorial.mt

@@ -138 +138 @@
 <h2 id="hooks">アプリケーション全体の共通処理</h2>
 
-<h2 id="session">セッション対応</h2>
-
-<p>
-各コントローラ (.pm ファイルまたは .mt ファイル) の中で plugin::session をロードすると、自動的にセッションクッキーが発行されるようになります。また、$app->session() 関数を呼んで <a href="http://d.hatena.ne.jp/tokuhirom/20081026/1224992245">HTTP::Session</a> オブジェクトを取得し、認証処理等を実現可能です。
+<h2 id="plugin">プラグイン機構</h2>
+
+<p>
+NanoA の動作を、プラグインを使って拡張することができます。プラグインは、各コントローラ (.pm ファイルまたは .mt ファイル) で use pluginname; するだけで適用されます。
+</p>
+
+<div class="pre_caption">例. セッションプラグインの適用 (.pm)</div>
+<pre>
+use plugin::session;
+</pre>
+
+<div class="pre_caption">例. セッションプラグインの適用 (.mt)</div>
+<pre>
+&#x3f; use plugin::session;
+</pre>
+
+<p>
+また、myapp/config.pm 内で use pluginname; すれば、同ディレクトリ内の全コントローラにプラグインが適用されます。例えば、全コントローラでモバイル対応機能を有効化したい、という場合は、こちらの手法が便利です。
+</p>
+
+<h2 id="session">セッションプラグイン</h2>
+
+<p>
+セッションプラグインをロードすると、自動的にセッションクッキーが発行されるようになります。また、$app->session() 関数を呼んで HTTP::Session オブジェクトを取得し、認証処理等を実現可能です。 
 </p>
 
@@ -149 +169 @@
 </pre>
 
+<p>
 <div class="pre_caption">セッション機能の有効化 (.mt)</div>
 <pre>
@@ -154 +175 @@
 </pre>
 
+</p>
+
 <div class="pre_caption">セッションオブジェクトの取得</div>
 <pre>
@@ -159 +182 @@
 </pre>
 
-<h2 id="mobile">ケータイ対応</h2>
-
-<p>
-各コントローラ (.pm ファイルまたは .mt ファイル) の中で plugin::mobile をロードすると、携帯端末にあわせて自動的に文字コードを変換して送受信するようになります。
+<h2 id="mobile">モバイルプラグイン</h2>
+
+<p>
+モバイルプラグインをロードすると、携帯端末にあわせて自動的に文字コードを変換して送受信するようになります。
 </p>
 

lang/perl/NanoA/trunk/lib/NanoA.pm

@@ -43 +43 @@
     my $self = shift;
     my $mode = shift;
-    my $hooks = $HOOKS{$mode}->{ref $self}
-        or return;
-    $_->($self, @_)
-        for @$hooks;
+    my $klass = ref $self;
+    my @hooks;
+    if (my $h = $HOOKS{$mode}->{$klass}) {
+        push @hooks, @$h;
+    }
+    if ($klass =~ /^([^:]+)/) {
+        if (my $h = $HOOKS{$mode}->{$1 . '::config'}) {
+            push @hooks, @$h;
+        }
+    }
+    return
+        unless @hooks;
+    $_->[0]->($self, @_)
+        for sort { $a->[1] <=> $b->[1] } @hooks;
 }
 
 sub register_hook {
-    my ($klass, $mode, $func) = @_;
-    die "unknown hook: $mode\n"
+    my ($klass, $mode, $func, $prio) = @_;
+    $prio ||= 50;
+    die 'unknown hook: ' . $mode. "\n"
         unless $HOOKS{$mode};
-    my $target = $HOOKS{$mode}->{ref $klass || $klass} ||= [];
-    return
-        if grep { $_ == $func } @$target;
-    push @$target, $func;
-    1;
+    my $hooks = $HOOKS{$mode}->{ref $klass || $klass} ||= [];
+    unless (grep { $_->[0] == $func } @$hooks) {
+        push @$hooks, [
+            $func,
+            $prio,
+        ];
+    }
 }
 
@@ -109 +122 @@
     my ($self, $uri, $status) = @_;
     $status ||= 302;
-    print "Status: $status\nLocation: $uri\n\n";
+    print 'Status: ', $status, "\nLocation: " . $uri . "\n\n";
     CGI::ExceptionManager::detach();
 }
@@ -161 +174 @@
         $ct .= "; charset=" . delete $headers->{-charset};
     }
-    print "Content-Type: $ct\n";
+    print 'Content-Type: ', $ct, "\n";
     foreach my $n (sort keys %$headers) {
         my $v = $headers->{$n};
@@ -168 +181 @@
         if (ref $v eq 'ARRAY') {
             foreach my $vv (@$v) {
-                print ucfirst($n), ": $vv\n";
+                print ucfirst($n), ': ', $vv, "\n";
             }
         } else {
-            print ucfirst($n), ": $v\n";
+            print ucfirst($n), ': ', $v, "\n";
         }
     }
@@ -189 +202 @@
     return if $LOADED{$mark_path};
     local $@;
-    if (do "$path") {
+    if (do $path) {
         $LOADED{$mark_path} = 1;
         return 1;
@@ -226 +239 @@
 sub read_file {
     my $fname = shift;
-    open my $fh, '<:utf8', $fname or die "cannot read $fname:$!";
+    open my $fh, '<:utf8', $fname or die 'cannot read ' . $fname. ":$!";
     my $s = do { local $/; join '', <$fh> };
     close $fh;
@@ -235 +248 @@
     my $module = shift;
     no strict 'refs';
-    *{"$module\::$_"} = \&{$_}
+    *{$module . '::' . $_} = \&{$_}
         for qw(escape_html);
 }

lang/perl/NanoA/trunk/plugin/mobile.pm

@@ -10 +10 @@
     my $pkg = caller;
     # add funcs to caller
-    NanoA::register_hook(
-        $pkg,
-        'prerun',
-        \&_prerun,
-    );
-    NanoA::register_hook(
-        $pkg,
-        'postrun',
-        \&_postrun,
-    );
+    NanoA::register_hook($pkg, 'prerun', \&_prerun, 0);
+    NanoA::register_hook($pkg, 'postrun', \&_postrun, 90);
 }
 

lang/perl/NanoA/trunk/plugin/session.pm

@@ -12 +12 @@
     my $pkg = caller;
     # add funcs to caller
-    NanoA::register_hook(
-        $pkg,
-        'postrun',
-        \&_postrun,
-    );
+    NanoA::register_hook($pkg, 'postrun', \&_postrun);
 }
+
+sub _postrun {
+    my ($app, $bodyref) = @_;
+    $app->session->header_filter($app);
+}
+
+no warnings 'redefine';
 
 sub NanoA::session {
@@ -31 +34 @@
 }
 
-sub _postrun {
-    my ($app, $bodyref) = @_;
-    $app->session->header_filter($app);
-}
-
 1;