## START upload ##
my ($content);
require File::Path;
######## Config ############
## The number of directory levels, relative to document root,
## beyond which directory creation is not allowed
my $create_dir_limit = 8;
## Specify special keywords
my %location = (IMAGEDIR => $S->{UI}->{VARS}->{imagedir},
);
my $perm_prefix = 'upload_'; # used in perm_groups
######## End Config ########
my $path = $S->{CGI}->param('path');
if ($path and
my $upload = $S->{APR}->upload ) {
$path =~ s/^s+//;
$path =~ s/s+$//;
my ($access);
my ($rv, $sth) = $S->db_select({
FROM => 'vars',
WHAT => 'name, value',
WHERE => "category = 'upload'",
});
if ($rv > 0) {
while ( my($var,$val) = $sth->fetchrow ) {
$location{$var} = $val;
}
}
$sth->finish;
### Assume given path is relative to docroot
$path = "/$path" unless ($path =~ m,^/,);
foreach my $name (keys %location) {
my $loc = $location{$name};
next unless ($loc =~ /\S/ and $loc !~ /\.\./);
next unless ($path =~ /^$loc/);
$S->have_perm("$perm_prefix$name") && ($access = 1) && last;
}
if ($access) { ## permission granted
### Prepare to write file
### Get info about file data
my $filename = $upload->filename;
my $size = $upload->size;
my $docroot = $S->{APACHE}->document_root;
my $abort = 0;
$filename =~ s/^s+//;
$filename =~ s/s+$//;
$path =~ s/ /\ /g; ## escape spaces
$path =~ s/\.\./\./g; ## remove doubledots
## untaint
if ( $path =~ /^([\w\.-\/]+)$/ ) {
$path = $1;
} else {
$content .= qq|<p>Invalid path. Unable to upload file.</p>|;
$path = '';
$abort = 1;
}
## Create the directory for this file
(my $pathdir = "$docroot$path") =~ s,[^/]*$,,;
if (!-e $pathdir) {
if ( $path =~ /(?:\/.*){$create_dir_limit}/ ) {
$content .= qq|<p>Creating directories that many levels deep is not allowed. Choose a new path.</p>|;
$abort = 1;
} else {
eval {
File::Path::mkpath($pathdir, 0, 0755);
}
}
}
if (!$docroot) {
$content .= qq|<p>Server error.</p>|;
warn "No document root found.";
} elsif (-d "$docroot$path") {
### Add original filename to destination path
$filename =~ s/ /\ /g; ## escape spaces
$filename =~ s/\.\./\./g; ## remove doubledots
if ($filename =~ /^([\w\.-]+)$/) {
## untaint name
$filename = $1;
$content .= qq|<p>$path is a directory, so using filename $filename</p>|;
$path .= '/' unless ($path =~ m,/$,);
$path .= $filename;
if (-d "$docroot$path") { ## another directory!
$content .= qq|<p>$path is a directory too. Please include a different filename</p>|;
$abort = 1;
}
} else {
$content .= qq|<p>$path is a directory. Please include a valid filename too.</p>|;
$filename = '';
$abort = 1;
}
} else {
}
if (!-d "$docroot$path" and -e "$docroot$path") {
$content .= qq|<p>$path is being overwritten...</p>|;
}
unless ($abort) {
my $writefile = $docroot . $path;
## Write file
if (open OUT, ">$writefile" ) {
my ($buff,$bytes_read);
my $fh = $upload->fh;
while ($bytes_read = read($fh,$buff,2096)) {
$size += $bytes_read;
binmode OUT;
print OUT $buff;
}
close OUT;
# $content .= qq|<p>File <b>$path ($size bytes)</b> has been written.</p>|;
## $size gets doubles for some reason?
$content .= qq|<p>File <b>$path</b> has been written.</p>|;
} else {
$content .= qq|<p>Unable to write file $writefile... $!</p>|;
}
}
} else {
(my $pathdir = $path) =~ s,[^/]*$,,;
$content .= qq|<p>Access denied to area $pathdir.</p>|;
}
} else {
my $uri = $S->{APACHE}->uri;
$content .= qq|
<FORM name="upload_form" action="$uri" method="POST" enctype="multipart/form-data">
<table>
<tr>
<td>Specify path of local file to upload:</td>
<td><INPUT type="file" name="sourcefile" size="40"/></td>
</tr><tr>
<td>Specify destination path, including file name.</td>
<td><INPUT type="text" name="path" size="40"/></td>
</tr></table>
<INPUT type="submit" value="upload" />
</FORM>
|;
}
return $content;
## END upload ##
