Initial commit
This commit is contained in:
eleksir
86
Slackmetarep/Buildinfo.pm
Normal file
86
Slackmetarep/Buildinfo.pm
Normal file
@@ -0,0 +1,86 @@
|
||||
package Slackmetarep::Buildinfo;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use vars qw/$VERSION/;
|
||||
use English qw( -no_match_vars );
|
||||
use Carp;
|
||||
|
||||
use JSON::XS;
|
||||
use Slackmetarep::Conf qw(loadConf);
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT_OK = qw(buildinfo);
|
||||
|
||||
$VERSION = '1.0';
|
||||
|
||||
my $c = loadConf();
|
||||
|
||||
sub buildinfo ($) {
|
||||
my $repo = shift;
|
||||
my ($status, $content, $msg) = ('400', 'text/plain', "Bad Request?\n");
|
||||
|
||||
return ($status, $content, $msg) unless ($repo =~ /\//xmsg);
|
||||
|
||||
my ($config, $package) = split(/\//xms, $repo);
|
||||
|
||||
unless (defined($c->{buildinfo}->{$config})) {
|
||||
$msg = "Config repo $config is not defined in config.\n";
|
||||
return ($status, $content, $msg);
|
||||
}
|
||||
|
||||
open (my $jhandle, '<', $c->{buildinfo}->{$config}) or do {
|
||||
$status = '500';
|
||||
$msg = "Unable to open $c->{buildinfo}->{$config}; $OS_ERROR\n";
|
||||
carp '[FATA] ' . $msg;
|
||||
return ($status, $content, $msg);
|
||||
};
|
||||
|
||||
my $len = (stat($c->{buildinfo}->{$config}))[7];
|
||||
my $json;
|
||||
my $readlen = read ($jhandle, $json, $len);
|
||||
close $jhandle; ## no critic (InputOutput::RequireCheckedSyscalls
|
||||
|
||||
unless (defined($readlen)) {
|
||||
$status = '500';
|
||||
$msg = "Unable to read $c->{buildinfo}->{$config}: $OS_ERROR";
|
||||
carp '[FATA] ' . $msg;
|
||||
return ($status, $content, $msg);
|
||||
}
|
||||
|
||||
if ($len != $readlen) {
|
||||
$status = '500';
|
||||
$msg = "Size of $c->{buildinfo}->{$config} $len bytes but actually read $readlen bytes";
|
||||
carp '[FATA] ' . $msg;
|
||||
return ('500', $content, "Unable to read $c->{buildinfo}->{$config}\n");
|
||||
}
|
||||
|
||||
my $j = eval { decode_json($json) } or do {
|
||||
$status = '500';
|
||||
$msg = "Error during decoding $c->{buildinfo}->{$config}; $EVAL_ERROR\n";
|
||||
carp '[FATA] ' . $msg;
|
||||
return ($status, $content, $msg);
|
||||
};
|
||||
|
||||
unless (defined($j->{$package})) {
|
||||
$msg = "$package is not defined in config for $config.\n";
|
||||
carp '[ERRO] ' . $msg;
|
||||
return ($status, $content, $msg);
|
||||
}
|
||||
|
||||
$json = JSON::XS->new->pretty->canonical->indent(1)->encode($j->{$package}) or do {
|
||||
$status = '500';
|
||||
$msg = "Unable to encode json.\n";
|
||||
carp '[ERRO] ' . $msg;
|
||||
return ($status, $content, $msg);
|
||||
};
|
||||
|
||||
$status = '200';
|
||||
$content = 'application/json';
|
||||
$msg = $json;
|
||||
return ($status, $content, $msg);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
43
Slackmetarep/Conf.pm
Normal file
43
Slackmetarep/Conf.pm
Normal file
@@ -0,0 +1,43 @@
|
||||
package Slackmetarep::Conf;
|
||||
# loads config
|
||||
|
||||
use 5.018;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use open qw(:std :utf8);
|
||||
use English qw( -no_match_vars );
|
||||
|
||||
use vars qw/$VERSION/;
|
||||
use JSON::XS;
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT_OK = qw(loadConf);
|
||||
|
||||
$VERSION = '1.0';
|
||||
|
||||
sub loadConf {
|
||||
my $c = 'data/config.json';
|
||||
open my $CH, '<', $c || die "[FATA] No conf at $c: $OS_ERROR\n";
|
||||
my $len = (stat ($c)) [7];
|
||||
my $json;
|
||||
my $readlen = read $CH, $json, $len;
|
||||
|
||||
unless ($readlen) {
|
||||
close $CH; ## no critic (InputOutput::RequireCheckedSyscalls
|
||||
die "[FATA] Unable to read $c: $OS_ERROR\n";
|
||||
}
|
||||
|
||||
if ($readlen != $len) {
|
||||
close $CH; ## no critic (InputOutput::RequireCheckedSyscalls
|
||||
die "[FATA] File $c is $len bytes on disk, but we read only $readlen bytes\n";
|
||||
}
|
||||
|
||||
close $CH; ## no critic (InputOutput::RequireCheckedSyscalls
|
||||
my $j = JSON::XS->new->utf8->relaxed;
|
||||
return $j->decode ($json);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4:
|
||||
387
Slackmetarep/Metagen.pm
Normal file
387
Slackmetarep/Metagen.pm
Normal file
@@ -0,0 +1,387 @@
|
||||
# Most of this data is generated during package build process and being uploaded
|
||||
# to pool alongside with packages themselves. So we can easily and fast regen meta.
|
||||
|
||||
# Assume that whole operation takes resonable amount of time to perform it syncronously
|
||||
|
||||
# metadata consists of
|
||||
# * CHECKSUMS.md5 or CHECKSUMS.md5.gz - checksum of each file in repo
|
||||
# * ChangeLog.txt - optional, contains history of changes, this script does not
|
||||
# handle it
|
||||
# * FILELIST.TXT - whole list of files that are part of repostory data or
|
||||
# metadata
|
||||
# * PACKAGES.TXT - packages description with metainfo such as relative path in
|
||||
# repo, compressed size and uncompressed size
|
||||
# * MANIFEST.bz2 - list of files in each package
|
||||
|
||||
# TODO: make metadata in atomic way
|
||||
# TODO: validate metadata
|
||||
|
||||
package Slackmetarep::Metagen;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
|
||||
use utf8;
|
||||
use open qw(:std :utf8);
|
||||
use vars qw/$VERSION/;
|
||||
use English qw( -no_match_vars );
|
||||
|
||||
use Carp;
|
||||
use Fcntl;
|
||||
use Compress::Raw::Bzip2 qw(BZ_RUN_OK BZ_STREAM_END);
|
||||
use Compress::Raw::Zlib;
|
||||
use POSIX qw(strftime);
|
||||
|
||||
use Slackmetarep::Conf qw(loadConf);
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT_OK = qw(metagen);
|
||||
|
||||
$VERSION = '1.0';
|
||||
|
||||
sub metagen($);
|
||||
sub __pdate; # generates current date in pretty format
|
||||
sub __trim($);
|
||||
sub __readfile($);
|
||||
sub __dirlist($);
|
||||
sub __writefile(@);
|
||||
sub __bzdata($);
|
||||
sub __gzdata($);
|
||||
|
||||
sub metagen ($) {
|
||||
my $dir = shift;
|
||||
my $c = loadConf();
|
||||
$dir = $c->{metagen}->{$dir};
|
||||
|
||||
unless (defined $dir || ($dir eq '')) {
|
||||
return ('400', 'text/plain', "No such repository\n");
|
||||
}
|
||||
|
||||
my $dirlist = __dirlist ($dir);
|
||||
return ('500', 'text/plain', $dirlist->{error}) if (defined $dirlist->{error});
|
||||
my @filelist = @{$dirlist->{dir}};
|
||||
$dirlist = undef;
|
||||
|
||||
# manifest
|
||||
my $buf = '';
|
||||
|
||||
foreach my $filename (@filelist) {
|
||||
if ($filename =~ /\.lst/xmsg) {
|
||||
my $file = __readfile("$dir/$filename");
|
||||
return ('500', 'text/plain', $file->{error}) if (defined $file->{'error'});
|
||||
$buf .= __trim $file->{data};
|
||||
$buf .= "\n\n\n";
|
||||
$file->{data} = ''; $file = undef;
|
||||
}
|
||||
}
|
||||
|
||||
my $bzdata = __bzdata (\$buf);
|
||||
return ('500', 'text/plain', $bzdata->{error}) if (defined $bzdata->{error});
|
||||
|
||||
my $manifest = __writefile ("$dir/MANIFEST.bz2", \$bzdata->{data});
|
||||
return ('500', 'text/plain', $manifest->{error}) if (defined $manifest->{error});
|
||||
|
||||
$bzdata->{data} = ''; $bzdata = undef;
|
||||
|
||||
# checksums
|
||||
$buf = << 'MSG';
|
||||
These are the MD5 message digests for the files in this directory.
|
||||
If you want to test your files, use 'md5sum' and compare the values to
|
||||
the ones listed here.
|
||||
|
||||
To test all these files, use this command:
|
||||
|
||||
tail +13 CHECKSUMS.md5 | md5sum --check | less
|
||||
|
||||
'md5sum' can be found in the GNU coreutils package on ftp.gnu.org in
|
||||
/pub/gnu, or at any GNU mirror site.
|
||||
|
||||
MD5 message digest Filename
|
||||
MSG
|
||||
|
||||
foreach my $filename (@filelist) {
|
||||
next if ($filename =~ /CHECKSUMS\.md5$/xmsg);
|
||||
next if ($filename =~ /CHECKSUMS.md5.gz$/xmsg);
|
||||
|
||||
if ($filename =~ /\.md5/xmsg) {
|
||||
my $file = __readfile("$dir/$filename");
|
||||
return ('500', 'text/plain', $file->{error}) if (defined $file->{'error'});
|
||||
$buf .= $file->{data};
|
||||
$file->{data} = ''; $file = undef;
|
||||
}
|
||||
}
|
||||
|
||||
my $checksum = __writefile ("$dir/CHECKSUMS.md5", \$buf);
|
||||
return ('500', 'text/plain', $checksum->{error}) if (defined $checksum->{error});
|
||||
|
||||
my $gzipchecksum = __gzdata(\$buf);
|
||||
return ('500', 'text/plain', $gzipchecksum->{error}) if (defined $gzipchecksum->{error});
|
||||
$buf = '';
|
||||
|
||||
my $checksumgz = __writefile ("$dir/CHECKSUMS.md5.gz", \$gzipchecksum->{data});
|
||||
return ('500', 'text/plain', $checksumgz->{error}) if (defined $checksumgz->{error});
|
||||
$gzipchecksum->{data} = ''; $gzipchecksum = undef;
|
||||
|
||||
# packages
|
||||
$buf = sprintf "PACKAGES.TXT; %s\n\n\n", __pdate;
|
||||
|
||||
foreach my $filename (@filelist) {
|
||||
if ($filename =~ /\.meta/xmsg) {
|
||||
my $file = __readfile("$dir/$filename");
|
||||
return ('500', 'text/plain', $file->{error}) if (defined $file->{'error'});
|
||||
$buf .= __trim ($file->{data});
|
||||
$buf .= "\n\n";
|
||||
$file->{data} = ''; $file = undef;
|
||||
}
|
||||
}
|
||||
|
||||
my $packages = __writefile ("$dir/PACKAGES.TXT", \$buf);
|
||||
return ('500', 'text/plain', $packages->{error}) if (defined $packages->{error});
|
||||
|
||||
my $gzippackages = __gzdata(\$buf);
|
||||
return ('500', 'text/plain', $gzippackages->{error}) if (defined $gzippackages->{error});
|
||||
$buf = '';
|
||||
|
||||
my $packagesgz = __writefile ("$dir/PACKAGES.TXT.gz", \$gzippackages->{data});
|
||||
return ('500', 'text/plain', $packagesgz->{error}) if (defined $packagesgz->{error});
|
||||
$gzippackages->{data} = ''; $gzippackages = undef;
|
||||
|
||||
# filelist
|
||||
$buf = __pdate;
|
||||
$buf .= "\n\n";
|
||||
$buf .= << 'BUFFER';
|
||||
Here is the file list for this directory,
|
||||
maintained by eleksir <eleksir@gmail.com> .
|
||||
If you are using a mirror site and find missing or extra files
|
||||
in the subdirectories, please have the archive administrator
|
||||
refresh the mirror.
|
||||
|
||||
BUFFER
|
||||
|
||||
# dir listing is not actual, so we need to re-read it
|
||||
$#filelist = -1;
|
||||
$dirlist = __dirlist ($dir);
|
||||
return ('500', 'text/plain', $dirlist->{error}) if (defined $dirlist->{error});
|
||||
@filelist = @{$dirlist->{dir}};
|
||||
$dirlist = undef;
|
||||
|
||||
while (my $file = shift (@filelist)) {
|
||||
my $filename = sprintf ('%s/%s', $dir, $file);
|
||||
my @stat = stat $filename;
|
||||
my @date = localtime ($stat[10]);
|
||||
|
||||
$buf .= sprintf (
|
||||
"-rw-r--r-- %d root root % 8d %04d-%02d-%02d %02d:%02d ./%s\n",
|
||||
$stat[3],
|
||||
$stat[7],
|
||||
$date[5] + 1900,
|
||||
$date[4],
|
||||
$date[3],
|
||||
$date[2],
|
||||
$date[1],
|
||||
$file
|
||||
);
|
||||
}
|
||||
|
||||
$#filelist = -1;
|
||||
my $filelist = __writefile ("$dir/FILELIST.TXT", \$buf);
|
||||
return ('500', 'text/plain', $filelist->{error}) if (defined $filelist->{error});
|
||||
$buf = '';
|
||||
return ('200', 'text/plain', "Done\n");
|
||||
}
|
||||
|
||||
sub __pdate {
|
||||
my @time = gmtime(time);
|
||||
my @DAYOFWEEK = qw(Sun Mon Tue Wed Thu Fri Sat);
|
||||
my @MONTH = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Nov Dec);
|
||||
return strftime "$DAYOFWEEK[$time[6]] $MONTH[$time[4] - 1] %e %T UTC %Y", @time;
|
||||
}
|
||||
|
||||
sub __trim ($) {
|
||||
my $str = shift;
|
||||
|
||||
while (substr ($str, 0, 1) =~ /^\s$/xms) {
|
||||
$str = substr ($str, 1);
|
||||
}
|
||||
|
||||
while (substr ($str, -1, 1) =~ /^\s$/xms) {
|
||||
chop ($str);
|
||||
}
|
||||
|
||||
return $str;
|
||||
}
|
||||
|
||||
sub __readfile ($) {
|
||||
my $file = shift;
|
||||
my $ret;
|
||||
|
||||
open (my $FILEHANDLE, '<', $file) or do {
|
||||
my $msg = "Unable to open file $file: $OS_ERROR";
|
||||
carp "[FATA] $msg";
|
||||
$ret->{error} = $msg;
|
||||
return $ret;
|
||||
};
|
||||
|
||||
binmode $FILEHANDLE;
|
||||
my $buf;
|
||||
my $len = (stat $file)[7];
|
||||
my $readlen = read ($FILEHANDLE, $buf, $len);
|
||||
close $FILEHANDLE; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
|
||||
unless (defined $readlen) {
|
||||
my $msg = "Unable to read $file: $OS_ERROR";
|
||||
carp "[FATA] $msg";
|
||||
$ret->{error} = $msg;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
if ($readlen != $len) {
|
||||
my $msg = "Unable to read $file: amount of read bytes does not match with file size";
|
||||
carp "[FATA] $msg";
|
||||
$ret->{error} = $msg;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
$ret->{data} = $buf;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub __writefile (@) {
|
||||
my $file = shift;
|
||||
my $dataref = shift;
|
||||
my $ret;
|
||||
|
||||
sysopen (my $FILEHANDLE, $file, O_WRONLY|O_TRUNC|O_CREAT) or do {
|
||||
my $msg = "Unable to open file $file: $OS_ERROR";
|
||||
carp "[FATA] $msg";
|
||||
$ret->{error} = $msg;
|
||||
return $ret;
|
||||
};
|
||||
|
||||
binmode $FILEHANDLE;
|
||||
|
||||
use bytes;
|
||||
my $len = length ${$dataref};
|
||||
no bytes;
|
||||
my $writelen = syswrite ($FILEHANDLE, ${$dataref}, $len);
|
||||
close $FILEHANDLE; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
|
||||
unless (defined $writelen) {
|
||||
my $msg = "Unable to write $file: $OS_ERROR";
|
||||
carp "[FATA] $msg";
|
||||
$ret->{error} = $msg;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
if ($writelen != $len) {
|
||||
my $msg = "Unable to write $file: amount of read bytes does not match with file size";
|
||||
carp "[FATA] $msg";
|
||||
$ret->{error} = $msg;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
$ret->{success} = 1;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub __dirlist ($) {
|
||||
my $dir = shift;
|
||||
my $res;
|
||||
my @files;
|
||||
|
||||
opendir (my $dirhandle, $dir) or do {
|
||||
my $msg = "Unable to open $dir: $OS_ERROR";
|
||||
carp "[FATA] $msg";
|
||||
$res->{error} = $msg;
|
||||
return $msg;
|
||||
};
|
||||
|
||||
while (readdir $dirhandle) {
|
||||
next unless (-f "$dir/$_");
|
||||
push @files, $_;
|
||||
}
|
||||
|
||||
closedir $dirhandle;
|
||||
@files = sort @files;
|
||||
$res->{dir} = \@files;
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub __bzdata ($) {
|
||||
my $databufref = shift;
|
||||
my $ret;
|
||||
my $bzdata;
|
||||
my $bz = Compress::Raw::Bzip2->new (1, 9, 0);
|
||||
|
||||
unless (defined $bz) {
|
||||
my $msg = 'Unable to create bz object';
|
||||
carp "[FATA] $msg";
|
||||
$ret->{error} = $msg;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
if ($bz->bzdeflate(${$databufref}, $bzdata) != BZ_RUN_OK) {
|
||||
my $msg = 'Unable to perofrm bzip2 compression';
|
||||
carp "[FATA] $msg";
|
||||
$ret->{error} = $msg;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
if ($bz->bzflush($bzdata) != BZ_RUN_OK) {
|
||||
my $msg = 'Unable to flush bz buffer';
|
||||
carp "[FATA] $msg";
|
||||
$ret->{error} = $msg;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
if ($bz->bzclose($bzdata) != BZ_STREAM_END) {
|
||||
my $msg = 'Unable to flush and close bz buffer';
|
||||
carp "[FATA] $msg";
|
||||
$ret->{error} = $msg;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
$ret->{data} = $bzdata;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub __gzdata ($) {
|
||||
my $databufref = shift;
|
||||
my $ret;
|
||||
my $gzdata;
|
||||
|
||||
my $gz = Compress::Raw::Zlib::Deflate->new (
|
||||
-Level => Z_BEST_COMPRESSION,
|
||||
-CRC32 => 1,
|
||||
-ADLER32=> 1,
|
||||
-WindowBits => WANT_GZIP
|
||||
);
|
||||
|
||||
unless (defined $gz) {
|
||||
my $msg = 'Unable to create gz object';
|
||||
carp "[FATA] $msg";
|
||||
$ret->{error} = $msg;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
if ($gz->deflate(${$databufref}, $gzdata) != Z_OK) {
|
||||
my $msg = 'Unable to deflate';
|
||||
carp "[FATA] $msg";
|
||||
$ret->{error} = $msg;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
if ($gz->flush($gzdata) != Z_OK) {
|
||||
my $msg = 'Unable to flush gz object';
|
||||
carp "[FATA] $msg";
|
||||
$ret->{error} = $msg;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
$ret->{data} = $gzdata;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4 :
|
||||
99
Slackmetarep/Upload.pm
Normal file
99
Slackmetarep/Upload.pm
Normal file
@@ -0,0 +1,99 @@
|
||||
package Slackmetarep::Upload;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use vars qw/$VERSION/;
|
||||
use English qw( -no_match_vars );
|
||||
use Carp;
|
||||
|
||||
use Fcntl;
|
||||
use Slackmetarep::Conf qw(loadConf);
|
||||
|
||||
use Exporter qw(import);
|
||||
our @EXPORT_OK = qw(upload);
|
||||
|
||||
$VERSION = '1.0';
|
||||
|
||||
my $c = loadConf ();
|
||||
|
||||
sub upload {
|
||||
my $input = shift; # file descriptor with data being uploaded
|
||||
my $len = shift; # expected data length (from client)
|
||||
my $name = shift; # upload "dir" and filename
|
||||
my ($status, $content, $msg) = ('400', 'text/plain', "Bad Request?\n");
|
||||
|
||||
return ($status, $content, "No Content-Length supplied.\n") unless (defined $len);
|
||||
return ($status, $content, "No name supplied.\n") unless (defined $name);
|
||||
|
||||
my $d;
|
||||
($d, $name) = split (/\//xms, $name, 2);
|
||||
|
||||
return ($status, $content, "Name does not match pattern.\n") unless ($name =~ /^[[:alnum:]_\-\+\.]+$/xmsg);
|
||||
|
||||
my $match;
|
||||
|
||||
foreach my $uploaddir (keys(%{$c->{upload}->{dir}})) {
|
||||
if ($d eq $uploaddir) {
|
||||
$match = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
return ($status, $content, "Incorrect destination dir.\n") unless $match; # incorrect destination in url
|
||||
|
||||
$name = sprintf('%s/%s', $c->{upload}->{dir}->{$d}, $name);
|
||||
|
||||
if ($len > 0) {
|
||||
if (sysopen (my $FH, $name, O_CREAT|O_TRUNC|O_WRONLY)) {
|
||||
my $buf;
|
||||
my $readlen = 0;
|
||||
my $totalread = 0;
|
||||
my $buflen = 524288; # 512 kbytes, looks sane enough
|
||||
|
||||
if ($len < $buflen) {
|
||||
$buflen = $len;
|
||||
}
|
||||
|
||||
do {
|
||||
$readlen = $input->read($buf, $buflen);
|
||||
|
||||
my $written = syswrite $FH, $buf, $readlen;
|
||||
|
||||
unless (defined($written)) { # out of space?
|
||||
close $FH; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
unlink $name;
|
||||
carp "[FATA] Unable to write to $name: $OS_ERROR";
|
||||
return ('500', $content, "An error has occured during upload: $OS_ERROR\n");
|
||||
}
|
||||
|
||||
if ($readlen != $written) {
|
||||
close $FH; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
unlink $name;
|
||||
carp "[FATA] Must write $readlen bytes, but actualy wrote $written bytes to $name";
|
||||
return ('500', $content, "An error has occured during upload: $OS_ERROR\n");
|
||||
}
|
||||
|
||||
$totalread += $readlen;
|
||||
} while ($readlen == $buflen);
|
||||
|
||||
close $FH; ## no critic (InputOutput::RequireCheckedSyscalls)
|
||||
|
||||
if ($totalread != $len) {
|
||||
($content, $msg) = ($content, "Content-Length does not match amount of recieved bytes.\n");
|
||||
} else {
|
||||
($status, $content, $msg) = ('201', $content, "Uploaded.\n");
|
||||
}
|
||||
} else {
|
||||
carp "[FATA] Unable to open file $name: $OS_ERROR";
|
||||
($status, $content, $msg) = ('500', $content, "Unable to write: $OS_ERROR\n");
|
||||
}
|
||||
} else {
|
||||
$msg = "Incorrect Content-Length\n";
|
||||
}
|
||||
|
||||
return ($status, $content, $msg);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
# vim: set ft=perl noet ai ts=4 sw=4 sts=4 :
|
||||
Reference in New Issue
Block a user