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