#!/usr/bin/perl -w
use strict;
use warnings;
=pod
Q. "How do I do a file upload?"
A. Answer in three steps:
1) Use CGI.pm unless you have a problem with that.
There's other ways to do it, but this is the easiest
way I've ever found.
2) Use the 'enctype' attribute correctly in your HTML <form></form> tag.
ex-
<form
action="foo.cgi"
method="POST"
enctype="multipart/form-data">
3) Push the 'submit' button.
(HAH! Just kidding...)
This concludes our brief tutorial. Now then, here's a stand-alone CGI script
that demonstrates steps one and two. Sorry, but you'll have to do step three
for yourself.
=cut
# use CGI.pm to handle retrieval of form field values and uploaded files.
use CGI qw( header );
# enable uploads, if turned off by default
$CGI::DISABLE_UPLOADS = 0;
# maximum allowed size for file uploads.
# this sets the max upload size to 5 megabytes. adjust as needed.
$CGI::POST_MAX = 1024 * 5000;
# create a new CGI object (-if you don't know what that is, who cares.
# the code will still work. in the mean time, see the perldoc section
# entitled 'perltoot' for a brief explanation about objects in Perl
my($cgi) = CGI->new();
# do something to determine if this script should try to manage a file
# upload at this point, or print out the html file upload form
print(header . &htform) and exit unless $cgi->param('X-been-here');
# handle uploads
my($upload) = &file_upload
(
'-upload-field-name' => 'my_upload_field',
'-target-directory' => './save/upload/here',
'-save-upload-as' => 'some_file_name',
'-overwrite-OK' => 1,
);
# check for upload success/failure
if ($upload && -e $upload) {
print(header . <<__COOL__);
You just did a file upload!
That was so cool! :O)
__COOL__
}
else {
print(header . <<__FOOEY__);
The attempted upload was not successful.
Sorry, that really sucks, man :O(
__FOOEY__
}
# code that handles file uploads
sub file_upload {
# upload target directory, name of the file upload form field
my($target_dir) = %{{@_}}->{'-target-directory'} || bad_call();
my($field_name) = %{{@_}}->{'-upload-field-name'} || bad_call();
my($file_name) = %{{@_}}->{'-save-upload-as'};
# don't worry about it if nothing got uploaded
return undef unless defined($cgi->param($field_name));
# auto-name files without override
unless ($file_name) {
# clean up raw name of the file being uploaded
$file_name = $cgi->param($field_name);
$file_name =~ s/^.*(?:\\|\/|\:)//;
$file_name =~ s/[\|\s\*\"\?\<\%\>]/\_/g;
}
# trailing directory path seperator on target dir? whack it.
$target_dir =~ s/(?:\\|\/|\:)$//;
# bypass uploads for pre-existant files unless -overwrite-OK
return(bypass(qq[$target_dir/$file_name]))
if (-e qq[$target_dir/$file_name] and !%{{@_}}->{'-overwrite-OK'});
# get an open filehandle on the file upload
my($IN) = $cgi->upload($field_name) || return undef;
# localize filehandle in case it's in use somewhere else. not likely.
local(*OUT);
# only using filehandle reference here for consistency with CGI.pm *GLOB{IO}
# upload interface (which by the way, employs a pretty clever use of Perl's
# magical filehandles. kudos LS.)
my($OUT) = \*OUT;
# get an open filehandle to the place where the uploaded file will be saved
open($OUT, qq[>$target_dir/$file_name])
or die(qq[Can't upload to "$target_dir/$file_name" $!]);
# prepare for system level I/O (this isn't buffered)
my($bytes_read, $bytes_written, $read_offset, $offset) = (0,0,0,0);
my($block_size) = 1024; # this should be fine for most
my($data) = '';
{ # save the upload to its now-determined name
# see perldoc -f sysread and the Perl FAQ section on 'files'
while ($bytes_read = sysread($IN,$data,$block_size,$offset)) {
# paranoia - (CGI.pm handles this already)
if (($bytes_written + $block_size) >= $CGI::POST_MAX) {
# truncate uploads that are too big.
print(header . <<__2BIG__) and exit;
Your upload has been cut short. The file size of your upload exceeds
the maximum size allowed for a file upload.
__2BIG__
}
# see perldoc -f syswrite and the Perl FAQ section on 'files'
$bytes_written = syswrite($OUT,$data,$bytes_read,$offset);
# I/O failure during disk writes - not common.
die(qq[Upload: system write error $!]) if !defined($bytes_written);
$offset += $bytes_written;
}
}
# close filehandles
close($IN); close($OUT);
# return somewhat useful success status
return($target_dir . '/' . $file_name);
# handle bad calls to the subroutine
sub bad_call { die(<<'__REBUKE__' . &usage) }
Hey! Your file upload failed because you called the subroutine "file_upload"
without the required arguments.
__REBUKE__
# called when bypassing when upload is necessary
sub bypass { warn(<<__ERR__ . &usage); undef }
Upload bypassed.
File "@{[$_[0]||'']}" exists.
Won't overwrite without force. Allow files to be overwriten by calling the
subroutine "file_upload" with the '-overwrite-OK' option set to a true value.
Continuing normal program execution without saving the current upload...
__ERR__
# help in times of need
sub usage { <<'__USAGE__' }
USAGE: &file_upload([option => value]);
OPTIONS:
-target-directory Directory path where the uploaded file will be
aved. *You must provide a value for this option.
-upload-field-name Name of the HTML form field corresponding to the
file being uploaded. *You must provide a value
for this option.
-save-upload-as Optionally specify a new filename to use when
saving an uploaded file. File will otherwise
be saved with the same name it had on the remote
client, minus the file path of course.
-overwrite-OK Optionally force existing files to be overwritten.
Uploads are otherwise skipped when there is an
existing file with the same name inside the target
directory.
EXAMPLE:
my($upload) = &file_upload
(
'-target-directory' => './save/upload/here', # required!
'-upload-field-name' => 'my_upload_field', # required!
'-save-upload-as' => 'some_file_name', # optional
'-overwrite-OK' => 1, # optional
);
print("The upload was successful.") if ($upload && -e $upload);
__USAGE__
}
# generates sample HTML form used in the script.
sub htform { <<'__FORM__' }
<?xml version="1.0" encoding='ISO-8859-1'?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html
xmlns="http://www.w3.org/1999/xhtml"
xml:lang="en"
lang="en">
<head>
<title>CGI Upload</title>
<meta
http-equiv="Content-Type"
content="text/html; charset=iso-8859-1" />
<link rel="stylesheet" type="text/css" href="/css/styles.css" />
</head>
<body>
<p> </p>
<div class="indent30">
<form
name="CGI Upload"
method="post"
enctype="multipart/form-data">
<input
type="file"
name="my_upload_field" />
<input
type="hidden"
name="X-been-here"
value="1" />
<input
type="submit"
value="begin upload"
onclick="foil_grandma(this)" />
</form>
</div>
<script
type="text/javascript"
xml:space="preserve">
<!--
// a javascript trick to help foil the double-clickers.
// this is just javascript. it won't always work. don't depend on it.
function foil_grandma(submit_button) {
submit_button.style.visibility="hidden";
alert("\
Please be patient while the upload is in transit.\n\
It could take a minute or two if the file is big or\n\
your internet connection is slow.\n\n\
If you push the back button or go to another page,\n\
your upload will be cut off.");
return true;
}
// --></script>
<p> </p>
</body>
</html>
__FORM__
# all done.
=pod
AUTHOR
Tommy Butler <cpan@atrixnet.com>
phone: (817)-468-7716
6711 Forest Park Dr
Arlington, TX
76001-8403
COPYRIGHT Tommy Butler, all rights reserved.
LISCENCE This library is free software, you may redistribute
and/or modify it under the same terms as Perl itself.
=cut