#!/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 = '
' . $param_hash{$_}[0]; print ' (required)' if $param_hash{$_}[3]; print ' | '; print $q->$formparam($_); print " Allowed Extensions: @valid_ext." if($formparam eq 'filefield'); print ' |
Password (required) | ' . $q->password_field('password') . ' | ' if $password; print '