Commit | Line | Data |
9d159224 |
1 | package Web::Simple::DispatchParser; |
2 | |
3 | use strict; |
4 | use warnings FATAL => 'all'; |
5 | |
6 | sub new { bless({}, ref($_[0])||$_[0]) } |
7 | |
8 | sub _blam { |
9 | my ($self, $error) = @_; |
10 | my $hat = (' ' x pos).'^'; |
11 | die "Error parsing dispatch specification: ${error}\n |
12 | ${_} |
13 | ${hat} here\n"; |
14 | } |
15 | |
16 | sub parse_dispatch_specification { |
17 | my ($self, $spec) = @_; |
18 | for ($spec) { |
19 | my @match; |
20 | local $self->{already_have}; |
21 | /^\G\s*/; # eat leading whitespace |
22 | PARSE: { do { |
23 | push @match, $self->_parse_spec_section($spec) |
24 | or $self->_blam("Unable to work out what the next section is"); |
25 | last PARSE if (pos == length); |
26 | /\G\+/gc or $self->_blam('Spec sections must be separated by +'); |
27 | } until (pos == length) }; # accept trailing whitespace |
28 | return $match[0] if (@match == 1); |
29 | return sub { |
30 | my $env = { %{$_[0]} }; |
31 | my $new_env; |
32 | my @got; |
33 | foreach my $match (@match) { |
34 | if (my @this_got = $match->($env)) { |
35 | my %change_env = %{shift(@this_got)}; |
36 | @{$env}{keys %change_env} = values %change_env; |
37 | @{$new_env}{keys %change_env} = values %change_env; |
38 | push @got, @this_got; |
39 | } else { |
40 | return; |
41 | } |
42 | } |
43 | return ($new_env, @got); |
44 | }; |
45 | } |
46 | } |
47 | |
48 | sub _dupe_check { |
49 | my ($self, $type) = @_; |
50 | $self->_blam("Can't have more than one ${type} match in a specification") |
51 | if $self->{already_have}{$type}; |
52 | $self->{already_have}{$type} = 1; |
53 | } |
54 | |
55 | sub _parse_spec_section { |
56 | my ($self) = @_; |
57 | for ($_[1]) { |
58 | |
59 | # GET POST PUT HEAD ... |
60 | |
61 | /\G([A-Z]+)/gc and |
62 | return $self->_http_method_match($_, $1); |
63 | |
64 | # /... |
65 | |
66 | /\G(?=\/)/gc and |
67 | return $self->_url_path_match($_); |
68 | |
69 | /\G\.(\w+)/gc and |
70 | return $self->_url_extension_match($_, $1); |
71 | } |
72 | return; # () will trigger the blam in our caller |
73 | } |
74 | |
75 | sub _http_method_match { |
76 | my ($self, $str, $method) = @_; |
77 | $self->_dupe_check('method'); |
78 | sub { shift->{REQUEST_METHOD} eq $method ? {} : () }; |
79 | } |
80 | |
81 | sub _url_path_match { |
82 | my ($self) = @_; |
83 | $self->_dupe_check('path'); |
84 | for ($_[1]) { |
85 | my @path; |
86 | while (/\G\//gc) { |
87 | push @path, $self->_url_path_segment_match($_) |
88 | or $self->_blam("Couldn't parse path match segment"); |
89 | } |
90 | my $re = '^()'.join('/','',@path).'$'; |
91 | return sub { |
92 | if (my @cap = (shift->{PATH_INFO} =~ /$re/)) { |
93 | $cap[0] = {}; return @cap; |
94 | } |
95 | return (); |
96 | }; |
97 | } |
98 | return; |
99 | } |
100 | |
101 | sub _url_path_segment_match { |
102 | my ($self) = @_; |
103 | for ($_[1]) { |
104 | # trailing / -> require / on end of URL |
105 | /\G(?:(?=\s)|$)/gc and |
106 | return '$'; |
107 | # word chars only -> exact path part match |
108 | /\G(\w+)/gc and |
109 | return "\Q$1"; |
110 | # ** -> capture unlimited path parts |
111 | /\G\*\*/gc and |
112 | return '(.+?)'; |
113 | # * -> capture path part |
114 | /\G\*/gc and |
115 | return '([^/]+)'; |
116 | } |
117 | return (); |
118 | } |
119 | |
120 | sub _url_extension_match { |
121 | my ($self, $str, $extension) = @_; |
122 | $self->_dupe_check('extension'); |
123 | sub { |
124 | if ((my $tmp = shift->{PATH_INFO}) =~ s/\.\Q${extension}\E$//) { |
125 | ({ PATH_INFO => $tmp }); |
126 | } else { |
127 | (); |
128 | } |
129 | }; |
130 | } |
131 | |
132 | 1; |