File Coverage

blib/lib/Devel/hdb/Router.pm
Criterion Covered Total %
statement 46 60 76.6
branch 10 26 38.4
condition 6 15 40.0
subroutine 7 8 87.5
pod 0 3 0.0
total 69 112 61.6


line stmt bran cond sub pod time code
1             package Devel::hdb::Router;
2              
3 5     5   740 use strict;
  5         10  
  5         121  
4 5     5   18 use warnings;
  5         7  
  5         540  
5              
6             our $VERSION = '0.23_15';
7              
8             sub new {
9 1     1 0 843 my $class = shift;
10 1         4 return bless {}, $class;
11             }
12              
13             foreach my $method ( qw(get post put delete head) ) {
14             my $key = uc($method);
15             my $sub = qq(
16             sub {
17             my(\$self, \$path, \$sub) = \@_;
18             my \$list = \$self->{$key} ||= [];
19             #print STDERR "Registering route for \$key \$path\\n";
20             push \@\$list, [ \$path, \$sub ];
21             };
22             );
23             $sub =~ s/#// if $ENV{HDB_DEBUG_MSG};
24 5     5   31 no strict 'refs';
  5         8  
  5         2279  
25 0   0 0   0 *$method = eval $sub;
  0   0     0  
  0   50     0  
  0   50     0  
  0   0     0  
  0         0  
  1         379  
  1         7  
  1         7  
  1         5  
  1         8  
  1         6  
  0         0  
  0         0  
  0         0  
26             }
27              
28             sub route($$) {
29 5     5 0 7 my $self = shift;
30 5         16 my $env = shift;
31              
32 5         7 my $req_method = $env->{REQUEST_METHOD};
33 5 50       13 print STDERR "Incoming request: $req_method ",$env->{PATH_INFO},"\n" if ($ENV{HDB_DEBUG_MSG});
34 5 100       12 return unless exists $self->{$req_method};
35 4         5 my $matchlist = $self->{$req_method};
36              
37 4         4 my($fire, @matches);
38 4         7 foreach my $route ( @$matchlist ) {
39 4         14 my($path,$cb) = @$route;
40              
41 4 50       12 if (my $ref = ref($path)) {
    50          
42 0 0       0 if ($ref eq 'Regexp') {
    0          
43 0 0       0 $fire = 1 if (@matches = $env->{PATH_INFO} =~ $path);
44             } elsif ($ref eq 'CODE') {
45 0 0       0 $fire = 1 if ($path->($self, $env));
46             }
47             } elsif ($env->{PATH_INFO} eq $path) {
48 4         6 $fire = 1;
49             }
50              
51 4 50       7 if ($fire) {
52 4 50       7 print STDERR " matched!\n" if ($ENV{HDB_DEBUG_MSG});
53 4         10 my $rv = $cb->($env, @matches);
54 4         17 my $hooks = $self->{after_hooks}->{$req_method}->{$path};
55 4 100 100     13 if ($hooks && @$hooks) {
56 1         4 $_->($rv, $env, @matches) foreach @$hooks;
57             }
58 4         20 return $rv;
59             }
60             }
61 0 0       0 print STDERR " no matching route\n" if ($ENV{HDB_DEBUG_MSG});
62 0         0 return [ 404, [ 'Content-Type' => 'text/html'], ['Not found']];
63             }
64              
65             sub once_after($$$&) {
66 1     1 0 4 my($self, $req, $path, $cb) = @_;
67              
68 1   50     7 my $this_list = $self->{after_hooks}->{$req}->{$path} ||= [];
69              
70 1         1 my $wrapped_as_str;
71             my $wrapped = sub {
72 1     1   4 &$cb;
73 1         5 for (my $i = 0; $i < @$this_list; $i++) {
74 1 50       3 if ($this_list->[$i] eq $wrapped_as_str) {
75 1         3 splice(@$this_list, $i, 1);
76 1         7 return;
77             }
78             }
79 1         4 };
80 1         3 $wrapped_as_str = $wrapped . '';
81              
82 1         5 push @$this_list, $wrapped;
83             }
84              
85             1;