File Coverage

blib/lib/Data/Predicate/Predicates.pm

Criterion	Covered	Total	%
statement	90	90	100.0
branch	38	38	100.0
condition	12	12	100.0
subroutine	33	33	100.0
pod	16	16	100.0
total	189	189	100.0

package Data::Predicate::Predicates;

use strict;
use warnings;

use Data::Predicate::ClosurePredicate;
use Scalar::Util qw(blessed looks_like_number);
use Readonly;
use base 'Exporter';

our @EXPORT_OK = qw(
  p_and
  p_or
  p_not
  p_always_true
  p_always_false
  p_undef
  p_defined
  p_blessed
  p_is_number
  p_ref_type
  p_isa
  p_can
  p_numeric_equals
  p_string_equals
  p_regex
  p_substring
);
our %EXPORT_TAGS = (
  all      => [@EXPORT_OK],
  logic    => [qw(p_and p_or p_not)],
  defaults => [qw(p_always_true p_always_false)],
  tests    => [qw(p_defined p_undef p_blessed p_is_number p_ref_type
                  p_isa p_can p_numeric_equals p_string_equals
                  p_regex p_substring)],
);

#Set of predicates which never change so we build once & cache; others may & do
Readonly::Hash my %STATIC_PREDICATES => (
  'true'  => Data::Predicate::ClosurePredicate->new(
    closure => sub { 1 } ,
    description => 'true'
  ),
  'false' => Data::Predicate::ClosurePredicate->new(
    closure => sub { 0 },
    description => 'false'
  ),
  'defined' => Data::Predicate::ClosurePredicate->new(
    closure => sub {
      my ($object) = @_;
      return ( defined $object ) ? 1 : 0;
    },
    description => 'defined'
  ),
  'undef' => Data::Predicate::ClosurePredicate->new(
    closure => sub {
      my ($object) = @_;
      return ( defined $object ) ? 0 : 1;
    },
    description => 'undef'
  ),
  'blessed' => Data::Predicate::ClosurePredicate->new(
    closure => sub {
      my ($object) = @_;
      return ( blessed($object) ) ? 1 : 0;
    },
    description => 'blessed'
  ),
  'number' => Data::Predicate::ClosurePredicate->new(
    closure => sub {
      my ($object) = @_;
      return ( defined $object && looks_like_number($object) ) ? 1 : 0;
    },
    description => 'number'
  )
);

sub p_and {
  my ( @predicates ) = @_;
  return Data::Predicate::ClosurePredicate->new(
    closure => sub {
      my ($object) = @_;
      foreach my $pred (@predicates) {
        if(!$pred->apply($object)) {
          return 0;
        }
      }
      return 1;
    },
    description => 'and'
  );
}

sub p_or {
  my ( @predicates ) = @_;
  return Data::Predicate::ClosurePredicate->new(
    closure => sub {
      my ($object) = @_;
      foreach my $pred (@predicates) {
        if($pred->apply($object)) {
          return 1;
        }
      }
      return 0;
    },
    description => 'or'
  );
}

sub p_not {
  my ($predicate) = @_;
  return Data::Predicate::ClosurePredicate->new(
    closure => sub {
      my ($object) = @_;
      return ($predicate->apply($object)) ? 0 : 1;
    },
    description => 'not'
  );
}

sub p_always_true {
  return $STATIC_PREDICATES{'true'};
}

sub p_always_false {
  return $STATIC_PREDICATES{'false'};
}

sub p_defined {
  return $STATIC_PREDICATES{'defined'};
}

sub p_undef {
  return $STATIC_PREDICATES{'undef'};
}

sub p_blessed {
  return $STATIC_PREDICATES{'blessed'};
}

sub p_is_number {
  return $STATIC_PREDICATES{'number'};
}

sub p_ref_type {
  my ($ref_type) = @_;
  return Data::Predicate::ClosurePredicate->new(
    closure => sub {
      my ($object) = @_;
      my $ref = ref($object);
      return 0 unless $ref;
      return ( $ref eq $ref_type ) ? 1 : 0;
    },
    description => 'ref_type predicate with type '.$ref_type
  );
}

sub p_isa {
  my ($isa) = @_;
  return Data::Predicate::ClosurePredicate->new(
    closure => sub {
      my ($object) = @_;
      return 0 unless p_blessed()->apply($object);
      return ( $object->isa($isa) ) ? 1 : 0;
    },
    description => 'isa predicate with type '.$isa
  );
}

sub p_can {
  my ($method) = @_;
  return Data::Predicate::ClosurePredicate->new(
    closure => sub {
      my ($object) = @_;
      return 0 unless p_blessed()->apply($object);
      return ( $object->can($method) ) ? 1 : 0;
    },
    description => 'Can predicate with method '.$method
  );
}

sub p_string_equals {
  my ($str, $method) = @_;
  my $target = (defined $method) ? "against method ${method}" : 'against values';
  return Data::Predicate::ClosurePredicate->new(
    closure => sub {
      my ($object) = @_;
      my $val = _invoke($object, $method);
      return ( p_defined->apply($val) && $val eq $str ) ? 1 : 0;
    },
    description => "String equals predicate $target with number $str"
  );
}

sub p_numeric_equals {
  my ($number, $method) = @_;
  my $target = (defined $method) ? "against method ${method}" : 'against values';
  return Data::Predicate::ClosurePredicate->new(
    closure => sub {
      my ($object) = @_;
      my $val = _invoke($object, $method);
      return ( p_is_number->apply($val) && $val == $number ) ? 1 : 0;
    },
    description => "Numeric equals predicate $target with number $number"
  );
}

sub p_regex {
  my ($regex, $method) = @_;
  my $target = (defined $method) ? "against method ${method}" : 'against values';
  return Data::Predicate::ClosurePredicate->new(
    closure => sub {
      my ($object) = @_;
      my $val = _invoke($object, $method);
      return ( p_defined->apply($val) && $val =~ $regex) ? 1 : 0;
    },
    description => "Regular expression predicate $target with regex $regex"
  );
}

sub p_substring {
  my ($substring, $method) = @_;
  my $target = (defined $method) ? "against method ${method}" : 'against values';
  return Data::Predicate::ClosurePredicate->new(
    closure => sub {
      my ($object) = @_;
      my $val = _invoke($object, $method);
      return ( p_defined->apply($val) && index($val, $substring) > -1) ? 1 : 0;
    },
    description => "Substring predicate $target with substring $substring"
  );
}

sub _invoke {
  my ($object, $method) = @_;
  my $val;
  if($method) {
    if(p_can($method)->apply($object)) {
      $val = $object->can($method)->($object);
    }
    else {
      confess("Cannot call the method '${method}' on the given object ${object}");
    }
  }
  else {
    $val = $object;
  }
  return $val;
}

1;
__END__