File Coverage

blib/lib/Devel/Unplug.pm

Criterion	Covered	Total	%
statement	36	36	100.0
branch	12	12	100.0
condition	5	6	83.3
subroutine	11	11	100.0
pod	3	3	100.0
total	67	68	98.5

package Devel::Unplug;

use warnings;
use strict;

=head1 NAME

Devel::Unplug - Simulate the non-availability of modules

=head1 VERSION

This document describes Devel::Unplug version 0.03

=cut

use vars qw($VERSION @ISA);

$VERSION = '0.03';

=head1 SYNOPSIS

    $ perl -d:Unplug=Some::Module,Some::Other::Module myprog.pl
    Can't locate Some/Module.pm in @INC (unplugged by Devel::Unplug) at myprog.pl line 5.
    BEGIN failed--compilation aborted at myprog.pl line 5.

=head1 DESCRIPTION

Sometimes - particularly during testing - it's useful to be able to find
out how your code behaves when a module it is expecting is unavailable.
This module allows you to simulate the non-availability of a module.

It uses L to replace C (and hence
C) and intercept attempts to load modules.

=cut

sub _get_module {
    my $file = shift;
    $file =~ s{/}{::}g;
    $file =~ s/[.]pm$//;
    return $file;
}

my %unplugged;

sub _is_unplugged {
    my $module = shift;

    for my $unp ( unplugged() ) {
        return 1
          if ( 'Regexp' eq ref $unp )
          ? $module =~ $unp
          : $module eq $unp;
    }

    return;
}

=head1 INTERFACE

None of these functions are exportable. Call them using their fully qualified names.

=head2 C<< unplug >>

Unplug one or more modules.

    Devel::Unplug::unplug( 'Some::Module', 'Some::Other::Module' );

Regular expressions may be used:

    Devel::Unplug::unplug( qr{^Some:: (?: Other:: )? Module$}x );

=cut

sub unplug {
    for my $unp ( @_ ) {
        exists $unplugged{$unp} and $unplugged{$unp}->[1]++
          or $unplugged{$unp} = [ $unp, 1 ];
    }
    return;
}

=head2 C<< insert >>

Make an unplugged module available again.

    Devel::Unplug::insert( 'Some::Module' );

You must call C for a given module as many times as C
was called to make it available again.

=cut

sub insert {
    for my $mod ( @_ ) {
        delete $unplugged{$mod}
          if exists $unplugged{$mod} && 0 == --$unplugged{$mod}->[1];
    }
    return;
}

BEGIN {
    use Devel::TraceLoad::Hook qw( register_require_hook );
    register_require_hook(
        sub {
            my ( $when, $depth, $arg, $p, $f, $l, $rc, $err ) = @_;

            return unless $when eq 'before';
            my $module = _get_module( $arg );
            return unless _is_unplugged( $module );

            # Ain't gonna let you load it
            die "Can't locate $arg in \@INC (unplugged by " . __PACKAGE__ . ")";
        }
    );
}

=head2 C<< unplugged >>

Get the list of unplugged modules. The returned array may potentially
contain a mixture of regular expressions and plain strings.

=cut

sub unplugged {
    map { $_->[0] } values %unplugged;
}

sub import {
    my $class = shift;
    unplug( @_ );
}

1;
__END__