New parser for traces
This commit is contained in:
Mercier Pierre-Olivier
parent
1de1b9a221
commit
15f89a5e39
3 changed files with 251 additions and 146 deletions
|
|
@ -111,7 +111,7 @@ sub insert ($$$)
|
|||
$self->{ids}{$_[0]} = $_[1];
|
||||
}
|
||||
|
||||
sub fill ($$)
|
||||
sub fill
|
||||
{
|
||||
my $self = shift;
|
||||
my $ids = shift;
|
||||
|
|
|
|||
393
ACU/Trace.pm
393
ACU/Trace.pm
|
|
@ -9,16 +9,13 @@ 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 = {
|
||||
ids => {},
|
||||
infos => {},
|
||||
comments => {},
|
||||
who => {},
|
||||
groups => [],
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
|
|
@ -33,10 +30,47 @@ sub _initialize ($$)
|
|||
{
|
||||
my $self = shift;
|
||||
|
||||
my $sax_handler = TraceHandler->new($self);
|
||||
my $parser = XML::SAX::ParserFactory->parser( Handler => $sax_handler );
|
||||
my $dom = XML::LibXML->load_xml(string => shift);
|
||||
$self->{groups} = $self->parseTrace($dom->documentElement());
|
||||
$self->{type} = $dom->documentElement()->getAttribute("type") // "mill";
|
||||
$self->{version} = $dom->documentElement()->getAttribute("version") // 1;
|
||||
}
|
||||
|
||||
$parser->parse_file(shift);
|
||||
sub parseTrace($$)
|
||||
{
|
||||
my $self = shift;
|
||||
my $tree = shift;
|
||||
my $ret = [];
|
||||
|
||||
foreach my $node ($tree->childNodes())
|
||||
{
|
||||
if ($node->nodeName eq "info")
|
||||
{
|
||||
my $tmp = $node->textContent;
|
||||
chomp($tmp);
|
||||
$self->{infos}{ $node->getAttribute("name") } = $tmp;
|
||||
}
|
||||
elsif ($node->nodeName eq "group")
|
||||
{
|
||||
my $g = Trace::Group->new(
|
||||
$node->getAttribute("id"),
|
||||
$node->getAttribute("name")
|
||||
);
|
||||
$g->append(@{ $self->parseTrace($node) });
|
||||
push @$ret, $g;
|
||||
}
|
||||
elsif ($node->nodeName eq "eval")
|
||||
{
|
||||
my $e = Trace::Eval->new(
|
||||
$node->getAttribute("id"),
|
||||
$node->getAttribute("type"),
|
||||
$node
|
||||
);
|
||||
push @$ret, $e;
|
||||
}
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub getVersion ($)
|
||||
|
|
@ -63,64 +97,63 @@ sub getInfos ($)
|
|||
return $self->{infos};
|
||||
}
|
||||
|
||||
sub getComment ($$)
|
||||
sub getIds
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{comments}{$_[0]};
|
||||
my $login = shift;
|
||||
|
||||
my %ids;
|
||||
foreach my $group (@{ $self->{groups} })
|
||||
{
|
||||
my %tmp = $group->getIds($login);
|
||||
while (my ($key, $value) = each %tmp)
|
||||
{
|
||||
%ids{$key} = $value;
|
||||
}
|
||||
}
|
||||
return %ids;
|
||||
}
|
||||
|
||||
sub getComments ($)
|
||||
sub getValue
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{comments};
|
||||
my $id = shift;
|
||||
my $login = shift;
|
||||
|
||||
my $value = 0;
|
||||
foreach my $group (@{ $self->{groups} })
|
||||
{
|
||||
$value += $group->getValue($id, $login);
|
||||
}
|
||||
return $value;
|
||||
}
|
||||
|
||||
sub getWho ($$)
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{who}{$_[0]};
|
||||
return $self->getWhos()->{$_[0]};
|
||||
}
|
||||
|
||||
sub getFirstWho ($)
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return $self->{who}{def1_end_group};
|
||||
return $self->getWhos()->{def1_end_group};
|
||||
}
|
||||
|
||||
sub getWhos ($)
|
||||
sub getWhos
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{who};
|
||||
}
|
||||
my $ret = {};
|
||||
|
||||
sub getValue ($$)
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{ids}{$_[0]};
|
||||
}
|
||||
foreach my $group (@{ $self->{groups} })
|
||||
{
|
||||
my $whos = $group->getWhos();
|
||||
foreach my $who (keys %{ $whos }) {
|
||||
$ret->{ $who } = $whos->{$who};
|
||||
}
|
||||
}
|
||||
|
||||
sub getIds ($)
|
||||
{
|
||||
my $self = shift;
|
||||
return $self->{ids};
|
||||
}
|
||||
|
||||
sub addId($$;$)
|
||||
{
|
||||
my $self = shift;
|
||||
my $key = shift;
|
||||
my $value = shift // 1;
|
||||
|
||||
$self->{ids}{$key} = $value;
|
||||
}
|
||||
|
||||
sub delId($$)
|
||||
{
|
||||
my $self = shift;
|
||||
my $key = shift;
|
||||
|
||||
delete $self->{ids}{$key};
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub toString ($;$)
|
||||
|
|
@ -153,23 +186,20 @@ sub toString ($;$)
|
|||
}
|
||||
|
||||
|
||||
package TraceHandler;
|
||||
package Trace::Group;
|
||||
|
||||
use v5.10.1;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
use constant NO_ID_VALUE => "__#";
|
||||
|
||||
sub new ($$)
|
||||
{
|
||||
my $class = shift;
|
||||
my $self = {
|
||||
groups => [],
|
||||
parsed => shift,
|
||||
inComment => "",
|
||||
inEval => "",
|
||||
inInfo => "",
|
||||
inValue => "",
|
||||
inWho => "",
|
||||
values => ""
|
||||
id => shift,
|
||||
name => shift,
|
||||
groups => []
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
|
|
@ -177,113 +207,188 @@ sub new ($$)
|
|||
return $self;
|
||||
}
|
||||
|
||||
sub start_element
|
||||
sub append ($@)
|
||||
{
|
||||
my ($self, $element) = @_;
|
||||
my $self = shift;
|
||||
|
||||
if ($element->{Name} eq "trace") {
|
||||
$self->{parsed}{version} = $element->{Attributes}{"{}version"}{Value};
|
||||
$self->{parsed}{type} = $element->{Attributes}{"{}type"}{Value};
|
||||
}
|
||||
elsif ($element->{Name} eq "info") {
|
||||
$self->{inInfo} = $element->{Attributes}{"{}name"}{Value};
|
||||
$self->{parsed}{infos}{ $self->{inInfo} } = 0;
|
||||
$self->{values} = "";
|
||||
}
|
||||
elsif ($element->{Name} eq "eval") {
|
||||
my $tmp = $element->{Attributes}{"{}id"}{Value};
|
||||
if ($tmp) {
|
||||
$self->{inEval} = $tmp;
|
||||
$self->{parsed}{ids}{ $self->{inEval} } = 0;
|
||||
}
|
||||
}
|
||||
elsif ($element->{Name} eq "comment" && $self->{inEval}) {
|
||||
$self->{inComment} = $self->{inEval};
|
||||
$self->{values} = "";
|
||||
}
|
||||
elsif ($element->{Name} eq "who" && $self->{inEval}) {
|
||||
$self->{inWho} = $self->{inEval};
|
||||
$self->{values} = "";
|
||||
}
|
||||
elsif ($element->{Name} eq "value") {
|
||||
if ($element->{Attributes}{"{}id"}{Value}) {
|
||||
$self->{inValue} = $element->{Attributes}{"{}id"}{Value};
|
||||
} else {
|
||||
$self->{inValue} = NO_ID_VALUE;
|
||||
}
|
||||
|
||||
$self->{values} = "";
|
||||
}
|
||||
elsif ($element->{Name} eq "group")
|
||||
{
|
||||
push @{ $self->{groups} }, ($element->{Attributes}{"{}id"}{Value} // "");
|
||||
}
|
||||
elsif ($element->{Name} ne "name" && $element->{Name} ne "statut" && $element->{Name} ne "status" && $element->{Name} ne "log") {
|
||||
croak "Not a valid trace XML: unknown tag ".$element->{Name};
|
||||
}
|
||||
push @{ $self->{groups} }, @_;
|
||||
}
|
||||
|
||||
sub characters
|
||||
sub getIds
|
||||
{
|
||||
my ($self, $characters) = @_;
|
||||
my $self = shift;
|
||||
my $login = shift;
|
||||
|
||||
if ($self->{inValue} || $self->{inInfo} || $self->{inComment} || $self->{inWho}) {
|
||||
$self->{values} .= $characters->{Data};
|
||||
}
|
||||
}
|
||||
|
||||
sub end_element
|
||||
{
|
||||
my ($self, $element) = @_;
|
||||
|
||||
if ($element->{Name} eq "value")
|
||||
my %ids;
|
||||
foreach my $group (@{ $self->{groups} })
|
||||
{
|
||||
if ($self->{values} =~ /([-+]?[0-9]+(.[0-9]+)?)/)
|
||||
my %tmp = $group->getIds($login);
|
||||
while (($key, $value) = each %tmp)
|
||||
{
|
||||
$self->{parsed}{ids}{ $self->{inEval} } += $1;
|
||||
if ($self->{inValue} ne NO_ID_VALUE and $1) {
|
||||
$self->{parsed}{ids}{ $self->{inValue} } = $1;
|
||||
}
|
||||
if ($self->{groups}) {
|
||||
my $key = @{ $self->{groups} }[$#{ $self->{groups} }];
|
||||
$self->{parsed}{ids}{ $key } += $1;
|
||||
%ids{$key} = $value;
|
||||
}
|
||||
}
|
||||
|
||||
%ids{ $self->{id} } = $self->getValue($self->{id}, $login);
|
||||
|
||||
return %ids;
|
||||
}
|
||||
|
||||
sub getValue
|
||||
{
|
||||
my $self = shift;
|
||||
my $id = shift // $self->{id};
|
||||
my $login = shift
|
||||
|
||||
if ($id eq $self->{id})
|
||||
{
|
||||
my $value = 0;
|
||||
foreach my $group (@{ $self->{groups} })
|
||||
{
|
||||
$value += $group->getValue(undef, $login);
|
||||
}
|
||||
return $value;
|
||||
}
|
||||
else
|
||||
{
|
||||
my $value = 0;
|
||||
foreach my $group (@{ $self->{groups} })
|
||||
{
|
||||
$value += $group->getValue($id, $login);
|
||||
}
|
||||
return $value;
|
||||
}
|
||||
}
|
||||
|
||||
sub getWhos
|
||||
{
|
||||
my $self = shift;
|
||||
my $ret = {};
|
||||
|
||||
foreach my $group (@{ $self->{groups} })
|
||||
{
|
||||
my $whos = $group->getWhos();
|
||||
foreach my $who (keys %{ $whos }) {
|
||||
$ret->{ $who } = $whos->{$who};
|
||||
}
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
|
||||
package Trace::Eval;
|
||||
|
||||
use v5.10.1;
|
||||
use strict;
|
||||
use warnings;
|
||||
use Carp;
|
||||
|
||||
sub new ($$;$)
|
||||
{
|
||||
my $class = shift;
|
||||
my $self = {
|
||||
id => shift,
|
||||
type => shift // "test",
|
||||
values => {},
|
||||
logs => {},
|
||||
};
|
||||
|
||||
bless $self, $class;
|
||||
if ($#_ >= 0) {
|
||||
$self->parseEval(@_);
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub parseEval
|
||||
{
|
||||
my $self = shift;
|
||||
my $tree = shift;
|
||||
|
||||
foreach my $node ($tree->childNodes())
|
||||
{
|
||||
my $val = $node->textContent;
|
||||
chomp($val);
|
||||
|
||||
if ($node->nodeName eq "value")
|
||||
{
|
||||
my $key;
|
||||
if ($node->hasAttribute("id")) {
|
||||
$key = $node->getAttribute("id");
|
||||
} else {
|
||||
$key = "";
|
||||
}
|
||||
|
||||
$self->{values}{ $key } = 0 if (!exists $self->{values}{ $key });
|
||||
$self->{values}{ $key } += $val;
|
||||
}
|
||||
$self->{inValue} = "";
|
||||
}
|
||||
elsif ($element->{Name} eq "eval")
|
||||
{
|
||||
# Remove empty identifier
|
||||
delete $self->{parsed}{ids}{ $self->{inEval} } if (!$self->{parsed}{ids}{ $self->{inEval} });
|
||||
$self->{inEval} = "";
|
||||
}
|
||||
elsif ($element->{Name} eq "comment")
|
||||
{
|
||||
if ($self->{values} =~ /([^\s].*[^\s]|[^\s])/) {
|
||||
$self->{parsed}{comments}{ $self->{inComment} } = $1;
|
||||
elsif ($node->nodeName eq "name")
|
||||
{
|
||||
$self->{name} = $val;
|
||||
}
|
||||
$self->{inComment} = "";
|
||||
}
|
||||
elsif ($element->{Name} eq "who")
|
||||
{
|
||||
if ($self->{values} =~ /([^\s].*[^\s]|[^\s])/) {
|
||||
$self->{parsed}{who}{ $self->{inWho} } = $1;
|
||||
elsif ($node->nodeName eq "status")
|
||||
{
|
||||
$self->{status} = $val;
|
||||
}
|
||||
$self->{inComment} = "";
|
||||
}
|
||||
elsif ($element->{Name} eq "info")
|
||||
{
|
||||
if ($self->{values} =~ /([^\s].*[^\s]|[^\s])/) {
|
||||
$self->{parsed}{infos}{ $self->{inInfo} } = $1;
|
||||
elsif ($node->nodeName eq "log")
|
||||
{
|
||||
my $key = $node->getAttribute("type") // "stdout";
|
||||
|
||||
$self->{logs}{ $key } = $val;
|
||||
}
|
||||
elsif ($node->nodeName eq "who")
|
||||
{
|
||||
$self->{who} = {
|
||||
login => $val,
|
||||
type => $node->getAttribute("type") // "login"
|
||||
};
|
||||
}
|
||||
$self->{inInfo} = "";
|
||||
}
|
||||
elsif ($element->{Name} eq "group")
|
||||
}
|
||||
|
||||
sub getIds
|
||||
{
|
||||
my $self = shift;
|
||||
my $login = shift;
|
||||
|
||||
my %ids;
|
||||
if (!$login || $self->{who}{type} eq "group" || $self->{who}{login} eq $login)
|
||||
{
|
||||
my $key = pop @{ $self->{groups} };
|
||||
# Remove empty identifier
|
||||
delete $self->{parsed}{ids}{ $key } if ($key && !$self->{parsed}{ids}{ $key });
|
||||
while (my ($key, $value) = each %{ $self->{who}{values} })
|
||||
{
|
||||
%ids{$key} = $value if ($key);
|
||||
}
|
||||
}
|
||||
|
||||
%ids{ $self->{id} } = $self->getValue($self->{id}, $login);
|
||||
|
||||
return %ids;
|
||||
}
|
||||
|
||||
sub getValue
|
||||
{
|
||||
my $self = shift;
|
||||
my $id = shift // $self->{id};
|
||||
my $login = shift;
|
||||
|
||||
my $value = 0;
|
||||
if (!$login || $self->{who}{type} eq "group" || $self->{who}{login} eq $login)
|
||||
{
|
||||
foreach my $key (%{ $self->{values} })
|
||||
{
|
||||
$value += $self->{values}{$key} if ($id eq $self->{id} || !$key || $key eq $id);
|
||||
}
|
||||
}
|
||||
return $value;
|
||||
}
|
||||
|
||||
sub getWhos
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
return { $self->{id} => $self->{who} };
|
||||
}
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -133,7 +133,7 @@ sub grades_generate
|
|||
|
||||
if (-f "$basedir/$tr_file")
|
||||
{
|
||||
open my $xmltrace, "<", "$basedir/$tr_file" or croak "$tr_file: $!";
|
||||
open my $xmltrace, "<", "$basedir/$tr_file" or die "$tr_file: $!";
|
||||
binmode $xmltrace;
|
||||
my $trace = Trace->new($xmltrace);
|
||||
close $xmltrace;
|
||||
|
|
|
|||
Reference in a new issue