File Coverage

blib/lib/Data/Binder.pm

Criterion	Covered	Total	%
statement	45	56	80.3
branch	15	24	62.5
condition	4	12	33.3
subroutine	9	10	90.0
pod	4	5	80.0
total	77	107	71.9

# Data::Binder - a map of keys to potential values for simple unification

#----------------------------------------------------------------------------
#
# Copyright (C) 1998-2003 Ed Halley
# http://www.halley.cc/ed/
#
#----------------------------------------------------------------------------

package Data::Binder;
use vars qw($VERSION);
$VERSION = 1.00;

=head1 NAME

Data::Binder - a map of keys to potential values for simple unification

=head1 SYNOPSIS

    $binder = new Data::Binder(city => 'Denver', altitude => 5280);
    if ($binder->bindable(city => 'Denver', population => 2000000))
        { ... }
    if ($binder->bind(city => 'Dallas', altitude => 750))
        { ... }
    if ($binder->bound())
        { ... }

=head1 ABSTRACT

A Binder is a special map of keys to potential values; it supports
non-conflicting unification against other Binders or terms.  Each key
term in the Binder may be unbound (associated with an undef value), or
bound to a defined scalar value.  Unbound keys may be bound to anything,
and bound keys may only be bound to identical values.  Attempts to bind a
new set of values succeeds completely or fails without changes.

Binders are useful in unifying a simple set of arguments to values, such
as in languages like Prolog.  Bind any lowercase arguments to themselves,
and uppercase "variable" arguments to the caller's values.  If that is
not successful, then the rule is inappropriate.

They are also useful when a number of multi-faceted objects or strategies
need to be tested against a single opportunity, but the available facets
for each object or strategy are not always the same.  Describe the facets
with a hash, and the opportunity with a binder; inappropriate facet
values will fail the unification.

=cut

#----------------------------------------------------------------------------

use warnings;
use strict;
use Carp;

#----------------------------------------------------------------------------

# $terms = $binder->_terms();
# Returns a clone of the current set of terms and values for this binder.
# Used internally to support atomicity in successful binding operations.
#
sub _terms
{
    my $self = shift;
    my $binding = { };
    $binding->{$_} = $self->{terms}{$_} foreach (keys %{$self->{terms}});
    return $binding;
}

=head1 METHODS

=head2 new()

    my $binder = new Data::Binder(city => 'Denver', altitude => 5280);

Create a new binder, optionally with any number of key-value
associations.  Values may be C, which indicate that the key is
present but unbound.

=cut

# $binder = new Data::Binder( 'key' => value, ... );
#
sub new
{
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = { terms => { } };
    bless $self, $class;
    $self->put(@_) if @_;
    return $self;
}

=head2 put()

    $binder->put(population => undef);

Forcefully assert new key-value associations into the binder.  Replaces
any existing value with the given value.  Values may be C, which
indicate that the key is present but unbound.

=cut

# $binder->put( 'key' => value, ... );
#
sub put
{
    my $self = shift;
    carp "arguments not even for term => value pairs" if (@_ % 2);
    while (@_ >= 2)
    {
	my ($term, $value) = (shift, shift);
	$self->{terms}{$term} = $value;
    }
    return $self;
}

=head2 bindable()

    if ( $binder->bindable( city => 'Denver', $another_binder, ... ) )
        { ... }

Check whether all arguments are compatible with existing values in the
binder.  If given another binder reference, that binder's key-value pairs
are tested in an arbitrary order.  Everything else is assumed to be
key-value pairs, and the pairs are tested in the order given; specifying
the least likely bindable pairs first is a useful optimization.

Our C<< term => undef >> can bind with any given C<< term => undef >>.

Our C<< term => undef >> can bind with any given C<< term => value >>.

Our C<< term => value >> can bind with any B given C<< term => value >>.

Our C<< term => value >> cannot bind with a given C<< term => different >>.

If any argument is unbindable, the returned value is C.  If all
arguments are bindable to this binder's pairs, the returned value is not
C.  In no case is any binder actually modified at any time.

=cut

# $bool = $binder->bindable( term => value, ... );
# $bool = $binder->bindable( $other_binder, ... );
#
sub bindable
{
    my $self = shift;
    my $binding = $self->_terms();
    while (@_)
    {
	if (ref $_[0] and ref $_[0]->{terms})
	{
	    my $other = shift;
	    unshift(@_, %{$other->{terms}});
	}
	carp "arguments not even for term => value pairs" if (@_ < 2);
	my ($term, $value) = (shift, shift);
	if (not exists $binding->{$term})
	{ $binding->{$term} = $value; }
	elsif (not defined $binding->{$term})
	{ $binding->{$term} = $value; }
	elsif (ref $value and $binding->{$term} != $value)
	{ return undef; }
	elsif (not ref $value and $binding->{$term} ne $value)
	{ return undef; }
    }
    return $binding;
}

=head2 bind()

    if ( $binder->bind( city => 'Denver', $another_binder, ... ) )
        { ... }

Just as with C<< $binder->bindable( ... ) >>, try to bind all arguments
to this binder's current key-value pairs.

If any argument is unbindable, the returned value is C, and this
binder is left unmodified.  If all arguments are bindable to this
binder's pairs, the returned value is not C, and I given
key-value pairs are asserted into this binder.

=cut

# $bool = $binder->bind( term => value, ... );
#
sub bind
{
    my $self = shift;
    carp "arguments not even for term => value pairs" if (@_ % 2);
    my $binding = $self->bindable(@_);
    return undef if not $binding;
    $self->{terms} = $binding;
    return $self;
}

# $bool = $binder->bound( );
# $bool = $binder->bound( $term );
#
sub bound
{
    my $self = shift;
    my $terms = $self->{terms};
    @_ = (keys %$terms) if not @_;
    foreach (@_)
    { return undef if not defined $terms->{$_}; }
    return $self;
}

#----------------------------------------------------------------------------

1;
__END__