File Coverage

blib/lib/Test/Weaken/ExtraBits.pm
Criterion Covered Total %
statement 30 43 69.7
branch 7 12 58.3
condition 4 12 33.3
subroutine 7 10 70.0
pod 5 5 100.0
total 53 82 64.6


line stmt bran cond sub pod time code
1             # Copyright 2008, 2009, 2010, 2011, 2012, 2015 Kevin Ryde
2              
3             # This file is part of Test-VariousBits.
4             #
5             # Test-VariousBits is free software; you can redistribute it and/or
6             # modify it under the terms of the GNU General Public License as published
7             # by the Free Software Foundation; either version 3, or (at your option) any
8             # later version.
9             #
10             # Test-VariousBits is distributed in the hope that it will be useful,
11             # but WITHOUT ANY WARRANTY; without even the implied warranty of
12             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
13             # Public License for more details.
14             #
15             # You should have received a copy of the GNU General Public License along
16             # with Test-VariousBits. If not, see .
17              
18             package Test::Weaken::ExtraBits;
19 1     1   67917 use 5.004;
  1         4  
  1         48  
20 1     1   6 use strict;
  1         2  
  1         41  
21              
22 1     1   7 use vars '$VERSION', '@ISA', '@EXPORT_OK';
  1         7  
  1         83  
23             $VERSION = 5;
24              
25 1     1   6 use Exporter;
  1         2  
  1         78  
26             @ISA = ('Exporter');
27             @EXPORT_OK = qw(
28             contents_glob_IO
29             ignore_Class_Singleton
30             ignore_DBI_globals
31             ignore_global_functions
32             ignore_functions
33             );
34              
35 1     1   7 use constant DEBUG => 0;
  1         1  
  1         579  
36              
37             #------------------------------------------------------------------------------
38             sub contents_glob_IO {
39 0     0 1 0 my ($ref) = @_;
40 0 0       0 ref($ref) eq 'GLOB' || return;
41 0         0 return *$ref{IO};
42             }
43              
44             #------------------------------------------------------------------------------
45              
46             sub ignore_Class_Singleton {
47 0     0 1 0 my ($ref) = @_;
48 0         0 my $class;
49 0         0 require Scalar::Util;
50 0   0     0 return (($class = Scalar::Util::blessed($ref))
51             && $ref->isa('Class::Singleton')
52             && $class->has_instance
53             && $class->instance == $ref);
54             }
55              
56             sub ignore_DBI_globals {
57 0     0 1 0 my ($ref) = @_;
58 0         0 require Scalar::Util;
59              
60 0 0 0     0 if (Scalar::Util::blessed($ref)
61             && $ref->isa('DBI::dr')) {
62 0         0 if (DEBUG) { Test::More::diag ("ignore DBI::dr object -- $ref\n"); }
63 0         0 return 1;
64             }
65              
66 0         0 return 0;
67             }
68              
69             sub ignore_global_functions {
70 7     7 1 645 my ($ref) = @_;
71 7 100       26 ref $ref eq 'CODE' or return;
72              
73             # could use Sub::Identify, but B comes with perl already
74 4         18 require B;
75 4         16 my $cv = B::svref_2object($ref);
76 4         13 my $gv = $cv->GV;
77             # as per Sub::Identify, for some sort of undefined GV
78 4 50       20 return if $gv->isa('B::SPECIAL');
79              
80 4         24 my $fullname = $gv->STASH->NAME . '::' . $gv->NAME;
81             # Test::More::diag "ignore_global_functions() fullname $fullname";
82              
83 4   66     35 return (defined &$fullname && $ref == \&$fullname);
84             }
85             # require Sub::Identify;
86             # my $fullname = Sub::Identify::sub_fullname ($ref);
87             # return (defined &$fullname
88             # && $ref == \&$fullname);
89              
90             sub ignore_functions {
91 9     9 1 10 my $ref = shift;
92 9 100       25 ref $ref eq 'CODE' or return;
93              
94 6         10 while (@_) {
95 8         9 my $funcname = shift;
96 8 100 66     38 if (defined &$funcname && $ref == \&$funcname) {
97 4         15 return 1;
98             }
99             }
100 2         8 return 0;
101             }
102              
103             #------------------------------------------------------------------------------
104             # =item C<$bool = Test::Weaken::ExtraBits::contents_glob ($ref)>
105             #
106             # If C<$ref> is a globref then return the contents of all of its slots,
107             # which means refs to
108             #
109             # SCALAR ARRAY HASH CODE IO GLOB FORMAT
110             #
111             # C, as of version 3.006, doesn't descend into globs. This
112             # contents func can be used if that's desired. Usually
113             #
114             # sub contents_glob {
115             # my ($ref) = @_;
116             # if (ref $ref eq 'GLOB') {
117             # return map {*$ref{$_}} qw(SCALAR ARRAY HASH CODE IO GLOB FORMAT);
118             # } else {
119             # return;
120             # }
121             # }
122              
123             # =item C<$bool = ignore_module_functions ($ref, $module, $module, ...)>
124             #
125             # Return true if C<$ref> is a coderef to any function in any of the given
126             # modules.
127             #
128             # Each C<$module> is a string like C. If a module doesn't exist
129             # then it's skipped, so it doesn't matter if the C package is
130             # actually loaded yet.
131             #
132             # sub ignore_module_functions {
133             # my $ref = shift;
134             # ref $ref eq 'CODE' or return;
135             #
136             # while (@_) {
137             # my $module = shift;
138             # my $symtabname = "${module}::";
139             # no strict 'refs';
140             # %$symtabname or next;
141             # foreach my $name (keys %$symtabname) {
142             # my $fullname = "${module}::$name";
143             # if (defined &$fullname && $ref == \&$fullname) {
144             # return 1;
145             # }
146             # }
147             # }
148             # return 0;
149             # }
150              
151             1;
152             __END__