Perl скрипт для загрузки файлов

Question

Я пытаюсь написать скрипт на Perl, который позволит пользователю загрузить файл. На данный момент он говорит, что работает, но на самом деле не загружает файл!

Вот код:

 #!/usr/bin/perl
 use CGI;
 my $cgi = new CGI;
 my $dir = 'sub';
 my $file = $cgi->param('file');
 $file=~m/^.*(\\|\/)(.*)/;
 # strip the remote path and keep the filename
 my $name = $2;
 open(LOCAL, ">$dir/$name") or print 'error';
 while(<$file>) {
    print LOCAL $_;
 }
 print $cgi->header();
 print $dir/$name;
 print "$file has been successfully uploaded... thank you.\n";enter code here

Answer 1

Как указал CanSpice, этот вопрос дает ответ:

 #!/usr/bin/perl
 use CGI;
 my $cgi = new CGI;
 my $dir = 'sub';
 my $file = $cgi->param('file');
 $file=~m/^.*(\\|\/)(.*)/;
 # strip the remote path and keep the filename
 my $name = $2;
 open(LOCAL, ">$dir/$name") or print 'error';
 my $file_handle = $cgi->upload('file');     // get the handle, not just the filename
 while(<$file_handle>) {               // use that handle
    print LOCAL $_;
 }
 close($file_handle);                        // clean the mess
 close(LOCAL);                               // 
 print $cgi->header();
 print $dir/$name;
 print "$file has been successfully uploaded... thank you.\n";enter code here

Answer 2

Вы можете использовать этот код, будет работать правильно.

#!/usr/bin/perl
 use CGI;
 my $cgi = new CGI;
 my $dir = 'sub';
 my $file = $cgi->param('file');
 $file=~m/^.*(\\|\/)(.*)/;
 # strip the remote path and keep the filename
 my $name = $2;
 open(LOCAL, ">$dir/$name") or print 'error';
 my $file_handle = $cgi->upload('file');     // get the handle, not just the filename
binmode LOCAL;
 while(<$file_handle>) {               // use that handle
    print LOCAL;
 }
 close($file_handle);                        // clean the mess
 close(LOCAL);                               // 
 print $cgi->header();
 print $dir/$name;
 print "$file has been successfully uploaded... thank you.\n";enter code here

Answer 3

CGI, помимо большого количества документации, также содержит множество примеров, см. http://search.cpan.org/dist/CGI/MANIFEST

Итак, в сочетании с этими знаниями, вы можете написать

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

# to avoid those pesky 500 errors
BEGIN {
    CGI::Carp::set_message(
        sub {
            print "<h1>Oooh I got an error, thats not good :)</h1>\n";
            if (DEBUG) {
                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; }

Ваш код уменьшается при переключении на Dancer / Catalyst / Mojolicious