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_private_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 . '_public'}++;

    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_private_methods {
    my($mixin, $pkg) = @_;

    return if $Thieved{$mixin . '_private'}++;

    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_private_methods( $mixin, $pkg );
92	_thieve_isa( $mixin, $pkg, $with );
93
94	unshift @{$caller.'::ISA'}, $pkg;
95	}
96
97
98	my %Thieved = ();
99	sub _thieve_public_methods {
100	my($mixin, $pkg) = @_;
101
102	return if $Thieved{$mixin . '_public'}++;
103
104	local *glob;
105	while( my($sym, $glob) = each %{$mixin.'::'}) {
106	next if $sym =~ /^_/;
107	next unless defined $glob;
108	glob = $glob;
109	{$pkg.'::'.$sym} = glob{CODE} if *glob{CODE};
110	}
111
112	return 1;
113	}
114	sub _thieve_private_methods {
115	my($mixin, $pkg) = @_;
116
117	return if $Thieved{$mixin . '_private'}++;
118
119	local *glob;
120	while( my($sym, $glob) = each %{$mixin.'::'}) {
121	next if $sym !~ /^_/;
122	next unless defined $glob;
123	glob = $glob;
124	{$pkg.'::'.$sym} = glob{CODE} if *glob{CODE};
125	}
126
127	return 1;
128	}
129
130	sub _thieve_isa {
131	my($mixin, $pkg, $with) = @_;
132
133	@{$pkg.'::ISA'} = grep $_ ne $with, @{$mixin.'::ISA'};
134
135	return 1;
136	}
137
138
139	sub _croak {
140	require Carp;
141	goto &Carp::croak;
142	}
143
144	sub _carp {
145	require Carp;
146	goto &Carp::carp;
147	}
148
149
150	=head1 AUTHOR
151
152	Michael G Schwern E<lt>schwern@pobox.comE<gt>
153
154	=cut
155
156	1;
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26