< web  portfolio >

#!/usr/local/bin/perl

##################################################
# PERL SCRIPT FOR UPLOADING FILES VIA WEB BROWSER
# Brenda C. Mondragon, 2000
#
# * Call the cgi without any arguments to produce an upload form
# * Works best if javascript is enabled
# SOME FEATURES:
# * Gives upload directory listing
# * Works on unix or NT
# * Gives a return link (or close window) to the calling form
# * You can specify which hosts can call the form
# * You can allow only certain extensions to upload, or alternatively block 
#   certain extensions from being uploaded
# * You can limit the size of uploads
# * Debugging mode to help troubleshoot

##################################################
# SET VARIABLES
##################################################
#
# DIRECTORY WHERE THE UPLOADED FILES WILL GO - WITH TRAILING SLASH 
# (be sure to use \\ in place of \ for NT, / for unix)
# the script must have permissions (such as 777) read/write/delete to this directory
# EXAMPLES: $filedir = "D:\\www\\www.mysite.com\\cgi-bin\\data\\";
#           $filedir = "/www/www.mysite.com/data/";
$filedir = "";

# HOSTS ALLOWED ACCESSING THIS CGI
@referer = ('dragon','rmi.net');

# EXTENSIONS THAT CAN BE UPLOADED, LEAVE BLANK IF NO RESTRICTIONS
# for example to allow only (web) images to be uploaded: @extensions = ('gif','jpg');
@extensions = ();

# EXTENSIONS YOU DEFINITELY WANT TO BLOCK UPLOADING 
# (note: if you define extensions that CAN be uploaded above that effectively blocks everything but those 
# extensions -  this setting is mostly in case you want to leave @extensions() empty to allow uploading 
# ALMOST anything and block only certain kinds of files [like .cgi, .exe etc.])
@block_extensions = ('exe');

# size limit (in K) of the uploaded file
$allowed_upload = '500';

# name of this cgi script
$cginame = 'upload.cgi';

# set debug to 1 if you would like to print out status messages instead of running script
$debug = 0;

##################################################
# figure out the OS....
if    ($0 =~ m!^(.*)\\!)  { $ostype = "win"; }  # win/dos  separator \
elsif ($0 =~ m!^(.*):!)   { $ostype = "mac"; }  # mac      separator :
elsif ($0 =~ m!^(.*)/!)   { $ostype = "unx"; }  # Unix     separator /
else  { $ostype = "unx"; }  # Unix is default
print "<B>OSTYPE = $ostype</B>\n" if $debug;

# newline code
if ($ostype eq "win") { $newlinecode = "\r\n"; }
if ($ostype eq "unx") { $newlinecode = "\r\n"; }

# command on this system to get a directory listing ('dir' for NT, 'ls -l' for unix)
if ($ostype eq "win") { $dircommand = 'dir'; }
if ($ostype eq "unx") { $dircommand = 'ls -x'; } 
print "<B>DIRCOMMAND = $dircommand</B>\n" if $debug;
...

###################################################
# SUBROUTINES

# BEGIN UPLOAD FILE PROCEDURE:
sub upload {

   $| = 1;
   $buffer =~ /^(.+)$newlinecode/;
   $bound = $1;
   @pairs = split(/$bound/,$buffer);
   @var = split(/$newlinecode/,$pairs[2]);
   
   ## FOR TESTING:
   print "<B>BUFFER EQUALS:</B>\n$buffer\n" if $debug;
   print "<B>BOUND EQUALS:</B>\n$bound\n" if $debug;
   print "<B>PAIRS[0] (pairs is splitting the \$buffer by \$bound):</B>\n$pairs[0]\n" if $debug;
   print "<B>PAIRS[1] (file content gobbledygook):</B>\n$pairs[1]\n" if $debug;
   print "<B>PAIRS[2]:</B>\n$pairs[2]\n" if $debug;
   print "<B>VAR[0] (var is splitting pairs[2] by \$newlinecode):</B>\n$var[0]\n" if $debug;
   print "<B>VAR[1]:</B>\n$var[1]\n" if $debug;
   print "<B>VAR[2]:</B>\n$var[2]\n" if $debug;
   print "<B>VAR[3] (file name on server):</B>\n$var[3]\n" if $debug;
   
   $filename = $var[3];
   $fname = $filename;
   &checkname;
   if ($pairs[1] =~ /Content-Type:/) {
      $pairs[1] =~ s/^$newlinecode.+filename.+[^\w\.\%-]([\w\.\%-]+)"$newlinecode(.*$newlinecode)$newlinecode//;
      $pairs[1] =~ s/$newlinecode$//;
   }
   else {
     @var = split(/$newlinecode/,$pairs[1]);
     $pairs[1] = $var[3];
   }

   $pairs[1] =~ s/\&action=upload//;
   print "<B>pairs[1] (file about to be written):</B>\n$pairs[1]\n" if $debug;
   exit(0) if $debug;
   
   open(OUTPUT,">$filedir$filename");
   binmode(OUTPUT);
   print OUTPUT $pairs[1];
   close(OUTPUT);
   
   $absolute_filename = "$filedir$filename";
   $filesize = -s $absolute_filename;
   
   if ($filesize > ($allowed_upload * 1000))  {
      unlink("$absolute_filename");
      &report("The file <B><TT>$filename</TT></B> was not uploaded because its size exceeded the limit of $allowed_upload kb.");
   }
   else {
      &check_creation($absolute_filename);
      $return_link = "<A HREF=\"$referpage\" onClick=\"if (window.opener) {window.close()}\">RETURN</A>";
      &report("The file <B><TT>$filename</TT></B> has been uploaded.<BR><BR><CENTER>$return_link</CENTER><BR><BR>");
   }
   
   chmod(0777,"$filedir$filename");
   
   exit(0);
}
# END UPLOAD FILE PROCEDURE