Beta Shell
v2.0 ยท web2.us.cloudlogin.co
[FM]
[CMD]
[PHP]
[DB]
[INFO]
[SEC]
File Manager
~
/
usr
/
share
/
doc
/
perl-HTTP-MultiPartParser
/
eg
Upload
3 items
Name
Size
Perms
Modified
Actions
[ .. / .. ]
example.pl
3.33 KB
-rwxr-xr-x
2017-04-10 04:49:30
Edit
Del
Editing: example.pl
(3.33 KB)
Path: /usr/share/doc/perl-HTTP-MultiPartParser/eg/example.pl
Back
#!/usr/bin/perl use strict; use warnings; use HTTP::MultiPartParser qw[]; use Hash::MultiValue qw[]; use IO::File qw[SEEK_SET]; use File::Temp qw[]; # extracts name and filename values from Content-Disposition header. # returns the escaped value, due to different behaviour across browsers. # (see https://gist.github.com/chansen/7163968) sub extract_form_data { local $_ = shift; # Fast exit for common form-data disposition if (/\A form-data; \s name="((?:[^"]|\\")*)" (?: ;\s filename="((?:[^"]|\\")*)" )? \z/x) { return ($1, $2); } # disposition type must be form-data s/\A \s* form-data \s* ; //xi or return; my (%p, $k, $v); while (length) { s/ ^ \s+ //x; s/ \s+ $ //x; # skip empty parameters and unknown tokens next if s/^ [^\s"=;]* \s* ; //x; # parameter name (token) s/^ ([^\s"=;]+) \s* = \s* //x or return; $k = lc $1; # quoted parameter value if (s/^ "((?:[^"]|\\")*)" \s* (?: ; | $) //x) { $v = $1; } # unquoted parameter value (token) elsif (s/^ ([^\s";]*) \s* (?: ; | $) //x) { $v = $1; } else { return; } if ($k eq 'name' || $k eq 'filename') { return if exists $p{$k}; $p{$k} = $v; } } return exists $p{name} ? @p{qw(name filename)} : (); } my $params = Hash::MultiValue->new; my $uploads = Hash::MultiValue->new; my $part; my $parser = HTTP::MultiPartParser->new( boundary => '----------0xKhTmLbOuNdArY', on_header => sub { my ($headers) = @_; my $disposition; foreach (@$headers) { if (/\A Content-Disposition: [\x09\x20]* (.*)/xi) { $disposition = $1; last; } } (defined $disposition) or die q/Content-Disposition header is missing/; my ($name, $filename) = extract_form_data($disposition); (defined $name) or die qq/Invalid Content-Disposition: '$disposition'/; $part = { name => $name, headers => $headers, }; if (defined $filename) { $part->{filename} = $filename; if (length $filename) { my $fh = File::Temp->new(UNLINK => 1); $part->{fh} = $fh; $part->{tempname} = $fh->filename; } } }, on_body => sub { my ($chunk, $final) = @_; my $fh = $part->{fh}; if ($fh) { print $fh $chunk or die qq/Could not write to file handle: '$!'/; if ($final) { seek($fh, 0, SEEK_SET) or die qq/Could not rewind file handle: '$!'/; $part->{size} = -s $fh; $uploads->add($part->{name}, $part); } } else { $part->{data} .= $chunk; if ($final) { $params->add($part->{name}, $part->{data}); } } } ); open my $fh, '<:raw', 't/data/001-content.dat' or die; while () { my $n = read($fh, my $buffer, 1024); unless ($n) { die qq/Could not read from fh: '$!'/ unless defined $n; last; } $parser->parse($buffer); } $parser->finish;