#!/usr/local/bin/perl -wT

## This version updated: 4/4/2001 by Tom Melly
##!c:/perl/bin/perl -wT

use strict;
use CGI qw(:/standard/);

############################################
### USER PARAMS - SEE 'README' FOR USAGE ###
############################################

# file-output options
my $filedir  =         '../upload/';
my $max_size =        1024000;
my $max_dir_size =    100 * $max_size;

# html options
my $success =         0;
my $fail    =         0;
my $allow_form =      1;
my $interp_success =  0;
my $interp_fail =     0;
my $link =            '/cgi/cgi-bin/upload.pl';

# mail options
my $mailer  =         '/usr/lib/sendmail';
my $recipient =       'upload@foobar.com';
my $mail_recipient =  0;
my $mail_sys_error =  0;

# security options (see also '$allow_form')
my @referers =        ('localhost', 'www.foobar.com');
my $password =        '';
my @valid_ext =       ('txt','htm','html','zip','gif','jpg','jpeg','png');

# defined form params
my %param_hash = (
  'name',     ['Name',             'textfield', 1,  0],
  'email',    ['Email Address',    'textfield', 2,  0],
  'comment',  ['File Description', 'textarea',  3,  0],
);

###################
#### MAIN-PROG ####
###################

# some security and cgi-upload settings
$CGI::POST_MAX = $max_size;
$ENV{PATH} = "/bin:/usr/bin:/usr/sbin";
$CGI::DISABLE_UPLOADS = 0;
delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};

# create cgi object - needed for sub_error, hence first
my $q = CGI::new();

if($ENV{CONTENT_LENGTH} > $max_size){
  sub_error("File too large - must be less than $max_size kb");
}

# check that target direc. is not too full
my $dir_size;
open DIR, $filedir || sys_error("Cannot open $filedir");
while(defined readdir DIR){
  $dir_size += -s "$filedir/$_";
}
if($dir_size += $ENV{CONTENT_LENGTH} > $max_dir_size){
  sys_error("$filedir is full")
}  

# setup file param
$param_hash{'file'} = ['File', 'filefield', 0, 1, 1];

# sort keys order for automated output
my @sorted_keys =
  sort {$param_hash{$a}[2] <=> $param_hash{$b}[2]} keys %param_hash;

# if no params sent, create new form if allowed, or return sub. error
if(!$q->param()){
  if(!$allow_form){
    sub_error("Please use an appropriate form to access this script");
  }
  else{
    return_form();
  }
}

# check password
if($password && $q->param('password') ne $password){
  sub_error("Bad Password");
}

#check and handle invalid referers
my $referer_ok = 0;
if (scalar @referers){ # & $$ENV{'HTTP_REFERER'}) {
  foreach(@referers) {
    if ($ENV{'HTTP_REFERER'} =~ m#https?://([^/]*)$_#i) {
      $referer_ok = 1;
      last;
    }
  }
}
else{
  $referer_ok = 1;
}
unless($referer_ok){
  sub_error("Bad referering URL");
}

# get, untaint and check required params from form
my $is_missing = 0;
my @missing;
my $param_val;
foreach(@sorted_keys){
  chomp($param_val = $q->param($_));
  $param_hash{$_}[5] = untaint_val($param_val, $param_hash{$_}[4]);
  #check for missing required params
  if($param_hash{$_}[3] && !$param_hash{$_}[5]){
    $is_missing = 1;
    push @missing, $param_hash{$_}[0];
  }
}
if($is_missing){
  sub_error(@missing);
}

# check for valid extensions, create output filename from input filename
my $ext_ok = 0;
foreach(@valid_ext){
  if($q ->param('file') =~ /.*\.$_$/){
    $ext_ok = 1;
  }
}
if(!$ext_ok){
  sub_error('Invalid file type (bad extension)');
}

$param_hash{'outfile'}[5] = untaint_val($param_hash{'file'}[5], 2);
$param_hash{'outfile'}[0] = 'Output Name';
if(!$param_hash{'outfile'}[5]){
  sub_error("Error in filename - $param_hash{'file'}[5] is too odd");
}

# transfer and save file
my $upfilefh = $q->param('file');
my $buffer = "";
my $buffer_size = 16384;
my $outfile = $param_hash{'outfile'}[5];
open(OUTPUT, ">$outfile")||
  sys_error("Cannot create file: $outfile - error may be temporary");

# need for win32
binmode $upfilefh;
binmode OUTPUT;

while(read($upfilefh, $buffer, $buffer_size)){
  print OUTPUT $buffer||
    sys_error("Unable to write to file: $outfile - error may be temporary");
}
close OUTPUT||sys_error("Unable to close file: $outfile");

# sendmail subroutine call
if($mail_recipient){
  send_mail();
}

# redirect to success page
if($success){
  return_html($success, $interp_success, '');
}
else{
  create_html('success', '');
}

exit;

######################
#### SUB-ROUTINES ####
######################

# untaints values according to untaint type
sub untaint_val{
  my $val = $_[0];
  my $untaint = $_[1];

  '' =~ /(.*)/; # set $1 to ''

  # user input - allow most general text and punc.
  if(!$untaint){
    $val =~ s#^-|[^\n\w/~@.,:;'"!?\$\s\#=-]#_!#g;
    $val =~ /(.*)/s; # we've cleaned it above
    $val = $1;
  }

  # file - allow normal file & path chars
  elsif($untaint == 1){
    $val =~ s#[^:\\\w\s./]#_!#g;
    $val =~ /(.*)/;
    $val = $1;
  }

  # outfile - output base filename, avoiding replace of existing files
  elsif($untaint == 2){
    $val =~ s/\s/_/g;
    $val =~ /(\w+[\w\._]*)$/;
    $val = $1;
    my $filecheck = -e $filedir . $val;
    my $fileinc = 0;
    while($filecheck){
      $fileinc ++;
      $val = $fileinc . '_' . $val unless
        $filecheck = -e $filedir . $fileinc . '_' . $val;
    }
    $val = $filedir . $val;
  }
  return $val;
}

# system error handling - nothing fancy since we're having sys problems
sub sys_error{
  my($reason) = @_;
  if($mail_sys_error){
    send_mail("System Error\n\n", $reason);
  }
  print $q->header("text/html")||die("can't print to STDOUT");
  print $q->start_html("System Error");
  print $q->h1("System Error") . "\n";
  print $q->p("Upload not processed because of the following error:") . "\n";
  print $q->p($reason) . "\n";
  print $q->p("on submission: " . $param_hash{'file'}[5]) . "\n";
  print $q->p($q->a({-href=>$link},'Back')) if $link;
  print $q->end_html;
  exit;
}

# submission error handling
sub sub_error{
  my $reason = '<ul>';
  foreach(@_){
    $reason = $reason . '<li>' . $_ . '</li>' . "\n";
  }
  $reason = $reason . '</ul>';
  if($fail){
    return_html($fail, $interp_fail, $reason);
  }
  else{
    create_html('fail', $reason);
  }
  exit;
}

# returned output to submitter - handles error or success
sub return_html {
  my($page, $interpret, $message) = @_;
  $param_hash{'link'}[5] = $link if $link;
  $param_hash{'message'}[5] = $message;
  if($interpret){
    open(IN, "$page")|| sys_error("cannot read return file: $page");
    print $q->header("text/html");
    my @lines = <IN>;
    my $line;
    foreach $line(@lines){
      if($line =~ /PARAM\:/){
        $line =~ s/PARAM\:([\w_]+)/$param_hash{$1}[5]/g;
      }
      print $line;
    }
  }
  else{
    print $q->redirect($page);
  }
  exit;
}

# mail sub
sub send_mail {
    my $extra_info = $_[0];
    # avoid mailing mail errors (infinite loop)
    my $temp = $mail_sys_error;
    $mail_sys_error = 0;
    open(MAIL,"|$mailer -t -i")||sys_error("Cannot open sendmail: $mailer");

    print MAIL "To: $recipient\n";
    print MAIL "From: upload script\n";
    print MAIL "Reply-to: $recipient\n";

    print MAIL "Subject: File submission $extra_info\n";

    print MAIL "$extra_info\n\n";
    print MAIL "Here is what was sent:\n";

   foreach(@sorted_keys){
      print MAIL "$param_hash{$_}[0]: $param_hash{$_}[5]\n";
    }
    print MAIL "$param_hash{'outfile'}[0]: $param_hash{'outfile'}[5]\n"
      if($param_hash{'outfile'}[5]);

    close (MAIL)||sys_error("Cannot close sendmail: $mailer");
    $mail_sys_error = $temp;
}

# basic form for submissions if not called from form
sub return_form {
  my $formparam;
  print $q->header("text/html")||die("can't print to STDOUT");
  print $q->start_html("Form Upload");
  print $q->h1("File Upload Form") . "\n";
  print $q->startform({-method=>'POST', -enctype=>'multipart/form-data'});
  print '<table>';
  foreach(@sorted_keys){
    $formparam = $param_hash{$_}[1];
    print '<tr><td>' . $param_hash{$_}[0];
    print ' (required)' if $param_hash{$_}[3];
    print '</td><td>';
    print $q->$formparam($_);
    print " Allowed Extensions: @valid_ext."
      if($formparam eq 'filefield');
    print '</td></tr>' . "\n";
  }
  print '<tr><td>Password (required)</td><td>'
    . $q->password_field('password') . '</td></td>' if $password;

  print '</table>';
  print $q->submit;
  print $q->reset;
  print $q->endform;
  print $q->end_html;
  exit;
}

# creates results html if no defined html for success/fail
sub create_html{
  my($type, $message) = @_;
  print $q->header("text/html")||die("can't print to STDOUT");
  if($type eq 'success'){
    print $q->start_html("Upload Success");
    print $q->h1("Upload Success");
    print $q->p("Thank you for your submission") . "\n";
    foreach(@sorted_keys){
      print "$param_hash{$_}[0] : $param_hash{$_}[5]" . "<br>\n";
    }
    print 'Output to: ' . $q->a({-href=>$param_hash{'outfile'}[5]},
      $param_hash{'outfile'}[5])
      if($param_hash{'outfile'}[5]);
    print $q->p($message) if $message;
    print $q->p($q->a({-href=>$link},'Back')) if $link;
  }  
  if($type eq 'fail'){
    print $q->start_html("Upload Fail");
    print $q->h1("Upload Fail");
    print $q->p("The following fields were not filled in,
      or filled with something odd:") . "\n";
    print $q->p($message) . "\n" if $message;
    print $q->p("Please use your browser's back button and try again");
    print $q->p($q->a({-href=>$link},'Back')) if $link;
  }  
  print $q->end_html;
  exit;
}
