Update: I missed the line about "I could arrange that the constructor wraps the subroutine at construction time, rather than de-referencing time". My apologies to the OP. This won't answer the OP's question, but maybe it will be helpful to someone interested in the more general solution "how do I..."

Is your goal to wrap the call to $f in a sub that inserts some before (or maybe before and after behavior)? Or it is to do that and insure that the blessed code ref and $f have the same memory address? And if so, why is this important?

If you don't need the same memory address, you could simply define a constructor that wraps the subroutine in another subroutine, like this:

which prints

Special stuff for class Before
Hello world!
Special stuff for class Before
Bonjour, le monde!
Special stuff for class Before
Guten tag, die welt!
Special stuff for class AlsoBefore
Boker tov, olam!
[download]

Best, beth

I agree that, if I'm willing to wrap at construction time, then the problem may be solved exactly as you describe. I was just wondering (specifically for the reason that I've described—and because I'm stubborn and want to do something the first way that occurred to me :-)—but more generally because it seems like an interesting, and possibly useful, thing to do) whether it's possible to get at the ‘true’ behaviour of an object which is subject to overloading.

A use case (which is not my actual situation) might go as follows: Imagine that Perl prototypes don't exist, and we're trying to create them. Then one could imagine wanting to write code like this:

package Prototype;
use overload
    '&{}' => sub {
        my ( $f ) = @_;
        return sub {
            check_arguments(@_);
            goto &$f;
        };
    };

sub i_know_what_im_doing {
    my $f = shift;
    goto &$f;
}
[download]

so that executing

$f->(@args)
[download]

would check the prototype, but executing

$f->i_know_what_im_doing(@args)
[download]

wouldn't.

(It's not a very good use case, because we have to store the prototype somewhere, and, if we are good and store it in the object, then it's easy to find a way around the problem. :-) )

Your question stands on its own merits, of course, but I'm still puzzled as to why one would want to do it. The syntax you describe above could be accomplished without overloading simply by using the wrapped functions reference address as a key into a hash that stores the original code reference. This would also give you the advantage of making the definition of i_know_what_im_doing class specific. Perhaps you could suggest another use case where overloading really is essential? The modified routine for those interested (I expect the OP could easily write it on his/her own).

Read more... (1252 Bytes)

Best, beth

Update: distinguished my question from OP's and clarified my own question which is still about why

package Before;
use Acme::Damn;

use overload
    '&{}' => sub {
        my $f = shift();
        my $ref = damn($f);
        return sub {
            print "Stuff before\n";
            my @rv = $ref->(@_);
            bless($ref, __PACKAGE__);
            return @rv;
        };
    };
1;
[download]

$ perl -MBefore -e 'my $foo = bless(sub { print shift()."\n" } => 'Bef
+ore'); $foo->("foo"); $foo->("bar")'
Stuff before
foo
Stuff before
bar
[download]

Provided $f only uses variables declared within its own subroutine body or passed in as parameters, couldn't you use the core module B::Deparse to avoid the extra stack frame (and the need to use an Acme module)?

use strict;
use warnings;

use B::Deparse;
{
  package Before;
  use overload '&{}' => sub {
    my ( $f ) = @_;
    my $s=B::Deparse->new()->coderef2text($f);

    # note: this will *NOT* work if $f uses package variables
    # this will also not work if $f uses certain global variables
    #
    # namely, if $f uses global variables from
    # the namespace where it is defined. At least for 5.8.8
    # B::Deparse erases the namespace name: i.e. 
    #   { package Foo; our $X=100;  my $f=sub { print "$Foo::X\n" } }
    # will be deparsed as:  sub { print "${X}\n" }.
    # Since ${X} is undefined in package Before, 
    # Perl will complain about undefined variables.

    $f=eval 'sub {'.$s.'}';
    return sub {
      print "Stuff before\n";
      goto &$f;
    }
  }
}

my $cr=bless(sub {print "Hello @_\n" },'Before');
$cr->('tweedledum', 'tweedledee');
$cr->('walrus','carpenter');
[download]

prints

Stuff before
Hello tweedledum tweedledee
Stuff before
Hello walrus carpenter
[download]

Best, beth

package Before;
my %looper;
use overload
    '&{}' => sub {
        my ( $f ) = @_;
        my $fs = overload::StrVal($f);
        if( $looper{$fs} ){
            print "$fs   got looper already\n";
            return $looper{overload::StrVal($f)};
        } else {
            my $looper = 0;
            my $s = sub {
                $looper++;
                print "$fs  Stuff before (looper=$looper)\n";
                goto &$f unless $looper > 1;
            };
            $looper{$fs} = $s;
            return $s;
        }
    };

package main;
( bless sub {} => 'Before' )->()
__END__
Before=CODE(0x18305e4)  Stuff before (looper=1)
Before=CODE(0x18305e4)   got looper already
Before=CODE(0x18305e4)  Stuff before (looper=2)
[download]

This gives the advertised output, and certainly avoids the infinite descent, but it seems only to do what I want for the empty sub (or any other side-effect-free sub, I suppose)—if I execute ( bless sub { print "I am a side effect\n" } => 'Before' )->(), then I am a side effect is never printed.

Probably because that sub is never executed