Add common script for parsing Trace and Grading XML documents
This commit is contained in:
Mercier Pierre-Olivier
parent
dd8947c16c
commit
8640b5c98c
2 changed files with 426 additions and 0 deletions
244
common/Grading.pm
Normal file
244
common/Grading.pm
Normal file
|
|
@ -0,0 +1,244 @@
|
|||
#! /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 => undef,
|
||||
ids => {}
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
$self->_initialize(@_);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _initialize
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
my $dom = XML::LibXML->load_xml(IO => shift);
|
||||
$self->{tree} = $self->parseGrade($dom->documentElement());
|
||||
}
|
||||
|
||||
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("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;
|
||||
|
||||
$self->{ids} = shift;
|
||||
}
|
||||
|
||||
sub compute ($)
|
||||
{
|
||||
my $self = shift;
|
||||
my $sum = 0;
|
||||
|
||||
for my $grade (@{ $self->{tree} }) {
|
||||
my $tmp = $grade->compute($self->{operators}, $self->{ids});
|
||||
$sum += $tmp if $tmp;
|
||||
}
|
||||
|
||||
return $sum;
|
||||
}
|
||||
|
||||
sub generate ($;$)
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
my $output = shift;
|
||||
|
||||
my $xmlout;
|
||||
if (not $output) {
|
||||
$xmlout = *STDOUT;
|
||||
}
|
||||
else {
|
||||
open $xmlout, "<", $output or die $!;
|
||||
}
|
||||
binmode $xmlout;
|
||||
|
||||
my $dom = XML::LibXML::Document->createDocument("1.0", "UTF-8");
|
||||
my $root = $dom->createElement("grade");
|
||||
}
|
||||
|
||||
|
||||
package Grade;
|
||||
|
||||
use v5.10.1;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
use Safe;
|
||||
use List::Util "reduce";
|
||||
|
||||
sub new ($$;$$)
|
||||
{
|
||||
my $class = shift;
|
||||
my $self = {
|
||||
id => shift,
|
||||
operator => shift // "add",
|
||||
factor => shift // 1,
|
||||
tree => []
|
||||
};
|
||||
|
||||
return bless $self;
|
||||
}
|
||||
|
||||
sub append ($@)
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
push @{ $self->{tree} }, @_;
|
||||
}
|
||||
|
||||
sub compute ($$$)
|
||||
{
|
||||
my $self = shift;
|
||||
my $operators = shift;
|
||||
my $ids = shift;
|
||||
my @current = ();
|
||||
|
||||
for my $node (@{ $self->{tree} }) {
|
||||
my $t = $node->compute($operators, $ids);
|
||||
push @current, $t if $t;
|
||||
}
|
||||
|
||||
#TODO: Be more secure!
|
||||
#$cpt = new Safe;
|
||||
#$cpt->permit(qw(require));
|
||||
#$safe->share_from('List::Util', [ 'reduce' ]);
|
||||
|
||||
#${$cpt->varglob("$$pvar[0]")} = "$$pvar[1]";
|
||||
|
||||
my $res = 0;
|
||||
{
|
||||
no warnings "uninitialized";
|
||||
$res = reduce { eval $operators->{ $self->{operator} } } @current if @current > 1;
|
||||
$res = $current[0] if @current == 1;
|
||||
}
|
||||
|
||||
$ids->{ $self->{id} } = $res;
|
||||
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub add
|
||||
{
|
||||
$a + $b;
|
||||
}
|
||||
|
||||
package Point;
|
||||
|
||||
use v5.10.1;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
sub new ($$$$$)
|
||||
{
|
||||
my $class = shift;
|
||||
my $self = {
|
||||
value => $_[0],
|
||||
ref => $_[1],
|
||||
qversion => $_[2],
|
||||
not => $_[3]
|
||||
};
|
||||
|
||||
return bless $self;
|
||||
}
|
||||
|
||||
sub getValue ($$)
|
||||
{
|
||||
my $self = shift;
|
||||
my $ids = shift;
|
||||
|
||||
if (not $self->{value}) {
|
||||
return $ids->{ $self->{ref} } // 0;
|
||||
}
|
||||
else {
|
||||
return $self->{value};
|
||||
}
|
||||
}
|
||||
|
||||
sub compute ($$$)
|
||||
{
|
||||
my $self = shift;
|
||||
my $operators = shift;
|
||||
my $ids = shift;
|
||||
my $ret = undef;
|
||||
|
||||
if ((not $self->{ref}) || $self->{ref} ~~ $ids) {
|
||||
$ret = $self->getValue( $ids );
|
||||
}
|
||||
|
||||
if ($self->{not}) {
|
||||
if ($ret) {
|
||||
$ret = undef;
|
||||
} else {
|
||||
$ret = $self->getValue( $ids );
|
||||
}
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
182
common/Trace.pm
Normal file
182
common/Trace.pm
Normal file
|
|
@ -0,0 +1,182 @@
|
|||
#! /usr/bin/env perl
|
||||
|
||||
package Trace;
|
||||
|
||||
use v5.10.1;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
use utf8;
|
||||
use open qw(:encoding(UTF-8) :std);
|
||||
use XML::LibXML;
|
||||
use XML::SAX::ParserFactory;
|
||||
|
||||
sub new ($$)
|
||||
{
|
||||
my $class = shift;
|
||||
my $self = {};
|
||||
|
||||
bless $self, $class;
|
||||
$self->_initialize(@_);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _initialize ($$)
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
my $sax_handler = TraceHandler->new;
|
||||
my $parser = XML::SAX::ParserFactory->parser( Handler => $sax_handler );
|
||||
|
||||
$parser->parse_file(shift);
|
||||
|
||||
$self->{version} = $sax_handler->getVersion();
|
||||
$self->{type} = $sax_handler->getType();
|
||||
$self->{ids} = $sax_handler->getIds();
|
||||
$self->{infos} = $sax_handler->getInfos();
|
||||
}
|
||||
|
||||
sub getVersion ($)
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{version};
|
||||
}
|
||||
|
||||
sub getType ($)
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{type};
|
||||
}
|
||||
|
||||
sub getInfo ($$)
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{infos}{$_[0]};
|
||||
}
|
||||
|
||||
sub getInfos ($)
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{infos};
|
||||
}
|
||||
|
||||
sub getValue ($$)
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{ids}{$_[0]};
|
||||
}
|
||||
|
||||
sub getIds ($)
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{ids};
|
||||
}
|
||||
|
||||
|
||||
package TraceHandler;
|
||||
|
||||
use constant NO_ID_VALUE => "__#";
|
||||
|
||||
sub new
|
||||
{
|
||||
my $class = shift;
|
||||
my $self = {
|
||||
ids => {},
|
||||
infos => {},
|
||||
inEval => "",
|
||||
inInfo => "",
|
||||
inValue => "",
|
||||
values => ""
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub start_element
|
||||
{
|
||||
my ($self, $element) = @_;
|
||||
|
||||
if ($element->{Name} eq "trace") {
|
||||
$self->{version} = $element->{Attributes}{"{}version"}{Value};
|
||||
$self->{type} = $element->{Attributes}{"{}type"}{Value};
|
||||
}
|
||||
elsif ($element->{Name} eq "info") {
|
||||
$self->{inInfo} = $element->{Attributes}{"{}name"}{Value};
|
||||
$self->{infos}{ $self->{inInfo} } = 0;
|
||||
$self->{values} = "";
|
||||
}
|
||||
elsif ($element->{Name} eq "eval") {
|
||||
my $tmp = $element->{Attributes}{"{}id"}{Value};
|
||||
if ($tmp) {
|
||||
$self->{inEval} = $tmp;
|
||||
$self->{ids}{ $self->{inEval} } = 0;
|
||||
}
|
||||
}
|
||||
elsif ($element->{Name} eq "value") {
|
||||
if ($element->{Attributes}{"{}id"}{Value}) {
|
||||
$self->{inValue} = $element->{Attributes}{"{}id"}{Value};
|
||||
} else {
|
||||
$self->{inValue} = NO_ID_VALUE;
|
||||
}
|
||||
|
||||
$self->{values} = "";
|
||||
}
|
||||
}
|
||||
|
||||
sub characters
|
||||
{
|
||||
my ($self, $characters) = @_;
|
||||
|
||||
if ($self->{inValue} || $self->{inInfo}) {
|
||||
$self->{values} .= $characters->{Data};
|
||||
}
|
||||
}
|
||||
|
||||
sub end_element
|
||||
{
|
||||
my ($self, $element) = @_;
|
||||
|
||||
if ($element->{Name} eq "value") {
|
||||
if ($self->{values} =~ /(-?[0-9]+(.[0-9]+)?)/) {
|
||||
$self->{ids}{ $self->{inEval} } += $1;
|
||||
if ($self->{inValue} ne NO_ID_VALUE) {
|
||||
$self->{ids}{ $self->{inValue} } = $1;
|
||||
}
|
||||
}
|
||||
$self->{inValue} = "";
|
||||
}
|
||||
elsif ($element->{Name} eq "info") {
|
||||
if ($self->{values} =~ /([^\s].*[^\s]|[^\s])/) {
|
||||
$self->{infos}{ $self->{inInfo} } = $1;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub getVersion ($)
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{version};
|
||||
}
|
||||
|
||||
sub getInfos ($)
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{infos};
|
||||
}
|
||||
|
||||
sub getType ($)
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{type};
|
||||
}
|
||||
|
||||
sub getIds ($)
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{ids};
|
||||
}
|
||||
|
||||
1;
|
||||
Reference in a new issue