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; |
920d6222 |
25 | /^\G\s*/; # eat leading whitespace |
26 | PARSE: { do { |
c6ea9542 |
27 | push @match, $self->_parse_spec_section($_) |
920d6222 |
28 | or $self->_blam("Unable to work out what the next section is"); |
b0420ad6 |
29 | if (/\G\)/gc) { |
30 | $self->_blam("Found closing ) with no opening (") unless $nested; |
31 | last PARSE; |
32 | } |
920d6222 |
33 | last PARSE if (pos == length); |
c6ea9542 |
34 | $match[-1] = $self->_parse_spec_combinator($_, $match[-1]) |
35 | or $self->_blam('No valid combinator - expected + or |'); |
920d6222 |
36 | } until (pos == length) }; # accept trailing whitespace |
b0420ad6 |
37 | if ($nested and pos == length) { |
a4ec359d |
38 | pos = $nested - 1; |
b0420ad6 |
39 | $self->_blam("No closing ) found for opening ("); |
40 | } |
920d6222 |
41 | return $match[0] if (@match == 1); |
42 | return sub { |
43 | my $env = { %{$_[0]} }; |
44 | my $new_env; |
45 | my @got; |
46 | foreach my $match (@match) { |
47 | if (my @this_got = $match->($env)) { |
48 | my %change_env = %{shift(@this_got)}; |
49 | @{$env}{keys %change_env} = values %change_env; |
50 | @{$new_env}{keys %change_env} = values %change_env; |
51 | push @got, @this_got; |
52 | } else { |
53 | return; |
54 | } |
55 | } |
56 | return ($new_env, @got); |
57 | }; |
58 | } |
59 | } |
60 | |
920d6222 |
61 | sub _parse_spec_section { |
62 | my ($self) = @_; |
63 | for ($_[1]) { |
64 | |
65 | # GET POST PUT HEAD ... |
66 | |
67 | /\G([A-Z]+)/gc and |
68 | return $self->_http_method_match($_, $1); |
69 | |
70 | # /... |
71 | |
72 | /\G(?=\/)/gc and |
73 | return $self->_url_path_match($_); |
74 | |
c6ea9542 |
75 | # .* and .html |
76 | |
77 | /\G\.(\*|\w+)/gc and |
920d6222 |
78 | return $self->_url_extension_match($_, $1); |
b0420ad6 |
79 | |
2ee4ab06 |
80 | # (...) |
b0420ad6 |
81 | |
82 | /\G\(/gc and |
83 | return $self->_parse_spec($_, pos); |
2ee4ab06 |
84 | |
85 | # !something |
86 | |
87 | /\G!/gc and |
88 | return do { |
89 | my $match = $self->_parse_spec_section($_); |
90 | return sub { |
91 | return {} unless $match->(@_); |
92 | return; |
93 | }; |
94 | }; |
920d6222 |
95 | } |
96 | return; # () will trigger the blam in our caller |
97 | } |
98 | |
c6ea9542 |
99 | sub _parse_spec_combinator { |
100 | my ($self, $spec, $match) = @_; |
101 | for ($_[1]) { |
102 | |
103 | /\G\+/gc and |
104 | return $match; |
105 | |
106 | /\G\|/gc and |
107 | return do { |
108 | my @match = $match; |
109 | PARSE: { do { |
c6ea9542 |
110 | push @match, $self->_parse_spec_section($_) |
111 | or $self->_blam("Unable to work out what the next section is"); |
112 | last PARSE if (pos == length); |
113 | last PARSE unless /\G\|/gc; # give up when next thing isn't | |
114 | } until (pos == length) }; # accept trailing whitespace |
115 | return sub { |
116 | foreach my $try (@match) { |
117 | if (my @ret = $try->(@_)) { |
118 | return @ret; |
119 | } |
120 | } |
121 | return; |
122 | }; |
123 | }; |
124 | } |
125 | return; |
126 | } |
127 | |
920d6222 |
128 | sub _http_method_match { |
129 | my ($self, $str, $method) = @_; |
920d6222 |
130 | sub { shift->{REQUEST_METHOD} eq $method ? {} : () }; |
131 | } |
132 | |
133 | sub _url_path_match { |
134 | my ($self) = @_; |
920d6222 |
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) = @_; |
c6ea9542 |
173 | if ($extension eq '*') { |
174 | sub { |
175 | if ((my $tmp = shift->{PATH_INFO}) =~ s/\.(\w+)$//) { |
176 | ({ PATH_INFO => $tmp }, $1); |
177 | } else { |
178 | (); |
179 | } |
180 | }; |
181 | } else { |
182 | sub { |
183 | if ((my $tmp = shift->{PATH_INFO}) =~ s/\.\Q${extension}\E$//) { |
184 | ({ PATH_INFO => $tmp }); |
185 | } else { |
186 | (); |
187 | } |
188 | }; |
189 | } |
920d6222 |
190 | } |
191 | |
192 | 1; |