From: Brandon L Black Date: Thu, 12 Apr 2007 22:15:07 +0000 (+0000) Subject: get rid of some earlier trash, prepare for putting in the real code X-Git-Tag: 0.02~21 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FClass-C3-XS.git;a=commitdiff_plain;h=fbe8c8c4b14d12e8f2e254abe7aab98c74391920 get rid of some earlier trash, prepare for putting in the real code --- diff --git a/Build.PL b/Build.PL index 4559bb6..9af804a 100644 --- a/Build.PL +++ b/Build.PL @@ -8,7 +8,6 @@ my $build = Module::Build->new( optional => {}, build_requires => { 'Test::More' => '0.47', - 'Test::Exception' => 0.15, }, create_makefile_pl => 'traditional', create_readme => 1, diff --git a/lib/Class/C3/XS.pm b/lib/Class/C3/XS.pm index e4efd50..c8bfbf3 100644 --- a/lib/Class/C3/XS.pm +++ b/lib/Class/C3/XS.pm @@ -7,13 +7,19 @@ our $VERSION = '0.15'; =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. The main L package will -first attempt to load L, and then failing that, will fall back to -L. Do not use this package directly, use L instead. +This contains XS performance enhancers for L. +The main L package will use this package automatically +if it can find it. Do not use this package directly, use +L instead. =head1 AUTHOR @@ -32,222 +38,7 @@ it under the same terms as Perl itself. =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 => [ ], -# methods => { -# orig => , -# code => \& -# }, -# 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; diff --git a/lib/Class/C3/XS.xs b/lib/Class/C3/XS.xs index d5e62f1..91eadd6 100644 --- a/lib/Class/C3/XS.xs +++ b/lib/Class/C3/XS.xs @@ -2,176 +2,18 @@ #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 */ diff --git a/t/00_load.t b/t/00_load.t index 9703116..5d7b70e 100644 --- a/t/00_load.t +++ b/t/00_load.t @@ -6,5 +6,5 @@ use warnings; use Test::More tests => 1; BEGIN { - use_ok('Class::C3'); -} \ No newline at end of file + use_ok('Class::C3::XS'); +} diff --git a/t/01_MRO.t b/t/01_MRO.t deleted file mode 100644 index 5865612..0000000 --- a/t/01_MRO.t +++ /dev/null @@ -1,76 +0,0 @@ -#!/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. - - - / \ - - \ / - - -=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'); diff --git a/t/02_MRO.t b/t/02_MRO.t deleted file mode 100644 index d4bf02c..0000000 --- a/t/02_MRO.t +++ /dev/null @@ -1,136 +0,0 @@ -#!/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 diff --git a/t/03_MRO.t b/t/03_MRO.t deleted file mode 100644 index a13294f..0000000 --- a/t/03_MRO.t +++ /dev/null @@ -1,117 +0,0 @@ -#!/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() -(, , , -, , , -) - -=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'); diff --git a/t/04_MRO.t b/t/04_MRO.t deleted file mode 100644 index 1e9bbba..0000000 --- a/t/04_MRO.t +++ /dev/null @@ -1,73 +0,0 @@ -#!/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 - - Object - ^ - | - LifeForm - ^ ^ - / \ - Sentient BiPedal - ^ ^ - | | - Intelligent Humanoid - ^ ^ - \ / - Vulcan - - define class () end class; - define class () end class; - define class () end class; - define class () end class; - define class (, ) 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 diff --git a/t/05_MRO.t b/t/05_MRO.t deleted file mode 100644 index d3c6b77..0000000 --- a/t/05_MRO.t +++ /dev/null @@ -1,33 +0,0 @@ -#!/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'); - diff --git a/t/06_MRO.t b/t/06_MRO.t deleted file mode 100644 index de8db0f..0000000 --- a/t/06_MRO.t +++ /dev/null @@ -1,64 +0,0 @@ -#!/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!!!! - - - / \ - - \ / - - -=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'); diff --git a/t/10_Inconsistent_hierarchy.t b/t/10_Inconsistent_hierarchy.t deleted file mode 100644 index 2378ea3..0000000 --- a/t/10_Inconsistent_hierarchy.t +++ /dev/null @@ -1,57 +0,0 @@ -#!/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'); diff --git a/t/20_reinitialize.t b/t/20_reinitialize.t deleted file mode 100644 index 7dce5d4..0000000 --- a/t/20_reinitialize.t +++ /dev/null @@ -1,88 +0,0 @@ -#!/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: - - - / \ - - \ / - - -=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: - - - \ / \ - - \ / - - -=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'); diff --git a/t/21_C3_with_overload.t b/t/21_C3_with_overload.t deleted file mode 100644 index d6bd9b4..0000000 --- a/t/21_C3_with_overload.t +++ /dev/null @@ -1,56 +0,0 @@ -#!/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 } diff --git a/t/22_uninitialize.t b/t/22_uninitialize.t deleted file mode 100644 index 4ffaf50..0000000 --- a/t/22_uninitialize.t +++ /dev/null @@ -1,89 +0,0 @@ -#!/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 - - - / \ - - \ / - - -=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'); - diff --git a/t/23_multi_init.t b/t/23_multi_init.t deleted file mode 100644 index ebe9a72..0000000 --- a/t/23_multi_init.t +++ /dev/null @@ -1,49 +0,0 @@ -#!/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'); diff --git a/t/30_next_method.t b/t/30_next_method.t deleted file mode 100644 index db724c9..0000000 --- a/t/30_next_method.t +++ /dev/null @@ -1,75 +0,0 @@ -#!/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. - - - / \ - - \ / - - -=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'); diff --git a/t/31_next_method_skip.t b/t/31_next_method_skip.t deleted file mode 100644 index 7af8035..0000000 --- a/t/31_next_method_skip.t +++ /dev/null @@ -1,85 +0,0 @@ -#!/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. - - - / \ - - \ / - - -=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'); diff --git a/t/32_next_method_edge_cases.t b/t/32_next_method_edge_cases.t deleted file mode 100644 index 5af7004..0000000 --- a/t/32_next_method_edge_cases.t +++ /dev/null @@ -1,90 +0,0 @@ -#!/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 diff --git a/t/33_next_method_used_with_NEXT.t b/t/33_next_method_used_with_NEXT.t deleted file mode 100644 index b2e4843..0000000 --- a/t/33_next_method_used_with_NEXT.t +++ /dev/null @@ -1,55 +0,0 @@ -#!/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'); - diff --git a/t/34_next_method_in_eval.t b/t/34_next_method_in_eval.t deleted file mode 100644 index f782cd6..0000000 --- a/t/34_next_method_in_eval.t +++ /dev/null @@ -1,51 +0,0 @@ -#!/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{}'); - - diff --git a/t/35_next_method_in_anon.t b/t/35_next_method_in_anon.t deleted file mode 100644 index 67342b5..0000000 --- a/t/35_next_method_in_anon.t +++ /dev/null @@ -1,64 +0,0 @@ -#!/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'); - - diff --git a/t/lib/A.pm b/t/lib/A.pm deleted file mode 100644 index 74acfec..0000000 --- a/t/lib/A.pm +++ /dev/null @@ -1,3 +0,0 @@ -package t::lib::A; -use c3; -1; \ No newline at end of file diff --git a/t/lib/B.pm b/t/lib/B.pm deleted file mode 100644 index 8d5d80f..0000000 --- a/t/lib/B.pm +++ /dev/null @@ -1,3 +0,0 @@ -package t::lib::B; -use c3; -1; \ No newline at end of file diff --git a/t/lib/C.pm b/t/lib/C.pm deleted file mode 100644 index 608ea0c..0000000 --- a/t/lib/C.pm +++ /dev/null @@ -1,4 +0,0 @@ -package t::lib::C; -use c3; -use base ('t::lib::A', 't::lib::B'); -1; \ No newline at end of file diff --git a/t/lib/D.pm b/t/lib/D.pm deleted file mode 100644 index 4ccb3de..0000000 --- a/t/lib/D.pm +++ /dev/null @@ -1,4 +0,0 @@ -package t::lib::D; -use c3; -use base ('t::lib::A', 't::lib::E'); -1; \ No newline at end of file diff --git a/t/lib/E.pm b/t/lib/E.pm deleted file mode 100644 index 4cb7b71..0000000 --- a/t/lib/E.pm +++ /dev/null @@ -1,3 +0,0 @@ -package t::lib::E; -use c3; -1; \ No newline at end of file diff --git a/t/lib/F.pm b/t/lib/F.pm deleted file mode 100644 index a53c2d7..0000000 --- a/t/lib/F.pm +++ /dev/null @@ -1,4 +0,0 @@ -package t::lib::F; -use c3; -use base ('t::lib::C', 't::lib::D'); -1; \ No newline at end of file