This works, but is SOOOO wrong....

It uses the debugger, and some little-documented side-effects of "caller"

#!/usr/bin/perl -w
package a; # the caller package

sub new {
 return bless {},shift
}

sub call {
 my ($self,$other)=@_;
 $other->do_something; # calling the other. Notice: no $self
}

sub back {
 my $self=shift;
 print "I've been called back!\n";
 print "And I have ",$self->{stuff},"\n";
}

package b; # the called package
use Data::Dumper;

sub new {
 return bless {},shift
}

sub do_something {
  my $p=DB::get_args();
  print Dumper($p); # this dumps the arguments of the caller (in this 
+case, a->call)
  $p->[0]->back()
}

package DB; # this MUST be called DB. It triggers magic in "caller"

sub get_args {
  my @a=caller(2); # 2 because 0 is this, 1 is the one that called it,
+ 2 is the one we need.
  # no, you can't remove the assignment: the optimizer will kill the l
+ine.
  return [@DB::args]; # @DB::args gets magically set to the param list
+.
}

package main;

$a=a->new;$b=b->new;
$a->{stuff}='something';
$a->call(b);
__END__
[download]

Will print:

$VAR1 = [
          bless( {
                   'stuff' => 'something'
                 }, 'a' ),
          'b'
        ];
I've been called back!
And I have something
[download]

UPDATE: clarified the meaning of the DB package

Very nice :-)

Ok, so you can. That still doesnt mean that you should.

In fact, I'm really curious why you would ever want this (except in the debugger ofcourse).

-- 
Joost       downtime n. The period during which a system
            is error-free and immune from user input.
[download]

Makeshifts last the longest.

Perfect. Here's some proof of concept code:

#!/usr/bin/perl

package Caller;
sub new  { bless {}, 'Caller' }
sub call {      
    my( $self, $one ) = @_;
    $one->output;
}
sub output { "I am the Caller\n" }
1;

package Called;
use PadWalker 'peek_my';
sub new    {  bless {}, 'Called' }
sub output {
    my $caller = peek_my( 1 )->{ '$self' }; #$h->{ '$self' };
    print STDOUT $$caller->output();
}
1;
                                                                
                                                                
package main;

my $one = new Caller;
my $two = new Called;

$one->call( $two );
[download]

This prints:
I am the Caller.
--
Love justice; desire mercy.

Perfect, so long as it is indeed called $self.. :)

Makeshifts last the longest.

I'm surprised that something like PadWalker is possible. I figured that the compiler would not retain the names at all at run-time.

sub Foo::new { bless {bar => pop}, shift }
sub Foo::call_bar {
   $_[0]->{bar}->some_method($_[0]);
}

sub Bar::new { bless [@_], shift }
sub Bar::some_method {
   print "the object whose method called this method: $_[-1]\n";
}

my $o = Foo->new( Bar->new(qw(a list of args)) );
$o->call_bar();

__output__

the object whose method called this method: Foo=HASH(0x8108174)
[download]

_________
broquaint

update: I sit corrected :)

What's wrong with:

sub method {
   my ($self) = shift;
   my $object = Object->new;
   $object->method2($self,@other_args);
}
[download]

If you've got some special problem that needs this functionality, maybe there is another way to solve it.

update: fixed typo.

-- 
Joost       downtime n. The period during which a system
            is error-free and immune from user input.
[download]

It doesn't solve the problem. That's what's wrong with it. ;) The original calling object isn't made available to my receiving object.

I'm working with a static package somebody else wrote. When a sub in my package is called, it needs to do something to the calling object. As dakkar pointed out (and you saw) it is possible. =) I think it ought to be easier, but I didn't (nor am I remotely qualified to) design the language I'm using.

I'm wary, though, when I hear somebody say "it can't be done". It's very easy to prove something possible. It's near to impossible to prove that a thing is impossible. I do have a number of other ways to solve the problem, but they're all kludges. I want a better way, and I think it may well exist someplace. If it does, I expect the answer to come from the undocumented depths of the way Perl works, on a much lower level than I currently understand. But I do think it may be out there.
--
Love justice; desire mercy.

I would probably rewrite the other package in this case, but if you really can't I would suggest using the caller/DB trick below. It's really nasty and somewhat underdocumented, but it will probably work.

But in my view it's simple: the problem lies not in your code, it's in the other package. Fix the problem; fix the other package.

-- 
Joost       downtime n. The period during which a system
            is error-free and immune from user input.
[download]

package NewObj;
sub new { return bless {},$_[0] };

package Foo;
our @ISA=qw(NewObj);
sub call_bar {
  my ($self,$bar)=@_;
  $bar->who_called;
}

package Bar;
use strict;
use warnings;

use overload; #VITAL!

our @ISA=qw(NewObj);
sub who_called {
  my ($self)=@_;
  package DB;
  unless (my (undef,undef,undef,$sub)=caller(1)) {
      print "Called from main\n";
  } else {
    print "Called from $sub\n";
    if (ref($DB::args[0]) and overload::StrVal($DB::args[0])=~/=/) {
        
        print "\tWhich is a method that was invoked on ".overload::Str
+Val($DB::args[0])."\n";
    } else {
        print "@DB::args";
    }
  }
}

package main;

my $obj1=Foo->new();
my $obj2=Bar->new();
print "OBJ1 (Foo) : ".overload::StrVal($obj1)."\n"
$obj1->call_bar($obj2);
[download]

--- demerphq
my friends call me, usually because I'm late....

Note that there are some funky issues that mean you _cant_ reliable replace the overload::StrVal calls with plain old reference stringification.

Do go on...

To coin a phrase, a snippet is worth a thousand words...

package Foo;
use overload qw("" stringify fallback 1 + zero);

sub stringify {
  "overload.pm just ruined your day!"
}

sub zero { 0 }

package main;
my $foo1=bless {},'Foo';
my $foo2=bless {},'Foo';

sub same { "'$_[0]' is ".($_[0] eq $_[1] ? "the same as" : "different 
+to" )." '$_[1]'\n" };


print same(0+$foo1,0+$foo2);
print same($foo1,$foo2);
print same("$foo1","$foo2");
print same(overload::StrVal($foo1),overload::StrVal($foo2));

__END__
'0' is the same as '0'
'overload.pm just ruined your day!' is the same as 'overload.pm just r
+uined your day!'
'overload.pm just ruined your day!' is the same as 'overload.pm just r
+uined your day!'
'Foo=HASH(0x1acef84)' is different to 'Foo=HASH(0x1acf038)'
[download]

:-)

AFAIK, the _only_ non-xs way to reliably determine the underlying variable type and class of an overloaded object is to parse the results of overload::StrVal. Even then you get nowhere with reblessed qr// objects. (Which still act as regexes at the same time.)

Frankly the fact that perl completely lacks any reliable native perl way of doing type introspection is IMO one of its few serious failings. (And no, at least some of the problems do not go away with Scalar::Utils and List::Utils.)

--- demerphq
my friends call me, usually because I'm late....

I'm a little curious about your constraints...

1. The result must be a reference to the object which called the sub.
2. The reference to the calling object must be obtained on the fly (no saving it anyplace first to be retrieved later).
3. No changes may be made to the calling object (say, to have it pass $self to the receiving object).

While they have provided some interesting (if somewhat baroque :-) solutions, I'd love to know what causes them in your particular instance?

For example, why can't you use Hook::LexWrap to temporarily override the method in question to stash the object somewhere for your later use (which would violate constraint (2) and (3)?

Just curious :-)

Hehe. Ok. Quite a few people appear to be interested. Here goes:

I'm writing an LDAP browser using Tk. My goal is to use ONLY the standard Tk:: modules and Net::LDAP, for reasons relating to the architectures I'm designing it for. Halfway through production, though, I designed a really cool (I think) new interface for it, which requires widgets totally unavailable in the standard Tk module set. I needed to make them myself.

During one attempt to create such a derivative widget, I needed to teach a widget that doesn't properly support scrolling to update the scrollbar I had attached to it when it received the yview() call. But since I was doing the binding myself (and hadn't yet discovered the ConfigSpecs command) the only way to tell the widget where the scrollbar was was to set $widget->{ scrollbar } to a reference to the scrollbar widget, and use that to address it. That method was messy, and just the Wrong Way To Do It, in my mind. Since I was using the standard Tk modules, and only happened to be doing a minor adjustment to one widget, I didn't want to modify it extensively enough to use LexWrap or anything else (not that I knew about LexWrap at the time =).

That was what got me thinking about finding the calling object. It's the sort of thing which would've been useful to me in some other places, and I figured there must be a way. Turns out there are at least three.

I'm very new at making derivative Tk widgets. Awhile after I posted, I found out about ConfigSpecs. Being able to use that solved a lot of problems that finding the calling object would've created, so I ended up using it instead.

In the end, I wasn't looking for an answer to the problem I have just explained. I had already thought of ways to store and retrieve the object, and didn't want to be told that that's how I should do it. That's why I posted the question I did.
--
Love justice; desire mercy.

Turns out there are at least three.

Er, i would say the three you mentioned are the same, with subtle differences, but essentially the same.

BTW, my personal feeling is that avoiding having to do this is the best way to proceed, but i understand your constraints.

Yves

--- demerphq
my friends call me, usually because I'm late....