File Coverage

blib/lib/Data/Structure/Util.pm
Criterion Covered Total %
statement 34 34 100.0
branch 15 20 75.0
condition n/a
subroutine 17 17 100.0
pod 9 9 100.0
total 75 80 93.7


line stmt bran cond sub pod time code
1             package Data::Structure::Util;
2              
3 7     7   32695 use 5.008;
  7         22  
  7         248  
4              
5 7     7   33 use strict;
  7         10  
  7         236  
6 7     7   34 use warnings::register;
  7         11  
  7         1128  
7 7     7   33 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
  7         14  
  7         234822  
8 7     7   6738 use Storable qw( freeze );
  7         28622  
  7         520  
9 7     7   54 use Digest::MD5 qw( md5_hex );
  7         14  
  7         5143  
10              
11             require Exporter;
12             require DynaLoader;
13             require AutoLoader;
14              
15             @ISA = qw( Exporter DynaLoader );
16              
17             $VERSION = '0.15';
18              
19             @EXPORT_OK = qw(
20             unbless get_blessed get_refs has_circular_ref circular_off signature
21             );
22              
23             if ( $] >= 5.008 ) {
24             push @EXPORT_OK, qw(
25             has_utf8 utf8_off utf8_on _utf8_on _utf8_off
26             );
27             }
28              
29             bootstrap Data::Structure::Util $VERSION;
30              
31             sub has_utf8 {
32 9 100   9 1 313 has_utf8_xs( $_[0] ) ? $_[0] : undef;
33             }
34              
35             sub utf8_off {
36 4 50   4 1 1085 utf8_off_xs( $_[0] ) ? $_[0] : undef;
37             }
38              
39             sub utf8_on {
40 5 50   5 1 24024 utf8_on_xs( $_[0] ) ? $_[0] : undef;
41             }
42              
43             sub _utf8_off {
44 2 50   2   38 _utf8_off_xs( $_[0] ) ? $_[0] : undef;
45             }
46              
47             sub _utf8_on {
48 1 50   1   11 _utf8_on_xs( $_[0] ) ? $_[0] : undef;
49             }
50              
51             sub unbless {
52 2     2 1 1382 unbless_xs( $_[0] );
53             }
54              
55             sub get_blessed {
56 5 100   5 1 444 $_[0] or return [];
57 3         54 get_blessed_xs( $_[0] );
58             }
59              
60             sub get_refs {
61 5 100   5 1 4103 $_[0] or return [];
62 3         52 get_refs_xs( $_[0] );
63             }
64              
65             sub has_circular_ref {
66 33 100   33 1 4694 $_[0] or return $_[0];
67 31         1552 has_circular_ref_xs( $_[0] );
68             }
69              
70             # Need to hold another reference to the passed in value to avoid this
71             # pathological case throwing an error
72             # my $obj8 = [];
73             # $obj8->[0] = \$obj8;
74             # circular_off($obj8); # Used to throw an error
75              
76             sub circular_off {
77 13     13 1 409 my $r = $_[0];
78 13 50       39 $r or return $r;
79 13         570 circular_off_xs( $r );
80             }
81              
82             sub signature {
83             return @_
84 19 100   19 1 6345 ? md5_hex( freeze( [ $_[0], signature_xs( $_[0] ) ] ) )
85             : '0' x 32;
86             }
87              
88             1;
89              
90             __END__