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