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

# Copyright 2008, 2009, 2010, 2011, 2012, 2015 Kevin Ryde

# This file is part of Test-VariousBits.
#
# Test-VariousBits is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as published
# by the Free Software Foundation; either version 3, or (at your option) any
# later version.
#
# Test-VariousBits is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General
# Public License for more details.
#
# You should have received a copy of the GNU General Public License along
# with Test-VariousBits.  If not, see .

package Test::Weaken::ExtraBits;
use 5.004;
use strict;

use vars '$VERSION', '@ISA', '@EXPORT_OK';
$VERSION = 5;

use Exporter;
@ISA = ('Exporter');
@EXPORT_OK = qw(
                 contents_glob_IO
                 ignore_Class_Singleton
                 ignore_DBI_globals
                 ignore_global_functions
                 ignore_functions
              );

use constant DEBUG => 0;

#------------------------------------------------------------------------------
sub contents_glob_IO {
  my ($ref) = @_;
  ref($ref) eq 'GLOB' || return;
  return *$ref{IO};
}

#------------------------------------------------------------------------------

sub ignore_Class_Singleton {
  my ($ref) = @_;
  my $class;
  require Scalar::Util;
  return (($class = Scalar::Util::blessed($ref))
          && $ref->isa('Class::Singleton')
          && $class->has_instance
          && $class->instance == $ref);
}

sub ignore_DBI_globals {
  my ($ref) = @_;
  require Scalar::Util;

  if (Scalar::Util::blessed($ref)
      && $ref->isa('DBI::dr')) {
    if (DEBUG) { Test::More::diag ("ignore DBI::dr object -- $ref\n"); }
    return 1;
  }

  return 0;
}

sub ignore_global_functions {
  my ($ref) = @_;
  ref $ref eq 'CODE' or return;

  # could use Sub::Identify, but B comes with perl already
  require B;
  my $cv = B::svref_2object($ref);
  my $gv = $cv->GV;
  # as per Sub::Identify, for some sort of undefined GV
  return if $gv->isa('B::SPECIAL');

  my $fullname = $gv->STASH->NAME . '::' . $gv->NAME;
  # Test::More::diag "ignore_global_functions() fullname $fullname";

  return (defined &$fullname && $ref == \&$fullname);
}
#   require Sub::Identify;
#   my $fullname = Sub::Identify::sub_fullname ($ref);
#   return (defined &$fullname
#           && $ref == \&$fullname);

sub ignore_functions {
  my $ref = shift;
  ref $ref eq 'CODE' or return;

  while (@_) {
    my $funcname = shift;
    if (defined &$funcname && $ref == \&$funcname) {
      return 1;
    }
  }
  return 0;
}

#------------------------------------------------------------------------------
# =item C<$bool = Test::Weaken::ExtraBits::contents_glob ($ref)>
#
# If C<$ref> is a globref then return the contents of all of its slots,
# which means refs to
#
#     SCALAR ARRAY HASH CODE IO GLOB FORMAT
#
# C, as of version 3.006, doesn't descend into globs.  This
# contents func can be used if that's desired.  Usually
#
# sub contents_glob {
#   my ($ref) = @_;
#   if (ref $ref eq 'GLOB') {
#     return map {*$ref{$_}} qw(SCALAR ARRAY HASH CODE IO GLOB FORMAT);
#   } else {
#     return;
#   }
# }

# =item C<$bool = ignore_module_functions ($ref, $module, $module, ...)>
#
# Return true if C<$ref> is a coderef to any function in any of the given
# modules.
#
# Each C<$module> is a string like C.  If a module doesn't exist
# then it's skipped, so it doesn't matter if the C package is
# actually loaded yet.
#
# sub ignore_module_functions {
#   my $ref = shift;
#   ref $ref eq 'CODE' or return;
#
#   while (@_) {
#     my $module = shift;
#     my $symtabname = "${module}::";
#     no strict 'refs';
#     %$symtabname or next;
#     foreach my $name (keys %$symtabname) {
#       my $fullname = "${module}::$name";
#       if (defined &$fullname && $ref == \&$fullname) {
#         return 1;
#       }
#     }
#   }
#   return 0;
# }

1;
__END__