init

dist.ini

@@ -0,0 +1,7 @@
+name             = DB-Skip
+author           = Christian Walde <walde.christian@googlemail.com>
+license          = WTFPL_2
+copyright_holder = Christian Walde
+copyright_year   = 2011
+
+[@DAGOLDEN]

lib/DB/Skip.pm

@@ -0,0 +1,51 @@
+package DB::Skip;
+
+use strict;
+use warnings;
+
+my $old_db;
+
+sub import {
+    my ( $class, %opts ) = @_;
+
+    $opts{$_} ||= [] for qw( pkgs subs );
+
+    my @pkg_regex = grep { ref and ref eq "Regexp" } @{ $opts{pkgs} };
+    my @sub_regex = grep { ref and ref eq "Regexp" } @{ $opts{subs} };
+
+    my %pkg_skip = map { $_ => 1 } grep { !ref } @{ $opts{pkgs} };
+    my %sub_skip = map { $_ => 1 } grep { !ref } @{ $opts{subs} };
+
+    $old_db ||= \&DB::DB;
+
+    my $new_DB = sub {
+        my $lvl = 0;
+        while ( my ( $pkg ) = caller( $lvl++ ) ) {
+            return if $pkg eq "DB" or $pkg =~ /^DB::/;
+        }
+
+        my ( $pkg ) = caller;
+        return if $pkg_skip{$pkg};
+
+        my ( undef, undef, undef, $sub ) = caller( 1 );
+        return if $sub and $sub_skip{$sub};
+
+        for my $pkg_re ( @pkg_regex ) {
+            return if $pkg =~ $pkg_re;
+        }
+
+        for my $sub_re ( @sub_regex ) {
+            return if $sub =~ $sub_re;
+        }
+
+        goto &{$old_db};
+    };
+
+    {
+        no warnings 'redefine';
+        *DB::DB = $new_DB;
+    }
+
+    return;
+}
+1;

t/basic.t

@@ -0,0 +1,22 @@
+use strict;
+use warnings;
+
+use Test::InDistDir;
+
+use Capture::Tiny 'capture';
+
+use Test::More;
+
+my @includes = map { "-I$_" } @INC;
+my ( $out, $err, $res ) = capture {
+    system( $^X, @includes, "-It/lib", "-d:Caller", "t/bin/example.pl" );
+};
+
+unlike $out, qr/main::meep/, "main::meep is skipped";
+unlike $out, qr/Marp::meep/, "Marp::meep is skipped";
+unlike $out, qr/Moop::meep/, "Moop::meep is skipped";
+like $out, qr/main::marp/, "main::marp is not skipped";
+is $err, "", "no errors";
+is $res, undef, "script didn't crash";
+
+done_testing;

t/bin/example.pl

@@ -0,0 +1,36 @@
+use strict;
+use warnings;
+
+use DB::Skip pkgs => [ qw( Marp ), qr/^Mo/ ], subs => [qw( main::meep )];
+
+my $meep = meep();
+print $meep;
+$meep = Marp::meep();
+print $meep;
+$meep = Moop::meep();
+print $meep;
+$meep = Moop::meep();
+print $meep;
+$meep = marp();
+print $meep;
+exit;
+
+sub meep {
+    return 1;
+}
+
+sub marp {
+    return 4;
+}
+
+package Marp;
+
+sub meep {
+    return 2;
+}
+
+package Moop;
+
+sub meep {
+    return 3;
+}

t/lib/Devel/Caller.pm

@@ -0,0 +1,11 @@
+use strict;
+use warnings;
+
+package DB;
+
+sub DB {
+    my @caller = ( caller, ( caller( 1 ) )[3] );
+    print "@caller\n";
+}
+
+1;