From: Brandon L Black Date: Fri, 5 Jan 2007 02:19:29 +0000 (+0000) Subject: adding the some preliminary junk X-Git-Tag: 0.02~22 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8995e8271e0f7f7b9c0942a4425e8a44099bf608;p=gitmo%2FClass-C3-XS.git adding the some preliminary junk --- diff --git a/Build.PL b/Build.PL new file mode 100644 index 0000000..4559bb6 --- /dev/null +++ b/Build.PL @@ -0,0 +1,22 @@ +use Module::Build; + +use strict; + +my $build = Module::Build->new( + module_name => 'Class::C3::XS', + license => 'perl', + optional => {}, + build_requires => { + 'Test::More' => '0.47', + 'Test::Exception' => 0.15, + }, + create_makefile_pl => 'traditional', + create_readme => 1, + recursive_test_files => 1, + add_to_cleanup => [ + 'META.yml', '*.bak', '*.gz', 'Makefile.PL', + ], +); + +$build->create_build_script; + diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..5d83af9 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,2 @@ +Revision history for Perl extension Class::C3::XS + diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..795aeb0 --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,18 @@ +^_build +^Build$ +^blib +~$ +\.bak$ +^MANIFEST\.SKIP$ +CVS +\.svn +\.DS_Store +cover_db +\..*\.sw.?$ +^Makefile$ +^pm_to_blib$ +^MakeMaker-\d +^blibdirs$ +\.old$ +^#.*#$ +^\.# \ No newline at end of file diff --git a/lib/Class/C3/XS.pm b/lib/Class/C3/XS.pm new file mode 100644 index 0000000..e4efd50 --- /dev/null +++ b/lib/Class/C3/XS.pm @@ -0,0 +1,253 @@ + +package Class::C3::XS; + +our $VERSION = '0.15'; + +=pod + +=head1 NAME + +Class::C3::XS - The XS implementation of Class::C3 + +=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. + +=head1 AUTHOR + +Stevan Little, Estevan@iinteractive.comE + +Brandon L. Black, Eblblack@gmail.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2005, 2006 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +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)->(@_) } + +1; diff --git a/lib/Class/C3/XS.xs b/lib/Class/C3/XS.xs new file mode 100644 index 0000000..d5e62f1 --- /dev/null +++ b/lib/Class/C3/XS.xs @@ -0,0 +1,177 @@ + +#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; + + hvname = HvNAME_get(selfstash); + if (!hvname) + Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); + + 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); + } + + +#else /* mro_linear stuff not in core, so do some helpers for the pure-perl variant */ + +/* 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 diff --git a/t/00_load.t b/t/00_load.t new file mode 100644 index 0000000..9703116 --- /dev/null +++ b/t/00_load.t @@ -0,0 +1,10 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 1; + +BEGIN { + use_ok('Class::C3'); +} \ No newline at end of file diff --git a/t/01_MRO.t b/t/01_MRO.t new file mode 100644 index 0000000..5865612 --- /dev/null +++ b/t/01_MRO.t @@ -0,0 +1,76 @@ +#!/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 new file mode 100644 index 0000000..d4bf02c --- /dev/null +++ b/t/02_MRO.t @@ -0,0 +1,136 @@ +#!/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 new file mode 100644 index 0000000..a13294f --- /dev/null +++ b/t/03_MRO.t @@ -0,0 +1,117 @@ +#!/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 new file mode 100644 index 0000000..1e9bbba --- /dev/null +++ b/t/04_MRO.t @@ -0,0 +1,73 @@ +#!/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 new file mode 100644 index 0000000..d3c6b77 --- /dev/null +++ b/t/05_MRO.t @@ -0,0 +1,33 @@ +#!/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 new file mode 100644 index 0000000..de8db0f --- /dev/null +++ b/t/06_MRO.t @@ -0,0 +1,64 @@ +#!/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 new file mode 100644 index 0000000..2378ea3 --- /dev/null +++ b/t/10_Inconsistent_hierarchy.t @@ -0,0 +1,57 @@ +#!/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 new file mode 100644 index 0000000..7dce5d4 --- /dev/null +++ b/t/20_reinitialize.t @@ -0,0 +1,88 @@ +#!/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 new file mode 100644 index 0000000..d6bd9b4 --- /dev/null +++ b/t/21_C3_with_overload.t @@ -0,0 +1,56 @@ +#!/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 new file mode 100644 index 0000000..4ffaf50 --- /dev/null +++ b/t/22_uninitialize.t @@ -0,0 +1,89 @@ +#!/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 new file mode 100644 index 0000000..ebe9a72 --- /dev/null +++ b/t/23_multi_init.t @@ -0,0 +1,49 @@ +#!/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 new file mode 100644 index 0000000..db724c9 --- /dev/null +++ b/t/30_next_method.t @@ -0,0 +1,75 @@ +#!/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 new file mode 100644 index 0000000..7af8035 --- /dev/null +++ b/t/31_next_method_skip.t @@ -0,0 +1,85 @@ +#!/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 new file mode 100644 index 0000000..5af7004 --- /dev/null +++ b/t/32_next_method_edge_cases.t @@ -0,0 +1,90 @@ +#!/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 new file mode 100644 index 0000000..b2e4843 --- /dev/null +++ b/t/33_next_method_used_with_NEXT.t @@ -0,0 +1,55 @@ +#!/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 new file mode 100644 index 0000000..f782cd6 --- /dev/null +++ b/t/34_next_method_in_eval.t @@ -0,0 +1,51 @@ +#!/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 new file mode 100644 index 0000000..67342b5 --- /dev/null +++ b/t/35_next_method_in_anon.t @@ -0,0 +1,64 @@ +#!/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 new file mode 100644 index 0000000..74acfec --- /dev/null +++ b/t/lib/A.pm @@ -0,0 +1,3 @@ +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 new file mode 100644 index 0000000..8d5d80f --- /dev/null +++ b/t/lib/B.pm @@ -0,0 +1,3 @@ +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 new file mode 100644 index 0000000..608ea0c --- /dev/null +++ b/t/lib/C.pm @@ -0,0 +1,4 @@ +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 new file mode 100644 index 0000000..4ccb3de --- /dev/null +++ b/t/lib/D.pm @@ -0,0 +1,4 @@ +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 new file mode 100644 index 0000000..4cb7b71 --- /dev/null +++ b/t/lib/E.pm @@ -0,0 +1,3 @@ +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 new file mode 100644 index 0000000..a53c2d7 --- /dev/null +++ b/t/lib/F.pm @@ -0,0 +1,4 @@ +package t::lib::F; +use c3; +use base ('t::lib::C', 't::lib::D'); +1; \ No newline at end of file diff --git a/t/pod.t b/t/pod.t new file mode 100644 index 0000000..4ae1af3 --- /dev/null +++ b/t/pod.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +eval "use Test::Pod 1.14"; +plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; + +all_pod_files_ok(); diff --git a/t/pod_coverage.t b/t/pod_coverage.t new file mode 100644 index 0000000..84632f2 --- /dev/null +++ b/t/pod_coverage.t @@ -0,0 +1,13 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +BEGIN { + eval "use Test::Pod::Coverage 1.04"; + plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@; + + all_pod_coverage_ok({ also_private => [ qr/removeChildAt/ ] }); +} \ No newline at end of file