396 lines
7.6 KiB
Perl
396 lines
7.6 KiB
Perl
#! /usr/bin/env perl
|
|
|
|
package Grading;
|
|
|
|
use v5.10.1;
|
|
use strict;
|
|
use warnings;
|
|
use XML::LibXML;
|
|
|
|
sub new
|
|
{
|
|
my $class = shift;
|
|
my $self = {
|
|
operators => {
|
|
'add' => '$a+$b'
|
|
},
|
|
tree => [],
|
|
ids => {}
|
|
};
|
|
|
|
bless $self, $class;
|
|
if ($#_ >= 0) {
|
|
$self->_initialize(@_);
|
|
}
|
|
|
|
return $self;
|
|
}
|
|
|
|
sub _initialize
|
|
{
|
|
my $self = shift;
|
|
|
|
my $dom = XML::LibXML->load_xml(string => shift);
|
|
$self->{tree} = $self->parseGrade($dom->documentElement());
|
|
$self->{max} = $dom->documentElement()->getAttribute("max") // "20";
|
|
}
|
|
|
|
sub create_from_ids
|
|
{
|
|
my $self = shift;
|
|
my $trace_name = shift;
|
|
my $ids = shift;
|
|
|
|
my $trace_id = $trace_name;
|
|
$trace_id =~ s/[^a-zA-Z0-9_]/_/g;
|
|
|
|
my $g = Grade->new($trace_id, $trace_name);
|
|
|
|
for my $id (sort( keys %{ $ids } ))
|
|
{
|
|
my $p = Point->new($ids->{$id}, $id, 0, 0);
|
|
push @{ $g->{tree} }, $p;
|
|
}
|
|
|
|
push @{ $self->{tree} }, $g;
|
|
}
|
|
|
|
sub parseGrade ($$)
|
|
{
|
|
my $self = shift;
|
|
my $ret = [];
|
|
my $node = shift;
|
|
|
|
foreach my $grade ($node->childNodes())
|
|
{
|
|
if ($grade->nodeName eq "operator")
|
|
{
|
|
my $tmp = $grade->textContent;
|
|
chomp($tmp);
|
|
$self->{operators}{ $grade->getAttribute("name") } = $tmp;
|
|
}
|
|
elsif ($grade->nodeName eq "grade")
|
|
{
|
|
my $g = Grade->new(
|
|
$grade->getAttribute("id"),
|
|
$grade->getAttribute("title"),
|
|
$grade->getAttribute("operator"),
|
|
$grade->getAttribute("factor")
|
|
);
|
|
$g->append(@{ $self->parseGrade($grade) });
|
|
push @$ret, $g;
|
|
}
|
|
elsif ($grade->nodeName eq "point")
|
|
{
|
|
my $n = Point->new(
|
|
$grade->textContent,
|
|
$grade->getAttribute("ref"),
|
|
$grade->getAttribute("qversion"),
|
|
$grade->getAttribute("not")
|
|
);
|
|
push @$ret, $n;
|
|
}
|
|
}
|
|
|
|
return $ret;
|
|
}
|
|
|
|
sub reset ($)
|
|
{
|
|
my $self = shift;
|
|
|
|
$self->{ids} = {};
|
|
}
|
|
|
|
sub insert ($$$)
|
|
{
|
|
my $self = shift;
|
|
|
|
$self->{ids}{$_[0]} = $_[1];
|
|
}
|
|
|
|
sub fill
|
|
{
|
|
my $self = shift;
|
|
my $ids = shift;
|
|
|
|
for my $k (keys %{ $ids }) {
|
|
$self->{ids}{$k} = $ids->{$k};
|
|
}
|
|
}
|
|
|
|
sub toString ($)
|
|
{
|
|
my $self = shift;
|
|
|
|
my $doc = XML::LibXML::Document->new('1.0');
|
|
|
|
my $root = $doc->createElement("grading");
|
|
|
|
for my $op (keys %{ $self->{operators} }) {
|
|
my $ope = $doc->createElement("operator");
|
|
$ope->addChild( $doc->createAttribute("name", $op) );
|
|
$ope->appendText($self->{operators}{$op});
|
|
$root->appendChild($ope);
|
|
}
|
|
|
|
for my $grade (@{ $self->{tree} }) {
|
|
$grade->toString($doc, $root, $root);
|
|
}
|
|
|
|
$doc->setDocumentElement( $root );
|
|
|
|
return $doc->toString();
|
|
}
|
|
|
|
sub compute ($;$)
|
|
{
|
|
my $self = shift;
|
|
my $login = shift;
|
|
my $sum = 0;
|
|
|
|
for my $grade (@{ $self->{tree} }) {
|
|
my $tmp = $grade->compute($self->{operators}, $self->{ids}, $login);
|
|
$sum += $tmp if $tmp;
|
|
}
|
|
|
|
return $sum;
|
|
}
|
|
|
|
sub computeXML ($;$)
|
|
{
|
|
my $self = shift;
|
|
my $login = shift;
|
|
|
|
my $doc = XML::LibXML::Document->new('1.0');
|
|
my $root = $doc->createElement("grading");
|
|
|
|
for my $grade (@{ $self->{tree} }) {
|
|
$grade->compute($self->{operators}, $self->{ids}, $login, $doc, $root);
|
|
}
|
|
|
|
$root->addChild( $doc->createAttribute("max", $self->{max}) );
|
|
|
|
$doc->setDocumentElement( $root );
|
|
return $doc->toString();
|
|
}
|
|
|
|
package Grade;
|
|
|
|
use v5.10.1;
|
|
use strict;
|
|
use warnings;
|
|
use Carp;
|
|
use Safe;
|
|
use List::Util "reduce";
|
|
use XML::LibXML;
|
|
|
|
sub new ($$$;$$)
|
|
{
|
|
my $class = shift;
|
|
my $self = {
|
|
id => shift,
|
|
title => shift,
|
|
operator => shift // "add",
|
|
factor => shift // 1,
|
|
tree => []
|
|
};
|
|
|
|
return bless $self;
|
|
}
|
|
|
|
sub toString ($$$)
|
|
{
|
|
my $self = shift;
|
|
my $doc = shift;
|
|
my $parent = shift;
|
|
|
|
my $grade = $doc->createElement("grade");
|
|
$grade->addChild( $doc->createAttribute("id", $self->{id}) );
|
|
$grade->addChild( $doc->createAttribute("title", $self->{title}) );
|
|
$grade->addChild( $doc->createAttribute("operator", $self->{operator}) ) if ($self->{operator} ne "add");
|
|
$grade->addChild( $doc->createAttribute("factor", $self->{factor}) ) if ($self->{factor} != 1);
|
|
$parent->appendChild($grade);
|
|
|
|
for my $item (@{ $self->{tree} }) {
|
|
$item->toString($doc, $grade);
|
|
}
|
|
}
|
|
|
|
sub append ($@)
|
|
{
|
|
my $self = shift;
|
|
|
|
push @{ $self->{tree} }, @_;
|
|
}
|
|
|
|
sub compute ($$$;$$$)
|
|
{
|
|
my $self = shift;
|
|
my $operators = shift;
|
|
my $ids = shift;
|
|
my $login = shift;
|
|
my $doc = shift;
|
|
my $parent = shift;
|
|
my @current = ();
|
|
|
|
my $grade;
|
|
if ($doc && $parent)
|
|
{
|
|
$grade = $doc->createElement("grade");
|
|
$grade->addChild( $doc->createAttribute("factor", $self->{factor}) );
|
|
$grade->addChild( $doc->createAttribute("name", $self->{title}) ) if ($self->{title});
|
|
$parent->appendChild( $grade );
|
|
}
|
|
|
|
for my $node (@{ $self->{tree} })
|
|
{
|
|
my $t = $node->compute($operators, $ids, $login, $doc, $grade);
|
|
push @current, $t if (defined $t);
|
|
}
|
|
|
|
my $res;
|
|
if (@current > 1)
|
|
{
|
|
my $operator = $self->{operator};
|
|
|
|
my $cpt = new Safe;
|
|
$cpt->permit_only(qw(:base_core :base_mem :base_loop padany rv2gv));
|
|
$res = reduce {
|
|
$cpt->share('$a');
|
|
$cpt->share('$b');
|
|
$cpt->reval($operators->{ $operator }) // die "Safe alert: $@";
|
|
}
|
|
@current;
|
|
}
|
|
else {
|
|
$res = $current[0] // 0;
|
|
}
|
|
|
|
$res = $res * $self->{factor};
|
|
|
|
$ids->{ $self->{id} } = $res;
|
|
|
|
$grade->addChild( $doc->createAttribute("value", $res) ) if ($grade);
|
|
|
|
return $res;
|
|
}
|
|
|
|
sub add
|
|
{
|
|
$a + $b;
|
|
}
|
|
|
|
package Point;
|
|
|
|
use v5.10.1;
|
|
use strict;
|
|
use warnings;
|
|
use Text::Glob qw( glob_to_regex match_glob );
|
|
use Term::ANSIColor qw(:constants);
|
|
|
|
use ACU::Log;
|
|
|
|
sub new ($$$$$)
|
|
{
|
|
my $class = shift;
|
|
my $self = {
|
|
value => $_[0],
|
|
ref => $_[1],
|
|
qversion => $_[2],
|
|
not => $_[3]
|
|
};
|
|
|
|
return bless $self;
|
|
}
|
|
|
|
sub toString ($$$)
|
|
{
|
|
my $self = shift;
|
|
my $doc = shift;
|
|
my $parent = shift;
|
|
|
|
my $point = $doc->createElement("point");
|
|
$point->addChild( $doc->createAttribute("ref", $self->{ref}) ) if ($self->{ref} ne "");
|
|
$point->addChild( $doc->createAttribute("qversion", $self->{qversion}) ) if ($self->{qversion} != 0);
|
|
$point->addChild( $doc->createAttribute("not", $self->{not}) ) if ($self->{not} != 0);
|
|
$point->appendText($self->{value});
|
|
$parent->appendChild($point);
|
|
}
|
|
|
|
sub getValue ($$$)
|
|
{
|
|
my $self = shift;
|
|
my $ids = shift;
|
|
my $ref = shift;
|
|
|
|
# Return the point node value if exists
|
|
return $self->{value} if ($self->{value} ne "");
|
|
|
|
# Else return pointed ref value
|
|
return $ids->{ $ref };
|
|
}
|
|
|
|
sub compute ($$$;$$$)
|
|
{
|
|
my $self = shift;
|
|
my $operators = shift;
|
|
my $ids = shift;
|
|
my $login = shift;
|
|
|
|
my $ref = $self->{ref};
|
|
|
|
# Handle $LOGIN in ref
|
|
$ref =~ s/\$LOGIN/$login/ if ($login && $ref);
|
|
|
|
# Handle globbing in ref
|
|
if (defined $ref)
|
|
{
|
|
eval
|
|
{
|
|
if ($ref =~ /\?|\*/)
|
|
{
|
|
my $value = 0;
|
|
for my $r (grep { match_glob($ref, $_); } keys %$ids) {
|
|
$value += $ids->{ $r } if ($ref != $r);
|
|
}
|
|
$ids->{ $ref } = $value if ($value);
|
|
log DEBUG, "New globbing identifier caculated $ref: $value";
|
|
}
|
|
};
|
|
if ($@) {
|
|
my $err = $@;
|
|
log ERROR, $@;
|
|
}
|
|
}
|
|
|
|
my $ret = undef;
|
|
|
|
my $result = (
|
|
# No condition on refs nor qversion?
|
|
! defined $ref
|
|
# Condition on refs
|
|
|| grep { $ref eq $_ } keys %$ids
|
|
);
|
|
|
|
# Handel not
|
|
$result = !$result if ($self->{not});
|
|
|
|
# ret is valued only if all conditions passed
|
|
$ret = $self->getValue( $ids, $ref ) if ($result);
|
|
|
|
if ($main::debug)
|
|
{
|
|
my $str = "not=".($self->{not}//0).", qversion".($self->{qversion}//"*").", ref=".($ref//"").",\tvalue=".($ids->{ $ref//"" } // "undef");
|
|
if ($result) {
|
|
say GREEN, ">>>", RESET, " Matching point: ", $str, ", ", BOLD, "got=".($ret // 0), RESET;
|
|
} else {
|
|
say RED, " * ", RESET, " Skipped point: ", $str;
|
|
}
|
|
}
|
|
|
|
return $ret;
|
|
}
|
|
|
|
1;
|