Subscribed unsubscribe Subscribe Subscribe

超簡易ファイルアップローダーを作ってみた

何故か自宅サーバーがFTPで繋がらないことが多く、でもちょっとした事情によりファイルのアップロードをしたいときに困ったので。

#!/usr/bin/perl -T
use strict;
use warnings;

use CGI;
use File::Basename;
use HTTP::Date;

my $script_name = basename $0;

my $cgi = CGI->new;
$cgi->charset("utf-8");
print $cgi->header(-charset => 'utf-8');
print $cgi->start_html(
    -title => 'upload',
    -encoding => 'utf-8',
    );
print q|<form method="post" enctype="multipart/form-data">
<input type="file" name="upload_file" />
<input type="submit" value="うpするぉ" />
</form>
|;
my $method = $ENV{'REQUEST_METHOD'};
if (defined $method && $method eq 'POST') {
    my $fh = $cgi->upload('upload_file') or die(qq(Invalid file handle returned.));
    my $name = $1 if $cgi->uploadInfo($fh)->{'Content-Disposition'} =~ /filename="(.*)"/;
    $name = $1 if $name =~ /.*\\(.*)/;
    print "Upload!! : $name<br />\n";
    open OUT, '>', $name or print $!;
    binmode OUT;
    my $buf;
    while (read $fh, $buf, 1024) {
        print OUT $buf;
    }
    close(OUT);
    close($fh);
}

print "<table>\n";
print "    <th>name</th><th>size</th><th>time</th>\n";
opendir DIR, '.';
for (readdir DIR) {
    next if m|^\.|;
    next if $_ eq $script_name;
    my $name = $_;
    my $size = -s $name;
    my $time = HTTP::Date::time2iso ((stat $name)[9]);
    print qq|    <tr>
        <td><a href="$name">$name</a></td>
        <td align="right">$size</td>
        <td>$time</td>
    </tr>
|;
}
close(DIR);
print "</table>";
print $cgi->end_html, "\n";