#!/usr/bin/perl --
use constant DEBUG => !!( 0 || $ENV{PERL_DEBUG_MYAPPNAME} );
use CGI::Carp qw( fatalsToBrowser );
use CGI;

# to avoid those pesky 500 errors
BEGIN {
    CGI::Carp::set_message(
        sub {
            print "<h1>something broke, we know what it is, thank you,
+ try again later</h1>\n";
            if (DEBUG) { # secrets
                print '<p>', CGI->escapeHTML(@_), '</p>';
            }
        }
    );
} ## end BEGIN


use strict;
use warnings;
use Data::Dumper ();
use File::Copy qw' copy ';

Main( @ARGV );
exit( 0 );

sub Main {
    
#~     return DebugCGI(); # generic, env.cgi
    return SaveUploadsTo(
        CGI->new,
        [qw' file otheruploadfile andAnother '],
        '/destination/dir/where/uploads/end/up', 
    );
} ## end sub Main


sub SaveUploadsTo {
    my( $cgi,  $uploadFields , $destDir ) = @_;
    chdir $destDir
      or die "Cannot chdir to upload destination directory: $!\n";
    print $cgi->header;
    for my $field ( @{ $uploadFields } ){
        my $filename = $cgi->param( $field );
        my $tmpfilename = $cgi->tmpFileName( $filename );
        $filename = WashFilename( $filename ) ;
        
        my $destFile = File::Spec->catfile( $destDir, $filename );
        
        copy( $tmpfilename, $destFile )
          or die "Copy to ( $destFile ) failed: (( $! ))(( $^E ))";
        
        print "<p>Sucessfully uploaded  ",
            CGI->escapeHTML( $filename  ),
            " thanks</p>\n";
    }
    print "<P>done processing uploads</p>\n";
} ## end sub SaveUploadsTo

sub DebugCGI {
    my $cgi = CGI->new;
    print $cgi->header();    # Write HTTP header
    print $cgi->start_html,
      $cgi->b( rand time, ' ', scalar gmtime ),
      '<table border="1" width="%100"><tr><td>',
      $cgi->Dump,
      '</td>',
      '<td><div style="white-space: pre-wrap; overflow: scroll;">',
      $cgi->escapeHTML( DD($cgi) ),
      '</div></td></tr></table>',
      CGI->new( \%ENV )->Dump,
      $cgi->end_html;
} ## end sub DebugCGI


sub WashFilename {
    use File::Basename;
    my $basename = basename( shift );
    # untainted , only use a-z A-Z 0-9 and dot
    $basename = join '', $basename =~ m/([.a-zA-Z0-9])/g;
    # basename is now, hopefully, file.ext
    ## so to ensure uniqueness, we adulterate it :)
    my $id = $$.'-'.time;
    my( $file, $ext ) = split /\./, $basename, 2 ;
    return join '.', grep defined, $file, $id, $ext;
} ## end sub WashFilename

sub DD {
    scalar Data::Dumper->new( \@_ )->Indent(1)->Useqq(1)->Dump;
}
[download]