{
    package Naughty;
    use base 'Exporter';
    our @EXPORT = 'some_func';
    sub some_func { 'naughty function.  no biscuit' }
}

{
    package Unsuspecting;
    Naughty->import;
    sub new { bless {}, shift }
    sub _private { 'Unsuspecting _private' }
}

if ( Unsuspecting->can('some_func') ) {
  die "a horrible death";
}
elsif ( Unsuspecting->can('_private') ) {
  die "Don't rely on private methods!";
}
else {
  print "home free";
}

##</code><code>##

package strict::can;

use warnings;
use strict;
use vars qw( $VERSION );
use B qw/svref_2object/;
use base 'Exporter';
our @EXPORT = qw(can);

my $package_for = sub {
    my $package;
    eval {
        my $stash = svref_2object(shift)->STASH;
        if ( $stash && $stash->can('NAME') ) {
            $package = $stash->NAME;
        }
        else {
            $package = '';
        }
    };
    if ($@) {
        warn "Could not determine calling package: $@";
    }
    return $package;
};

sub can {
    my ( $proto, $method ) = @_;

    return if '_' eq substr $method, 0, 1;
    my $class = ref $proto || $proto;
    if ( my $code = $proto->SUPER::can($method) ) {
        my $code_package = $package_for->($code);
        if ( $code_package eq $class || $class->isa($code_package) ) {
            return $code;
        }
        else {
            return;
        }
    }
    return;
}

1;

##</code><code>##

#!perl

#use Test::More tests => 1;
use Test::More qw/no_plan/;

BEGIN {
    chdir 't' if -d 't';
    unshift @INC, '../lib';
}

{
    package Naughty;
    use base 'Exporter';
    our @EXPORT = 'some_func';
    sub some_func { 'naughty function.  no biscuit' }
}

{
    package Unsuspecting;
    use strict::can;
    Naughty->import;
    sub new { bless {}, shift }
    sub _private { 'Unsuspecting _private' }
}

{
    package Unsuspecting::Subclass;
    our @ISA = 'Unsuspecting';
}

ok my $new = Unsuspecting->can('new'),
  'can() should return something if a package->can do something';
is ref $new, 'CODE', '... and that something should be a code reference';
ok my $object = Unsuspecting->$new, '... which we should be able to call';
is ref $object, 'Unsuspecting', '... and it should behave as we expect';

ok !Unsuspecting->can('some_func'),
  'strict::can() should not report imported functions';
ok Unsuspecting::some_func(), '... even though the package can still call it';

ok !Unsuspecting->can('_private'),
  'strict::can should ignore functions which begin with an underscore';

ok $new = Unsuspecting::Subclass->can('new'),
  'can() should return something if a subclass->can do something';
is ref $new, 'CODE', '... and that something should be a code reference';
ok $object = Unsuspecting::Subclass->$new,
  '... which we should be able to call';
is ref $object, 'Unsuspecting::Subclass',
  '... and it should behave as we expect';

ok !Unsuspecting::Subclass->can('some_func'),
  'strict::can() should not report imported functions';

ok !Unsuspecting::Subclass->can('_private'),
  'strict::can should ignore functions which begin with an underscore';

##</code><code>##

sub can {
    my ( $proto, $method ) = @_;

    my ($callpack) = caller(0);
    my $class = ref $proto || $proto;
    if ( my $coderef = $proto->SUPER::can($method) ) {
        return $coderef if 'can' eq $method;

        my $code_package = $package_for->($coderef);
        if ( 
            $class->isa($code_package) 
            && 
            ('_' ne substr($method, 0, 1) || $callpack->isa($code_package))
          )     
        {           
            return $coderef;
        } 
    }   
    return; 
}