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__ |