File Coverage

blib/lib/Data/HashArray.pm

Criterion	Covered	Total	%
statement	56	69	81.1
branch	10	20	50.0
condition	1	6	16.6
subroutine	13	15	86.6
pod	2	2	100.0
total	82	112	73.2

# $Id$
#
use strict;
use warnings;
no warnings qw(uninitialized);
use utf8;

package Data::HashArray;
require 5.008;

use Carp qw(carp cluck);
use Data::Dumper;
use Scalar::Util qw(reftype);

use vars qw($VERSION);
$VERSION = '1.03';

our $AUTOLOAD;

# Hash deref. gives access to the first element
# For debugging purpose only
#carp "\033\[0;35m[NOTICE] Overloaded '\"\"' called (".
#  __PACKAGE__.")\033\[0m";
use overload (
    '%{}'      => sub { $_[0]->_hash_access; },
    '""'       => sub { "". $_[0]->_hash_access; },
    'fallback' => 1,
);

# --------------------------------------------------------------------
# Constructor
# --------------------------------------------------------------------

sub new {
    my ($proto, @array) = @_;
    my $class = ref($proto) || $proto;

    bless \@array, $class;
}


# Return the first element (which is normally a hash ref) of the list
sub _hash_access () {
    my ($self) = @_;

    my $item = eval { $self->[0]; };
    if ($@) {
        cluck "$@";
    }

    #carp "Hash-access => DONE\n";
    return $item;
}

#-------------------------------------------------------
# hash(field1, field2, field3, ...)
#
# Return a hash keyed on field1. If there is no field2, this will be
# a hash of HashArrays. If field2 exists, this will be a hash of hashes of
# HashArrays. And so on...
#
# Note that field1; field2, ... may be CODE references, too. In that case, the sub gets called
# at least once for each item in the array. The item is passed as an argument to the sub.
#
# Breadth-first recursive.
#-------------------------------------------------------
sub hash {
	my $self	= shift;
	my $class	= ref($self);
	return undef unless (@_);
	my $field	= shift;
	return undef unless defined($field);

	my $h = {};

	# Hash the array on '$field';
	foreach my $item (@$self) {
		my $key;

		if (ref($field) eq 'CODE') {
			# Field is a CODE refernce. Call it, with 'item' passed as an argument
			$key = &$field($item);
		} elsif (UNIVERSAL::can($item, $field)) {
			# Field has an accessor. Call it  (the resukt should stringify to a hash key).
			$key = $item->$field();
		} else {
			# Field should otherwise stringify to a hash key
			$key = $item->{$field};
		}

		# If the keyed item doesn't yet exist, create a new NodeArray and assign it.
		unless ( exists($h->{$key}) ) {
			$h->{$key} = $class->new();
		}

		# Push the item on the keyed NodeArray.
		my $array= $h->{$key};
		push @$array, $item;
	}

	# If we don't have any more fields, just return the hash.
	return $h unless (@_);

	# Otherwise, further hash each item in the hash on the remaining fields.
	foreach my $key (keys %$h) {
		my $array = $h->{$key};
		$h->{$key} = $array->hash(@_);
	}
	return $h;
}


#-------------------------------------------------------
# By default, all method calls are delegated to the first element.
#-------------------------------------------------------
sub AUTOLOAD {
    my $self = shift;
    my $func = $AUTOLOAD;
    $func    =~ s/.*:://;

    if ($func =~ /^[0-9]+$/o) {
        return eval { $self->[$func]; };
    }

    return undef if $func eq 'DESTROY';
    if (reftype($self) && reftype($self) eq 'ARRAY') {
        $self->_hash_access->$func(@_);
    } else {
        cluck "*** \$self->$func";
    }
}


1;


__END__