File Coverage

lib/Sub/Contract.pm

Criterion	Covered	Total	%
statement	147	149	98.6
branch	49	62	79.0
condition	27	54	50.0
subroutine	33	33	100.0
pod	16	16	100.0
total	272	314	86.6

#-------------------------------------------------------------------
#
#   Sub::Contract - Programming by contract and memoizing in one
#
#   $Id: Contract.pm,v 1.35 2009/06/16 12:23:57 erwan_lemonnier Exp $
#

package Sub::Contract;

use strict;
use warnings;
use Carp qw(croak confess);
use Data::Dumper;
use Sub::Contract::ArgumentChecks;
use Sub::Contract::Debug qw(debug);
use Sub::Contract::Pool qw(get_contract_pool);
use Symbol;

# Add compiling and memoizing abilities through multiple inheritance, to keep code separate
use base qw( Exporter
	     Sub::Contract::Compiler
	     Sub::Contract::Memoizer );

our @EXPORT = qw();
our @EXPORT_OK = qw( contract
		     undef_or
		     defined_and
                     is_defined_and
                     is_undefined_or
                     is_not
                     is_one_of
                     is_all_of
		     is_a
		     );

our $VERSION = '0.12';

my $pool = Sub::Contract::Pool::get_contract_pool();

# the argument list passed to the contractor
local @Sub::Contract::args;
local $Sub::Contract::wantarray;
local @Sub::Contract::results;

#---------------------------------------------------------------
#
#   contract - declare a contract
#

sub contract {
    croak "contract() expects only one argument, a subroutine name" if (scalar @_ != 1 || !defined $_[0]);
    my $caller = caller;
    return new Sub::Contract($_[0], caller => $caller);
}

#---------------------------------------------------------------
#
#
#   functions to combine constraints
#
#
#---------------------------------------------------------------

sub is_undefined_or {
    croak "is_undefined_or() expects a coderef" if (scalar @_ != 1 || !defined $_[0] || ref $_[0] ne 'CODE');
    my $test = shift;
    return sub {
	return 1 if (!defined $_[0]);
	return &$test(@_);
    };
}

# backward compatibility
*undef_or = *is_undefined_or;

sub is_defined_and {
    croak "is_defined_and() expects a coderef" if (scalar @_ != 1 || !defined $_[0] || ref $_[0] ne 'CODE');
    my $test = shift;
    return sub {
	return 0 if (!defined $_[0]);
	return &$test(@_);
    };
}

# backward compatibility
*defined_and = *is_defined_and;

sub is_not {
    croak "is_not() expects a coderef" if (scalar @_ != 1 || !defined $_[0] || ref $_[0] ne 'CODE');
    my $test = shift;
    return sub {
	return !&$test(@_);
    };
}

sub is_one_of {
    my @tests = @_;
    croak "is_one_of() expects at least two coderefs" if (scalar @tests < 2);
    foreach my $test (@tests) {
	croak "is_one_of() expects only coderefs" if (!defined $test || ref $test ne 'CODE');
    }

    return sub {
	my @args = @_;
	foreach my $test (@tests) {
	    if (&$test(@args)) {
		return 1;
	    }
	}
	return 0;
    };
}

sub is_all_of {
    my @tests = @_;
    croak "is_all_of() expects at least two coderefs" if (scalar @tests < 2);
    foreach my $test (@tests) {
	croak "is_all_of() expects only coderefs" if (!defined $test || ref $test ne 'CODE');
    }

    return sub {
	my @args = @_;
	foreach my $test (@tests) {
	    if (!&$test(@args)) {
		return 0;
	    }
	}
	return 1;
    };
}

sub is_a {
    croak "is_a() expects a package name" if (scalar @_ != 1 || !defined $_[0] || ref $_[0] ne '');
    my $type = shift;
    return sub {
	return 0 if (!defined $_[0]);
	return (ref $_[0] eq $type) ? 1:0;
    };
}

################################################################
#
#
#   Object API
#
#
################################################################

#---------------------------------------------------------------
#
#   new - instantiate a new subroutine contract
#

sub new {
    my ($class,$fullname,%args) = @_;
    $class = ref $class || $class;
    my $caller = delete $args{caller} || caller();

    croak "new() expects a subroutine name as first argument" if (!defined $fullname);
    croak "new() got unknown arguments: ".Dumper(%args) if (keys %args != 0);

    # identify the subroutine to contract and make sure it exists
    my $contractor_cref;
    my $contractor;

    if ($fullname !~ /::/) {
	$contractor_cref = *{ qualify_to_ref($fullname,$caller) }{CODE};
	$contractor = qualify($fullname,$caller);
    } else {
	$contractor_cref = *{ qualify_to_ref($fullname) }{CODE};
	$contractor = qualify($fullname);
    }

    if (!defined $contractor_cref) {
	croak "Can't find subroutine named '".$contractor."'";
    }

    # create instance of contract
    my $self = bless({}, $class);
    $self->{is_enabled}      = 0;                  # 1 if contract is enabled
    $self->{is_memoized}     = 0;                  # TODO: needed?
    $self->{contractor}      = $contractor;        # The fully qualified name of the contracted subroutine
    $self->{contractor_cref} = $contractor_cref;   # A code reference to the contracted subroutine

    $self->reset;

    # add self to the contract pool (if not already in)
    croak "trying to contract function [$contractor] twice"
	if ($pool->has_contract($contractor));

    $pool->_add_contract($self);

    return $self;
}

#---------------------------------------------------------------
#
#   reset - reset all constraints in a contract
#

sub reset {
    my $self = shift;
    $self->{in}          = undef;        # An array of coderefs checking respective input arguments
    $self->{out}         = undef;        # An array of coderefs checking respective return arguments
    $self->{pre}         = undef;        # Coderef checking pre conditions
    $self->{post}        = undef;        # Coderef checking post conditions
    $self->{invariant}   = undef;        # Coderef checking an invariant condition
    if (exists $self->{cache}) {
	$self->{cache}->clear;
	delete $self->{cache};
    }
    return $self;
}

#---------------------------------------------------------------
#
#   in, out - declare conditions for each of the subroutine's in- and out-arguments
#

sub _set_in_out {
    my ($type,$self,@checks) = @_;
    local $Carp::CarpLevel = 2;
    my $validator = new Sub::Contract::ArgumentChecks($type);

    my $pos = 0;

    # check arguments passed in list-style
    while (@checks) {
	my $check = shift @checks;

	if (!defined $check || ref $check eq 'CODE') {
	    # ok
	    $validator->add_list_check($check);
	} elsif (ref $check eq '') {
	    # this is a hash key. we expect hash syntax from there on
	    unshift @checks, $check;
	    last;
	} else {
	    croak "invalid contract definition: argument at position $pos in $type() should be undef or a coderef or a string";
	}
	$pos++;
    }

    # @checks should be either empty or describe hash checks (sequence of string => coderef)
    if (scalar @checks % 2) {
	croak "invalid contract definition: odd number of arguments from position $pos in $type(), can't ".
	    "constrain hash-style passed arguments";
    }

    # check arguments passed in hash-style
    my %known_keys;
    while (@checks) {
	my $key = shift @checks;
	my $check = shift @checks;

	if (defined $key && ref $key eq '') {
	    # is this key defined more than once?
	    if (exists $known_keys{$key}) {
		croak "invalid contract definition: constraining argument \'$key\' twice in $type()";
	    }
	    $known_keys{$key} = 1;

	    # ok with key. verify $check
	    if (!defined $check || ref $check eq 'CODE') {
		# ok
		$validator->add_hash_check($key,$check);
	    } else {
		croak "invalid contract definition: check for \'$key\' should be undef or a coderef in $type()";
	    }
	} else {
	    croak "invalid contract definition: argument at position $pos should be a string in $type()";
	}
	$pos += 2;
    }

    # everything ok!
    $self->{$type} = $validator;
    return $self;
}

sub in   { return _set_in_out('in',@_); }
sub out  { return _set_in_out('out',@_); }

#---------------------------------------------------------------
#
#   pre, post - declare pre and post conditions on subroutine
#

sub _set_pre_post {
    my ($type,$self,$subref) = @_;
    local $Carp::CarpLevel = 2;

    croak "the method $type() expects exactly one argument"
	if (scalar @_ != 3);
    croak "the method $type() expects a code reference as argument"
	if (defined $subref && ref $subref ne 'CODE');

    $self->{$type} = $subref;

    return $self;
}

sub pre  { return _set_pre_post('pre',@_); }
sub post { return _set_pre_post('post',@_); }

#---------------------------------------------------------------
#
#   invariant - adds an invariant condition
#

sub invariant {
    my ($self,$subref) = @_;

    croak "the method invariant() expects exactly one argument"
	if (scalar @_ != 2);
    croak "the method invariant() expects a code reference as argument"
	if (defined $subref && ref $subref ne 'CODE');

    $self->{invariant} = $subref;

    return $self;
}

#---------------------------------------------------------------
#
#   contractor - returns the contractor subroutine's fully qualified name
#

sub contractor {
    return $_[0]->{contractor};
}

#---------------------------------------------------------------
#
#   contractor_cref - return a code ref to the contractor subroutine
#

sub contractor_cref {
    return $_[0]->{contractor_cref};
}


# TODO: implement return?

1;

__END__