line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Router::Resource; |
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
386
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
27
|
|
4
|
1
|
|
|
1
|
|
8
|
use 5.8.1; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
36
|
|
5
|
1
|
|
|
1
|
|
447
|
use Router::Simple::Route; |
|
1
|
|
|
|
|
2132
|
|
|
1
|
|
|
|
|
41
|
|
6
|
1
|
|
|
|
|
12
|
use Sub::Exporter -setup => { |
7
|
|
|
|
|
|
|
exports => [ qw(router resource missing GET POST PUT DELETE HEAD OPTIONS TRACE CONNECT)], |
8
|
|
|
|
|
|
|
groups => { default => [ qw(resource router missing GET POST PUT DELETE HEAD OPTIONS TRACE CONNECT) ] } |
9
|
1
|
|
|
1
|
|
472
|
}; |
|
1
|
|
|
|
|
9601
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
our $VERSION = '0.20'; |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
sub new { |
14
|
3
|
|
|
3
|
0
|
4
|
my $class = shift; |
15
|
3
|
|
|
|
|
11
|
bless { @_, routes => [] }; |
16
|
|
|
|
|
|
|
} |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
our (%METHS, $ROUTER); |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
sub router(&;@) { |
21
|
3
|
|
|
3
|
0
|
2488
|
my ($block, @settings) = @_; |
22
|
3
|
|
|
|
|
12
|
local $ROUTER = __PACKAGE__->new(@settings); |
23
|
3
|
|
|
|
|
9
|
$block->(); |
24
|
3
|
|
|
|
|
85
|
return $ROUTER; |
25
|
|
|
|
|
|
|
} |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
sub resource ($&) { |
28
|
5
|
|
|
5
|
0
|
163
|
my ($path, $code) = @_; |
29
|
5
|
|
|
|
|
7
|
local %METHS = (); |
30
|
5
|
|
|
|
|
9
|
$code->(); |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
# Let HEAD use GET if not specified. |
33
|
5
|
|
66
|
|
|
26
|
$METHS{HEAD} ||= $METHS{GET}; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
# Add OPTIONS if requested. |
36
|
5
|
100
|
66
|
|
|
23
|
if ($ROUTER->{auto_options} && !$METHS{OPTIONS}) { |
37
|
1
|
|
|
|
|
5
|
my $methods = join(', ' => 'OPTIONS', keys %METHS); |
38
|
1
|
|
|
1
|
|
5
|
$METHS{OPTIONS} = sub { [200, ['Allow', $methods], []] }; |
|
1
|
|
|
|
|
7
|
|
39
|
|
|
|
|
|
|
} |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
# Add the route. |
42
|
5
|
|
|
|
|
5
|
push @{ $ROUTER->{routes} }, Router::Simple::Route->new( |
|
5
|
|
|
|
|
38
|
|
43
|
|
|
|
|
|
|
$path, { meths => { %METHS } } |
44
|
|
|
|
|
|
|
); |
45
|
|
|
|
|
|
|
} |
46
|
|
|
|
|
|
|
|
47
|
1
|
|
|
1
|
0
|
69
|
sub missing(&) { $ROUTER->{missing} = shift } |
48
|
6
|
|
|
6
|
1
|
39
|
sub GET(&) { $METHS{GET} = shift } |
49
|
1
|
|
|
1
|
1
|
6
|
sub HEAD(&) { $METHS{HEAD} = shift } |
50
|
2
|
|
|
2
|
1
|
9
|
sub POST(&) { $METHS{POST} = shift } |
51
|
2
|
|
|
2
|
1
|
12
|
sub PUT(&) { $METHS{PUT} = shift } |
52
|
1
|
|
|
1
|
|
4
|
sub DELETE(&) { $METHS{DELETE} = shift } |
53
|
1
|
|
|
1
|
1
|
5
|
sub OPTIONS(&) { $METHS{OPTIONS} = shift } |
54
|
1
|
|
|
1
|
1
|
7
|
sub TRACE(&) { $METHS{TRACE} = shift } |
55
|
1
|
|
|
1
|
1
|
6
|
sub CONNECT(&) { $METHS{CONNECT} = shift } |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
sub dispatch { |
58
|
19
|
|
|
19
|
0
|
7991
|
my ($self, $env) = @_; |
59
|
19
|
|
|
|
|
33
|
my $match = $self->match($env); |
60
|
19
|
100
|
|
|
|
40
|
if (my $meth = $match->{meth}) { |
61
|
14
|
|
|
|
|
42
|
return $meth->($env, $match->{data}); |
62
|
|
|
|
|
|
|
} |
63
|
5
|
100
|
|
|
|
23
|
my $missing = $self->{missing} or return [ |
64
|
|
|
|
|
|
|
$match->{code}, $match->{headers}, [$match->{message}] |
65
|
|
|
|
|
|
|
]; |
66
|
2
|
|
|
|
|
6
|
return $missing->($env, $match); |
67
|
|
|
|
|
|
|
} |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
sub match { |
70
|
22
|
|
|
22
|
0
|
1249
|
my ($self, $env) = @_; |
71
|
22
|
50
|
50
|
|
|
70
|
my $meth = uc($env->{REQUEST_METHOD} || '') or return; |
72
|
|
|
|
|
|
|
|
73
|
22
|
|
|
|
|
17
|
for my $route (@{ $self->{routes} }) { |
|
22
|
|
|
|
|
37
|
|
74
|
45
|
100
|
|
|
|
229
|
my $match = $route->match($env) or next; |
75
|
19
|
|
|
|
|
427
|
my $meths = delete $match->{meths}; |
76
|
4
|
|
|
|
|
33
|
my $code = $meths->{$meth} or return { |
77
|
|
|
|
|
|
|
code => 405, |
78
|
|
|
|
|
|
|
message => 'not allowed', |
79
|
19
|
100
|
|
|
|
39
|
headers => [Allow => join ', ', sort keys %{ $meths } ], |
80
|
|
|
|
|
|
|
}; |
81
|
15
|
|
|
|
|
46
|
return { meth => $code, code => 200, data => $match }; |
82
|
|
|
|
|
|
|
} |
83
|
3
|
|
|
|
|
32
|
return { code => 404, message => 'not found', headers => [] }; |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
1; |
87
|
|
|
|
|
|
|
__END__ |