Commit | Line | Data |
4f5db602 |
1 | package HTTP::Body::MultiPart; |
6a0eb7a7 |
2 | |
3 | use strict; |
32b29b79 |
4 | use base 'HTTP::Body'; |
5 | use bytes; |
6a0eb7a7 |
6 | |
7 | use File::Temp 0.14; |
8 | |
aac7ca02 |
9 | =head1 NAME |
10 | |
4deaf0f0 |
11 | HTTP::Body::MultiPart - HTTP Body Multipart Parser |
aac7ca02 |
12 | |
13 | =head1 SYNOPSIS |
14 | |
15 | use HTTP::Body::Multipart; |
16 | |
17 | =head1 DESCRIPTION |
18 | |
19 | HTTP Body Multipart Parser. |
20 | |
21 | =head1 METHODS |
22 | |
23 | =over 4 |
24 | |
25 | =item init |
26 | |
27 | =cut |
28 | |
32b29b79 |
29 | sub init { |
30 | my $self = shift; |
31 | |
32 | unless ( $self->content_type =~ /boundary=\"?([^\";,]+)\"?/ ) { |
33 | my $content_type = $self->content_type; |
e61c6e1c |
34 | Carp::croak("Invalid boundary in content_type: '$content_type'"); |
32b29b79 |
35 | } |
36 | |
37 | $self->{boundary} = $1; |
38 | $self->{state} = 'preamble'; |
6a0eb7a7 |
39 | |
40 | return $self; |
41 | } |
42 | |
aac7ca02 |
43 | =item spin |
44 | |
45 | =cut |
46 | |
58050177 |
47 | sub spin { |
48 | my $self = shift; |
32b29b79 |
49 | |
50 | while (1) { |
51 | |
7e2df1d9 |
52 | if ( $self->{state} =~ /^(preamble|boundary|header|body)$/ ) { |
32b29b79 |
53 | my $method = "parse_$1"; |
58050177 |
54 | return unless $self->$method; |
32b29b79 |
55 | } |
56 | |
57 | else { |
58 | Carp::croak('Unknown state'); |
59 | } |
60 | } |
61 | } |
62 | |
aac7ca02 |
63 | =item boundary |
64 | |
65 | =cut |
66 | |
32b29b79 |
67 | sub boundary { |
58050177 |
68 | return shift->{boundary}; |
32b29b79 |
69 | } |
70 | |
aac7ca02 |
71 | =item boundary_begin |
72 | |
73 | =cut |
74 | |
32b29b79 |
75 | sub boundary_begin { |
76 | return "--" . shift->boundary; |
77 | } |
78 | |
aac7ca02 |
79 | =item boundary_end |
80 | |
81 | =cut |
82 | |
32b29b79 |
83 | sub boundary_end { |
84 | return shift->boundary_begin . "--"; |
85 | } |
86 | |
aac7ca02 |
87 | =item crlf |
88 | |
89 | =cut |
90 | |
32b29b79 |
91 | sub crlf { |
92 | return "\x0d\x0a"; |
93 | } |
94 | |
aac7ca02 |
95 | =item delimiter_begin |
96 | |
97 | =cut |
98 | |
32b29b79 |
99 | sub delimiter_begin { |
100 | my $self = shift; |
101 | return $self->crlf . $self->boundary_begin; |
102 | } |
103 | |
aac7ca02 |
104 | =item delimiter_end |
105 | |
106 | =cut |
107 | |
32b29b79 |
108 | sub delimiter_end { |
109 | my $self = shift; |
110 | return $self->crlf . $self->boundary_end; |
111 | } |
112 | |
aac7ca02 |
113 | =item parse_preamble |
114 | |
115 | =cut |
116 | |
32b29b79 |
117 | sub parse_preamble { |
118 | my $self = shift; |
119 | |
120 | my $index = index( $self->{buffer}, $self->boundary_begin ); |
121 | |
122 | unless ( $index >= 0 ) { |
6a0eb7a7 |
123 | return 0; |
124 | } |
125 | |
32b29b79 |
126 | # replace preamble with CRLF so we can match dash-boundary as delimiter |
127 | substr( $self->{buffer}, 0, $index, $self->crlf ); |
6a0eb7a7 |
128 | |
32b29b79 |
129 | $self->{state} = 'boundary'; |
6a0eb7a7 |
130 | |
32b29b79 |
131 | return 1; |
132 | } |
6a0eb7a7 |
133 | |
aac7ca02 |
134 | =item parse_boundary |
135 | |
136 | =cut |
137 | |
32b29b79 |
138 | sub parse_boundary { |
139 | my $self = shift; |
6a0eb7a7 |
140 | |
32b29b79 |
141 | if ( index( $self->{buffer}, $self->delimiter_begin . $self->crlf ) == 0 ) { |
6a0eb7a7 |
142 | |
32b29b79 |
143 | substr( $self->{buffer}, 0, length( $self->delimiter_begin ) + 2, '' ); |
58050177 |
144 | $self->{part} = {}; |
145 | $self->{state} = 'header'; |
32b29b79 |
146 | |
147 | return 1; |
6a0eb7a7 |
148 | } |
149 | |
32b29b79 |
150 | if ( index( $self->{buffer}, $self->delimiter_end . $self->crlf ) == 0 ) { |
aac7ca02 |
151 | |
58050177 |
152 | substr( $self->{buffer}, 0, length( $self->delimiter_end ) + 2, '' ); |
153 | $self->{part} = {}; |
154 | $self->{state} = 'done'; |
aac7ca02 |
155 | |
32b29b79 |
156 | return 0; |
58050177 |
157 | } |
32b29b79 |
158 | |
159 | return 0; |
160 | } |
161 | |
aac7ca02 |
162 | =item parse_header |
163 | |
164 | =cut |
165 | |
32b29b79 |
166 | sub parse_header { |
167 | my $self = shift; |
168 | |
169 | my $crlf = $self->crlf; |
170 | my $index = index( $self->{buffer}, $crlf . $crlf ); |
171 | |
172 | unless ( $index >= 0 ) { |
173 | return 0; |
6a0eb7a7 |
174 | } |
175 | |
32b29b79 |
176 | my $header = substr( $self->{buffer}, 0, $index ); |
6a0eb7a7 |
177 | |
32b29b79 |
178 | substr( $self->{buffer}, 0, $index + 4, '' ); |
6a0eb7a7 |
179 | |
32b29b79 |
180 | my @headers; |
181 | for ( split /$crlf/, $header ) { |
182 | if (s/^[ \t]+//) { |
183 | $headers[-1] .= $_; |
184 | } |
6a0eb7a7 |
185 | else { |
32b29b79 |
186 | push @headers, $_; |
6a0eb7a7 |
187 | } |
188 | } |
6a0eb7a7 |
189 | |
32b29b79 |
190 | my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/; |
6a0eb7a7 |
191 | |
32b29b79 |
192 | for my $header (@headers) { |
6a0eb7a7 |
193 | |
32b29b79 |
194 | $header =~ s/^($token):[\t ]*//; |
6a0eb7a7 |
195 | |
32b29b79 |
196 | ( my $field = $1 ) =~ s/\b(\w)/uc($1)/eg; |
197 | |
58050177 |
198 | if ( exists $self->{part}->{headers}->{$field} ) { |
199 | for ( $self->{part}->{headers}->{$field} ) { |
6a0eb7a7 |
200 | $_ = [$_] unless ref($_) eq "ARRAY"; |
32b29b79 |
201 | push( @$_, $header ); |
6a0eb7a7 |
202 | } |
203 | } |
204 | else { |
58050177 |
205 | $self->{part}->{headers}->{$field} = $header; |
6a0eb7a7 |
206 | } |
207 | } |
208 | |
32b29b79 |
209 | $self->{state} = 'body'; |
210 | |
211 | return 1; |
6a0eb7a7 |
212 | } |
213 | |
aac7ca02 |
214 | =item parse_body |
215 | |
216 | =cut |
217 | |
32b29b79 |
218 | sub parse_body { |
6a0eb7a7 |
219 | my $self = shift; |
220 | |
32b29b79 |
221 | my $index = index( $self->{buffer}, $self->delimiter_begin ); |
6a0eb7a7 |
222 | |
32b29b79 |
223 | if ( $index < 0 ) { |
6a0eb7a7 |
224 | |
32b29b79 |
225 | # make sure we have enough buffer to detect end delimiter |
a9df1200 |
226 | my $length = length( $self->{buffer} ) - ( length( $self->delimiter_end ) + 2 ); |
32b29b79 |
227 | |
228 | unless ( $length > 0 ) { |
229 | return 0; |
6a0eb7a7 |
230 | } |
32b29b79 |
231 | |
58050177 |
232 | $self->{part}->{data} .= substr( $self->{buffer}, 0, $length, '' ); |
233 | $self->{part}->{size} += $length; |
aac7ca02 |
234 | $self->{part}->{done} = 0; |
32b29b79 |
235 | |
58050177 |
236 | $self->handler( $self->{part} ); |
32b29b79 |
237 | |
238 | return 0; |
239 | } |
240 | |
58050177 |
241 | $self->{part}->{data} .= substr( $self->{buffer}, 0, $index, '' ); |
242 | $self->{part}->{size} += $index; |
aac7ca02 |
243 | $self->{part}->{done} = 1; |
32b29b79 |
244 | |
58050177 |
245 | $self->handler( $self->{part} ); |
32b29b79 |
246 | |
247 | $self->{state} = 'boundary'; |
248 | |
249 | return 1; |
250 | } |
251 | |
aac7ca02 |
252 | =item handler |
253 | |
254 | =cut |
255 | |
32b29b79 |
256 | sub handler { |
257 | my ( $self, $part ) = @_; |
258 | |
7e2df1d9 |
259 | # skip parts without content |
32b29b79 |
260 | if ( $part->{done} && $part->{size} == 0 ) { |
261 | return 0; |
262 | } |
263 | |
fa1d3d65 |
264 | unless ( exists $part->{name} ) { |
32b29b79 |
265 | |
266 | my $disposition = $part->{headers}->{'Content-Disposition'}; |
aac7ca02 |
267 | my ($name) = $disposition =~ / name="?([^\";]+)"?/; |
268 | my ($filename) = $disposition =~ / filename="?([^\"]+)"?/; |
32b29b79 |
269 | |
270 | $part->{name} = $name; |
271 | $part->{filename} = $filename; |
272 | |
273 | if ($filename) { |
274 | |
275 | my $fh = File::Temp->new( UNLINK => 0 ); |
276 | |
277 | $part->{fh} = $fh; |
278 | $part->{tempname} = $fh->filename; |
6a0eb7a7 |
279 | } |
280 | } |
281 | |
f4600b8f |
282 | if ( $part->{filename} && ( my $length = length( $part->{data} ) ) ) { |
283 | $part->{fh}->write( substr( $part->{data}, 0, $length, '' ), $length ); |
32b29b79 |
284 | } |
285 | |
286 | if ( $part->{done} ) { |
287 | |
288 | if ( $part->{filename} ) { |
aac7ca02 |
289 | |
58050177 |
290 | $part->{fh}->close; |
aac7ca02 |
291 | |
292 | delete @{$part}{qw[ data done fh ]}; |
293 | |
32b29b79 |
294 | $self->upload( $part->{name}, $part ); |
295 | } |
296 | |
297 | else { |
298 | $self->param( $part->{name}, $part->{data} ); |
299 | } |
300 | } |
6a0eb7a7 |
301 | } |
302 | |
aac7ca02 |
303 | =back |
304 | |
305 | =head1 AUTHOR |
306 | |
307 | Christian Hansen, C<ch@ngmedia.com> |
308 | |
309 | =head1 LICENSE |
310 | |
311 | This library is free software . You can redistribute it and/or modify |
312 | it under the same terms as perl itself. |
313 | |
314 | =cut |
315 | |
6a0eb7a7 |
316 | 1; |