optional => {},
build_requires => {
'Test::More' => '0.47',
- 'Test::Exception' => 0.15,
},
create_makefile_pl => 'traditional',
create_readme => 1,
=head1 NAME
-Class::C3::XS - The XS implementation of Class::C3
+Class::C3::XS - XS speedups for Class::C3
+
+=head1 SUMMARY
+
+ use Class::C3; # Automatically loads Class::C3::XS
+ # if it's installed locally
=head1 DESCRIPTION
-This is the XS implementation of L<Class::C3>. The main L<Class::C3> package will
-first attempt to load L<Class::C3::XS>, and then failing that, will fall back to
-L<Class::C3::PurePerl>. Do not use this package directly, use L<Class::C3> instead.
+This contains XS performance enhancers for L<Class::C3>.
+The main L<Class::C3> package will use this package automatically
+if it can find it. Do not use this package directly, use
+L<Class::C3> instead.
=head1 AUTHOR
=cut
-package # hide me from PAUSE
- Class::C3;
-
-use strict;
-use warnings;
-
-use Scalar::Util 'blessed';
-use Algorithm::C3;
-
-# 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>
-# },
-# has_overload_fallback => (1 | 0)
-# }
-#
-our %MRO;
-
-# use these for debugging ...
-sub _dump_MRO_table { %MRO }
-our $TURN_OFF_C3 = 0;
-
-# state tracking for initialize()/uninitialize()
-our $_initialized = 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 unless exists $MRO{$class};
-}
-
-## initializers
-
-sub initialize {
- # why bother if we don't have anything ...
- return unless keys %MRO;
- if($_initialized) {
- uninitialize();
- $MRO{$_} = undef foreach keys %MRO;
- }
- _calculate_method_dispatch_tables();
- _apply_method_dispatch_tables();
- %next::METHOD_CACHE = ();
- $_initialized = 1;
-}
-
-sub uninitialize {
- # why bother if we don't have anything ...
- return unless keys %MRO;
- _remove_method_dispatch_tables();
- %next::METHOD_CACHE = ();
- $_initialized = 0;
-}
-
-sub reinitialize { goto &initialize }
-
-## functions for applying C3 to classes
-
-sub _calculate_method_dispatch_tables {
- my %merge_cache;
- foreach my $class (keys %MRO) {
- _calculate_method_dispatch_table($class, \%merge_cache);
- }
-}
-
-sub _calculate_method_dispatch_table {
- my ($class, $merge_cache) = @_;
- no strict 'refs';
- my @MRO = calculateMRO($class, $merge_cache);
- $MRO{$class} = { MRO => \@MRO };
- my $has_overload_fallback = 0;
- 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]) {
- # if overload has tagged this module to
- # have use "fallback", then we want to
- # grab that value
- $has_overload_fallback = ${"${local}::()"}
- if defined ${"${local}::()"};
- 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;
- $MRO{$class}->{has_overload_fallback} = $has_overload_fallback;
-}
-
-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';
- ${"${class}::()"} = $MRO{$class}->{has_overload_fallback}
- if $MRO{$class}->{has_overload_fallback};
- foreach my $method (keys %{$MRO{$class}->{methods}}) {
- *{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code};
- }
-}
-
-sub _remove_method_dispatch_tables {
- foreach my $class (keys %MRO) {
- _remove_method_dispatch_table($class);
- }
-}
-
-sub _remove_method_dispatch_table {
- my $class = shift;
- no strict 'refs';
- delete ${"${class}::"}{"()"} if $MRO{$class}->{has_overload_fallback};
- foreach my $method (keys %{$MRO{$class}->{methods}}) {
- delete ${"${class}::"}{$method}
- if defined *{"${class}::${method}"}{CODE} &&
- (*{"${class}::${method}"}{CODE} eq $MRO{$class}->{methods}->{$method}->{code});
- }
-}
-
-## functions for calculating C3 MRO
-
-sub calculateMRO {
- my ($class, $merge_cache) = @_;
- return Algorithm::C3::merge($class, sub {
- no strict 'refs';
- @{$_[0] . '::ISA'};
- }, $merge_cache);
-}
-
-package # hide me from PAUSE
- next;
-
-use strict;
-use warnings;
-
-our $VERSION = 0.15;
-
-use Scalar::Util 'blessed';
-
-our %METHOD_CACHE;
-
-sub method {
- my $indirect = caller() =~ /^(?:next|maybe::next)$/;
- my $level = $indirect ? 2 : 1;
-
- my ($method_caller, $label, @label);
- while ($method_caller = (caller($level++))[3]) {
- @label = (split '::', $method_caller);
- $label = pop @label;
- last unless
- $label eq '(eval)' ||
- $label eq '__ANON__';
- }
- my $caller = join '::' => @label;
- my $self = $_[0];
- my $class = blessed($self) || $self;
-
- my $method = $METHOD_CACHE{"$class|$caller|$label"} ||= do {
-
- my @MRO = Class::C3::calculateMRO($class);
-
- my $current;
- while ($current = shift @MRO) {
- last if $caller eq $current;
- }
-
- no strict 'refs';
- my $found;
- foreach my $class (@MRO) {
- next if (defined $Class::C3::MRO{$class} &&
- defined $Class::C3::MRO{$class}{methods}{$label});
- last if (defined ($found = *{$class . '::' . $label}{CODE}));
- }
-
- $found;
- };
-
- return $method if $indirect;
-
- die "No next::method '$label' found for $self" if !$method;
-
- goto &{$method};
-}
-
-sub can { method($_[0]) }
-
-package # hide me from PAUSE
- maybe::next;
-
-use strict;
-use warnings;
-
-our $VERSION = 0.15;
-
-sub method { (next::method($_[0]) || return)->(@_) }
+# TODO: put XSLoader stuff here
+# TODO: shut off redef warnings and set Class::C3::calculateMRO = Class::C3::XS::calculateMRO
1;
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
-
-STATIC I32
-__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
- I32 i;
- for (i = startingblock; i >= 0; i--) {
- register const PERL_CONTEXT * const cx = &cxstk[i];
- switch (CxTYPE(cx)) {
- default:
- continue;
- case CXt_EVAL:
- case CXt_SUB:
- case CXt_FORMAT:
- DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
- return i;
- }
- }
- return i;
-}
-
-MODULE = Class::C3::XS PACKAGE = next
-
-#ifdef XXX_NEW_PERL /* some sort of cpp check for a perl that has mro_linear */
-
-/* we want to define next::can, next::method, and maybe::next::method */
-
-CV*
-canxs(self)
- SV* self
- PPCODE:
- register I32 cxix = __dopoptosub_at(cxstack, cxstack_ix);
- register const PERL_CONTEXT *cx;
- register const PERL_CONTEXT *ccstack = cxstack;
- const PERL_SI *top_si = PL_curstackinfo;
- HV* selfstash;
- //sv_dump(self);
- if(sv_isobject(self)) {
- selfstash = SvSTASH(SvRV(self));
- }
- else {
- selfstash = gv_stashsv(self, 0);
- }
- assert(selfstash);
-
- for (;;) {
- /* we may be in a higher stacklevel, so dig down deeper */
- while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
- top_si = top_si->si_prev;
- ccstack = top_si->si_cxstack;
- cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
- }
- if (cxix < 0) {
- croak("next::/maybe::next:: must be used in method context");
- }
-
- /* caller() should not report the automatic calls to &DB::sub */
- if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
- continue;
-
- cx = &ccstack[cxix];
- if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
- const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
- /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
- field below is defined for any cx. */
- /* caller() should not report the automatic calls to &DB::sub */
- if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
- cx = &ccstack[dbcxix];
- }
- if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
- GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
- /* So is ccstack[dbcxix]. */
- if (isGV(cvgv)) { /* we found a real sub here */
- const char *stashname;
- const char *fq_subname;
- const char *subname;
- STRLEN fq_subname_len;
- STRLEN stashname_len;
- STRLEN subname_len;
- GV * found_gv;
- SV * const sv = sv_2mortal(newSV(0));
-
- gv_efullname3(sv, cvgv, NULL);
- fq_subname = SvPVX(sv);
- fq_subname_len = SvCUR(sv);
-/* warn("fqsubname is %s", fq_subname); */
-
- subname = strrchr(fq_subname, ':');
- if(subname) {
- subname++;
- subname_len = fq_subname_len - (subname - fq_subname);
- stashname = fq_subname;
- stashname_len = subname - fq_subname - 2;
- if(subname_len == 8 && strEQ(subname, "__ANON__")) {
- croak("Cannot use next::method/next::can/maybe::next::method from an anonymous sub");
- }
- else {
- GV** gvp;
- AV* linear_av;
- SV** linear_svp;
- SV* linear_sv;
- HV* curstash;
- GV* candidate = NULL;
- CV* cand_cv = NULL;
- const char *hvname;
- I32 items;
+/* TODO: put __calculate_mro here, from blead patch's mro_linear_c3 */
+/* TODO: put __nextcan / __poptosubat here, from blead patch */
- hvname = HvNAME_get(selfstash);
- if (!hvname)
- Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
+MODULE = Class::C3::XS PACKAGE = Class::C3::XS
- linear_av = mro_linear(selfstash); /* has ourselves at the top of the list */
- sv_2mortal((SV*)linear_av);
-
- linear_svp = AvARRAY(linear_av) + 1; /* skip over self */
- items = AvFILLp(linear_av); /* no +1, to skip over self */
-
- while (items--) {
- linear_sv = *linear_svp++;
- assert(linear_sv);
- if(strEQ(SvPVX(linear_sv), stashname)) break;
- }
-
- while (items--) {
- linear_sv = *linear_svp++;
- assert(linear_sv);
- curstash = gv_stashsv(linear_sv, FALSE);
-
- if (!curstash) {
- if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
- (void*)linear_sv, hvname);
- continue;
- }
-
- assert(curstash);
-
- gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
- if (!gvp) continue;
- candidate = *gvp;
- assert(candidate);
- if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, curstash, subname, subname_len, TRUE);
- if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
- PUSHs((SV*)cand_cv);
- return;
- }
- }
-
- /* Check UNIVERSAL without caching */
- if((candidate = gv_fetchmeth(NULL, subname, subname_len, 1))) {
- PUSHs((SV*)GvCV(candidate));
- return;
- }
- PUSHs(&PL_sv_undef);
- return;
- }
- }
- }
- }
-
- cxix = __dopoptosub_at(ccstack, cxix - 1);
- }
+/* TODO: put calculateMRO here, uses __calculate_mro */
+
+MODULE = Class::C3::XS PACKAGE = next
+/* TODO: put next::method / next::can here */
-#else /* mro_linear stuff not in core, so do some helpers for the pure-perl variant */
+MODULE = Class::C3::XS PACKAGE = maybe
-/* we want to define two helper functions:
- 1) A replacement for Alg::C3::merge based on mro_linear_c3, but without the mro_meta caching parts.
- it should have optional merge cache support just like Alg::C3 does, but only support @ISA, not
- generic parents. Call it Class::C3::calculateMRO_XS or something.
- 2) A fast "fetch the most recent caller's package/sub-names", based on the xs can function above,
- to speed up the top half of pure-perl next::method.
-*/
-#endif
+/* TODO: put maybe::next::method here */
use Test::More tests => 1;
BEGIN {
- use_ok('Class::C3');
-}
\ No newline at end of file
+ use_ok('Class::C3::XS');
+}
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 11;
-
-BEGIN {
- use_ok('Class::C3');
- # uncomment this line, and re-run the
- # test to see the normal p5 dispatch order
- #$Class::C3::TURN_OFF_C3 = 1;
-}
-
-=pod
-
-This tests the classic diamond inheritence pattern.
-
- <A>
- / \
-<B> <C>
- \ /
- <D>
-
-=cut
-
-{
- package Diamond_A;
- use Class::C3;
- sub hello { 'Diamond_A::hello' }
-}
-{
- package Diamond_B;
- use base 'Diamond_A';
- use Class::C3;
-}
-{
- package Diamond_C;
- use Class::C3;
- use base 'Diamond_A';
-
- sub hello { 'Diamond_C::hello' }
-}
-{
- package Diamond_D;
- use base ('Diamond_B', 'Diamond_C');
- use Class::C3;
-}
-
-Class::C3::initialize();
-
-
-is_deeply(
- [ Class::C3::calculateMRO('Diamond_D') ],
- [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
- '... got the right MRO for Diamond_D');
-
-is(Diamond_D->hello, 'Diamond_C::hello', '... method resolved itself as expected');
-
-is(Diamond_D->can('hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected');
-is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected');
-
-# now undo the C3
-Class::C3::uninitialize();
-
-is(Diamond_D->hello, 'Diamond_A::hello', '... old method resolution has been restored');
-
-is(Diamond_D->can('hello')->(), 'Diamond_A::hello', '... can(method) resolution has been restored');
-is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_A::hello', '... can(method) resolution has been restored');
-
-Class::C3::initialize();
-
-is(Diamond_D->hello, 'Diamond_C::hello', '... C3 method restored itself as expected');
-
-is(Diamond_D->can('hello')->(), 'Diamond_C::hello', '... C3 can(method) restored itself as expected');
-is(UNIVERSAL::can("Diamond_D", 'hello')->(), 'Diamond_C::hello', '... C3 can(method) restored itself as expected');
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 15;
-
-BEGIN {
- use_ok('Class::C3');
- # uncomment this line, and re-run the
- # test to see the normal p5 dispatch order
- #$Class::C3::TURN_OFF_C3 = 1;
-}
-
-=pod
-
-This example is take from: http://www.python.org/2.3/mro.html
-
-"My first example"
-class O: pass
-class F(O): pass
-class E(O): pass
-class D(O): pass
-class C(D,F): pass
-class B(D,E): pass
-class A(B,C): pass
-
-
- 6
- ---
-Level 3 | O | (more general)
- / --- \
- / | \ |
- / | \ |
- / | \ |
- --- --- --- |
-Level 2 3 | D | 4| E | | F | 5 |
- --- --- --- |
- \ \ _ / | |
- \ / \ _ | |
- \ / \ | |
- --- --- |
-Level 1 1 | B | | C | 2 |
- --- --- |
- \ / |
- \ / \ /
- ---
-Level 0 0 | A | (more specialized)
- ---
-
-=cut
-
-{
- package Test::O;
- use Class::C3;
-
- package Test::F;
- use Class::C3;
- use base 'Test::O';
-
- package Test::E;
- use base 'Test::O';
- use Class::C3;
-
- sub C_or_E { 'Test::E' }
-
- package Test::D;
- use Class::C3;
- use base 'Test::O';
-
- sub C_or_D { 'Test::D' }
-
- package Test::C;
- use base ('Test::D', 'Test::F');
- use Class::C3;
-
- sub C_or_D { 'Test::C' }
- sub C_or_E { 'Test::C' }
-
- package Test::B;
- use Class::C3;
- use base ('Test::D', 'Test::E');
-
- package Test::A;
- use base ('Test::B', 'Test::C');
- use Class::C3;
-}
-
-Class::C3::initialize();
-
-is_deeply(
- [ Class::C3::calculateMRO('Test::F') ],
- [ qw(Test::F Test::O) ],
- '... got the right MRO for Test::F');
-
-is_deeply(
- [ Class::C3::calculateMRO('Test::E') ],
- [ qw(Test::E Test::O) ],
- '... got the right MRO for Test::E');
-
-is_deeply(
- [ Class::C3::calculateMRO('Test::D') ],
- [ qw(Test::D Test::O) ],
- '... got the right MRO for Test::D');
-
-is_deeply(
- [ Class::C3::calculateMRO('Test::C') ],
- [ qw(Test::C Test::D Test::F Test::O) ],
- '... got the right MRO for Test::C');
-
-is_deeply(
- [ Class::C3::calculateMRO('Test::B') ],
- [ qw(Test::B Test::D Test::E Test::O) ],
- '... got the right MRO for Test::B');
-
-is_deeply(
- [ Class::C3::calculateMRO('Test::A') ],
- [ qw(Test::A Test::B Test::C Test::D Test::E Test::F Test::O) ],
- '... got the right MRO for Test::A');
-
-is(Test::A->C_or_D, 'Test::C', '... got the expected method output');
-is(Test::A->can('C_or_D')->(), 'Test::C', '... can got the expected method output');
-
-is(Test::A->C_or_E, 'Test::C', '... got the expected method output');
-is(Test::A->can('C_or_E')->(), 'Test::C', '... can got the expected method output');
-
-# remove the C3
-Class::C3::uninitialize();
-
-is(Test::A->C_or_D, 'Test::D', '... old method resolution has been restored');
-is(Test::A->can('C_or_D')->(), 'Test::D', '... old can(method) resolution has been restored');
-
-is(Test::A->C_or_E, 'Test::E', '... old method resolution has been restored');
-is(Test::A->can('C_or_E')->(), 'Test::E', '... old can(method) resolution has been restored');
-
-
\ No newline at end of file
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 8;
-
-BEGIN {
- use_ok('Class::C3');
- # uncomment this line, and re-run the
- # test to see the normal p5 dispatch order
- #$Class::C3::TURN_OFF_C3 = 1;
-}
-
-=pod
-
-
-This example is take from: http://www.python.org/2.3/mro.html
-
-"My second example"
-class O: pass
-class F(O): pass
-class E(O): pass
-class D(O): pass
-class C(D,F): pass
-class B(E,D): pass
-class A(B,C): pass
-
- 6
- ---
-Level 3 | O |
- / --- \
- / | \
- / | \
- / | \
- --- --- ---
-Level 2 2 | E | 4 | D | | F | 5
- --- --- ---
- \ / \ /
- \ / \ /
- \ / \ /
- --- ---
-Level 1 1 | B | | C | 3
- --- ---
- \ /
- \ /
- ---
-Level 0 0 | A |
- ---
-
->>> A.mro()
-(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
-<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
-<type 'object'>)
-
-=cut
-
-{
- package Test::O;
- use Class::C3;
-
- sub O_or_D { 'Test::O' }
- sub O_or_F { 'Test::O' }
-
- package Test::F;
- use base 'Test::O';
- use Class::C3;
-
- sub O_or_F { 'Test::F' }
-
- package Test::E;
- use base 'Test::O';
- use Class::C3;
-
- package Test::D;
- use base 'Test::O';
- use Class::C3;
-
- sub O_or_D { 'Test::D' }
- sub C_or_D { 'Test::D' }
-
- package Test::C;
- use base ('Test::D', 'Test::F');
- use Class::C3;
-
- sub C_or_D { 'Test::C' }
-
- package Test::B;
- use base ('Test::E', 'Test::D');
- use Class::C3;
-
- package Test::A;
- use base ('Test::B', 'Test::C');
- use Class::C3;
-}
-
-Class::C3::initialize();
-
-is_deeply(
- [ Class::C3::calculateMRO('Test::A') ],
- [ qw(Test::A Test::B Test::E Test::C Test::D Test::F Test::O) ],
- '... got the right MRO for Test::A');
-
-is(Test::A->O_or_D, 'Test::D', '... got the right method dispatch');
-is(Test::A->O_or_F, 'Test::F', '... got the right method dispatch');
-
-# NOTE:
-# this test is particularly interesting because the p5 dispatch
-# would actually call Test::D before Test::C and Test::D is a
-# subclass of Test::C
-is(Test::A->C_or_D, 'Test::C', '... got the right method dispatch');
-
-Class::C3::uninitialize();
-
-is(Test::A->O_or_D, 'Test::O', '... old dispatch order is restored');
-is(Test::A->O_or_F, 'Test::O', '... old dispatch order is restored');
-is(Test::A->C_or_D, 'Test::D', '... old dispatch order is restored');
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 2;
-
-BEGIN {
- use lib 'opt', '../opt', '..';
- use_ok('c3');
-}
-
-=pod
-
-example taken from: L<http://gauss.gwydiondylan.org/books/drm/drm_50.html>
-
- Object
- ^
- |
- LifeForm
- ^ ^
- / \
- Sentient BiPedal
- ^ ^
- | |
- Intelligent Humanoid
- ^ ^
- \ /
- Vulcan
-
- define class <sentient> (<life-form>) end class;
- define class <bipedal> (<life-form>) end class;
- define class <intelligent> (<sentient>) end class;
- define class <humanoid> (<bipedal>) end class;
- define class <vulcan> (<intelligent>, <humanoid>) end class;
-
-=cut
-
-{
- package Object;
- use c3;
-
- package LifeForm;
- use c3;
- use base 'Object';
-
- package Sentient;
- use c3;
- use base 'LifeForm';
-
- package BiPedal;
- use c3;
- use base 'LifeForm';
-
- package Intelligent;
- use c3;
- use base 'Sentient';
-
- package Humanoid;
- use c3;
- use base 'BiPedal';
-
- package Vulcan;
- use c3;
- use base ('Intelligent', 'Humanoid');
-}
-
-Class::C3::initialize();
-
-is_deeply(
- [ c3::calculateMRO('Vulcan') ],
- [ qw(Vulcan Intelligent Sentient Humanoid BiPedal LifeForm Object) ],
- '... got the right MRO for the Vulcan Dylan Example');
\ No newline at end of file
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 3;
-
-BEGIN {
- use lib 'opt', '../opt', '..';
- use_ok('c3');
- use_ok('t::lib::F');
-}
-
-=pod
-
-From the parrot test t/pmc/object-meths.t
-
- A B A E
- \ / \ /
- C D
- \ /
- \ /
- F
-
-=cut
-
-Class::C3::initialize();
-
-is_deeply(
- [ c3::calculateMRO('t::lib::F') ],
- [ qw(t::lib::F t::lib::C t::lib::D t::lib::A t::lib::B t::lib::E) ],
- '... got the right MRO for t::lib::F');
-
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 3;
-
-BEGIN {
- use_ok('Class::C3');
- # uncomment this line, and re-run the
- # test to see the normal p5 dispatch order
- #$Class::C3::TURN_OFF_C3 = 1;
-}
-
-=pod
-
-This tests a strange bug found by Matt S. Trout
-while building DBIx::Class. Thanks Matt!!!!
-
- <A>
- / \
-<C> <B>
- \ /
- <D>
-
-=cut
-
-{
- package Diamond_A;
- use Class::C3;
-
- sub foo { 'Diamond_A::foo' }
-}
-{
- package Diamond_B;
- use base 'Diamond_A';
- use Class::C3;
-
- sub foo { 'Diamond_B::foo => ' . (shift)->next::method }
-}
-{
- package Diamond_C;
- use Class::C3;
- use base 'Diamond_A';
-
-}
-{
- package Diamond_D;
- use base ('Diamond_C', 'Diamond_B');
- use Class::C3;
-
- sub foo { 'Diamond_D::foo => ' . (shift)->next::method }
-}
-
-Class::C3::initialize();
-
-is_deeply(
- [ Class::C3::calculateMRO('Diamond_D') ],
- [ qw(Diamond_D Diamond_C Diamond_B Diamond_A) ],
- '... got the right MRO for Diamond_D');
-
-is(Diamond_D->foo,
- 'Diamond_D::foo => Diamond_B::foo => Diamond_A::foo',
- '... got the right next::method dispatch path');
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 2;
-
-BEGIN {
- use_ok('Class::C3');
-}
-
-=pod
-
-This example is take from: http://www.python.org/2.3/mro.html
-
-"Serious order disagreement" # From Guido
-class O: pass
-class X(O): pass
-class Y(O): pass
-class A(X,Y): pass
-class B(Y,X): pass
-try:
- class Z(A,B): pass #creates Z(A,B) in Python 2.2
-except TypeError:
- pass # Z(A,B) cannot be created in Python 2.3
-
-=cut
-
-{
- package X;
- use Class::C3;
-
- package Y;
- use Class::C3;
-
- package XY;
- use Class::C3;
- use base ('X', 'Y');
-
- package YX;
- use Class::C3;
- use base ('Y', 'X');
-
- package Z;
- # use Class::C3; << Dont do this just yet ...
- use base ('XY', 'YX');
-}
-
-Class::C3::initialize();
-
-eval {
- # now try to calculate the MRO
- # and watch it explode :)
- Class::C3::calculateMRO('Z')
-};
-#diag $@;
-like($@, qr/^Inconsistent hierarchy/, '... got the right error with an inconsistent hierarchy');
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 5;
-
-BEGIN {
- use_ok('Class::C3');
- # uncomment this line, and re-run the
- # test to see the normal p5 dispatch order
- #$Class::C3::TURN_OFF_C3 = 1;
-}
-
-=pod
-
-Start with this:
-
- <A>
- / \
-<B> <C>
- \ /
- <D>
-
-=cut
-
-{
- package Diamond_A;
- use Class::C3;
- sub hello { 'Diamond_A::hello' }
-}
-{
- package Diamond_B;
- use base 'Diamond_A';
- use Class::C3;
-}
-{
- package Diamond_C;
- use Class::C3;
- use base 'Diamond_A';
- sub hello { 'Diamond_C::hello' }
-}
-{
- package Diamond_D;
- use base ('Diamond_B', 'Diamond_C');
- use Class::C3;
-}
-
-Class::C3::initialize();
-
-is_deeply(
- [ Class::C3::calculateMRO('Diamond_D') ],
- [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
- '... got the right MRO for Diamond_D');
-
-=pod
-
-Then change it to this:
-
-<E> <A>
- \ / \
- <B> <C>
- \ /
- <D>
-
-=cut
-
-{
- package Diamond_E;
- use Class::C3;
- sub hello { 'Diamond_E::hello' }
-}
-
-{
- no strict 'refs';
- unshift @{"Diamond_B::ISA"} => 'Diamond_E';
-}
-
-is_deeply(
- [ Class::C3::calculateMRO('Diamond_D') ],
- [ qw(Diamond_D Diamond_B Diamond_E Diamond_C Diamond_A) ],
- '... got the new MRO for Diamond_D');
-
-is(Diamond_D->hello, 'Diamond_C::hello', '... method still resolves with old MRO');
-
-Class::C3::reinitialize();
-
-is(Diamond_D->hello, 'Diamond_E::hello', '... method resolves with reinitialized MRO');
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 8;
-
-BEGIN {
- use_ok('Class::C3');
-}
-
-{
- package BaseTest;
- use strict;
- use warnings;
- use Class::C3;
-
- package OverloadingTest;
- use strict;
- use warnings;
- use Class::C3;
- use base 'BaseTest';
- use overload '""' => sub { ref(shift) . " stringified" },
- fallback => 1;
-
- sub new { bless {} => shift }
-
- package InheritingFromOverloadedTest;
- use strict;
- use warnings;
- use base 'OverloadingTest';
- use Class::C3;
-}
-
-Class::C3::initialize();
-
-my $x = InheritingFromOverloadedTest->new();
-isa_ok($x, 'InheritingFromOverloadedTest');
-
-my $y = OverloadingTest->new();
-isa_ok($y, 'OverloadingTest');
-
-is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
-is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
-
-ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly');
-
-my $result;
-eval {
- $result = $x eq 'InheritingFromOverloadedTest stringified'
-};
-ok(!$@, '... this should not throw an exception');
-ok($result, '... and we should get the true value');
-
-#use Data::Dumper;
-#diag Dumper { Class::C3::_dump_MRO_table }
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 12;
-
-BEGIN {
- use_ok('Class::C3');
- # uncomment this line, and re-run the
- # test to see the normal p5 dispatch order
- #$Class::C3::TURN_OFF_C3 = 1;
-}
-
-=pod
-
- <A>
- / \
-<B> <C>
- \ /
- <D>
-
-=cut
-
-{
- package Diamond_A;
- use Class::C3;
- sub hello { 'Diamond_A::hello' }
-}
-{
- package Diamond_B;
- use base 'Diamond_A';
- use Class::C3;
-}
-{
- package Diamond_C;
- use Class::C3;
- use base 'Diamond_A';
- sub goodbye { 'Diamond_C::goodbye' }
- sub hello { 'Diamond_C::hello' }
-}
-{
- package Diamond_D;
- use base ('Diamond_B', 'Diamond_C');
- use Class::C3;
-
- our @hello = qw(h e l l o);
- our $hello = 'hello';
- our %hello = (h => 1, e => 2, l => "3 & 4", o => 5)
-}
-
-Class::C3::initialize();
-
-is(Diamond_D->hello, 'Diamond_C::hello', '... method resolves with the correct MRO');
-is(Diamond_D->goodbye, 'Diamond_C::goodbye', '... method resolves with the correct MRO');
-
-{
- no warnings 'redefine';
- no strict 'refs';
- *{"Diamond_D::goodbye"} = sub { 'Diamond_D::goodbye' };
-}
-
-is(Diamond_D->goodbye, 'Diamond_D::goodbye', '... method overwritten');
-
-is($Diamond_D::hello, 'hello', '... our SCALAR package vars are here');
-is_deeply(
- \@Diamond_D::hello,
- [ qw(h e l l o) ],
- '... our ARRAY package vars are here');
-is_deeply(
- \%Diamond_D::hello,
- { h => 1, e => 2, l => "3 & 4", o => 5 },
- '... our HASH package vars are here');
-
-Class::C3::uninitialize();
-
-is(Diamond_D->hello, 'Diamond_A::hello', '... method resolves with reinitialized MRO');
-is(Diamond_D->goodbye, 'Diamond_D::goodbye', '... uninitialize does not mess with the manually changed method');
-
-is($Diamond_D::hello, 'hello', '... our SCALAR package vars are still here');
-is_deeply(
- \@Diamond_D::hello,
- [ qw(h e l l o) ],
- '... our ARRAY package vars are still here');
-is_deeply(
- \%Diamond_D::hello,
- { h => 1, e => 2, l => "3 & 4", o => 5 },
- '... our HASH package vars are still here');
-
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 2;
-
-BEGIN {
- use_ok('Class::C3');
-}
-
-=pod
-
-rt.cpan.org # 21558
-
-If compile-time code from another module issues a [re]initialize() part-way
-through the process of setting up own our modules, that shouldn't prevent
-our own initialize() call from working properly.
-
-=cut
-
-{
- package TestMRO::A;
- use Class::C3;
- sub testmethod { 42 }
-
- package TestMRO::B;
- use base 'TestMRO::A';
- use Class::C3;
-
- package TestMRO::C;
- use base 'TestMRO::A';
- use Class::C3;
- sub testmethod { shift->next::method + 1 }
-
- package TestMRO::D;
- BEGIN { Class::C3::initialize }
- use base 'TestMRO::B';
- use base 'TestMRO::C';
- use Class::C3;
- sub new {
- my $class = shift;
- my $self = {};
- bless $self => $class;
- }
-}
-
-Class::C3::initialize;
-is(TestMRO::D->new->testmethod, 43, 'double-initialize works ok');
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 6;
-
-BEGIN {
- use lib 'opt', '../opt', '..';
- use_ok('c3');
- # uncomment this line, and re-run the
- # test to see the normal p5 dispatch order
- #$Class::C3::TURN_OFF_C3 = 1;
-}
-
-=pod
-
-This tests the classic diamond inheritence pattern.
-
- <A>
- / \
-<B> <C>
- \ /
- <D>
-
-=cut
-
-{
- package Diamond_A;
- use c3;
- sub hello { 'Diamond_A::hello' }
- sub foo { 'Diamond_A::foo' }
-}
-{
- package Diamond_B;
- use base 'Diamond_A';
- use c3;
- sub foo { 'Diamond_B::foo => ' . (shift)->next::method() }
-}
-{
- package Diamond_C;
- use c3;
- use base 'Diamond_A';
-
- sub hello { 'Diamond_C::hello => ' . (shift)->next::method() }
- sub foo { 'Diamond_C::foo => ' . (shift)->next::method() }
-}
-{
- package Diamond_D;
- use base ('Diamond_B', 'Diamond_C');
- use c3;
-
- sub foo { 'Diamond_D::foo => ' . (shift)->next::method() }
-}
-
-Class::C3::initialize();
-
-is_deeply(
- [ Class::C3::calculateMRO('Diamond_D') ],
- [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
- '... got the right MRO for Diamond_D');
-
-is(Diamond_D->hello, 'Diamond_C::hello => Diamond_A::hello', '... method resolved itself as expected');
-
-is(Diamond_D->can('hello')->('Diamond_D'),
- 'Diamond_C::hello => Diamond_A::hello',
- '... can(method) resolved itself as expected');
-
-is(UNIVERSAL::can("Diamond_D", 'hello')->('Diamond_D'),
- 'Diamond_C::hello => Diamond_A::hello',
- '... can(method) resolved itself as expected');
-
-is(Diamond_D->foo,
- 'Diamond_D::foo => Diamond_B::foo => Diamond_C::foo => Diamond_A::foo',
- '... method foo resolved itself as expected');
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 11;
-
-BEGIN {
- use lib 'opt', '../opt', '..';
- use_ok('c3');
- # uncomment this line, and re-run the
- # test to see the normal p5 dispatch order
- #$Class::C3::TURN_OFF_C3 = 1;
-}
-
-=pod
-
-This tests the classic diamond inheritence pattern.
-
- <A>
- / \
-<B> <C>
- \ /
- <D>
-
-=cut
-
-{
- package Diamond_A;
- use c3;
- sub bar { 'Diamond_A::bar' }
- sub baz { 'Diamond_A::baz' }
-}
-{
- package Diamond_B;
- use base 'Diamond_A';
- use c3;
- sub baz { 'Diamond_B::baz => ' . (shift)->next::method() }
-}
-{
- package Diamond_C;
- use c3;
- use base 'Diamond_A';
- sub foo { 'Diamond_C::foo' }
- sub buz { 'Diamond_C::buz' }
-
- sub woz { 'Diamond_C::woz' }
- sub maybe { 'Diamond_C::maybe' }
-}
-{
- package Diamond_D;
- use base ('Diamond_B', 'Diamond_C');
- use c3;
- sub foo { 'Diamond_D::foo => ' . (shift)->next::method() }
- sub bar { 'Diamond_D::bar => ' . (shift)->next::method() }
- sub buz { 'Diamond_D::buz => ' . (shift)->baz() }
- sub fuz { 'Diamond_D::fuz => ' . (shift)->next::method() }
-
- sub woz { 'Diamond_D::woz can => ' . ((shift)->next::can() ? 1 : 0) }
- sub noz { 'Diamond_D::noz can => ' . ((shift)->next::can() ? 1 : 0) }
-
- sub maybe { 'Diamond_D::maybe => ' . ((shift)->maybe::next::method() || 0) }
- sub moybe { 'Diamond_D::moybe => ' . ((shift)->maybe::next::method() || 0) }
-
-}
-
-Class::C3::initialize();
-
-is_deeply(
- [ Class::C3::calculateMRO('Diamond_D') ],
- [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
- '... got the right MRO for Diamond_D');
-
-is(Diamond_D->foo, 'Diamond_D::foo => Diamond_C::foo', '... skipped B and went to C correctly');
-is(Diamond_D->bar, 'Diamond_D::bar => Diamond_A::bar', '... skipped B & C and went to A correctly');
-is(Diamond_D->baz, 'Diamond_B::baz => Diamond_A::baz', '... called B method, skipped C and went to A correctly');
-is(Diamond_D->buz, 'Diamond_D::buz => Diamond_B::baz => Diamond_A::baz', '... called D method dispatched to , different method correctly');
-eval { Diamond_D->fuz };
-like($@, qr/^No next::method 'fuz' found for Diamond_D/, '... cannot re-dispatch to a method which is not there');
-
-is(Diamond_D->woz, 'Diamond_D::woz can => 1', '... can re-dispatch figured out correctly');
-is(Diamond_D->noz, 'Diamond_D::noz can => 0', '... cannot re-dispatch figured out correctly');
-
-is(Diamond_D->maybe, 'Diamond_D::maybe => Diamond_C::maybe', '... redispatched D to C when it exists');
-is(Diamond_D->moybe, 'Diamond_D::moybe => 0', '... quietly failed redispatch from D');
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 12;
-
-BEGIN {
- use_ok('Class::C3');
-}
-
-{
-
- {
- package Foo;
- use strict;
- use warnings;
- use Class::C3;
- sub new { bless {}, $_[0] }
- sub bar { 'Foo::bar' }
- }
-
- # call the submethod in the direct instance
-
- my $foo = Foo->new();
- isa_ok($foo, 'Foo');
-
- can_ok($foo, 'bar');
- is($foo->bar(), 'Foo::bar', '... got the right return value');
-
- # fail calling it from a subclass
-
- {
- package Bar;
- use strict;
- use warnings;
- use Class::C3;
- our @ISA = ('Foo');
- }
-
- my $bar = Bar->new();
- isa_ok($bar, 'Bar');
- isa_ok($bar, 'Foo');
-
- # test it working with with Sub::Name
- SKIP: {
- eval 'use Sub::Name';
- skip "Sub::Name is required for this test", 3 if $@;
-
- my $m = sub { (shift)->next::method() };
- Sub::Name::subname('Bar::bar', $m);
- {
- no strict 'refs';
- *{'Bar::bar'} = $m;
- }
-
- Class::C3::initialize();
-
- can_ok($bar, 'bar');
- my $value = eval { $bar->bar() };
- ok(!$@, '... calling bar() succedded') || diag $@;
- is($value, 'Foo::bar', '... got the right return value too');
- }
-
- # test it failing without Sub::Name
- {
- package Baz;
- use strict;
- use warnings;
- use Class::C3;
- our @ISA = ('Foo');
- }
-
- my $baz = Baz->new();
- isa_ok($baz, 'Baz');
- isa_ok($baz, 'Foo');
-
- {
- my $m = sub { (shift)->next::method() };
- {
- no strict 'refs';
- *{'Baz::bar'} = $m;
- }
-
- Class::C3::initialize();
-
- eval { $baz->bar() };
- ok($@, '... calling bar() with next::method failed') || diag $@;
- }
-}
\ No newline at end of file
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More;
-
-BEGIN {
- eval "use NEXT";
- plan skip_all => "NEXT required for this test" if $@;
- plan tests => 4;
-}
-
-{
- package Foo;
- use strict;
- use warnings;
- use Class::C3;
-
- sub foo { 'Foo::foo' }
-
- package Fuz;
- use strict;
- use warnings;
- use Class::C3;
- use base 'Foo';
-
- sub foo { 'Fuz::foo => ' . (shift)->next::method }
-
- package Bar;
- use strict;
- use warnings;
- use Class::C3;
- use base 'Foo';
-
- sub foo { 'Bar::foo => ' . (shift)->next::method }
-
- package Baz;
- use strict;
- use warnings;
- require NEXT; # load this as late as possible so we can catch the test skip
-
- use base 'Bar', 'Fuz';
-
- sub foo { 'Baz::foo => ' . (shift)->NEXT::foo }
-}
-
-Class::C3::initialize();
-
-is(Foo->foo, 'Foo::foo', '... got the right value from Foo->foo');
-is(Fuz->foo, 'Fuz::foo => Foo::foo', '... got the right value from Fuz->foo');
-is(Bar->foo, 'Bar::foo => Foo::foo', '... got the right value from Bar->foo');
-
-is(Baz->foo, 'Baz::foo => Bar::foo => Fuz::foo => Foo::foo', '... got the right value using NEXT in a subclass of a C3 class');
-
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 2;
-
-BEGIN {
- use lib 'opt', '../opt', '..';
- use_ok('c3');
-}
-
-=pod
-
-This tests the use of an eval{} block to wrap a next::method call.
-
-=cut
-
-{
- package A;
- use c3;
-
- sub foo {
- die 'A::foo died';
- return 'A::foo succeeded';
- }
-}
-
-{
- package B;
- use base 'A';
- use c3;
-
- sub foo {
- eval {
- return 'B::foo => ' . (shift)->next::method();
- };
-
- if ($@) {
- return $@;
- }
- }
-}
-
-Class::C3::initialize();
-
-like(B->foo,
- qr/^A::foo died/,
- 'method resolved inside eval{}');
-
-
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use warnings;
-
-use Test::More tests => 3;
-
-BEGIN {
- use lib 'opt', '../opt', '../blib/lib';
- use_ok('c3');
-}
-
-=pod
-
-This tests the successful handling of a next::method call from within an
-anonymous subroutine.
-
-=cut
-
-{
- package A;
- use c3;
-
- sub foo {
- return 'A::foo';
- }
-
- sub bar {
- return 'A::bar';
- }
-}
-
-{
- package B;
- use base 'A';
- use c3;
-
- sub foo {
- my $code = sub {
- return 'B::foo => ' . (shift)->next::method();
- };
- return (shift)->$code;
- }
-
- sub bar {
- my $code1 = sub {
- my $code2 = sub {
- return 'B::bar => ' . (shift)->next::method();
- };
- return (shift)->$code2;
- };
- return (shift)->$code1;
- }
-}
-
-Class::C3::initialize();
-
-is(B->foo, "B::foo => A::foo",
- 'method resolved inside anonymous sub');
-
-is(B->bar, "B::bar => A::bar",
- 'method resolved inside nested anonymous subs');
-
-
+++ /dev/null
-package t::lib::A;
-use c3;
-1;
\ No newline at end of file
+++ /dev/null
-package t::lib::B;
-use c3;
-1;
\ No newline at end of file
+++ /dev/null
-package t::lib::C;
-use c3;
-use base ('t::lib::A', 't::lib::B');
-1;
\ No newline at end of file
+++ /dev/null
-package t::lib::D;
-use c3;
-use base ('t::lib::A', 't::lib::E');
-1;
\ No newline at end of file
+++ /dev/null
-package t::lib::E;
-use c3;
-1;
\ No newline at end of file
+++ /dev/null
-package t::lib::F;
-use c3;
-use base ('t::lib::C', 't::lib::D');
-1;
\ No newline at end of file
projects / gitmo/Class-C3-XS.git / commitdiff