Beefy Boxes and Bandwidth Generously Provided by pair Networks
Do you know where your variables are?
 
PerlMonks  

messing with @ISA - unblessing

by Boldra (Deacon)
on Aug 02, 2008 at 15:37 UTC ( #701826=perlquestion: print w/replies, xml ) Need Help??

Boldra has asked for the wisdom of the Perl Monks concerning the following question:

Hello readers,

Is there an easier way to unbless an object than this?
package Liftable; use Class:ISA; sub new { bless $_[1], $_[0] } sub lift { my $self = shift; my $old_class = ( grep { $_ !~ /__PACKAGE__/ } ( Class::ISA::super_path( ref($self) ) ) )[0]; bless $self, $old_class; }
I want to temporarily make an object a member of a second (third, fourth) class, overriding some methods, but retaining all attributes when the object reverts. I'm worried that the solution above might have unwanted side-effects.


- Boldra

Replies are listed 'Best First'.
Re: messing with @ISA - unblessing
by crashtest (Curate) on Aug 02, 2008 at 16:05 UTC

    I see your code and I think Decorator pattern. Basically, you create a class that wraps the original object, and dispatches all method calls to the original object, except for those you want to override/modify, or those that are new. The advantage here is if some other part of your code is referencing the object you are monkeying with, it won't suddenly find its behavior changed.

    In Perl, you get the added bonus of being able to implement all the methods that just dispatch to the original object using AUTOLOAD. Below is an example I've used before, YMMV.

    package MyDecorator; sub new{ my ($class, $wrapped, %options) = @_; my $self = { wrapped => $wrapped, options => \%options }; bless $self, __PACKAGE__; } sub method1{ my $self = shift; my $wrapped = $self->{'wrapped'} # Do something different than what # $wrapped->method1 would do. # ... } sub method2{ my $self = shift; my $wrapped = $self->{'wrapped'} # method2 is a new method that now provides additional # functionality for the object. } # Implement autoload to defer all the methods we can't handle to the # wrapped class. sub AUTOLOAD{ return if our $AUTOLOAD =~ /::DESTROY$/; my $self = shift; my ($method, @namespace) = reverse(split '::' => $AUTOLOAD); my $wrapped = $self->{'wrapped'}; if ($wrapped->can($method)){ no strict 'refs'; $AUTOLOAD->($wrapped, @_); } else{ die "Cannot run or defer method \"$method\"!"; } }

    (All this goes to show, once again, TIMTOWTDI. But also: I am no expert on object oriented design, so take this with a grain of salt.)

      Applying this, as I learned this week, is trivial with Moose (or Mouse). Here is a snippet that installs a Template object inside your object, and only when needed, and then dispatches--via the handles param which has even more sugar than shown--any calls on your $object->process to the TT2 object exactly as if it were called instead. It's really very hot.

      use Mouse; has "tt2" => ( is => "ro", lazy => 1, # not always used isa => "Template", default => sub { require Template; Template->new(); }, handles => [qw( process )], );

      Update (2017-07-11): moved use to require inside the default sub. A better practice if the object is not always used.

      Many thanks for your suggestion, but AUTOLOAD only lets me define new methods, not redefine old ones, which is one of my aims.

        I don't understand how that's a problem. The AUTOLOAD goes in the Decorator class, not the original object's class. The Decorator is new, so I wouldn't expect it to subclass anything else...?

        Of course, you can implement a Decorator class without AUTOLOAD, it's just more tedious as you have to write a little method each time, and maintain the Decorator as the original object's class changes. Based off your example, maybe something like this:

        package Curse::Older; sub new{ my ($class, $player, $older_by) = @_; my $self = { player => $player, older_by => $older_by, cursed => 1 }; bless $self, $class; } # name is just simply delegated sub name{ my $self = shift; $self->{'player'}->name(@_); } # age is however intercepted and modified sub age{ my $self = shift; my $player = $self->{'player'}; my $age = $player->age(); if ($self->{'cursed'}){ $age + $self->{'older_by'}; } else{ $age; } } # Meanwhile... package main; my $player = new Player('Jim', 30); # curse Jim to make him 10 years older my $cursed_player = Curse::Older->new($player, +10);

        Anyway, it looks like you're going down the re-blessing route. The Java programmer in me thinks that's nuts, but the Perl hacker in me admires what the language lets you do!

Re: messing with @ISA - unblessing
by FunkyMonk (Chancellor) on Aug 02, 2008 at 15:42 UTC
      This might not work for the OP since it also unblesses anything contained in the original object.
      I'd have to test it, but it looks like it also removes much more than just the blessing that it created itself.


      - Boldra
Re: messing with @ISA - unblessing
by shmem (Chancellor) on Aug 02, 2008 at 22:25 UTC

    I haven't explored the implications, but I have the gut feeling that Alter might provide a solution, since with that inside-out package objects don't loose their attributes on re-blessing and re-blessing back. Since @ISA is package (class) level, you might need to provide an equivalent method dispatch path on the object level, hard to tell without seeing the whole picture. But the interesting thing is - why do you need re-blessing? might that be a XY Problem?

    --shmem

    _($_=" "x(1<<5)."?\n".q·/)Oo.  G°\        /
                                  /\_¯/(q    /
    ----------------------------  \__(m.====·.(_("always off the crowd"))."·
    ");sub _{s./.($e="'Itrs `mnsgdq Gdbj O`qkdq")=~y/"-y/#-z/;$e.e && print}
Re: messing with @ISA - unblessing
by pjotrik (Friar) on Aug 02, 2008 at 16:44 UTC
    Acme::Damn provides method for unblessing, but I don't think it's the way to go.
Re: messing with @ISA - unblessing
by ysth (Canon) on Aug 03, 2008 at 05:19 UTC
Re: messing with @ISA - unblessing
by Anonymous Monk on Aug 02, 2008 at 15:45 UTC
    Bad idea, you probably want a copy/clone
Re: messing with @ISA - unblessing
by Boldra (Deacon) on Aug 03, 2008 at 09:57 UTC
    To clarify the problem I've written the following test code. It uses the 'lift' method from the original post, and the tests all pass.

    The only problem I see with this code is that @ISA will gradually become littered with rubbish package names. Were Curse to define any subs that weren't just redefinitions of subs from Player, these would remain accessible from my main program. Curse doesn't, and won't, so I should be error free, but over time I must take a memory/performance hit.
    #!/usr/bin/perl -w use strict; use warnings; use Test::More tests => 7; my $player = new Player; $player->name('Tim'); is( $player->name, 'Tim', 'name' ); $player->age( 10 ); is( $player->age, 10, 'age set' ); my $curse = new Curse::Older( $player ); is( $player->name, 'Tim (cursed)', 'name cursed' ); is( $player->age, 20, 'cursed age' ); $player->age( 20 ); is( $player->age, 40, 'age set while cursed' ); $curse->lift; #can_ok( $player, 'name', 'player has name method'); #why does this fa +il? is( $player->name, 'Tim', 'name back to normal' ); is( $player->age, 20, 'age learnt while cursed' ); #--------------------------------------------------------------------- +---------- package Player; use strict; use warnings; sub new { bless {}, $_[0] } sub age { $_[1] and $_[0]->{age} = $_[1]; return $_[0]->{age} } sub name { $_[1] and $_[0]->{name} = $_[1]; return $_[0]->{name} } #--------------------------------------------------------------------- +---------- package Curse; use strict; use warnings; use base 'Player'; use Class::ISA; sub new { my $class = shift; my $player = shift; return bless $player, $class; } sub name { $_[0]->SUPER::name . ' (cursed)' } sub lift { my $curse = shift; my $pkg = __PACKAGE__; my $old_class = ( grep { $_ !~ /^$pkg/ } ( Class::ISA::super_path( ref( $curse ) ) ) )[0]; bless $curse, $old_class; } #--------------------------------------------------------------------- +---------- package Curse::Older; use base 'Curse'; sub age { $_[0]->SUPER::age( $_[1] ) * 2}
    I hope I haven't muddied the waters too much with my package names; 'curse' is not the opposite of 'bless', it's actually a package that an object (player) can be blessed into, and then unblessed back out of.

    Admittedly sub lift isn't exactly as in my original, this version also fixes a bug in my usage of __PACKAGE__.



    - Boldra
      #can_ok( $player, 'name', 'player has name method'); #why does this fail?
      Because can_ok is looking for methods called 'name' and 'player has name method'?

      According to Test::More:

      can_ok

      can_ok($module, @methods);
      can_ok($object, @methods);

        Yep, that would be it. Thankyou!


        - Boldra
      #can_ok( $player, 'name', 'player has name method'); #why does this fa +il?

      Looks like a bug to me, since

      ok( $player->can('name'), 'player has name method');

      doesn't fail.

      --shmem

      _($_=" "x(1<<5)."?\n".q·/)Oo.  G°\        /
                                    /\_¯/(q    /
      ----------------------------  \__(m.====·.(_("always off the crowd"))."·
      ");sub _{s./.($e="'Itrs `mnsgdq Gdbj O`qkdq")=~y/"-y/#-z/;$e.e && print}
Re: messing with @ISA - unblessing
by Tanktalus (Canon) on Aug 03, 2008 at 21:16 UTC

    I went about the same idea (nearly) another way: perhaps Module::Replace might work for you? Temporarily overriding some methods is what that module does.

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: perlquestion [id://701826]
Approved by Corion
Front-paged by Corion
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others taking refuge in the Monastery: (5)
As of 2020-10-28 12:11 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?
    My favourite web site is:












    Results (260 votes). Check out past polls.

    Notices?