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) = @_; |
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) = @_; |
c6ea9542 |
18 | return $self->_parse_spec($spec); |
19 | } |
20 | |
21 | sub _parse_spec { |
22 | my ($self, $spec) = @_; |
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"); |
30 | last PARSE if (pos == length); |
c6ea9542 |
31 | $match[-1] = $self->_parse_spec_combinator($_, $match[-1]) |
32 | or $self->_blam('No valid combinator - expected + or |'); |
920d6222 |
33 | } until (pos == length) }; # accept trailing whitespace |
34 | return $match[0] if (@match == 1); |
35 | return sub { |
36 | my $env = { %{$_[0]} }; |
37 | my $new_env; |
38 | my @got; |
39 | foreach my $match (@match) { |
40 | if (my @this_got = $match->($env)) { |
41 | my %change_env = %{shift(@this_got)}; |
42 | @{$env}{keys %change_env} = values %change_env; |
43 | @{$new_env}{keys %change_env} = values %change_env; |
44 | push @got, @this_got; |
45 | } else { |
46 | return; |
47 | } |
48 | } |
49 | return ($new_env, @got); |
50 | }; |
51 | } |
52 | } |
53 | |
54 | sub _dupe_check { |
55 | my ($self, $type) = @_; |
56 | $self->_blam("Can't have more than one ${type} match in a specification") |
57 | if $self->{already_have}{$type}; |
58 | $self->{already_have}{$type} = 1; |
59 | } |
60 | |
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); |
79 | } |
80 | return; # () will trigger the blam in our caller |
81 | } |
82 | |
c6ea9542 |
83 | sub _parse_spec_combinator { |
84 | my ($self, $spec, $match) = @_; |
85 | for ($_[1]) { |
86 | |
87 | /\G\+/gc and |
88 | return $match; |
89 | |
90 | /\G\|/gc and |
91 | return do { |
92 | my @match = $match; |
93 | PARSE: { do { |
94 | local $self->{already_have}; |
95 | push @match, $self->_parse_spec_section($_) |
96 | or $self->_blam("Unable to work out what the next section is"); |
97 | last PARSE if (pos == length); |
98 | last PARSE unless /\G\|/gc; # give up when next thing isn't | |
99 | } until (pos == length) }; # accept trailing whitespace |
100 | return sub { |
101 | foreach my $try (@match) { |
102 | if (my @ret = $try->(@_)) { |
103 | return @ret; |
104 | } |
105 | } |
106 | return; |
107 | }; |
108 | }; |
109 | } |
110 | return; |
111 | } |
112 | |
920d6222 |
113 | sub _http_method_match { |
114 | my ($self, $str, $method) = @_; |
115 | $self->_dupe_check('method'); |
116 | sub { shift->{REQUEST_METHOD} eq $method ? {} : () }; |
117 | } |
118 | |
119 | sub _url_path_match { |
120 | my ($self) = @_; |
121 | $self->_dupe_check('path'); |
122 | for ($_[1]) { |
123 | my @path; |
124 | while (/\G\//gc) { |
125 | push @path, $self->_url_path_segment_match($_) |
126 | or $self->_blam("Couldn't parse path match segment"); |
127 | } |
128 | my $re = '^()'.join('/','',@path).'$'; |
129 | return sub { |
130 | if (my @cap = (shift->{PATH_INFO} =~ /$re/)) { |
131 | $cap[0] = {}; return @cap; |
132 | } |
133 | return (); |
134 | }; |
135 | } |
136 | return; |
137 | } |
138 | |
139 | sub _url_path_segment_match { |
140 | my ($self) = @_; |
141 | for ($_[1]) { |
142 | # trailing / -> require / on end of URL |
143 | /\G(?:(?=\s)|$)/gc and |
144 | return '$'; |
145 | # word chars only -> exact path part match |
146 | /\G(\w+)/gc and |
147 | return "\Q$1"; |
28f3dfd5 |
148 | # ** -> capture unlimited path parts |
149 | /\G\*\*/gc and |
150 | return '(.*?[^/])'; |
920d6222 |
151 | # * -> capture path part |
152 | /\G\*/gc and |
153 | return '([^/]+)'; |
154 | } |
155 | return (); |
156 | } |
157 | |
158 | sub _url_extension_match { |
159 | my ($self, $str, $extension) = @_; |
160 | $self->_dupe_check('extension'); |
c6ea9542 |
161 | if ($extension eq '*') { |
162 | sub { |
163 | if ((my $tmp = shift->{PATH_INFO}) =~ s/\.(\w+)$//) { |
164 | ({ PATH_INFO => $tmp }, $1); |
165 | } else { |
166 | (); |
167 | } |
168 | }; |
169 | } else { |
170 | sub { |
171 | if ((my $tmp = shift->{PATH_INFO}) =~ s/\.\Q${extension}\E$//) { |
172 | ({ PATH_INFO => $tmp }); |
173 | } else { |
174 | (); |
175 | } |
176 | }; |
177 | } |
920d6222 |
178 | } |
179 | |
180 | 1; |