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	joko	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