File Coverage

blib/lib/Object/AutoAccessor.pm

Criterion	Covered	Total	%
statement	131	158	82.9
branch	50	76	65.7
condition	7	15	46.6
subroutine	20	22	90.9
pod	9	15	60.0
total	217	286	75.8

package Object::AutoAccessor;

require 5.004;
use strict;
use Carp;		# require 5.004

use vars qw($VERSION $AUTOLOAD);

$VERSION = '0.06';

sub new {
	my $obj = shift;
	my $class = ref($obj) || $obj;

	unless (@_ % 2 == 0) {
		croak "Odd number of argumentes for $class->new()";
	}

	my %args = @_;
	my $options = { autoload => 1 };
	$options->{$_} = $args{$_} for keys %args;
	bless $options, $class;
}

sub renew {
	my $obj = shift;
	my $class = ref($obj) || $obj;

	unless (@_ % 2 == 0) {
		croak "Odd number of argumentes for $class->renew()";
	}

	my %args = @_;
	if (ref($obj) and UNIVERSAL::isa($obj, __PACKAGE__)) {
		%args = map { $_ => $obj->{$_} } grep !/^params$/, keys %$obj;
	}
	$class->new(%args);
}

sub renew_node { shift->renew(@_) }

sub new_node {
	my $self = shift;

	unless (@_) {
		croak "Not enough arguments for " . ref($self) . "->new_node()";
	}

	my $label = shift;
	my $child = $self->renew(@_);
	$self->param($label => $child);
	$child;
}

sub node {
	my $self = shift;

	unless (@_) {
		return grep { $self->is_node($_) } keys(%{ $self->{params} });
	}

	my $first = shift;

	if (@_) {
		my @children = ();
		for my $label ($first,@_) {
			if ($self->is_node($label)) {
				push(@children, $self->{params}->{$label});
			}
			else {
				push(@children, undef);
			}
		}
		return wantarray ? @children : [@children];
	}
	else {
		if ($self->is_node($first)) {
			return $self->{params}->{$first};
		}
		else {
			return undef;
		}
	}
}

sub has_node { scalar shift->node() }

sub is_node {
	my $self = shift;

	unless (@_) {
		croak "Not enough arguments for " . ref($self) . "->is_node()";
	}

	my $label = shift;
	return (ref($self->{params}->{$label}) and UNIVERSAL::isa($self->{params}->{$label}, __PACKAGE__));
}

sub param {
	my $self = shift;

	unless (@_) {
		return grep { !$self->is_node($_) } keys(%{ $self->{params} });
	}

	my $first = shift;

	if (@_) {
		croak "Odd number of argumentes for " . ref($self) . "->param()" unless ((@_ % 2) == 1);

		my %hash = ($first,@_);

		for my $key (keys %hash) {
			my $ref = ( ref $hash{$key} );

			if ($ref eq 'HASH') {
				%{ $self->{params}->{$key} } = %{ $hash{$key} };
			}
			elsif ($ref eq 'ARRAY') {
				@{ $self->{params}->{$key} } = @{ $hash{$key} };
			}
			elsif ($ref eq 'SCALAR') {
				$self->{params}->{$key} = $hash{$key};
			}
			else {
				$self->{params}->{$key} = $hash{$key};
			}
		}

		if (@_ == 1) {
			return $self->{params}->{$first};
		}
	}
	else {
		if ($self->is_node($first)) {
			return undef;
		}

		my $type = ( ref $self->{params}->{$first} );

		if ($type eq 'HASH') {
			return \%{ $self->{params}->{$first} };
		}
		elsif ($type eq 'ARRAY') {
			return \@{ $self->{params}->{$first} };
		}
		elsif ($type eq 'SCALAR') {
			return $self->{params}->{$first};
		}
		else { # CODEREF, IO, GLOB, OBJECT
			return $self->{params}->{$first};
		}
	}
}

sub defined {
	my $self = shift;

	unless (@_) {
		croak "Not enough arguments for " . ref($self) . "->defined()";
	}

	my $label = shift;
	return CORE::defined($self->{params}->{$label});
}

sub exists {
	my $self = shift;

	unless (@_) {
		croak "Not enough arguments for " . ref($self) . "->exists()";
	}

	my $label = shift;
	return CORE::exists($self->{params}->{$label});
}

sub delete {
	my $self = shift;

	unless (@_) {
		croak "Not enough arguments for " . ref($self) . "->delete()";
	}

	my $label = shift;
	return CORE::delete($self->{params}->{$label});
}

sub undef {
	my $self = shift;

	unless (@_) {
		croak "Not enough arguments for " . ref($self) . "->undef()";
	}

	my $label = shift;
	return CORE::undef($self->{params}->{$label});
}

sub build {
	my $obj = shift;
	my $class = ref($obj) || $obj;

	unless (@_) {
		croak "Not enough arguments for " . $class . "->build()";
	}

	my $hashref = shift;

	unless (UNIVERSAL::isa($hashref, 'HASH')) {
		croak $class . "->build(): Cannot build: argument is not a HASH reference";
	}

	my $self = $class->new(@_);

	$self->_build($hashref);

	$self;
}

sub _build {
	my $self = shift;
	my $struct = shift;

	for my $key (keys %$struct) {
		if (UNIVERSAL::isa($struct->{$key}, 'HASH')) {
			$self->new_node($key)->_build($struct->{$key});
		}
		else {
			$self->param( $key => $struct->{$key} );
		}
	}
}

sub as_hashref {
	my $self = shift;

	my $hashref = {};

	$self->_as_hashref($hashref);
}

sub _as_hashref {
	my $self = shift;
	my $hashref = shift;

	for my $key (keys %{ $self->{params} }) {
		if (UNIVERSAL::isa($self->{params}->{$key}, __PACKAGE__)) {
			$hashref->{$key} = $self->node($key)->_as_hashref($hashref->{$key});
		}
		else {
			$hashref->{$key} = $self->param($key);
		}
	}

	$hashref;
}

sub autoload {
	my $self = shift;
	$self->{autoload} = shift if @_;
	$self->{autoload};
}

sub AUTOLOAD {
	my $self = shift;

	return if $AUTOLOAD =~ /::DESTROY$/;

	my ($method) = ($AUTOLOAD =~ /.*::(.*?)$/);

	if ( $self->{autoload} ) {
		if ( $self->can( $method ) ) {
			return $self->$method( @_ );
		}
		elsif ($method =~ /^([sg]et_)(.*)$/) {
			my($prefix, $name) = ($1, $2);
			if ($prefix eq 'set_') {
				return $self->param($name => @_);
			}
			else {
				carp "Too many arguments for " . ref($self) . "->get_$name\()" if @_;
				return $self->param($name);
			}
		}
		else {
			if ($self->is_node($method)) {
				if (@_) {
					undef $self->{params}->{$method};
					return $self->param($method => @_);
				}
				else {
					return $self->{params}->{$method};
				}
			}
			else {
				return $self->param($method => @_);
			}
		}
	}
	else {
		croak(ref($self) . "->$method\() : this method is not implimented");
	}

	return;
}

sub DESTROY {}

1;
__END__