File Coverage

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

Criterion	Covered	Total	%
statement	32	33	96.9
branch	5	8	62.5
condition	7	8	87.5
subroutine	9	9	100.0
pod	0	3	0.0
total	53	61	86.8

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

#pod =head1 SYNOPSIS
#pod
#pod   use Data::Rx;
#pod   use Data::Rx::Type::Perl::Ref;
#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::Ref' ]
#pod   });
#pod
#pod   my $int_ref_rx = $rx->make_schema({
#pod     type       => '/perl/ref',
#pod     referent   => '//int',
#pod   });
#pod
#pod   ok(  $int_ref_rx->check(  1 ), "1 is not a ref to an integer");
#pod   ok(! $int_ref_rx->check( \1 ), "\1 is a ref to an integer");
#pod
#pod =head1 ARGUMENTS
#pod
#pod "referent" indicates another type to which the reference must refer.
#pod
#pod =cut

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

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

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

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

  my $guts = { };

  if ($arg->{referent}) {
    my $ref_checker = $rx->make_schema($arg->{referent});

    $guts->{referent} = $ref_checker;
  }

  return $guts;
}

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

  unless (ref $value and (ref $value eq 'REF' or ref $value eq 'SCALAR')) {
    $self->fail({
      error   => [ qw(type) ],
      message => "found value is not a scalar reference",
      value   => $value,
    });
  }

  if ($self->{referent}) {
    $self->perform_subchecks([
      [
        $$value,
        $self->{referent},
        {
          data_path  => [ [ 'scalar_deref', 'deref', sub { "\${$_[0]}" } ] ],
          check_path => [ [ 'referent', 'key' ] ],
        },
      ],
    ]);
  }

  return 1;
}

1;

__END__