root/lang/perl/HTTP-Engine/trunk/lib/HTTP/Engine.pm @ 10759

Revision 10759, 5.7 kB (checked in by marcus, 7 years ago)

Changed wording in pod

Line 
1package HTTP::Engine;
2use strict;
3use warnings;
4BEGIN { eval "package HTTPEx; sub dummy {} 1;" }
5use base 'HTTPEx';
6use Class::Component;
7our $VERSION = '0.0.2';
8
9use Carp;
10use Scalar::Util;
11use URI;
12
13use HTTP::Engine::Context;
14use HTTP::Engine::Request;
15use HTTP::Engine::Response;
16
17__PACKAGE__->load_components(qw/Plaggerize Autocall::InjectMethod/);
18
19sub new {
20    my ($class, %opts) = @_;
21
22    my $self = $class->NEXT( 'new' => { config => delete $opts{config} } );
23    $self->set_handle_request(delete $opts{handle_request}) if $opts{handle_request};
24
25    $self->conf->{global}->{log}->{fh} ||= \*STDERR;
26
27    return $self;
28}
29
30sub run { die "404 Engine not found!" }
31
32sub set_handle_request {
33    my($self, $callback) = @_;
34    croak 'please CODE refarence' unless $callback && ref($callback) eq 'CODE';
35    $self->{handle_request} = $callback;
36}
37
38sub prepare_request {}
39sub prepare_connection {}
40sub prepare_query_parameters {}
41sub prepare_headers {}
42sub prepare_cookie {}
43sub prepare_path {}
44sub prepare_body {}
45sub prepare_body_parameters {}
46sub prepare_parameters {}
47sub prepare_uploads {}
48sub errors { shift->{errors} }
49sub push_errors { push @{ shift->{errors} }, @_ }
50sub clear_errors { shift->{errors} = [] }
51
52sub handle_request {
53    my $self = shift;
54
55    $self->clear_errors();
56
57    $self->run_hook( 'initialize' );
58
59    my $context = HTTP::Engine::Context->new({
60        engine => $self,
61        req    => HTTP::Engine::Request->new,
62        res    => HTTP::Engine::Response->new,
63        conf   => $self->conf,
64    });
65    if (my %env = @_) {
66        $context->env(\%env);
67    } else {
68        $context->env(\%ENV);
69    }
70    for my $method (qw/ request connection query_parameters headers cookie path body body_parameters parameters uploads /) {
71        my $method = "prepare_$method";
72        $self->$method($context);
73    }
74
75    $self->run_hook( before_handle_request => $context );
76    my $ret = eval {
77        $self->{handle_request}->($context);
78    };
79    {
80        local $@;
81        $self->run_hook( after_handle_request => $context );
82    }
83    if (my $e = $@) {
84        $self->push_errors($e);
85        $self->run_hook('handle_error', $context);
86    }
87    $self->finalize($context);
88
89    $ret;
90}
91
92sub finalize {
93    my($self, $c) = @_;
94
95    $self->finalize_headers($c); # finalize_headers
96    $c->res->body('') if $c->req->method eq 'HEAD';
97    $self->finalize_body($c); # finalize_body
98}
99
100sub finalize_headers {
101    my($self, $c) = @_;
102    return if $c->res->{_finalized_headers};
103
104    # Handle redirects
105    if (my $location = $c->res->redirect ) {
106        $self->log( debug => qq/Redirecting to "$location"/ );
107        $c->res->header( Location => $self->absolute_url($c, $location) );
108        $c->res->body($c->res->status . ': Redirect') unless $c->res->body;
109    }
110
111    # Content-Length
112    $c->res->content_length(0);
113    if ($c->res->body && !$c->res->content_length) {
114        # get the length from a filehandle
115        if (Scalar::Util::blessed($c->res->body) && $c->res->body->can('read')) {
116            if (my $stat = stat $c->res->body) {
117                $c->res->content_length($stat->size);
118            } else {
119                $self->log( warn => 'Serving filehandle without a content-length' );
120            }
121        } else {
122            $c->res->content_length(bytes::length($c->res->body));
123        }
124    }
125
126    $c->res->content_type('text/html') unless $c->res->content_type;
127
128    # Errors
129    if ($c->res->status =~ /^(1\d\d|[23]04)$/) {
130        $c->res->headers->remove_header("Content-Length");
131        $c->res->body('');
132    }
133
134    $self->finalize_cookies($c);
135    $self->finalize_output_headers($c);
136
137    # Done
138    $c->res->{_finalized_headers} = 1;
139}
140
141sub finalize_cookies {}
142sub finalize_output_headers {}
143sub finalize_body {
144    my $self = shift;
145    $self->finalize_output_body(@_);
146}
147sub finalize_output_body {}
148
149
150sub absolute_url {
151    my($self, $c, $location) = @_;
152
153    unless ($location =~ m!^https?://!) {
154        my $base = $c->req->base;
155        my $url = sprintf '%s://%s', $base->scheme, $base->host;
156        unless (($base->scheme eq 'http' && $base->port eq '80') ||
157               ($base->scheme eq 'https' && $base->port eq '443')) {
158            $url .= ':' . $base->port;
159        }
160        $url .= $base->path;
161        $location = URI->new_abs($location, $url);
162    }
163    $location;
164}
165
1661;
167__END__
168
169=encoding utf8
170
171=head1 NAME
172
173HTTP::Engine - Web Server Gateway Interface and HTTP Server Engine Drivers (Yet Another Catalyst::Engine)
174
175=head1 SYNOPSIS
176
177  use HTTP::Engine;
178  HTTP::Engine->new(
179    config         => 'config.yaml',
180    handle_request => sub {
181      my $c = shift;
182      $c->res->body( Dumper($e->req) );
183    }
184  )->run;
185
186=head1 CONCEPT RELEASE
187
188Version 0.0.x is a concept release, the internal interface is still fluid.
189It is mostly based on the code of Catalyst::Engine.
190
191=head1 DESCRIPTION
192
193HTTP::Engine is a bare-bones, extensible HTTP engine. It is not a
194socket binding server. The purpose of this module is to be an
195adaptor between various HTTP-based logic layers and the actual
196implementation of an HTTP server, such as, mod_perl and FastCGI
197
198=head1 PLUGINS
199
200For all non-core plugins (consult #codrepos first), use the HTTPEx::
201namespace. For example, if you have a plugin module named "HTTPEx::Plugin::Foo",
202you could load it as
203
204  use HTTP::Engine;
205  HTTP::Engine->load_plugins(qw( +HTTPEx::Plugin::Foo ));
206
207=head1 AUTHOR
208
209Kazuhiro Osawa E<lt>ko@yappo.ne.jpE<gt>
210
211=head1 COMMITTERS
212
213lestrrat
214
215tokuhirom
216
217=head1 SEE ALSO
218
219=head1 REPOSITORY
220
221  svn co http://svn.coderepos.org/share/lang/perl/HTTP-Engine/trunk HTTP-Engine
222
223HTTP::Engine's Subversion repository is hosted at L<http://coderepos.org/share/>.
224patches and collaborators are welcome.
225
226=head1 LICENSE
227
228This library is free software; you can redistribute it and/or modify
229it under the same terms as Perl itself.
230
231=cut
Note: See TracBrowser for help on using the browser.