Class-C3-0.33/000755 000765 000024 00000000000 13077221666 013242 5ustar00gknopstaff000000 000000 Class-C3-0.33/Changes000644 000765 000024 00000013573 13077221630 014535 0ustar00gknopstaff000000 000000 Revision history for Perl extension Class::C3. 0.33 - 2017-04-23 - update bundled ExtUtils::HasCompiler to 0.017 - moved repository to Moose GitHub org - avoid using base.pm in tests (RT#120530) - minor pod and test cleanups 0.32 - 2016-09-15 - update bundled ExtUtils::HasCompiler to 0.016 0.31 - 2016-04-19 - update bundled ExtUtils::HasCompiler to 0.013 to fix possible false negative (RT#113635) 0.30 - 2015-10-19 - include ExtUtils::HasCompiler in dist as intended so it doesn't need to be installed 0.29 - 2015-10-18 - Update compiler detection to use ExtUtils::HasCompiler 0.28 - 2015-04-14 - Change link to Dylan paper to use archive.org, as the original link has gone offline (RT#99756). 0.27 - 2014-08-16 - declare minimum perl version of 5.6 in metadata 0.26 Tue, Mar 4, 2104 - Fix bug in Makefile.PL when ExtUtils::CBuilder not available 0.25 Thu, July 4, 2013 - Drop compatibility from 5.6.2 to 5.6.0 - Pod typo fixes (RT#77453, RT#85357) - Only ask for Devel::Hide on perls where it will be actually used (RT#81106) - Fix SYNOPSIS to actually be executable (RT#78327) 0.24 Sat, May 12, 2012 - Require Class::C3::XS on 5.8 perls if a working compiler is found 0.23 Sat, Jun 19, 2010 - Fix various documentation problems (Martin Becker). 0.22 Fri, Jan 29, 2010 - Add note that people should be using MRO::Compat rather than Class::C3 directly. 0.21 Wed, Mar 25, 2009 - Remove fake Build.PL. Module::Install doesn't support that anymore. (Florian Ragwitz) - Stop using auto_instal in Makefile.PL. Its use is strongly discouraged. (Closes RT#38051, RT#44541) (Simon Bertrang) 0.20 Mon, Dec 8, 2008 - Prevent redefined warnings when Class::C3 is loaded explicitly after MRO::Compat has been loaded. Also add tests for this. 0.19 Mon, Jun 4, 2007 - Added new goto tests, bumped XS version req 0.18 Sat, May 12, 2007 - Just bumped XS version requirement 0.17 Tues, May 8, 2007 - Remove Build.PL from the distribution 0.16 Thurs, May 3, 2007 - Converted to Module::Install - Supports optional Class::C3::XS - Supports optional perl 5.9.5+ mro code - Fixed overload fallback edge cases. - Fix for overloading to method name string, from Ittetsu Miyazaki. 0.14 Tues, Sep 19, 2006 - Fix for rt.cpan.org #21558 - converted to Module::Build 0.13 Fri, Aug 25, 2006 - Make use of Algorithm::C3 0.05's merge caching 0.12 Tues, July 18, 2006 - clarifying docs for &initialize (thanks jcs) - applying patch from Robert Norris to add next::can() and maybe::next::method() functionality which allows safe probing of the presence of the next method 0.11 Thurs, Feb 23, 2006 - added some more tests for edge cases - removed INIT, you must explicitly call &initialize now - added docs explaining this - altered tests as needed - moved the C3 algorithm to Algorithm::C3 and added that as a dependency to this module - added docs to explain the "next::method in anon-sub" issue - suggestions/solutions/patches welcome :) - bumped the Scalar::Util version requirement back down to 1.10, apparently the newer version has some issues 0.10 - Wed, Feb 8, 2006 - removed the Sub::Name and NEXT dependencies and made the test just skip if they are not present - bumped the Scalar::Util version requirement up (the newest version tends to work the best across different platforms) 0.09 - Fri, Dec 30, 2005 - this is actually the proper version of 0.08, I forgot to check in some modifications, and so they didn't get included in my upload. 0.08 - Wed, Dec 28, 2005 - adjusted &_remove_method_dispatch_table to be more discriminating about what it deletes. Thanks to Matt S. Trout for this fix. - tweaked &_merge to avoid un-needed looping. Thanks to Audrey Tang for this fix. - added better support for calling next::method within an eval BLOCKs and anon-subroutines. Thanks to Justin Guenther for this patch and test. 0.07 - Wed, Nov 23, 2005 * all bugs found by, and fixes provided by Matt S. Trout * - fixed issue caused when module is imported more than once - fixed subtle bug in how next::method is calculated - added test for this - added util/visualize_c3.pl tool, which visualizes C3 dispatch order using GraphViz 0.06 - Tues, Nov 15, 2005 - added Sub::Name to dependencies (even though it is just for the tests) - removed OS X resource fork which slipped into the tar.gz - improved error reporting for Inconsistent Hierarchies - added feature to insure that Overload "fallback" setting is properly inherited - added test for this 0.05 - Mon, Nov 14, 2005 - added caching to next::method, courtesy of quicksilver and mst over at #dbi-class - added next::method edge case test - added next::method & NEXT test 0.04 - Thurs, Sept 29, 2004 - changed NEXT::METHOD::foo to next::method - added more tests as well 0.03 - Wed, Sept 28, 2005 - added the NEXT::METHOD psuedo package for method redispatching along the C3 linearization - added test for this 0.02 - Mon, Aug 8, 2005 - code refactoring - many comments added - added many more tests - most of the tests from Perl6::MetaModel moved over - tested loading modules with `use` as well as the inline package definition - added optional 'c3' pragma - this is not installed and can be found in opt/ - added `uninitialize` function to remove C3 dispatch ordering - added tests for this - added `reinitialize` function to reload C3 dispatch ordering - added tests for this 0.01 - Sun, Aug 7, 2005 - initial release of module - some code and tests based on previous Perl6::MetaModel work Class-C3-0.33/inc/000755 000765 000024 00000000000 13077221665 014012 5ustar00gknopstaff000000 000000 Class-C3-0.33/lib/000755 000765 000024 00000000000 13077221665 014007 5ustar00gknopstaff000000 000000 Class-C3-0.33/maint/000755 000765 000024 00000000000 13077221665 014351 5ustar00gknopstaff000000 000000 Class-C3-0.33/Makefile.PL000644 000765 000024 00000006174 13073775246 015230 0ustar00gknopstaff000000 000000 use strict; use warnings FATAL => 'all'; use 5.006; use lib 'inc'; use ExtUtils::HasCompiler qw(can_compile_loadable_object); my %META = ( name => 'Class-C3', license => 'perl_5', prereqs => { configure => { requires => { 'ExtUtils::MakeMaker' => 0, } }, build => { requires => { } }, test => { requires => { 'Test::More' => '0.47', }, }, runtime => { requires => { 'Algorithm::C3' => '0.07', 'Scalar::Util' => '0', 'perl' => 5.006, }, }, develop => { requires => { 'Test::Pod' => 1.14, 'Test::Pod::Coverage' => 1.04, }, }, }, resources => { repository => { url => 'https://github.com/moose/Class-C3.git', web => 'https://github.com/moose/Class-C3', type => 'git', }, bugtracker => { web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Class-C3', mailto => 'bug-Class-C3@rt.cpan.org', }, homepage => 'https://metacpan.org/release/Class-C3', license => [ 'http://dev.perl.org/licenses/' ], }, no_index => { directory => [ 't', 'xt', 'opt', 'inc' ] }, ); my %MM_ARGS = ( TEST_REQUIRES => { ( $] < 5.009_005 and is_smoker() ) ? ( 'Devel::Hide' => 0 ) : () }, PREREQ_PM => { ( $] < 5.009_005 and can_compile_loadable_object(quiet => 1) ) ? ( 'Class::C3::XS' => '0.13' ) : () }, ); sub is_smoker { return ( $ENV{AUTOMATED_TESTING} && ! $ENV{PERL5_CPANM_IS_RUNNING} && ! $ENV{RELEASE_TESTING} ) } ## BOILERPLATE ############################################################### require ExtUtils::MakeMaker; (do './maint/Makefile.PL.include' or die $@) unless -f 'META.yml'; # have to do this since old EUMM dev releases miss the eval $VERSION line my $eumm_version = eval $ExtUtils::MakeMaker::VERSION; my $mymeta = $eumm_version >= 6.57_02; my $mymeta_broken = $mymeta && $eumm_version < 6.57_07; ($MM_ARGS{NAME} = $META{name}) =~ s/-/::/g; ($MM_ARGS{VERSION_FROM} = "lib/$MM_ARGS{NAME}.pm") =~ s{::}{/}g; $META{license} = [ $META{license} ] if $META{license} && !ref $META{license}; $MM_ARGS{LICENSE} = $META{license}[0] if $META{license} && $eumm_version >= 6.30; $MM_ARGS{NO_MYMETA} = 1 if $mymeta_broken; $MM_ARGS{META_ADD} = { 'meta-spec' => { version => 2 }, %META } unless -f 'META.yml'; for (qw(configure build test runtime)) { my $key = $_ eq 'runtime' ? 'PREREQ_PM' : uc $_.'_REQUIRES'; my $r = $MM_ARGS{$key} = { %{$META{prereqs}{$_}{requires} || {}}, %{delete $MM_ARGS{$key} || {}}, }; defined $r->{$_} or delete $r->{$_} for keys %$r; } $MM_ARGS{MIN_PERL_VERSION} = delete $MM_ARGS{PREREQ_PM}{perl} || 0; delete $MM_ARGS{MIN_PERL_VERSION} if $eumm_version < 6.47_01; $MM_ARGS{BUILD_REQUIRES} = {%{$MM_ARGS{BUILD_REQUIRES}}, %{delete $MM_ARGS{TEST_REQUIRES}}} if $eumm_version < 6.63_03; $MM_ARGS{PREREQ_PM} = {%{$MM_ARGS{PREREQ_PM}}, %{delete $MM_ARGS{BUILD_REQUIRES}}} if $eumm_version < 6.55_01; delete $MM_ARGS{CONFIGURE_REQUIRES} if $eumm_version < 6.51_03; ExtUtils::MakeMaker::WriteMakefile(%MM_ARGS); ## END BOILERPLATE ########################################################### Class-C3-0.33/MANIFEST000644 000765 000024 00000001503 13077221666 014372 0ustar00gknopstaff000000 000000 Changes inc/ExtUtils/HasCompiler.pm lib/Class/C3.pm lib/Class/C3/next.pm maint/Makefile.PL.include Makefile.PL MANIFEST This list of files opt/c3.pm t/00_load.t t/01_MRO.t t/02_MRO.t t/03_MRO.t t/04_MRO.t t/05_MRO.t t/06_MRO.t t/10_Inconsistent_hierarchy.t t/20_reinitialize.t t/21_C3_with_overload.t t/22_uninitialize.t t/23_multi_init.t t/24_more_overload.t t/30_next_method.t t/31_next_method_skip.t t/32_next_method_edge_cases.t t/33_next_method_used_with_NEXT.t t/34_next_method_in_eval.t t/35_next_method_in_anon.t t/36_next_goto.t t/37_mro_warn.t t/40_no_xs.t xt/pod.t xt/pod_coverage.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) README README file (added by Distar) Class-C3-0.33/META.json000644 000765 000024 00000003306 13077221666 014665 0ustar00gknopstaff000000 000000 { "abstract" : "A pragma to use the C3 method resolution order algorithm", "author" : [ "Stevan Little, " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Class-C3", "no_index" : { "directory" : [ "t", "xt", "opt", "inc" ] }, "prereqs" : { "build" : { "requires" : {} }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : { "Test::Pod" : "1.14", "Test::Pod::Coverage" : "1.04" } }, "runtime" : { "requires" : { "Algorithm::C3" : "0.07", "Scalar::Util" : "0", "perl" : "5.006" } }, "test" : { "requires" : { "Test::More" : "0.47" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-Class-C3@rt.cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Class-C3" }, "homepage" : "https://metacpan.org/release/Class-C3", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "https://github.com/moose/Class-C3.git", "web" : "https://github.com/moose/Class-C3" } }, "version" : "0.33", "x_serialization_backend" : "JSON::PP version 2.27300" } Class-C3-0.33/META.yml000644 000765 000024 00000001546 13077221666 014521 0ustar00gknopstaff000000 000000 --- abstract: 'A pragma to use the C3 method resolution order algorithm' author: - 'Stevan Little, ' build_requires: Test::More: '0.47' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.24, CPAN::Meta::Converter version 2.150005' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Class-C3 no_index: directory: - t - xt - opt - inc requires: Algorithm::C3: '0.07' Scalar::Util: '0' perl: '5.006' resources: bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Class-C3 homepage: https://metacpan.org/release/Class-C3 license: http://dev.perl.org/licenses/ repository: https://github.com/moose/Class-C3.git version: '0.33' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Class-C3-0.33/opt/000755 000765 000024 00000000000 13077221665 014043 5ustar00gknopstaff000000 000000 Class-C3-0.33/README000644 000765 000024 00000031450 13077221666 014125 0ustar00gknopstaff000000 000000 NAME Class::C3 - A pragma to use the C3 method resolution order algorithm SYNOPSIS # NOTE - DO NOT USE Class::C3 directly as a user, use MRO::Compat instead! package ClassA; use Class::C3; sub hello { 'A::hello' } package ClassB; use base 'ClassA'; use Class::C3; package ClassC; use base 'ClassA'; use Class::C3; sub hello { 'C::hello' } package ClassD; use base ('ClassB', 'ClassC'); use Class::C3; # Classic Diamond MI pattern # # / \ # # \ / # package main; # initializez the C3 module # (formerly called in INIT) Class::C3::initialize(); print join ', ' => Class::C3::calculateMRO('ClassD'); # prints ClassD, ClassB, ClassC, ClassA print ClassD->hello(); # prints 'C::hello' instead of the standard p5 'A::hello' ClassD->can('hello')->(); # can() also works correctly UNIVERSAL::can('ClassD', 'hello'); # as does UNIVERSAL::can() DESCRIPTION This is pragma to change Perl 5's standard method resolution order from depth-first left-to-right (a.k.a - pre-order) to the more sophisticated C3 method resolution order. NOTE: YOU SHOULD NOT USE THIS MODULE DIRECTLY - The feature provided is integrated into perl version >= 5.9.5, and you should use MRO::Compat instead, which will use the core implementation in newer perls, but fallback to using this implementation on older perls. What is C3? C3 is the name of an algorithm which aims to provide a sane method resolution order under multiple inheritance. It was first introduced in the language Dylan (see links in the "SEE ALSO" section), and then later adopted as the preferred MRO (Method Resolution Order) for the new-style classes in Python 2.3. Most recently it has been adopted as the 'canonical' MRO for Perl 6 classes, and the default MRO for Parrot objects as well. How does C3 work. C3 works by always preserving local precedence ordering. This essentially means that no class will appear before any of its subclasses. Take the classic diamond inheritance pattern for instance: / \ \ / The standard Perl 5 MRO would be (D, B, A, C). The result being that A appears before C, even though C is the subclass of A. The C3 MRO algorithm however, produces the following MRO (D, B, C, A), which does not have this same issue. This example is fairly trivial, for more complex examples and a deeper explanation, see the links in the "SEE ALSO" section. How does this module work? This module uses a technique similar to Perl 5's method caching. When "Class::C3::initialize" is called, this module calculates the MRO of all the classes which called "use Class::C3". It then gathers information from the symbol tables of each of those classes, and builds a set of method aliases for the correct dispatch ordering. Once all these C3-based method tables are created, it then adds the method aliases into the local classes symbol table. The end result is actually classes with pre-cached method dispatch. However, this caching does not do well if you start changing your @ISA or messing with class symbol tables, so you should consider your classes to be effectively closed. See the CAVEATS section for more details. OPTIONAL LOWERCASE PRAGMA This release also includes an optional module c3 in the opt/ folder. I did not include this in the regular install since lowercase module names are considered *"bad"* by some people. However I think that code looks much nicer like this: package MyClass; use c3; This is more clunky: package MyClass; use Class::C3; But hey, it's your choice, that's why it is optional. FUNCTIONS calculateMRO ($class) Given a $class this will return an array of class names in the proper C3 method resolution order. initialize This must be called to initialize the C3 method dispatch tables, this module will not work if you do not do this. It is advised to do this as soon as possible after loading any classes which use C3. Here is a quick code example: package Foo; use Class::C3; # ... Foo methods here package Bar; use Class::C3; use base 'Foo'; # ... Bar methods here package main; Class::C3::initialize(); # now it is safe to use Foo and Bar This function used to be called automatically for you in the INIT phase of the perl compiler, but that lead to warnings if this module was required at runtime. After discussion with my user base (the DBIx::Class folks), we decided that calling this in INIT was more of an annoyance than a convenience. I apologize to anyone this causes problems for (although I would be very surprised if I had any other users other than the DBIx::Class folks). The simplest solution of course is to define your own INIT method which calls this function. NOTE: If "initialize" detects that "initialize" has already been executed, it will "uninitialize" and clear the MRO cache first. uninitialize Calling this function results in the removal of all cached methods, and the restoration of the old Perl 5 style dispatch order (depth-first, left-to-right). reinitialize This is an alias for "initialize" above. METHOD REDISPATCHING It is always useful to be able to re-dispatch your method call to the "next most applicable method". This module provides a pseudo package along the lines of "SUPER::" or "NEXT::" which will re-dispatch the method along the C3 linearization. This is best shown with an example. # a classic diamond MI pattern ... # # / \ # # \ / # package ClassA; use Class::C3; sub foo { 'ClassA::foo' } package ClassB; use base 'ClassA'; use Class::C3; sub foo { 'ClassB::foo => ' . (shift)->next::method() } package ClassC; use base 'ClassA'; use Class::C3; sub foo { 'ClassC::foo => ' . (shift)->next::method() } package ClassD; use base ('ClassB', 'ClassC'); use Class::C3; sub foo { 'D::foo => ' . (shift)->next::method() } print D->foo; # prints out "D::foo => B::foo => C::foo => A::foo" A few things to note. First, we do not require you to add on the method name to the "next::method" call (this is unlike "NEXT::" and "SUPER::" which do require that). This helps to enforce the rule that you cannot dispatch to a method of a different name (this is how "NEXT::" behaves as well). The next thing to keep in mind is that you will need to pass all arguments to "next::method". It can not automatically use the current @_. If "next::method" cannot find a next method to re-dispatch the call to, it will throw an exception. You can use "next::can" to see if "next::method" will succeed before you call it like so: $self->next::method(@_) if $self->next::can; Additionally, you can use "maybe::next::method" as a shortcut to only call the next method if it exists. The previous example could be simply written as: $self->maybe::next::method(@_); There are some caveats about using "next::method", see below for those. CAVEATS This module used to be labeled as *experimental*, however it has now been pretty heavily tested by the good folks over at DBIx::Class and I am confident this module is perfectly usable for whatever your needs might be. But there are still caveats, so here goes ... Use of "SUPER::". The idea of "SUPER::" under multiple inheritance is ambiguous, and generally not recommended anyway. However, its use in conjunction with this module is very much not recommended, and in fact very discouraged. The recommended approach is to instead use the supplied "next::method" feature, see more details on its usage above. Changing @ISA. It is the author's opinion that changing @ISA at runtime is pure insanity anyway. However, people do it, so I must caveat. Any changes to the @ISA will not be reflected in the MRO calculated by this module, and therefore probably won't even show up. If you do this, you will need to call "reinitialize" in order to recalculate all method dispatch tables. See the "reinitialize" documentation and an example in t/20_reinitialize.t for more information. Adding/deleting methods from class symbol tables. This module calculates the MRO for each requested class by interrogating the symbol tables of said classes. So any symbol table manipulation which takes place after our INIT phase is run will not be reflected in the calculated MRO. Just as with changing the @ISA, you will need to call "reinitialize" for any changes you make to take effect. Calling "next::method" from methods defined outside the class There is an edge case when using "next::method" from within a subroutine which was created in a different module than the one it is called from. It sounds complicated, but it really isn't. Here is an example which will not work correctly: *Foo::foo = sub { (shift)->next::method(@_) }; The problem exists because the anonymous subroutine being assigned to the glob *Foo::foo will show up in the call stack as being called "__ANON__" and not "foo" as you might expect. Since "next::method" uses "caller" to find the name of the method it was called in, it will fail in this case. But fear not, there is a simple solution. The module "Sub::Name" will reach into the perl internals and assign a name to an anonymous subroutine for you. Simply do this: use Sub::Name 'subname'; *Foo::foo = subname 'Foo::foo' => sub { (shift)->next::method(@_) }; and things will Just Work. Of course this is not always possible to do, but to be honest, I just can't manage to find a workaround for it, so until someone gives me a working patch this will be a known limitation of this module. COMPATIBILITY If your software requires Perl 5.9.5 or higher, you do not need Class::C3, you can simply "use mro 'c3'", and not worry about "initialize()", avoid some of the above caveats, and get the best possible performance. See mro for more details. If your software is meant to work on earlier Perls, use Class::C3 as documented here. Class::C3 will detect Perl 5.9.5+ and take advantage of the core support when available. Class::C3::XS This module will load Class::C3::XS if it's installed and you are running on a Perl version older than 5.9.5. The optional module will be automatically installed for you if a C compiler is available, as it results in significant performance improvements (but unlike the 5.9.5+ core support, it still has all of the same caveats as Class::C3). CODE COVERAGE Devel::Cover was reporting 94.4% overall test coverage earlier in this module's life. Currently, the test suite does things that break under coverage testing, but it is fair to assume the coverage is still close to that value. SEE ALSO The original Dylan paper The prototype Perl 6 Object Model uses C3 Parrot now uses C3 Python 2.3 MRO related links C3 for TinyCLOS ACKNOWLEGEMENTS Thanks to Matt S. Trout for using this module in his module DBIx::Class and finding many bugs and providing fixes. Thanks to Justin Guenther for making "next::method" more robust by handling calls inside "eval" and anon-subs. Thanks to Robert Norris for adding support for "next::can" and "maybe::next::method". AUTHOR Stevan Little, Brandon L. Black, COPYRIGHT AND LICENSE Copyright 2005, 2006 by Infinity Interactive, Inc. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Class-C3-0.33/t/000755 000765 000024 00000000000 13077221665 013504 5ustar00gknopstaff000000 000000 Class-C3-0.33/xt/000755 000765 000024 00000000000 13077221665 013674 5ustar00gknopstaff000000 000000 Class-C3-0.33/xt/pod.t000644 000765 000024 00000000125 12513116626 014633 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; use Test::Pod 1.14; all_pod_files_ok(); Class-C3-0.33/xt/pod_coverage.t000644 000765 000024 00000000213 12513116613 016500 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; use Test::Pod::Coverage 1.04; all_pod_coverage_ok({ also_private => [ qr/removeChildAt/ ] }); Class-C3-0.33/t/00_load.t000644 000765 000024 00000001450 12266112410 015071 0ustar00gknopstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 2; use Class::C3; use Class::C3::next; if ($] > 5.009_004) { ok ($Class::C3::C3_IN_CORE, 'C3 in core'); ok (!$Class::C3::C3_XS, 'Not using XS'); diag "Fast C3 provided by this perl version $] in core" unless $INC{'Devel/Hide.pm'}; } else { ok (!$Class::C3::C3_IN_CORE, 'C3 not in core'); if (eval { require Class::C3::XS; Class::C3::XS->VERSION }) { ok ($Class::C3::C3_XS, 'Using XS'); diag "XS speedups available (via Class::C3::XS)" unless $INC{'Devel/Hide.pm'}; } else { ok (! $Class::C3::C3_XS, 'Not using XS'); unless ($INC{'Devel/Hide.pm'}) { diag "NO XS speedups - YOUR CODE WILL BE VERY SLOW. Consider installing Class::C3::XS"; sleep 3 if -t *STDIN or -t *STDERR; } } } Class-C3-0.33/t/01_MRO.t000644 000765 000024 00000003271 13077201754 014626 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More tests => 10; =pod This tests the classic diamond inheritence pattern. / \ \ / =cut { package Diamond_A; use Class::C3; sub hello { 'Diamond_A::hello' } } { package Diamond_B; BEGIN { our @ISA = ('Diamond_A'); } use Class::C3; } { package Diamond_C; use Class::C3; BEGIN { our @ISA = ('Diamond_A'); } sub hello { 'Diamond_C::hello' } } { package Diamond_D; BEGIN { our @ISA = ('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'); Class-C3-0.33/t/02_MRO.t000644 000765 000024 00000006775 13077201754 014643 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More tests => 14; =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; BEGIN { our @ISA = ('Test::O'); } package Test::E; BEGIN { our @ISA = ('Test::O'); } use Class::C3; sub C_or_E { 'Test::E' } package Test::D; use Class::C3; BEGIN { our @ISA = ('Test::O'); } sub C_or_D { 'Test::D' } package Test::C; BEGIN { our @ISA = ('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; BEGIN { our @ISA = ('Test::D', 'Test::E'); } package Test::A; BEGIN { our @ISA = ('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'); Class-C3-0.33/t/03_MRO.t000644 000765 000024 00000005160 13077201754 014627 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More tests => 7; =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; BEGIN { our @ISA = ('Test::O'); } use Class::C3; sub O_or_F { 'Test::F' } package Test::E; BEGIN { our @ISA = ('Test::O'); } use Class::C3; package Test::D; BEGIN { our @ISA = ('Test::O'); } use Class::C3; sub O_or_D { 'Test::D' } sub C_or_D { 'Test::D' } package Test::C; BEGIN { our @ISA = ('Test::D', 'Test::F'); } use Class::C3; sub C_or_D { 'Test::C' } package Test::B; BEGIN { our @ISA = ('Test::E', 'Test::D'); } use Class::C3; package Test::A; BEGIN { our @ISA = ('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'); Class-C3-0.33/t/04_MRO.t000644 000765 000024 00000002554 13077201754 014634 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More tests => 1; =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 Class::C3; package LifeForm; use Class::C3; BEGIN { our @ISA = ('Object'); } package Sentient; use Class::C3; BEGIN { our @ISA = ('LifeForm'); } package BiPedal; use Class::C3; BEGIN { our @ISA = ('LifeForm'); } package Intelligent; use Class::C3; BEGIN { our @ISA = ('Sentient'); } package Humanoid; use Class::C3; BEGIN { our @ISA = ('BiPedal'); } package Vulcan; use Class::C3; BEGIN { our @ISA = ('Intelligent', 'Humanoid'); } } Class::C3::initialize(); is_deeply( [ Class::C3::calculateMRO('Vulcan') ], [ qw(Vulcan Intelligent Sentient Humanoid BiPedal LifeForm Object) ], '... got the right MRO for the Vulcan Dylan Example'); Class-C3-0.33/t/05_MRO.t000644 000765 000024 00000001315 13077201754 014627 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More tests => 1; BEGIN { package ClassA; use Class::C3; } BEGIN { package ClassB; use Class::C3; } BEGIN { package ClassC; use Class::C3; } BEGIN { package ClassD; use Class::C3; our @ISA = qw(ClassA ClassB); } BEGIN { package ClassE; use Class::C3; our @ISA = qw(ClassA ClassC); } BEGIN { package ClassF; use Class::C3; our @ISA = qw(ClassD ClassE); } =pod From the parrot test t/pmc/object-meths.t A B A C \ / \ / D E \ / \ / F =cut Class::C3::initialize(); is_deeply( [ Class::C3::calculateMRO('ClassF') ], [ qw(ClassF ClassD ClassE ClassA ClassB ClassC) ], '... got the right MRO for ClassF'); Class-C3-0.33/t/06_MRO.t000644 000765 000024 00000001733 13077201754 014634 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More tests => 2; =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; BEGIN { our @ISA = ('Diamond_A'); } use Class::C3; sub foo { 'Diamond_B::foo => ' . (shift)->next::method } } { package Diamond_C; use Class::C3; BEGIN { our @ISA = ('Diamond_A'); } } { package Diamond_D; BEGIN { our @ISA = ('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'); Class-C3-0.33/t/10_Inconsistent_hierarchy.t000644 000765 000024 00000001773 13077201754 020714 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More tests => 1; =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 eval q{ { package X; use Class::C3; package Y; use Class::C3; package XY; use Class::C3; BEGIN { our @ISA = ('X', 'Y'); } package YX; use Class::C3; BEGIN { our @ISA = ('Y', 'X'); } package Z; eval 'use Class::C3' if $Class::C3::C3_IN_CORE; BEGIN { our @ISA = ('XY', 'YX'); } } Class::C3::initialize(); # 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'); Class-C3-0.33/t/20_reinitialize.t000644 000765 000024 00000003010 13077201754 016651 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More tests => 4; =pod Start with this: / \ \ / =cut { package Diamond_A; use Class::C3; sub hello { 'Diamond_A::hello' } } { package Diamond_B; BEGIN { our @ISA = ('Diamond_A'); } use Class::C3; } { package Diamond_C; use Class::C3; BEGIN { our @ISA = ('Diamond_A'); } sub hello { 'Diamond_C::hello' } } { package Diamond_D; BEGIN { our @ISA = ('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'); # Doesn't work with core support, since reinit is not neccesary and the change # takes effect immediately SKIP: { skip "This test does not work with a c3-patched perl interpreter", 1 if $Class::C3::C3_IN_CORE; 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'); Class-C3-0.33/t/21_C3_with_overload.t000644 000765 000024 00000003064 13077201754 017366 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More tests => 8; { package BaseTest; use strict; use warnings; use Class::C3; package OverloadingTest; use strict; use warnings; use Class::C3; BEGIN { our @ISA = ('BaseTest'); } use overload '""' => sub { ref(shift) . " stringified" }, fallback => 1; sub new { bless {} => shift } package InheritingFromOverloadedTest; use strict; use warnings; BEGIN { our @ISA = ('OverloadingTest'); } use Class::C3; package BaseTwo; use overload ( q{fallback} => 1, q{""} => 'str', ### character ); sub str { return 'BaseTwo str'; } package OverloadInheritTwo; use Class::C3; BEGIN { our @ISA = (qw/BaseTwo/); } } 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'); eval { my $obj = bless {}, 'OverloadInheritTwo'; }; is($@, '', "Overloading to method name string"); #use Data::Dumper; #diag Dumper { Class::C3::_dump_MRO_table } Class-C3-0.33/t/22_uninitialize.t000644 000765 000024 00000003552 13077201754 016702 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More tests => 11; =pod / \ \ / =cut { package Diamond_A; use Class::C3; sub hello { 'Diamond_A::hello' } } { package Diamond_B; BEGIN { our @ISA = ('Diamond_A'); } use Class::C3; } { package Diamond_C; use Class::C3; BEGIN { our @ISA = ('Diamond_A'); } sub goodbye { 'Diamond_C::goodbye' } sub hello { 'Diamond_C::hello' } } { package Diamond_D; BEGIN { our @ISA = ('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'); Class-C3-0.33/t/23_multi_init.t000644 000765 000024 00000001644 13077201754 016354 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More tests => 1; =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; BEGIN { our @ISA = ('TestMRO::A'); } use Class::C3; package TestMRO::C; BEGIN { our @ISA = ('TestMRO::A'); } use Class::C3; sub testmethod { shift->next::method + 1 } package TestMRO::D; BEGIN { Class::C3::initialize } BEGIN { our @ISA = ('TestMRO::B'); } BEGIN { our @ISA = ('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'); Class-C3-0.33/t/24_more_overload.t000644 000765 000024 00000002555 13077201754 017037 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More tests => 3; { package BaseTest; use Class::C3; sub new { bless {} => shift } package OverloadingTest; use Class::C3; BEGIN { our @ISA = ('BaseTest'); } use overload '+' => sub { die "called plus operator in OT" }, fallback => 0; package InheritingFromOverloadedTest; BEGIN { our @ISA = ('OverloadingTest'); } use Class::C3; use overload '+' => sub { die "called plus operator in IFOT" }, fallback => 1; package IFOTX; use Class::C3; BEGIN { our @ISA = ('OverloadingTest'); } package IFIFOT; use Class::C3; BEGIN { our @ISA = ('InheritingFromOverloadedTest'); } package Foo; use Class::C3; BEGIN { our @ISA = ('BaseTest'); } use overload '+' => sub { die "called plus operator in Foo" }, fallback => 1; package Bar; use Class::C3; BEGIN { our @ISA = ('Foo'); } use overload '+' => sub { die "called plus operator in Bar" }, fallback => 0; package Baz; use Class::C3; BEGIN { our @ISA = ('Bar'); } } Class::C3::initialize(); my $x = IFOTX->new(); eval { $x += 1 }; like($@, qr/no method found,/); my $y = IFIFOT->new(); eval { $y += 1 }; like($@, qr/called plus operator in IFOT/); my $z = Baz->new(); eval { $z += 1 }; like($@, qr/no method found,/); Class-C3-0.33/t/30_next_method.t000644 000765 000024 00000002770 13077201754 016514 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More tests => 5; =pod This tests the classic diamond inheritence pattern. / \ \ / =cut { package Diamond_A; use Class::C3; sub hello { 'Diamond_A::hello' } sub foo { 'Diamond_A::foo' } } { package Diamond_B; BEGIN { our @ISA = ('Diamond_A'); } use Class::C3; sub foo { 'Diamond_B::foo => ' . (shift)->next::method() } } { package Diamond_C; use Class::C3; BEGIN { our @ISA = ('Diamond_A'); } sub hello { 'Diamond_C::hello => ' . (shift)->next::method() } sub foo { 'Diamond_C::foo => ' . (shift)->next::method() } } { package Diamond_D; BEGIN { our @ISA = ('Diamond_B', 'Diamond_C'); } 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_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'); Class-C3-0.33/t/31_next_method_skip.t000644 000765 000024 00000004627 13077201754 017546 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More tests => 10; =pod This tests the classic diamond inheritence pattern. / \ \ / =cut { package Diamond_A; use Class::C3; sub bar { 'Diamond_A::bar' } sub baz { 'Diamond_A::baz' } } { package Diamond_B; BEGIN { our @ISA = ('Diamond_A'); } use Class::C3; sub baz { 'Diamond_B::baz => ' . (shift)->next::method() } } { package Diamond_C; use Class::C3; BEGIN { our @ISA = ('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; BEGIN { our @ISA = ('Diamond_B', 'Diamond_C'); } use Class::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'); Class-C3-0.33/t/32_next_method_edge_cases.t000644 000765 000024 00000003351 13077201754 020654 0ustar00gknopstaff000000 000000 #!/usr/bin/perl use strict; use warnings; use Test::More tests => 11; { { 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 $@; } } Class-C3-0.33/t/33_next_method_used_with_NEXT.t000644 000765 000024 00000002244 13077201754 021424 0ustar00gknopstaff000000 000000 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; BEGIN { our @ISA = ('Foo'); } sub foo { 'Fuz::foo => ' . (shift)->next::method } package Bar; use strict; use warnings; use Class::C3; BEGIN { our @ISA = ('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 BEGIN { our @ISA = ('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'); Class-C3-0.33/t/34_next_method_in_eval.t000644 000765 000024 00000001135 13077201754 020207 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More tests => 1; =pod This tests the use of an eval{} block to wrap a next::method call. =cut { package ClassA; use Class::C3; sub foo { die 'ClassA::foo died'; return 'ClassA::foo succeeded'; } } { package ClassB; BEGIN { our @ISA = ('ClassA'); } use Class::C3; sub foo { eval { return 'ClassB::foo => ' . (shift)->next::method(); }; if ($@) { return $@; } } } Class::C3::initialize(); like(ClassB->foo, qr/^ClassA::foo died/, 'method resolved inside eval{}'); Class-C3-0.33/t/35_next_method_in_anon.t000644 000765 000024 00000001700 13077201754 020212 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More tests => 2; =pod This tests the successful handling of a next::method call from within an anonymous subroutine. =cut { package ClassA; use Class::C3; sub foo { return 'ClassA::foo'; } sub bar { return 'ClassA::bar'; } } { package ClassB; BEGIN { our @ISA = ('ClassA'); } use Class::C3; sub foo { my $code = sub { return 'ClassB::foo => ' . (shift)->next::method(); }; return (shift)->$code; } sub bar { my $code1 = sub { my $code2 = sub { return 'ClassB::bar => ' . (shift)->next::method(); }; return (shift)->$code2; }; return (shift)->$code1; } } Class::C3::initialize(); is(ClassB->foo, "ClassB::foo => ClassA::foo", 'method resolved inside anonymous sub'); is(ClassB->bar, "ClassB::bar => ClassA::bar", 'method resolved inside nested anonymous subs'); Class-C3-0.33/t/36_next_goto.t000644 000765 000024 00000001506 13077201754 016206 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More tests => 4; use Class::C3; { package Proxy; our @ISA = qw//; sub next_proxy { goto &next::method } sub maybe_proxy { goto &maybe::next::method } sub can_proxy { goto &next::can } package TBase; our @ISA = qw//; sub foo { 42 } sub bar { 24 } # baz doesn't exist intentionally sub quux { 242 } package TTop; our @ISA = qw/TBase/; sub foo { shift->Proxy::next_proxy() } sub bar { shift->Proxy::maybe_proxy() } sub baz { shift->Proxy::maybe_proxy() } sub quux { shift->Proxy::can_proxy()->() } } is(TTop->foo, 42, 'proxy next::method via goto'); is(TTop->bar, 24, 'proxy maybe::next::method via goto'); is(TTop->baz, undef, 'proxy maybe::next::method via goto with no method'); is(TTop->quux, 242, 'proxy next::can via goto'); Class-C3-0.33/t/37_mro_warn.t000644 000765 000024 00000002475 13077201754 016033 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; BEGIN { if ($] < 5.009_005) { plan(skip_all => "This test is only applicable for perl >= 5.9.5"); } elsif ( ! eval { require MRO::Compat } || $@) { plan(skip_all => "MRO::Compat not available"); } elsif ( ! eval { require Class::C3 } || $@) { plan(skip_all => "Class::C3 not available"); } else { plan(tests => 2); } } { # If the bug still exists, I should get a few warnings my @warnings; local $SIG{__WARN__} = sub { push @warnings, $_[0]; }; # Remove symbols from respective tables, and # remove from INC, so we force re-evaluation foreach my $class (qw(Class::C3 MRO::Compat)) { my $file = $class; $file =~ s/::/\//g; $file .= '.pm'; delete $INC{$file}; { # Don't do this at home, kids! no strict 'refs'; foreach my $key (keys %{ "${class}::" }) { delete ${"${class}::"}{$key}; } } } eval { require MRO::Compat; require Class::C3; }; ok( ! $@, "Class::C3 loaded ok"); if (! ok( ! @warnings, "loading Class::C3 did not generate warnings" )) { diag("Generated warnings are (expecting 'subroutine redefined...')"); diag(" $_") for @warnings; } } Class-C3-0.33/t/40_no_xs.t000644 000765 000024 00000002232 12766424666 015333 0ustar00gknopstaff000000 000000 use strict; use warnings; use Test::More; BEGIN { plan skip_all => "PP tests not applicable for this perl $]" if $] > 5.009_004; plan skip_all => "All tests already executed in PP mode" unless eval { require Class::C3::XS }; plan skip_all => "Devel::Hide required for this test" unless eval { require Devel::Hide }; } use Config; use IPC::Open2 qw(open2); use File::Glob 'bsd_glob'; # for the $^X-es $ENV{PERL5LIB} = join ($Config{path_sep}, @INC); # rerun the tests under the assumption of pure-perl my $this_file = quotemeta(__FILE__); for my $fn (bsd_glob("t/*.t")) { next if $fn =~ /${this_file}$/; local $ENV{DEVEL_HIDE_VERBOSE} = 0; my @cmd = ( $^X, '-MDevel::Hide=Class::C3::XS', $fn ); # this is cheating, and may even hang here and there (testing on windows passed fine) # if it does - will have to fix it somehow (really *REALLY* don't want to pull # in IPC::Cmd just for a fucking test) # the alternative would be to have an ENV check in each test to force a subtest open2(my $out, my $in, @cmd); while (my $ln = <$out>) { print " $ln"; } wait; ok (! $?, "Exit $? from: @cmd"); } done_testing; Class-C3-0.33/opt/c3.pm000644 000765 000024 00000000537 12266111114 014675 0ustar00gknopstaff000000 000000 ## OPTIONAL MODULE # this module is supplied simply the use of this module # more aesthetically pleasing (at least to me), I think # it is much nicer to see: # # use c3; # # then to see a bunch of: # # use Class::C3; # # all over the place. package # ignore me PAUSE c3; BEGIN { use Class::C3; *{'c3::'} = *{'Class::C3::'}; } 1;Class-C3-0.33/maint/Makefile.PL.include000644 000765 000024 00000000436 12611066624 017743 0ustar00gknopstaff000000 000000 BEGIN { -e 'Distar' or system("git clone git://git.shadowcat.co.uk/p5sagit/Distar.git") } use lib 'Distar/lib'; use Distar 0.001; use ExtUtils::MakeMaker 6.57_10 (); author 'Stevan Little, '; manifest_include opt => '.pm'; manifest_include inc => '.pm'; 1; Class-C3-0.33/lib/Class/000755 000765 000024 00000000000 13077221665 015054 5ustar00gknopstaff000000 000000 Class-C3-0.33/lib/Class/C3/000755 000765 000024 00000000000 13077221665 015321 5ustar00gknopstaff000000 000000 Class-C3-0.33/lib/Class/C3.pm000644 000765 000024 00000044034 13077221560 015656 0ustar00gknopstaff000000 000000 package Class::C3; use strict; use warnings; our $VERSION = '0.33'; our $C3_IN_CORE; our $C3_XS; BEGIN { if($] > 5.009_004) { $C3_IN_CORE = 1; require mro; } elsif($C3_XS or not defined $C3_XS) { my $error = do { local $@; eval { require Class::C3::XS }; $@; }; if ($error) { die $error if $error !~ /\blocate\b/; if ($C3_XS) { require Carp; Carp::croak( "XS explicitly requested but Class::C3::XS is not available" ); } require Algorithm::C3; require Class::C3::next; } else { $C3_XS = 1; } } } # 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; mro::set_mro($class, 'c3') if $C3_IN_CORE; # make a note to calculate $class # during INIT phase $MRO{$class} = undef unless exists $MRO{$class}; } ## initializers # This prevents silly warnings when Class::C3 is # used explicitly along with MRO::Compat under 5.9.5+ { no warnings 'redefine'; sub initialize { %next::METHOD_CACHE = (); # why bother if we don't have anything ... return unless keys %MRO; if($C3_IN_CORE) { mro::set_mro($_, 'c3') for keys %MRO; } else { if($_initialized) { uninitialize(); $MRO{$_} = undef foreach keys %MRO; } _calculate_method_dispatch_tables(); _apply_method_dispatch_tables(); $_initialized = 1; } } sub uninitialize { # why bother if we don't have anything ... %next::METHOD_CACHE = (); return unless keys %MRO; if($C3_IN_CORE) { mro::set_mro($_, 'dfs') for keys %MRO; } else { _remove_method_dispatch_tables(); $_initialized = 0; } } sub reinitialize { goto &initialize } } # end of "no warnings 'redefine'" ## functions for applying C3 to classes sub _calculate_method_dispatch_tables { return if $C3_IN_CORE; my %merge_cache; foreach my $class (keys %MRO) { _calculate_method_dispatch_table($class, \%merge_cache); } } sub _calculate_method_dispatch_table { return if $C3_IN_CORE; my ($class, $merge_cache) = @_; no strict 'refs'; my @MRO = calculateMRO($class, $merge_cache); $MRO{$class} = { MRO => \@MRO }; my $has_overload_fallback; my %methods; # NOTE: # we do @MRO[1 .. $#MRO] here because it # makes no sense to interrogate 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 $has_overload_fallback && defined ${"${local}::()"}; foreach my $method (grep { defined &{"${local}::$_"} } keys %{"${local}::"}) { # skip if already overridden 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 { return if $C3_IN_CORE; foreach my $class (keys %MRO) { _apply_method_dispatch_table($class); } } sub _apply_method_dispatch_table { return if $C3_IN_CORE; my $class = shift; no strict 'refs'; ${"${class}::()"} = $MRO{$class}->{has_overload_fallback} if !defined &{"${class}::()"} && defined $MRO{$class}->{has_overload_fallback}; foreach my $method (keys %{$MRO{$class}->{methods}}) { if ( $method =~ /^\(/ ) { my $orig = $MRO{$class}->{methods}->{$method}->{orig}; ${"${class}::$method"} = $$orig if defined $$orig; } *{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code}; } } sub _remove_method_dispatch_tables { return if $C3_IN_CORE; foreach my $class (keys %MRO) { _remove_method_dispatch_table($class); } } sub _remove_method_dispatch_table { return if $C3_IN_CORE; 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}); } } sub calculateMRO { my ($class, $merge_cache) = @_; return Algorithm::C3::merge($class, sub { no strict 'refs'; @{$_[0] . '::ISA'}; }, $merge_cache); } # Method overrides to support 5.9.5+ or Class::C3::XS sub _core_calculateMRO { @{mro::get_linear_isa($_[0], 'c3')} } if($C3_IN_CORE) { no warnings 'redefine'; *Class::C3::calculateMRO = \&_core_calculateMRO; } elsif($C3_XS) { no warnings 'redefine'; *Class::C3::calculateMRO = \&Class::C3::XS::calculateMRO; *Class::C3::_calculate_method_dispatch_table = \&Class::C3::XS::_calculate_method_dispatch_table; } 1; __END__ =pod =head1 NAME Class::C3 - A pragma to use the C3 method resolution order algorithm =head1 SYNOPSIS # NOTE - DO NOT USE Class::C3 directly as a user, use MRO::Compat instead! package ClassA; use Class::C3; sub hello { 'A::hello' } package ClassB; use base 'ClassA'; use Class::C3; package ClassC; use base 'ClassA'; use Class::C3; sub hello { 'C::hello' } package ClassD; use base ('ClassB', 'ClassC'); use Class::C3; # Classic Diamond MI pattern # # / \ # # \ / # package main; # initializez the C3 module # (formerly called in INIT) Class::C3::initialize(); print join ', ' => Class::C3::calculateMRO('ClassD'); # prints ClassD, ClassB, ClassC, ClassA print ClassD->hello(); # prints 'C::hello' instead of the standard p5 'A::hello' ClassD->can('hello')->(); # can() also works correctly UNIVERSAL::can('ClassD', 'hello'); # as does UNIVERSAL::can() =head1 DESCRIPTION This is pragma to change Perl 5's standard method resolution order from depth-first left-to-right (a.k.a - pre-order) to the more sophisticated C3 method resolution order. B YOU SHOULD NOT USE THIS MODULE DIRECTLY - The feature provided is integrated into perl version >= 5.9.5, and you should use L instead, which will use the core implementation in newer perls, but fallback to using this implementation on older perls. =head2 What is C3? C3 is the name of an algorithm which aims to provide a sane method resolution order under multiple inheritance. It was first introduced in the language Dylan (see links in the L section), and then later adopted as the preferred MRO (Method Resolution Order) for the new-style classes in Python 2.3. Most recently it has been adopted as the 'canonical' MRO for Perl 6 classes, and the default MRO for Parrot objects as well. =head2 How does C3 work. C3 works by always preserving local precedence ordering. This essentially means that no class will appear before any of its subclasses. Take the classic diamond inheritance pattern for instance: / \ \ / The standard Perl 5 MRO would be (D, B, A, C). The result being that B appears before B, even though B is the subclass of B. The C3 MRO algorithm however, produces the following MRO (D, B, C, A), which does not have this same issue. This example is fairly trivial, for more complex examples and a deeper explanation, see the links in the L section. =head2 How does this module work? This module uses a technique similar to Perl 5's method caching. When C is called, this module calculates the MRO of all the classes which called C. It then gathers information from the symbol tables of each of those classes, and builds a set of method aliases for the correct dispatch ordering. Once all these C3-based method tables are created, it then adds the method aliases into the local classes symbol table. The end result is actually classes with pre-cached method dispatch. However, this caching does not do well if you start changing your C<@ISA> or messing with class symbol tables, so you should consider your classes to be effectively closed. See the L section for more details. =head1 OPTIONAL LOWERCASE PRAGMA This release also includes an optional module B in the F folder. I did not include this in the regular install since lowercase module names are considered I<"bad"> by some people. However I think that code looks much nicer like this: package MyClass; use c3; This is more clunky: package MyClass; use Class::C3; But hey, it's your choice, that's why it is optional. =head1 FUNCTIONS =over 4 =item B Given a C<$class> this will return an array of class names in the proper C3 method resolution order. =item B This B to initialize the C3 method dispatch tables, this module B if you do not do this. It is advised to do this as soon as possible B loading any classes which use C3. Here is a quick code example: package Foo; use Class::C3; # ... Foo methods here package Bar; use Class::C3; use base 'Foo'; # ... Bar methods here package main; Class::C3::initialize(); # now it is safe to use Foo and Bar This function used to be called automatically for you in the INIT phase of the perl compiler, but that lead to warnings if this module was required at runtime. After discussion with my user base (the L folks), we decided that calling this in INIT was more of an annoyance than a convenience. I apologize to anyone this causes problems for (although I would be very surprised if I had any other users other than the L folks). The simplest solution of course is to define your own INIT method which calls this function. NOTE: If C detects that C has already been executed, it will L and clear the MRO cache first. =item B Calling this function results in the removal of all cached methods, and the restoration of the old Perl 5 style dispatch order (depth-first, left-to-right). =item B This is an alias for L above. =back =head1 METHOD REDISPATCHING It is always useful to be able to re-dispatch your method call to the "next most applicable method". This module provides a pseudo package along the lines of C or C which will re-dispatch the method along the C3 linearization. This is best shown with an example. # a classic diamond MI pattern ... # # / \ # # \ / # package ClassA; use Class::C3; sub foo { 'ClassA::foo' } package ClassB; use base 'ClassA'; use Class::C3; sub foo { 'ClassB::foo => ' . (shift)->next::method() } package ClassC; use base 'ClassA'; use Class::C3; sub foo { 'ClassC::foo => ' . (shift)->next::method() } package ClassD; use base ('ClassB', 'ClassC'); use Class::C3; sub foo { 'D::foo => ' . (shift)->next::method() } print D->foo; # prints out "D::foo => B::foo => C::foo => A::foo" A few things to note. First, we do not require you to add on the method name to the C call (this is unlike C and C which do require that). This helps to enforce the rule that you cannot dispatch to a method of a different name (this is how C behaves as well). The next thing to keep in mind is that you will need to pass all arguments to C. It can not automatically use the current C<@_>. If C cannot find a next method to re-dispatch the call to, it will throw an exception. You can use C to see if C will succeed before you call it like so: $self->next::method(@_) if $self->next::can; Additionally, you can use C as a shortcut to only call the next method if it exists. The previous example could be simply written as: $self->maybe::next::method(@_); There are some caveats about using C, see below for those. =head1 CAVEATS This module used to be labeled as I, however it has now been pretty heavily tested by the good folks over at L and I am confident this module is perfectly usable for whatever your needs might be. But there are still caveats, so here goes ... =over 4 =item Use of C. The idea of C under multiple inheritance is ambiguous, and generally not recommended anyway. However, its use in conjunction with this module is very much not recommended, and in fact very discouraged. The recommended approach is to instead use the supplied C feature, see more details on its usage above. =item Changing C<@ISA>. It is the author's opinion that changing C<@ISA> at runtime is pure insanity anyway. However, people do it, so I must caveat. Any changes to the C<@ISA> will not be reflected in the MRO calculated by this module, and therefore probably won't even show up. If you do this, you will need to call C in order to recalculate B method dispatch tables. See the C documentation and an example in F for more information. =item Adding/deleting methods from class symbol tables. This module calculates the MRO for each requested class by interrogating the symbol tables of said classes. So any symbol table manipulation which takes place after our INIT phase is run will not be reflected in the calculated MRO. Just as with changing the C<@ISA>, you will need to call C for any changes you make to take effect. =item Calling C from methods defined outside the class There is an edge case when using C from within a subroutine which was created in a different module than the one it is called from. It sounds complicated, but it really isn't. Here is an example which will not work correctly: *Foo::foo = sub { (shift)->next::method(@_) }; The problem exists because the anonymous subroutine being assigned to the glob C<*Foo::foo> will show up in the call stack as being called C<__ANON__> and not C as you might expect. Since C uses C to find the name of the method it was called in, it will fail in this case. But fear not, there is a simple solution. The module C will reach into the perl internals and assign a name to an anonymous subroutine for you. Simply do this: use Sub::Name 'subname'; *Foo::foo = subname 'Foo::foo' => sub { (shift)->next::method(@_) }; and things will Just Work. Of course this is not always possible to do, but to be honest, I just can't manage to find a workaround for it, so until someone gives me a working patch this will be a known limitation of this module. =back =head1 COMPATIBILITY If your software requires Perl 5.9.5 or higher, you do not need L, you can simply C, and not worry about C, avoid some of the above caveats, and get the best possible performance. See L for more details. If your software is meant to work on earlier Perls, use L as documented here. L will detect Perl 5.9.5+ and take advantage of the core support when available. =head1 Class::C3::XS This module will load L if it's installed and you are running on a Perl version older than 5.9.5. The optional module will be automatically installed for you if a C compiler is available, as it results in significant performance improvements (but unlike the 5.9.5+ core support, it still has all of the same caveats as L). =head1 CODE COVERAGE L was reporting 94.4% overall test coverage earlier in this module's life. Currently, the test suite does things that break under coverage testing, but it is fair to assume the coverage is still close to that value. =head1 SEE ALSO =head2 The original Dylan paper =over 4 =item L =back =head2 The prototype Perl 6 Object Model uses C3 =over 4 =item L =back =head2 Parrot now uses C3 =over 4 =item L =item L =back =head2 Python 2.3 MRO related links =over 4 =item L =item L =back =head2 C3 for TinyCLOS =over 4 =item L =back =head1 ACKNOWLEGEMENTS =over 4 =item Thanks to Matt S. Trout for using this module in his module L and finding many bugs and providing fixes. =item Thanks to Justin Guenther for making C more robust by handling calls inside C and anon-subs. =item Thanks to Robert Norris for adding support for C and C. =back =head1 AUTHOR Stevan Little, Brandon L. Black, =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 Class-C3-0.33/lib/Class/C3/next.pm000644 000765 000024 00000004316 13077221560 016633 0ustar00gknopstaff000000 000000 package # hide me from PAUSE next; use strict; use warnings; no warnings 'redefine'; # for 00load.t w/ core support use Scalar::Util 'blessed'; our $VERSION = '0.33'; our %METHOD_CACHE; sub method { my $self = $_[0]; my $class = blessed($self) || $self; 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 $method; my $caller = join '::' => @label; $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; no warnings 'redefine'; # for 00load.t w/ core support our $VERSION = '0.33'; sub method { (next::method($_[0]) || return)->(@_) } 1; __END__ =pod =head1 NAME Class::C3::next - Pure-perl next::method and friends =head1 DESCRIPTION This module is used internally by L when necessary, and shouldn't be used (or required in distribution dependencies) directly. It defines C, C, and C in pure perl. =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 Class-C3-0.33/inc/ExtUtils/000755 000765 000024 00000000000 13077221665 015573 5ustar00gknopstaff000000 000000 Class-C3-0.33/inc/ExtUtils/HasCompiler.pm000644 000765 000024 00000014267 13077207070 020343 0ustar00gknopstaff000000 000000 package ExtUtils::HasCompiler; $ExtUtils::HasCompiler::VERSION = '0.017'; use strict; use warnings; use base 'Exporter'; our @EXPORT_OK = qw/can_compile_loadable_object/; our %EXPORT_TAGS = (all => \@EXPORT_OK); use Config; use Carp 'carp'; use File::Basename 'basename'; use File::Spec::Functions qw/catfile catdir rel2abs/; use File::Temp qw/tempdir tempfile/; my $tempdir = tempdir('HASCOMPILERXXXX', CLEANUP => 1, DIR => '.'); my $loadable_object_format = <<'END'; #define PERL_NO_GET_CONTEXT #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifndef PERL_UNUSED_VAR #define PERL_UNUSED_VAR(var) #endif XS(exported) { #ifdef dVAR dVAR; #endif dXSARGS; PERL_UNUSED_VAR(cv); /* -W */ PERL_UNUSED_VAR(items); /* -W */ XSRETURN_IV(42); } #ifndef XS_EXTERNAL #define XS_EXTERNAL(foo) XS(foo) #endif /* we don't want to mess with .def files on mingw */ #if defined(WIN32) && defined(__GNUC__) # define EXPORT __declspec(dllexport) #else # define EXPORT #endif EXPORT XS_EXTERNAL(boot_%s) { #ifdef dVAR dVAR; #endif dXSARGS; PERL_UNUSED_VAR(cv); /* -W */ PERL_UNUSED_VAR(items); /* -W */ newXS("%s::exported", exported, __FILE__); } END my $counter = 1; my %prelinking = map { $_ => 1 } qw/MSWin32 VMS aix/; sub can_compile_loadable_object { my %args = @_; my $output = $args{output} || \*STDOUT; my $config = $args{config} || 'ExtUtils::HasCompiler::Config'; return if not $config->get('usedl'); my ($source_handle, $source_name) = tempfile('TESTXXXX', DIR => $tempdir, SUFFIX => '.c', UNLINK => 1); my $basename = basename($source_name, '.c'); my $shortname = '_Loadable' . $counter++; my $package = "ExtUtils::HasCompiler::$shortname"; printf $source_handle $loadable_object_format, $basename, $package or do { carp "Couldn't write to $source_name: $!"; return }; close $source_handle or do { carp "Couldn't close $source_name: $!"; return }; my $abs_basename = catfile($tempdir, $basename); my $object_file = $abs_basename . $config->get('_o'); my $loadable_object = $abs_basename . '.' . $config->get('dlext'); my $incdir = catdir($config->get('archlibexp'), 'CORE'); my ($cc, $ccflags, $optimize, $cccdlflags, $ld, $ldflags, $lddlflags, $libperl, $perllibs) = map { $config->get($_) } qw/cc ccflags optimize cccdlflags ld ldflags lddlflags libperl perllibs/; if ($prelinking{$^O}) { require ExtUtils::Mksymlists; ExtUtils::Mksymlists::Mksymlists(NAME => $basename, FILE => $abs_basename, IMPORTS => {}); } my @commands; if ($^O eq 'MSWin32' && $cc =~ /^cl/) { push @commands, qq{$cc $ccflags $cccdlflags $optimize /I "$incdir" /c $source_name /Fo$object_file}; push @commands, qq{$ld $object_file $lddlflags $libperl $perllibs /out:$loadable_object /def:$abs_basename.def /pdb:$abs_basename.pdb}; } elsif ($^O eq 'VMS') { # Mksymlists is only the beginning of the story. open my $opt_fh, '>>', "$abs_basename.opt" or do { carp "Couldn't append to '$abs_basename.opt'"; return }; print $opt_fh "PerlShr/Share\n"; close $opt_fh; my $incdirs = $ccflags =~ s{ /inc[^=]+ (?:=)+ (?:\()? ( [^\/\)]* ) }{}xi ? "$1,$incdir" : $incdir; push @commands, qq{$cc $ccflags $optimize /include=($incdirs) $cccdlflags $source_name /obj=$object_file}; push @commands, qq{$ld $ldflags $lddlflags=$loadable_object $object_file,$abs_basename.opt/OPTIONS,${incdir}perlshr_attr.opt/OPTIONS' $perllibs}; } else { my @extra; if ($^O eq 'MSWin32') { my $lib = '-l' . ($libperl =~ /lib([^.]+)\./)[0]; push @extra, "$abs_basename.def", $lib, $perllibs; } elsif ($^O eq 'cygwin') { push @extra, catfile($incdir, $config->get('useshrplib') ? 'libperl.dll.a' : 'libperl.a'); } elsif ($^O eq 'aix') { $lddlflags =~ s/\Q$(BASEEXT)\E/$abs_basename/; $lddlflags =~ s/\Q$(PERL_INC)\E/$incdir/; } elsif ($^O eq 'android') { push @extra, qq{"-L$incdir"}, '-lperl', $perllibs; } push @commands, qq{$cc $ccflags $optimize "-I$incdir" $cccdlflags -c $source_name -o $object_file}; push @commands, qq{$ld $object_file -o $loadable_object $lddlflags @extra}; } for my $command (@commands) { print $output "$command\n" if not $args{quiet}; system $command and do { carp "Couldn't execute $command: $!"; return }; } # Skip loading when cross-compiling return 1 if exists $args{skip_load} ? $args{skip_load} : $config->get('usecrosscompile'); require DynaLoader; local @DynaLoader::dl_require_symbols = "boot_$basename"; my $handle = DynaLoader::dl_load_file(rel2abs($loadable_object), 0); if ($handle) { my $symbol = DynaLoader::dl_find_symbol($handle, "boot_$basename") or do { carp "Couldn't find boot symbol for $basename"; return }; my $compilet = DynaLoader::dl_install_xsub('__ANON__::__ANON__', $symbol, $source_name); my $ret = eval { $compilet->(); $package->exported } or carp $@; delete $ExtUtils::HasCompiler::{"$shortname\::"}; eval { DynaLoader::dl_unload_file($handle) } or carp $@; return defined $ret && $ret == 42; } else { carp "Couldn't load $loadable_object: " . DynaLoader::dl_error(); return; } } sub ExtUtils::HasCompiler::Config::get { my (undef, $key) = @_; return $ENV{uc $key} || $Config{$key}; } 1; # ABSTRACT: Check for the presence of a compiler __END__ =pod =encoding UTF-8 =head1 NAME ExtUtils::HasCompiler - Check for the presence of a compiler =head1 VERSION version 0.017 =head1 DESCRIPTION This module tries to check if the current system is capable of compiling, linking and loading an XS module. B: this is an early release, interface stability isn't guaranteed yet. =head1 FUNCTIONS =head2 can_compile_loadable_object(%opts) This checks if the system can compile, link and load a perl loadable object. It may take the following options: =over 4 =item * quiet Do not output the executed compilation commands. =item * config An L (compatible) object for configuration. =item * skip_load This causes can_compile_loadable_object to not try to load the generated object. This defaults to true on a cross-compiling perl. =back =head1 AUTHOR Leon Timmermans =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2014 by Leon Timmermans. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut