File Coverage

blib/lib/Data/Conveyor/YAML/Marshall/Payload/InstructionContainer.pm

Criterion	Covered	Total	%
statement	19	36	52.7
branch	0	8	0.0
condition	0	6	0.0
subroutine	7	9	77.7
pod	2	2	100.0
total	28	61	45.9

use 5.008;
use strict;
use warnings;

package Data::Conveyor::YAML::Marshall::Payload::InstructionContainer;
BEGIN {
  $Data::Conveyor::YAML::Marshall::Payload::InstructionContainer::VERSION = '1.103130';
}
# ABSTRACT: Stage-based conveyor-belt-like ticket handling system
use YAML::Marshall 'payload/instructioncontainer';
use YAML 'Dump';
use parent 'Class::Scaffold::YAML::Marshall';

sub yaml_load {
    my $self = shift;
    my $node = $self->SUPER::yaml_load(@_);
    my $instruction_container =
      $self->delegate->make_obj('payload_instruction_container');
    our $instruction_factory ||=
      $self->delegate->make_obj('payload_instruction_factory');

    # expect an ordered list of instructions, each with name and value. The
    # YAML::Active plugin uses the payload_instruction_factory to
    # generate the right instruction object, then sets the value on it
    # and inserts it into the container. The name is prepended by 'u-'
    # for IC_UPDATE, 'a-' for IC_ADD and 'd-' for IC_DELETE to provide a
    # concise notation.
    #
    # Example:
    #
    # - u-value_person_company_no: &COMPANYNO 1234
    # - u-value_person_name_title: &TITLE Grunz
    # - u-value_person_name_firstname: &FIRSTNAME Franz
    # - u-value_person_name_lastname: &LASTNAME Testler
    # - a-value_person_email_address: &EMAIL [e-mail]
    # - a-value_person_fax_number: &FAX1 '[phone]'
    # - a-value_person_fax_number: &FAX2 '[phone]'
    # - clear: 1
    # - foo: 1
    for my $spec (@$node) {
        unless (ref $spec eq 'HASH' && scalar(keys %$spec) == 1) {
            throw Error::Hierarchy::Internal::CustomMessage(custom_message =>
                  "expected a single-item hash with the instruction, got:\n"
                  . Dump($spec));
        }
        my ($key, $value) = %$spec;
        if ($key =~ /^([a-z])-(.*)/) {
            my ($abbrev_command, $type) = ($1, $2);
            my $command = $self->word_complete($abbrev_command, $self->delegate->IC)
              or throw Error::Hierarchy::Internal::CustomMessage(custom_message =>
                  "can't determine instruction command from [$abbrev_command]");
            $instruction_container->items_push(
                $instruction_factory->gen_instruction(
                    $type,
                    command => $command,
                    value   => $value,
                )
            );
        } else {
            $instruction_container->items_push(
                $instruction_factory->gen_instruction($key, value => $value));
        }
    }
    $instruction_container;
}

sub word_complete {
    my ($self, $word, @candidates) = @_;
    for (@candidates) {
        return $_ if index($_, $word) == 0;
    }
}
1;


__END__