Class::AutoPlug::Pluggable - automatically make a non-pluggable class pluggable

  package Nonpluggable::Class::Pluggable;
  use base qw(Class::AutoPlug::Pluggable);
  1;

package Class::AutoPlug::Pluggable;
# AutoPluguse Smart::Comments;
use Class::AutoPlug::ResultState;
use Devel::Peek;
use Sub::Installer;

our $AUTOLOAD;
our $VERSION = 0.02;

# Methods to call for each plugin to finish initialization.
my @init_methods = qw(_load_methods _set_hooks);

sub new {
	my ($class, %args) = @_;
	(my $base_class = $class) =~ s/::Pluggable//;

  	# Must have a base class object to delegate to.
  	eval "use $base_class";
  	die "$base_class not loadable: $@\n" if $@;

  	my $pluggable_name = $class;
  	$pluggable_name =~ s/Pluggable$/Plugin/ 
    	or die qq(The module name "$class" is incorrect; it should end in "::Pluggable"\n);
  	# Create plugins() method in the proper class.
  	eval <<EOS;
package $class; 
use Module::Pluggable search_path=>[qw($pluggable_name)]
EOS

  	my $self = {};
  	bless $self, $class;

  	$self->{PreHooks} = {};
  	$self->{PostHooks} = {};

  	# Let the plugins look over the arguments
  	# initialize themselves, and use up arguments that they want.
  	local $_;
  	delete $args{$_} foreach $self->_init(%args);

  	# Read and act on all the "advertisements" from the plugins.
  	if (exists $args{consume} and ref $args{consume} eq 'ARRAY') {
		$self->_consume(@{ $args{consume} });
  	}
  	else {
		$self->_consume(@init_methods);	
  	}
  	$self->base_obj($base_class->new(%args));
  	return $self;
}
	
sub _init {
	my ($self, %args) = @_;
  	# call all the inits (if defined) in all our
  	# plugins so they can all set up their defaults
  	my @deletes;

  	foreach my $plugin ($self->plugins) {
    	eval "use $plugin";
    	if ($plugin->can('init')) {
      		push @deletes, $plugin->init($self, %args);
    	}
  	}
  	return @deletes;
}

sub _consume {
  	my ($self, @method_names) = @_;
  	foreach my $plugin ( $self->plugins) {
    	foreach my $method (@method_names) {
      		$self->$method($plugin);
    	}
  	}
}

sub _set_hooks {
  	my($self, $plugin) = @_;
  	my $class = ref $self;
  	foreach my $hook_type (qw(PRE POST)) {
     	# Find the hook queue for this plugin
		my @hook_queue;
     	{
			no strict 'refs';
     		@hook_queue = eval "\@${plugin}::${hook_type}HOOKS";
		}
     	my $method_name = lc($hook_type)."_hook";
     	while ( (my($hooked_method, $hook_sub), @hook_queue) = @hook_queue) {
       		# Install the hooks
       		$self->$method_name($hooked_method, $hook_sub);
     	}
  	}
}

sub _load_methods {
  	my ($self, $plugin) = @_;
  	my @methods = eval "\@${plugin}::METHODS";
  	while (@methods) {
    	(my($method_name, $method_code), @methods) = @methods;
    	if ($self->can($method_name)) {
      		warn "$method_name redefined by plugin\n";
    	}
		__PACKAGE__->install_sub( { $method_name => $method_code } );
   	}
}

sub remove_hook {
  	my ($self, $which, $method, $hook_sub) = @_;
  	$self->{$which}->{$method} = 
    	[grep { "$_" ne "$hook_sub"} @{$self->{$which}->{$method}}]
      		if defined $self->{$which}->{$method};
	return;
}

sub insert_hook {
  	my ($self, $which, $method, $hook_sub) = @_;
  	push @{$self->{$which}->{$method}}, $hook_sub;
	return;
}

sub pre_hook {
  	my $self = shift;
  	$self->insert_hook(PreHooks=>@_);
	return;
}

sub post_hook {
  	my $self = shift;
  	$self->insert_hook(PostHooks=>@_);
	return;
}

sub AUTOLOAD {
  	# don't shift; this might be a straight sub call!
  	my $self = $_[0];

  	# figure out what was supposed to be called.
  	(my $super_sub = $AUTOLOAD) =~ s/::Pluggable//;
  	my ($plain_sub) = ($AUTOLOAD =~ /.*::(.*)$/);

  	# Record the method name so plugins can check it.
  	# We check for $self being a ref because this could
  	# be a class method call. (Plugins won't be able to
  	# re-call class methods, but I can't think of a reason
  	# why we'd need that for now, so we'll skip it.)
  	$self->last_method($plain_sub) if ref $self;

  	# If this is a straight sub call, just do it. We don't
  	# try to hook these.
  	if (scalar @_ == 0 or !defined $_[0] or !ref $_[0]) {
    	no strict 'refs';
    	$super_sub->(@_);
  	}
  	else {
		my $result = 
			Class::AutoPlug::ResultState->new( 
				{ context => (wantarray ? 'list' : 'scalar') } 
			);
    	my ($ret, @ret);
    	shift @_;
    	my @incoming = @_;
		$result->at_under(\@incoming);
	
    	my $skip;
    	if (my $pre_hook = $self->{PreHooks}->{$plain_sub}) {
	  		# There has not yet been a replacement result from any hook.
      		my $replacing_hook = undef;
      		my $replacement_result;

      		# No hook has forced a skip.
      		$self->_clear_skipping_hooks();

	  		# Try all the hooks in the queue.
      		foreach my $hook (@$pre_hook) {
	    		# Save the hook's name for diagnostics.
	    		my $current_hook_name = _name_from_coderef($hook);
	
	    		# Call it; returns a (possibly altered) ResultState.
        		$result = $hook->($self, $result);

				# Replace @_ if the hook returns a replacement version.
        		if (my $at_under_ref = $result->at_under) {
          			@_ = @{ $at_under_ref };
          			# Warn if we're not going to call the method; this may mean
          			# that the @_ alteration won't take.
          			warn "\@_ alteration by $current_hook_name may be useless; method skip by " .
               		$self->_show_skipping_hooks()
                 		if $self->_skipping_hooks();
        		}

				if ($result->result) {
		  			# Warn if there's already a replacing result, and replace it again.
          			if (defined $replacement_result and
						$replacement_result ne $result->result() and 
						defined $replacing_hook)  {
						### pre-current: $current_hook_name
						### pre-replacing: $replacing_hook
	        			warn "Result replaced by $current_hook_name but already done by $replacing_hook";
	       			}
	       			# Replace the result, and record who last replaced it.
		   			$replacement_result = $result->result;
		   			$replacing_hook = $current_hook_name;
				}

        		# Record the name of this hook if it wanted to skip the method call.		
        		if ($result->skip_method_call) {
	      			$self->_add_skipping_hook($current_hook_name);
	    		}
      		}
    	}

		# If any hook requested a skip, there'll be something in _skipping_hooks.
    	unless ($self->_skipping_hooks) {
      		# Double-check: can we actually dispatch this?
      		if (! $self->base_obj->can($plain_sub) ) {
        		# We have absolutely no idea what to do.
        		die "$plain_sub() call unresolvable (did all your plugins load?)\n";
      		} 

      		# We can do it. Go ahead, in the right context.
      		# Save the current result in the ResultState object.
      		if (wantarray) {
        		@ret = $self->base_obj->$plain_sub(@_);	
				$result->result([@ret]);
      		}
      		else {
        		$ret = $self->base_obj->$plain_sub(@_);
				$result->result([$ret]);
      		}
    	}

    	# If we actually called the method and got a return value save it.
    	# Note that we will call the method unless we were told to skip it;
    	# we may want to take advantage of side effects even if we don't care about the return value.
    	if ($replacement_result and !$self->_skipping_hooks) {
	  		if (wantarray) {
	    		@ret = @{ $replacement_result};	
				$result->result([@ret]);
	  		}
	  		else {
				if (int @{ $replacement_result } == 1) {
					$ret = $replacement_result->[0];			
				}
				else {
					$ret = scalar @{ $replacement_result };
				}
				$result->result([$ret]);
	  		}
    	}

    	# On to the posthooks. The ResultState object has whatever result was determined to be
    	# 'the' result - whether this was what came back from the method call, or whether it was
    	# supplied by a pre-hook is now immaterial.

		# Already captured, so discard this.
		$replacement_result = undef;
    	if (my $post_hooks = $self->{PostHooks}->{$plain_sub}) {
      		foreach my $hook (@$post_hooks) {
	    		# Save the hook's name for diagnostics.
	    		my $current_hook_name = _name_from_coderef($hook);
	    		# Hook returns a ResultState.
	    		$result = $hook->($self, $result);
				# We only are concerned with whether a replacing result exists for a posthook.
				if ($result->result) {
		  			# Warn if there's already a replacing result, and replace it again.
          			if (defined $replacement_result and 
						$replacement_result ne $result->result() and 
						defined $replacing_hook)  {
						### post-current: $current_hook_name
						### post-replacing: $replacing_hook
	        			warn "Result replaced by $current_hook_name but already done by $replacing_hook";
	       			}
	       			# Replace the result, and record who last replaced it.
		   			$replacement_result = $result->result();
		   			$replacing_hook = $current_hook_name;
				}
      		}
    	}

    	# Again, replace the return value if we've got something to replace it with.
    	if ($replacement_result) {
	  		if (wantarray) {
	    		@ret = @{ $replacement_result };	
				$result->result([@ret]);
	  		}
	  		else {
				if (int @{ $replacement_result } == 1) {
					$ret = $replacement_result->[0];			
				}
				else {
					$ret = scalar @{ $replacement_result };
				}
				$result->result([$ret]);
	  		}
    	}

    	wantarray ? @ret : $ret;
  	}
}

sub base_obj {
  	my ($self, $value) = @_;
  	$self->{_base_obj} = $value if defined $value;
  	return $self->{_base_obj};
}

sub last_method {
  	my ($self, $value) = @_;
  	$self->{_last_method} = $value if defined $value;
  	return $self->{_last_method};
}

sub _clear_skipping_hooks {
	my($self) = @_;
	$self->{SkippingHooks} = [];
	return;
}

sub _add_skipping_hook {
	my ($self, $hook_name) = @_;
	push @{ $self->{SkippingHooks} }, $hook_name;
	return;
}

sub _skipping_hooks {
	my($self) = @_;
	return @{ $self->{SkippingHooks} };
}

sub _show_skipping_hooks {
	my ($self) = @_;
	my @hook_names = $self->_skipping_hooks;
	if (@hook_names == 1) {
		return $hook_names[0];
	}
	elsif (@hook_names == 2) {
        return "$hook_names[0] and $hook_names[1]";
    }
    else {
		my $result = '';
	    while (@hook_names > 2) {
			$result .= $hook_name[0].', ';
			shift @hook_names;
		}
		return $result . "$hook_names[0] and $hook_names[1]";
	}
}

sub _name_from_coderef {
  	my ($sub) = @_;
  	my $ini = $sub;
  	$sub = $1 if $sub =~ /^\{\*(.*)\}$/;
  	my $subref = defined $1 ? \&$sub : \&$ini;
  	$subref = \&$subref;                  # Hard reference...
  	my $gv = Devel::Peek::CvGV($subref) or return "CODE()";
  	'&' . *$gv{PACKAGE} . '::' . *$gv{NAME};
}

"Class::AutoPlug::Pluggable defined";