File Coverage

blib/lib/PlackX/RouteBuilder.pm
Criterion Covered Total %
statement 70 106 66.0
branch 4 12 33.3
condition 0 5 0.0
subroutine 22 37 59.4
pod 0 14 0.0
total 96 174 55.1


line stmt bran cond sub pod time code
1             package PlackX::RouteBuilder;
2 2     2   543 use strict;
  2         4  
  2         76  
3 2     2   10 use warnings;
  2         4  
  2         112  
4             our $VERSION = '0.03';
5              
6 2     2   11 use Carp ();
  2         3  
  2         36  
7 2     2   12276 use Router::Simple;
  2         13625  
  2         63  
8 2     2   5603 use Try::Tiny;
  2         4532  
  2         158  
9 2     2   2864 use Plack::Request;
  2         191479  
  2         80  
10 2     2   24 use Scalar::Util qw(blessed);
  2         4  
  2         196  
11              
12             my $_ROUTER = Router::Simple->new;
13              
14             sub import {
15 2     2   12 my $caller = caller;
16              
17 2     2   12 no strict 'refs';
  2         4  
  2         68  
18 2     2   12 no warnings 'redefine';
  2         6  
  2         492  
19              
20 2         6 *{"${caller}::router"} = \&router;
  2         14  
21              
22 2         7 my @http_methods = qw/get post put del any/;
23 2         5 for my $http_method (@http_methods) {
24 10     5   37 *{"${caller}\::$http_method"} = sub { goto \&$http_method };
  10         47  
  5         463  
25             }
26              
27 2         29 strict->import;
28 2         2831 warnings->import;
29             }
30              
31             sub _stub {
32 10     10   13 my $name = shift;
33 10     0   52 return sub { Carp::croak("Can't call $name() outside router block") };
  0         0  
34             }
35              
36             {
37             my @declarations = qw(get post put del any);
38             for my $keyword (@declarations) {
39 2     2   18 no strict 'refs';
  2         5  
  2         174  
40             *$keyword = _stub $keyword;
41             }
42             }
43              
44             sub router (&) {
45 1     1 0 15 my $block = shift;
46              
47 1 50       8 if ($block) {
48 2     2   12 no warnings 'redefine';
  2         4  
  2         2445  
49 1     2   8 local *get = sub { do_get(@_) };
  2         7  
50 1     1   6 local *post = sub { do_post(@_) };
  1         5  
51 1     0   5 local *put = sub { do_put(@_) };
  0         0  
52 1     0   5 local *del = sub { do_del(@_) };
  0         0  
53 1     2   5 local *any = sub { do_any(@_) };
  2         8  
54 1         6 $block->();
55              
56 0     0   0 return sub { dispatch(shift) }
57 1         99 }
58             }
59              
60             # HTTP Methods
61             sub route {
62 5     5 0 9 my ( $pattern, $code, $methods ) = @_;
63 5 50       17 unless ( ref $code eq 'CODE' ) {
64 0         0 Carp::croak("The logic for $pattern must be CodeRef");
65             }
66              
67             $_ROUTER->connect(
68 12         50 $pattern,
69             { action => $code },
70 5         17 { method => [ map { uc $_ } @$methods ] }
71             );
72             }
73              
74             sub do_any {
75 2 100   2 0 6 if ( scalar @_ == 4 ) {
76 1         3 my ( $methods, $pattern, $code ) = @_;
77 1         3 route( $pattern, $code, $methods );
78             }
79             else {
80 1         3 my ( $pattern, $code ) = @_;
81 1         17 route( $pattern, $code, [ 'GET', 'POST', 'DELETE', 'PUT', 'HEAD' ] );
82             }
83             }
84              
85             sub do_get {
86 2     2 0 5 my ( $pattern, $code ) = @_;
87 2         10 route( $pattern, $code, [ 'GET', 'HEAD' ] );
88             }
89              
90             sub do_post {
91 1     1 0 4 my ( $pattern, $code ) = @_;
92 1         4 route( $pattern, $code, ['POST'] );
93             }
94              
95             sub do_put {
96 0     0 0   my ( $pattern, $code ) = @_;
97 0           route( $pattern, $code, ['PUT'] );
98             }
99              
100             sub do_del {
101 0     0 0   my ( $pattern, $code ) = @_;
102 0           route( $pattern, $code, ['DELETE'] );
103             }
104              
105             # dispatch
106             sub dispatch {
107 0     0 0   my $env = shift;
108 0 0         if ( my $match = $_ROUTER->match($env) ) {
109 0           my $req = Plack::Request->new($env);
110 0           return handle_request( $req, $match );
111             }
112             else {
113 0           return handle_not_found();
114             }
115             }
116              
117             sub handle_request {
118 0     0 0   my ( $req, $match ) = @_;
119 0           my $code = delete $match->{action};
120             my $res = try {
121 0     0     $code->( $req, $match );
122             }
123             catch {
124 0     0     my $e = shift;
125 0           return handle_exception($e);
126 0           };
127 0           return psgi_response($res);
128             }
129              
130             sub psgi_response {
131 0     0 0   my $res = shift;
132              
133 0           my $psgi_res;
134 0   0       my $res_type = ref($res) || '';
135 0 0 0       if ( blessed $res && $res->isa('Plack::Response') ) {
    0          
136 0           $psgi_res = $res->finalize;
137             }
138             elsif ( $res_type eq 'ARRAY' ) {
139 0           $psgi_res = $res;
140             }
141             else {
142 0           Carp::croak("unknown response type: $res_type. The response is $res");
143             }
144 0           $psgi_res;
145             }
146              
147             sub handle_exception {
148 0     0 0   my $e = shift;
149 0           warn "An internal error occured during processing request: $e";
150 0           return internal_server_error($e);
151             }
152              
153             sub handle_not_found {
154 0     0 0   return not_found();
155             }
156              
157             sub not_found {
158 0     0 0   [ 404, [], ['Not Found'] ];
159             }
160              
161             sub internal_server_error {
162 0     0 0   my $e = shift;
163 0           [ 500, [], [ 'Internal server error: ' . $e ] ];
164             }
165              
166             1;
167              
168             __END__