File Coverage

blib/lib/Amon2/Web.pm
Criterion Covered Total %
statement 89 122 72.9
branch 11 14 78.5
condition 4 13 30.7
subroutine 23 35 65.7
pod 17 20 85.0
total 144 204 70.5


line stmt bran cond sub pod time code
1             package Amon2::Web;
2 17     17   242008 use strict;
  17         56  
  17         489  
3 17     17   79 use warnings;
  17         32  
  17         442  
4 17     17   787 use Amon2::Util ();
  17         32  
  17         385  
5 17     17   6871 use Amon2::Trigger qw/add_trigger call_trigger get_trigger_code/;
  17         44  
  17         1157  
6 17     17   5244 use Encode ();
  17         127319  
  17         351  
7 17     17   1037 use Plack::Util ();
  17         19380  
  17         236  
8 17     17   4204 use URI::Escape ();
  17         13256  
  17         394  
9 17     17   6448 use Amon2::Web::Request;
  17         48  
  17         571  
10 17     17   7443 use Amon2::Web::Response;
  17         50  
  17         472  
11 17     17   138 use Scalar::Util ();
  17         48  
  17         273  
12 17     17   86 use Plack::Util;
  17         33  
  17         2194  
13              
14             # -------------------------------------------------------------------------
15             # Hook points:
16             # You can override these methods.
17 22     22 1 137 sub create_request { Amon2::Web::Request->new($_[1], $_[0]) }
18 47     47 1 183 sub create_response { shift; Amon2::Web::Response->new(@_) }
  47         271  
19 0     0 1 0 sub create_view { die "This is abstract method: create_view" }
20 0     0 1 0 sub dispatch { die "This is abstract method: dispatch" }
21              
22 0     0 1 0 sub html_content_type { 'text/html; charset=UTF-8' }
23 0         0 BEGIN {
24 17   50 17   126 my $encoding = Encode::find_encoding('utf-8') || die;
25 26     26 1 89 sub encoding { $encoding }
26             }
27              
28             sub session {
29 0     0 0 0 my $self = shift;
30 0   0     0 my $klass = ref $self || $self;
31              
32 0         0 require Plack::Session;
33 17     17   4341 no strict 'refs';
  17         36  
  17         20832  
34 0         0 *{"${klass}::session"} = sub {
35 0     0   0 my $self = shift;
36 0   0     0 $self->{session} ||= Plack::Session->new($self->request->env);
37 0         0 };
38              
39 0         0 return $self->session();
40             }
41              
42             # -------------------------------------------------------------------------
43             # Attributes:
44 40     40 1 155 sub request { $_[0]->{request} }
45 24     24 1 296 sub req { $_[0]->{request} }
46              
47             # -------------------------------------------------------------------------
48             # Methods:
49              
50             sub redirect {
51 9     9 1 45 my ($self, $location, $params) = @_;
52 9         13 my $url = do {
53 9 100       53 if ($location =~ m{^https?://}i) {
54 7         16 $location;
55             } else {
56 2         11 my $url = $self->request->base;
57 2         7869 $url =~ s{/+$}{};
58 2         47 $location =~ s{^/+([^/])}{/$1};
59 2         8 $url .= $location;
60             }
61             };
62 9 100       23 if (my $ref_params = ref $params) {
63 6 100       17 if ($ref_params eq 'ARRAY') {
    50          
64 5         18 my $uri = URI->new($url);
65 5         352 $uri->query_form($uri->query_form, map { Encode::encode($self->encoding, $_) } @$params);
  10         7891  
66 5         760 $url = $uri->as_string;
67             } elsif ($ref_params eq 'HASH') {
68 1         3 my @ary;
69 1         4 my $encoding = $self->encoding;
70 1         8 while (my ($k, $v) = each %$params) {
71 1         7 push @ary, Encode::encode($encoding, $k);
72 1         23 push @ary, Encode::encode($encoding, $v);
73             }
74 1         21 my $uri = URI->new($url);
75 1         72 $uri->query_form($uri->query_form, @ary);
76 1         254 $url = $uri->as_string;
77             }
78             }
79 9         63 return $self->create_response(
80             302,
81             ['Location' => $url],
82             []
83             );
84             }
85              
86             sub create_simple_status_page {
87 0     0 1 0 my ($self, $code, $message) = @_;
88 0         0 my $codestr = Plack::Util::encode_html($code);
89 0         0 $message = Plack::Util::encode_html($message);
90 0         0 my $content = <<"...";
91             <!doctype html>
92             <html>
93             <head>
94             <meta charset=utf-8 />
95             <title>$codestr $message</title>
96             <style type="text/css">
97             body {
98             text-align: center;
99             font-family: 'Menlo', 'Monaco', Courier, monospace;
100             background-color: whitesmoke;
101             padding-top: 10%;
102             }
103             .number {
104             font-size: 800%;
105             font-weight: bold;
106             margin-bottom: 40px;
107             }
108             .message {
109             font-size: 400%;
110             }
111             </style>
112             </head>
113             <body>
114             <div class="number">$codestr</div>
115             <div class="message">$message</div>
116             </body>
117             </html>
118             ...
119 0         0 $self->create_response(
120             $code,
121             [
122             'Content-Type' => 'text/html; charset=utf-8',
123             'Content-Length' => length($content),
124             ],
125             [$content]
126             );
127             }
128              
129             sub res_403 {
130 0     0 1 0 my ($self) = @_;
131 0         0 return $self->create_simple_status_page(403, 'Forbidden');
132             }
133              
134             sub res_404 {
135 0     0 1 0 my ($self) = @_;
136 0         0 return $self->create_simple_status_page(404, 'File Not Found');
137             }
138              
139             sub res_405 {
140 0     0 1 0 my ($self) = @_;
141 0         0 return $self->create_simple_status_page(405, 'Method Not Allowed');
142             }
143              
144             sub res_500 {
145 0     0 0 0 my ($self) = @_;
146 0         0 return $self->create_simple_status_page(500, 'Internal Server Error');
147             }
148              
149             sub to_app {
150 8     8 1 270 my ($class, ) = @_;
151 8     22   38 return sub { $class->handle_request(shift) };
  22         212263  
152             }
153              
154             sub handle_request {
155 22     22 0 56 my ($class, $env) = @_;
156              
157 22         82 my $req = $class->create_request($env);
158 22         101 my $self = $class->new(
159             request => $req,
160             );
161 22         76 my $guard = $self->context_guard();
162              
163 22         35 my $response;
164 22         82 for my $code ($self->get_trigger_code('BEFORE_DISPATCH')) {
165 4         11 $response = $code->($self);
166 4 100 66     152 goto PROCESS_END if Scalar::Util::blessed($response) && $response->isa('Plack::Response');
167             }
168 20 50       74 $response = $self->dispatch() or die "cannot get any response";
169 22         338 PROCESS_END:
170             $self->call_trigger('AFTER_DISPATCH' => $response);
171              
172 22         88 return $response->finalize;
173             }
174              
175             sub uri_for {
176 1     1 1 11 my ($self, $path, $query) = @_;
177 1   50     6 my $root = $self->req->{env}->{SCRIPT_NAME} || '/';
178 1         5 $root =~ s{([^/])$}{$1/};
179 1         4 $path =~ s{^/}{};
180              
181 1         2 my @q;
182 1         6 while (my ($key, $val) = each %$query) {
183 1         5 $val = URI::Escape::uri_escape(Encode::encode($self->encoding, $val));
184 1         156 push @q, "${key}=${val}";
185             }
186 1 50       10 $root . $path . (scalar @q ? '?' . join('&', @q) : '');
187             }
188              
189             sub render {
190 0     0 1   my $self = shift;
191 0           my $html = $self->create_view()->render(@_);
192              
193 0           for my $code ($self->get_trigger_code('HTML_FILTER')) {
194 0           $html = $code->($self, $html);
195             }
196              
197 0           $html = $self->encode_html($html);
198              
199 0           return $self->create_response(
200             200,
201             [
202             'Content-Type' => $self->html_content_type,
203             'Content-Length' => length($html)
204             ],
205             $html,
206             );
207             }
208              
209             # You can override this method on your application.
210             sub encode_html {
211 0     0 1   my ($self, $html) = @_;
212 0           return Encode::encode($self->encoding, $html);
213             }
214              
215             1;
216             __END__
217              
218             =head1 NAME
219              
220             Amon2::Web - Web Application Base.
221              
222             =head1 SYNOPSIS
223              
224             package MyApp;
225             use parent qw/Amon2/;
226              
227             package MyApp::Web;
228             use parent qw/MyApp Amon2::Web/;
229              
230             =head1 DESCRIPTION
231              
232             This is a web application base class.
233              
234             =head1 METHODS
235              
236             =over 4
237              
238             =item C<< $c->create_request() >>
239              
240             Create new request object from C<< $c >>.
241              
242             You can override this method to change request object's class.
243              
244             =item C<< $c->create_response($code, \@headers, \@body) >>
245              
246             Create new response object.
247              
248             You can override this method to change response object's class.
249              
250             =item C<< $c->create_view() >>
251              
252             Create new view object. View object should have C<< $view->render(@_) >> method.
253              
254             You can override this method to change view object's class.
255              
256             =item C<< $c->dispatch() : Plack::Response >>
257              
258             Do dispatch request. This method must return instance of L<Plack::Response>.
259              
260             You can override this method to change behavior.
261              
262             =item C<< $c->html_content_type() : Str >>
263              
264             Returns default Content-Type value for the HTML response.
265              
266             You can override this method to change behavior.
267              
268             =item C<< $c->request() : Plack::Request >>
269              
270             =item C<< $c->req() : Plack::Request >>
271              
272             This is a accessor method to get the request object in this context.
273              
274             =item C<< $c->redirect($location : Str, \%parameters) : Plack::Response >>
275              
276             Create a response object to redirect for C< $location > with C<< \%parameters >>.
277              
278             $c->redirect('/foo', +{bar => 3})
279              
280             is same as following(if base URL is http://localhost:5000/)
281              
282             $c->create_response(302, [Location => 'http://localhost:5000/foo?bar=3'])
283              
284             =item C<< $c->res_403() >>
285              
286             Create new response object which has 403 status code.
287              
288             =item C<< $c->res_404() >>
289              
290             Create new response object which has 404 status code.
291              
292             =item C<< $c->res_405() >>
293              
294             Create new response object which has 405 status code.
295              
296             =item C<< $c->create_simple_status_page($code, $message) >>
297              
298             Create a new response object which represents specified status code.
299              
300             =item C<< MyApp->to_app() : CodeRef >>
301              
302             Create an instance of PSGI application.
303              
304             =item C<< $c->uri_for($path: Str, \%args) : Str >>
305              
306             Create URI from C<< $path >> and C<< \%args >>.
307              
308             This method returns relative URI.
309              
310             =item C<< $c->render($tmpl[, @args|%args]) : Plack::Web::Response >>
311              
312             This method renders HTML.
313              
314             =item C<< $c->encoding() >>
315              
316             Return a encoding object using C<< Encode::find_encoding() >>.
317              
318             You can override this method to change behavior.
319              
320             =item C<< $c->encode_html($html) : Str >>
321              
322             This method encodes HTML from bytes.
323              
324             You can override this method to change behavior.
325              
326             =back