From 1a605816ae4f1b462317860177227f50228b8b59 Mon Sep 17 00:00:00 2001 From: TizenOpenSource Date: Wed, 14 Feb 2024 14:16:48 +0900 Subject: [PATCH] Imported Upstream version 2.002004 --- Changes | 286 +++++++++ LICENSE | 374 +++++++++++ MANIFEST | 44 ++ META.json | 64 ++ META.yml | 30 + Makefile.PL | 109 ++++ README | 235 +++++++ lib/Role/Tiny.pm | 823 +++++++++++++++++++++++++ lib/Role/Tiny/With.pm | 50 ++ maint/Makefile.PL.include | 12 + t/concrete-methods.t | 134 ++++ t/create-hook.t | 26 + t/does.t | 59 ++ t/extend-role-tiny.t | 42 ++ t/extend.t | 52 ++ t/lib/BrokenModule.pm | 6 + t/lib/ExistingModule.pm | 4 + t/lib/FalseModule.pm | 3 + t/lib/TrueModule.pm | 4 + t/load-module.t | 41 ++ t/make-role.t | 22 + t/method-conflicts.t | 51 ++ t/namespace-clean.t | 74 +++ t/overload.t | 82 +++ t/proto.t | 58 ++ t/role-basic-basic.t | 38 ++ t/role-basic-bugs.t | 100 +++ t/role-basic-composition.t | 261 ++++++++ t/role-basic-exceptions.t | 79 +++ t/role-duplication.t | 45 ++ t/role-long-package-name.t | 52 ++ t/role-tiny-composition.t | 42 ++ t/role-tiny-with.t | 57 ++ t/role-tiny.t | 126 ++++ t/role-with-inheritance.t | 30 + t/stub.t | 61 ++ t/subclass.t | 164 +++++ xt/around-does.t | 35 ++ xt/compose-modifiers.t | 97 +++ xt/dependents.t | 308 +++++++++ xt/dependents/Moo-isa-assign.patch | 11 + xt/dependents/Moo-sort-sub-quote.patch | 10 + xt/modifiers.t | 79 +++ xt/recompose-modifier.t | 82 +++ 44 files changed, 4362 insertions(+) create mode 100644 Changes create mode 100644 LICENSE create mode 100644 MANIFEST create mode 100644 META.json create mode 100644 META.yml create mode 100644 Makefile.PL create mode 100644 README create mode 100644 lib/Role/Tiny.pm create mode 100644 lib/Role/Tiny/With.pm create mode 100644 maint/Makefile.PL.include create mode 100644 t/concrete-methods.t create mode 100644 t/create-hook.t create mode 100644 t/does.t create mode 100644 t/extend-role-tiny.t create mode 100644 t/extend.t create mode 100644 t/lib/BrokenModule.pm create mode 100644 t/lib/ExistingModule.pm create mode 100644 t/lib/FalseModule.pm create mode 100644 t/lib/TrueModule.pm create mode 100644 t/load-module.t create mode 100644 t/make-role.t create mode 100644 t/method-conflicts.t create mode 100644 t/namespace-clean.t create mode 100644 t/overload.t create mode 100644 t/proto.t create mode 100644 t/role-basic-basic.t create mode 100644 t/role-basic-bugs.t create mode 100644 t/role-basic-composition.t create mode 100644 t/role-basic-exceptions.t create mode 100644 t/role-duplication.t create mode 100644 t/role-long-package-name.t create mode 100644 t/role-tiny-composition.t create mode 100644 t/role-tiny-with.t create mode 100644 t/role-tiny.t create mode 100644 t/role-with-inheritance.t create mode 100644 t/stub.t create mode 100644 t/subclass.t create mode 100644 xt/around-does.t create mode 100644 xt/compose-modifiers.t create mode 100644 xt/dependents.t create mode 100644 xt/dependents/Moo-isa-assign.patch create mode 100644 xt/dependents/Moo-sort-sub-quote.patch create mode 100644 xt/modifiers.t create mode 100644 xt/recompose-modifier.t diff --git a/Changes b/Changes new file mode 100644 index 0000000..182b379 --- /dev/null +++ b/Changes @@ -0,0 +1,286 @@ +Revision history for Role-Tiny + +2.002004 - 2021-01-24 + - restore requiring base class when using create_class_with_roles, which was + accidentally lost in 2.002_000 (RT#134075) + +2.002003 - 2021-01-11 + - set dynamic_config to 0 and x_static_install to 1 + - fixed filenames in dependents author test to not use colons + - removed MRO::Compat from prereqs as it is no longer used + - marked Class::Method::Modifiers as a hard developer dependency rather than + a recommended developer dependency + - rewrote test for namespace cleaning to not require namespace::clean, and + moved it from an author test to a normal test + - removed namespace::autoclean from developer prereqs + +2.002_002 - 2021-01-03 + - refactored some internals for subclasses to use + - methods_provided_by will ensure the module is loaded before checking for + methods + +2.002_001 - 2020-12-27 + - fix tests when Class::Method::Modifiers is not installed + +2.002_000 - 2020-12-23 + - Refactored create_class_with_roles to not use "composable packages". This + was an optimization for when a role is used in many different uses of + create_class_with_roles, but required an entirely separate implementation, + which did not have fully compatible behavior. It would also result in + methods using modifiers being slower. + - Add documentation for what methods will be composed from a role + (RT#133363) + - Fix backwards compatibility with older versions of Moo when interacting + with Moose. + - Treat modifiers as required methods during create_class_with_roles. + - Fixed methods being no longer composed after they participated in an + allowed conflict. + - Dropped use of MRO::Compat. + - Test cleanups for checking requires during create_class_with_roles. + - Additional tests to confirm internal role application steps can be fully + qualified. + - Fix Pod links to Class::Method::Modifiers + - Tweaks to author tests + - Additional tests for working with older Moo versions + - Additional tests for module loading + - Allow method modifiers to be specified with an array reference of method + names, rather than a list. This now matches how the corresponding + Class::Method::Modifiers subs can be called. + +2.001004 - 2019-10-25 + - fix methods being excluded from composition if they previously existed in + the composing role (RT#130811) + - fix role application overwriting subs that are not considered methods + - fix helper subs created by a Role::Tiny extension (like Moo::Role) + sometimes being teated as methods + +2.001003 - 2019-10-09 + - releasing as stable + +2.001_002 - 2019-10-06 + - fix methods from roles composed via create_class_with_roles being treated + differently from roles composed directly (RT#128470) + - fix constants being included in the methods provided by a role if they + were created before importing Role::Tiny but used after importing + - fix prototype handling test on cperl + +2.001001 - 2019-10-01 + - added tests for make_role + +2.001_000 - 2019-09-19 + - refactored method tracking to allow easier extending (such as by Moo) + - added make_role method to make a package into a role, but without + exporting any subs into it + - refactored sub exporting to allow extensions to do different things with + the subs + +2.000_009 - 2019-09-06 + - fix composing roles into packages that have stub subs in them + - treat constants consistently with all other subs, no matter where they are + defined + +2.000008 - 2019-08-05 + - reverting all changes from 2.000007 due to failures on some perl versions + and a number of downstream users. The changes will be reintroduced in a + fixed form in a future version. + +2.000007 - 2019-07-31 + - fix composing roles into packages that have stub subs in them + - exclude all constant subs from method list + +2.000006 - 2017-11-08 + - account for code references stored directly in stash (for perl 5.28) + - work around hint leakage when loading modules in perl 5.8 and 5.10.1 + +2.000005 - 2016-11-01 + - revert change to MRO::Compat usage + +2.000004 - 2016-10-31 + - Fix consuming stubs from roles (RT#116674). + - Fix error message when applying conflicting roles to an object. + - Drop prerequisite on MRO::Compat on perl 5.8. + +2.000003 - 2016-04-21 + - don't install subs if importing into a package that is already a role. This + can happen if the module previously imported Moo::Role. + +2.000002 - 2016-04-19 + - restore compatibility with Moo versions pre 1.004_003 + - delay loading Class::Method::Modifiers until applying modifiers to a package + - use croak rather than die for reporting errors + - apply method modifiers only once, even if they are applied via multiple + composition paths (RT#106668) + +2.000001 - 2015-04-24 + - fix generating invalid package names with single colons when abbreviating + long package names (RT#103310) + - don't run module interaction tests for user installs + +2.000000 - 2015-02-26 + * Incompatible Changes + - Role::Tiny no longer applies fatal warnings to roles created with it. + strict and non-fatal warnings will continue to be applied. + +1.003004 - 2014-10-22 + - allow does_role to be overridden by Moo::Role + +1.003003 - 2014-03-15 + - overloads specified as method names rather than subrefs are now applied + properly + - allow superclass to provide conflicting methods (RT#91054) + - use ->is_role internally to check if a package is a role + - document that Role::Tiny applies strict and fatal warnings + +1.003002 - 2013-09-04 + - abbreviate generated package names if they are longer than perl can handle + (RT#83248) + - add explicit dependency on the version of Exporter that added 'import' + +1.003001 - 2013-07-14 + - fix test accidentally requiring Class::Method::Modifiers + +1.003000 - 2013-07-14 + - allow composing roles simultaneously that mutually require each other + (RT#82711) + - Fix _concrete_methods_of returning non-CODE entries + - fix broken implementation of method conflict resolution + (Perlmonks#1041015) + - add is_role method for checking if a given package is a role + - drop minimum perl version - code tests just fine on 5.6.1 and 5.6.2 + +1.002005 - 2013-02-01 + - complain loudly if Class::Method::Modifiers is too old (and skip tests) + - don't use $_ as loop variable when calling arbitrary code + +1.002004 - 2012-11-02 + - remove accidentally-introduced strictures.pm usage + +1.002003 - 2012-10-29 + - fix method modifier breakage on 5.10.0 + +1.002002 - 2012-10-28 + - skip t/around-does.t when Class::Method::Modifiers is not installed + (RT#80310) + +1.002001 - 2012-10-26 + - t/does-Moo.t moved to 'xt' (RT#80290) + - don't die when looking for 'DOES' on perl < 5.10 (RT#80402) + +1.002000 - 2012-10-19 + - load class in addition to roles when using create_class_from_roles + - fix module name in Makefile.PL (RT#78591) + - when classes consume roles, override their DOES method (RT#79747) + - method modifiers can be used for 'does' and 'DOES' + +1.001005 - 2012-07-18 + - localize UNIVERSAL::can change to avoid confusing TB2 + - properly report roles consumed by superclasses + +1.001004 - 2012-07-12 + - remove strictures.pm from the test supplied by mmcleric so we install again + - when applying runtime roles include roles from original class in new class + ( fixes ::does_role checks) + +1.001003 - 2012-06-19 + - correctly apply modifiers with role composition + - check for conflicts during role-to-object application (test from mmcleric) + - add an explicit return to all exported subs so people don't accidentally + rely on the return value + - store coderefs as well as their refaddrs to protect against crazy + +1.001002 - 2012-05-05 + - alter duplication test to not provoke Class::Method::Modifiers loading + +1.001001 - 2012-04-27 + - remove strictures from one last test file + +1.001000 - 2012-04-27 + - Documentation improvements, no code changes + +1.000_901 - 2012-04-12 + - Fix MANIFEST inclusion of Role::Basic composition + +1.000_900 - 2012-04-11 + - Add composition with tests stolen from Role::Basic + +1.000001 - 2012-04-03 + - Document that Class::Method::Modifiers must be depended on separately + - Update tests so that they skip correctly without C::M::M + - Add a SEE ALSO section + +1.000000 - 2012-03-29 + - Remove redundant code in create_class_with_roles + - Minor doc fix to does_role + - Split Role::Tiny out into its own dist + +Changes below this line are from when Role::Tiny was still bundled with Moo: + + - Fix a bug where coercions weren't called on lazy default/builder returns + - Switch Moo::Utils to using Module::Runtime, and add the 5.8 %INC + leakage fix into Role::Tiny's _load_module to provide partial parity + - Update incompatibilities with Moose documentation + - Remove Sub::Quote's outstanding queue since it doesn't actually slow + things down to do it this way and makes debugging easier. + - Revert 'local $@' around require calls to avoid triggering Unknown Error + - Explicitly require Role::Tiny in Role::Tiny::With (RT#70446) + - Fix spurious 'once' warnings under perl -w + +0.009013 - 2011-12-23 + - fix up Class::XSAccessor version check to be more robust + - improved documentation + - fix failures on perls < 5.8.3 + - fix test failures on cygwin + +0.009012 - 2011-11-15 + - make Method::Generate::Constructor handle $obj->new + - fix bug where constants containing a reference weren't handled correctly + (ref(\[]) is 'REF' not 'SCALAR', ref(\v1) is 'VSTRING') + +0.009011 - 2011-10-03 + - add support for DEMOLISH + - add support for BUILDARGS + +0.009010 - 2011-07-20 + - missing new files for Role::Tiny::With + +0.009009 - 2011-07-20 + - remove the big scary warning because we seem to be mostly working now + - perl based getter dies if @_ > 1 (XSAccessor already did) + - add Role::Tiny::With for use in classes + - automatically generate constructors in subclasses when required so that + subclasses with a BUILD method but no attributes get it honoured + - add coerce handling + +0.009008 - 2011-06-03 + - transfer fix to _load_module to Role::Tiny and make a note it's an inline + - Bring back 5.8.1 compat + +0.009007 - 2011-02-25 + - I botched the copyright. re-disting. + +0.009006 - 2011-02-25 + - handle non-lazy default and builder when init_arg is undef + - add copyright and license info for downstream packagers + - weak ref checking for Sub::Quote to avoid bugs on refaddr reuse + - Switch composed role names to be a valid package name + +0.9.5 Tue Jan 11 2011 + - Fix clobberage of runtime-installed wrappers by Sub::Defer + - Fix nonMoo constructor firing through multiple layers of Moo + - Fix bug where nonMoo is mistakenly detected given a Moo superclass + with no attributes (and hence no own constructor) + +0.9.4 Mon Dec 13 2010 + - Automatic detection on non-Moo superclasses + +0.9.3 Sun Dec 5 2010 + - Fix _load_module to deal with pre-existing subpackages + +0.9.2 Wed Nov 17 2010 + - Add explanation of Moo's existence + - Change @ISA setting mechanism to deal with a big in 5.10.0's get_linear_isa + - Change 5.10 checks to >= to not try and load MRO::Compat on 5.10.0 + - Make 'perl -Moo' DTRT + +0.9.1 Tue Nov 16 2010 + - Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..afa5e57 --- /dev/null +++ b/LICENSE @@ -0,0 +1,374 @@ +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) 2021 by mst - Matt S. Trout (cpan:MSTROUT) . + +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) 2021 by mst - Matt S. Trout (cpan:MSTROUT) . + +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 + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..1af42df --- /dev/null +++ b/MANIFEST @@ -0,0 +1,44 @@ +Changes +lib/Role/Tiny.pm +lib/Role/Tiny/With.pm +maint/Makefile.PL.include +Makefile.PL +MANIFEST This list of files +t/concrete-methods.t +t/create-hook.t +t/does.t +t/extend-role-tiny.t +t/extend.t +t/lib/BrokenModule.pm +t/lib/ExistingModule.pm +t/lib/FalseModule.pm +t/lib/TrueModule.pm +t/load-module.t +t/make-role.t +t/method-conflicts.t +t/namespace-clean.t +t/overload.t +t/proto.t +t/role-basic-basic.t +t/role-basic-bugs.t +t/role-basic-composition.t +t/role-basic-exceptions.t +t/role-duplication.t +t/role-long-package-name.t +t/role-tiny-composition.t +t/role-tiny-with.t +t/role-tiny.t +t/role-with-inheritance.t +t/stub.t +t/subclass.t +xt/around-does.t +xt/compose-modifiers.t +xt/dependents.t +xt/dependents/Moo-isa-assign.patch +xt/dependents/Moo-sort-sub-quote.patch +xt/modifiers.t +xt/recompose-modifier.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) diff --git a/META.json b/META.json new file mode 100644 index 0000000..820ac08 --- /dev/null +++ b/META.json @@ -0,0 +1,64 @@ +{ + "abstract" : "Roles: a nouvelle cuisine portion size slice of Moose", + "author" : [ + "mst - Matt S. Trout (cpan:MSTROUT) " + ], + "dynamic_config" : 0, + "generated_by" : "ExtUtils::MakeMaker version 7.58, CPAN::Meta::Converter version 2.150010", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : 2 + }, + "name" : "Role-Tiny", + "no_index" : { + "directory" : [ + "t", + "xt" + ] + }, + "prereqs" : { + "build" : {}, + "configure" : {}, + "develop" : { + "requires" : { + "Class::Method::Modifiers" : "1.05" + } + }, + "runtime" : { + "recommends" : { + "Class::Method::Modifiers" : "1.05" + }, + "requires" : { + "Exporter" : "5.57", + "perl" : "5.006" + } + }, + "test" : { + "requires" : { + "Test::More" : "0.88" + } + } + }, + "release_status" : "stable", + "resources" : { + "bugtracker" : { + "mailto" : "bug-Role-Tiny@rt.cpan.org", + "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=Role-Tiny" + }, + "license" : [ + "http://dev.perl.org/licenses/" + ], + "repository" : { + "type" : "git", + "url" : "git://github.com/moose/Role-Tiny.git", + "web" : "https://github.com/moose/Role-Tiny" + }, + "x_IRC" : "irc://irc.perl.org/#moose" + }, + "version" : "2.002004", + "x_serialization_backend" : "JSON::PP version 4.04", + "x_static_install" : 1 +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..7fde869 --- /dev/null +++ b/META.yml @@ -0,0 +1,30 @@ +--- +abstract: 'Roles: a nouvelle cuisine portion size slice of Moose' +author: + - 'mst - Matt S. Trout (cpan:MSTROUT) ' +build_requires: + Test::More: '0.88' +dynamic_config: 0 +generated_by: 'ExtUtils::MakeMaker version 7.58, 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: Role-Tiny +no_index: + directory: + - t + - xt +recommends: + Class::Method::Modifiers: '1.05' +requires: + Exporter: '5.57' + perl: '5.006' +resources: + IRC: irc://irc.perl.org/#moose + bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=Role-Tiny + license: http://dev.perl.org/licenses/ + repository: git://github.com/moose/Role-Tiny.git +version: '2.002004' +x_serialization_backend: 'CPAN::Meta::YAML version 0.018' +x_static_install: 1 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..26c5f5b --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,109 @@ +use strict; +use warnings; +use 5.006; + +my %META = ( + name => 'Role-Tiny', + prereqs => { + test => { requires => { + 'Test::More' => '0.88', + } }, + runtime => { + requires => { + 'perl' => '5.006', + 'Exporter' => '5.57', + }, + recommends => { + 'Class::Method::Modifiers' => '1.05', + }, + }, + develop => { + requires => { + 'Class::Method::Modifiers' => '1.05', + }, + }, + }, + resources => { + repository => { + url => 'git://github.com/moose/Role-Tiny.git', + web => 'https://github.com/moose/Role-Tiny', + type => 'git', + }, + bugtracker => { + mailto => 'bug-Role-Tiny@rt.cpan.org', + web => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Role-Tiny', + }, + x_IRC => 'irc://irc.perl.org/#moose', + license => [ 'http://dev.perl.org/licenses/' ], + }, + no_index => { + directory => [ 't', 'xt' ] + }, + dynamic_config => 0, + x_static_install => 1, +); + +my $xt = $ENV{EXTENDED_TESTING} && do { + my %x_prereqs = ( + %{ $META{prereqs}{develop}{requires} }, + ); + local $@; + !grep !eval { + my $module = $_; + my $v = $x_prereqs{$module}; + (my $file = "$module.pm") =~ s{::}{/}g; + require $file; + $module->VERSION($v) + if $v; + 1; + }, sort keys %x_prereqs; +}; + +my %MM_ARGS = ( + ($xt ? ( + test => { TESTS => 't/*.t xt/*.t' }, + ):()), +); + +## BOILERPLATE ############################################################### +require ExtUtils::MakeMaker; +(do './maint/Makefile.PL.include' or die $@) unless -f 'META.yml'; + +# have to do this since old EUMM dev releases miss the eval $VERSION line +my $eumm_version = eval $ExtUtils::MakeMaker::VERSION; +my $mymeta = $eumm_version >= 6.57_02; +my $mymeta_broken = $mymeta && $eumm_version < 6.57_07; + +($MM_ARGS{NAME} = $META{name}) =~ s/-/::/g; +($MM_ARGS{VERSION_FROM} = "lib/$MM_ARGS{NAME}.pm") =~ s{::}{/}g; +$META{license} = [ $META{license} ] + if $META{license} && !ref $META{license}; +$MM_ARGS{LICENSE} = $META{license}[0] + if $META{license} && $eumm_version >= 6.30; +$MM_ARGS{NO_MYMETA} = 1 + if $mymeta_broken; +$MM_ARGS{META_ADD} = { 'meta-spec' => { version => 2 }, %META } + unless -f 'META.yml'; + +for (qw(configure build test runtime)) { + my $key = $_ eq 'runtime' ? 'PREREQ_PM' : uc $_.'_REQUIRES'; + my $r = $MM_ARGS{$key} = { + %{$META{prereqs}{$_}{requires} || {}}, + %{delete $MM_ARGS{$key} || {}}, + }; + defined $r->{$_} or delete $r->{$_} for keys %$r; +} + +$MM_ARGS{MIN_PERL_VERSION} = delete $MM_ARGS{PREREQ_PM}{perl} || 0; + +delete $MM_ARGS{MIN_PERL_VERSION} + if $eumm_version < 6.47_01; +$MM_ARGS{BUILD_REQUIRES} = {%{$MM_ARGS{BUILD_REQUIRES}}, %{delete $MM_ARGS{TEST_REQUIRES}}} + if $eumm_version < 6.63_03; +$MM_ARGS{PREREQ_PM} = {%{$MM_ARGS{PREREQ_PM}}, %{delete $MM_ARGS{BUILD_REQUIRES}}} + if $eumm_version < 6.55_01; +delete $MM_ARGS{CONFIGURE_REQUIRES} + if $eumm_version < 6.51_03; + +ExtUtils::MakeMaker::WriteMakefile(%MM_ARGS); +## END BOILERPLATE ########################################################### diff --git a/README b/README new file mode 100644 index 0000000..c3f3f5c --- /dev/null +++ b/README @@ -0,0 +1,235 @@ +NAME + Role::Tiny - Roles: a nouvelle cuisine portion size slice of Moose + +SYNOPSIS + package Some::Role; + + use Role::Tiny; + + sub foo { ... } + + sub bar { ... } + + around baz => sub { ... }; + + 1; + + elsewhere + + package Some::Class; + + use Role::Tiny::With; + + # bar gets imported, but not foo + with 'Some::Role'; + + sub foo { ... } + + # baz is wrapped in the around modifier by Class::Method::Modifiers + sub baz { ... } + + 1; + + If you wanted attributes as well, look at Moo::Role. + +DESCRIPTION + "Role::Tiny" is a minimalist role composition tool. + +ROLE COMPOSITION + Role composition can be thought of as much more clever and meaningful + multiple inheritance. The basics of this implementation of roles is: + + * If a method is already defined on a class, that method will not be + composed in from the role. A method inherited by a class gets + overridden by the role's method of the same name, though. + + * If a method that the role "requires" to be implemented is not + implemented, role application will fail loudly. + + Unlike Class::C3, where the last class inherited from "wins," role + composition is the other way around, where the class wins. If multiple + roles are applied in a single call (single with statement), then if any + of their provided methods clash, an exception is raised unless the class + provides a method since this conflict indicates a potential problem. + + ROLE METHODS + All subs created after importing Role::Tiny will be considered methods + to be composed. For example: + + package MyRole; + use List::Util qw(min); + sub mysub { } + use Role::Tiny; + use List::Util qw(max); + sub mymethod { } + + In this role, "max" and "mymethod" will be included when composing + MyRole, and "min" and "mysub" will not. For additional control, + namespace::clean can be used to exclude undesired subs from roles. + +IMPORTED SUBROUTINES + requires + requires qw(foo bar); + + Declares a list of methods that must be defined to compose role. + + with + with 'Some::Role1'; + + with 'Some::Role1', 'Some::Role2'; + + Composes another role into the current role (or class via + Role::Tiny::With). + + If you have conflicts and want to resolve them in favour of Some::Role1 + you can instead write: + + with 'Some::Role1'; + with 'Some::Role2'; + + If you have conflicts and want to resolve different conflicts in favour + of different roles, please refactor your codebase. + + before + before foo => sub { ... }; + + See "before method(s) => sub { ... };" in Class::Method::Modifiers for + full documentation. + + Note that since you are not required to use method modifiers, + Class::Method::Modifiers is lazily loaded and we do not declare it as a + dependency. If your Role::Tiny role uses modifiers you must depend on + both Class::Method::Modifiers and Role::Tiny. + + around + around foo => sub { ... }; + + See "around method(s) => sub { ... };" in Class::Method::Modifiers for + full documentation. + + Note that since you are not required to use method modifiers, + Class::Method::Modifiers is lazily loaded and we do not declare it as a + dependency. If your Role::Tiny role uses modifiers you must depend on + both Class::Method::Modifiers and Role::Tiny. + + after + after foo => sub { ... }; + + See "after method(s) => sub { ... };" in Class::Method::Modifiers for + full documentation. + + Note that since you are not required to use method modifiers, + Class::Method::Modifiers is lazily loaded and we do not declare it as a + dependency. If your Role::Tiny role uses modifiers you must depend on + both Class::Method::Modifiers and Role::Tiny. + + Strict and Warnings + In addition to importing subroutines, using "Role::Tiny" applies strict + and warnings to the caller. + +SUBROUTINES + does_role + if (Role::Tiny::does_role($foo, 'Some::Role')) { + ... + } + + Returns true if class has been composed with role. + + This subroutine is also installed as ->does on any class a Role::Tiny is + composed into unless that class already has an ->does method, so + + if ($foo->does('Some::Role')) { + ... + } + + will work for classes but to test a role, one must use ::does_role + directly. + + Additionally, Role::Tiny will override the standard Perl "DOES" method + for your class. However, if "any" class in your class' inheritance + hierarchy provides "DOES", then Role::Tiny will not override it. + +METHODS + make_role + Role::Tiny->make_role('Some::Role'); + + Makes a package into a role, but does not export any subs into it. + + apply_roles_to_package + Role::Tiny->apply_roles_to_package( + 'Some::Package', 'Some::Role', 'Some::Other::Role' + ); + + Composes role with package. See also Role::Tiny::With. + + apply_roles_to_object + Role::Tiny->apply_roles_to_object($foo, qw(Some::Role1 Some::Role2)); + + Composes roles in order into object directly. Object is reblessed into + the resulting class. Note that the object's methods get overridden by + the role's ones with the same names. + + create_class_with_roles + Role::Tiny->create_class_with_roles('Some::Base', qw(Some::Role1 Some::Role2)); + + Creates a new class based on base, with the roles composed into it in + order. New class is returned. + + is_role + Role::Tiny->is_role('Some::Role1') + + Returns true if the given package is a role. + +CAVEATS + * On perl 5.8.8 and earlier, applying a role to an object won't apply + any overloads from the role to other copies of the object. + + * On perl 5.16 and earlier, applying a role to a class won't apply any + overloads from the role to any existing instances of the class. + +SEE ALSO + Role::Tiny is the attribute-less subset of Moo::Role; Moo::Role is a + meta-protocol-less subset of the king of role systems, Moose::Role. + + Ovid's Role::Basic provides roles with a similar scope, but without + method modifiers, and having some extra usage restrictions. + +AUTHOR + mst - Matt S. Trout (cpan:MSTROUT) + +CONTRIBUTORS + dg - David Leadbeater (cpan:DGL) + + frew - Arthur Axel "fREW" Schmidt (cpan:FREW) + + hobbs - Andrew Rodland (cpan:ARODLAND) + + jnap - John Napiorkowski (cpan:JJNAPIORK) + + ribasushi - Peter Rabbitson (cpan:RIBASUSHI) + + chip - Chip Salzenberg (cpan:CHIPS) + + ajgb - Alex J. G. Burzyński (cpan:AJGB) + + doy - Jesse Luehrs (cpan:DOY) + + perigrin - Chris Prather (cpan:PERIGRIN) + + Mithaldu - Christian Walde (cpan:MITHALDU) + + + ilmari - Dagfinn Ilmari MannsÃ¥ker (cpan:ILMARI) + + tobyink - Toby Inkster (cpan:TOBYINK) + + haarg - Graham Knop (cpan:HAARG) + +COPYRIGHT + Copyright (c) 2010-2012 the Role::Tiny "AUTHOR" and "CONTRIBUTORS" as + listed above. + +LICENSE + This library is free software and may be distributed under the same + terms as perl itself. + diff --git a/lib/Role/Tiny.pm b/lib/Role/Tiny.pm new file mode 100644 index 0000000..ae59004 --- /dev/null +++ b/lib/Role/Tiny.pm @@ -0,0 +1,823 @@ +package Role::Tiny; +use strict; +use warnings; + +our $VERSION = '2.002004'; +$VERSION =~ tr/_//d; + +our %INFO; +our %APPLIED_TO; +our %COMPOSED; +our %COMPOSITE_INFO; +our @ON_ROLE_CREATE; + +# Module state workaround totally stolen from Zefram's Module::Runtime. + +BEGIN { + *_WORK_AROUND_BROKEN_MODULE_STATE = "$]" < 5.009 ? sub(){1} : sub(){0}; + *_WORK_AROUND_HINT_LEAKAGE + = "$]" < 5.011 && !("$]" >= 5.009004 && "$]" < 5.010001) + ? sub(){1} : sub(){0}; + *_CONSTANTS_DEFLATE = "$]" >= 5.012 && "$]" < 5.020 ? sub(){1} : sub(){0}; +} + +sub _getglob { no strict 'refs'; \*{$_[0]} } +sub _getstash { no strict 'refs'; \%{"$_[0]::"} } + +sub croak { + require Carp; + no warnings 'redefine'; + *croak = \&Carp::croak; + goto &Carp::croak; +} + +sub Role::Tiny::__GUARD__::DESTROY { + delete $INC{$_[0]->[0]} if @{$_[0]}; +} + +sub _load_module { + my ($module) = @_; + (my $file = "$module.pm") =~ s{::}{/}g; + return 1 + if $INC{$file}; + + # can't just ->can('can') because a sub-package Foo::Bar::Baz + # creates a 'Baz::' key in Foo::Bar's symbol table + return 1 + if grep !/::\z/, keys %{_getstash($module)}; + my $guard = _WORK_AROUND_BROKEN_MODULE_STATE + && bless([ $file ], 'Role::Tiny::__GUARD__'); + local %^H if _WORK_AROUND_HINT_LEAKAGE; + require $file; + pop @$guard if _WORK_AROUND_BROKEN_MODULE_STATE; + return 1; +} + +sub _require_module { + _load_module($_[1]); +} + +sub _all_subs { + my ($me, $package) = @_; + my $stash = _getstash($package); + return { + map {; + no strict 'refs'; + # this is an ugly hack to populate the scalar slot of any globs, to + # prevent perl from converting constants back into scalar refs in the + # stash when they are used (perl 5.12 - 5.18). scalar slots on their own + # aren't detectable through pure perl, so this seems like an acceptable + # compromise. + ${"${package}::${_}"} = ${"${package}::${_}"} + if _CONSTANTS_DEFLATE; + $_ => \&{"${package}::${_}"} + } + grep exists &{"${package}::${_}"}, + grep !/::\z/, + keys %$stash + }; +} + +sub import { + my $target = caller; + my $me = shift; + strict->import; + warnings->import; + my $non_methods = $me->_non_methods($target); + $me->_install_subs($target, @_); + $me->make_role($target); + $me->_mark_new_non_methods($target, $non_methods) + if $non_methods && %$non_methods; + return; +} + +sub _mark_new_non_methods { + my ($me, $target, $old_non_methods) = @_; + + my $non_methods = $INFO{$target}{non_methods}; + + my $subs = $me->_all_subs($target); + for my $sub (keys %$subs) { + if ( exists $old_non_methods->{$sub} && $non_methods->{$sub} != $subs->{$sub} ) { + $non_methods->{$sub} = $subs->{$sub}; + } + } + + return; +} + +sub make_role { + my ($me, $target) = @_; + + return if $me->is_role($target); + $INFO{$target}{is_role} = 1; + + my $non_methods = $me->_all_subs($target); + delete @{$non_methods}{grep /\A\(/, keys %$non_methods}; + $INFO{$target}{non_methods} = $non_methods; + + # a role does itself + $APPLIED_TO{$target} = { $target => undef }; + foreach my $hook (@ON_ROLE_CREATE) { + $hook->($target); + } +} + +sub _install_subs { + my ($me, $target) = @_; + return if $me->is_role($target); + my %install = $me->_gen_subs($target); + *{_getglob("${target}::${_}")} = $install{$_} + for sort keys %install; + return; +} + +sub _gen_subs { + my ($me, $target) = @_; + ( + (map {; + my $type = $_; + $type => sub { + my $code = pop; + my @names = ref $_[0] eq 'ARRAY' ? @{ $_[0] } : @_; + push @{$INFO{$target}{modifiers}||=[]}, [ $type, @names, $code ]; + return; + }; + } qw(before after around)), + requires => sub { + push @{$INFO{$target}{requires}||=[]}, @_; + return; + }, + with => sub { + $me->apply_roles_to_package($target, @_); + return; + }, + ); +} + +sub role_application_steps { + qw( + _install_methods + _check_requires + _install_modifiers + _copy_applied_list + ); +} + +sub _copy_applied_list { + my ($me, $to, $role) = @_; + # copy our role list into the target's + @{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = (); +} + +sub apply_roles_to_object { + my ($me, $object, @roles) = @_; + my $class = ref($object); + # on perl < 5.8.9, magic isn't copied to all ref copies. bless the parameter + # directly, so at least the variable passed to us will get any magic applied + bless($_[1], $me->create_class_with_roles($class, @roles)); +} + +my $role_suffix = 'A000'; +sub _composite_name { + my ($me, $superclass, @roles) = @_; + + my $new_name = $superclass . '__WITH__' . join '__AND__', @roles; + + if (length($new_name) > 252) { + $new_name = $COMPOSED{abbrev}{$new_name} ||= do { + my $abbrev = substr $new_name, 0, 250 - length $role_suffix; + $abbrev =~ s/(?_require_module($superclass); + $me->_check_roles(@roles); + + my $new_name = $me->_composite_name($superclass, @roles); + + return $new_name + if $COMPOSED{class}{$new_name}; + + return $me->_build_class_with_roles($new_name, $superclass, @roles); +} + +sub _build_class_with_roles { + my ($me, $new_name, $superclass, @roles) = @_; + + $COMPOSED{base}{$new_name} = $superclass; + @{*{_getglob("${new_name}::ISA")}} = ( $superclass ); + $me->apply_roles_to_package($new_name, @roles); + $COMPOSED{class}{$new_name} = 1; + return $new_name; +} + +sub _check_roles { + my ($me, @roles) = @_; + croak "No roles supplied!" unless @roles; + + my %seen; + if (my @dupes = grep 1 == $seen{$_}++, @roles) { + croak "Duplicated roles: ".join(', ', @dupes); + } + + foreach my $role (@roles) { + $me->_require_module($role); + croak "${role} is not a ${me}" unless $me->is_role($role); + } +} + +our %BACKCOMPAT_HACK; +$BACKCOMPAT_HACK{+__PACKAGE__} = 0; +sub _want_backcompat_hack { + my $me = shift; + return $BACKCOMPAT_HACK{$me} + if exists $BACKCOMPAT_HACK{$me}; + no warnings 'uninitialized'; + $BACKCOMPAT_HACK{$me} = + $me->can('apply_single_role_to_package') != \&apply_single_role_to_package + && $me->can('role_application_steps') == \&role_application_steps +} + +our $IN_APPLY_ROLES; +sub apply_single_role_to_package { + return + if $IN_APPLY_ROLES; + local $IN_APPLY_ROLES = 1; + + my ($me, $to, $role) = @_; + $me->apply_roles_to_package($to, $role); +} + +sub apply_role_to_package { + my ($me, $to, $role) = @_; + $me->apply_roles_to_package($to, $role); +} + +sub apply_roles_to_package { + my ($me, $to, @roles) = @_; + croak "Can't apply roles to object with apply_roles_to_package" + if ref $to; + + $me->_check_roles(@roles); + + my @have_conflicts; + my %role_methods; + + if (@roles > 1) { + my %conflicts = %{$me->_composite_info_for(@roles)->{conflicts}}; + @have_conflicts = grep $to->can($_), keys %conflicts; + delete @conflicts{@have_conflicts}; + + if (keys %conflicts) { + my $class = $COMPOSED{base}{$to} || $to; + my $fail = + join "\n", + map { + "Due to a method name conflict between roles " + .join(' and ', map "'$_'", sort values %{$conflicts{$_}}) + .", the method '$_' must be implemented by '$class'" + } sort keys %conflicts; + croak $fail; + } + + %role_methods = map +($_ => $me->_concrete_methods_of($_)), @roles; + } + + if (!$IN_APPLY_ROLES and _want_backcompat_hack($me)) { + local $IN_APPLY_ROLES = 1; + foreach my $role (@roles) { + $me->apply_single_role_to_package($to, $role); + } + } + + my $role_methods; + foreach my $step ($me->role_application_steps) { + foreach my $role (@roles) { + # conflicting methods are supposed to be treated as required by the + # composed role. we don't have an actual composed role, but because + # we know the target class already provides them, we can instead + # pretend that the roles don't do for the duration of application. + $role_methods = $role_methods{$role} and ( + (local @{$role_methods}{@have_conflicts}), + (delete @{$role_methods}{@have_conflicts}), + ); + + $me->$step($to, $role); + } + } + $APPLIED_TO{$to}{join('|',@roles)} = 1; +} + +sub _composite_info_for { + my ($me, @roles) = @_; + $COMPOSITE_INFO{join('|', sort @roles)} ||= do { + my %methods; + foreach my $role (@roles) { + my $this_methods = $me->_concrete_methods_of($role); + $methods{$_}{$this_methods->{$_}} = $role for keys %$this_methods; + } + delete $methods{$_} for grep keys(%{$methods{$_}}) == 1, keys %methods; + +{ conflicts => \%methods } + }; +} + +sub _check_requires { + my ($me, $to, $name, $requires) = @_; + $requires ||= $INFO{$name}{requires} || []; + if (my @requires_fail = grep !$to->can($_), @$requires) { + # role -> role, add to requires, role -> class, error out + if (my $to_info = $INFO{$to}) { + push @{$to_info->{requires}||=[]}, @requires_fail; + } else { + croak "Can't apply ${name} to ${to} - missing ".join(', ', @requires_fail); + } + } +} + +sub _non_methods { + my ($me, $role) = @_; + my $info = $INFO{$role} or return {}; + + my %non_methods = %{ $info->{non_methods} || {} }; + + # this is only for backwards compatibility with older Moo, which + # reimplements method tracking rather than calling our method + my %not_methods = reverse %{ $info->{not_methods} || {} }; + return \%non_methods unless keys %not_methods; + + my $subs = $me->_all_subs($role); + for my $sub (grep !/\A\(/, keys %$subs) { + my $code = $subs->{$sub}; + if (exists $not_methods{$code}) { + $non_methods{$sub} = $code; + } + } + + return \%non_methods; +} + +sub _concrete_methods_of { + my ($me, $role) = @_; + my $info = $INFO{$role}; + + return $info->{methods} + if $info && $info->{methods}; + + my $non_methods = $me->_non_methods($role); + + my $subs = $me->_all_subs($role); + for my $sub (keys %$subs) { + if ( exists $non_methods->{$sub} && $non_methods->{$sub} == $subs->{$sub} ) { + delete $subs->{$sub}; + } + } + + if ($info) { + $info->{methods} = $subs; + } + return $subs; +} + +sub methods_provided_by { + my ($me, $role) = @_; + $me->_require_module($role); + croak "${role} is not a ${me}" unless $me->is_role($role); + sort (keys %{$me->_concrete_methods_of($role)}, @{$INFO{$role}->{requires}||[]}); +} + +sub _install_methods { + my ($me, $to, $role) = @_; + + my $methods = $me->_concrete_methods_of($role); + + my %existing_methods; + @existing_methods{keys %{ $me->_all_subs($to) }} = (); + + # _concrete_methods_of caches its result on roles. that cache needs to be + # invalidated after applying roles + delete $INFO{$to}{methods} if $INFO{$to}; + + foreach my $i (keys %$methods) { + next + if exists $existing_methods{$i}; + + my $glob = _getglob "${to}::${i}"; + *$glob = $methods->{$i}; + + # overloads using method names have the method stored in the scalar slot + # and &overload::nil in the code slot. + next + unless $i =~ /^\(/ + && ((defined &overload::nil && $methods->{$i} == \&overload::nil) + || (defined &overload::_nil && $methods->{$i} == \&overload::_nil)); + + my $overload = ${ _getglob "${role}::${i}" }; + next + unless defined $overload; + + *$glob = \$overload; + } + + $me->_install_does($to); +} + +sub _install_modifiers { + my ($me, $to, $name) = @_; + return unless my $modifiers = $INFO{$name}{modifiers}; + my $info = $INFO{$to}; + my $existing = ($info ? $info->{modifiers} : $COMPOSED{modifiers}{$to}) ||= []; + my @modifiers = grep { + my $modifier = $_; + !grep $_ == $modifier, @$existing; + } @{$modifiers||[]}; + push @$existing, @modifiers; + + if (!$info) { + foreach my $modifier (@modifiers) { + $me->_install_single_modifier($to, @$modifier); + } + } +} + +my $vcheck_error; + +sub _install_single_modifier { + my ($me, @args) = @_; + defined($vcheck_error) or $vcheck_error = do { + local $@; + eval { + require Class::Method::Modifiers; + Class::Method::Modifiers->VERSION(1.05); + 1; + } ? 0 : $@; + }; + $vcheck_error and die $vcheck_error; + Class::Method::Modifiers::install_modifier(@args); +} + +my $FALLBACK = sub { 0 }; +sub _install_does { + my ($me, $to) = @_; + + # only add does() method to classes + return if $me->is_role($to); + + my $does = $me->can('does_role'); + # add does() only if they don't have one + *{_getglob "${to}::does"} = $does unless $to->can('does'); + + return + if $to->can('DOES') and $to->can('DOES') != (UNIVERSAL->can('DOES') || 0); + + my $existing = $to->can('DOES') || $to->can('isa') || $FALLBACK; + my $new_sub = sub { + my ($proto, $role) = @_; + $proto->$does($role) or $proto->$existing($role); + }; + no warnings 'redefine'; + return *{_getglob "${to}::DOES"} = $new_sub; +} + +# optimize for newer perls +require mro + if "$]" >= 5.009_005; + +if (defined &mro::get_linear_isa) { + *_linear_isa = \&mro::get_linear_isa; +} +else { + my $e; + { + local $@; +# this routine is simplified and not fully compatible with mro::get_linear_isa +# but for our use the order doesn't matter, so we don't need to care + eval <<'END_CODE' or $e = $@; +sub _linear_isa($;$) { + if (defined &mro::get_linear_isa) { + no warnings 'redefine', 'prototype'; + *_linear_isa = \&mro::get_linear_isa; + goto &mro::get_linear_isa; + } + + my @check = shift; + my @lin; + + my %found; + while (defined(my $check = shift @check)) { + push @lin, $check; + no strict 'refs'; + unshift @check, grep !$found{$_}++, @{"$check\::ISA"}; + } + + return \@lin; +} + +1; +END_CODE + } + die $e if defined $e; +} + +sub does_role { + my ($proto, $role) = @_; + foreach my $class (@{_linear_isa(ref($proto)||$proto)}) { + return 1 if exists $APPLIED_TO{$class}{$role}; + } + return 0; +} + +sub is_role { + my ($me, $role) = @_; + return !!($INFO{$role} && ( + $INFO{$role}{is_role} + # these are for backward compatibility with older Moo that overrode some + # methods without calling the originals, thus not getting is_role set + || $INFO{$role}{requires} + || $INFO{$role}{not_methods} + || $INFO{$role}{non_methods} + )); +} + +1; +__END__ + +=encoding utf-8 + +=head1 NAME + +Role::Tiny - Roles: a nouvelle cuisine portion size slice of Moose + +=head1 SYNOPSIS + + package Some::Role; + + use Role::Tiny; + + sub foo { ... } + + sub bar { ... } + + around baz => sub { ... }; + + 1; + +elsewhere + + package Some::Class; + + use Role::Tiny::With; + + # bar gets imported, but not foo + with 'Some::Role'; + + sub foo { ... } + + # baz is wrapped in the around modifier by Class::Method::Modifiers + sub baz { ... } + + 1; + +If you wanted attributes as well, look at L. + +=head1 DESCRIPTION + +C is a minimalist role composition tool. + +=head1 ROLE COMPOSITION + +Role composition can be thought of as much more clever and meaningful multiple +inheritance. The basics of this implementation of roles is: + +=over 2 + +=item * + +If a method is already defined on a class, that method will not be composed in +from the role. A method inherited by a class gets overridden by the role's +method of the same name, though. + +=item * + +If a method that the role L to be implemented is not implemented, +role application will fail loudly. + +=back + +Unlike L, where the B class inherited from "wins," role +composition is the other way around, where the class wins. If multiple roles +are applied in a single call (single with statement), then if any of their +provided methods clash, an exception is raised unless the class provides +a method since this conflict indicates a potential problem. + +=head2 ROLE METHODS + +All subs created after importing Role::Tiny will be considered methods to be +composed. For example: + + package MyRole; + use List::Util qw(min); + sub mysub { } + use Role::Tiny; + use List::Util qw(max); + sub mymethod { } + +In this role, C and C will be included when composing MyRole, +and C and C will not. For additional control, L +can be used to exclude undesired subs from roles. + +=head1 IMPORTED SUBROUTINES + +=head2 requires + + requires qw(foo bar); + +Declares a list of methods that must be defined to compose role. + +=head2 with + + with 'Some::Role1'; + + with 'Some::Role1', 'Some::Role2'; + +Composes another role into the current role (or class via L). + +If you have conflicts and want to resolve them in favour of Some::Role1 you +can instead write: + + with 'Some::Role1'; + with 'Some::Role2'; + +If you have conflicts and want to resolve different conflicts in favour of +different roles, please refactor your codebase. + +=head2 before + + before foo => sub { ... }; + +See L<< Class::Method::Modifiers/before method(s) => sub { ... }; >> for full +documentation. + +Note that since you are not required to use method modifiers, +L is lazily loaded and we do not declare it as +a dependency. If your L role uses modifiers you must depend on +both L and L. + +=head2 around + + around foo => sub { ... }; + +See L<< Class::Method::Modifiers/around method(s) => sub { ... }; >> for full +documentation. + +Note that since you are not required to use method modifiers, +L is lazily loaded and we do not declare it as +a dependency. If your L role uses modifiers you must depend on +both L and L. + +=head2 after + + after foo => sub { ... }; + +See L<< Class::Method::Modifiers/after method(s) => sub { ... }; >> for full +documentation. + +Note that since you are not required to use method modifiers, +L is lazily loaded and we do not declare it as +a dependency. If your L role uses modifiers you must depend on +both L and L. + +=head2 Strict and Warnings + +In addition to importing subroutines, using C applies L and +L to the caller. + +=head1 SUBROUTINES + +=head2 does_role + + if (Role::Tiny::does_role($foo, 'Some::Role')) { + ... + } + +Returns true if class has been composed with role. + +This subroutine is also installed as ->does on any class a Role::Tiny is +composed into unless that class already has an ->does method, so + + if ($foo->does('Some::Role')) { + ... + } + +will work for classes but to test a role, one must use ::does_role directly. + +Additionally, Role::Tiny will override the standard Perl C method +for your class. However, if C class in your class' inheritance +hierarchy provides C, then Role::Tiny will not override it. + +=head1 METHODS + +=head2 make_role + + Role::Tiny->make_role('Some::Role'); + +Makes a package into a role, but does not export any subs into it. + +=head2 apply_roles_to_package + + Role::Tiny->apply_roles_to_package( + 'Some::Package', 'Some::Role', 'Some::Other::Role' + ); + +Composes role with package. See also L. + +=head2 apply_roles_to_object + + Role::Tiny->apply_roles_to_object($foo, qw(Some::Role1 Some::Role2)); + +Composes roles in order into object directly. Object is reblessed into the +resulting class. Note that the object's methods get overridden by the role's +ones with the same names. + +=head2 create_class_with_roles + + Role::Tiny->create_class_with_roles('Some::Base', qw(Some::Role1 Some::Role2)); + +Creates a new class based on base, with the roles composed into it in order. +New class is returned. + +=head2 is_role + + Role::Tiny->is_role('Some::Role1') + +Returns true if the given package is a role. + +=head1 CAVEATS + +=over 4 + +=item * On perl 5.8.8 and earlier, applying a role to an object won't apply any +overloads from the role to other copies of the object. + +=item * On perl 5.16 and earlier, applying a role to a class won't apply any +overloads from the role to any existing instances of the class. + +=back + +=head1 SEE ALSO + +L is the attribute-less subset of L; L is +a meta-protocol-less subset of the king of role systems, L. + +Ovid's L provides roles with a similar scope, but without method +modifiers, and having some extra usage restrictions. + +=head1 AUTHOR + +mst - Matt S. Trout (cpan:MSTROUT) + +=head1 CONTRIBUTORS + +dg - David Leadbeater (cpan:DGL) + +frew - Arthur Axel "fREW" Schmidt (cpan:FREW) + +hobbs - Andrew Rodland (cpan:ARODLAND) + +jnap - John Napiorkowski (cpan:JJNAPIORK) + +ribasushi - Peter Rabbitson (cpan:RIBASUSHI) + +chip - Chip Salzenberg (cpan:CHIPS) + +ajgb - Alex J. G. Burzyński (cpan:AJGB) + +doy - Jesse Luehrs (cpan:DOY) + +perigrin - Chris Prather (cpan:PERIGRIN) + +Mithaldu - Christian Walde (cpan:MITHALDU) + +ilmari - Dagfinn Ilmari MannsÃ¥ker (cpan:ILMARI) + +tobyink - Toby Inkster (cpan:TOBYINK) + +haarg - Graham Knop (cpan:HAARG) + +=head1 COPYRIGHT + +Copyright (c) 2010-2012 the Role::Tiny L and L +as listed above. + +=head1 LICENSE + +This library is free software and may be distributed under the same terms +as perl itself. + +=cut diff --git a/lib/Role/Tiny/With.pm b/lib/Role/Tiny/With.pm new file mode 100644 index 0000000..bc9f2e4 --- /dev/null +++ b/lib/Role/Tiny/With.pm @@ -0,0 +1,50 @@ +package Role::Tiny::With; + +use strict; +use warnings; + +our $VERSION = '2.002004'; +$VERSION =~ tr/_//d; + +use Role::Tiny (); + +use Exporter 'import'; +our @EXPORT = qw( with ); + +sub with { + my $target = caller; + Role::Tiny->apply_roles_to_package($target, @_) +} + +1; + +=head1 NAME + +Role::Tiny::With - Neat interface for consumers of Role::Tiny roles + +=head1 SYNOPSIS + + package Some::Class; + + use Role::Tiny::With; + + with 'Some::Role'; + + # The role is now mixed in + +=head1 DESCRIPTION + +C is a minimalist role composition tool. C +provides a C function to compose such roles. + +=head1 AUTHORS + +See L for authors. + +=head1 COPYRIGHT AND LICENSE + +See L for the copyright and license. + +=cut + + diff --git a/maint/Makefile.PL.include b/maint/Makefile.PL.include new file mode 100644 index 0000000..9037f72 --- /dev/null +++ b/maint/Makefile.PL.include @@ -0,0 +1,12 @@ +BEGIN { -e 'Distar' or system qw(git clone https://github.com/p5sagit/Distar.git) } +use lib 'Distar/lib'; +use Distar; +use ExtUtils::MakeMaker; +ExtUtils::MakeMaker->VERSION(6.68) + unless $ENV{CONTINUOUS_INTEGRATION}; + +author 'mst - Matt S. Trout (cpan:MSTROUT) '; + +manifest_include 'xt/dependents', '.patch'; + +1; diff --git a/t/concrete-methods.t b/t/concrete-methods.t new file mode 100644 index 0000000..68bbb51 --- /dev/null +++ b/t/concrete-methods.t @@ -0,0 +1,134 @@ +use strict; +use warnings; +no warnings 'once'; +use Test::More; + +BEGIN { + package MyRole1; + + our $before_scalar = 1; + sub before_sub {} + sub before_sub_blessed {} + sub before_stub; + sub before_stub_proto ($); + use constant before_constant => 1; + use constant before_constant_list => (4, 5); + use constant before_constant_glob => 1; + our $before_constant_glob = 1; + use constant before_constant_inflate => 1; + use constant before_constant_list_inflate => (4, 5); + use constant before_constant_deflate => 1; + + # subs stored directly in the stash are meant to be supported in perl 5.22+, + # but until 5.26.1 they have a risk of segfaulting. perl itself won't ever + # install subs in exactly this form, so we're safe to just dodge the issue + # in the test and not account for it in Role::Tiny itself. + BEGIN { + if ("$]" >= 5.026001) { + $MyRole1::{'blorf'} = sub { 'blorf' }; + } + } + + use Role::Tiny; + no warnings 'once'; + + our $after_scalar = 1; + sub after_sub {} + sub after_sub_blessed {} + sub after_stub; + sub after_stub_proto ($); + use constant after_constant => 1; + use constant after_constant_list => (4, 5); + use constant after_constant_glob => 1; + our $after_constant_glob = 1; + use constant after_constant_inflate => (my $f = 1); + use constant after_constant_list_inflate => (4, 5); + + for ( + \&before_constant_inflate, + \&before_constant_list_inflate, + \&after_constant_inflate, + \&after_constant_list_inflate, + ) {} + + my $deflated = before_constant_deflate; + + bless \&before_sub_blessed; + bless \&after_sub_blessed; +} + +{ + package MyClass1; + no warnings 'once'; + + our $GLOBAL1 = 1; + sub method {} +} + +my @methods = qw( + after_sub + after_sub_blessed + after_stub + after_stub_proto + after_constant + after_constant_list + after_constant_glob + after_constant_inflate + after_constant_list_inflate +); + +my $type = ref $MyRole1::{'blorf'}; + +my $role_methods = Role::Tiny->_concrete_methods_of('MyRole1'); +is_deeply([sort keys %$role_methods], [sort @methods], + 'only subs after Role::Tiny import are methods' ); + +# only created on 5.26, but types will still match +is ref $MyRole1::{'blorf'}, $type, + '_concrete_methods_of does not inflate subrefs in stash'; + +my @role_method_list = Role::Tiny->methods_provided_by('MyRole1'); +is_deeply([sort @role_method_list], [sort @methods], + 'methods_provided_by gives method list' ); + +my $class_methods = Role::Tiny->_concrete_methods_of('MyClass1'); +is_deeply([sort keys %$class_methods], ['method'], + 'only subs from non-Role::Tiny packages are methods' ); + +eval { Role::Tiny->methods_provided_by('MyClass1') }; +like $@, + qr/is not a Role::Tiny/, + 'methods_provided_by refuses to work on classes'; + +{ + package Look::Out::Here::Comes::A::Role; + use Role::Tiny; + sub its_a_method { 1 } +} + +{ + package And::Another::One; + sub its_a_method { 2 } + use Role::Tiny; + + my @warnings; + local $SIG{__WARN__} = sub { push @warnings, @_ }; + with 'Look::Out::Here::Comes::A::Role'; + ::is join('', @warnings), '', + 'non-methods not overwritten by role composition'; +} + +{ + package RoleLikeOldMoo; + use Role::Tiny; + sub not_a_method { 1 } + + # simulate what older versions of Moo do to mark non-methods + $Role::Tiny::INFO{+__PACKAGE__}{not_methods}{$_} = $_ + for \¬_a_method; +} + +is_deeply [Role::Tiny->methods_provided_by('RoleLikeOldMoo')], [], + 'subs marked in not_methods (like old Moo) are excluded from method list'; + +done_testing; diff --git a/t/create-hook.t b/t/create-hook.t new file mode 100644 index 0000000..fe37147 --- /dev/null +++ b/t/create-hook.t @@ -0,0 +1,26 @@ +use strict; +use warnings; +use Test::More; + +use Role::Tiny (); + +my $last_role; +push @Role::Tiny::ON_ROLE_CREATE, sub { + ($last_role) = @_; +}; + +eval q{ + package MyRole; + use Role::Tiny; +}; + +is $last_role, 'MyRole', 'role create hook was run'; + +eval q{ + package MyRole2; + use Role::Tiny; +}; + +is $last_role, 'MyRole2', 'role create hook was run again'; + +done_testing; diff --git a/t/does.t b/t/does.t new file mode 100644 index 0000000..7a1ad64 --- /dev/null +++ b/t/does.t @@ -0,0 +1,59 @@ +use strict; +use warnings; +use Test::More; + +BEGIN { + package Local::Role1; + use Role::Tiny; +} + +BEGIN { + package Local::Role2; + use Role::Tiny; +} + +BEGIN { + package Local::Class1; + use Role::Tiny::With; + with qw( + Local::Role1 + Local::Role2 + ); +} + +BEGIN { + package Local::Class2; + use Role::Tiny::With; + with qw( Local::Role1 ); + with qw( Local::Role2 ); +} + +BEGIN { + package Local::Class3; + use Role::Tiny::With; + with qw( Local::Role1 ); + with qw( Local::Role2 ); + sub DOES { + my ($proto, $role) = @_; + return 1 if $role eq 'Local::Role3'; + return $proto->Role::Tiny::does_role($role); + } +} + +for my $c (1 .. 3) { + my $class = "Local::Class$c"; + for my $r (1 .. 2) { + my $role = "Local::Role$r"; + ok($class->does($role), "$class\->does($role)"); + ok($class->DOES($role), "$class\->DOES($role)"); + } +} + +{ + my $class = "Local::Class3"; + my $role = "Local::Role3"; + ok( ! $class->does($role), "$class\->does($role)"); + ok( $class->DOES($role), "$class\->DOES($role)"); +} + +done_testing; diff --git a/t/extend-role-tiny.t b/t/extend-role-tiny.t new file mode 100644 index 0000000..0bad5ae --- /dev/null +++ b/t/extend-role-tiny.t @@ -0,0 +1,42 @@ +use strict; +use warnings; +use Test::More; + +BEGIN { + package My::Role::Tiny::Extension; + $INC{'My/Role/Tiny/Extension.pm'} = __FILE__; + use Role::Tiny (); + our @ISA = qw(Role::Tiny); + + my %lie; + + sub _install_subs { + my $me = shift; + my ($role) = @_; + local $lie{$role} = 1; + $me->SUPER::_install_subs(@_); + } + + sub is_role { + my ($me, $role) = @_; + return 0 + if $lie{$role}; + $me->SUPER::is_role($role); + } +} + +my @warnings; +BEGIN { + package My::Thing::Using::Extended::Role; + My::Role::Tiny::Extension->import; + local $SIG{__WARN__} = sub { push @warnings, @_ }; + My::Role::Tiny::Extension->import; +} + +my $methods = My::Role::Tiny::Extension->_concrete_methods_of('My::Thing::Using::Extended::Role'); +is join(', ', sort keys %$methods), '', + 'subs installed when creating a role are not methods'; + +# there will be warnings but we don't care about them + +done_testing; diff --git a/t/extend.t b/t/extend.t new file mode 100644 index 0000000..2b17f26 --- /dev/null +++ b/t/extend.t @@ -0,0 +1,52 @@ +use strict; +use warnings; +use Test::More; + +my %apply_steps; +BEGIN { + package MyRoleTinyExtension; + use Role::Tiny (); + our @ISA = qw(Role::Tiny); + + sub role_application_steps { + my $self = shift; + return ( + 'role_apply_before', + $self->SUPER::role_application_steps(@_), + 'Fully::Qualified::role_apply_after', + ); + }; + + sub role_apply_before { + my ($self, $to, $role) = @_; + ::ok !Role::Tiny::does_role($to, $role), + "$role not applied to $to yet"; + $apply_steps{$to}{$role}{before}++; + } + sub Fully::Qualified::role_apply_after { + my ($self, $to, $role) = @_; + ::ok +Role::Tiny::does_role($to, $role), + "$role applied to $to"; + $apply_steps{$to}{$role}{after}++; + } +} + +{ + package ExtendedRole; + MyRoleTinyExtension->import; + + sub added_sub {} +} + +{ + package ApplyTo; + MyRoleTinyExtension->apply_role_to_package(__PACKAGE__, 'ExtendedRole'); +} + +is $apply_steps{'ApplyTo'}{'ExtendedRole'}{before}, 1, + 'before step was run'; + +is $apply_steps{'ApplyTo'}{'ExtendedRole'}{after}, 1, + 'after step was run'; + +done_testing; diff --git a/t/lib/BrokenModule.pm b/t/lib/BrokenModule.pm new file mode 100644 index 0000000..6271159 --- /dev/null +++ b/t/lib/BrokenModule.pm @@ -0,0 +1,6 @@ +package BrokenModule; +use strict; +use warnings; + +my $f = blorp; +1; diff --git a/t/lib/ExistingModule.pm b/t/lib/ExistingModule.pm new file mode 100644 index 0000000..f6cf88a --- /dev/null +++ b/t/lib/ExistingModule.pm @@ -0,0 +1,4 @@ +package ExistingModule; +our $LOADED; +$LOADED++; +1; diff --git a/t/lib/FalseModule.pm b/t/lib/FalseModule.pm new file mode 100644 index 0000000..9e7ae7a --- /dev/null +++ b/t/lib/FalseModule.pm @@ -0,0 +1,3 @@ +package FalseModule; + +0; diff --git a/t/lib/TrueModule.pm b/t/lib/TrueModule.pm new file mode 100644 index 0000000..9e4456c --- /dev/null +++ b/t/lib/TrueModule.pm @@ -0,0 +1,4 @@ +package TrueModule; +our $LOADED; +$LOADED++; +1; diff --git a/t/load-module.t b/t/load-module.t new file mode 100644 index 0000000..0bce619 --- /dev/null +++ b/t/load-module.t @@ -0,0 +1,41 @@ +use strict; +use warnings; +no warnings 'once'; +use Test::More; +use Role::Tiny (); + +use lib 't/lib'; + +Role::Tiny::_load_module('TrueModule'); + +is do { + no strict 'refs'; + ${"TrueModule::LOADED"} +}, 1, 'normal module loaded properly'; + +{ + package ExistingModule; + our $LOADED = 0; +} + +Role::Tiny::_load_module('ExistingModule'); +is do { + no strict 'refs'; + ${"ExistingModule::LOADED"} +}, 0, 'modules not loaded if symbol table entries exist'; + +eval { Role::Tiny::_load_module('BrokenModule') }; +like "$@", qr/Compilation failed/, + 'broken modules throw errors'; +eval { require BrokenModule }; +like "$@", qr/Compilation failed/, + ' ... and still fail if required again'; + +eval { Role::Tiny::_load_module('FalseModule') }; +like "$@", qr/did not return a true value/, + 'modules returning false throw errors'; +eval { require FalseModule }; +like "$@", qr/did not return a true value/, + ' ... and still fail if required again'; + +done_testing; diff --git a/t/make-role.t b/t/make-role.t new file mode 100644 index 0000000..1ffef0f --- /dev/null +++ b/t/make-role.t @@ -0,0 +1,22 @@ +use strict; +use warnings; +use Test::More; + +use Role::Tiny (); + +Role::Tiny->make_role('Foo'); +{ + no warnings 'once'; + *Foo::foo = sub {42}; +} + +ok( Role::Tiny->is_role('Foo'), 'Foo is_role'); + +for my $m (qw(requires with before around after)) { + ok( !Foo->can($m), "Foo cannot '$m'" ); +} + +Role::Tiny->apply_roles_to_package('FooFoo', 'Foo'); +can_ok 'FooFoo', 'foo'; + +done_testing; diff --git a/t/method-conflicts.t b/t/method-conflicts.t new file mode 100644 index 0000000..41bc1b2 --- /dev/null +++ b/t/method-conflicts.t @@ -0,0 +1,51 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Local::R1; + use Role::Tiny; + sub method { 1 }; +} + +{ + package Local::R2; + use Role::Tiny; + sub method { 2 }; +} + +ok( + !eval { + package Local::C1; + use Role::Tiny::With; + with qw(Local::R1 Local::R2); + 1; + }, + 'method conflict dies', +); + +like( + $@, + qr{^Due to a method name conflict between roles 'Local::R.' and 'Local::R.', the method 'method' must be implemented by 'Local::C1'}, + '... with correct error message', +); + +ok( + eval { + package Local::C2; + use Role::Tiny::With; + with qw(Local::R1 Local::R2); + sub method { 3 }; + 1; + }, + '... but can be resolved', +); + +is( + "Local::C2"->method, + 3, + "... which works properly", +); + +done_testing; diff --git a/t/namespace-clean.t b/t/namespace-clean.t new file mode 100644 index 0000000..3725f77 --- /dev/null +++ b/t/namespace-clean.t @@ -0,0 +1,74 @@ +use strict; +use warnings; +use Test::More; + +use B (); + +sub is_method { + my ($ns, $sub) = @_; + no strict 'refs'; + my $cv = B::svref_2object(\&{"${ns}::${sub}"}); + return + if !$cv->isa('B::CV'); + my $gv = $cv->GV; + return + if $gv->isa('B::SPECIAL'); + + my $pack = $gv->STASH->NAME + or return; + + return ( + $pack eq $ns + || ($pack eq 'constant' && $gv->name eq '__ANON__') + ); +} + +BEGIN { + package Local::Role; + use Role::Tiny; + sub foo { 1 }; +} + +BEGIN { + package Local::Class; + use Role::Tiny::With; + with qw( Local::Role ); + + BEGIN { + # poor man's namespace::autoclean + no strict 'refs'; + my @subs = grep defined &$_, keys %Local::Class::; + my @imports = grep !::is_method(__PACKAGE__, $_), @subs; + delete @Local::Class::{@imports}; + } +} + +ok !defined &Local::Class::with, 'imports are cleaned'; + +can_ok 'Local::Class', 'foo'; +can_ok 'Local::Class', 'does'; + +BEGIN { + package Local::Role2; + use Role::Tiny; + + # poor man's namespace::clean + my @subs; + BEGIN { + no strict 'refs'; + @subs = grep defined &$_, keys %Local::Role2:: + } + delete @Local::Role2::{@subs}; + + sub foo { 1 }; +} + +BEGIN { + package Local::Role2; + use Role::Tiny; +} + +# this may not be ideal, but we'll test it since it is done explicitly +ok !defined &Local::Role2::with, 'subs are not re-exported'; + +done_testing; diff --git a/t/overload.t b/t/overload.t new file mode 100644 index 0000000..f49cdf6 --- /dev/null +++ b/t/overload.t @@ -0,0 +1,82 @@ +use strict; +use warnings; +use Test::More; + +BEGIN { + package MyRole; + use Role::Tiny; + + sub as_string { "welp" } + sub as_num { 219 } + use overload + '""' => \&as_string, + '0+' => 'as_num', + bool => sub(){0}, + fallback => 1; +} + +BEGIN { + package MyClass; + use Role::Tiny::With; + with 'MyRole'; + sub new { bless {}, shift } +} + +BEGIN { + package MyClass2; + use overload + fallback => 0, + '""' => 'class_string', + '0+' => sub { 42 }, + ; + use Role::Tiny::With; + with 'MyRole'; + sub new { bless {}, shift } + sub class_string { 'yarp' } +} + +BEGIN { + package MyClass3; + sub new { bless {}, shift } +} + +{ + my $o = MyClass->new; + is "$o", 'welp', 'subref overload'; + is sprintf('%d', $o), 219, 'method name overload'; + ok !$o, 'anon subref overload'; +} + +{ + my $o = MyClass2->new; + eval { my $f = 0+$o }; + like $@, qr/no method found/, 'fallback value not overwritten'; + is "$o", 'yarp', 'method name overload not overwritten'; + is sprintf('%d', $o), 42, 'subref overload not overwritten'; +} + +{ + my $orig = MyClass3->new; + my $copy = $orig; + Role::Tiny->apply_roles_to_object($orig, 'MyRole'); + for my $o ($orig, $copy) { + my $copied = \$o == \$copy ? ' copy' : ''; + local $TODO = 'magic not applied to all ref copies on perl < 5.8.9' + if $copied && "$]" < 5.008009; + is "$o", 'welp', 'subref overload applied to instance'.$copied; + is sprintf('%d', $o), 219, 'method name overload applied to instance'.$copied; + ok !$o, 'anon subref overload applied to instance'.$copied; + } +} + +{ + my $o = MyClass3->new; + Role::Tiny->apply_roles_to_package('MyClass3', 'MyRole'); + local $TODO = 'magic not applied to existing objects on perl < 5.18' + if "$]" < 5.018; + is "$o", 'welp', 'subref overload applied to class with instance'; + is sprintf('%d', $o), 219, 'method name overload applied to class with instance'; + ok !$o, 'anon subref overload applied to class with instance'; +} + +done_testing; diff --git a/t/proto.t b/t/proto.t new file mode 100644 index 0000000..3f09dff --- /dev/null +++ b/t/proto.t @@ -0,0 +1,58 @@ +use strict; +use warnings; +use Test::More; + +my $invalid_prototypes; + +BEGIN { + package TestExporter1; + $INC{"TestExporter1.pm"} = 1; + use Exporter; + our @ISA = qw(Exporter); + our @EXPORT = qw(guff welp farb tube truck); + + sub guff { rand(1) } + sub welp () { rand(1) } + sub farb ($) { rand(1) } + + no warnings; + + eval q{ + sub tube (plaf) { rand(1) } + sub truck (-1) { rand(1) } + 1; + } and $invalid_prototypes = 1; +} + +BEGIN { + package TestRole1; + use Role::Tiny; + use TestExporter1; +} + +BEGIN { + package SomeClass; + use Role::Tiny::With; + use TestExporter1; + with 'TestRole1'; + eval { guff }; + ::is $@, '', + 'composing matching function with no prototype works'; + eval { welp }; + ::is $@, '', + 'composing matching function with empty prototype works'; + eval { farb 1 }; + ::is $@, '', + 'composing matching function with ($) prototype works'; + + if ($invalid_prototypes) { + eval { &tube }; + ::is $@, '', + 'composing matching function with invalid prototype works'; + eval { &truck }; + ::is $@, '', + 'composing matching function with invalid -1 prototype works'; + } +} + +done_testing; diff --git a/t/role-basic-basic.t b/t/role-basic-basic.t new file mode 100644 index 0000000..f66bf86 --- /dev/null +++ b/t/role-basic-basic.t @@ -0,0 +1,38 @@ +use strict; +use warnings; +use Test::More; + +BEGIN { + package My::Does::Basic; + $INC{'My/Does/Basic.pm'} = 1; + + use Role::Tiny; + + requires 'turbo_charger'; + + sub no_conflict { + return "My::Does::Basic::no_conflict"; + } +} + +BEGIN { + package My::Example; + $INC{'My/Example.pm'} = 1; + + use Role::Tiny 'with'; + + with 'My::Does::Basic'; + + sub new { bless {} => shift } + + sub turbo_charger {} + $My::Example::foo = 1; + sub foo() {} +} + +use My::Example; +can_ok 'My::Example', 'no_conflict'; +is +My::Example->no_conflict, 'My::Does::Basic::no_conflict', + '... and it should return the correct value'; + +done_testing; diff --git a/t/role-basic-bugs.t b/t/role-basic-bugs.t new file mode 100644 index 0000000..0a888aa --- /dev/null +++ b/t/role-basic-bugs.t @@ -0,0 +1,100 @@ +use strict; +use warnings; +use Test::More; + +# multiple roles with the same role +{ + package RoleC; + use Role::Tiny; + sub baz { 'baz' } + + package RoleB; + use Role::Tiny; + with 'RoleC'; + sub bar { 'bar' } + + package RoleA; + use Role::Tiny; + with 'RoleC'; + sub foo { 'foo' } + + package Foo; + use strict; + use warnings; + use Role::Tiny 'with'; + eval { + with 'RoleA', 'RoleB'; + 1; + } or $@ ||= 'unknown error'; + ::is $@, '', + 'Composing multiple roles which use the same role should not have conflicts'; + sub new { bless {} => shift } + + my $object = Foo->new; + foreach my $method (qw/foo bar baz/) { + ::can_ok $object, $method; + ::is $object->$method, $method, + '... and all methods should be composed in correctly'; + } +} + +{ + no warnings 'redefine'; + local *UNIVERSAL::can = sub { 1 }; + eval <<' END'; + package Can::Can; + use Role::Tiny 'with'; + with 'A::NonExistent::Role'; + END +} + +{ + my $error = $@ || ''; + like $error, qr{^Can't locate A/NonExistent/Role.pm}, + 'If ->can always returns true, we should still not think we loaded the role'; +} + +{ + package Role1; + use Role::Tiny; + + package Role2; + use Role::Tiny; + + package Frew; + use strict; + use warnings; + sub new { bless {} => shift } + + my $object = Frew->new; + + ::ok(!Role::Tiny::does_role($object, 'Role1'), 'no Role1 yet'); + ::ok(!Role::Tiny::does_role($object, 'Role2'), 'no Role2 yet'); + + Role::Tiny->apply_roles_to_object($object, 'Role1'); + ::ok(Role::Tiny::does_role($object, "Role1"), 'Role1 consumed'); + ::ok(!Role::Tiny::does_role($object, 'Role2'), 'no Role2 yet'); + Role::Tiny->apply_roles_to_object($object, 'Role2'); + ::ok(Role::Tiny::does_role($object, "Role1"), 'Role1 consumed'); + ::ok(Role::Tiny::does_role($object, 'Role2'), 'Role2 consumed'); +} + +BEGIN { + package Bar; + $INC{'Bar.pm'} = __FILE__; + + sub new { bless {} => shift } + sub bar { 1 } +} +BEGIN { + package Baz; + $INC{'Baz.pm'} = __FILE__; + + use Role::Tiny; + + sub baz { 1 } +} + +can_ok(Role::Tiny->create_class_with_roles(qw(Bar Baz))->new, qw(bar baz)); + +done_testing; diff --git a/t/role-basic-composition.t b/t/role-basic-composition.t new file mode 100644 index 0000000..629623c --- /dev/null +++ b/t/role-basic-composition.t @@ -0,0 +1,261 @@ +use strict; +use warnings; +use Test::More; +require Role::Tiny; + +{ + package My::Does::Basic1; + use Role::Tiny; + requires 'turbo_charger'; + + sub method { + return __PACKAGE__ . " method"; + } +} +{ + package My::Does::Basic2; + use Role::Tiny; + requires 'turbo_charger'; + + sub method2 { + return __PACKAGE__ . " method2"; + } +} + +eval <<'END_PACKAGE'; +package My::Class1; +use Role::Tiny 'with'; +with qw( + My::Does::Basic1 + My::Does::Basic2 +); +sub turbo_charger {} +END_PACKAGE +ok !$@, 'We should be able to use two roles with the same requirements' + or die $@; + +{ + package My::Does::Basic3; + use Role::Tiny; + with 'My::Does::Basic2'; + + sub method3 { + return __PACKAGE__ . " method3"; + } +} + +eval <<'END_PACKAGE'; +package My::Class2; +use Role::Tiny 'with'; +with qw( + My::Does::Basic3 +); +sub new { bless {} => shift } +sub turbo_charger {} +END_PACKAGE +ok !$@, 'We should be able to use roles which consume roles' + or die $@; +can_ok 'My::Class2', 'method2'; +is My::Class2->method2, 'My::Does::Basic2 method2', + '... and it should be the correct method'; +can_ok 'My::Class2', 'method3'; +is My::Class2->method3, 'My::Does::Basic3 method3', + '... and it should be the correct method'; + +ok My::Class2->Role::Tiny::does_role('My::Does::Basic3'), 'A class DOES roles which it consumes'; +ok My::Class2->Role::Tiny::does_role('My::Does::Basic2'), + '... and should do roles which its roles consumes'; +ok !My::Class2->Role::Tiny::does_role('My::Does::Basic1'), + '... but not roles which it never consumed'; + +my $object = My::Class2->new; +ok $object->Role::Tiny::does_role('My::Does::Basic3'), 'An instance DOES roles which its class consumes'; +ok $object->Role::Tiny::does_role('My::Does::Basic2'), + '... and should do roles which its roles consumes'; +ok !$object->Role::Tiny::does_role('My::Does::Basic1'), + '... but not roles which it never consumed'; + + +{ + package GenAccessors; + BEGIN { $INC{'GenAccessors.pm'} = __FILE__ } + + sub import { + my ( $class, @methods ) = @_; + my $target = caller; + + foreach my $method (@methods) { + no strict 'refs'; + *{"${target}::${method}"} = sub { + @_ > 1 ? $_[0]->{$method} = $_[1] : $_[0]->{$method}; + }; + } + } +} + +{ + { + package Role::Which::Imports; + use Role::Tiny; + use GenAccessors qw(this that); + } + { + package Class::With::ImportingRole; + use Role::Tiny 'with'; + with 'Role::Which::Imports'; + sub new { bless {} => shift } + } + my $o = Class::With::ImportingRole->new; + + foreach my $method (qw/this that/) { + can_ok $o, $method; + ok $o->$method($method), '... and calling "allow"ed methods should succeed'; + is $o->$method, $method, '... and it should function correctly'; + } +} + +{ + { + package Role::WithImportsOnceRemoved; + use Role::Tiny; + with 'Role::Which::Imports'; + } + { + package Class::With::ImportingRole2; + use Role::Tiny 'with'; + with 'Role::WithImportsOnceRemoved'; + sub new { bless {} => shift } + } + ok my $o = Class::With::ImportingRole2->new, + 'We should be able to use roles which compose roles which import'; + + foreach my $method (qw/this that/) { + can_ok $o, $method; + ok $o->$method($method), '... and calling "allow"ed methods should succeed'; + is $o->$method, $method, '... and it should function correctly'; + } +} + +{ + { + package Method::Role1; + use Role::Tiny; + sub method1 { } + requires 'method2'; + } + + { + package Method::Role2; + use Role::Tiny; + sub method2 { } + requires 'method1'; + } + my $success = eval q{ + package Class; + use Role::Tiny::With; + with 'Method::Role1', 'Method::Role2'; + 1; + }; + is $success, 1, 'composed mutually dependent methods successfully' or diag "Error: $@"; +} + +SKIP: { + skip "Class::Method::Modifiers not installed or too old", 1 + unless eval "use Class::Method::Modifiers 1.05; 1"; + { + package Modifier::Role1; + use Role::Tiny; + sub foo { + } + before 'bar', sub {}; + } + + { + package Modifier::Role2; + use Role::Tiny; + sub bar { + } + before 'foo', sub {}; + } + my $success = eval q{ + package Class; + use Role::Tiny::With; + with 'Modifier::Role1', 'Modifier::Role2'; + 1; + }; + is $success, 1, 'composed mutually dependent modifiers successfully' or diag "Error: $@"; +} + +{ + { + package Base::Role; + use Role::Tiny; + requires qw/method1 method2/; + } + + { + package Sub::Role1; + use Role::Tiny; + with 'Base::Role'; + sub method1 {} + } + + { + package Sub::Role2; + use Role::Tiny; + with 'Base::Role'; + sub method2 {} + } + + my $success = eval q{ + package Diamant::Class; + use Role::Tiny::With; + with qw/Sub::Role1 Sub::Role2/; + 1; + }; + is $success, 1, 'composed diamantly dependent roles successfully' or diag "Error: $@"; +} + +{ + { + package My::Does::Conflict; + use Role::Tiny; + + sub method { + return __PACKAGE__ . " method"; + } + } + { + package My::Class::Base; + + sub turbo_charger { + return __PACKAGE__ . " turbo charger"; + } + sub method { + return __PACKAGE__ . " method"; + } + } + my $success = eval q{ + package My::Class::Child; + use base 'My::Class::Base'; + use Role::Tiny::With; + with qw/My::Does::Basic1 My::Does::Conflict/; + 1; + }; + is $success, 1, 'role conflict resolved by superclass method' or diag "Error: $@"; + can_ok 'My::Class::Child', 'method'; + is My::Class::Child->method, 'My::Class::Base method', 'inherited method prevails'; + + $success = eval q{ + package My::Class::Child2; + use base 'My::Class::Base'; + use Role::Tiny::With; + with qw/My::Does::Basic1/; + 1; + }; + is $success, 1, 'role composed after conflict resolution' or diag "Error: $@"; + can_ok 'My::Class::Child2', 'method'; + is My::Class::Child2->method, 'My::Does::Basic1 method', 'role method applied'; +} + +done_testing; diff --git a/t/role-basic-exceptions.t b/t/role-basic-exceptions.t new file mode 100644 index 0000000..abddd63 --- /dev/null +++ b/t/role-basic-exceptions.t @@ -0,0 +1,79 @@ +use strict; +use warnings; +use Test::More; +require Role::Tiny; + +{ + package My::Does::Basic; + + use Role::Tiny; + + requires 'turbo_charger'; + + sub conflict { + return "My::Does::Basic::conflict"; + } +} + +eval <<'END_PACKAGE'; + package My::Bad::Requirement; + use Role::Tiny::With; + with 'My::Does::Basic'; # requires turbo_charger +END_PACKAGE +like $@, qr/missing turbo_charger/, + 'Trying to use a role without providing required methods should fail'; + +{ + { + package My::Conflict; + use Role::Tiny; + sub conflict {}; + } + eval <<' END_PACKAGE'; + package My::Bad::MethodConflicts; + use Role::Tiny::With; + with qw(My::Does::Basic My::Conflict); + sub turbo_charger {} + END_PACKAGE + like $@, qr/.+/, + 'Trying to use multiple roles with the same method should fail'; +} + + +{ + { + package Role1; + use Role::Tiny; + requires 'missing_method'; + sub method1 { 'method1' } + } + { + package Role2; + use Role::Tiny; + with 'Role1'; + sub method2 { 'method2' } + } + eval <<' END'; + package My::Class::Missing1; + use Role::Tiny::With; + with 'Role2'; + END + like $@, qr/missing missing_method/, + 'Roles composed from roles should propogate requirements upwards'; +} +{ + { + package Role3; + use Role::Tiny; + requires qw(this that); + } + eval <<' END'; + package My::Class::Missing2; + use Role::Tiny::With; + with 'Role3'; + END + like $@, qr/missing this, that/, + 'Roles should be able to require multiple methods'; +} + +done_testing; diff --git a/t/role-duplication.t b/t/role-duplication.t new file mode 100644 index 0000000..dbba0e0 --- /dev/null +++ b/t/role-duplication.t @@ -0,0 +1,45 @@ +use strict; +use warnings; +use Test::More; + +BEGIN { + package Role1; use Role::Tiny; + sub foo1 { 1 } +} +BEGIN { + package Role2; use Role::Tiny; + sub foo2 { 2 } +} +BEGIN { + package BaseClass; + sub foo { 0 } +} + +eval { + Role::Tiny->create_class_with_roles( + 'BaseClass', + qw(Role2 Role1 Role1 Role2 Role2), + ); +}; + +like $@, qr/\ADuplicated roles: Role1, Role2 /, + 'duplicate roles detected'; + +BEGIN { + package AnotherRole; + use Role::Tiny; + with 'Role1'; +} + +BEGIN { + package AnotherClass; + use Role::Tiny::With; + with 'AnotherRole'; + delete $AnotherClass::{foo1}; + with 'AnotherRole'; +} + +ok +AnotherClass->can('foo1'), + 'reapplying roles re-adds missing methods'; + +done_testing; diff --git a/t/role-long-package-name.t b/t/role-long-package-name.t new file mode 100644 index 0000000..ffa43c6 --- /dev/null +++ b/t/role-long-package-name.t @@ -0,0 +1,52 @@ +use strict; +use warnings; +use Test::More; + +# using Role::Tiny->apply_roles_to_object with too many roles, +# It makes 'Identifier too long' error in string 'eval'. +# And, Moo uses string eval. +{ + package R::AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA; + use Role::Tiny; + package R::BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB; + use Role::Tiny; + package R::CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC; + use Role::Tiny; + package R::DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD; + use Role::Tiny; + package R::EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE; + use Role::Tiny; +} + +# test various lengths so abbreviation cuts off double colon +for my $pack (qw( + Foo + Fooo + Foooo + Fooooo + Foooooo + Fooooooo + Foooooooo +)) { + { + no strict 'refs'; + *{"${pack}::new"} = sub { bless {}, $_[0] }; + } + my $o = $pack->new; + for (qw( + R::AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA + R::BBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBBB + R::CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + R::DDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDDD + R::EEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE + )) { + Role::Tiny->apply_roles_to_object($o, $_); + } + + my $pkg = ref $o; + eval "package $pkg;"; + is $@, '', 'package name usable by perl' + or diag "package: $pkg"; +} + +done_testing; diff --git a/t/role-tiny-composition.t b/t/role-tiny-composition.t new file mode 100644 index 0000000..c93cbcc --- /dev/null +++ b/t/role-tiny-composition.t @@ -0,0 +1,42 @@ +use strict; +use warnings; +use Test::More; + +{ + package R1; + use Role::Tiny; + + sub foo {} + + $INC{"R1.pm"} = __FILE__; +} + +{ + package R2; + use Role::Tiny; + + sub foo {} + + $INC{"R2.pm"} = __FILE__; +} + +{ + package X; + sub new { + bless {} => shift + } +} + +eval { Role::Tiny->apply_roles_to_object(X->new, "R1", "R2") }; +like $@, + qr/^Due to a method name conflict between roles 'R1' and 'R2', the method 'foo' must be implemented by 'X'/, + 'apply conflicting roles to object'; + +eval { Role::Tiny->apply_roles_to_object(X->new); 1 } + or $@ ||= "false exception!"; +like $@, + qr/^No roles supplied!/, + 'apply no roles to object'; + + +done_testing; diff --git a/t/role-tiny-with.t b/t/role-tiny-with.t new file mode 100644 index 0000000..34ba1eb --- /dev/null +++ b/t/role-tiny-with.t @@ -0,0 +1,57 @@ +use strict; +use warnings; +use Test::More; + +BEGIN { + package MyRole; + + use Role::Tiny; + + sub bar { 'role bar' } + + sub baz { 'role baz' } +} + +BEGIN { + package MyClass; + + use Role::Tiny::With; + + with 'MyRole'; + + sub foo { 'class foo' } + + sub baz { 'class baz' } + +} + +is(MyClass->foo, 'class foo', 'method from class no override'); +is(MyClass->bar, 'role bar', 'method from role'); +is(MyClass->baz, 'class baz', 'method from class'); + +BEGIN { + package RoleWithStub; + + use Role::Tiny; + + sub foo { 'role foo' } + + sub bar ($$); +} + +{ + package ClassConsumeStub; + use Role::Tiny::With; + + eval { + with 'RoleWithStub'; + }; +} + +is $@, '', 'stub composed without error'; +ok exists &ClassConsumeStub::bar, + 'stub exists in consuming class'; +ok !defined &ClassConsumeStub::bar, + 'stub consumed as stub'; + +done_testing; diff --git a/t/role-tiny.t b/t/role-tiny.t new file mode 100644 index 0000000..2b69273 --- /dev/null +++ b/t/role-tiny.t @@ -0,0 +1,126 @@ +use strict; +use warnings; +use Test::More; + +BEGIN { + package MyRole; + + use Role::Tiny; + + requires qw(req1 req2); + + sub bar { 'role bar' } + + sub baz { 'role baz' } +} + +BEGIN { + package MyClass; + + use constant SIMPLE => 'simple'; + use constant REF_CONST => [ 'ref_const' ]; + use constant VSTRING_CONST => v1; + + sub req1 { } + sub req2 { } + sub foo { 'class foo' } + sub baz { 'class baz' } + +} + +BEGIN { + package ExtraClass; + sub req1 { } + sub req2 { } + sub req3 { } + sub foo { } + sub baz { 'class baz' } +} + +BEGIN { + package IntermediaryRole; + use Role::Tiny; + requires 'req3'; +} + +BEGIN { + package NoMethods; + + package OneMethod; + + sub req1 { } +} + +BEGIN { + package ExtraRole; + use Role::Tiny; + + sub extra1 { 'role extra' } +} + +sub try_apply_to { + my $to = shift; + eval { Role::Tiny->apply_role_to_package($to, 'MyRole'); 1 } + and return undef; + return $@ if $@; + die "false exception caught!"; +} + +is(try_apply_to('MyClass'), undef, 'role applies cleanly'); +is(MyClass->bar, 'role bar', 'method from role'); +is(MyClass->baz, 'class baz', 'method from class'); +ok(MyClass->does('MyRole'), 'class does role'); +ok(!MyClass->does('IntermediaryRole'), 'class does not do non-applied role'); +ok(!MyClass->does('Random'), 'class does not do non-role'); + +like try_apply_to(bless {}, 'MyClass'), qr/\ACan't apply roles to object/, + 'error apply_role_to_package on object'; + +like(try_apply_to('NoMethods'), qr/req1, req2/, 'error for both methods'); +like(try_apply_to('OneMethod'), qr/req2/, 'error for one method'); + +eval { + Role::Tiny->apply_role_to_package('IntermediaryRole', 'MyRole'); + Role::Tiny->apply_role_to_package('ExtraClass', 'IntermediaryRole'); + 1; +} or $@ ||= "false exception!"; +is $@, '', 'No errors applying roles'; + +eval { + Role::Tiny->apply_role_to_package('MyClass', 'ExtraClass'); +}; +like $@, qr/ExtraClass is not a Role::Tiny/, 'No errors applying roles'; + +ok(ExtraClass->does('MyRole'), 'ExtraClass does MyRole'); +ok(ExtraClass->does('IntermediaryRole'), 'ExtraClass does IntermediaryRole'); +is(ExtraClass->bar, 'role bar', 'method from role'); +is(ExtraClass->baz, 'class baz', 'method from class'); + +my $new_class; +eval { + $new_class = Role::Tiny->create_class_with_roles('MyClass', 'ExtraRole'); +} or $@ ||= "false exception!"; +is $@, '', 'No errors creating class with roles'; + +isa_ok($new_class, 'MyClass'); +is($new_class->extra1, 'role extra', 'method from role'); + +eval { + Role::Tiny->create_class_with_roles('MyClass'); + 1; +} or $@ ||= "false exception!"; +like $@, qr/^No roles supplied!/, + 'error on no roles to create_class_with_roles'; + +eval { + Role::Tiny->create_class_with_roles('MyClass', 'ExtraClass'); + 1; +} or $@ ||= "false exception!"; +like $@, qr/^ExtraClass is not a Role::Tiny/, + 'error on non-role to create_class_with_roles'; + +ok(Role::Tiny->is_role('MyRole'), 'is_role true for roles'); +ok(!Role::Tiny->is_role('MyClass'), 'is_role false for classes'); + + +done_testing; diff --git a/t/role-with-inheritance.t b/t/role-with-inheritance.t new file mode 100644 index 0000000..e62b854 --- /dev/null +++ b/t/role-with-inheritance.t @@ -0,0 +1,30 @@ +use strict; +use warnings; +use Test::More; + +{ + package R1; + use Role::Tiny; +} +{ + package R2; + use Role::Tiny; +} +{ + package C1; + use Role::Tiny::With; + with 'R1'; +} +{ + package C2; + use Role::Tiny::With; + our @ISA=('C1'); + with 'R2'; +} + +ok Role::Tiny::does_role('C1','R1'), "Parent does own role"; +ok !Role::Tiny::does_role('C1','R2'), "Parent does not do child's role"; +ok Role::Tiny::does_role('C2','R1'), "Child does base's role"; +ok Role::Tiny::does_role('C2','R2'), "Child does own role"; + +done_testing(); diff --git a/t/stub.t b/t/stub.t new file mode 100644 index 0000000..6dfe883 --- /dev/null +++ b/t/stub.t @@ -0,0 +1,61 @@ +use strict; +use warnings; +use Test::More; + +use Role::Tiny (); + +{ + eval q{ + package RoleWithMatchingSub; + use Role::Tiny; + sub stubsub { "stubsub" } + 1; + } or die $@; + + my $e; + if (!eval q{ + package ClassWithStub; + use Role::Tiny::With; + + sub stubsub; + + with 'RoleWithMatchingSub'; + 1; + }) { + $e = $@; + } + + is $e, undef, + 'no error composing role in class with stub'; + + ok exists &ClassWithStub::stubsub && !defined &ClassWithStub::stubsub, + 'stub sub prevents composing matching sub'; +} + +{ + eval q{ + package RoleWithStub; + use Role::Tiny; + sub stubsub; + 1; + } or die $@; + + my $e; + if (!eval q{ + package ComposeStub; + use Role::Tiny::With; + + with 'RoleWithStub'; + 1; + }) { + $e = $@; + } + + is $e, undef, + 'no error composing role with stub'; + + ok exists &ComposeStub::stubsub && !defined &ComposeStub::stubsub, + 'composing role includes stub subs'; +} + +done_testing; diff --git a/t/subclass.t b/t/subclass.t new file mode 100644 index 0000000..f3eca00 --- /dev/null +++ b/t/subclass.t @@ -0,0 +1,164 @@ +use strict; +use warnings; +use Test::More; + +my $backcompat_called; +{ + package RoleExtension; + use base 'Role::Tiny'; + + sub apply_single_role_to_package { + my $me = shift; + $me->SUPER::apply_single_role_to_package(@_); + $backcompat_called++; + } +} +{ + package RoleExtension2; + use base 'Role::Tiny'; + + sub role_application_steps { + $_[0]->SUPER::role_application_steps; + } + + sub apply_single_role_to_package { + my $me = shift; + $me->SUPER::apply_single_role_to_package(@_); + $backcompat_called++; + } + +} + +{ + package Role1; + $INC{'Role1.pm'} = __FILE__; + use Role::Tiny; + sub sub1 {} +} + +{ + package Role2; + $INC{'Role2.pm'} = __FILE__; + use Role::Tiny; + sub sub2 {} +} + +{ + package Class1; + RoleExtension->apply_roles_to_package(__PACKAGE__, 'Role1', 'Role2'); +} + +is $backcompat_called, 2, + 'overridden apply_single_role_to_package called for backcompat'; + +$backcompat_called = 0; +{ + package Class2; + RoleExtension2->apply_roles_to_package(__PACKAGE__, 'Role1', 'Role2'); +} +is $backcompat_called, 0, + 'overridden role_application_steps prevents backcompat attempt'; + +{ + package ClassWithoutExtraMethod; + sub foo {} +} +{ + package RoleWithRequires; + use Role::Tiny; + requires 'extra_sub'; +} +eval { Role::Tiny->create_class_with_roles('ClassWithoutExtraMethod', 'RoleWithRequires') }; +like $@, qr/extra_sub/, + 'requires checked properly during create_class_with_roles'; + + +SKIP: { + skip "Class::Method::Modifiers not installed or too old", 1 + unless eval "use Class::Method::Modifiers 1.05; 1"; + { + package RoleWithAround; + use Role::Tiny; + around extra_sub => sub { my $orig = shift; $orig->(@_); }; + } + + eval { Role::Tiny->create_class_with_roles('ClassWithoutExtraMethod', 'RoleWithAround') }; + like $@, qr/extra_sub/, + 'requires for modifiers checked properly during create_class_with_roles'; +} + +{ + package SimpleRole1; + use Role::Tiny; + sub role_method { __PACKAGE__ } +} + +{ + package SimpleRole2; + use Role::Tiny; + sub role_method { __PACKAGE__ } +} + +{ + package SomeEmptyClass; + $INC{'SomeEmptyClass.pm'} ||= __FILE__; +} + +{ + my $create_class = Role::Tiny->create_class_with_roles('SomeEmptyClass', 'SimpleRole1'); + Role::Tiny->apply_roles_to_package( $create_class, 'SimpleRole2' ); + + my $manual_extend = 'ManualExtend'; + @ManualExtend::ISA = qw(SomeEmptyClass); + Role::Tiny->apply_roles_to_package( $manual_extend, 'SimpleRole1' ); + Role::Tiny->apply_roles_to_package( $manual_extend, 'SimpleRole2' ); + + is $create_class->role_method, $manual_extend->role_method, + 'methods added by create_class_with_roles treated equal to those added with apply_roles_to_package'; +} + +SKIP: { + skip "Class::Method::Modifiers not installed or too old", 1 + unless eval "use Class::Method::Modifiers 1.05; 1"; + { + package CreateMITest::Top; + sub method { return __PACKAGE__ } + + package CreateMITest::Left; + our @ISA = qw(CreateMITest::Top); + + package CreateMITest::Right; + our @ISA = qw(CreateMITest::Top); + sub method { return (__PACKAGE__, $_[0]->SUPER::method); } + + package CreateMITest::Bottom; + our @ISA = qw(CreateMITest::Left CreateMITest::Right); + } + + { + package CreateMITest::MyRole; + use Role::Tiny; + around method => sub { + my ($orig, $self) = (shift, shift); + return (__PACKAGE__, $self->$orig); + }; + } + + { + package CreateMITest::MyChild; + use Role::Tiny::With; + our @ISA = qw(CreateMITest::Bottom); + with 'CreateMITest::MyRole'; + } + + my $child_with = 'CreateMITest::MyChild'; + my $child_gen = Role::Tiny->create_class_with_roles('CreateMITest::Bottom', 'CreateMITest::MyRole'); + + my @want = $child_with->method; + my @got = $child_gen->method; + + is join(', ', @got), join(', ', @want), + 'create_class_with_roles follows same MRO as equivalent using with'; +} + +done_testing; diff --git a/xt/around-does.t b/xt/around-does.t new file mode 100644 index 0000000..f57dfef --- /dev/null +++ b/xt/around-does.t @@ -0,0 +1,35 @@ +use strict; +use warnings; +use Test::More; + +use Class::Method::Modifiers 1.05; + +my $pass; +my $pass2; + +BEGIN { + package Local::Role; + use Role::Tiny; + around does => sub { + my ($orig, $self, @args) = @_; + $pass++; + return $self->$orig(@args); + }; + around DOES => sub { + my ($orig, $self, @args) = @_; + $pass2++; + return $self->$orig(@args); + }; +} + +BEGIN { + package Local::Class; + use Role::Tiny::With; + with 'Local::Role'; +} + +ok(Local::Class->does('Local::Role')); +ok($pass); +ok(Local::Class->DOES('Local::Role')); +ok($pass2); +done_testing(); diff --git a/xt/compose-modifiers.t b/xt/compose-modifiers.t new file mode 100644 index 0000000..e543378 --- /dev/null +++ b/xt/compose-modifiers.t @@ -0,0 +1,97 @@ +use strict; +use warnings; +use Test::More; + +use Class::Method::Modifiers 1.05 (); + +{ + package One; use Role::Tiny; + around foo => sub { my $orig = shift; (__PACKAGE__, $orig->(@_)) }; + package Two; use Role::Tiny; + around foo => sub { my $orig = shift; (__PACKAGE__, $orig->(@_)) }; + package Three; use Role::Tiny; + around foo => sub { my $orig = shift; (__PACKAGE__, $orig->(@_)) }; + package Four; use Role::Tiny; + requires 'foo'; + around foo => sub { my $orig = shift; (__PACKAGE__, $orig->(@_)) }; + package BaseClass; sub foo { __PACKAGE__ } +} + +foreach my $combo ( + [ qw(One Two Three Four) ], + [ qw(Two Four Three) ], + [ qw(One Two) ] +) { + my $combined = Role::Tiny->create_class_with_roles('BaseClass', @$combo); + is_deeply( + [ $combined->foo ], [ reverse(@$combo), 'BaseClass' ], + "${combined} ok" + ); + my $object = bless({}, 'BaseClass'); + Role::Tiny->apply_roles_to_object($object, @$combo); + is(ref($object), $combined, 'Object reblessed into correct class'); +} + +{ + package BaseClassNoFoo; + sub bar { __PACKAGE__ } +} + +{ + is eval { + package WithFour; + use Role::Tiny::With; + use base 'BaseClassNoFoo'; + with 'Four'; + }, undef, + "composing an around modifier fails when method doesn't exist"; + like $@, qr/Can't apply Four to WithFour - missing foo/, + ' ... with correct error message'; +} +{ + is eval { + Role::Tiny->create_class_with_roles('BaseClassNoFoo', 'Four'); + }, undef, + "composing an around modifier fails when method doesn't exist"; + like $@, qr/Can't apply Four to .* - missing foo/, + ' ... with correct error message'; +} + +{ + package WrapsMultiple; + use Role::Tiny; + around 'method1', 'method2', sub { + my $orig = shift; + return (__PACKAGE__, $orig->(@_)); + }; + around [ 'method3', 'method4' ], sub { + my $orig = shift; + return (__PACKAGE__, $orig->(@_)); + }; +} + +{ + package ClassToWrapMultiple; + use Role::Tiny::With; + sub method1 { __PACKAGE__ } + sub method2 { __PACKAGE__ } + sub method3 { __PACKAGE__ } + sub method4 { __PACKAGE__ } + with 'WrapsMultiple'; +} + +for my $method (qw(method1 method2)) { + is_deeply( + [ ClassToWrapMultiple->$method ], [ 'WrapsMultiple', 'ClassToWrapMultiple' ], + 'wrapping multiple methods using list works', + ); +} + +for my $method (qw(method3 method4)) { + is_deeply( + [ ClassToWrapMultiple->$method ], [ 'WrapsMultiple', 'ClassToWrapMultiple' ], + 'wrapping multiple methods using arrayref works', + ); +} + +done_testing; diff --git a/xt/dependents.t b/xt/dependents.t new file mode 100644 index 0000000..89e9bd2 --- /dev/null +++ b/xt/dependents.t @@ -0,0 +1,308 @@ +use strict; +use warnings; + +use Test::More; +use IPC::Open3; +use File::Spec; +use Cwd qw(abs_path); +use Config (); +use File::Temp; +use Cwd (); +use File::Basename (); +use Data::Dumper (); +use Getopt::Long qw(:config gnu_getopt); + +my $v = 0; +sub cpan { + my $cmd = shift; + open my $in, '<', File::Spec->devnull + or die "can't open devnull: $!"; + my $pid = open3 $in, my $out, undef, $^X, '-MCPAN', '-e', "$cmd(\@ARGV)", @_; + my $output = ''; + while (my $line = <$out>) { + $output .= $line; + if ($v || $line =~ /^Running / || $line =~ / --( NOT)? OK$/) { + diag $line; + } + } + close $out; + waitpid $pid, 0; + my $status = $?; + return wantarray ? ($output, $status) : $output; +} + +my $prefs = do { + my $xt = sub { + my ($dist, $extra) = @_; + my $config = { + %$extra, + match => { + distribution => $dist, + env => { MOO_XT => 1 }, + }, + test => { + args => [ 'TEST_FILES=t/*.t xt/*.t' ], + }, + }; + return $config; + }; + { + 'Moo' => [ + { + match => { distribution => '\\bMoo-0\\.009001\\b' }, + patches => [ + 'Moo-isa-assign.patch', + 'Moo-sort-sub-quote.patch' + ], + }, + { + match => { distribution => '\\bMoo-0\\.00900[2-7]\\b' }, + patches => [ + 'Moo-sort-sub-quote.patch' + ], + }, + { + match => { distribution => '\\bMoo-0\\.009_?(00[8-9]|01[0-4])\\b' }, + }, + $xt->('\\bMoo-0\\.(009_?01[5-9]|091_?00[012])', { + depends => { + requires => { + 'MooX::Types::MooseLike::Base' => 0, + 'MooX::Types::MooseLike::Numeric' => 0, + 'Moose' => 0, + 'MooseX::Types::Common::Numeric' => 0 + } + }, + }), + $xt->('\\bMoo-0\\.091003', { + depends => { + requires => { + 'MooX::Types::MooseLike::Base' => 0, + 'MooX::Types::MooseLike::Numeric' => 0, + 'Moose' => 0, + 'MooseX::Types::Common::Numeric' => 0, + 'namespace::autoclean' => 0 + } + }, + }), + $xt->('\\bMoo-(0\\.091_?(00[4-9]|01[0-4])|1.00[012]|1.003000)', { + depends => { + requires => { + 'MooX::Types::MooseLike::Base' => 0, + 'MooX::Types::MooseLike::Numeric' => 0, + 'Moose' => 0, + 'MooseX::Types::Common::Numeric' => 0, + 'namespace::autoclean' => 0, + 'namespace::clean' => 0 + } + }, + }), + $xt->('\\bMoo-1.0', { + depends => { + requires => { + 'Moose' => 0, + 'MooseX::Types::Common::Numeric' => 0, + 'Mouse' => 0, + 'namespace::autoclean' => 0, + 'namespace::clean' => 0 + } + }, + }), + $xt->('\\bMoo-(1|2.00[0-3])', { + depends => { + requires => { + 'Class::Tiny' => 0, + 'Moose' => 0, + 'MooseX::Types::Common::Numeric' => 0, + 'Mouse' => 0, + 'Type::Tiny' => 0, + 'namespace::autoclean' => 0, + 'namespace::clean' => 0 + } + }, + }), + $xt->('\\bMoo-v?[0-9]', { + pl => { + env => { EXTENDED_TESTING => 1 }, + }, + }), + ], + 'Role-Tiny' => [ + { + match => { distribution => "\\bRole-Tiny-\\b" }, + install => { commandline => 'echo "skipped"' }, + }, + ], + }; +}; + +GetOptions( + 'verbose|v' => sub { $v++ }, + 'quiet|q' => sub { $v-- }, + 'doit' => \(my $doit = $ENV{EXTENDED_TESTING}), +) or die 'Bad parameters!'; + +$v = 0 + if $v < 0; + +my @dists = @ARGV; +if (!@dists && $doit) { + @dists = qw( + MSTROUT/Moo-0.009001.tar.gz + MSTROUT/Moo-0.091011.tar.gz + MSTROUT/Moo-1.000000.tar.gz + MSTROUT/Moo-1.000008.tar.gz + HAARG/Moo-1.007000.tar.gz + HAARG/Moo-2.000000.tar.gz + HAARG/Moo-2.001000.tar.gz + Moo + namespace::autoclean + Dancer2 + MooX::Options + MooX::ClassAttribute + ); +} + +plan skip_all => 'Set EXTENDED_TESTING to enable dependents testing' + if !@dists; + +plan tests => scalar @dists; + +my $path_sep = $Config::Config{path_sep}; +my $archname = $Config::Config{archname}; +my $version = $Config::Config{version}; + +my $temp_home = File::Temp::tempdir('Role-Tiny-XXXXXX', TMPDIR => 1, CLEANUP => 1); + +my $local_lib = "$temp_home/perl5"; +mkdir "$local_lib"; +mkdir "$local_lib/bin"; +mkdir "$local_lib/lib"; +mkdir "$local_lib/lib/perl5"; +mkdir "$local_lib/lib/perl5/$version"; +mkdir "$local_lib/lib/perl5/$version/$archname"; +mkdir "$local_lib/lib/perl5/$archname"; +mkdir "$local_lib/man"; +mkdir "$local_lib/man1"; +mkdir "$local_lib/man3"; + +my @extra_libs = do { + my @libs = `"$^X" -le"print for \@INC"`; + chomp @libs; + my %libs; @libs{@libs} = (); + map { Cwd::abs_path($_) } grep { !exists $libs{$_} } @INC; +}; + +my $cpan_home = "$temp_home/.cpan"; +mkdir $cpan_home; +mkdir "$cpan_home/CPAN"; +my $prefs_dir = "$cpan_home/prefs"; +mkdir $prefs_dir; + +my $patch_dir = Cwd::realpath(File::Basename::dirname(__FILE__) . '/dependents'); + +delete $ENV{HARNESS_PERL_SWITCHES}; +delete $ENV{AUTHOR_TESTING}; +delete $ENV{EXTENDED_TESTING}; +delete $ENV{RELEASE_TESTING}; +$ENV{NONINTERACTIVE_TESTING} = 1; +$ENV{PERL_MM_USE_DEFAULT} = 1; +$ENV{HOME} = $temp_home; +$ENV{PERL5LIB} = join $path_sep, "$local_lib/lib/perl5", @extra_libs, $ENV{PERL5LIB}||(); +$ENV{PERL_MM_OPT} = qq{INSTALL_BASE="$local_lib"}; +$ENV{PERL_MB_OPT} = qq{--install_base "$local_lib"}; +$ENV{PERL_LOCAL_LIB_ROOT} = join $path_sep, $local_lib, $ENV{PERL_LOCAL_LIB_ROOT}||(); + +my $config_file = "$cpan_home/CPAN/MyConfig.pm"; +{ + open my $fh, '>', $config_file + or die; + + my $config = do { + local $Data::Dumper::Terse = 0; + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Indent = 1; + Data::Dumper->Dump([{ + allow_installing_module_downgrades => 'yes', + allow_installing_outdated_dists => 'yes', + auto_commit => 0, + build_requires_install_policy => 'yes', + connect_to_internet_ok => 1, + cpan_home => $cpan_home, + inhibit_startup_message => 1, + prefs_dir => $prefs_dir, + patches_dir => $patch_dir, + prerequisites_policy => 'follow', + recommends_policy => 0, + suggests_policy => 0, + urllist => [ 'http://cpan.metacpan.org/' ], + use_sqlite => 0, + }], ['$CPAN::Config']); + }; + print { $fh } $config . "1;\n__END__\n"; + close $fh; +} + +cpan('CPAN::Shell->o', 'conf'); + +{ + + local $CPAN::Config; + require $config_file; + + my $yaml = $CPAN::Config->{yaml_module}; + if ($yaml) { + (my $mod = "$yaml.pm") =~ s{::}{/}g; + eval { require $mod } + or undef $yaml; + } + + for my $dist (keys %$prefs) { + my $prefs = $prefs->{$dist}; + + if ($yaml) { + open my $fh, '>', "$prefs_dir/$dist.yml"; + print { $fh } $yaml->can('Dump')->(@$prefs); + close $fh; + } + + local $Data::Dumper::Sortkeys = 1; + local $Data::Dumper::Indent = 1; + open my $fh, '>', "$prefs_dir/$dist.dd"; + print { $fh } Data::Dumper::Dumper(@$prefs); + close $fh; + } +} + +my $ext = qr{\.(?:t(?:ar\.)?(?:bz2|xz|gz)|tar|zip)}; +for my $dist (@dists) { + my $name = $dist; + $name =~ s{$ext$}{} + if $name =~ m{/}; + + note "Testing $dist ..."; + + local $ENV{MOO_XT} = $dist =~ /\bMoo\b/ ? '1' : '0'; + + my $prereq_output = cpan('notest', 'install', $dist); + + # in case Role::Tiny got installed somehow + unlink "$local_lib/lib/perl5/Role/Tiny.pm"; + unlink "$local_lib/lib/perl5/Role/Tiny/With.pm"; + + my $test_output = cpan('test', $dist); + + if ($dist !~ m{/}) { + $test_output =~ m{^Configuring (.)/(\1.)/(\2.*)$ext\s}m + and $name = "$3 (latest)"; + } + + my $passed = $test_output =~ /--\s*OK\s*\z/ && $test_output !~ /--\s*NOT\s+OK\s*\z/; + ok $passed, "$name passed tests"; + diag "$prereq_output$test_output" + if !$passed && !$v; +} + +done_testing; + +__DATA__ diff --git a/xt/dependents/Moo-isa-assign.patch b/xt/dependents/Moo-isa-assign.patch new file mode 100644 index 0000000..11f8b3c --- /dev/null +++ b/xt/dependents/Moo-isa-assign.patch @@ -0,0 +1,11 @@ +--- i/lib/Moo.pm ++++ w/lib/Moo.pm +@@ -15,7 +15,7 @@ sub import { + return if $MAKERS{$target}; # already exported into this package + *{_getglob("${target}::extends")} = sub { + _load_module($_) for @_; +- *{_getglob("${target}::ISA")} = \@_; ++ *{_getglob("${target}::ISA")} = [@_]; + }; + *{_getglob("${target}::with")} = sub { + require Moo::Role; diff --git a/xt/dependents/Moo-sort-sub-quote.patch b/xt/dependents/Moo-sort-sub-quote.patch new file mode 100644 index 0000000..02dfa65 --- /dev/null +++ b/xt/dependents/Moo-sort-sub-quote.patch @@ -0,0 +1,10 @@ +--- i/t/sub-quote.t ++++ w/t/sub-quote.t +@@ -21,7 +21,7 @@ ok(!keys %EVALED, 'Nothing evaled yet'); + my $u_one = unquote_sub $one; + + is_deeply( +- [ keys %EVALED ], [ qw(one two) ], ++ [ sort keys %EVALED ], [ qw(one two) ], + 'Both subs evaled' + ); diff --git a/xt/modifiers.t b/xt/modifiers.t new file mode 100644 index 0000000..653f876 --- /dev/null +++ b/xt/modifiers.t @@ -0,0 +1,79 @@ +use strict; +use warnings; +use Test::More; + +use Class::Method::Modifiers 1.05 (); + +BEGIN { + package MyRole; + + use Role::Tiny; + + around foo => sub { my $orig = shift; join ' ', 'role foo', $orig->(@_) }; +} + +BEGIN { + package ExtraRole; + + use Role::Tiny; +} + +BEGIN { + package MyClass; + + sub foo { 'class foo' } +} + +BEGIN { + package ExtraClass; + + use Role::Tiny::With; + + with qw(MyRole ExtraRole); + + sub foo { 'class foo' } +} + +BEGIN { + package BrokenRole; + use Role::Tiny; + + around 'broken modifier' => sub { my $orig = shift; $orig->(@_) }; +} + +BEGIN { + package MyRole2; + use Role::Tiny; + with 'MyRole'; +} + +BEGIN { + package ExtraClass2; + use Role::Tiny::With; + with 'MyRole2'; + sub foo { 'class foo' } +} + +sub try_apply_to { + my $to = shift; + eval { Role::Tiny->apply_role_to_package($to, 'MyRole'); 1 } + and return undef; + return $@ if $@; + die "false exception caught!"; +} + +is(try_apply_to('MyClass'), undef, 'role applies cleanly'); +is(MyClass->foo, 'role foo class foo', 'method modifier'); +is(ExtraClass->foo, 'role foo class foo', 'method modifier with composition'); + +is(ExtraClass2->foo, 'role foo class foo', + 'method modifier with role composed into role'); + +eval { + Role::Tiny->create_class_with_roles('MyClass', 'BrokenRole'); + 1; +} or $@ ||= 'false exception!'; +like $@, qr/broken modifier/, + 'exception caught creating class with broken modifier in a role'; + +done_testing; diff --git a/xt/recompose-modifier.t b/xt/recompose-modifier.t new file mode 100644 index 0000000..d03ded0 --- /dev/null +++ b/xt/recompose-modifier.t @@ -0,0 +1,82 @@ +use strict; +use warnings; +use Test::More; +{ + package ModifierRole; + use Role::Tiny; + + sub method { 0 } + around method => sub { + my $orig = shift; + my $self = shift; + $self->$orig(@_) + 1; + }; +} + +{ + package Role1; + use Role::Tiny; + + with 'ModifierRole'; +} + +{ + package Role2; + use Role::Tiny; + + with 'ModifierRole'; +} + +{ + package ComposingClass1; + use Role::Tiny::With; + + with qw(Role1 Role2); +} + +is +ComposingClass1->method, 1, 'recomposed modifier called once'; + +{ + package ComposingClass2; + use Role::Tiny::With; + + with 'Role1'; + with 'Role2'; +} + +is +ComposingClass2->method, 1, 'recomposed modifier called once (separately composed)'; + +{ + package DoubleRole; + + use Role::Tiny; + with qw(Role1 Role2); +} + +{ + package ComposingClass3; + use Role::Tiny::With; + + with 'DoubleRole'; +} + +is +ComposingClass3->method, 1, 'recomposed modifier called once (via composing role)'; + +{ + package DoubleRoleSeparate; + + use Role::Tiny; + with 'Role1'; + with 'Role2'; +} + +{ + package ComposingClass4; + use Role::Tiny::With; + + with qw(DoubleRoleSeparate); +} + +is +ComposingClass4->method, 1, 'recomposed modifier called once (via separately composing role)'; + +done_testing; -- 2.34.1