Commit | Line | Data |
b6bf9ed3 |
1 | package Web::Dispatch::ParamParser; |
134d6c1f |
2 | |
3 | use strict; |
4 | use warnings FATAL => 'all'; |
5 | |
2993003a |
6 | use Encode 'decode_utf8'; |
7 | |
134d6c1f |
8 | sub UNPACKED_QUERY () { __PACKAGE__.'.unpacked_query' } |
53d47b78 |
9 | sub UNPACKED_BODY () { __PACKAGE__.'.unpacked_body' } |
05aafc1a |
10 | sub UNPACKED_BODY_OBJECT () { __PACKAGE__.'.unpacked_body_object' } |
11 | sub UNPACKED_UPLOADS () { __PACKAGE__.'.unpacked_uploads' } |
d96756e8 |
12 | sub ORIG_ENV () { 'Web::Dispatch.original_env' } |
134d6c1f |
13 | |
14 | sub get_unpacked_query_from { |
d96756e8 |
15 | return ($_[0]->{+ORIG_ENV}||$_[0])->{+UNPACKED_QUERY} ||= do { |
8b48a8e4 |
16 | my $p = _unpack_params($_[0]->{QUERY_STRING}); |
1da2e3c5 |
17 | unless (keys %$p == 1 and exists $p->{j} and ref($p->{j}) eq 'ARRAY' and @{$p->{j}} == 1 and $p->{j}[0] =~ /^{/) { |
8b48a8e4 |
18 | $p; |
19 | } else { |
20 | require JSON::MaybeXS; |
21 | if (my $data = eval { |
22 | my %data = %{JSON::MaybeXS::decode_json($p->{j}[0])}; |
23 | +{ map +($_ => [ $data{$_} ]), keys %data }; |
24 | }) { |
25 | $data |
26 | } else { |
27 | {} |
28 | } |
29 | } |
134d6c1f |
30 | }; |
31 | } |
32 | |
53d47b78 |
33 | sub get_unpacked_body_from { |
d96756e8 |
34 | return ($_[0]->{+ORIG_ENV}||$_[0])->{+UNPACKED_BODY} ||= do { |
05aafc1a |
35 | my $ct = lc($_[0]->{CONTENT_TYPE}||''); |
36 | if (!$_[0]->{CONTENT_LENGTH}) { |
37 | {} |
38 | } elsif (index($ct, 'application/x-www-form-urlencoded') >= 0) { |
53d47b78 |
39 | $_[0]->{'psgi.input'}->read(my $buf, $_[0]->{CONTENT_LENGTH}); |
40 | _unpack_params($buf); |
05aafc1a |
41 | } elsif (index($ct, 'multipart/form-data') >= 0) { |
42 | my $p = get_unpacked_body_object_from($_[0])->param; |
c62cf40a |
43 | # forcible arrayification (functional, $p does not belong to us, |
44 | # do NOT replace this with a side-effect ridden "simpler" version) |
05aafc1a |
45 | +{ |
46 | map +(ref($p->{$_}) eq 'ARRAY' |
47 | ? ($_ => $p->{$_}) |
48 | : ($_ => [ $p->{$_} ]) |
49 | ), keys %$p |
50 | }; |
fd472484 |
51 | } elsif (index($ct, 'application/json') >= 0) { |
52 | $_[0]->{'psgi.input'}->read(my $buf, $_[0]->{CONTENT_LENGTH}); |
53 | require JSON::MaybeXS; |
54 | if (my $data = eval { |
55 | my %data = %{JSON::MaybeXS::decode_json($buf)}; |
56 | +{ map +($_ => [ $data{$_} ]), keys %data }; |
57 | }) { |
58 | $data |
59 | } else { |
60 | {} |
61 | } |
53d47b78 |
62 | } else { |
63 | {} |
64 | } |
65 | }; |
66 | } |
67 | |
05aafc1a |
68 | sub get_unpacked_body_object_from { |
69 | # we may have no object at all - so use a single element arrayref for ||= |
d96756e8 |
70 | return (($_[0]->{+ORIG_ENV}||$_[0])->{+UNPACKED_BODY_OBJECT} ||= do { |
05aafc1a |
71 | if (!$_[0]->{CONTENT_LENGTH}) { |
72 | [ undef ] |
73 | } elsif (index(lc($_[0]->{CONTENT_TYPE}||''),'multipart/form-data')==-1) { |
74 | [ undef ] |
75 | } else { |
76 | [ _make_http_body($_[0]) ] |
77 | } |
78 | })->[0]; |
79 | } |
80 | |
81 | sub get_unpacked_uploads_from { |
82 | $_[0]->{+UNPACKED_UPLOADS} ||= do { |
83 | require Web::Dispatch::Upload; require HTTP::Headers; |
84 | my ($final, $reason) = ( |
85 | {}, "field %s exists with value %s but body was not multipart/form-data" |
86 | ); |
87 | if (my $body = get_unpacked_body_object_from($_[0])) { |
88 | my $u = $body->upload; |
89 | $reason = "field %s exists with value %s but was not an upload"; |
90 | foreach my $k (keys %$u) { |
91 | foreach my $v (ref($u->{$k}) eq 'ARRAY' ? @{$u->{$k}} : $u->{$k}) { |
92 | push(@{$final->{$k}||=[]}, Web::Dispatch::Upload->new( |
93 | %{$v}, |
94 | headers => HTTP::Headers->new($v->{headers}) |
95 | )); |
96 | } |
97 | } |
98 | } |
99 | my $b = get_unpacked_body_from($_[0]); |
100 | foreach my $k (keys %$b) { |
101 | next if $final->{$k}; |
102 | foreach my $v (@{$b->{$k}}) { |
103 | next unless $v; |
104 | push(@{$final->{$k}||=[]}, Web::Dispatch::NotAnUpload->new( |
105 | filename => $v, |
106 | reason => sprintf($reason, $k, $v) |
107 | )); |
108 | } |
109 | } |
110 | $final; |
111 | }; |
112 | } |
206620db |
113 | |
134d6c1f |
114 | { |
115 | # shamelessly stolen from HTTP::Body::UrlEncoded by Christian Hansen |
116 | |
117 | my $DECODE = qr/%([0-9a-fA-F]{2})/; |
118 | |
119 | my %hex_chr; |
120 | |
121 | foreach my $num ( 0 .. 255 ) { |
122 | my $h = sprintf "%02X", $num; |
123 | $hex_chr{ lc $h } = $hex_chr{ uc $h } = chr $num; |
124 | } |
125 | |
126 | sub _unpack_params { |
127 | my %unpack; |
a5917caa |
128 | (my $params = $_[0]) =~ s/\+/ /g; |
134d6c1f |
129 | my ($name, $value); |
a5917caa |
130 | foreach my $pair (split(/[&;](?:\s+)?/, $params)) { |
134d6c1f |
131 | next unless (($name, $value) = split(/=/, $pair, 2)) == 2; |
2993003a |
132 | |
134d6c1f |
133 | s/$DECODE/$hex_chr{$1}/gs for ($name, $value); |
2993003a |
134 | $_ = decode_utf8 $_ for ($name, $value); |
134d6c1f |
135 | |
136 | push(@{$unpack{$name}||=[]}, $value); |
137 | } |
138 | \%unpack; |
139 | } |
140 | } |
141 | |
05aafc1a |
142 | { |
143 | # shamelessly stolen from Plack::Request by miyagawa |
144 | |
145 | sub _make_http_body { |
146 | |
147 | # Can't actually do this yet, since Plack::Request deletes the |
148 | # header structure out of the uploads in its copy of the body. |
149 | # I suspect I need to supply miyagawa with a failing test. |
150 | |
151 | #if (my $plack_body = $_[0]->{'plack.request.http.body'}) { |
152 | # # Plack already constructed one; probably wasteful to do it again |
153 | # return $plack_body; |
154 | #} |
155 | |
156 | require HTTP::Body; |
157 | my $body = HTTP::Body->new(@{$_[0]}{qw(CONTENT_TYPE CONTENT_LENGTH)}); |
158 | $body->cleanup(1); |
159 | my $spin = 0; |
160 | my $input = $_[0]->{'psgi.input'}; |
161 | my $cl = $_[0]->{CONTENT_LENGTH}; |
162 | while ($cl) { |
163 | $input->read(my $chunk, $cl < 8192 ? $cl : 8192); |
164 | my $read = length $chunk; |
165 | $cl -= $read; |
166 | $body->add($chunk); |
167 | |
168 | if ($read == 0 && $spin++ > 2000) { |
169 | require Carp; |
170 | Carp::croak("Bad Content-Length: maybe client disconnect? ($cl bytes remaining)"); |
171 | } |
172 | } |
173 | return $body; |
174 | } |
175 | } |
176 | |
134d6c1f |
177 | 1; |