169 lines
4 KiB
Perl
169 lines
4 KiB
Perl
#! /usr/bin/env perl
|
|
|
|
use v5.10.1;
|
|
use strict;
|
|
use warnings;
|
|
use Carp;
|
|
use Pod::Usage;
|
|
use File::Copy;
|
|
use File::Path qw(remove_tree);
|
|
use File::Temp qw/tempfile tempdir/;
|
|
|
|
use ACU::Log;
|
|
use ACU::Process;
|
|
|
|
my %actions = (
|
|
"tar" => \&receive_tar,
|
|
"git" => \&receive_git,
|
|
|
|
"tests" => \&create_testsuite,
|
|
"moulette" => \&moulette,
|
|
);
|
|
|
|
sub prepare_dir
|
|
{
|
|
my $year = shift;
|
|
my $project_id = shift;
|
|
my $rendu = shift;
|
|
|
|
# TODO: replace ~calvair by the destination directory
|
|
my $dir = "~calvair/$year-$project_id-$rendu/";
|
|
|
|
if (! -d $dir) {
|
|
mkpath($destdir) or croak "An error occurs while creating directory: $!";
|
|
}
|
|
|
|
return $dir;
|
|
}
|
|
|
|
sub receive_tar
|
|
{
|
|
my $args = shift;
|
|
my $project_id = $args->{param}{id};
|
|
my $year = $args->{param}{year};
|
|
my $rendu = $args->{param}{rendu};
|
|
my $file = $args->{param}{file};
|
|
my $login = $args->{param}{login} // "ref";
|
|
|
|
croak "No file named '$file' given" if (!exists $args->{files}{$file});
|
|
|
|
my ($fh, $filename) = tempfile(SUFFIX => $file);
|
|
binmode($fh);
|
|
print $fh $args->{files}{$file};
|
|
close $fh;
|
|
|
|
my $destdir = prepare_dir($year, $project_id, $file);
|
|
# TODO: Call Fact for create .ff
|
|
# qx(Fact package create $filename $destdir/$login.ff)
|
|
croak "Cannot create $login.ff" if ($?);
|
|
|
|
# Clean
|
|
unlink $filename;
|
|
}
|
|
|
|
sub receive_git
|
|
{
|
|
my $args = shift;
|
|
my $project_id = $args->{param}{id};
|
|
my $year = $args->{param}{year};
|
|
my $rendu = $args->{param}{rendu};
|
|
my $file = $args->{param}{file};
|
|
my $login = $args->{param}{login} // "ref";
|
|
|
|
croak "No file named '$file' given" if (!exists $args->{files}{$file});
|
|
|
|
my $tempdir = tempdir();
|
|
open my $fh, "|tar -xz -C '$tempdir'";
|
|
print $fh $args->{files}{$file};
|
|
close $fh;
|
|
|
|
croak "An error occurs while extracting the tarball" if ($?);
|
|
|
|
my $destdir = prepare_dir($year, $project_id, $file);
|
|
# TODO: Call Fact for create .ff
|
|
# qx(Fact package create $tempdir $destdir/$login.ff)
|
|
croak "Cannot create $login.ff" if ($?);
|
|
|
|
# Clean
|
|
remove_tree($tempdir);
|
|
}
|
|
|
|
sub create_testsuite
|
|
{
|
|
my $args = shift;
|
|
my $project_id = $args->{param}{id};
|
|
my $year = $args->{param}{year};
|
|
my $rendu = $args->{param}{rendu};
|
|
my $file = $args->{param}{file};
|
|
|
|
croak "No file named '$file' given" if (!exists $args->{files}{$file});
|
|
|
|
my $tempdir = tempdir();
|
|
open my $fh, "|tar -xz -C '$tempdir'";
|
|
print $fh $args->{files}{$file};
|
|
close $fh;
|
|
|
|
croak "An error occurs while extracting the tarball" if ($?);
|
|
|
|
qx(make -C $tempdir/tests/);
|
|
croak "An error occurs while making the testsuite" if ($?);
|
|
|
|
my $destdir = prepare_dir($year, $project_id, $rendu);
|
|
copy("$tempdir/tests/tests.ff", "$destdir/tests.ff") or croak "An error occurs while coping the testsuite: $!";
|
|
copy("$tempdir/tests/test.ft", "$destdir/test.ft") or croak "An error occurs while coping test.ft: $!";
|
|
|
|
# Clean
|
|
remove_tree($tempdir);
|
|
}
|
|
|
|
sub moulette
|
|
{
|
|
my $args = shift;
|
|
my $project_id = $args->{param}{id};
|
|
my $year = $args->{param}{year};
|
|
my $rendu = $args->{param}{rendu};
|
|
|
|
my $testdir = prepare_dir($year, $project_id, $rendu);
|
|
|
|
chdir($testdir);
|
|
for (my $i = $args->{unamed}; $i > 0; $i--)
|
|
{
|
|
my $login = $args->{param}{$i}
|
|
|
|
open my $fhin, "<", "$testdir/test.ft";
|
|
open my $fhout, ">", "$testdir/$login.ft";
|
|
print $fhout s/#LOGIN_X/$login/g while (<$fhin>);
|
|
close $fhin;
|
|
close $fhout;
|
|
|
|
# TODO: Call Fact to launch student tarball
|
|
# qx(Fact system manager $login.ft)
|
|
|
|
log WARN, "An error occurs while starting tests for $login on $year-$project_id-$rendu" if ($?);
|
|
}
|
|
}
|
|
|
|
|
|
sub process_get
|
|
{
|
|
my ($given_args, $args) = @_;
|
|
|
|
my $type = $args->{param}{type} // "";
|
|
|
|
if (! exists $actions{$type}) {
|
|
log WARN, "Unknown type '$type'";
|
|
return "Unknown type '$type'.";
|
|
}
|
|
|
|
eval {
|
|
$actions{$type}($args);
|
|
}
|
|
if ($@) {
|
|
my $err = $@;
|
|
log ERROR, $err;
|
|
return $err;
|
|
}
|
|
return "Ok";
|
|
}
|
|
|
|
Process::register("moulette_get", \&process_get);
|