File Coverage

blib/lib/Hash/Filler.pm

Criterion	Covered	Total	%
statement	81	136	59.5
branch	27	62	43.5
condition	5	11	45.4
subroutine	14	20	70.0
pod	8	9	88.8
total	135	238	56.7

package Hash::Filler;

use strict;
use Carp;
use vars qw($VERSION $DEBUG $indent);
use Time::HiRes qw(gettimeofday tv_interval);

# How to check for the existence of an element

use constant TRUE	=> 0;	# Test if the value is true
use constant DEFINED	=> 1;	# Use defined()
use constant EXISTS	=> 2;	# Use exists() (default)

use constant INDENT	=> 2;	# How much to indent printouts

$VERSION	= '1.40';
$DEBUG		= '0';

my $indent = 0;

# Preloaded methods go here.

sub new {
    my $type = shift;
    my $class = ref($type) || $type || "Hash::Filler";

    my $self = {
	'rules' => {},		# All the rules we know about
	'wild' => [],		# Wildcard rules
	'times' => [],		# Accumulated times for each rule
	'calls' => [],		# How many times each rule has been used
	'id' => 0,		# Current rule id
	'loop' => 1,		# Avoid loops by default
	'method' => EXISTS,	# Which method to use to check for
				# existence of a hash key
    };

    bless $self, $class;
}

sub _sort {			# This is to be used by the sort
				# built-in
    return
	    $b->{'pref'} <=> $a->{'pref'} or
		@{$a->{'prereq'}} <=> @{$b->{'prereq'}} or
		    $a->{'used'} <=> $b->{'used'};
}

sub _print_rule {
    my $self = shift;
    my $rule = shift;
    my $key = shift;

    printf("%s[%d] rule for key %s, used %s, pref %s, %s be used\n",
	   ' ' x $indent,
	   $rule->{'id'},
	   defined $rule->{'key'} ? $rule->{'key'} : '',
	   $rule->{'used'},
	   $rule->{'pref'},
	   $rule->{'use'} ? 'can' : 'cannot');
    printf("%s|[called %d times (%0.6f secs)]\n",
	   ' ' x $indent,
	   $self->{'calls'}->[$rule->{'id'}],
	   $self->{'times'}->[$rule->{'id'}]);
    if (defined $key) {
	printf("%s|[called to get key %s]\n",
	       ' ' x $indent,
	       $key);
    }
    my $pre = 0;
    foreach my $pr (sort @{$rule->{'prereq'}}) {
	printf("%s+- prereq %s\n", ' ' x $indent, $pr);
	++$pre;
    }
    printf("%s+- No prereq\n", ' ' x $indent) unless $pre;
}

sub dump_r_tree {
    my $self = shift;
    foreach my $key (keys %{$self->{'rules'}}) {
	my $dumped = 0;
	print "Rules for key $key:\n";
	foreach my $rule (sort(_sort @{$self->{'rules'}->{$key}})) {
	    ++$dumped;
	    $self->_print_rule($rule);
	}
	print "  No rules.\n" unless $dumped;
    }
    my $dumped = 0;
    print "Wildcard rules:\n";
    foreach my $rule (sort(_sort @{$self->{'wild'}})) {
	++$dumped;
	$self->_print_rule($rule);
    }
    print "  No rules.\n" unless $dumped;
}

sub loop {
    $_[0]->{'loop'} = $_[1];
}

sub method {
    $_[0]->{'method'} = $_[1];
}

sub stats {
    @{$_[0]->{'calls'}};
}

sub profile {
    @{$_[0]->{'times'}};
}

sub remove {
    my $self = shift;
    my $id = shift;

    return unless $id;

    foreach my $key (keys %{$self->{'rules'}}) {
	foreach my $rule (@{$self->{'rules'}->{$key}}) {
	    if ($rule->{'id'} == $id) {
		$rule->{'use'} = 0;
		return;
	    }
	}
    }
    foreach my $rule (@{$self->{'wild'}}) {
	if ($rule->{'id'} == $id) {
	    $rule->{'use'} = 0;
	    return;
	}
    }
}

sub add {
    my $ret;

    if (defined $_[1]) {	# Specific rule
	push @{$_[0]->{'rules'}->{$_[1]}}, {
	    'key' => $_[1],
	    'code' => $_[2],
	    'prereq' => $_[3],
	    'pref' => $_[4] ? $_[4] : 100,
	    'used' => 0,
	    'use' => 1,
	    'id' => $ret = ++ $_[0]->{'id'},
	};
    }
    else {			# Wildcard rule
	push @{$_[0]->{'wild'}}, {
	    'key' => undef,
	    'code' => $_[2],
	    'prereq' => $_[3],
	    'pref' => $_[4] ? $_[4] : 100,
	    'used' => 0,
	    'use' => 1,
	    'id' => $ret = ++ $_[0]->{'id'},
	};
    }
    $ret;
}

sub _exists {
    my $self = shift;
    my $href = shift;
    my $key = shift;

    if ($self->{'method'} == DEFINED) {
	return 1 if defined $href->{$key};
    }
    elsif ($self->{'method'} == EXISTS) {
	return 1 if exists $href->{$key};
    }
    elsif (ref $self->{'method'} eq 'CODE') {
	return 1 if $self->{'method'}->($href, $key);
    }
    else {
	return 1 if $href->{$key};
    }
    return 0;
}

sub fill {
    my $self = shift;
    my $href = shift;
    my $key = shift;
    my $ret = 0;

    croak "->fill() must be given a hash reference"
	unless ref($href) eq 'HASH';

				# Provide a quick exit if the hash
				# key is already defined or if
				# we have no rules to generate it.

    ++ $self->{'calls'}->[0];	# Keep the number of times ->fill
				# has been called.

    return 1
	if $self->_exists($href, $key);

    return 0
	unless $self->{'rules'}->{$key} or
	    @{$self->{'wild'}};

				# Look through the available rules
				# and try to find an execution plan
				# to fill the requested $key.

    my @rulelist;

    if ($self->{'rules'}->{$key}) {
	push @rulelist, sort(_sort @{$self->{'rules'}->{$key}});
    }

    push @rulelist, sort(_sort @{$self->{'wild'}});

  RULE:
    foreach my $rule (@rulelist) {

	next RULE		# Watch out for infinite loops
	    if $self->{'loop'} and
		$rule->{'used'};

	$rule->{'used'} ++;	# Mark this rule as being used
				# to control infinite recursion

	++ $self->{'calls'}->[$rule->{'id'}];

				# Insure that all prerequisites
				# are there before attempting to
				# call this method

	foreach my $pr (@{$rule->{'prereq'}}) {

				# A rule cannot be invoked to resolve
				# its own prerequisite as this might make
				# no sense.

	    if ($pr eq $key) {
		if (defined $rule->{'key'}) {
		    croak "Rule "
			. $rule->{'id'}
		    . " has itself as prerequisite";
		}
		else {		# A wildcard rule...
		    next RULE
			unless $self->_exists($href, $pr);
		}
	    }

				# Recursive call. If required, attempt
				# to fill this prerequisite using the
				# available rules. If the prereq is
				# already in the hash, this will return
				# immediatly. The retval of this ->fill()
				# is ignored as there might be more than
				# one rule that can provide the missing
				# prereq.

# XXX - Note that we might want to return false from this rule if the fill
# method for a prereq returns false. The current implementation allows the
# method's return value control the behavior of ->fill more fine-granedly.

	    $indent += INDENT;
	    $self->fill($href, $pr);
	    $indent -= INDENT;

				# Insure that the required hash
				# buckets are already filled
				# before attempting to call the
				# user supplied function.

	    next RULE
		unless $self->_exists($href, $pr);
	}

	$self->_print_rule($rule, $key) if $DEBUG;

				# Run and profile the execution of
				# the user supplied method.

	my $time = [gettimeofday];
	$ret = $rule->{'code'}->($href, $key);
	$time = tv_interval($time);

	$self->{'times'}->[$rule->{'id'}] += $time;
	$self->{'times'}->[0] += $time;
    }
    continue {
	$rule->{'used'} --;	# Rule is no longer used
	return $ret		# If a user-supplied sub was
	    if $ret;		# succesful, we're done
    }

    return 0;			# No rule matched or was succesful.
}

# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__