File Coverage

blib/lib/Test2/Tools/Ref.pm
Criterion Covered Total %
statement 57 57 100.0
branch 24 24 100.0
condition 3 3 100.0
subroutine 9 9 100.0
pod 3 3 100.0
total 96 96 100.0


line stmt bran cond sub pod time code
1             package Test2::Tools::Ref;
2 154     154   1048 use strict;
  154         331  
  154         4194  
3 154     154   749 use warnings;
  154         281  
  154         6381  
4              
5             our $VERSION = '0.000153';
6              
7 154     154   895 use Scalar::Util qw/reftype refaddr/;
  154         351  
  154         8007  
8 154     154   976 use Test2::API qw/context/;
  154         393  
  154         7245  
9 154     154   1005 use Test2::Util::Ref qw/render_ref/;
  154         429  
  154         9892  
10              
11             our @EXPORT = qw/ref_ok ref_is ref_is_not/;
12 154     154   1003 use base 'Exporter';
  154         354  
  154         90367  
13              
14             sub ref_ok($;$$) {
15 6     6 1 402 my ($thing, $wanttype, $name) = @_;
16 6         13 my $ctx = context();
17              
18 6         397 my $gotname = render_ref($thing);
19 6         10 my $gottype = reftype($thing);
20              
21 6 100       13 if (!$gottype) {
22 2         10 $ctx->ok(0, $name, ["'$gotname' is not a reference"]);
23 2         866 $ctx->release;
24 2         41 return 0;
25             }
26              
27 4 100 100     14 if ($wanttype && $gottype ne $wanttype) {
28 1         6 $ctx->ok(0, $name, ["'$gotname' is not a '$wanttype' reference"]);
29 1         539 $ctx->release;
30 1         22 return 0;
31             }
32              
33 3         8 $ctx->ok(1, $name);
34 3         194 $ctx->release;
35 3         59 return 1;
36             }
37              
38             sub ref_is($$;$@) {
39 20     20 1 428 my ($got, $exp, $name, @diag) = @_;
40 20         328 my $ctx = context();
41              
42 20 100       1561 $got = '' unless defined $got;
43 20 100       42 $exp = '' unless defined $exp;
44              
45 20         175 my $bool = 0;
46 20 100       75 if (!ref($got)) {
    100          
47 2         7 $ctx->ok(0, $name, ["First argument '$got' is not a reference", @diag]);
48             }
49             elsif(!ref($exp)) {
50 2         7 $ctx->ok(0, $name, ["Second argument '$exp' is not a reference", @diag]);
51             }
52             else {
53             # Don't let overloading mess with us.
54 16         57 $bool = refaddr($got) == refaddr($exp);
55 16         105 $ctx->ok($bool, $name, ["'$got' is not the same reference as '$exp'", @diag]);
56             }
57              
58 20         4677 $ctx->release;
59 20 100       522 return $bool ? 1 : 0;
60             }
61              
62             sub ref_is_not($$;$) {
63 6     6 1 89 my ($got, $exp, $name, @diag) = @_;
64 6         13 my $ctx = context();
65              
66 6 100       382 $got = '' unless defined $got;
67 6 100       10 $exp = '' unless defined $exp;
68              
69 6         9 my $bool = 0;
70 6 100       16 if (!ref($got)) {
    100          
71 2         15 $ctx->ok(0, $name, ["First argument '$got' is not a reference", @diag]);
72             }
73             elsif(!ref($exp)) {
74 2         8 $ctx->ok(0, $name, ["Second argument '$exp' is not a reference", @diag]);
75             }
76             else {
77             # Don't let overloading mess with us.
78 2         5 $bool = refaddr($got) != refaddr($exp);
79 2         11 $ctx->ok($bool, $name, ["'$got' is the same reference as '$exp'", @diag]);
80             }
81              
82 6         2177 $ctx->release;
83 6 100       127 return $bool ? 1 : 0;
84             }
85              
86             1;
87              
88             __END__