Most of the time calling $object->can($method); just works. Unfortunately, when dealing with dynamic languages, sometimes we find weird corner cases where our stretching things actually breaks them. can() is one thing which breaks ... a lot. One type of breakage which seriosly bit me was having a module say "yes, I can do that imported function."

{
    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";
}

[download]

Frequently when writing classes we might import (knowingly or otherwise) functions to help our class, but we don't want people to rely on them or, for that matter, to call them. This can also apply to private "underscore" methods. So I wrote a little module which makes can() report false for those.

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;

[download]

With this, your class merely needs to add the line use strict::can; and it gets a can() method which doesn't report what you don't want it to. First, the weird strict:: namespace was started (I believe) by Sean Burke (TorgoX) with strict::ModuleName. I feel odd with the name strict::can, but I can't think of a better one.

I'm still torn about the "private methods" bit. It seems to me that perhaps can() should succeed if you're checking for a private method within a package that subclasses the package you're checking. This assumes that the outside world shouldn't know about "private" methods but if you're subclassing we'll trust you a little bit more.

In any event, if you want to play around with this idea, here are a few tests:

#!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 referenc
+e';
ok my $object = Unsuspecting->$new, '... which we should be able to ca
+ll';
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 c
+all 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 referenc
+e';
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'
+;

[download]

Note that the tests are not using some of the built-in "can_ok", "isa_ok" and other test shortcuts because of the nature of the code I'm testing.

Update: a newer version of the can() method.

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_pack
+age))
          )     
        {           
            return $coderef;
        } 
    }   
    return; 
}

[download]

Cheers,
Ovid

New address of my CGI Course.

Replies are listed 'Best First'.
Re: Fixing nits with $object->can($method); (packages)
by tye (Sage) on Dec 04, 2005 at 21:59 UTC

    I solve this and several other "problems" via packages: 

    package Foo::Bar;
use vars qw( $VERSION );
...

package Foo::Bar::_implement;
use Dood::Dad;

sub helper { ... }

sub Foo::Bar::objectPackage {
    "Foo::Bar::Object";
}

sub Foo::Bar::new { ... }

sub Foo::Bar::Object::method { ... }

...

    [download]

    as expanded upon in other nodes.

    Note that you can use Exporter (or similar) to avoid having to retype the module name so much (which I'm pretty sure you would dislike, but which makes for an easy way to demonstrate the technique).

    - tye        

[reply]
[d/l]
Re: Fixing nits with $object->can($method);
by friedo (Prior) on Dec 05, 2005 at 00:26 UTC
    It's worth noting that a lot of modules use this bug feature intentionally. For example, CGI::Application's plugin architecture depends on importing new methods into the C::A application's namespace from external modules. In this case, can should succeed for imported subs.
[reply]
[d/l]
Re: Fixing nits with $object->can($method);
by xdg (Monsignor) on Dec 04, 2005 at 21:45 UTC

    I think that's an interesting idea, but I can see where it might not work when you expect it to. Much like UNIVERSAL::isa, some people may call UNIVERSAL::can directly as a static method so as to avoid having to check if something is an object or package name. Contrived example: 

    sub has_method {
    my ( $target, $method ) = @_;
    return UNIVERSAL::can( $target, $method) ? 1 : 0;
}

    [download]

    How often this will occur is hard to say, but it's at least worth a warning in the documentation. Whether it's advisable is entirely another issue -- I generally tend to think that one should realize that modules might override UNIVERSAL functions for a reason and respect that.

    -xdg

    Code written by xdg and posted on PerlMonks is public domain. It is provided as is with no warranties, express or implied, of any kind. Posted code may not have been tested. Use of posted code is at your own risk.

[reply]
[d/l]
[select]

      People shouldn't do that. The documentation has a warning about that now. Use blessed() from Scalar::Util instead.

      I wrote an entire article about this and other traps in The Perl Review's Winter 2005 edition.

[reply]
[d/l]
Re: Fixing nits with $object->can($method);
by Roy Johnson (Monsignor) on Dec 05, 2005 at 18:40 UTC
    On a purely whimsical note, it would be amusing to have a Can package with a function t that would disable whatever functions you passed to it. You would, of course, call it with the old-style package notation: 
    {
    package Unsuspecting;
    Naughty->import;
    sub new { bless {}, shift }
    Can't('some_func'); # <--- Here's the call
    sub _private { 'Unsuspecting _private' }
}

    [download]
    Caution: Contents may have been coded under pressure.
[reply]
[d/l]
Re: Fixing nits with $object->can($method);
by tilly (Archbishop) on Dec 06, 2005 at 04:48 UTC
    I really dislike what this module is trying to do.

    All that can is doing is telling you what will be called if you try to call that method. You're noticing that the imported functions are littering your namespace and providing things to trip over. So you're going to lie about where the pitfalls are.

    What I would prefer is a way to import functions and have them not also be methods. Fixing that in Perl is a language issue, so you can't. But second best would be to have a module that allows you to rename what things will be imported as so you can get rid of your conflicts. Whose API might look like this: 

    # This imports from Module and does the following renamings:
#
#       foo   => _foo
#       bar   => _bar
#       hello => _baz_hello
#       world => _baz_world
#
use with_prefix Module => qw(foo bar =_baz_ this that);

    [download]
    (Trick: import into another module then re-export from there to your final module.)

    And now you can reposition the obstacle course rather than lying about it.

[reply]
[d/l]
Re: Fixing nits with $object->can($method);
by adrianh (Chancellor) on Dec 06, 2005 at 12:53 UTC
    Frequently when writing classes we might import (knowingly or otherwise) functions to help our class, but we don't want people to rely on them or, for that matter, to call them.

    Except, of course, when we do ;-) I often use import as a poor man's mixin.

[reply]
      I often use import as a poor man's mixin.

      I tend to think of it more like a poor man's trait.

      -xdg

      Code written by xdg and posted on PerlMonks is public domain. It is provided as is with no warranties, express or implied, of any kind. Posted code may not have been tested. Use of posted code is at your own risk.

[reply]
        I tend to think of it more like a poor man's trait.

        Indeed. All depends on your definition of trait and mixing ;-)

[reply]

Back to Meditations