File Coverage

blib/lib/Soar/WM/Element.pm

Criterion	Covered	Total	%
statement	67	68	98.5
branch	19	22	86.3
condition			n/a
subroutine	10	10	100.0
pod	7	7	100.0
total	103	107	96.2

#
# This file is part of Soar-WM
#
# This software is copyright (c) 2012 by Nathan Glenn.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
package Soar::WM::Element;
use strict;
use warnings;

our $VERSION = '0.04'; # VERSION
# ABSTRACT: Work with Soar working memory elements

use Carp;

sub new {
    my ( $class, $wm, $id ) = @_;
    if ( !exists $wm->{$id} ) {
        carp 'Given ID doesn\'t exist in given working memory';
        return;
    }

    my $self = bless {
        wm   => $wm,
        id   => $id,
        node => $wm->{$id},
    }, $class;
    return $self;
}

sub id {
    my ($self) = @_;
    return $self->{id};
}

sub atts {
    my ($self) = @_;
    my @atts = keys %{ $self->{node} };
    return \@atts;
}

sub vals {
    my ( $self, $query ) = @_;
    if ( !$query ) {
        carp 'missing argument attribute name';
        return;
    }
	return [] unless exists $self->{node}->{$query};
    my @values = @{ $self->{node}->{$query} };

    #find ones that are links and change them into WME instances
    for ( 0 .. $#values ) {
        if ( exists $self->{wm}->{ $values[$_] } ) {
            $values[$_] = __PACKAGE__->new( $self->{wm}, $values[$_] );
        }
    }
    return \@values;
}

sub children {
    my ($self , %args) = @_;

	my @children;
	for my $key ( keys %{$self->{node}} ){
		push @children, @{ $self->{node}->{$key} };
	}

    #find ones that are links and change them into WME instances
    for ( 0 .. $#children ) {
        if ( exists $self->{wm}->{ $children[$_] } ) {
            $children[$_] = __PACKAGE__->new( $self->{wm}, $children[$_] );
        }
    }
	my $retVal;
	if($args{links_only}){
		my @links = grep {ref($_) eq 'Soar::WM::Element'} @children;
		$retVal = \@links;
	}else{
		$retVal = \@children;
	}
    return $retVal;
}

sub first_val {
    my ( $self, $query ) = @_;
    if ( !$query ) {
        carp 'missing argument attribute name';
        return;
    }
	return unless exists $self->{node}->{$query};

    # grab only the first value
    my $value = ${ $self->{node}->{$query} }[0];

	if(not defined $value){
		return;
	}

    #if value is a link, change it into a WME instance
    if ( exists $self->{wm}->{$value} ) {
        $value = __PACKAGE__->new( $self->{wm}, $value );
    }
    return $value;
}

sub num_links {
    my ($self) = @_;
    my $count = 0;

    #iterate values of each attribute; a child will have its own entry in WM
    for my $att ( @{ $self->atts } ) {
        for my $val ( @{ $self->{node}->{$att} } ) {
            $count++
              if ( exists $self->{wm}->{$val} );
        }
    }
    return $count;
}

1;

__END__