Add common script for parsing Trace and Grading XML documents

common/Grading.pm

@@ -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;

common/Trace.pm

@@ -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;