Commit | Line | Data |
920d6222 |
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) = @_; |
a4ec359d |
10 | my $hat = (' ' x (pos||0)).'^'; |
920d6222 |
11 | die "Error parsing dispatch specification: ${error}\n |
12 | ${_} |
13 | ${hat} here\n"; |
14 | } |
15 | |
16 | sub parse_dispatch_specification { |
17 | my ($self, $spec) = @_; |
c6ea9542 |
18 | return $self->_parse_spec($spec); |
19 | } |
20 | |
21 | sub _parse_spec { |
b0420ad6 |
22 | my ($self, $spec, $nested) = @_; |
c6ea9542 |
23 | for ($_[1]) { |
920d6222 |
24 | my @match; |
25 | local $self->{already_have}; |
26 | /^\G\s*/; # eat leading whitespace |
27 | PARSE: { do { |
c6ea9542 |
28 | push @match, $self->_parse_spec_section($_) |
920d6222 |
29 | or $self->_blam("Unable to work out what the next section is"); |
b0420ad6 |
30 | if (/\G\)/gc) { |
31 | $self->_blam("Found closing ) with no opening (") unless $nested; |
32 | last PARSE; |
33 | } |
920d6222 |
34 | last PARSE if (pos == length); |
c6ea9542 |
35 | $match[-1] = $self->_parse_spec_combinator($_, $match[-1]) |
36 | or $self->_blam('No valid combinator - expected + or |'); |
920d6222 |
37 | } until (pos == length) }; # accept trailing whitespace |
b0420ad6 |
38 | if ($nested and pos == length) { |
a4ec359d |
39 | pos = $nested - 1; |
b0420ad6 |
40 | $self->_blam("No closing ) found for opening ("); |
41 | } |
920d6222 |
42 | return $match[0] if (@match == 1); |
43 | return sub { |
44 | my $env = { %{$_[0]} }; |
45 | my $new_env; |
46 | my @got; |
47 | foreach my $match (@match) { |
48 | if (my @this_got = $match->($env)) { |
49 | my %change_env = %{shift(@this_got)}; |
50 | @{$env}{keys %change_env} = values %change_env; |
51 | @{$new_env}{keys %change_env} = values %change_env; |
52 | push @got, @this_got; |
53 | } else { |
54 | return; |
55 | } |
56 | } |
57 | return ($new_env, @got); |
58 | }; |
59 | } |
60 | } |
61 | |
62 | sub _dupe_check { |
63 | my ($self, $type) = @_; |
64 | $self->_blam("Can't have more than one ${type} match in a specification") |
65 | if $self->{already_have}{$type}; |
66 | $self->{already_have}{$type} = 1; |
67 | } |
68 | |
69 | sub _parse_spec_section { |
70 | my ($self) = @_; |
71 | for ($_[1]) { |
72 | |
73 | # GET POST PUT HEAD ... |
74 | |
75 | /\G([A-Z]+)/gc and |
76 | return $self->_http_method_match($_, $1); |
77 | |
78 | # /... |
79 | |
80 | /\G(?=\/)/gc and |
81 | return $self->_url_path_match($_); |
82 | |
c6ea9542 |
83 | # .* and .html |
84 | |
85 | /\G\.(\*|\w+)/gc and |
920d6222 |
86 | return $self->_url_extension_match($_, $1); |
b0420ad6 |
87 | |
88 | # ( |
89 | |
90 | /\G\(/gc and |
91 | return $self->_parse_spec($_, pos); |
920d6222 |
92 | } |
93 | return; # () will trigger the blam in our caller |
94 | } |
95 | |
c6ea9542 |
96 | sub _parse_spec_combinator { |
97 | my ($self, $spec, $match) = @_; |
98 | for ($_[1]) { |
99 | |
100 | /\G\+/gc and |
101 | return $match; |
102 | |
103 | /\G\|/gc and |
104 | return do { |
105 | my @match = $match; |
106 | PARSE: { do { |
107 | local $self->{already_have}; |
108 | push @match, $self->_parse_spec_section($_) |
109 | or $self->_blam("Unable to work out what the next section is"); |
110 | last PARSE if (pos == length); |
111 | last PARSE unless /\G\|/gc; # give up when next thing isn't | |
112 | } until (pos == length) }; # accept trailing whitespace |
113 | return sub { |
114 | foreach my $try (@match) { |
115 | if (my @ret = $try->(@_)) { |
116 | return @ret; |
117 | } |
118 | } |
119 | return; |
120 | }; |
121 | }; |
122 | } |
123 | return; |
124 | } |
125 | |
920d6222 |
126 | sub _http_method_match { |
127 | my ($self, $str, $method) = @_; |
128 | $self->_dupe_check('method'); |
129 | sub { shift->{REQUEST_METHOD} eq $method ? {} : () }; |
130 | } |
131 | |
132 | sub _url_path_match { |
133 | my ($self) = @_; |
134 | $self->_dupe_check('path'); |
135 | for ($_[1]) { |
136 | my @path; |
137 | while (/\G\//gc) { |
138 | push @path, $self->_url_path_segment_match($_) |
139 | or $self->_blam("Couldn't parse path match segment"); |
140 | } |
141 | my $re = '^()'.join('/','',@path).'$'; |
142 | return sub { |
143 | if (my @cap = (shift->{PATH_INFO} =~ /$re/)) { |
144 | $cap[0] = {}; return @cap; |
145 | } |
146 | return (); |
147 | }; |
148 | } |
149 | return; |
150 | } |
151 | |
152 | sub _url_path_segment_match { |
153 | my ($self) = @_; |
154 | for ($_[1]) { |
155 | # trailing / -> require / on end of URL |
156 | /\G(?:(?=\s)|$)/gc and |
157 | return '$'; |
158 | # word chars only -> exact path part match |
159 | /\G(\w+)/gc and |
160 | return "\Q$1"; |
28f3dfd5 |
161 | # ** -> capture unlimited path parts |
162 | /\G\*\*/gc and |
163 | return '(.*?[^/])'; |
920d6222 |
164 | # * -> capture path part |
165 | /\G\*/gc and |
166 | return '([^/]+)'; |
167 | } |
168 | return (); |
169 | } |
170 | |
171 | sub _url_extension_match { |
172 | my ($self, $str, $extension) = @_; |
173 | $self->_dupe_check('extension'); |
c6ea9542 |
174 | if ($extension eq '*') { |
175 | sub { |
176 | if ((my $tmp = shift->{PATH_INFO}) =~ s/\.(\w+)$//) { |
177 | ({ PATH_INFO => $tmp }, $1); |
178 | } else { |
179 | (); |
180 | } |
181 | }; |
182 | } else { |
183 | sub { |
184 | if ((my $tmp = shift->{PATH_INFO}) =~ s/\.\Q${extension}\E$//) { |
185 | ({ PATH_INFO => $tmp }); |
186 | } else { |
187 | (); |
188 | } |
189 | }; |
190 | } |
920d6222 |
191 | } |
192 | |
193 | 1; |