Class-C3-0.35/000755 000000 000000 00000000000 13752157660 013064 5ustar00rootwheel000000 000000 Class-C3-0.35/inc/000755 000000 000000 00000000000 13752157656 013642 5ustar00rootwheel000000 000000 Class-C3-0.35/README000644 000000 000000 00000031506 13752157660 013751 0ustar00rootwheel000000 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 { 'ClassD::foo => ' . (shift)->next::method() } print ClassD->foo; # prints out "ClassD::foo => ClassB::foo => ClassC::foo => ClassA::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.35/Changes000644 000000 000000 00000014336 13752157635 014370 0ustar00rootwheel000000 000000 Revision history for Perl extension Class::C3. 0.35 - 2020-11-09 - update bundled ExtUtils::HasCompiler to 0.022 - support PUREPERL_ONLY environment variable during installation - fix no-XS test to not require newer Test::More that declared prereq - drop optional Devel::Hide prereq 0.34 - 2018-04-19 - update bundled ExtUtils::HasCompiler to 0.021 - fix some examples in pod 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.35/MANIFEST000644 000000 000000 00000001637 13752157660 014224 0ustar00rootwheel000000 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 t/lib/HideModule.pm 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) LICENSE LICENSE file (added by Distar) Class-C3-0.35/LICENSE000644 000000 000000 00000043447 13752157660 014105 0ustar00rootwheel000000 000000 Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2020 by Stevan Little, . This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2020 by Stevan Little, . This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End Class-C3-0.35/t/000755 000000 000000 00000000000 13752157656 013334 5ustar00rootwheel000000 000000 Class-C3-0.35/xt/000755 000000 000000 00000000000 13752157656 013524 5ustar00rootwheel000000 000000 Class-C3-0.35/META.yml000644 000000 000000 00000001546 13752157657 014351 0ustar00rootwheel000000 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.50, CPAN::Meta::Converter version 2.150010' 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.35' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Class-C3-0.35/META.json000644 000000 000000 00000003301 13752157657 014510 0ustar00rootwheel000000 000000 { "abstract" : "A pragma to use the C3 method resolution order algorithm", "author" : [ "Stevan Little, " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.50, CPAN::Meta::Converter version 2.150010", "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.35", "x_serialization_backend" : "JSON::PP version 4.05" } Class-C3-0.35/lib/000755 000000 000000 00000000000 13752157656 013637 5ustar00rootwheel000000 000000 Class-C3-0.35/opt/000755 000000 000000 00000000000 13752157656 013673 5ustar00rootwheel000000 000000 Class-C3-0.35/maint/000755 000000 000000 00000000000 13752157656 014201 5ustar00rootwheel000000 000000 Class-C3-0.35/Makefile.PL000644 000000 000000 00000006676 13747201577 015056 0ustar00rootwheel000000 000000 use strict; use warnings FATAL => 'all'; use 5.006; use lib 'inc'; 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 = ( PREREQ_PM => { ( $] < 5.009_005 and want_xs() ) ? ( 'Class::C3::XS' => '0.13' ) : () }, ); sub parse_args { require Text::ParseWords; require ExtUtils::MakeMaker; # copied from EUMM my $tmp = {}; ExtUtils::MakeMaker::parse_args( $tmp, Text::ParseWords::shellwords($ENV{PERL_MM_OPT} || ''), @ARGV, ); return $tmp->{ARGS} || {}; } sub want_xs { my $explicit_pp = defined $ENV{PUREPERL_ONLY} ? $ENV{PUREPERL_ONLY} : parse_args()->{PUREPERL_ONLY}; return !$explicit_pp if defined $explicit_pp; require ExtUtils::HasCompiler; return ExtUtils::HasCompiler::can_compile_loadable_object(quiet => 1) } ## 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'; $MM_ARGS{PL_FILES} ||= {}; $MM_ARGS{NORECURS} = 1 if not exists $MM_ARGS{NORECURS}; 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.35/maint/Makefile.PL.include000644 000000 000000 00000000436 13662440405 017563 0ustar00rootwheel000000 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.35/opt/c3.pm000644 000000 000000 00000000537 13662440405 014526 0ustar00rootwheel000000 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.35/lib/Class/000755 000000 000000 00000000000 13752157656 014704 5ustar00rootwheel000000 000000 Class-C3-0.35/lib/Class/C3.pm000644 000000 000000 00000044072 13752157625 015512 0ustar00rootwheel000000 000000 package Class::C3; use strict; use warnings; our $VERSION = '0.35'; 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 { 'ClassD::foo => ' . (shift)->next::method() } print ClassD->foo; # prints out "ClassD::foo => ClassB::foo => ClassC::foo => ClassA::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.35/lib/Class/C3/000755 000000 000000 00000000000 13752157656 015151 5ustar00rootwheel000000 000000 Class-C3-0.35/lib/Class/C3/next.pm000644 000000 000000 00000004276 13752157625 016472 0ustar00rootwheel000000 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.35'; 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.35'; 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, 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.35/xt/pod.t000644 000000 000000 00000000125 13662440405 014454 0ustar00rootwheel000000 000000 use strict; use warnings; use Test::More; use Test::Pod 1.14; all_pod_files_ok(); Class-C3-0.35/xt/pod_coverage.t000644 000000 000000 00000000213 13662440405 016325 0ustar00rootwheel000000 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.35/t/24_more_overload.t000644 000000 000000 00000002555 13662440405 016655 0ustar00rootwheel000000 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.35/t/35_next_method_in_anon.t000644 000000 000000 00000001700 13662440405 020030 0ustar00rootwheel000000 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.35/t/01_MRO.t000644 000000 000000 00000003271 13662440405 014444 0ustar00rootwheel000000 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.35/t/33_next_method_used_with_NEXT.t000644 000000 000000 00000002244 13662440405 021242 0ustar00rootwheel000000 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.35/t/23_multi_init.t000644 000000 000000 00000001644 13662440405 016172 0ustar00rootwheel000000 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.35/t/03_MRO.t000644 000000 000000 00000005160 13662440405 014445 0ustar00rootwheel000000 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.35/t/00_load.t000644 000000 000000 00000001450 13662440405 014722 0ustar00rootwheel000000 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.35/t/21_C3_with_overload.t000644 000000 000000 00000003064 13662440405 017204 0ustar00rootwheel000000 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.35/t/30_next_method.t000644 000000 000000 00000002770 13662440405 016332 0ustar00rootwheel000000 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.35/t/05_MRO.t000644 000000 000000 00000001315 13662440405 014445 0ustar00rootwheel000000 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.35/t/34_next_method_in_eval.t000644 000000 000000 00000001135 13662440405 020025 0ustar00rootwheel000000 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.35/t/02_MRO.t000644 000000 000000 00000006775 13662440405 014461 0ustar00rootwheel000000 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.35/t/20_reinitialize.t000644 000000 000000 00000003010 13662440405 016467 0ustar00rootwheel000000 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.35/t/10_Inconsistent_hierarchy.t000644 000000 000000 00000001773 13662440405 020532 0ustar00rootwheel000000 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.35/t/04_MRO.t000644 000000 000000 00000002554 13662440405 014452 0ustar00rootwheel000000 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.35/t/06_MRO.t000644 000000 000000 00000001733 13662440405 014452 0ustar00rootwheel000000 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.35/t/36_next_goto.t000644 000000 000000 00000001506 13662440405 016024 0ustar00rootwheel000000 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.35/t/40_no_xs.t000644 000000 000000 00000002216 13747173247 015151 0ustar00rootwheel000000 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 }; } use Config; use IPC::Open2 qw(open2); use File::Glob 'bsd_glob'; use Cwd (); # for the $^X-es $ENV{PERL5LIB} = join ($Config{path_sep}, @INC); # rerun the tests under the assumption of pure-perl my $this_file = Cwd::realpath(__FILE__); my @tests = grep $this_file ne Cwd::realpath($_), bsd_glob("t/*.t"); plan tests => scalar @tests; for my $fn (@tests) { local $ENV{DEVEL_HIDE_VERBOSE} = 0; my @cmd = ( $^X, '-It/lib', '-MHideModule=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.35/t/lib/000755 000000 000000 00000000000 13752157656 014102 5ustar00rootwheel000000 000000 Class-C3-0.35/t/31_next_method_skip.t000644 000000 000000 00000004627 13662440405 017364 0ustar00rootwheel000000 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.35/t/22_uninitialize.t000644 000000 000000 00000003552 13662440405 016520 0ustar00rootwheel000000 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.35/t/37_mro_warn.t000644 000000 000000 00000002475 13662440405 015651 0ustar00rootwheel000000 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.35/t/32_next_method_edge_cases.t000644 000000 000000 00000003351 13662440405 020472 0ustar00rootwheel000000 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.35/t/lib/HideModule.pm000644 000000 000000 00000000713 13747173163 016453 0ustar00rootwheel000000 000000 package HideModule; use strict; use warnings; my %hide; sub import { shift; @hide{@_} = (); my $hook = \&_hook; for my $i (reverse 0 .. $#INC) { if (ref $INC[$i] eq ref $hook && $INC[$i] == $hook) { splice @INC, $i, 1; } } unshift @INC, $hook; } sub _hook { my (undef, $file) = @_; if (exists $hide{$file}) { die sprintf 'Can\'t locate %s in @INC (Hidden Module) at %s line %s.', $file, (caller)[1,2]; } return; } 1; Class-C3-0.35/inc/ExtUtils/000755 000000 000000 00000000000 13752157656 015423 5ustar00rootwheel000000 000000 Class-C3-0.35/inc/ExtUtils/HasCompiler.pm000644 000000 000000 00000022042 13747174106 020160 0ustar00rootwheel000000 000000 package ExtUtils::HasCompiler; $ExtUtils::HasCompiler::VERSION = '0.022'; use strict; use warnings; use base 'Exporter'; our @EXPORT_OK = qw/can_compile_loadable_object can_compile_static_library can_compile_extension/; 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 $abs_basename = catfile($tempdir, $basename); my ($cc, $ccflags, $optimize, $cccdlflags, $ld, $ldflags, $lddlflags, $libperl, $perllibs, $archlibexp, $_o, $dlext) = map { $config->get($_) } qw/cc ccflags optimize cccdlflags ld ldflags lddlflags libperl perllibs archlibexp _o dlext/; my $incdir = catdir($archlibexp, 'CORE'); my $object_file = $abs_basename.$_o; my $loadable_object = "$abs_basename.$dlext"; 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 =~ /^(cygwin|msys)$/) { 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}; } if ($prelinking{$^O}) { require ExtUtils::Mksymlists; ExtUtils::Mksymlists::Mksymlists(NAME => $basename, FILE => $abs_basename, IMPORTS => {}); } 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 }; 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; } } my %static_unsupported_on = map { $_ => 1 } qw/VMS aix MSWin32 cygwin/; sub can_compile_static_library { my %args = @_; my $output = $args{output} || \*STDOUT; my $config = $args{config} || 'ExtUtils::HasCompiler::Config'; return if $config->get('useshrplib') eq 'true'; my ($source_handle, $source_name) = tempfile('TESTXXXX', DIR => $tempdir, SUFFIX => '.c', UNLINK => 1); my $basename = basename($source_name, '.c'); my $abs_basename = catfile($tempdir, $basename); my ($cc, $ccflags, $optimize, $ar, $full_ar, $ranlib, $archlibexp, $_o, $lib_ext) = map { $config->get($_) } qw/cc ccflags optimize ar full_ar ranlib archlibexp _o lib_ext/; my $incdir = catdir($archlibexp, 'CORE'); my $object_file = "$abs_basename$_o"; my $static_library = $abs_basename.$lib_ext; my @commands; if ($static_unsupported_on{$^O}) { return; } else { my $my_ar = length $full_ar ? $full_ar : $ar; push @commands, qq{$cc $ccflags $optimize "-I$incdir" -c $source_name -o $object_file}; push @commands, qq{$my_ar cr $static_library $object_file}; push @commands, qq{$ranlib $static_library} if $ranlib ne ':'; } 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 }; for my $command (@commands) { print $output "$command\n" if not $args{quiet}; system $command and do { carp "Couldn't execute $command: $!"; return }; } return 1; } sub can_compile_extension { my %args = @_; $args{config} ||= 'ExtUtils::HasCompiler::Config'; my $linktype = $args{linktype} || ($args{config}->get('usedl') ? 'dynamic' : 'static'); return $linktype eq 'static' ? can_compile_static_library(%args) : can_compile_loadable_object(%args); } 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.022 =head1 SYNOPSIS use ExtUtils::HasCompiler 'can_compile_extension'; if (can_compile_extension()) { ... } else { ... } =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 =head2 can_compile_static_library(%opts) This checks if the system can compile and link a perl static library. It does not check it it can compile a new perl with it. 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. =back =head2 can_compile_extension(%opts) This will call either C, or C, depending on which is the default on your configuration. In addition to the arguments listed above, it can take one more optional argument: =over 4 =item * linktype This will force the linktype to be either static or dynamic. Dynamic compilation on a static perl won't work, but static libraries can be viable on a dynamic 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