File Coverage

blib/lib/Class/Mixin.pm

Criterion	Covered	Total	%
statement	67	68	98.5
branch	15	20	75.0
condition	7	10	70.0
subroutine	11	11	100.0
pod	1	1	100.0
total	101	110	91.8

=pod

=head1 NAME

Class::Mixin - API for aliasing methods to/from other classes

=head1 OVERVIEW

Class::Mixin provides a way to mix methods from one class into another,
such that the target class can use both its methods as well as those
of the source class.

The primary advantage is that the behavior of a class can be modified
to effectively be another class without changing any of the calling
code -- just requires using the new class that mixes into the original.

=head1 SYNOPSIS

  # class1.pm
  package class1;
  sub sub1 { return 11 };
  ...

  # class2.pm
  package class2;
  use Class::Mixin to=> 'class1';
  sub sub2 { return 22 };

  # Original calling code
  use class1;
  print class1->sub1;  # 11
  print class1->can('sub2');  # false

  # Updated calling code
  use class1;
  use class2;	# performs the mixing-in
  print class1->sub1;  # 11
  print class1->can('sub2');  # true
  print class1->sub2;  # 22  <-- note class1 now has the class2 method

=head1 METHODS

=cut

#######################################################
package Class::Mixin;
use strict;

use Symbol ();
use Carp;
use warnings::register;

our $VERSION = '1.00';

my %r = map { $_=> 1 } qw(
	BEGIN
	INIT
	CHECK
	END
	DESTROY
	AUTOLOAD
	ISA

	import
	can
	isa
	ISA
	STDIN
	STDOUT
	STDERR
	ARGV
	ARGVOUT
	ENV
	INC
	SIG
);

sub __new {
	return $Class::Mixin::OBJ if defined $Class::Mixin::OBJ;
	$Class::Mixin::OBJ = bless {}, shift;
	return $Class::Mixin::OBJ;
}

=pod

=head2 import

Method used when loading class to import symbols or perform
some function.  In this case we take the calling classes methods
and map them into the class passed in as a parameter.

=over 2

=item Input

=over 2

=item None

=back

=item Output

None

=back

=cut

sub import {
	my $cl = shift;
	return unless @_;
	my $obj = Class::Mixin->__new;
	my $p = { @_ };
	Carp::croak q{Must mixin 'to' or 'from' something} unless exists $p->{to} || exists $p->{from};

	my $class = caller;
	if( exists $p->{to} ){
	  $obj->{mixins}->{ $class   }->{ $p->{to} } ||= [];
	}
	if( exists $p->{from} ){
	  $obj->{mixins}->{ $p->{from} }->{ $class } ||= [];
	}
}

CHECK { resync() }

=pod

=head2 B DESTROY

This modules uses a destructor for un-mixing methods.  This is done in
the case that this module is unloaded for some reason.  It will return
modules to their original states.

=over 2

=item Input

=over 2

=item *

Class::Mixin object

=back

=item Output

=over 2

=item None

=back

=back

=cut

sub DESTROY {
  my $obj = shift;
	foreach my $mixin ( keys %{$obj->{mixins}} ) {
	  foreach my $target ( keys %{$obj->{mixins}->{$mixin}} ) {
	    foreach my $v ( @{ $obj->{mixins}->{$mixin}->{$target} } ){
		no strict 'refs';
		my $m = $v->{'method'};
		my $c = $v->{'class'} . '::';
		my $s = $v->{'symbol'};
		*{ $s } = undef;
		delete ${ $c }{ $m };
		$s = undef;
	    }
	  }
	}
}

=pod

=head2 resync

Function used to process registered 'mixins'.  Typically automatically
called once immediately after program compilation.  Sometimes though you
may want to call it manually if a modules is reloaded.

=over 2

=item Input

=over 2

=item None

=back

=item Output

=over 2

=item None

=back

=back

=cut

sub resync {
	my $obj = Class::Mixin->__new;
	my $class = caller;

	foreach my $mixin ( keys %{$obj->{mixins}} ) {
	  foreach my $target ( keys %{$obj->{mixins}->{$mixin}} ) {

		my $mixinSym = $mixin . '::';
		my $targetSym = $target . '::';

		next if $class ne $mixin && !$class->isa( __PACKAGE__ );

		no strict 'refs';

		foreach my $method ( keys %$mixinSym ) {
			if ( exists $r{ $method } ) {
				warnings::warn "Unable to Mixin method '$method', restricted"
					if warnings::enabled();
			} elsif ( exists ${ $targetSym }{ $method } ) {
				warnings::warn qq{
Unable to Mixin method '$method'
FROM $mixin
TO $target
already defined in $target
} if warnings::enabled();
			} else {
				my $m = Symbol::qualify_to_ref( $method, $mixin );
				my $t = Symbol::qualify_to_ref( $method, $target );
				*{ $t } = *{ $m };

				push @{ $obj->{mixins}->{$mixin}->{$target} }, {
					class=>		$target,
					method=>	$method,
					symbol=>	$t,
				};
			}
		}

	  }
	}
}

1;

__END__