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