Auto-wrapping subclass methods

jonswar on 2009-04-27T02:45:18

Back in Feb I asked on various lists how I could auto-wrap CHI driver methods, but didn't get any completely satisfying answers:

CHI drivers implement methods like remove() and clear(). If you call $cache->remove(), it goes directly to the driver subclass.

The problem is that there are now legitimate reasons to "wrap" these methods at the CHI/Driver.pm superclass level (meaning, do something before and/or after the method). For example, I want to add an optional generic size-awareness feature (the cache can keep track of its own size), which means that we have to adjust size whenever remove() and clear() are called. And I want to log remove() calls the way we currently log get() and set().

So one solution is to define remove() and clear() in CHI/Driver.pm, and have them call _remove() and _clear() in the driver subclasses. But this kind of change makes me uneasy for several reasons:

It changes the driver API, i.e. all existing drivers out there have to modified. And we might have to change it again as we identify new methods to wrap.
The list of 'normal' versus 'underscore' methods becomes rather arbitrary - it's "whatever we've needed to wrap so far".

I thought about using regular wrapping modules, like Sub::Prepend or Hook::LexWrap. But this fails when you have subclasses more than one level deep. e.g.:

CHI::Driver -> CHI::Driver::Foo -> CHI::Driver::Foo::Bar

Now if you call CHI::Driver::Foo::Bar::remove(), the wrapping code will get called twice, once for each subclass. I only want it to be called once regardless of how deep the subclass is.

Here's how I solved this in CHI-0.2. When each CHI driver is used for the first time, e.g. CHI::Driver::Memory:

my $cache = CHI->new('Memory');

CHI autogenerates a new class called CHI::Wrapped::CHI::Driver::Memory, which inherits from

('CHI::Driver::Wrapper', 'CHI::Driver::Memory')

then blesses the actual cache object (and future cache objects of this driver) as CHI::Wrapped::CHI::Driver::Memory.

Now, when someone calls a method like $cache->get() or $cache->remove(), CHI::Driver::Wrapper has an opportunity to handle it first, and then pass control to CHI::Driver::Memory. If not, it goes directly to CHI::Driver::Memory.

I was unable to find this solution on CPAN, even though I feel like I must be reinventing the wheel. If someone knows of a distribution that encapsulates this technique, please let me know.

Here's the code from CHI::Driver::Wrapper that creates the wrapper class:

sub create_wrapped_driver_class {
    my ( $proto, $driver_class ) = @_;
    carp "internal class method" if ref($proto);
   
    if ( !$wrapped_driver_classes{$driver_class} ) {
        my $wrapped_driver_class      = "CHI::Wrapped::$driver_class";
        my $wrapped_driver_class_decl = join( "\n",
            "package $wrapped_driver_class;",
            "use strict;",
            "use warnings;",
            "use base qw(CHI::Driver::Wrapper $driver_class);",
            "sub driver_class { '$driver_class' }",
            "1;" );
        eval($wrapped_driver_class_decl);    ## no critic ProhibitStringyEval
        die $@ if $@;                        ## no critic RequireCarping
        $wrapped_driver_classes{$driver_class} = $wrapped_driver_class;
    }
    return $wrapped_driver_classes{$driver_class};
}

And here's the first application of auto-wrapping: when certain methods are called on a cache, automatically call them on the subcaches, if any.

# Call these methods first on the main cache, then on any subcaches.
#
foreach my $method (qw(remove expire expire_if clear purge)) {
    no strict 'refs';
    *{ __PACKAGE__ . "::$method" } = sub {
        my $self = shift;
        my $retval = $self->call_native_driver( $method, @_ );
        $self->call_method_on_subcaches( $method, @_ );
        return $retval;
    };
}

# Call the specified $method on the native driver class, e.g. CHI::Driver::Memory.  SUPER
# cannot be used because it refers to the superclass(es) of the current package and not to
# the superclass(es) of the object - see perlobj.
#
sub call_native_driver {
    my $self                 = shift;
    my $method               = shift;
    my $native_driver_method = join( "::", $self->driver_class, $method );
    $self->$native_driver_method(@_);
}

SUPER

chromatic on 2009-04-27T06:18:22

The SUPER module addresses that problem.