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


line stmt bran cond sub pod time code
1 1     1   6 use strict;
  1         3  
  1         26  
2 1     1   4 use warnings;
  1         2  
  1         34  
3             package Data::Rx::Type::Perl::Ref 0.010;
4             # ABSTRACT: experimental / perl reference type
5 1     1   4 use parent 'Data::Rx::CommonType::EasyNew';
  1         2  
  1         4  
6              
7             #pod =head1 SYNOPSIS
8             #pod
9             #pod use Data::Rx;
10             #pod use Data::Rx::Type::Perl::Ref;
11             #pod use Test::More tests => 2;
12             #pod
13             #pod my $rx = Data::Rx->new({
14             #pod prefix => {
15             #pod perl => 'tag:codesimply.com,2008:rx/perl/',
16             #pod },
17             #pod type_plugins => [ 'Data::Rx::Type::Perl::Ref' ]
18             #pod });
19             #pod
20             #pod my $int_ref_rx = $rx->make_schema({
21             #pod type => '/perl/ref',
22             #pod referent => '//int',
23             #pod });
24             #pod
25             #pod ok( $int_ref_rx->check( 1 ), "1 is not a ref to an integer");
26             #pod ok(! $int_ref_rx->check( \1 ), "\1 is a ref to an integer");
27             #pod
28             #pod =head1 ARGUMENTS
29             #pod
30             #pod "referent" indicates another type to which the reference must refer.
31             #pod
32             #pod =cut
33              
34 1     1   51 use Carp ();
  1         1  
  1         21  
35 1     1   5 use Scalar::Util ();
  1         2  
  1         281  
36              
37 1     1 0 16 sub type_uri { 'tag:codesimply.com,2008:rx/perl/ref' }
38              
39             sub guts_from_arg {
40 3     3 0 1284 my ($class, $arg, $rx) = @_;
41 3   50     8 $arg ||= {};
42              
43 3         8 for my $key (keys %$arg) {
44 3 50       10 next if $key eq 'referent';
45 0         0 Carp::croak(
46             "unknown argument $key in constructing " . $class->type_uri . " type",
47             );
48             }
49              
50 3         5 my $guts = { };
51              
52 3 50       7 if ($arg->{referent}) {
53 3         11 my $ref_checker = $rx->make_schema($arg->{referent});
54              
55 3         147 $guts->{referent} = $ref_checker;
56             }
57              
58 3         5 return $guts;
59             }
60              
61             sub assert_valid {
62 11     11 0 1460 my ($self, $value) = @_;
63              
64 11 100 100     58 unless (ref $value and (ref $value eq 'REF' or ref $value eq 'SCALAR')) {
      100        
65 3         15 $self->fail({
66             error => [ qw(type) ],
67             message => "found value is not a scalar reference",
68             value => $value,
69             });
70             }
71              
72 8 50       19 if ($self->{referent}) {
73             $self->perform_subchecks([
74             [
75             $$value,
76             $self->{referent},
77             {
78 8     1   72 data_path => [ [ 'scalar_deref', 'deref', sub { "\${$_[0]}" } ] ],
  1         213  
79             check_path => [ [ 'referent', 'key' ] ],
80             },
81             ],
82             ]);
83             }
84              
85 5         187 return 1;
86             }
87              
88             1;
89              
90             __END__