Beefy Boxes and Bandwidth Generously Provided by pair Networks
Syntactic Confectionery Delight

Adding a method to an existing object

by forgot_other_usrname (Novice)
on Feb 13, 2012 at 02:40 UTC ( #953383=perlquestion: print w/replies, xml ) Need Help??

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

I'm in need of "runtime decorators". That is, a class whose constructor is to take an instance of either the base class or a separate "runtime decorator" and add functionality to it. I don't know ahead of time what the type of the object will be. Here's an extremely contrived example of what I want to do (this strategy makes sense in the actual problem domain).
package Base; sub new { my $package = shift; my $id = shift; return bless { id => $id, }, $package; } sub id { my ($self, $id) = @_; $self->{id} = $id if defined $id; return $self->{id}; } 1; package NameDecorator; sub new { my $package = shift; my $base_or_decorated = shift; my $self = $base_or_decorated->new(@_); $self->{name} = undef; return $self->{name}; } sub name { my ($self, $name) = @_; $self->{name} = $name if defined $name; return $self->{name}; } 1; the same for an AgeDecorator
Then I could use it like follows
use Base; use NameDecorator; use AgeDecorator; my $decorated = AgeDecorator->new(NameDecorator->new(Base->new('id1')) +); $decorated->name('Edith'); $decorated->age(93);
I need the flexibility to be able to chain decorators together and still have available to methods added from the decorator before it. Is there a name for what I'm trying to do and can this be done easily without the help of a module or is there a module which can help me achieve this?

UPDATE: This is getting closer to what I want, but it still adds to the class rather than the object
package NameProto; use strict; use base qw(Base::Decorator); sub new { my $self = shift->SUPER::new(@_); $self->{age} = 0; no strict 'refs'; my $package = ref($self->{base}); *{$package . '::name'} = sub { my ($self, $name) = @_; $self->{name} = $name if defined $name; return $self->{name}; }; return bless $self, $package; } sub name { return shift->{base}->name(@_); } 1;

Replies are listed 'Best First'.
Re: Adding a method to an existing object
by chromatic (Archbishop) on Feb 13, 2012 at 02:50 UTC

    I use a similar technique for a very simple plugin system. The main object is a Moose object, and all of the plugins are Moose roles. With in the main class (call it MyApp), I have a method:

    sub create_with_roles { my ($class, $roles, %args) = @_; for my $role (@$roles) { next if $role =~ /::/; $role = 'MyApp::Role::' . $role; } Moose::Util::ensure_all_roles( $class, @$roles ); return $class->new( %args ); }

    ... and within the drive program, I can write:

    my $app = MyApp->create_with_roles( [qw( List Of Role Names )], %constructor_arguments );

    ... and get back an object which is an instance of MyApp which performs all of the named roles. It's been working very well.

    Improve your skills with Modern Perl: the free book.

      Note that this will permanently change the MyApp class, which might not be what is desired. I tend to use MooseX::Traits in most of the general cases.

      Ordinary morality is for ordinary people. -- Aleister Crowley

        I should have mentioned that. It's no problem in my case, because I know none of the plugins will override each other (and no code wants to use an unmodified MyApp object), but Moose traits are more general and applicable.

Re: Adding a method to an existing object
by moritz (Cardinal) on Feb 13, 2012 at 07:15 UTC

    Well, methods are looked up in package tables, not in objects.

    So you have basically three options:

    1. create a new subclass per object into which the new methods go, and rebless the objects into their respective classes
    2. Carry around a custom method table (for example a hash) in the instance data of an object, and define an AUTOLOAD sub that considers this custom method table as a fallback
    3. Look what CPAN has to offer; somebody likely already implemented either approach.
Re: Adding a method to an existing object
by JavaFan (Canon) on Feb 13, 2012 at 10:08 UTC
    use 5.010; use strict; use warnings; sub Base::set_id {$_[0]{id} = $_[1]; $_[0]} sub Base::id {$_[0]{id}} sub Name::set_name {$_[0]{name} = $_[1]; $_[0]} sub Name::name {$_[0]{name}} sub Age::set_age {$_[0]{age} = $_[1]; $_[0]} sub Age::age {$_[0]{age}} sub gimme_object { state $class = "MyClass00000"; $class++; no strict 'refs'; @{"${class}::ISA"} = (Base => @_); bless {}, $class; } my $obj1 = gimme_object qw[Name]; my $obj2 = gimme_object qw[Age]; my $obj3 = gimme_object qw[Age Name]; $obj1->set_id(1)->set_name("Foo"); $obj2->set_id(2)->set_age(42); $obj3->set_id(3)->set_name("Bar")->set_age(15); printf "Object %d has name %s\n", $obj1->id, $obj1->name; printf "Object %d has age %d\n", $obj2->id, $obj2->age; printf "Object %d has name %s and age %d\n", $obj3->id, $obj3->name, $ +obj3->age; __END__ Object 1 has name Foo Object 2 has age 42 Object 3 has name Bar and age 15
Re: Adding a method to an existing object
by draegtun (Scribe) on Feb 17, 2012 at 16:56 UTC

    The following two modules on CPAN allow you to add methods to an object:

    * MooseX::SingletonMethod (for Moose objects)
    * Object::Method (for normal Perl objects)

    Alternatively in Moose you can apply roles directly to an object:

        YourRole->meta->apply( $your_object ); # $your_object now has the methods from YourRole

    I did a few blog posts on how roles work and howto implement singleton-methods (in Moose). They're listed in the MooseX::SingletonMethod CPAN page. Also this link should bring them up.


Log In?

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: perlquestion [id://953383]
Approved by Old_Gray_Bear
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others musing on the Monastery: (5)
As of 2023-03-28 14:18 GMT
Find Nodes?
    Voting Booth?
    Which type of climate do you prefer to live in?

    Results (67 votes). Check out past polls.