Bivio::ClassWrapper
# Copyright (c) 2009 bivio Software, Inc. All Rights Reserved. # $Id$ package Bivio::ClassWrapper; use strict; use Bivio::Base 'Collection.Attributes'; sub call_method { my($self, $args) = @_; return unless my $c = $self->get('code_ref'); return $c->(@$args); } sub wrap_methods { my($proto, $pkg, $attrs, $map) = @_; $attrs ||= {}; while (my($method, $wrapper) = each(%$map)) { my($c) = _code_ref_for_method($pkg, $method); my($self) = $proto->new({ %$attrs, code_ref => $c, method => $method, })->set_read_only; $pkg->replace_subroutine($method, sub {$wrapper->($self, \@_)}); } return; } sub _code_ref_for_method { my($pkg, $method) = @_; return (_code_ref_for_subroutine($pkg, $method))[0] || (_unsafe_super_for_method($pkg, $method))[0]; } sub _code_ref_for_subroutine { my($pkg, $name) = @_; do { no strict; local(*p) = *{$pkg->package_name . '::'}; if (exists($p{$name})) { local(*n) = $p{$name}; return *n{CODE} if defined(*n{CODE}); } }; return undef; } sub _unsafe_super_for_method { my($pkg, $method) = @_; $method ||= $pkg->my_caller; foreach my $ia (@{$pkg->inheritance_ancestors}) { if (my $sub = _code_ref_for_subroutine($ia, $method)) { return ($sub, $ia); } } return; } 1;