[gitmo/Class-C3.git] / lib / Class / C3.pm


package Class::C3;

use strict;
use warnings;

use Scalar::Util 'blessed';

our $VERSION = '0.02';

# this is our global stash of both 
# MRO's and method dispatch tables
# the structure basically looks like
# this:
#
#   $MRO{$class} = {
#      MRO => [ <class precendence list> ],
#      methods => {
#          orig => <original location of method>,
#          code => \&<ref to original method>
#      }
#   }
#
my %MRO;

# use this for debugging ...
sub _dump_MRO_table { %MRO }

our $TURN_OFF_C3 = 0;

sub import {
    my $class = caller();
    # skip if the caller is main::
    # since that is clearly not relevant
    return if $class eq 'main';
    return if $TURN_OFF_C3;
    # make a note to calculate $class 
    # during INIT phase
    $MRO{$class} = undef;
}

## initializers

# NOTE:
# this will not run under the following
# conditions:
#  - mod_perl
#  - require Class::C3;
#  - eval "use Class::C3"
# in all those cases, you need to call 
# the initialize() function manually
INIT { initialize() }

sub initialize {
    # why bother if we don't have anything ...
    return unless keys %MRO;
    _calculate_method_dispatch_tables();
    _apply_method_dispatch_tables();
}

## functions for applying C3 to classes

sub _calculate_method_dispatch_tables {
    foreach my $class (keys %MRO) {
        _calculate_method_dispatch_table($class);
    }
}

sub _calculate_method_dispatch_table {
    my $class = shift;
    no strict 'refs';
    my @MRO = calculateMRO($class);
    $MRO{$class} = { MRO => \@MRO };
    my %methods;
    # NOTE: 
    # we do @MRO[1 .. $#MRO] here because it
    # makes no sense to interogate the class
    # which you are calculating for. 
    foreach my $local (@MRO[1 .. $#MRO]) {
        foreach my $method (grep { defined &{"${local}::$_"} } keys %{"${local}::"}) {
            # skip if already overriden in local class
            next unless !defined *{"${class}::$method"}{CODE};
            $methods{$method} = {
                orig => "${local}::$method",
                code => \&{"${local}::$method"}
            } unless exists $methods{$method};
        }
    }    
    # now stash them in our %MRO table
    $MRO{$class}->{methods} = \%methods;    
}

sub _apply_method_dispatch_tables {
    foreach my $class (keys %MRO) {
        _apply_method_dispatch_table($class);
    }     
}

sub _apply_method_dispatch_table {
    my $class = shift;
    no strict 'refs';
    foreach my $method (keys %{$MRO{$class}->{methods}}) {
        *{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code};
    }    
}

## functions for calculating C3 MRO

# this function is a perl-port of the 
# python code on this page:
#   http://www.python.org/2.3/mro.html
sub _merge {                
    my (@seqs) = @_;
    my @res; 
    while (1) {
        # remove all empty seqences
        my @nonemptyseqs = (map { (@{$_} ? $_ : ()) } @seqs);
        # return the list if we have no more no-empty sequences
        return @res if not @nonemptyseqs; 
        my $cand; # a canidate ..
        foreach my $seq (@nonemptyseqs) {
            $cand = $seq->[0]; # get the head of the list
            my $nothead;            
            foreach my $sub_seq (@nonemptyseqs) {
                # XXX - this is instead of the python "in"
                my %in_tail = (map { $_ => 1 } @{$sub_seq}[ 1 .. $#{$sub_seq} ]);
                # NOTE:
                # jump out as soon as we find one matching
                # there is no reason not too. However, if 
                # we find one, then just remove the '&& last'
                $nothead++ && last if exists $in_tail{$cand};      
            }
            last unless $nothead; # leave the loop with our canidate ...
            $cand = undef;        # otherwise, reject it ...
        }
        die "Inconsistent hierarchy" if not $cand;
        push @res => $cand;
        # now loop through our non-empties and pop 
        # off the head if it matches our canidate
        foreach my $seq (@nonemptyseqs) {
            shift @{$seq} if $seq->[0] eq $cand;
        }
    }
}

sub calculateMRO {
    my ($class) = @_;
    no strict 'refs';
    return _merge(
        [ $class ],                                        # the class we are linearizing
        (map { [ calculateMRO($_) ] } @{"${class}::ISA"}), # the MRO of all the superclasses
        [ @{"${class}::ISA"} ]                             # a list of all the superclasses    
    );
}

1;

__END__

=pod

=head1 NAME

Class::C3 - A pragma to use the C3 method resolution order algortihm

=head1 SYNOPSIS

    package A;
    use Class::C3;     
    sub hello { 'A::hello' }

    package B;
    use base 'A';
    use Class::C3;     

    package C;
    use base 'A';
    use Class::C3;     

    sub hello { 'C::hello' }

    package D;
    use base ('B', 'C');
    use Class::C3;    

    # Classic Diamond MI pattern
    #    <A>
    #   /   \
    # <B>   <C>
    #   \   /
    #    <D>

    package main;

    print join ', ' => Class::C3::calculateMRO('Diamond_D') # prints D, B, C, A

    print D->hello() # prints 'C::hello' instead of the standard p5 'A::hello'
    
    D->can('hello')->();          # can() also works correctly
    UNIVERSAL::can('D', 'hello'); # as does UNIVERSAL::can()

=head1 DESCRIPTION

This is currently an experimental pragma to change Perl 5's standard method resolution order 
from depth-first left-to-right (a.k.a - pre-order) to the more sophisticated C3 method resolution
order. 

=head2 What is C3?

C3 is the name of an algorithm which aims to provide a sane method resolution order under multiple
inheritence. It was first introduced in the langauge Dylan (see links in the L<SEE ALSO> section),
and then later adopted as the prefered MRO (Method Resolution Order) for the new-style classes in 
Python 2.3. Most recently it has been adopted as the 'canonical' MRO for Perl 6 classes, and the 
default MRO for Parrot objects as well.

=head2 How does C3 work.

C3 works by always preserving local precendence ordering. This essentially means that no class will 
appear before any of it's subclasses. Take the classic diamond inheritence pattern for instance:

     <A>
    /   \
  <B>   <C>
    \   /
     <D>

The standard Perl 5 MRO would be (D, B, A, C). The result being that B<A> appears before B<C>, even 
though B<C> is the subclass of B<A>. The C3 MRO algorithm however, produces the following MRO 
(D, B, C, A), which does not have this same issue.

This example is fairly trival, for more complex examples and a deeper explaination, see the links in
the L<SEE ALSO> section.

=head2 How does this module work?

This module uses a technique similar to Perl 5's method caching. During the INIT phase, this module 
calculates the MRO of all the classes which called C<use Class::C3>. It then gathers information from 
the symbol tables of each of those classes, and builds a set of method aliases for the correct 
dispatch ordering. Once all these C3-based method tables are created, it then adds the method aliases
into the local classes symbol table. 

The end result is actually classes with pre-cached method dispatch. However, this caching does not
do well if you start changing your C<@ISA> or messing with class symbol tables, so you should consider
your classes to be effectively closed. See the L<CAVEATS> section for more details.

=head1 OPTIONAL LOWERCASE PRAGMA

This release also includes an optional module B<c3> in the F<opt/> folder. I did not include this in 
the regular install since lowercase module names are considered I<"bad"> by some people. However I
think that code looks much nicer like this:

  package MyClass;
  use c3;
  
The the more clunky:

  package MyClass;
  use Class::C3;
  
But hey, it's your choice, thats why it is optional.

=head1 FUNCTIONS

=over 4

=item B<calculateMRO ($class)>

Given a C<$class> this will return an array of class names in the proper C3 method resolution order.

=item B<initialize>

This can be used to initalize the C3 method dispatch tables. You need to call this if you are running
under mod_perl, or in any other environment which does not run the INIT phase of the perl compiler.

NOTE: 
This can B<not> be used to re-load the dispatch tables for all classes. This is because it does not first
return the classes to their virginal state, which would need to happen in order for the dispatch tables
to be properly reloaded.

=back

=head1 CAVEATS

Let me first say, this is an experimental module, and so it should not be used for anything other 
then other experimentation for the time being. 

That said, it is the authors intention to make this into a completely usable and production stable 
module if possible. Time will tell.

And now, onto the caveats.

=over 4

=item Use of C<SUPER::>.

The idea of C<SUPER::> under multiple inheritence is ambigious, and generally not recomended anyway.
However, it's use in conjuntion with this module is very much not recommended, and in fact very 
discouraged. In the future I plan to support a C<NEXT::> style interface to be used to move to the 
next most appropriate method in the MRO.

=item Changing C<@ISA>.

It is the author's opinion that changing C<@ISA> at runtime is pure insanity anyway. However, people
do it, so I must caveat. Any changes to the C<@ISA> will not be reflected in the MRO calculated by this
module, and therefor probably won't even show up. I am considering some kind of C<recalculateMRO> function
which can be used to recalculate the MRO on demand at runtime, but that is still off in the future.

=item Adding/deleting methods from class symbol tables.

This module calculates the MRO for each requested class during the INIT phase by interogatting the symbol
tables of said classes. So any symbol table manipulation which takes place after our INIT phase is run will
not be reflected in the calculated MRO.

=back

=head1 TODO

=over 4

=item More tests

You can never have enough tests :)

I need to convert the other MRO and class-precendence-list related tests from the Perl6-MetaModel (see link
in L<SEE ALSO>). In addition, I need to add some method checks to these tests as well.

=item call-next-method / NEXT:: / next METHOD

I am contemplating some kind of psudeo-package which can dispatch to the next most relevant method in the 
MRO. This should not be too hard to implement when the time comes.

=item recalculateMRO

This being Perl, it would be remiss of me to force people to close thier classes at runtime. So I need to 
develop a means for recalculating the MRO for a given class. 

=back

=head1 SEE ALSO

=head2 The original Dylan paper

=over 4

=item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>

=back

=head2 The prototype Perl 6 Object Model uses C3

=over 4

=item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>

=back

=head2 Parrot now uses C3

=over 4

=item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>

=item L<http://use.perl.org/~autrijus/journal/25768>

=back

=head2 Python 2.3 MRO related links

=over 4

=item L<http://www.python.org/2.3/mro.html>

=item L<http://www.python.org/2.2.2/descrintro.html#mro>

=back

=head2 C3 for TinyCLOS

=over 4

=item L<http://www.call-with-current-continuation.org/eggs/c3.html>

=back 

=head1 AUTHOR

Stevan Little, E<lt>stevan@iinteractive.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2005 by Infinity Interactive, Inc.

L<http://www.iinteractive.com>

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=cut
Commit	Line	Data
95bebf8c	1
	2	package Class::C3;
	3
	4	use strict;
	5	use warnings;
	6
95bebf8c	7	use Scalar::Util 'blessed';
95bebf8c	8
d401eda1	9	our $VERSION = '0.02';
	10
	11	# this is our global stash of both
	12	# MRO's and method dispatch tables
	13	# the structure basically looks like
	14	# this:
	15	#
	16	# $MRO{$class} = {
	17	# MRO => [ <class precendence list> ],
	18	# methods => {
	19	# orig => <original location of method>,
	20	# code => \&<ref to original method>
	21	# }
	22	# }
	23	#
95bebf8c	24	my %MRO;
95bebf8c	25
d401eda1	26	# use this for debugging ...
	27	sub _dump_MRO_table { %MRO }
	28
	29	our $TURN_OFF_C3 = 0;
	30
95bebf8c	31	sub import {
95bebf8c	32	my $class = caller();
d401eda1	33	# skip if the caller is main::
d401eda1	34	# since that is clearly not relevant
95bebf8c	35	return if $class eq 'main';
d401eda1	36	return if $TURN_OFF_C3;
	37	# make a note to calculate $class
	38	# during INIT phase
95bebf8c	39	$MRO{$class} = undef;
	40	}
	41
d401eda1	42	## initializers
	43
	44	# NOTE:
	45	# this will not run under the following
	46	# conditions:
	47	# - mod_perl
	48	# - require Class::C3;
	49	# - eval "use Class::C3"
	50	# in all those cases, you need to call
	51	# the initialize() function manually
	52	INIT { initialize() }
	53
	54	sub initialize {
	55	# why bother if we don't have anything ...
	56	return unless keys %MRO;
	57	_calculate_method_dispatch_tables();
	58	_apply_method_dispatch_tables();
	59	}
	60
	61	## functions for applying C3 to classes
	62
	63	sub _calculate_method_dispatch_tables {
95bebf8c	64	foreach my $class (keys %MRO) {
d401eda1	65	_calculate_method_dispatch_table($class);
95bebf8c	66	}
d401eda1	67	}
	68
	69	sub _calculate_method_dispatch_table {
	70	my $class = shift;
	71	no strict 'refs';
	72	my @MRO = calculateMRO($class);
	73	$MRO{$class} = { MRO => \@MRO };
	74	my %methods;
	75	# NOTE:
	76	# we do @MRO[1 .. $#MRO] here because it
	77	# makes no sense to interogate the class
	78	# which you are calculating for.
	79	foreach my $local (@MRO[1 .. $#MRO]) {
	80	foreach my $method (grep { defined &{"${local}::$_"} } keys %{"${local}::"}) {
	81	# skip if already overriden in local class
	82	next unless !defined *{"${class}::$method"}{CODE};
	83	$methods{$method} = {
	84	orig => "${local}::$method",
	85	code => \&{"${local}::$method"}
	86	} unless exists $methods{$method};
95bebf8c	87	}
d401eda1	88	}
	89	# now stash them in our %MRO table
	90	$MRO{$class}->{methods} = \%methods;
	91	}
	92
	93	sub _apply_method_dispatch_tables {
	94	foreach my $class (keys %MRO) {
	95	_apply_method_dispatch_table($class);
	96	}
95bebf8c	97	}
95bebf8c	98
d401eda1	99	sub _apply_method_dispatch_table {
	100	my $class = shift;
	101	no strict 'refs';
	102	foreach my $method (keys %{$MRO{$class}->{methods}}) {
	103	*{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code};
	104	}
	105	}
	106
	107	## functions for calculating C3 MRO
	108
	109	# this function is a perl-port of the
	110	# python code on this page:
	111	# http://www.python.org/2.3/mro.html
95bebf8c	112	sub _merge {
	113	my (@seqs) = @_;
	114	my @res;
	115	while (1) {
	116	# remove all empty seqences
	117	my @nonemptyseqs = (map { (@{$_} ? $_ : ()) } @seqs);
	118	# return the list if we have no more no-empty sequences
	119	return @res if not @nonemptyseqs;
	120	my $cand; # a canidate ..
	121	foreach my $seq (@nonemptyseqs) {
	122	$cand = $seq->[0]; # get the head of the list
	123	my $nothead;
	124	foreach my $sub_seq (@nonemptyseqs) {
	125	# XXX - this is instead of the python "in"
	126	my %in_tail = (map { $_ => 1 } @{$sub_seq}[ 1 .. $#{$sub_seq} ]);
	127	# NOTE:
	128	# jump out as soon as we find one matching
	129	# there is no reason not too. However, if
	130	# we find one, then just remove the '&& last'
	131	$nothead++ && last if exists $in_tail{$cand};
	132	}
	133	last unless $nothead; # leave the loop with our canidate ...
	134	$cand = undef; # otherwise, reject it ...
	135	}
	136	die "Inconsistent hierarchy" if not $cand;
	137	push @res => $cand;
	138	# now loop through our non-empties and pop
	139	# off the head if it matches our canidate
	140	foreach my $seq (@nonemptyseqs) {
	141	shift @{$seq} if $seq->[0] eq $cand;
	142	}
	143	}
	144	}
	145
	146	sub calculateMRO {
	147	my ($class) = @_;
	148	no strict 'refs';
	149	return _merge(
	150	[ $class ], # the class we are linearizing
	151	(map { [ calculateMRO($_) ] } @{"${class}::ISA"}), # the MRO of all the superclasses
	152	[ @{"${class}::ISA"} ] # a list of all the superclasses
	153	);
	154	}
	155
	156	1;
	157
	158	__END__
	159
	160	=pod
	161
	162	=head1 NAME
	163
	164	Class::C3 - A pragma to use the C3 method resolution order algortihm
	165
	166	=head1 SYNOPSIS
	167
	168	package A;
	169	use Class::C3;
	170	sub hello { 'A::hello' }
	171
	172	package B;
	173	use base 'A';
	174	use Class::C3;
	175
176	package C;
177	use base 'A';
178	use Class::C3;
179
180	sub hello { 'C::hello' }
181
182	package D;
183	use base ('B', 'C');
184	use Class::C3;
185
186	# Classic Diamond MI pattern
d401eda1	187	# <A>
	188	# / \
	189	# <B> <C>
	190	# \ /
	191	# <D>
95bebf8c	192
	193	package main;
	194
	195	print join ', ' => Class::C3::calculateMRO('Diamond_D') # prints D, B, C, A
	196
	197	print D->hello() # prints 'C::hello' instead of the standard p5 'A::hello'
	198
	199	D->can('hello')->(); # can() also works correctly
	200	UNIVERSAL::can('D', 'hello'); # as does UNIVERSAL::can()
	201
	202	=head1 DESCRIPTION
	203
	204	This is currently an experimental pragma to change Perl 5's standard method resolution order
	205	from depth-first left-to-right (a.k.a - pre-order) to the more sophisticated C3 method resolution
	206	order.
	207
	208	=head2 What is C3?
	209
	210	C3 is the name of an algorithm which aims to provide a sane method resolution order under multiple
	211	inheritence. It was first introduced in the langauge Dylan (see links in the L<SEE ALSO> section),
	212	and then later adopted as the prefered MRO (Method Resolution Order) for the new-style classes in
	213	Python 2.3. Most recently it has been adopted as the 'canonical' MRO for Perl 6 classes, and the
	214	default MRO for Parrot objects as well.
	215
	216	=head2 How does C3 work.
	217
	218	C3 works by always preserving local precendence ordering. This essentially means that no class will
	219	appear before any of it's subclasses. Take the classic diamond inheritence pattern for instance:
	220
d401eda1	221	<A>
	222	/ \
	223	<B> <C>
	224	\ /
	225	<D>
95bebf8c	226
	227	The standard Perl 5 MRO would be (D, B, A, C). The result being that B<A> appears before B<C>, even
	228	though B<C> is the subclass of B<A>. The C3 MRO algorithm however, produces the following MRO
	229	(D, B, C, A), which does not have this same issue.
	230
	231	This example is fairly trival, for more complex examples and a deeper explaination, see the links in
	232	the L<SEE ALSO> section.
	233
	234	=head2 How does this module work?
	235
	236	This module uses a technique similar to Perl 5's method caching. During the INIT phase, this module
	237	calculates the MRO of all the classes which called C<use Class::C3>. It then gathers information from
	238	the symbol tables of each of those classes, and builds a set of method aliases for the correct
	239	dispatch ordering. Once all these C3-based method tables are created, it then adds the method aliases
	240	into the local classes symbol table.
	241
	242	The end result is actually classes with pre-cached method dispatch. However, this caching does not
	243	do well if you start changing your C<@ISA> or messing with class symbol tables, so you should consider
	244	your classes to be effectively closed. See the L<CAVEATS> section for more details.
	245
d401eda1	246	=head1 OPTIONAL LOWERCASE PRAGMA
	247
	248	This release also includes an optional module B<c3> in the F<opt/> folder. I did not include this in
	249	the regular install since lowercase module names are considered I<"bad"> by some people. However I
	250	think that code looks much nicer like this:
	251
	252	package MyClass;
	253	use c3;
	254
	255	The the more clunky:
	256
	257	package MyClass;
	258	use Class::C3;
	259
	260	But hey, it's your choice, thats why it is optional.
	261
95bebf8c	262	=head1 FUNCTIONS
	263
	264	=over 4
	265
	266	=item B<calculateMRO ($class)>
	267
	268	Given a C<$class> this will return an array of class names in the proper C3 method resolution order.
	269
d401eda1	270	=item B<initialize>
	271
	272	This can be used to initalize the C3 method dispatch tables. You need to call this if you are running
	273	under mod_perl, or in any other environment which does not run the INIT phase of the perl compiler.
	274
	275	NOTE:
	276	This can B<not> be used to re-load the dispatch tables for all classes. This is because it does not first
	277	return the classes to their virginal state, which would need to happen in order for the dispatch tables
	278	to be properly reloaded.
	279
95bebf8c	280	=back
	281
	282	=head1 CAVEATS
	283
	284	Let me first say, this is an experimental module, and so it should not be used for anything other
	285	then other experimentation for the time being.
	286
	287	That said, it is the authors intention to make this into a completely usable and production stable
	288	module if possible. Time will tell.
	289
	290	And now, onto the caveats.
	291
	292	=over 4
	293
	294	=item Use of C<SUPER::>.
	295
	296	The idea of C<SUPER::> under multiple inheritence is ambigious, and generally not recomended anyway.
	297	However, it's use in conjuntion with this module is very much not recommended, and in fact very
	298	discouraged. In the future I plan to support a C<NEXT::> style interface to be used to move to the
	299	next most appropriate method in the MRO.
	300
	301	=item Changing C<@ISA>.
	302
	303	It is the author's opinion that changing C<@ISA> at runtime is pure insanity anyway. However, people
	304	do it, so I must caveat. Any changes to the C<@ISA> will not be reflected in the MRO calculated by this
	305	module, and therefor probably won't even show up. I am considering some kind of C<recalculateMRO> function
	306	which can be used to recalculate the MRO on demand at runtime, but that is still off in the future.
	307
	308	=item Adding/deleting methods from class symbol tables.
	309
	310	This module calculates the MRO for each requested class during the INIT phase by interogatting the symbol
	311	tables of said classes. So any symbol table manipulation which takes place after our INIT phase is run will
	312	not be reflected in the calculated MRO.
	313
95bebf8c	314	=back
95bebf8c	315
15eeb546	316	=head1 TODO
	317
	318	=over 4
	319
	320	=item More tests
	321
	322	You can never have enough tests :)
	323
	324	I need to convert the other MRO and class-precendence-list related tests from the Perl6-MetaModel (see link
	325	in L<SEE ALSO>). In addition, I need to add some method checks to these tests as well.
	326
	327	=item call-next-method / NEXT:: / next METHOD
	328
	329	I am contemplating some kind of psudeo-package which can dispatch to the next most relevant method in the
	330	MRO. This should not be too hard to implement when the time comes.
	331
	332	=item recalculateMRO
	333
	334	This being Perl, it would be remiss of me to force people to close thier classes at runtime. So I need to
	335	develop a means for recalculating the MRO for a given class.
	336
	337	=back
	338
95bebf8c	339	=head1 SEE ALSO
	340
	341	=head2 The original Dylan paper
	342
	343	=over 4
	344
	345	=item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
	346
	347	=back
	348
	349	=head2 The prototype Perl 6 Object Model uses C3
	350
	351	=over 4
	352
	353	=item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
	354
	355	=back
	356
	357	=head2 Parrot now uses C3
	358
	359	=over 4
	360
	361	=item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
	362
	363	=item L<http://use.perl.org/~autrijus/journal/25768>
	364
	365	=back
	366
	367	=head2 Python 2.3 MRO related links
	368
	369	=over 4
	370
	371	=item L<http://www.python.org/2.3/mro.html>
	372
	373	=item L<http://www.python.org/2.2.2/descrintro.html#mro>
	374
	375	=back
	376
	377	=head2 C3 for TinyCLOS
	378
	379	=over 4
	380
	381	=item L<http://www.call-with-current-continuation.org/eggs/c3.html>
	382
	383	=back
	384
	385	=head1 AUTHOR
	386
d401eda1	387	Stevan Little, E<lt>stevan@iinteractive.comE<gt>
95bebf8c	388
	389	=head1 COPYRIGHT AND LICENSE
	390
	391	Copyright 2005 by Infinity Interactive, Inc.
	392
	393	L<http://www.iinteractive.com>
	394
	395	This library is free software; you can redistribute it and/or modify
	396	it under the same terms as Perl itself.
	397
	398	=cut