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