#!I:\Interwoven\TeamSite\iw-perl\bin\iwperl -Tw

use strict;
use warnings;
use diagnostics;
use CGI;
use CGI::Carp qw(fatalsToBrowser warningsToBrowser set_message);   
set_message("It's not a bug, it's a feature!");

$CGI::POST_MAX = 1024 * 100;  # maximum upload filesize is 100K

######################## Build the form #########################

my $q = CGI->new;
my $OUTFILE;
my @ts_dir = qw();
my $video = 0;

print $q->header;
warningsToBrowser(1);

print $q->start_html(-title => "Upload file to web server"),
      $q->h3('Import File'),
      $q->start_multipart_form(
                               -name    => 'main_form',
                               -ENCTYPE => 'multipart/form-data',
                              ),
      'Click on the browse button to choose a filename: <BR>',
      $q->filefield(
                    -name      => 'filename',
                    -size      => 75,
                    -maxlength => 80,
                    ),
      $q->hr,
      $q->submit(-value => 'Upload file'),
      $q->hr,
      $q->end_form;

########## Look for uploads that exceed $CGI::POST_MAX ##########

if (!$q->param('filename') && $q->cgi_error()) {
    print $q->cgi_error();
    print <<'EOT';
<p>
The file you are attempting to upload exceeds the maximum allowable fi
+le size.
<p>
Please refer to your system administrator
EOT
    print $q->hr, $q->end_html;
    exit 0;
}

###################### Upload the file ########################

if ($q->param) {
    save_file($q);
}

print $q->end_html;

exit 0;

#-------------------------------------------------------------

sub save_file {

    my ($q) = @_;
    my ($bytesread, $buffer);
    my $num_bytes = 1024;
    my $totalbytes;
    my $source_filename = $q->upload('filename');
    my $untainted_filename;
    my $filename_orig = $source_filename;
    my $dir_path = "";
    my $destination_filename = "";    
    
    if (!$source_filename) {
            print $q->p('You must enter a filename before you can uplo
+ad it');
            return;
    }
    
    ################# CGI Variables to get path and user id ##########
+######
    print "<pre>\n";
    my $user_id = "";
    foreach my $key (sort keys(%ENV)) {
      if ($key =~ /QUERY_STRING/) {
        push(@ts_dir,$ENV{$key});
        #print "$ENV{$key}<p>";
      }
      elsif ($key =~ /IWUSER/) {
        $user_id = $ENV{$key};
        #print "$user_id<p>";
      }
    }
    print "</pre>\n";

    foreach my $d_path (@ts_dir) {
      $d_path =~ s/&done.*//;
      $d_path =~ s/.*=\/\/testserver//;  
      $dir_path = $d_path;
      #print "Destination Directory:<BR>";
      #print "$dir_path<p>";
    }
    
    # original vpath 
    my $orig_dir_path = $dir_path;
    
    $dir_path =~ s/\//\\/g;
    $dir_path = "Y:"."$dir_path"."\\";
    
    # absolute directory path
    my $ts_dir_path = $dir_path;
        
    ################ Untaint $source_filename #################
    if ($source_filename =~ /\.swf/ || $source_filename =~ /high/ || $
+source_filename =~ /low/) {
        $video = 1;
        $source_filename =~ /(\w+.\w+)$/;
        $untainted_filename = $1;
    } else {
        $video = 0;
        $source_filename =~ /(\w+.\w+)$/;
        $untainted_filename = $1;    
    }
    
    # restore original vpath
    $dir_path = $orig_dir_path;
    
    if ($video == 0 && $dir_path =~ /\/design\/user\/videos/) {
    #print "dir_path: $dir_path\n";
        die <<"EOT";
Only '.swf' files and files with 'high' or 'low' in the name will be u
+ploaded to /design/user/videos.
EOT
    } 
    elsif ($video == 1 && $dir_path !~ /\/design\/user\/videos/) {
    #print "dir_path: $dir_path\n";
        die <<"EOT";
Video files not allowed to be uploaded to current destination folder.
EOT
    }

    if ($untainted_filename =~ m/\.\./) {
        die <<"EOT";
Your upload filename may not contain the sequence '..' 
Rename your file so that it does not include the sequence '..', and tr
+y again.
EOT
    }
            
    opendir(DIR, $ts_dir_path);
    my @files = grep(/\.*$/,readdir(DIR));
    closedir(DIR);
    
    $source_filename = $filename_orig;
    $source_filename =~ s|.*\\||;
    
    # determine if the file already exists on server
    foreach my $ts_file (@files) {  

        if ($ts_file =~ m|$source_filename|) {
            die <<"EOT";
Your upload filename already exists at folder location on server. 
Rename your file, and try again.
EOT
        }
    } # End of foreach my $ts_file (@files) {
                            
    $dir_path = $orig_dir_path;
    
    if ($video == 1 && $dir_path =~ /\/design\/user\/videos/) {
        $destination_filename = "Y:\\main\\$untainted_filename";
    }
    elsif ($video == 0 && $dir_path !~ /\/design\/user\/videos/) {
        $dir_path =~ s/\//\\/g;
        $dir_path = "Y:"."$dir_path"."\\";
        print "dir_path: $dir_path<BR>";
        $destination_filename = "$dir_path"."$untainted_filename";
        print "destination_filename: $destination_filename<BR>";    
    }
    
    $source_filename = $filename_orig;
    print "<u>Upload Started:</u> <BR>$source_filename <BR><i>uploadin
+g to</i> <BR>$destination_filename<BR>";

    # If running this on a non-Unix/non-Linux/non-MacOS platform, be s
+ure to 
    # set binmode on the $OUTFILE filehandle, refer to 
    #    perldoc -f open 
    # and
    #    perldoc -f binmode
    
    open ($OUTFILE, '>', $destination_filename) || die "Couldn't open 
+$destination_filename for writing: $!";
    binmode($OUTFILE);
    
    while ($bytesread = read($source_filename, $buffer, $num_bytes)) {
        $totalbytes += $bytesread;
        print $OUTFILE $buffer;
    }
    die "Read failure" unless defined($bytesread);
    unless (defined($totalbytes)) {
        print "<p>Error: Could not read file ${untainted_filename}, ";
        print "or the file was zero length.";
    } else {
        print "<p><u>Upload Completed:</u> <BR>$source_filename <BR><i
+>uploaded to</i> <BR>$destination_filename ($totalbytes bytes)";
    }
    close $OUTFILE or die "Couldn't close $destination_filename: $!";
}
#-------------------------------------------------------------
[download]