VS::RuleEngine::Loader::XML - Load VS::RuleEngine engine declarations in XML

  use VS::RuleEngine::Loader::XML;

  my $engine = VS::RuleEngine::Loader::XML->load_file("my_engine.xml");
  $engine->run();

  my $other_engine = VS::RuleEngine::Loader::XML->load_string($xml);
  $other_engine->run();

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__