perl/libs/mixin.pm

package mixin;

use strict;
no strict 'refs';
use vars qw($VERSION);
$VERSION = '0.04';


=head1 NAME

mixin - Mix-in inheritance, an alternative to multiple inheritance

=head1 SYNOPSIS

  package Dog;
  sub speak { print "Bark!\n" }
  sub new { my $class = shift;  bless {}, $class }

  package Dog::Small;
  use base 'Dog';
  sub speak { print "Yip!\n"; }

  package Dog::Retriever;
  use mixin::with 'Dog';
  sub fetch { print "Get your own stinking $_[1]\n" }

  package Dog::Small::Retriever;
  use base 'Dog::Small';
  use mixin 'Dog::Retriever';

  my $small_retriever = Dog::Small::Retriever->new;
  $small_retriever->speak;          # Yip!
  $small_retriever->fetch('ball');  # Get your own stinking ball

=head1 DESCRIPTION

Mixin inheritance is an alternative to the usual multiple-inheritance
and solves the problem of knowing which parent will be called.
It also solves a number of tricky problems like diamond inheritence.

The idea is to solve the same sets of problems which MI solves without
the problems of MI.

=head2 Using a mixin class.

There are two steps to using a mixin-class.

First, make sure you are inherited from the class with which the
mixin-class is to be mixed.

  package Dog::Small::Retriever;
  use base 'Dog::Small';

Since Dog::Small isa Dog, that does it.  Then simply mixin the new
functionality

  use mixin 'Dog::Retriever';

and now you can use fetch().


=cut

sub import {
    my($class, @mixins) = @_;
    my $caller = caller;

    foreach my $mixin (@mixins) {
        # XXX This is lousy, but it will do for now.
        unless( defined ${$mixin.'::VERSION'} ) {
            eval qq{ require $mixin; };
        }
        _mixup($mixin, $caller);
    }
}

sub _mixup {
    my($mixin, $caller) = @_;

    require mixin::with;
    my($with, $pkg) = mixin::with->__mixers($mixin);

    _croak("$mixin is not a mixin") unless $with;
    _croak("$caller must be a subclass of $with")
      unless $caller->isa($with);

    # This has to happen here and not in mixin::with because "use
    # mixin::with" typically runs *before* the rest of the mixin's
    # subroutines are declared.
    _thieve_public_methods( $mixin, $pkg );
    _thieve_isa( $mixin, $pkg, $with );

    unshift @{$caller.'::ISA'}, $pkg;
}


my %Thieved = ();
sub _thieve_public_methods {
    my($mixin, $pkg) = @_;

    return if $Thieved{$mixin}++;

    local *glob;
    while( my($sym, $glob) = each %{$mixin.'::'}) {
        next if $sym =~ /^_/;
        next unless defined $glob;
        *glob = *$glob;
        *{$pkg.'::'.$sym} = *glob{CODE} if *glob{CODE};
    }

    return 1;
}

sub _thieve_isa {
    my($mixin, $pkg, $with) = @_;

    @{$pkg.'::ISA'} = grep $_ ne $with, @{$mixin.'::ISA'};

    return 1;
}


sub _croak {
    require Carp;
    goto &Carp::croak;
}

sub _carp {
    require Carp;
    goto &Carp::carp;
}


=head1 AUTHOR

Michael G Schwern E<lt>schwern@pobox.comE<gt>

=cut

1;
1	package mixin;
2
3	use strict;
4	no strict 'refs';
5	use vars qw($VERSION);
6	$VERSION = '0.04';
7
8
9	=head1 NAME
10
11	mixin - Mix-in inheritance, an alternative to multiple inheritance
12
13	=head1 SYNOPSIS
14
15	package Dog;
16	sub speak { print "Bark!\n" }
17	sub new { my $class = shift; bless {}, $class }
18
19	package Dog::Small;
20	use base 'Dog';
21	sub speak { print "Yip!\n"; }
22
23	package Dog::Retriever;
24	use mixin::with 'Dog';
25	sub fetch { print "Get your own stinking $_[1]\n" }
26
27	package Dog::Small::Retriever;
28	use base 'Dog::Small';
29	use mixin 'Dog::Retriever';
30
31	my $small_retriever = Dog::Small::Retriever->new;
32	$small_retriever->speak; # Yip!
33	$small_retriever->fetch('ball'); # Get your own stinking ball
34
35	=head1 DESCRIPTION
36
37	Mixin inheritance is an alternative to the usual multiple-inheritance
38	and solves the problem of knowing which parent will be called.
39	It also solves a number of tricky problems like diamond inheritence.
40
41	The idea is to solve the same sets of problems which MI solves without
42	the problems of MI.
43
44	=head2 Using a mixin class.
45
46	There are two steps to using a mixin-class.
47
48	First, make sure you are inherited from the class with which the
49	mixin-class is to be mixed.
50
51	package Dog::Small::Retriever;
52	use base 'Dog::Small';
53
54	Since Dog::Small isa Dog, that does it. Then simply mixin the new
55	functionality
56
57	use mixin 'Dog::Retriever';
58
59	and now you can use fetch().
60
61
62	=cut
63
64	sub import {
65	my($class, @mixins) = @_;
66	my $caller = caller;
67
68	foreach my $mixin (@mixins) {
69	# XXX This is lousy, but it will do for now.
70	unless( defined ${$mixin.'::VERSION'} ) {
71	eval qq{ require $mixin; };
72	}
73	_mixup($mixin, $caller);
74	}
75	}
76
77	sub _mixup {
78	my($mixin, $caller) = @_;
79
80	require mixin::with;
81	my($with, $pkg) = mixin::with->__mixers($mixin);
82
83	_croak("$mixin is not a mixin") unless $with;
84	_croak("$caller must be a subclass of $with")
85	unless $caller->isa($with);
86
87	# This has to happen here and not in mixin::with because "use
88	# mixin::with" typically runs before the rest of the mixin's
89	# subroutines are declared.
90	_thieve_public_methods( $mixin, $pkg );
91	_thieve_isa( $mixin, $pkg, $with );
92
93	unshift @{$caller.'::ISA'}, $pkg;
94	}
95
96
97	my %Thieved = ();
98	sub _thieve_public_methods {
99	my($mixin, $pkg) = @_;
100
101	return if $Thieved{$mixin}++;
102
103	local *glob;
104	while( my($sym, $glob) = each %{$mixin.'::'}) {
105	next if $sym =~ /^_/;
106	next unless defined $glob;
107	glob = $glob;
108	{$pkg.'::'.$sym} = glob{CODE} if *glob{CODE};
109	}
110
111	return 1;
112	}
113
114	sub _thieve_isa {
115	my($mixin, $pkg, $with) = @_;
116
117	@{$pkg.'::ISA'} = grep $_ ne $with, @{$mixin.'::ISA'};
118
119	return 1;
120	}
121
122
123	sub _croak {
124	require Carp;
125	goto &Carp::croak;
126	}
127
128	sub _carp {
129	require Carp;
130	goto &Carp::carp;
131	}
132
133
134	=head1 AUTHOR
135
136	Michael G Schwern E<lt>schwern@pobox.comE<gt>
137
138	=cut
139
140	1;
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26