File Coverage

blib/lib/Data/Rx/Type/Perl/Obj.pm

Criterion	Covered	Total	%
statement	29	32	90.6
branch	6	8	75.0
condition	5	11	45.4
subroutine	8	8	100.0
pod	0	3	0.0
total	48	62	77.4

use strict;
use warnings;
package Data::Rx::Type::Perl::Obj 0.010;
# ABSTRACT: experimental / perl object type
use parent 'Data::Rx::CommonType::EasyNew';

#pod =head1 SYNOPSIS
#pod
#pod   use Data::Rx;
#pod   use Data::Rx::Type::Perl::Obj;
#pod   use Test::More tests => 2;
#pod
#pod   my $rx = Data::Rx->new({
#pod     prefix  => {
#pod       perl => 'tag:codesimply.com,2008:rx/perl/',
#pod     },
#pod     type_plugins => [ 'Data::Rx::Type::Perl::Obj' ]
#pod   });
#pod
#pod   my $isa_rx = $rx->make_schema({
#pod     type       => '/perl/obj',
#pod     isa        => 'Data::Rx',
#pod   });
#pod
#pod   ok($isa_rx->check($rx),   "a Data::Rx object isa Data::Rx /perl/obj");
#pod   ok(! $isa_rx->check( 1 ), "1 is not a Data::Rx /perl/obj");
#pod
#pod =head1 ARGUMENTS
#pod
#pod "isa" and "does" ensure that the object passes the relevant test for the
#pod identifier given.
#pod
#pod =cut

use Carp ();
use Scalar::Util ();

sub type_uri { 'tag:codesimply.com,2008:rx/perl/obj' }

sub guts_from_arg {
  my ($class, $arg, $rx, $type) = @_;
  $arg ||= {};

  for my $key (keys %$arg) {
    next if $key eq 'isa' or $key eq 'does';
    Carp::croak(
      "unknown argument $key in constructing " . $class->type_uri .  " type",
    );
  }

  return {
    isa  => $arg->{isa},
    does => $arg->{does},
  };
}

sub assert_valid {
  my ($self, $value) = @_;

  unless (Scalar::Util::blessed($value)) {
    $self->fail({
      error   => [ qw(type) ],
      message => "found value is not blessed",
      value   => $value,
    });
  }

  if (defined $self->{isa} and not eval { $value->isa($self->{isa}) }) {
    $self->fail({
      error   => [ qw(isa) ],
      message => "found value is not isa $self->{isa}",
      value   => $value,
    });
  }

  if (defined $self->{does} and not eval { $value->DOES($self->{does}) }) {
    $self->fail({
      error   => [ qw(does) ],
      message => "found value does not do role $self->{does}",
      value   => $value,
    });
  }

  return 1;
}

1;

__END__