upload.pl
branchtesting
changeset 22 35e487d91ad9
parent 17 dc78008e8c97
child 23 7d003f241139
equal deleted inserted replaced
21:d1d25ca0be3f 22:35e487d91ad9
    22 
    22 
    23 use 5.010;
    23 use 5.010;
    24 use strict;
    24 use strict;
    25 use warnings;
    25 use warnings;
    26 use Cwd qw(abs_path);
    26 use Cwd qw(abs_path);
    27 use CGI qw(:all *table);
    27 use CGI qw(:cgi);
    28 use CGI::Carp qw(fatalsToBrowser);
    28 use CGI::Carp qw(fatalsToBrowser);
    29 use CGI::Pretty;
    29 use CGI::Pretty;
    30 use File::Basename;
    30 use File::Basename;
    31 use FindBin qw($Bin);
    31 use FindBin qw($Bin);
    32 use Digest::MD5 qw(md5_hex);
    32 use Digest::MD5 qw(md5_hex);
    34 use Template;
    34 use Template;
    35 
    35 
    36 my $DIR     = "d/{view}";
    36 my $DIR     = "d/{view}";
    37 my $DIR_URI = "./$DIR";
    37 my $DIR_URI = "./$DIR";
    38 
    38 
    39 sub human($);
    39 sub _human($);
       
    40 sub _upload($$);
       
    41 sub _get_files($$);
    40 
    42 
    41 delete @ENV{ grep /PATH/, keys %ENV };
    43 delete @ENV{ grep /PATH/, keys %ENV };
    42 $ENV{PATH} = "/usr/local/bin:/usr/bin:/bin:/usr/local/sbin:/usr/sbin:/sbin";
    44 $ENV{PATH} = "/usr/local/bin:/usr/bin:/bin:/usr/local/sbin:/usr/sbin:/sbin";
    43 
    45 
    44 $_ = dirname $DIR;
    46 $_ = dirname $DIR;
    69       or mkdir $DIR => 0750
    71       or mkdir $DIR => 0750
    70       or die "Can't mkdir $DIR: $!\n";
    72       or die "Can't mkdir $DIR: $!\n";
    71 
    73 
    72     #
    74     #
    73     # delete is simple
    75     # delete is simple
    74     #
    76     # 
    75 
    77 
    76     if (param("op") eq "rm") {
    78     if (param("op") eq "rm") {
    77 	param("id") =~ /([-a-z\d]+-\d+)/i;
    79 	param("id") =~ /([-a-z\d]+-\d+)/i;
    78         my $dir = $1;
    80         my $dir = $1;
    79         if (-d "$DIR/$dir") {
    81         if (-d "$DIR/$dir") {
    91     if (param("op") eq "admin") {
    93     if (param("op") eq "admin") {
    92 	my $tt = Template->new(%TT2_CONFIG)
    94 	my $tt = Template->new(%TT2_CONFIG)
    93 	    or die Template->error();
    95 	    or die Template->error();
    94 	print header(-charset => "UTF-8");
    96 	print header(-charset => "UTF-8");
    95 	$tt->process("admin" => {
    97 	$tt->process("admin" => {
       
    98 	    view => $ENV{REMOTE_USER},
       
    99 	    alink => "?op=admin",
    96 	}) or die $tt->error;
   100 	}) or die $tt->error;
    97 	exit 0;
   101 	exit 0;
    98     }
   102     }
    99 
   103 
   100     #
   104     #
   101     # it is an upload
   105     # it is an upload
   102     # 
   106     # 
   103 
   107 
   104     if (length(my $file = param("upload"))) {
   108     if (length(param("upload"))) {
   105         my $days = param("expires");
   109 	_upload(param("upload"), param("expires"));
   106         my $expires;
       
   107         tie my $uuid => "OSSP::uuid::tie", "v4";
       
   108 
       
   109         # sanitize expires
       
   110         $days =~ /.*?(\d+).*/;
       
   111         $days = defined $1 ? $1 : 10;
       
   112         $expires = time + $days * 86400;
       
   113 
       
   114         # sanitizing the filename
       
   115         (my $filename = $file) =~ tr /\\/\//;
       
   116         $filename =~ /(.*)/;
       
   117         $filename = $1;
       
   118 
       
   119         my $dir = "$DIR/$uuid-$expires";
       
   120         mkdir $dir, 0750 or die "Can't mkdir $dir: $!\n";
       
   121         open(my $outfh, ">" => "$dir/$filename")
       
   122           or die "Can't create $dir/$filename: $!\n";
       
   123         print {$outfh} <$file>;
       
   124 
       
   125         if (open(my $atfh, "|-" => "at now + $days days")) {
       
   126             print {$atfh}
       
   127               "rm -f \"$dir/$filename\"\n",
       
   128               "rmdir \"$dir\"\n";
       
   129             close $atfh;
       
   130         }
       
   131     }
   110     }
   132 
   111 
   133     # 
   112     my @files = _get_files($DIR, $DIR_URI);
   134     # now check for existing files
   113 
   135     #
   114     #
       
   115     # the rest uses some templates
       
   116     #
       
   117     my $tt = Template->new(%TT2_CONFIG) or die Template->error();
       
   118     print header(-charset => "UTF-8");
       
   119     $tt->process("overview" => {
       
   120 	    alink => "?op=admin",
       
   121 	    view => $ENV{REMOTE_USER},
       
   122 	    directory => "$DIR | " . path_info()  . " | " . url(-path => 0),
       
   123 	    sel => { 7 => "selected" },
       
   124 	    files => \@files,
       
   125     }) or die $tt->error;
       
   126     exit 0;
       
   127 }
       
   128 
       
   129 sub _upload($$) {
       
   130     my ($file, $days) = @_;
       
   131     my $expires;
       
   132     tie my $uuid => "OSSP::uuid::tie", "v4";
       
   133 
       
   134     # sanitize expires
       
   135     $days =~ /.*?(\d+).*/;
       
   136     $days = defined $1 ? $1 : 10;
       
   137     $expires = time + $days * 86400;
       
   138 
       
   139     # sanitizing the filename
       
   140     (my $filename = $file) =~ tr /\\/\//;
       
   141     $filename =~ /(.*)/;
       
   142     $filename = $1;
       
   143 
       
   144     my $dir = "$DIR/$uuid-$expires";
       
   145     mkdir $dir, 0750 or die "Can't mkdir $dir: $!\n";
       
   146     open(my $outfh, ">" => "$dir/$filename")
       
   147       or die "Can't create $dir/$filename: $!\n";
       
   148     print {$outfh} <$file>;
       
   149 
       
   150     if (open(my $atfh, "|-" => "at now + $days days")) {
       
   151 	print {$atfh}
       
   152 	  "rm -f \"$dir/$filename\"\n",
       
   153 	  "rmdir \"$dir\"\n";
       
   154 	close $atfh;
       
   155     }
       
   156 }
       
   157 
       
   158 sub _get_files($$) {
       
   159     my ($base, $base_uri) = @_;
       
   160 
   136     my @files;
   161     my @files;
   137     foreach (map { /(.*)/ } sort { -M $a <=> -M $b } glob "$DIR/*-*/*") {
   162     foreach (map { /(.*)/ } sort { -M $a <=> -M $b } glob "$base/*-*/*") {
   138 	my ($file, $dir) = fileparse($_);
   163 	my ($file, $dir) = fileparse($_);
   139 	$dir = basename $dir;
   164 	$dir = basename $dir;
   140 
   165 
   141 	# $dir =~ /(?<hash>\S+)-(?<expires>\d+)$/ or next;
       
   142 	$dir =~ /(\S+)-(\d+)$/ or next;
   166 	$dir =~ /(\S+)-(\d+)$/ or next;
   143 	my $hash    = $1;
   167 	my $hash    = $1;
   144 	my $expires = $2;
   168 	my $expires = $2;
   145 	if ($expires <= time) {
   169 	if ($expires <= time) {
   146 	    /(.*)/;
   170 	    /(.*)/;
   148 	    rmdir $dir or die "Can't rmdir $dir: $!\n";
   172 	    rmdir $dir or die "Can't rmdir $dir: $!\n";
   149 	    next;
   173 	    next;
   150 	}
   174 	}
   151 
   175 
   152 	push @files, {
   176 	push @files, {
   153 	    link => "$DIR_URI/$dir/$file",
   177 	    link => "$base_uri/$dir/$file",
   154 	    name => $file,
   178 	    name => $file,
   155 	    size => human((stat $_)[7]),
   179 	    size => _human((stat $_)[7]),
   156 	    mtime => (stat $_)[9],
   180 	    mtime => (stat $_)[9],
   157 	    dtime => $expires,
   181 	    dtime => $expires,
   158 	    dlink => "?op=rm&id=$dir",
   182 	    dlink => "?op=rm&id=$dir",
   159 	}
   183 	}
   160 
   184 
   161     }
   185     }
   162 
   186     return @files;
   163     #
       
   164     # the rest uses some templates
       
   165     #
       
   166     my $tt = Template->new(%TT2_CONFIG) or die Template->error();
       
   167     print header(-charset => "UTF-8");
       
   168     $tt->process("overview" => {
       
   169 	    alink => "?op=admin",
       
   170 	    view => $ENV{REMOTE_USER},
       
   171 	    directory => $DIR,
       
   172 	    sel => { 7 => "selected" },
       
   173 	    files => \@files,
       
   174     }) or die $tt->error;
       
   175     exit 0;
       
   176 }
   187 }
   177 
   188 
   178 sub human($) {
   189 sub _human($) {
   179     my $_     = shift;
   190     my $_     = shift;
   180     my @units = qw(B K M G T);
   191     my @units = qw(B K M G T);
   181     while (length int > 3 and @units) {
   192     while (length int > 3 and @units) {
   182         $_ = sprintf "%.1f" => $_ / 1024;
   193         $_ = sprintf "%.1f" => $_ / 1024;
   183         shift @units;
   194         shift @units;