Changeset 18361 for lang/perl

Timestamp:

08/28/08 08:08:56 (3 months ago)

Author:

tokuhirom

Message:

rewrote

Location:

lang/perl/HTTP-Engine-Compat/trunk

Files:

• lib/HTTP/Engine/Compat.pm (modified) (6 diffs)
• lib/HTTP/Engine/Compat/Context.pm (modified) (1 diff)
• t/010_core/context.t (modified) (1 diff)
• t/010_core/middleware-wrap.t (modified) (1 diff)
• t/010_core/request_processor-response_error.t (modified) (1 diff)
• t/010_core/response_redirect.t (modified) (1 diff)

lang/perl/HTTP-Engine-Compat/trunk/lib/HTTP/Engine/Compat.pm

@@ -5 +5 @@
 #extends 'HTTP::Engine';
 use HTTP::Engine;
-use HTTP::Engine::RequestProcessor;
 use HTTP::Engine::Request;
+use HTTP::Engine::ResponseFinalizer;
 use HTTP::Engine::Compat::Context;
+use HTTP::Engine::Role::Interface;
+
+our $rh;
+my @wraps;
 
 sub import {
-    my($class, %args) = @_;
-
-    $class->_wrap( \&_extract_context );
+    my ( $class, %args ) = @_;
 
     $class->_modify(
@@ -43 +45 @@
 
                     if (@_) {
-                        $self->location( shift );
+                        $self->location(shift);
                         $self->status( shift || 302 );
                     }
@@ -54 +56 @@
 
     $class->_modify(
-        'HTTP::Engine::ResponseFinalizer',
+        'HTTP::Engine',
         sub {
             my $meta = shift;
             $meta->add_around_method_modifier(
-                finalize => sub {
-                    my $code = shift;
-                    my ($self, $req, $res) = @_;
-                    if (my $location = $res->location) {
-                        $res->header( Location => $req->absolute_url($location) );
-                        $res->body($res->status . ': Redirect') unless $res->body;
-                    }
-                    $code->(@_);
+                'new' => sub {
+                    my ($next, @args) = @_;
+                    my $instance = $next->(@args);
+
+                    $class->_setup_interface($instance->interface->meta);
+                    $instance;
                 },
-            )
-        }
-    );
+            );
+        },
+    );
+
+    do {
+        my $meta =
+          Class::MOP::Class->initialize('HTTP::Engine::ResponseFinalizer')
+          or die "cannot get meta";
+        $meta->add_around_method_modifier(
+            finalize => sub {
+                my $code = shift;
+                my ( $self, $req, $res ) = @_;
+                if ( my $location = $res->location ) {
+                    $res->header( Location => $req->absolute_url($location) );
+                    $res->body( $res->status . ': Redirect' ) unless $res->body;
+                }
+                $code->(@_);
+            },
+        );
+    };
 
     return unless $args{middlewares} && ref $args{middlewares} eq 'ARRAY';
-    $class->load_middlewares(@{ $args{middlewares} });
+    $class->load_middlewares( @{ $args{middlewares} } );
+}
+
+my %initialized;
+sub _setup_interface {
+    my ($class, $inter) = @_;
+
+    $inter->make_mutable;
+
+    $inter->add_method(
+        'call_handler' => sub {
+            my $req = shift;
+            $rh->( $req );
+        }
+    );
+    $class->_wrap( $inter, \&_extract_context );
+    $class->_wrap( $inter, $_ ) for @wraps;
+
+    $inter->make_mutable;
+    $inter->add_method(
+        'handle_request' => sub {
+            my ( $self, %args ) = @_;
+
+            my $c = HTTP::Engine::Compat::Context->new(
+                req => HTTP::Engine::Request->new(
+                    request_builder => $self->request_builder,
+                    %args,
+                ),
+                res => HTTP::Engine::Response->new( status => 200 ),
+            );
+
+            eval {
+                local $rh = $self->request_handler;
+                my $res = $inter->get_method('call_handler')->($c);
+                if (Scalar::Util::blessed($res) && $res->isa('HTTP::Engine::Response')) {
+                    $c->res( $res );
+                }
+            };
+            if ( my $e = $@ ) {
+                print STDERR $e;
+                $c->res->status(500);
+                $c->res->body('internal server error');
+            }
+
+            HTTP::Engine::ResponseFinalizer->finalize( $c->req => $c->res );
+
+            $self->response_writer->finalize( $c->req => $c->res );
+            return $c->res;
+        },
+    );
+
+    $inter->make_immutable;
 }
 
@@ -101 +169 @@
 
     if ($pkg->meta->has_method('wrap')) {
-        $class->_wrap( $pkg->meta->get_method('wrap')->body );
-        $class->_wrap( \&_extract_context );
+        push @wraps, $pkg->meta->get_method('wrap')->body;
     }
 }
 
 sub _wrap {
-    my ($class, $code ) = @_;
-    $class->_modify(
-        'HTTP::Engine::RequestProcessor',
-        sub {
-            my $meta = shift;
-            $meta->add_around_method_modifier(
-                call_handler => $code,
-            );
-        },
-    );
+    my ($class, $interface, $code ) = @_;
+    $interface->make_mutable;
+    $interface->add_around_method_modifier(
+        call_handler => $code,
+    );
+    $interface->make_immutable;
 }
 
@@ -124 +187 @@
     # process argument
     if (Scalar::Util::blessed($arg) ne 'HTTP::Engine::Compat::Context') {
-        $arg = HTTP::Engine::Compat::Context->new(
-            req => $arg,
-            res => HTTP::Engine::Response->new(
-                status => 200
-            ),
-        );
     }
 
@@ -148 +205 @@
     my ($class, $target, $cb) = @_;
     my $meta = $target->meta;
-    $meta->make_mutable;
+    $meta->make_mutable if $meta->can('make_mutable');
     $cb->($meta);
-    $meta->make_immutable;
+    $meta->make_immutable if $meta->can('make_immutable');
 }
 

lang/perl/HTTP-Engine-Compat/trunk/lib/HTTP/Engine/Compat/Context.pm

@@ -2 +2 @@
 use Moose;
 use HTTP::Engine::Request;
-use HTTP::Engine::RequestBuilder;
 use HTTP::Engine::Response;
 

lang/perl/HTTP-Engine-Compat/trunk/t/010_core/context.t

@@ -3 +3 @@
 use HTTP::Engine::Compat;
 use Scalar::Util qw/refaddr/;
-use Test::More tests => 3;
+use Test::More tests => 5;
 
-my $c = HTTP::Engine::Compat::Context->new(
-    req => HTTP::Engine::Request->new(
-        _connection => {
-            input_handle  => \*STDIN,
-            output_handle => \*STDIN,
-            env           => \%ENV,
+HTTP::Engine->new(
+    interface => {
+        module => 'Test',
+        args => { },
+        request_handler => sub {
+            my $c = shift;
+            isa_ok $c, 'HTTP::Engine::Compat::Context';
+            is $c->req->path, '/foo';
+            is refaddr( $c->req ), refaddr( $c->request ),  'alias';
+            is refaddr( $c->res ), refaddr( $c->response ), 'alias';
+            is refaddr( $c->req->context ), refaddr($c), 'trigger';
         },
-        request_builder => HTTP::Engine::RequestBuilder->new,
-    )
-);
-is refaddr( $c->req ), refaddr( $c->request ),  'alias';
-is refaddr( $c->res ), refaddr( $c->response ), 'alias';
-is refaddr( $c->req->context ), refaddr($c), 'trigger';
+    },
+)->run(HTTP::Request->new('GET', '/foo'));
+

lang/perl/HTTP-Engine-Compat/trunk/t/010_core/middleware-wrap.t

@@ -13 +13 @@
 our $wrap;
 is $main::wrap, 'ok';
-is $response->content, 'OK!';
+is $response->body, 'OK!';

lang/perl/HTTP-Engine-Compat/trunk/t/010_core/request_processor-response_error.t

@@ -38 +38 @@
             $code->();
         } HTTP::Request->new( GET => 'http://localhost/');
-        is $res->code, 200;
-        is $res->content, $content, $content;
+        is $res->status, 200;
+        is $res->body, $content, $content;
     }
 }

lang/perl/HTTP-Engine-Compat/trunk/t/010_core/response_redirect.t

@@ -4 +4 @@
 use HTTP::Engine::Compat;
 use HTTP::Engine::Compat::Context;
-use HTTP::Engine::ResponseFinalizer;
+use t::Utils;
 
 do {
-    my $c = HTTP::Engine::Compat::Context->new(
-        req => HTTP::Engine::Request->new(
-            _connection => {
-                input_handle  => \*STDIN,
-                output_handle => \*STDIN,
-                env           => \%ENV,
-            },
-            request_builder => HTTP::Engine::RequestBuilder->new,
-        )
-    );
-    $c->req->method('POST');
-    $c->req->base(URI->new('http://d.hatena.ne.jp/'));
-    $c->res->redirect('/TKSK/');
-    HTTP::Engine::ResponseFinalizer->finalize($c->req, $c->res);
-    is $c->res->header('Location'), 'http://d.hatena.ne.jp/TKSK/';
-    is $c->res->status, 302;
-    is $c->res->redirect, '/TKSK/';
-    is $c->res->body, '302: Redirect';
+    my $res = run_engine {
+        my $c = shift;
+        $c->res->redirect('/TKSK/');
+    } HTTP::Request->new('POST', 'http://d.hatena.ne.jp/');
+    is $res->header('Location'), 'http://d.hatena.ne.jp/TKSK/';
+    is $res->status, 302;
+    is $res->redirect, '/TKSK/';
+    is $res->body, '302: Redirect';
 };
 
 do {
-    my $c = HTTP::Engine::Compat::Context->new(
-        req => HTTP::Engine::Request->new(
-            _connection => {
-                input_handle  => \*STDIN,
-                output_handle => \*STDIN,
-                env           => \%ENV,
-            },
-            request_builder => HTTP::Engine::RequestBuilder->new,
-        )
-    );
-    $c->req->method('GET');
-    $c->req->base(URI->new('http://d.hatena.ne.jp/'));
-    $c->res->body('OK');
-    $c->res->redirect('/TKSK/' => 303);
-    HTTP::Engine::ResponseFinalizer->finalize($c->req, $c->res);
-    is $c->res->header('Location'), 'http://d.hatena.ne.jp/TKSK/';
-    is $c->res->status, 303;
-    is $c->res->redirect, '/TKSK/';
-    is $c->res->body, 'OK';
+    my $res = run_engine {
+        my $c = shift;
+        $c->res->body('OK');
+        $c->res->redirect('/TKSK/' => 303);
+    } HTTP::Request->new('GET', 'http://d.hatena.ne.jp');
+    is $res->header('Location'), 'http://d.hatena.ne.jp/TKSK/';
+    is $res->status, 303;
+    is $res->redirect, '/TKSK/';
+    is $res->body, 'OK';
 };