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   746 use strict;
  5         10  
  5         139  
4 5     5   25 use warnings;
  5         11  
  5         727  
5              
6             our $VERSION = '0.24';
7              
8             sub new {
9 1     1 0 504 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   40 no strict 'refs';
  5         9  
  5         2701  
25 0   0 0   0 *$method = eval $sub;
  0   0     0  
  0   50     0  
  0   50     0  
  0   0     0  
  0         0  
  1         4  
  1         6  
  1         6  
  1         319  
  1         7  
  1         5  
  0         0  
  0         0  
  0         0  
26             }
27              
28             sub route($$) {
29 5     5 0 8 my $self = shift;
30 5         18 my $env = shift;
31              
32 5         8 my $req_method = $env->{REQUEST_METHOD};
33 5 50       18 print STDERR "Incoming request: $req_method ",$env->{PATH_INFO},"\n" if ($ENV{HDB_DEBUG_MSG});
34 5 100       17 return unless exists $self->{$req_method};
35 4         7 my $matchlist = $self->{$req_method};
36              
37 4         5 my($fire, @matches);
38 4         7 foreach my $route ( @$matchlist ) {
39 4         9 my($path,$cb) = @$route;
40              
41 4 50       15 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         22 $fire = 1;
49             }
50              
51 4 50       9 if ($fire) {
52 4 50       11 print STDERR " matched!\n" if ($ENV{HDB_DEBUG_MSG});
53 4         10 my $rv = $cb->($env, @matches);
54 4         20 my $hooks = $self->{after_hooks}->{$req_method}->{$path};
55 4 100 100     15 if ($hooks && @$hooks) {
56 1         4 $_->($rv, $env, @matches) foreach @$hooks;
57             }
58 4         21 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 3 my($self, $req, $path, $cb) = @_;
67              
68 1   50     8 my $this_list = $self->{after_hooks}->{$req}->{$path} ||= [];
69              
70 1         3 my $wrapped_as_str;
71             my $wrapped = sub {
72 1     1   3 &$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         2 splice(@$this_list, $i, 1);
76 1         7 return;
77             }
78             }
79 1         3 };
80 1         3 $wrapped_as_str = $wrapped . '';
81              
82 1         6 push @$this_list, $wrapped;
83             }
84              
85             1;