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