ACU/common/Grading.pm

#! /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;