File Coverage

blib/lib/VS/RuleEngine/Loader/XML.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package VS::RuleEngine::Loader::XML;

use strict;
use warnings;

use Carp qw(croak);
use Scalar::Util qw(blessed);
use XML::LibXML;

use VS::RuleEngine::Engine;
use VS::RuleEngine::Util qw(is_existing_package);

use Object::Tiny qw(_ruleset);

our $VERSION = "0.05";

sub _new {
    my ($pkg) = @_;
    my $self = bless {
        _ruleset => {},
    }, $pkg;
    return $self;
}

sub load_file {
    my ($self, $path) = @_;

    my $parser  = XML::LibXML->new();
    my $doc     = $parser->parse_file($path);
    my $engine  = $self->_process_document($doc);

    return $engine;
}

sub load_string {
    my ($self, $xml) = @_;

    my $parser  = XML::LibXML->new();
    my $doc     = $parser->parse_string($xml);
    my $engine  = $self->_process_document($doc);

    return $engine;
}

{
    my %Node_Handler = (
        action      => "_process_action",
        defaults    => "_process_defaults",
        input       => "_process_input",
        output      => "_process_output",
        posthook    => "_process_posthook",
        prehook     => "_process_prehook",
        rule        => "_process_rule",
        ruleset     => "_process_ruleset",
        run         => "_process_run",
    );

    sub _process_document {
        my ($self, $doc) = @_;

        $self = __PACKAGE__->_new() unless blessed $self;

        # Clear rulesets
        $self->{_ruleset} = {};

        my $root = $doc->documentElement();
        croak ("Expected root node 'engine' but found '", $root->nodeName, "'") if $root->nodeName ne "engine";

        my $engine_class = "VS::RuleEngine::Engine";
        if ($root->hasAttribute("instanceOf")) {
            my $class = $root->getAttribute("instanceOf");
            if (!is_existing_package($class)) {
                eval "require ${class};";
                croak $@ if $@;
            }

            $engine_class = $class;
        }

        my $engine = $engine_class->new();

        # Iterate over child nodes
        for my $child ($root->childNodes) {
            # Skip stuff that's not elements
            next unless $child->isa("XML::LibXML::Element");

            my $name = $child->nodeName;
            my $handler = $Node_Handler{$name};
            croak "Don't know how to handle '${name}'" if !$handler;

            $self->$handler($child, $engine);
        }

        return $engine;
    }
}

sub _process_action {
    my ($self, $action, $engine) = @_;
    my ($name, $class, $defaults, @args) = $self->_process_std_element($action);
    $engine->add_action($name => $class, $defaults, @args);
};

sub _process_input {
    my ($self, $input, $engine) = @_;
    my ($name, $class, $defaults, @args) = $self->_process_std_element($input);
    $engine->add_input($name => $class, $defaults, @args);
};

sub _process_output {
    my ($self, $output, $engine) = @_;
    my ($name, $class, $defaults, @args) = $self->_process_std_element($output);
    $engine->add_output($name => $class, $defaults, @args);
};

sub _process_prehook {
    my ($self, $hook, $engine) = @_;
    my ($name, $class, $defaults, @args) = $self->_process_std_element($hook);
    $engine->add_hook($name => $class, $defaults, @args);
    $engine->add_pre_hook($name);
};

sub _process_posthook {
    my ($self, $hook, $engine) = @_;
    my ($name, $class, $defaults, @args) = $self->_process_std_element($hook);
    $engine->add_hook($name => $class, $defaults, @args);
    $engine->add_post_hook($name);
};

sub _process_rule {
    my ($self, $rule, $engine) = @_;
    my ($name, $class, $defaults, @args) = $self->_process_std_element($rule);
    $engine->add_rule($name => $class, $defaults, @args);
};

sub _process_defaults {
    my ($self, $defaults, $engine) = @_;

    my $name = $defaults->getAttribute("name");

    my @args;
    for my $arg ($defaults->childNodes) {
        next unless $arg->isa("XML::LibXML::Element");
        my $name = $arg->nodeName;
        my $value = $arg->hasChildNodes ? $arg->textContent : undef;
        push @args, $name => $value;
    }

    my $data = { @args };

    $engine->add_defaults($name, $data);
}

sub _process_ruleset {
    my ($self, $ruleset, $engine) = @_;

    my $name = $ruleset->getAttribute("name");

    croak "Ruleset '${name}' is already defined" if exists $self->_ruleset->{$name};

    # This does not apply to all rules in the engine
    # but rather to the ones we've added so far when
    # parsing
    my @rules;

    if ($ruleset->hasAttribute("rulesMatchingName")) {
        my $s   = $ruleset->getAttribute("rulesMatchingName");
        my $re  = qr/$s/;

        my @matching_rules = sort grep { $_ =~ $re } $engine->rules;
        push @rules, @matching_rules;
    }

    if ($ruleset->hasAttribute("rulesOfClass")) {
        my $c = $ruleset->getAttribute("rulesOfClass");
        my @matching_rules = sort grep {
            my $rule = $engine->_get_rule($_);
            UNIVERSAL::isa($rule->_pkg, $c)
        } $engine->rules;

        push @rules, @matching_rules;
    }

    push @rules, $self->_process_rules($ruleset, $engine);

    @rules = sort keys %{+{ map { $_ => 1 } @rules }};

    $self->_ruleset->{$name} = \@rules;
}

sub _process_run {
    my ($self, $run, $engine) = @_;

    croak "Missing attribute 'action' for element 'run'" unless $run->hasAttribute("action");
    my $action = $run->getAttribute("action");
    croak "No action named '${action}' exists" unless $engine->has_action($action);

    my @rules = $self->_process_rules($run, $engine);

    for my $rule (@rules) {
        $engine->add_rule_action($rule => $action);
    }
}

sub _process_std_element {
    my ($self, $element) = @_;

    if (!$element->hasAttribute("name")) {
        croak $element->nodeName, " is missing mandatory attribute 'name'";
    }
    my $name = $element->getAttribute("name");

    if (!$element->hasAttribute("instanceOf")) {
        croak $element->nodeName, " is missing mandatory attribute 'instanceOf'";
    }
    my $class = $element->getAttribute("instanceOf");

    my $defaults = $element->getAttribute("defaults");
    $defaults = "" if !defined $defaults;
    $defaults = [split/,\s*|\s+/, $defaults];

    my @args = $self->_process_args($element, $class);

    return ($name, $class, $defaults, @args);
}

sub _process_rules {
    my ($self, $element, $engine) = @_;

    my @rules;

    for my $rule ($element->childNodes) {
        next unless $rule->isa("XML::LibXML::Element");
        my $name = $rule->textContent;
        my $type = $rule->nodeName;

        ($name) = $name =~ /^\s*(.*?)\s*$/;
        croak "Empty '${type}' name" if $name eq '';

        if ($type eq 'rule') {
            croak "No rule named '${name}' exists" unless $engine->has_rule($name);
            push @rules, $name;
        }
        elsif ($type eq 'ruleset') {
            croak "No ruleset named '${name}' exists" if !exists $self->_ruleset->{$name};
            push @rules, @{$self->_ruleset->{$name}};
        }
        else {
            croak "Expected rule or ruleset element but got '${type}'";
        }
    }

    @rules = sort keys %{+{ map { $_ => 1 } @rules }};

    return @rules;
}

sub _process_args {
    my ($self, $element, $class) = @_;

    if (!is_existing_package($class)) {
        eval "require ${class};";
        croak $@ if $@;
    }

    if ($class->can("process_xml_loader_args")) {
        return $class->process_xml_loader_args($element);
    }

    my @args;
    for my $arg ($element->childNodes) {
        next unless $arg->isa("XML::LibXML::Element");
        my $name = $arg->nodeName;
        my $value = $arg->hasChildNodes ? $arg->textContent : undef;
        push @args, $name => $value;
    }

    return @args;
}

1;
__END__