Commit | Line | Data |
6a0eb7a7 |
1 | package HTTP::Body::Multipart; |
2 | |
3 | use strict; |
32b29b79 |
4 | use base 'HTTP::Body'; |
5 | use bytes; |
6a0eb7a7 |
6 | |
7 | use File::Temp 0.14; |
8 | |
32b29b79 |
9 | sub init { |
10 | my $self = shift; |
11 | |
12 | unless ( $self->content_type =~ /boundary=\"?([^\";,]+)\"?/ ) { |
13 | my $content_type = $self->content_type; |
14 | Carp::croak("Invalid boudrary in content_type: '$content_type'"); |
15 | } |
16 | |
17 | $self->{boundary} = $1; |
18 | $self->{state} = 'preamble'; |
19 | $self->{length} = $self->content_length - $self->content_length * 2; |
6a0eb7a7 |
20 | |
21 | return $self; |
22 | } |
23 | |
32b29b79 |
24 | sub add { |
25 | my ( $self, $buffer ) = @_; |
6a0eb7a7 |
26 | |
32b29b79 |
27 | unless ( defined $buffer ) { |
28 | $buffer = ''; |
29 | } |
30 | |
31 | $self->{buffer} .= $buffer; |
32 | $self->{length} += length($buffer); |
33 | |
34 | while (1) { |
35 | |
36 | if ( $self->{state} eq 'done' ) { |
37 | return 0; |
38 | } |
39 | |
40 | elsif ( $self->{state} =~ /^(preamble|boundary|header|body)$/ ) { |
41 | my $method = "parse_$1"; |
42 | return $self->{length} unless $self->$method; |
43 | } |
44 | |
45 | else { |
46 | Carp::croak('Unknown state'); |
47 | } |
48 | } |
49 | } |
50 | |
51 | sub boundary { |
52 | my $self = shift; |
53 | $self->{boundary} = shift if @_; |
54 | return $self->{boundary}; |
55 | } |
56 | |
57 | sub boundary_begin { |
58 | return "--" . shift->boundary; |
59 | } |
60 | |
61 | sub boundary_end { |
62 | return shift->boundary_begin . "--"; |
63 | } |
64 | |
65 | sub crlf { |
66 | return "\x0d\x0a"; |
67 | } |
68 | |
69 | sub delimiter_begin { |
70 | my $self = shift; |
71 | return $self->crlf . $self->boundary_begin; |
72 | } |
73 | |
74 | sub delimiter_end { |
75 | my $self = shift; |
76 | return $self->crlf . $self->boundary_end; |
77 | } |
78 | |
79 | sub parse_preamble { |
80 | my $self = shift; |
81 | |
82 | my $index = index( $self->{buffer}, $self->boundary_begin ); |
83 | |
84 | unless ( $index >= 0 ) { |
6a0eb7a7 |
85 | return 0; |
86 | } |
87 | |
32b29b79 |
88 | # replace preamble with CRLF so we can match dash-boundary as delimiter |
89 | substr( $self->{buffer}, 0, $index, $self->crlf ); |
6a0eb7a7 |
90 | |
32b29b79 |
91 | $self->{state} = 'boundary'; |
6a0eb7a7 |
92 | |
32b29b79 |
93 | return 1; |
94 | } |
6a0eb7a7 |
95 | |
32b29b79 |
96 | sub parse_boundary { |
97 | my $self = shift; |
6a0eb7a7 |
98 | |
32b29b79 |
99 | if ( index( $self->{buffer}, $self->delimiter_begin . $self->crlf ) == 0 ) { |
6a0eb7a7 |
100 | |
32b29b79 |
101 | substr( $self->{buffer}, 0, length( $self->delimiter_begin ) + 2, '' ); |
102 | $self->{current} = {}; |
103 | $self->{state} = 'header'; |
104 | |
105 | return 1; |
6a0eb7a7 |
106 | } |
107 | |
32b29b79 |
108 | if ( index( $self->{buffer}, $self->delimiter_end . $self->crlf ) == 0 ) { |
109 | $self->{current} = {}; |
110 | $self->{state} = 'done'; |
111 | return 0; |
112 | } |
113 | |
114 | return 0; |
115 | } |
116 | |
117 | sub parse_header { |
118 | my $self = shift; |
119 | |
120 | my $crlf = $self->crlf; |
121 | my $index = index( $self->{buffer}, $crlf . $crlf ); |
122 | |
123 | unless ( $index >= 0 ) { |
124 | return 0; |
6a0eb7a7 |
125 | } |
126 | |
32b29b79 |
127 | my $header = substr( $self->{buffer}, 0, $index ); |
6a0eb7a7 |
128 | |
32b29b79 |
129 | substr( $self->{buffer}, 0, $index + 4, '' ); |
6a0eb7a7 |
130 | |
32b29b79 |
131 | my @headers; |
132 | for ( split /$crlf/, $header ) { |
133 | if (s/^[ \t]+//) { |
134 | $headers[-1] .= $_; |
135 | } |
6a0eb7a7 |
136 | else { |
32b29b79 |
137 | push @headers, $_; |
6a0eb7a7 |
138 | } |
139 | } |
6a0eb7a7 |
140 | |
32b29b79 |
141 | my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/; |
6a0eb7a7 |
142 | |
32b29b79 |
143 | for my $header (@headers) { |
6a0eb7a7 |
144 | |
32b29b79 |
145 | $header =~ s/^($token):[\t ]*//; |
6a0eb7a7 |
146 | |
32b29b79 |
147 | ( my $field = $1 ) =~ s/\b(\w)/uc($1)/eg; |
148 | |
149 | if ( exists $self->{current}->{headers}->{$field} ) { |
150 | for ( $self->{current}->{headers}->{$field} ) { |
6a0eb7a7 |
151 | $_ = [$_] unless ref($_) eq "ARRAY"; |
32b29b79 |
152 | push( @$_, $header ); |
6a0eb7a7 |
153 | } |
154 | } |
155 | else { |
32b29b79 |
156 | $self->{current}->{headers}->{$field} = $header; |
6a0eb7a7 |
157 | } |
158 | } |
159 | |
32b29b79 |
160 | $self->{state} = 'body'; |
161 | |
162 | return 1; |
6a0eb7a7 |
163 | } |
164 | |
32b29b79 |
165 | sub parse_body { |
6a0eb7a7 |
166 | my $self = shift; |
167 | |
32b29b79 |
168 | my $index = index( $self->{buffer}, $self->delimiter_begin ); |
6a0eb7a7 |
169 | |
32b29b79 |
170 | if ( $index < 0 ) { |
6a0eb7a7 |
171 | |
32b29b79 |
172 | # make sure we have enough buffer to detect end delimiter |
173 | my $length = length( $self->{buffer} ) - ( length( $self->delimiter_end ) + 2 ); |
174 | |
175 | unless ( $length > 0 ) { |
176 | return 0; |
6a0eb7a7 |
177 | } |
32b29b79 |
178 | |
179 | $self->{current}->{data} .= substr( $self->{buffer}, 0, $length, '' ); |
180 | $self->{current}->{size} += $length; |
181 | $self->{current}->{done} = 0; |
182 | |
183 | $self->handler( $self->{current} ); |
184 | |
185 | return 0; |
186 | } |
187 | |
188 | $self->{current}->{data} .= substr( $self->{buffer}, 0, $index, '' ); |
189 | $self->{current}->{size} += $index; |
190 | $self->{current}->{done} = 1; |
191 | |
192 | $self->handler( $self->{current} ); |
193 | |
194 | $self->{state} = 'boundary'; |
195 | |
196 | return 1; |
197 | } |
198 | |
199 | sub handler { |
200 | my ( $self, $part ) = @_; |
201 | |
202 | if ( $part->{done} && $part->{size} == 0 ) { |
203 | return 0; |
204 | } |
205 | |
206 | unless ( $self->{seen}->{"$part"}++ ) { |
207 | |
208 | my $disposition = $part->{headers}->{'Content-Disposition'}; |
209 | my ($name) = $disposition =~ / name="?([^\";]+)"?"/; |
210 | my ($filename) = $disposition =~ / filename="?([^\"]+)"?/; |
211 | |
212 | $part->{name} = $name; |
213 | $part->{filename} = $filename; |
214 | |
215 | if ($filename) { |
216 | |
217 | my $fh = File::Temp->new( UNLINK => 0 ); |
218 | |
219 | $part->{fh} = $fh; |
220 | $part->{tempname} = $fh->filename; |
6a0eb7a7 |
221 | } |
222 | } |
223 | |
32b29b79 |
224 | if ( $part->{filename} ) { |
225 | $part->{fh}->write( delete $part->{data} ); |
226 | } |
227 | |
228 | if ( $part->{done} ) { |
229 | |
230 | if ( $part->{filename} ) { |
231 | |
232 | my $fh = delete $part->{fh}; |
233 | $fh->close; |
234 | |
235 | $self->upload( $part->{name}, $part ); |
236 | } |
237 | |
238 | else { |
239 | $self->param( $part->{name}, $part->{data} ); |
240 | } |
241 | } |
6a0eb7a7 |
242 | } |
243 | |
244 | 1; |