File Coverage

blib/lib/Farly/Object.pm

Criterion	Covered	Total	%
statement	122	125	97.6
branch	33	44	75.0
condition	10	21	47.6
subroutine	32	32	100.0
pod	14	14	100.0
total	211	236	89.4

package Farly::Object;

use 5.008008;
use strict;
use warnings;
use Carp;

#Farly containers
use Farly::Object::List;
use Farly::Object::Set;
use Farly::Object::Aggregate;
#Farly reference object
require Farly::Object::Ref;
#Farly value objects
use Farly::Value::String;
use Farly::Value::Integer;
use Farly::IPv4::Address;
use Farly::IPv4::Network;
use Farly::IPv4::Range;
use Farly::IPv4::ICMPType;
use Farly::Transport::Port;
use Farly::Transport::PortGT;
use Farly::Transport::PortLT;
use Farly::Transport::PortRange;
use Farly::Transport::Protocol;

our $VERSION = '0.26';

sub new {
    my ($class) = @_;

    carp "constructor arguments not supported; use 'set'"
      if ( scalar(@_) > 1 );

    return bless {}, $class;
}

sub set {
    my ( $self, $key, $value ) = @_;

    confess "invalid key"
      unless ( defined($key) && length($key) );

    confess "a value object must be defined"
      unless ( defined($value) );

    # reference object, or list (i.e. $self is tree node), or set
    if ( $value->isa('Farly::Object') || $value->isa('Farly::Object::List')
         || $value->isa('Farly::Object::Set') )
    {
        $self->{$key} = $value;
        return;
    }

    # or value object
    confess "$value is not a valid value object type"
      unless ( $value->can('equals')
        && $value->can('contains')
        && $value->can('intersects')
        && $value->can('compare')
        && $value->can('as_string') );

    $self->{$key} = $value;
}

sub get {
    my ( $self, $key ) = @_;
    if ( defined( $self->{$key} ) ) {
        return $self->{$key};
    }
    else {
        confess $self->dump(), "\n undefined key $key. use 'has_defined' to
		  check for the existance of a key/value pair";
    }
}

sub has_defined {
    my ( $self, $key ) = @_;
    return 1 if defined $self->{$key};
}

sub delete_key {
    my ( $self, $key ) = @_;
    delete $self->{$key}
      or carp "key $key delete error";
}

sub get_keys {
    return keys %{ $_[0] };
}

sub equals {
    my ( $self, $other ) = @_;

    if ( $other->isa(__PACKAGE__) ) {

        if ( scalar( keys %$self ) != scalar( keys %$other ) ) {
            return undef;
        }

        return $self->matches($other);
    }
}

sub matches {
    my ( $self, $other ) = @_;

    if ( $other->isa(__PACKAGE__) ) {

        foreach my $key ( keys %$other ) {
            if ( !defined( $self->{$key} ) ) {
                return undef;
            }
            if ( !$self->{$key}->equals( $other->{$key} ) ) {
                return undef;
            }
        }
        return 1;
    }
}

sub intersects {
    my ( $self, $other ) = @_;

    if ( $other->isa(__PACKAGE__) ) {

        foreach my $key ( keys %$other ) {
            if ( !defined( $self->{$key} ) ) {
                return undef;
            }
            if ( !$self->{$key}->intersects( $other->{$key} ) ) {
                return undef;
            }
        }

        return 1;
    }
}

sub contains {
    my ( $self, $other ) = @_;

    if ( $other->isa(__PACKAGE__) ) {

        foreach my $key ( keys %$other ) {
            if ( !defined( $self->{$key} ) ) {
                return undef;
            }
            if ( !$self->{$key}->contains( $other->{$key} ) ) {
                return undef;
            }
        }

        return 1;
    }
}

sub contained_by {
    my ( $self, $other ) = @_;

    if ( $other->isa(__PACKAGE__) ) {

        foreach my $key ( keys %$other ) {
            if ( !defined( $self->{$key} ) ) {
                return undef;
            }
            if ( !$other->{$key}->contains( $self->{$key} ) ) {
                return undef;
            }
        }

        return 1;
    }
}

sub clone {
    my ($self) = @_;
    my %clone = %$self;
    return bless( \%clone, ref $self );
}

sub as_string {
    my ($self) = @_;
    my $string;
    foreach my $key ( sort keys %$self ) {
        $string .= $key . " => " . $self->get($key) . " ";
    }
    return $string;
}

sub dump {
    my ($self) = @_;
    my $string;
    foreach my $key ( sort keys %$self ) {
        $string .=
            $key . " => "
          . ref( $self->get($key) ) . " "
          . $self->get($key)->as_string() . "\n";
    }
    return $string;

}

1;
__END__