COPYRIGHT000664001750001750 1523414772476615 14647 0ustar00taitai000000000000Sub-HandlesVia-0.050002Format: http://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ Upstream-Name: Sub-HandlesVia Upstream-Contact: Toby Inkster (TOBYINK) Source: https://metacpan.org/release/Sub-HandlesVia Files: dist.ini t/00begin.t t/02moo.t t/02moo/ext_attr.t t/02moo/roles-multiple.t t/03moo_mxtt.t t/04moose.t t/04moose/ext_attr.t t/04moose/role.t t/04moose/roles-multiple.t t/04moose/trait_array.t t/04moose/trait_bool.t t/04moose/trait_code.t t/04moose/trait_counter.t t/04moose/trait_hash.t t/04moose/trait_number.t t/04moose/trait_string.t t/05moose_nativetypes/trait_array.t t/06mouse.t t/06mouse/ext_attr.t t/06mouse/roles-multiple.t t/06mouse/trait_hash.t t/10barebones_eagerbuilder.t t/11delegation.t t/14enum.t t/15preludes.t t/16stackqueue.t t/30egpod/array.t t/30egpod/bool.t t/30egpod/code.t t/30egpod/counter.t t/30egpod/hash.t t/30egpod/number.t t/30egpod/scalar.t t/30egpod/string.t t/40mite/array.t t/40mite/bool.t t/40mite/code.t t/40mite/counter.t t/40mite/hash.t t/40mite/lib/MyTest.pm t/40mite/lib/MyTest.pm.mite.pm t/40mite/lib/MyTest/Class1.pm t/40mite/lib/MyTest/Class1.pm.mite.pm t/40mite/lib/MyTest/Mite.pm t/40mite/lib/MyTest/Role1.pm t/40mite/lib/MyTest/Role1.pm.mite.pm t/40mite/lib/MyTest/Role2.pm t/40mite/lib/MyTest/Role2.pm.mite.pm t/40mite/lib/MyTest/TestClass/Array.pm t/40mite/lib/MyTest/TestClass/Array.pm.mite.pm t/40mite/lib/MyTest/TestClass/Bool.pm t/40mite/lib/MyTest/TestClass/Bool.pm.mite.pm t/40mite/lib/MyTest/TestClass/Code.pm t/40mite/lib/MyTest/TestClass/Code.pm.mite.pm t/40mite/lib/MyTest/TestClass/Counter.pm t/40mite/lib/MyTest/TestClass/Counter.pm.mite.pm t/40mite/lib/MyTest/TestClass/Hash.pm t/40mite/lib/MyTest/TestClass/Hash.pm.mite.pm t/40mite/lib/MyTest/TestClass/Number.pm t/40mite/lib/MyTest/TestClass/Number.pm.mite.pm t/40mite/lib/MyTest/TestClass/Scalar.pm t/40mite/lib/MyTest/TestClass/Scalar.pm.mite.pm t/40mite/lib/MyTest/TestClass/String.pm t/40mite/lib/MyTest/TestClass/String.pm.mite.pm t/40mite/number.t t/40mite/scalar.t t/40mite/string.t t/60detect.t t/61moosemetagubbins.t t/62mousemetagubbins.t t/94cmp.t t/96foreach.t Copyright: Copyright 2022 Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: t/02moo/role.t t/02moo/trait_array.t t/02moo/trait_bool.t t/02moo/trait_code.t t/02moo/trait_counter.t t/02moo/trait_hash.t t/02moo/trait_number.t t/02moo/trait_string.t t/03moo_mxtt/role.t t/03moo_mxtt/trait_array.t t/03moo_mxtt/trait_bool.t t/03moo_mxtt/trait_code.t t/03moo_mxtt/trait_counter.t t/03moo_mxtt/trait_hash.t t/03moo_mxtt/trait_number.t t/03moo_mxtt/trait_string.t t/05moose_nativetypes.t t/05moose_nativetypes/role.t t/05moose_nativetypes/trait_bool.t t/05moose_nativetypes/trait_code.t t/05moose_nativetypes/trait_counter.t t/05moose_nativetypes/trait_hash.t t/05moose_nativetypes/trait_number.t t/05moose_nativetypes/trait_string.t t/06mouse/role.t t/06mouse/trait_array.t t/06mouse/trait_bool.t t/06mouse/trait_code.t t/06mouse/trait_counter.t t/06mouse/trait_number.t t/06mouse/trait_string.t t/07mouse_nativetypes.t t/07mouse_nativetypes/role.t t/07mouse_nativetypes/trait_array.t t/07mouse_nativetypes/trait_bool.t t/07mouse_nativetypes/trait_code.t t/07mouse_nativetypes/trait_counter.t t/07mouse_nativetypes/trait_hash.t t/07mouse_nativetypes/trait_number.t t/07mouse_nativetypes/trait_string.t t/08classtiny.t t/09barebones.t t/12slotaccess.t t/95any.t t/97pickrandom.t t/98apply.t Copyright: Copyright 2020 Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: Changes META.json META.yml doap.ttl lib/Sub/HandlesVia/CodeGenerator.pm.mite.pm lib/Sub/HandlesVia/Handler.pm.mite.pm lib/Sub/HandlesVia/HandlerLibrary.pm lib/Sub/HandlesVia/HandlerLibrary/Array.pm lib/Sub/HandlesVia/HandlerLibrary/Bool.pm lib/Sub/HandlesVia/HandlerLibrary/Code.pm lib/Sub/HandlesVia/HandlerLibrary/Counter.pm lib/Sub/HandlesVia/HandlerLibrary/Hash.pm lib/Sub/HandlesVia/HandlerLibrary/Number.pm lib/Sub/HandlesVia/HandlerLibrary/Scalar.pm lib/Sub/HandlesVia/HandlerLibrary/String.pm lib/Sub/HandlesVia/Mite.pm lib/Sub/HandlesVia/Toolkit.pm.mite.pm lib/Sub/HandlesVia/Toolkit/Mite.pm lib/Sub/HandlesVia/Toolkit/Mite.pm.mite.pm lib/Sub/HandlesVia/Toolkit/Moo.pm lib/Sub/HandlesVia/Toolkit/Moo.pm.mite.pm lib/Sub/HandlesVia/Toolkit/Moose.pm lib/Sub/HandlesVia/Toolkit/Moose.pm.mite.pm lib/Sub/HandlesVia/Toolkit/Mouse.pm lib/Sub/HandlesVia/Toolkit/Mouse.pm.mite.pm lib/Sub/HandlesVia/Toolkit/ObjectPad.pm lib/Sub/HandlesVia/Toolkit/ObjectPad.pm.mite.pm lib/Sub/HandlesVia/Toolkit/Plain.pm lib/Sub/HandlesVia/Toolkit/Plain.pm.mite.pm t/50objectpad.t t/99headtail.t Copyright: Copyright 2025 Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: lib/Sub/HandlesVia/Declare.pm lib/Sub/HandlesVia/HandlerLibrary/Blessed.pm lib/Sub/HandlesVia/HandlerLibrary/Enum.pm lib/Sub/HandlesVia/Manual/Advanced.pod lib/Sub/HandlesVia/Manual/Comparison.pod lib/Sub/HandlesVia/Manual/WithClassTiny.pod lib/Sub/HandlesVia/Manual/WithGeneric.pod lib/Sub/HandlesVia/Manual/WithMite.pod lib/Sub/HandlesVia/Manual/WithMoo.pod lib/Sub/HandlesVia/Manual/WithMoose.pod lib/Sub/HandlesVia/Manual/WithMouse.pod lib/Sub/HandlesVia/Manual/WithObjectPad.pod t/20moosex_extended.t t/31egpod_dummy.t t/40mite/00-basic.t t/40mite/01-roles.t Copyright: This software is copyright (c) 2022 by Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: README lib/Sub/HandlesVia.pm lib/Sub/HandlesVia/CodeGenerator.pm lib/Sub/HandlesVia/Handler.pm lib/Sub/HandlesVia/HandlerLibrary/Array.pod lib/Sub/HandlesVia/HandlerLibrary/Bool.pod lib/Sub/HandlesVia/HandlerLibrary/Code.pod lib/Sub/HandlesVia/HandlerLibrary/Counter.pod lib/Sub/HandlesVia/HandlerLibrary/Hash.pod lib/Sub/HandlesVia/HandlerLibrary/Number.pod lib/Sub/HandlesVia/HandlerLibrary/Scalar.pod lib/Sub/HandlesVia/HandlerLibrary/String.pod lib/Sub/HandlesVia/Toolkit.pm Copyright: This software is copyright (c) 2020, 2022 by Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: INSTALL LICENSE Makefile.PL t/40mite/.mite/config Copyright: Unknown License: Unknown Files: COPYRIGHT CREDITS SIGNATURE Copyright: None License: public-domain Files: t/80beam.t t/81mxpa.t Copyright: Copyright 2023 Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: t/01basic.t Copyright: This software is copyright (c) 2020 by Toby Inkster. License: GPL-1.0+ or Artistic-1.0 License: Artistic-1.0 This software is Copyright (c) 2025 by the copyright holder(s). This is free software, licensed under: The Artistic License 1.0 License: GPL-1.0 This software is Copyright (c) 2025 by the copyright holder(s). This is free software, licensed under: The GNU General Public License, Version 1, February 1989 CREDITS000664001750001750 24014772476615 14323 0ustar00taitai000000000000Sub-HandlesVia-0.050002Maintainer: - Toby Inkster (TOBYINK) Thanks: - Bartosz Jarzyna (BRTASTIC) - Peter Mottram (SYSPETE) Changes000664001750001750 2422714772476615 14651 0ustar00taitai000000000000Sub-HandlesVia-0.050002Sub-HandlesVia ============== Created: 2020-01-18 Home page: Bug tracker: Maintainer: Toby Inkster (TOBYINK) 0.050002 2025-03-23 [ SECURITY ] - Fix: Rebuild using Mite 0.013000. 0.050001 2025-03-23 [ Documentation ] - Update documentation which is out of date due to Object::Pad dropping the `has` keyword. [ Other ] - Updated: Fix test cases which failed due to Object::Pad dropping the `has` keyword. - Updated: Fix test cases which will fail due to changed error messages in next release of Type::Tiny. 0.050000 2023-04-05 [ Documentation ] - Add a few missing references to the Sub::HandlesVia::HandlerLibrary::Enum module to the documentation. - Mention potential load-order bugs when importing multiple extensions for Moo into the same package. - Update Sub::HandlesVia::Manual::Comparison. [ Packaging ] - Change versioning scheme. 0.046 2022-12-16 - Added: Sub::HandlesVia::HandlerLibrary::Enum module. - Handler libraries can now provide constants for shortcuts. - Updated: Rebuild with latest Mite. 0.045 2022-11-08 [ Bug Fixes ] - Fix for `with qw(Role1 Role2)` in Moose where at least one role uses Sub::HandlesVia. Bartosz Jarzyna++ - Support attributes declared with `has '+name'`. Bartosz Jarzyna++ [ Documentation ] - Document that `with qw(Role1 Role2)` in Mouse is currently broken if either role uses Sub::HandlesVia. [ Test Suite ] - Test that `with qw(Role1 Role2)` in Moo works if either role uses Sub::HandlesVia. [ Other ] - Added: Add a `generator_for_prelude` attribute to Sub::HandlesVia::CodeGenerator. 0.044 2022-10-31 [ Documentation ] - Moved a lot of pod out of Sub::HandlesVia and into Sub::HandlesVia::Manual::*. 0.043 2022-10-31 - Added: Sub::HandlesVia::HandlerLibrary methods: handler_names, has_handler, and get_handler. - Added: Sub::HandlesVia::HandlerLibrary::Blessed. 0.042 2022-10-30 - Added: Sub::HandlesVia::Declare for compile-time declaration of Sub::HandlesVia delegations. - Improved support for Object::Pad, including support for non-scalar fields. 0.041 2022-10-29 - Added: Experimental support for Object::Pad. 0.040 2022-10-27 [ Bug Fixes ] - Stricter detection of Moo::Role roles to prevent some false positives when given Mouse::Role and Moose::Role roles. Bartosz Jarzyna++ [ Test Suite ] - Add a test using Sub::HandlesVia when Beam::Wire is loaded. Bartosz Jarzyna++ 0.039 2022-10-26 [ Bug Fixes ] - Fix application of Sub::HandlesVia Moose/Mouse traits to metaobjects that have other traits applied to them. Bartosz Jarzyna++ [ Test Suite ] - Mite has supported Perl 5.8.x for a while now, so Mite-related tests shouldn't be restricted to running on Perl 5.10.1+. 0.038 2022-10-21 [ Documentation ] - Minor changes to documentation for Hash:accessor and Array:accessor. 0.037 2022-09-26 [ Bug Fixes ] - Fix test case broken by Type::Tiny v2. Peter Mottram++ - Hash:set shouldn't hardcode use of Carp::croak. Instead a CodeGenerator should decide how to deal with error messages. 0.036 2022-08-26 [ Bug Fixes ] - Fix integration issues with newer versions of Mite. [ Documentation ] - Examples for a few methods. - More tests for a few methods. [ Other ] - Added: Add a delete_where method for hashes. - Added: Add execute_list, execute_scalar, execute_void, and corresponding _method variants for coderefs. - Added: The flatten_deep, natatime, and first_index methods for arrayrefs no longer use callbacks. 0.035 2022-08-12 - Sub::HandlesVia::CodeGenerator method_installer is now a rw attribute as Sub::Accessor::Small was relying on that. 0.034 2022-08-07 - Sub::HandlesVia::CodeGenerator now handles generating code for type assertions and coercions instead of relying on handlers to do it. - Sub::HandlesVia::CodeGenerator now has a configurable sandbox package. - Updated: Sub::HandlesVia::Toolkit::Mite supports recent Mite features such as lvalue accessors and new ways of specifying defaults. 0.033 2022-07-12 - Optimizations to Sub::HandlesVia::CodeGenerator. - Updated: Recompile with newer Mite. 0.032 2022-07-12 [ Packaging ] - Require newer version of Role::Hooks. 0.031 2022-07-09 [ Packaging ] - Add dependencies on MRO::Compat and Devel::GlobalDestruction, but only on very old Perls. 0.030 2022-07-09 [ Packaging ] - Drop dependency on Scope::Guard. 0.029 2022-07-09 [ Packaging ] - Use Mite internally, dropping the dependency on Class::Tiny. 0.028 2022-07-02 [ Test Suite ] - Lots more tests for using Sub::HandlesVia with Mite. [ Other ] - Updated: Support for Mite roles. 0.027 2022-06-30 [ Test Suite ] - Skip Mite test on Perl < 5.10.1 0.026 2022-06-30 - Added: Support classes built with Mite. 0.025 2022-06-16 - Internally shift off the method invocant sometimes as benchmarking shows that to be faster. 0.024 2022-06-15 [ Documentation ] - Explicitly document that Sub::HandlesVia needs to be imported AFTER Moo/Moose/Mouse so that it can detect the class/role builder being used. [ Test Suite ] - Test that Sub::HandlesVia works okay with MooseX::Extended. 0.023 2022-06-14 [ Documentation ] - Minor documentation improvements. [ Packaging ] - Changed minimum required Perl from 5.8.0 to 5.8.1. [ Other ] - Major Sub::HandlesVia::CodeGenerator cleanups. - Move some code from Sub::HandlesVia::Toolkit::Plain to its base class. - Removed: Sub::HandlesVia::CodeGenerator's simple_set concept has been removed; this was vestigial and had no effect. 0.022 2022-06-14 [ Documentation ] - Additional Array example: push and shift. - Document Sub::HandlesVia::Handler and Sub::HandlesVia::CodeGenerator. - Other documentation improvements. [ Other ] - Cleaned up Sub::HandlesVia::Handler and moved a lot of code into a new class Sub::HandlesVia::CodeGenerator, which replaces the big hash of callbacks which was passed around everywhere. 0.021 2022-06-12 [ Documentation ] - Provide extended examples in HandlerLibrary pod. [ Test Suite ] - Additional tests based on extended examples. 0.020 2022-06-11 [ Documentation ] - Improve and document the Sub::HandlesVia::HandlerLibrary::Scalar module. [ Test Suite ] - Additional tests based on pod examples. 0.019 2022-06-11 [ Documentation ] - Include more examples in pod for HandlerLibrary modules. 0.018 2022-06-11 [ Documentation ] - Generated pod for the HandlerLibrary modules. [ Other ] - Added: Sub::HandlesVia::Handler objects now have a `documentation` attribute. 0.017 2022-06-11 - Added: Case-insensitive versions of string comparison methods. - Added: Numeric comparison methods. - Added: String comparison methods. - Added: String match_i method. - Added: String starts_with, ends_with, and contains methods, plus case-insensitive versions of them. - Added: String uc, lc, and fc methods. 0.016 2020-09-20 [ Bug Fixes ] - Fix load order issue where handles_via is used in a Moo::Role when Moo.pm isn't loaded yet. 0.015 2020-09-12 - Added: `reset` method for Array. - Added: `reset` method for Hash. - Plain toolkit (used by non-Moo/Moose/Mouse classes) now supports defaults/builders. 0.014 2020-08-25 [ Bug Fixes ] - Fix compilation errors caused by value coercions under some circumstances. 0.013 2020-02-04 [ Test Suite ] - Skip Moo tests on very old Moo. 0.012 2020-02-02 - Added: Add missing methods from List::Util to Array. (These are mostly untested, but probably don't have bugs as they are simple non-mutator methods.) 0.011 2020-01-27 [ Documentation ] - Document which aliases MouseX::NativeTraits provides. [ Other ] - Added: `any` method for Array. 0.010 2020-01-27 - Added: `apply` method for Array. - Added: `for_each_key` method for Hash. - Added: `for_each_pair` method for Array. - Added: `for_each_pair` method for Hash. - Added: `for_each_value` method for Hash. - Added: `for_each` method for Array. - Added: `pick_random` method for Array. 0.009 2020-01-27 [ Test Suite ] - Revert MooX::TypeTiny test verbosity from 0.008_xxx. - Skip Array trait tests under Mouse if Mouse is not using XS due to Mouse::PurePerl bug. [ Packaging ] - Revert testing dependency additions from 0.008_xxx. 0.008_003 2020-01-27 [ Test Suite ] - Skip t/03moo_mxtt/trait_hash.t if Type::Tiny is not using XS. 0.008_002 2020-01-27 [ Test Suite ] - Spew even more output in t/03moo_mxtt/trait_hash.t. 0.008_001 2020-01-26 [ Test Suite ] - Load Carp::Always for failing test case. 0.008_000 2020-01-26 [ Test Suite ] - Spew some output in t/03moo_mxtt/trait_hash.t. [ Packaging ] - Require MooX::TypeTiny and Moo. 0.007 2020-01-25 Bond... James Bond [ Bug Fixes ] - Better handling for non-hashref-based Moose instances. [ Other ] - Added: `scalar_ref` method for Scalar. 0.006 2020-01-23 [ Test Suite ] - Output some version numbers and environment variables in test suite. 0.005 2020-01-23 [ Bug Fixes ] - Stop accidentally setting coerce=>'' for some Moo attributes. It confuses Moo. [ Other ] - Added: `head` method for Array. - Added: `tail` method for Array. 0.004 2020-01-22 - Support for Moo::Role, Moose::Role, and Mouse::Role. 0.003 2020-01-21 [ Documentation ] - Document API for how Sub::HandlesVia interacts with OO frameworks. [ Other ] - A lot of refactoring, reducing duplication in Moo, Moose, and Mouse integration. 0.002 2020-01-21 [ Documentation ] - Fix some typos. - Remove some outdated information. [ Packaging ] - Add missing dependency on Class::Tiny. [ Other ] - Drop dependency on List::MoreUtils by including our own copies of `natatime` and `firstidx`. 0.001 2020-01-21 Initial release INSTALL000664001750001750 170414772476615 14362 0ustar00taitai000000000000Sub-HandlesVia-0.050002 Installing Sub-HandlesVia should be straightforward. INSTALLATION WITH CPANMINUS If you have cpanm, you only need one line: % cpanm Sub::HandlesVia If you are installing into a system-wide directory, you may need to pass the "-S" flag to cpanm, which uses sudo to install the module: % cpanm -S Sub::HandlesVia INSTALLATION WITH THE CPAN SHELL Alternatively, if your CPAN shell is set up, you should just be able to do: % cpan Sub::HandlesVia MANUAL INSTALLATION As a last resort, you can manually install it. Download the tarball and unpack it. Consult the file META.json for a list of pre-requisites. Install these first. To build Sub-HandlesVia: % perl Makefile.PL % make && make test Then install it: % make install If you are installing into a system-wide directory, you may need to run: % sudo make install LICENSE000664001750001750 4642714772476615 14371 0ustar00taitai000000000000Sub-HandlesVia-0.050002This software is copyright (c) 2025 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. 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) 2025 by Toby Inkster. 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 Perl Artistic License 1.0 --- This software is Copyright (c) 2025 by Toby Inkster. This is free software, licensed under: The Perl 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 as specified below. "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 uunet.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) give non-standard executables non-standard names, and clearly document 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. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 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 whoever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End MANIFEST000664001750001750 1232714772476615 14505 0ustar00taitai000000000000Sub-HandlesVia-0.050002COPYRIGHT CREDITS Changes INSTALL LICENSE MANIFEST META.json META.yml Makefile.PL README SIGNATURE dist.ini doap.ttl lib/Sub/HandlesVia.pm lib/Sub/HandlesVia/CodeGenerator.pm lib/Sub/HandlesVia/CodeGenerator.pm.mite.pm lib/Sub/HandlesVia/Declare.pm lib/Sub/HandlesVia/Handler.pm lib/Sub/HandlesVia/Handler.pm.mite.pm lib/Sub/HandlesVia/HandlerLibrary.pm lib/Sub/HandlesVia/HandlerLibrary/Array.pm lib/Sub/HandlesVia/HandlerLibrary/Array.pod lib/Sub/HandlesVia/HandlerLibrary/Blessed.pm lib/Sub/HandlesVia/HandlerLibrary/Bool.pm lib/Sub/HandlesVia/HandlerLibrary/Bool.pod lib/Sub/HandlesVia/HandlerLibrary/Code.pm lib/Sub/HandlesVia/HandlerLibrary/Code.pod lib/Sub/HandlesVia/HandlerLibrary/Counter.pm lib/Sub/HandlesVia/HandlerLibrary/Counter.pod lib/Sub/HandlesVia/HandlerLibrary/Enum.pm lib/Sub/HandlesVia/HandlerLibrary/Hash.pm lib/Sub/HandlesVia/HandlerLibrary/Hash.pod lib/Sub/HandlesVia/HandlerLibrary/Number.pm lib/Sub/HandlesVia/HandlerLibrary/Number.pod lib/Sub/HandlesVia/HandlerLibrary/Scalar.pm lib/Sub/HandlesVia/HandlerLibrary/Scalar.pod lib/Sub/HandlesVia/HandlerLibrary/String.pm lib/Sub/HandlesVia/HandlerLibrary/String.pod lib/Sub/HandlesVia/Manual/Advanced.pod lib/Sub/HandlesVia/Manual/Comparison.pod lib/Sub/HandlesVia/Manual/WithClassTiny.pod lib/Sub/HandlesVia/Manual/WithGeneric.pod lib/Sub/HandlesVia/Manual/WithMite.pod lib/Sub/HandlesVia/Manual/WithMoo.pod lib/Sub/HandlesVia/Manual/WithMoose.pod lib/Sub/HandlesVia/Manual/WithMouse.pod lib/Sub/HandlesVia/Manual/WithObjectPad.pod lib/Sub/HandlesVia/Mite.pm lib/Sub/HandlesVia/Toolkit.pm lib/Sub/HandlesVia/Toolkit.pm.mite.pm lib/Sub/HandlesVia/Toolkit/Mite.pm lib/Sub/HandlesVia/Toolkit/Mite.pm.mite.pm lib/Sub/HandlesVia/Toolkit/Moo.pm lib/Sub/HandlesVia/Toolkit/Moo.pm.mite.pm lib/Sub/HandlesVia/Toolkit/Moose.pm lib/Sub/HandlesVia/Toolkit/Moose.pm.mite.pm lib/Sub/HandlesVia/Toolkit/Mouse.pm lib/Sub/HandlesVia/Toolkit/Mouse.pm.mite.pm lib/Sub/HandlesVia/Toolkit/ObjectPad.pm lib/Sub/HandlesVia/Toolkit/ObjectPad.pm.mite.pm lib/Sub/HandlesVia/Toolkit/Plain.pm lib/Sub/HandlesVia/Toolkit/Plain.pm.mite.pm t/00begin.t t/01basic.t t/02moo.t t/02moo/ext_attr.t t/02moo/role.t t/02moo/roles-multiple.t t/02moo/trait_array.t t/02moo/trait_bool.t t/02moo/trait_code.t t/02moo/trait_counter.t t/02moo/trait_hash.t t/02moo/trait_number.t t/02moo/trait_string.t t/03moo_mxtt.t t/03moo_mxtt/role.t t/03moo_mxtt/trait_array.t t/03moo_mxtt/trait_bool.t t/03moo_mxtt/trait_code.t t/03moo_mxtt/trait_counter.t t/03moo_mxtt/trait_hash.t t/03moo_mxtt/trait_number.t t/03moo_mxtt/trait_string.t t/04moose.t t/04moose/ext_attr.t t/04moose/role.t t/04moose/roles-multiple.t t/04moose/trait_array.t t/04moose/trait_bool.t t/04moose/trait_code.t t/04moose/trait_counter.t t/04moose/trait_hash.t t/04moose/trait_number.t t/04moose/trait_string.t t/05moose_nativetypes.t t/05moose_nativetypes/role.t t/05moose_nativetypes/trait_array.t t/05moose_nativetypes/trait_bool.t t/05moose_nativetypes/trait_code.t t/05moose_nativetypes/trait_counter.t t/05moose_nativetypes/trait_hash.t t/05moose_nativetypes/trait_number.t t/05moose_nativetypes/trait_string.t t/06mouse.t t/06mouse/ext_attr.t t/06mouse/role.t t/06mouse/roles-multiple.t t/06mouse/trait_array.t t/06mouse/trait_bool.t t/06mouse/trait_code.t t/06mouse/trait_counter.t t/06mouse/trait_hash.t t/06mouse/trait_number.t t/06mouse/trait_string.t t/07mouse_nativetypes.t t/07mouse_nativetypes/role.t t/07mouse_nativetypes/trait_array.t t/07mouse_nativetypes/trait_bool.t t/07mouse_nativetypes/trait_code.t t/07mouse_nativetypes/trait_counter.t t/07mouse_nativetypes/trait_hash.t t/07mouse_nativetypes/trait_number.t t/07mouse_nativetypes/trait_string.t t/08classtiny.t t/09barebones.t t/10barebones_eagerbuilder.t t/11delegation.t t/12slotaccess.t t/14enum.t t/15preludes.t t/16stackqueue.t t/20moosex_extended.t t/30egpod/array.t t/30egpod/bool.t t/30egpod/code.t t/30egpod/counter.t t/30egpod/hash.t t/30egpod/number.t t/30egpod/scalar.t t/30egpod/string.t t/31egpod_dummy.t t/40mite/.mite/config t/40mite/00-basic.t t/40mite/01-roles.t t/40mite/array.t t/40mite/bool.t t/40mite/code.t t/40mite/counter.t t/40mite/hash.t t/40mite/lib/MyTest.pm t/40mite/lib/MyTest.pm.mite.pm t/40mite/lib/MyTest/Class1.pm t/40mite/lib/MyTest/Class1.pm.mite.pm t/40mite/lib/MyTest/Mite.pm t/40mite/lib/MyTest/Role1.pm t/40mite/lib/MyTest/Role1.pm.mite.pm t/40mite/lib/MyTest/Role2.pm t/40mite/lib/MyTest/Role2.pm.mite.pm t/40mite/lib/MyTest/TestClass/Array.pm t/40mite/lib/MyTest/TestClass/Array.pm.mite.pm t/40mite/lib/MyTest/TestClass/Bool.pm t/40mite/lib/MyTest/TestClass/Bool.pm.mite.pm t/40mite/lib/MyTest/TestClass/Code.pm t/40mite/lib/MyTest/TestClass/Code.pm.mite.pm t/40mite/lib/MyTest/TestClass/Counter.pm t/40mite/lib/MyTest/TestClass/Counter.pm.mite.pm t/40mite/lib/MyTest/TestClass/Hash.pm t/40mite/lib/MyTest/TestClass/Hash.pm.mite.pm t/40mite/lib/MyTest/TestClass/Number.pm t/40mite/lib/MyTest/TestClass/Number.pm.mite.pm t/40mite/lib/MyTest/TestClass/Scalar.pm t/40mite/lib/MyTest/TestClass/Scalar.pm.mite.pm t/40mite/lib/MyTest/TestClass/String.pm t/40mite/lib/MyTest/TestClass/String.pm.mite.pm t/40mite/number.t t/40mite/scalar.t t/40mite/string.t t/50objectpad.t t/60detect.t t/61moosemetagubbins.t t/62mousemetagubbins.t t/80beam.t t/81mxpa.t t/94cmp.t t/95any.t t/96foreach.t t/97pickrandom.t t/98apply.t t/99headtail.t META.json000664001750001750 1475014772476615 14777 0ustar00taitai000000000000Sub-HandlesVia-0.050002{ "abstract" : "alternative handles_via implementation", "author" : [ "Toby Inkster (TOBYINK) " ], "dynamic_config" : 1, "generated_by" : "Dist::Inkt::Profile::TOBYINK version 0.024, CPAN::Meta::Converter version 2.150010", "keywords" : [], "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Sub-HandlesVia", "no_index" : { "directory" : [ "eg", "examples", "inc", "t", "xt" ] }, "optional_features" : {}, "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.17" } }, "develop" : { "recommends" : { "Dist::Inkt" : "0.001" }, "requires" : { "Mite" : "0.006001" } }, "runtime" : { "recommends" : { "Sub::Util" : "0" }, "requires" : { "Class::Method::Modifiers" : "0", "Exporter::Shiny" : "0", "List::Util" : "1.54", "Role::Hooks" : "0.008", "Role::Tiny" : "0", "Type::Tiny" : "1.004", "perl" : "5.008001" } }, "test" : { "recommends" : { "Class::Tiny" : "0", "Moo" : "0", "MooX::TypeTiny" : "0", "Moose" : "0", "MooseX::Extended" : "0.22", "Mouse" : "0", "Object::Pad" : "0.70" }, "requires" : { "Test::Fatal" : "0", "Test::More" : "0.96", "Test::Requires" : "0", "Try::Tiny" : "0" } } }, "provides" : { "Sub::HandlesVia" : { "file" : "lib/Sub/HandlesVia.pm", "version" : "0.050002" }, "Sub::HandlesVia::CodeGenerator" : { "file" : "lib/Sub/HandlesVia/CodeGenerator.pm", "version" : "0.050002" }, "Sub::HandlesVia::Declare" : { "file" : "lib/Sub/HandlesVia/Declare.pm", "version" : "0.050002" }, "Sub::HandlesVia::Handler" : { "file" : "lib/Sub/HandlesVia/Handler.pm", "version" : "0.050002" }, "Sub::HandlesVia::Handler::CodeRef" : { "file" : "lib/Sub/HandlesVia/Handler.pm", "version" : "0.050002" }, "Sub::HandlesVia::Handler::Traditional" : { "file" : "lib/Sub/HandlesVia/Handler.pm", "version" : "0.050002" }, "Sub::HandlesVia::HandlerLibrary" : { "file" : "lib/Sub/HandlesVia/HandlerLibrary.pm", "version" : "0.050002" }, "Sub::HandlesVia::HandlerLibrary::Array" : { "file" : "lib/Sub/HandlesVia/HandlerLibrary/Array.pm", "version" : "0.050002" }, "Sub::HandlesVia::HandlerLibrary::Blessed" : { "file" : "lib/Sub/HandlesVia/HandlerLibrary/Blessed.pm", "version" : "0.050002" }, "Sub::HandlesVia::HandlerLibrary::Bool" : { "file" : "lib/Sub/HandlesVia/HandlerLibrary/Bool.pm", "version" : "0.050002" }, "Sub::HandlesVia::HandlerLibrary::Code" : { "file" : "lib/Sub/HandlesVia/HandlerLibrary/Code.pm", "version" : "0.050002" }, "Sub::HandlesVia::HandlerLibrary::Counter" : { "file" : "lib/Sub/HandlesVia/HandlerLibrary/Counter.pm", "version" : "0.050002" }, "Sub::HandlesVia::HandlerLibrary::Enum" : { "file" : "lib/Sub/HandlesVia/HandlerLibrary/Enum.pm", "version" : "0.050002" }, "Sub::HandlesVia::HandlerLibrary::Hash" : { "file" : "lib/Sub/HandlesVia/HandlerLibrary/Hash.pm", "version" : "0.050002" }, "Sub::HandlesVia::HandlerLibrary::Number" : { "file" : "lib/Sub/HandlesVia/HandlerLibrary/Number.pm", "version" : "0.050002" }, "Sub::HandlesVia::HandlerLibrary::Scalar" : { "file" : "lib/Sub/HandlesVia/HandlerLibrary/Scalar.pm", "version" : "0.050002" }, "Sub::HandlesVia::HandlerLibrary::String" : { "file" : "lib/Sub/HandlesVia/HandlerLibrary/String.pm", "version" : "0.050002" }, "Sub::HandlesVia::Mite" : { "file" : "lib/Sub/HandlesVia/Mite.pm" }, "Sub::HandlesVia::Toolkit" : { "file" : "lib/Sub/HandlesVia/Toolkit.pm", "version" : "0.050002" }, "Sub::HandlesVia::Toolkit::Mite" : { "file" : "lib/Sub/HandlesVia/Toolkit/Mite.pm", "version" : "0.050002" }, "Sub::HandlesVia::Toolkit::Moo" : { "file" : "lib/Sub/HandlesVia/Toolkit/Moo.pm", "version" : "0.050002" }, "Sub::HandlesVia::Toolkit::Moose" : { "file" : "lib/Sub/HandlesVia/Toolkit/Moose.pm", "version" : "0.050002" }, "Sub::HandlesVia::Toolkit::Moose::PackageTrait" : { "file" : "lib/Sub/HandlesVia/Toolkit/Moose.pm", "version" : "0.050002" }, "Sub::HandlesVia::Toolkit::Moose::RoleTrait" : { "file" : "lib/Sub/HandlesVia/Toolkit/Moose.pm", "version" : "0.050002" }, "Sub::HandlesVia::Toolkit::Mouse" : { "file" : "lib/Sub/HandlesVia/Toolkit/Mouse.pm", "version" : "0.050002" }, "Sub::HandlesVia::Toolkit::Mouse::PackageTrait" : { "file" : "lib/Sub/HandlesVia/Toolkit/Mouse.pm", "version" : "0.050002" }, "Sub::HandlesVia::Toolkit::Mouse::RoleTrait" : { "file" : "lib/Sub/HandlesVia/Toolkit/Mouse.pm", "version" : "0.050002" }, "Sub::HandlesVia::Toolkit::ObjectPad" : { "file" : "lib/Sub/HandlesVia/Toolkit/ObjectPad.pm", "version" : "0.050002" }, "Sub::HandlesVia::Toolkit::Plain" : { "file" : "lib/Sub/HandlesVia/Toolkit/Plain.pm", "version" : "0.050002" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/tobyink/p5-sub-handlesvia/issues" }, "homepage" : "https://metacpan.org/release/Sub-HandlesVia", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "git://github.com/tobyink/p5-sub-handlesvia.git", "web" : "https://github.com/tobyink/p5-sub-handlesvia" }, "x_identifier" : "http://purl.org/NET/cpan-uri/dist/Sub-HandlesVia/project" }, "version" : "0.050002", "x_serialization_backend" : "JSON::PP version 4.16" } META.yml000664001750001750 1034614772476615 14624 0ustar00taitai000000000000Sub-HandlesVia-0.050002--- abstract: 'alternative handles_via implementation' author: - 'Toby Inkster (TOBYINK) ' build_requires: Test::Fatal: '0' Test::More: '0.96' Test::Requires: '0' Try::Tiny: '0' configure_requires: ExtUtils::MakeMaker: '6.17' dynamic_config: 1 generated_by: 'Dist::Inkt::Profile::TOBYINK version 0.024, CPAN::Meta::Converter version 2.150010' keywords: [] license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Sub-HandlesVia no_index: directory: - eg - examples - inc - t - xt optional_features: {} provides: Sub::HandlesVia: file: lib/Sub/HandlesVia.pm version: '0.050002' Sub::HandlesVia::CodeGenerator: file: lib/Sub/HandlesVia/CodeGenerator.pm version: '0.050002' Sub::HandlesVia::Declare: file: lib/Sub/HandlesVia/Declare.pm version: '0.050002' Sub::HandlesVia::Handler: file: lib/Sub/HandlesVia/Handler.pm version: '0.050002' Sub::HandlesVia::Handler::CodeRef: file: lib/Sub/HandlesVia/Handler.pm version: '0.050002' Sub::HandlesVia::Handler::Traditional: file: lib/Sub/HandlesVia/Handler.pm version: '0.050002' Sub::HandlesVia::HandlerLibrary: file: lib/Sub/HandlesVia/HandlerLibrary.pm version: '0.050002' Sub::HandlesVia::HandlerLibrary::Array: file: lib/Sub/HandlesVia/HandlerLibrary/Array.pm version: '0.050002' Sub::HandlesVia::HandlerLibrary::Blessed: file: lib/Sub/HandlesVia/HandlerLibrary/Blessed.pm version: '0.050002' Sub::HandlesVia::HandlerLibrary::Bool: file: lib/Sub/HandlesVia/HandlerLibrary/Bool.pm version: '0.050002' Sub::HandlesVia::HandlerLibrary::Code: file: lib/Sub/HandlesVia/HandlerLibrary/Code.pm version: '0.050002' Sub::HandlesVia::HandlerLibrary::Counter: file: lib/Sub/HandlesVia/HandlerLibrary/Counter.pm version: '0.050002' Sub::HandlesVia::HandlerLibrary::Enum: file: lib/Sub/HandlesVia/HandlerLibrary/Enum.pm version: '0.050002' Sub::HandlesVia::HandlerLibrary::Hash: file: lib/Sub/HandlesVia/HandlerLibrary/Hash.pm version: '0.050002' Sub::HandlesVia::HandlerLibrary::Number: file: lib/Sub/HandlesVia/HandlerLibrary/Number.pm version: '0.050002' Sub::HandlesVia::HandlerLibrary::Scalar: file: lib/Sub/HandlesVia/HandlerLibrary/Scalar.pm version: '0.050002' Sub::HandlesVia::HandlerLibrary::String: file: lib/Sub/HandlesVia/HandlerLibrary/String.pm version: '0.050002' Sub::HandlesVia::Mite: file: lib/Sub/HandlesVia/Mite.pm Sub::HandlesVia::Toolkit: file: lib/Sub/HandlesVia/Toolkit.pm version: '0.050002' Sub::HandlesVia::Toolkit::Mite: file: lib/Sub/HandlesVia/Toolkit/Mite.pm version: '0.050002' Sub::HandlesVia::Toolkit::Moo: file: lib/Sub/HandlesVia/Toolkit/Moo.pm version: '0.050002' Sub::HandlesVia::Toolkit::Moose: file: lib/Sub/HandlesVia/Toolkit/Moose.pm version: '0.050002' Sub::HandlesVia::Toolkit::Moose::PackageTrait: file: lib/Sub/HandlesVia/Toolkit/Moose.pm version: '0.050002' Sub::HandlesVia::Toolkit::Moose::RoleTrait: file: lib/Sub/HandlesVia/Toolkit/Moose.pm version: '0.050002' Sub::HandlesVia::Toolkit::Mouse: file: lib/Sub/HandlesVia/Toolkit/Mouse.pm version: '0.050002' Sub::HandlesVia::Toolkit::Mouse::PackageTrait: file: lib/Sub/HandlesVia/Toolkit/Mouse.pm version: '0.050002' Sub::HandlesVia::Toolkit::Mouse::RoleTrait: file: lib/Sub/HandlesVia/Toolkit/Mouse.pm version: '0.050002' Sub::HandlesVia::Toolkit::ObjectPad: file: lib/Sub/HandlesVia/Toolkit/ObjectPad.pm version: '0.050002' Sub::HandlesVia::Toolkit::Plain: file: lib/Sub/HandlesVia/Toolkit/Plain.pm version: '0.050002' recommends: Sub::Util: '0' requires: Class::Method::Modifiers: '0' Exporter::Shiny: '0' List::Util: '1.54' Role::Hooks: '0.008' Role::Tiny: '0' Type::Tiny: '1.004' perl: '5.008001' resources: Identifier: http://purl.org/NET/cpan-uri/dist/Sub-HandlesVia/project bugtracker: https://github.com/tobyink/p5-sub-handlesvia/issues homepage: https://metacpan.org/release/Sub-HandlesVia license: http://dev.perl.org/licenses/ repository: git://github.com/tobyink/p5-sub-handlesvia.git version: '0.050002' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Makefile.PL000664001750001750 3147714772476615 15335 0ustar00taitai000000000000Sub-HandlesVia-0.050002use strict; use ExtUtils::MakeMaker 6.17; my $EUMM = eval( $ExtUtils::MakeMaker::VERSION ); my $meta = { "abstract" => "alternative handles_via implementation", "author" => ["Toby Inkster (TOBYINK) "], "dynamic_config" => 1, "generated_by" => "Dist::Inkt::Profile::TOBYINK version 0.024, CPAN::Meta::Converter version 2.150010", "keywords" => [], "license" => ["perl_5"], "meta-spec" => { url => "http://search.cpan.org/perldoc?CPAN::Meta::Spec", version => 2, }, "name" => "Sub-HandlesVia", "no_index" => { directory => ["eg", "examples", "inc", "t", "xt"] }, "prereqs" => { configure => { requires => { "ExtUtils::MakeMaker" => 6.17 } }, develop => { recommends => { "Dist::Inkt" => 0.001 }, requires => { Mite => 0.006001 }, }, runtime => { recommends => { "Sub::Util" => 0 }, requires => { "Class::Method::Modifiers" => 0, "Exporter::Shiny" => 0, "List::Util" => 1.54, "perl" => 5.008001, "Role::Hooks" => 0.008, "Role::Tiny" => 0, "Type::Tiny" => 1.004, }, }, test => { recommends => { "Class::Tiny" => 0, "Moo" => 0, "Moose" => 0, "MooseX::Extended" => 0.22, "MooX::TypeTiny" => 0, "Mouse" => 0, "Object::Pad" => "0.70", }, requires => { "Test::Fatal" => 0, "Test::More" => 0.96, "Test::Requires" => 0, "Try::Tiny" => 0, }, }, }, "provides" => { "Sub::HandlesVia" => { file => "lib/Sub/HandlesVia.pm", version => 0.050002 }, "Sub::HandlesVia::CodeGenerator" => { file => "lib/Sub/HandlesVia/CodeGenerator.pm", version => 0.050002 }, "Sub::HandlesVia::Declare" => { file => "lib/Sub/HandlesVia/Declare.pm", version => 0.050002 }, "Sub::HandlesVia::Handler" => { file => "lib/Sub/HandlesVia/Handler.pm", version => 0.050002 }, "Sub::HandlesVia::Handler::CodeRef" => { file => "lib/Sub/HandlesVia/Handler.pm", version => 0.050002 }, "Sub::HandlesVia::Handler::Traditional" => { file => "lib/Sub/HandlesVia/Handler.pm", version => 0.050002 }, "Sub::HandlesVia::HandlerLibrary" => { file => "lib/Sub/HandlesVia/HandlerLibrary.pm", version => 0.050002 }, "Sub::HandlesVia::HandlerLibrary::Array" => { file => "lib/Sub/HandlesVia/HandlerLibrary/Array.pm", version => 0.050002, }, "Sub::HandlesVia::HandlerLibrary::Blessed" => { file => "lib/Sub/HandlesVia/HandlerLibrary/Blessed.pm", version => 0.050002, }, "Sub::HandlesVia::HandlerLibrary::Bool" => { file => "lib/Sub/HandlesVia/HandlerLibrary/Bool.pm", version => 0.050002, }, "Sub::HandlesVia::HandlerLibrary::Code" => { file => "lib/Sub/HandlesVia/HandlerLibrary/Code.pm", version => 0.050002, }, "Sub::HandlesVia::HandlerLibrary::Counter" => { file => "lib/Sub/HandlesVia/HandlerLibrary/Counter.pm", version => 0.050002, }, "Sub::HandlesVia::HandlerLibrary::Enum" => { file => "lib/Sub/HandlesVia/HandlerLibrary/Enum.pm", version => 0.050002, }, "Sub::HandlesVia::HandlerLibrary::Hash" => { file => "lib/Sub/HandlesVia/HandlerLibrary/Hash.pm", version => 0.050002, }, "Sub::HandlesVia::HandlerLibrary::Number" => { file => "lib/Sub/HandlesVia/HandlerLibrary/Number.pm", version => 0.050002, }, "Sub::HandlesVia::HandlerLibrary::Scalar" => { file => "lib/Sub/HandlesVia/HandlerLibrary/Scalar.pm", version => 0.050002, }, "Sub::HandlesVia::HandlerLibrary::String" => { file => "lib/Sub/HandlesVia/HandlerLibrary/String.pm", version => 0.050002, }, "Sub::HandlesVia::Mite" => { file => "lib/Sub/HandlesVia/Mite.pm" }, "Sub::HandlesVia::Toolkit" => { file => "lib/Sub/HandlesVia/Toolkit.pm", version => 0.050002 }, "Sub::HandlesVia::Toolkit::Mite" => { file => "lib/Sub/HandlesVia/Toolkit/Mite.pm", version => 0.050002 }, "Sub::HandlesVia::Toolkit::Moo" => { file => "lib/Sub/HandlesVia/Toolkit/Moo.pm", version => 0.050002 }, "Sub::HandlesVia::Toolkit::Moose" => { file => "lib/Sub/HandlesVia/Toolkit/Moose.pm", version => 0.050002 }, "Sub::HandlesVia::Toolkit::Moose::PackageTrait" => { file => "lib/Sub/HandlesVia/Toolkit/Moose.pm", version => 0.050002 }, "Sub::HandlesVia::Toolkit::Moose::RoleTrait" => { file => "lib/Sub/HandlesVia/Toolkit/Moose.pm", version => 0.050002 }, "Sub::HandlesVia::Toolkit::Mouse" => { file => "lib/Sub/HandlesVia/Toolkit/Mouse.pm", version => 0.050002 }, "Sub::HandlesVia::Toolkit::Mouse::PackageTrait" => { file => "lib/Sub/HandlesVia/Toolkit/Mouse.pm", version => 0.050002 }, "Sub::HandlesVia::Toolkit::Mouse::RoleTrait" => { file => "lib/Sub/HandlesVia/Toolkit/Mouse.pm", version => 0.050002 }, "Sub::HandlesVia::Toolkit::ObjectPad" => { file => "lib/Sub/HandlesVia/Toolkit/ObjectPad.pm", version => 0.050002, }, "Sub::HandlesVia::Toolkit::Plain" => { file => "lib/Sub/HandlesVia/Toolkit/Plain.pm", version => 0.050002 }, }, "release_status" => "stable", "resources" => { bugtracker => { web => "https://github.com/tobyink/p5-sub-handlesvia/issues" }, homepage => "https://metacpan.org/release/Sub-HandlesVia", license => ["http://dev.perl.org/licenses/"], repository => { type => "git", url => "git://github.com/tobyink/p5-sub-handlesvia.git", web => "https://github.com/tobyink/p5-sub-handlesvia", }, x_identifier => "http://purl.org/NET/cpan-uri/dist/Sub-HandlesVia/project", }, "version" => 0.050002, }; my %dynamic_config; do { if ($] lt 5.010000) { $meta->{prereqs}{runtime}{requires}{'MRO::Compat'} = 0; } if ($] lt 5.014000) { $meta->{prereqs}{runtime}{requires}{'Devel::GlobalDestruction'} = 0; } }; my %WriteMakefileArgs = ( ABSTRACT => $meta->{abstract}, AUTHOR => ($EUMM >= 6.5702 ? $meta->{author} : $meta->{author}[0]), DISTNAME => $meta->{name}, VERSION => $meta->{version}, EXE_FILES => [ map $_->{file}, values %{ $meta->{x_provides_scripts} || {} } ], NAME => do { my $n = $meta->{name}; $n =~ s/-/::/g; $n }, test => { TESTS => "t/*.t t/02moo/*.t t/03moo_mxtt/*.t t/04moose/*.t t/05moose_nativetypes/*.t t/06mouse/*.t t/07mouse_nativetypes/*.t t/30egpod/*.t t/40mite/*.t" }, %dynamic_config, ); $WriteMakefileArgs{LICENSE} = $meta->{license}[0] if $EUMM >= 6.3001; sub deps { my %r; for my $stage (@_) { for my $dep (keys %{$meta->{prereqs}{$stage}{requires}}) { next if $dep eq 'perl'; my $ver = $meta->{prereqs}{$stage}{requires}{$dep}; $r{$dep} = $ver if !exists($r{$dep}) || $ver >= $r{$dep}; } } \%r; } my ($build_requires, $configure_requires, $runtime_requires, $test_requires); if ($EUMM >= 6.6303) { $WriteMakefileArgs{BUILD_REQUIRES} ||= deps('build'); $WriteMakefileArgs{CONFIGURE_REQUIRES} ||= deps('configure'); $WriteMakefileArgs{TEST_REQUIRES} ||= deps('test'); $WriteMakefileArgs{PREREQ_PM} ||= deps('runtime'); } elsif ($EUMM >= 6.5503) { $WriteMakefileArgs{BUILD_REQUIRES} ||= deps('build', 'test'); $WriteMakefileArgs{CONFIGURE_REQUIRES} ||= deps('configure'); $WriteMakefileArgs{PREREQ_PM} ||= deps('runtime'); } elsif ($EUMM >= 6.52) { $WriteMakefileArgs{CONFIGURE_REQUIRES} ||= deps('configure'); $WriteMakefileArgs{PREREQ_PM} ||= deps('runtime', 'build', 'test'); } else { $WriteMakefileArgs{PREREQ_PM} ||= deps('configure', 'build', 'test', 'runtime'); } { my ($minperl) = reverse sort( grep defined && /^[0-9]+(\.[0-9]+)?$/, map $meta->{prereqs}{$_}{requires}{perl}, qw( configure build runtime ) ); if (defined($minperl)) { die "Installing $meta->{name} requires Perl >= $minperl" unless $] >= $minperl; $WriteMakefileArgs{MIN_PERL_VERSION} ||= $minperl if $EUMM >= 6.48; } } my $mm = WriteMakefile(%WriteMakefileArgs); exit(0); README000664001750001750 765214772476615 14221 0ustar00taitai000000000000Sub-HandlesVia-0.050002NAME Sub::HandlesVia - alternative handles_via implementation SYNOPSIS package Kitchen { use Moo; use Sub::HandlesVia; use Types::Standard qw( ArrayRef Str ); has food => ( is => 'ro', isa => ArrayRef[Str], handles_via => 'Array', default => sub { [] }, handles => { 'add_food' => 'push', 'find_food' => 'grep', }, ); } my $kitchen = Kitchen->new; $kitchen->add_food('Bacon'); $kitchen->add_food('Eggs'); $kitchen->add_food('Sausages'); $kitchen->add_food('Beans'); my @foods = $kitchen->find_food(sub { /^B/i }); DESCRIPTION If you've used Moose's native attribute traits, or MooX::HandlesVia before, you should have a fairly good idea what this does. Why re-invent the wheel? Well, this is an implementation that should work okay with Moo, Moose, Mouse, and any other OO toolkit you throw at it. One ring to rule them all, so to speak. For details of how to use it, see the manual. Sub::HandlesVia::Manual::WithMoo How to use Sub::HandlesVia with Moo and Moo::Role. Sub::HandlesVia::Manual::WithMoose How to use Sub::HandlesVia with Moose and Moose::Role. Sub::HandlesVia::Manual::WithMouse How to use Sub::HandlesVia with Mouse and Mouse::Role. Sub::HandlesVia::Manual::WithMite How to use Sub::HandlesVia with Mite. Sub::HandlesVia::Manual::WithClassTiny How to use Sub::HandlesVia with Class::Tiny. Sub::HandlesVia::Manual::WithObjectPad How to use Sub::HandlesVia with Object::Pad classes. Sub::HandlesVia::Manual::WithGeneric How to use Sub::HandlesVia with other OO toolkits, and hand-written Perl classes. Note: as Sub::HandlesVia needs to detect which toolkit you are using, and often needs to detect whether your package is a class or a role, it needs to be loaded *after* Moo/Moose/Mouse/etc. Your `use Moo` or `use Moose::Role` or whatever needs to be *before* your `use Sub::HandlesVia`. BUGS Please report any bugs to . (There are known bugs for Moose native types that do coercion.) SEE ALSO Guides for use with different OO toolkits: Sub::HandlesVia::Manual::WithMoo, Sub::HandlesVia::Manual::WithMoose, Sub::HandlesVia::Manual::WithMouse, Sub::HandlesVia::Manual::WithMite, Sub::HandlesVia::Manual::WithClassTiny, Sub::HandlesVia::Manual::WithObjectPad, Sub::HandlesVia::Manual::WithGeneric. Documentation for delegatable methods: Sub::HandlesVia::HandlerLibrary::Array, Sub::HandlesVia::HandlerLibrary::Blessed, Sub::HandlesVia::HandlerLibrary::Bool, Sub::HandlesVia::HandlerLibrary::Code, Sub::HandlesVia::HandlerLibrary::Counter, Sub::HandlesVia::HandlerLibrary::Enum, Sub::HandlesVia::HandlerLibrary::Hash, Sub::HandlesVia::HandlerLibrary::Number, Sub::HandlesVia::HandlerLibrary::Scalar, and Sub::HandlesVia::HandlerLibrary::String. Other implementations of the same concept: Moose::Meta::Attribute::Native, MouseX::NativeTraits, and MooX::HandlesVia with Data::Perl. Comparison of those: Sub::HandlesVia::Manual::Comparison Sub::HandlesVia::Declare is a helper for declaring Sub::HandlesVia delegations at compile-time, useful for Object::Pad and (to a lesser extent) Class::Tiny. AUTHOR Toby Inkster . COPYRIGHT AND LICENCE This software is copyright (c) 2020, 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. DISCLAIMER OF WARRANTIES 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. SIGNATURE000664001750001750 4632314772476615 14643 0ustar00taitai000000000000Sub-HandlesVia-0.050002This file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.88. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: RIPEMD160 SHA256 6b86cde225d606b13786ab31a5744a65fc34607156f10483813334b91ff35550 COPYRIGHT SHA256 07c5d60a0bbe19df7264abcb09e2181dd97246107caa3ec27503216a220bc147 CREDITS SHA256 e4aba471a4e963b32e51cbddc82652ea3b88d53f7bff89f14265b98c41df094e Changes SHA256 35bc6e48ae9f06aba42a170044f623d625a4825b6c1d960959ee0e286d5e8732 INSTALL SHA256 8e7094312357a5a73b44c1b87d32fca39e6d2f6c5a5504bcbcd0f0cf34b7c9cc LICENSE SHA256 ed0f6351ae8b08908852d3e676755c35d00bf79b07e1164adcc845699fec4e99 MANIFEST SHA256 a12b779eae0da7c49a17245119f3a85b11badb7b540624eae76428f6f4e3fba5 META.json SHA256 e24303a5801b0a5ba719aecaa3e955a0a8fbd515a5fc888b77a4409a8c6320ad META.yml SHA256 5c15c4be2169edba6880d589fb6586680ea5a47d12eed2074451e58d3a660466 Makefile.PL SHA256 5c93c81ffd8dfd51046c0a632a1239397e1d3f8a16e84b952bb1050ed0d22249 README SHA256 ba056c60f1cf17808ec8d0b21111edb072b7200d69927070f0a4172de9e6df89 dist.ini SHA256 23038088080c2d3fd8b83dbc20aebf7ff1b6b2d4f5fe09e5fdab03b07dafea0d doap.ttl SHA256 46393d1ff4fa7fb064bcbe2cdb6ecfd91fd40559e1ed457de65dcca39df6ac86 lib/Sub/HandlesVia.pm SHA256 de1ac7c3827d924329c4e242053fddf4ead5d7132a97ce53517d535e73c94d3e lib/Sub/HandlesVia/CodeGenerator.pm SHA256 bd39ab9018f9c7693e2b4c1dd5927689587c00992fc0bc1a7fea57de84882114 lib/Sub/HandlesVia/CodeGenerator.pm.mite.pm SHA256 6bc0d07b91c1834e7e3371c41bd53dfcae3ecff959f2faff5456a16ae6544066 lib/Sub/HandlesVia/Declare.pm SHA256 76a4fd979f920a255e94ec3252f490832adff104631c780ef36d6488daa4cae5 lib/Sub/HandlesVia/Handler.pm SHA256 5549fba58307f4033adf289e222007d11b18fb674120f0662074e72fc14abcd4 lib/Sub/HandlesVia/Handler.pm.mite.pm SHA256 b26dec7f8e5758b67fead3814d919dd4164e1707fc1f8a9c2bed53acf0ba084c lib/Sub/HandlesVia/HandlerLibrary.pm SHA256 f9ef93cd9509794f2067d6abd5f79db696e199527c0598e2d2c7ab7624772d9f lib/Sub/HandlesVia/HandlerLibrary/Array.pm SHA256 c2ad9d68ef1606456d71f82650b02b86fb659798abee3629db61a39df1f0edb4 lib/Sub/HandlesVia/HandlerLibrary/Array.pod SHA256 869701e9e117bc2ca78d8514e7ab7542882ba766c577088a569e4b984e291327 lib/Sub/HandlesVia/HandlerLibrary/Blessed.pm SHA256 849db3edc18d4dac5cd260995d8a2d3d75e2470e3b9b9fbb35a2694b1a39fcd6 lib/Sub/HandlesVia/HandlerLibrary/Bool.pm SHA256 b364df1453e94807beab1bf7aa59ede52f6278b89467d7ef211a13eed91e1d6b lib/Sub/HandlesVia/HandlerLibrary/Bool.pod SHA256 eb496ab0531bc0dd65ad8756262f84645509a835a0bc24bb59e4973fed65a4c0 lib/Sub/HandlesVia/HandlerLibrary/Code.pm SHA256 1d2283849fef32fe2adee886e0ea97eda44a6610e28f6a6e35339d8cb4e5c239 lib/Sub/HandlesVia/HandlerLibrary/Code.pod SHA256 406237919e202b6458b8cd80693193f2108b827d14d24d3c1606885e16223ffb lib/Sub/HandlesVia/HandlerLibrary/Counter.pm SHA256 0e4960e3e6bf46c6043da8d1dee8dc46c94b073bb997ef73195391bff9f8323f lib/Sub/HandlesVia/HandlerLibrary/Counter.pod SHA256 3570f3f14c46392f468832126a85eae2112fdf93a2492273a585eaf999e52381 lib/Sub/HandlesVia/HandlerLibrary/Enum.pm SHA256 77aa4afe791a8802287b432d4dbef14ded5137425b1b7ba826e8962b606cd883 lib/Sub/HandlesVia/HandlerLibrary/Hash.pm SHA256 6b7ab23ad13024e87773fa869763aa0a431121c0c8ed4cdc32d01f1977bdf94d lib/Sub/HandlesVia/HandlerLibrary/Hash.pod SHA256 1224ae5a658f1435b2bd477d2c100430351615774fb4e7fb9a8b5dcb3fa32b68 lib/Sub/HandlesVia/HandlerLibrary/Number.pm SHA256 63e76521c76c1d15cce086eebc636b408342afa20fa863f2f5d27e2c1b4aba91 lib/Sub/HandlesVia/HandlerLibrary/Number.pod SHA256 ace055f2764b29b67a9b80a0849e435487b43d1ea8e4e4fc846b8cf5a8d64476 lib/Sub/HandlesVia/HandlerLibrary/Scalar.pm SHA256 f729f7562a305cbd9d566aa9dda983370d4ff64f284ac8b548ae2c1436a021ef lib/Sub/HandlesVia/HandlerLibrary/Scalar.pod SHA256 64a1acaac1d1da7820d790c85c11ad9484c07993aba14dfb8729f0cf15cfeab5 lib/Sub/HandlesVia/HandlerLibrary/String.pm SHA256 c0888a1243406109a348f576919c13ce70b4efa7321759f8aa2236ab5edb90ac lib/Sub/HandlesVia/HandlerLibrary/String.pod SHA256 9fa6a02f9d12ddb1925a02b11a3fb04065d982a2399e3bab8161e01ab826e215 lib/Sub/HandlesVia/Manual/Advanced.pod SHA256 f8f8d056c5c8f800078409d777301e2e97a9e13ef853f266e172275af0515f13 lib/Sub/HandlesVia/Manual/Comparison.pod SHA256 0fca3ce95c9775079fddfdacb4cd37d4d9cb0fb6036fc90ceab9d8299b5ff73e lib/Sub/HandlesVia/Manual/WithClassTiny.pod SHA256 c110e61670345cd110e34d0967962de86374ba34281fd00d40f5ffe33bcdc197 lib/Sub/HandlesVia/Manual/WithGeneric.pod SHA256 410f57846648dfd2a9373076216ca1ee020c7e7170ba62b325d4193f751f9b7c lib/Sub/HandlesVia/Manual/WithMite.pod SHA256 2930a815d297bfbc66e0b285a5ab1d978bf3b83b8e931037bda15b976824fa0d lib/Sub/HandlesVia/Manual/WithMoo.pod SHA256 e509dea64f2e05743df5afc6b9b28bbeea2c29fcba11f9f08d3da81366c1dd47 lib/Sub/HandlesVia/Manual/WithMoose.pod SHA256 74eb64922e08557b0ff53e0c10ad0bc1e701f06012d270baf9fa3c83458729da lib/Sub/HandlesVia/Manual/WithMouse.pod SHA256 70115bfb971c1a6c3b6dfa095c0d7a636debbb07f5daa2fae9e82fedba62b2f6 lib/Sub/HandlesVia/Manual/WithObjectPad.pod SHA256 53c62df7e3f288e7fab70b314bbe6e19e844d13ab676fab2e15e9ecb73684d04 lib/Sub/HandlesVia/Mite.pm SHA256 df052d79c0d07654c9efa11bb0b1ffe1ca63114bb29cd3331029a6fc1ebd15a2 lib/Sub/HandlesVia/Toolkit.pm SHA256 9b93c4536f1e35e931bf8ec997d6244351b518f4f2bda24c68202ccf99757284 lib/Sub/HandlesVia/Toolkit.pm.mite.pm SHA256 282db276dda0114d19ab360625dc79c4157173258352766fab5d7623305ef682 lib/Sub/HandlesVia/Toolkit/Mite.pm SHA256 2d64e211dd3577cb45b74ab3eaf748763a165cc353af7629d07f6eea77cd6b93 lib/Sub/HandlesVia/Toolkit/Mite.pm.mite.pm SHA256 416e0f9308b251ca2258c3dcc4c2b5ec2274182d7f391c0006bf55f3481034b9 lib/Sub/HandlesVia/Toolkit/Moo.pm SHA256 dffa899e9a4b06ff8f7cac3462aeec7d501c3eb8df0ede95fd1d40946bc4f781 lib/Sub/HandlesVia/Toolkit/Moo.pm.mite.pm SHA256 3b23dcb5d65ba3df5945aa929949f61097d08537682ad3019eb106b957161633 lib/Sub/HandlesVia/Toolkit/Moose.pm SHA256 6b415be23c14838117590ce50e865f0a4f1971ce6b1315d53e4cd0d1102a7049 lib/Sub/HandlesVia/Toolkit/Moose.pm.mite.pm SHA256 2d1d3cd0d4087f0183697bc214bba4e2fad44b71d9a5b8f35c048bcea7f05ec5 lib/Sub/HandlesVia/Toolkit/Mouse.pm SHA256 78272c88537584cfc614a12d912524c5a2abfa20609c0cde7459e4a2df53a918 lib/Sub/HandlesVia/Toolkit/Mouse.pm.mite.pm SHA256 981203363343270b9a0998b49d0e923b4051f5db3de607b5bd1c7121a1dd5976 lib/Sub/HandlesVia/Toolkit/ObjectPad.pm SHA256 3d0accf70505c52d6bae9bfedded1718f79c2ec5e13ff2c05b9cda4eb9205b80 lib/Sub/HandlesVia/Toolkit/ObjectPad.pm.mite.pm SHA256 281d627776649f7d9c3c04b8680a760022b727ff38a0896fc8836d8d29411292 lib/Sub/HandlesVia/Toolkit/Plain.pm SHA256 eda37d293539e43f3c9e167a0a10d6bc010ef8f2c91bb303913577c190d57227 lib/Sub/HandlesVia/Toolkit/Plain.pm.mite.pm SHA256 b2e9a673ff39da47abd0997dd246adb49f749027d513e0e4f260f67539ad740b t/00begin.t SHA256 5be3d6935e48a88ff74c38cd8a03e911b2f3d4f49ac639246e40b1e88e8fcb32 t/01basic.t SHA256 983043ae6118d9065777a811b6edc3b25d7b3b433d4817e033723fb8bb88332f t/02moo.t SHA256 51a4ee1945713ee501250cdacdffdc764b8a2604e407f61ee12cdd56b766ff9b t/02moo/ext_attr.t SHA256 02a8dc13c7451b68163d1701b4e8ca520a463c4adea8166189d15852aeaab5b5 t/02moo/role.t SHA256 9ee20825faff0db0bbb30c2ed0bacef1d5e555aff8f30d74506d6a5f427d71e9 t/02moo/roles-multiple.t SHA256 2f53fbd88977f0974315c7306624d0c3ec1b7bd4556b83703a2ea97ce9c96105 t/02moo/trait_array.t SHA256 c148d69bc563ee87c11365b21a38bd02d8715a631e3f069532232648c98a8527 t/02moo/trait_bool.t SHA256 4907d4e290996299252cee49c5f41e0365407ddc26b3ff19382f3537694d86a6 t/02moo/trait_code.t SHA256 519ba7d0bbbdd4dc865f934b39fc8e9c13a4e6124f39735c58f626e461206eb3 t/02moo/trait_counter.t SHA256 0f236c6f764046cc5220fe0e18e2d39af4970585f48972715977e360a9c141cb t/02moo/trait_hash.t SHA256 35cc50d0c3faace062d761e2162b166a8975e74073eb7483fa0884ea3c0851b8 t/02moo/trait_number.t SHA256 23b594f9012c95bb1c5db42a138c74b95749121b98cb01a88d34d3b7b46f8bf5 t/02moo/trait_string.t SHA256 38bef4a17bb2517add3ed460d0d6de336250cd6cf02f66cae276026706d0f4ee t/03moo_mxtt.t SHA256 b53841d4594133cec46b68e9d9fe26df13c132214bcc00e71199b9e53bd49b7a t/03moo_mxtt/role.t SHA256 7e7865ad095dc00085226b145e341088883dd6d156d4a987dc5430ed31953035 t/03moo_mxtt/trait_array.t SHA256 61e936c3b3edae0173851a2ca6cea925da2aa0f8dfeabbcaa161ea633c5b599f t/03moo_mxtt/trait_bool.t SHA256 b20c98997532eae19b7c40624e354efcfe9c91e7e7c62a133b2a549cbdf61295 t/03moo_mxtt/trait_code.t SHA256 ba57e31c117aa13938a94abf84c36f0d8965e095c05468e323856c0eb8457ad4 t/03moo_mxtt/trait_counter.t SHA256 daa2501bf7f15d3caac06c3b79e1dc850b53366204a02c898644aae014846e54 t/03moo_mxtt/trait_hash.t SHA256 bf0ebc9c9c7dae416958e41f0277f6f2a8f4f172e63ddd18a6c3380ffff74689 t/03moo_mxtt/trait_number.t SHA256 b946296c566b4c95c7056dae6ed5379ef12e62c85f7bc77ca367da2b7d7be27c t/03moo_mxtt/trait_string.t SHA256 d7c743824c01a01013687226e0450b1e09df95bd833912557807717a7dce17c5 t/04moose.t SHA256 e0f4e56fb0ea2869c3853f986e1ba181b5e198e6e97670e13fcb423ab3d13fdc t/04moose/ext_attr.t SHA256 5307fae95a9f4da426d32c874586da8317b9fe64f55d16d4c14f6a0c204c6387 t/04moose/role.t SHA256 e5c9a1b29dff1d57498f3fedd1130c990321f51090655b05dcebc7e8c5a89a78 t/04moose/roles-multiple.t SHA256 30706099772b658e4217095e55e86c572ee1a5e9f44c09a07b6007065db5fb64 t/04moose/trait_array.t SHA256 eda58d0a92eee96b9d792ca833b5b1136ce16baaaa87d66f001b6948f1658241 t/04moose/trait_bool.t SHA256 0419ca33b0a352be50bff6571bd02da0aa56220aecacc7efaed4bd3220668815 t/04moose/trait_code.t SHA256 3e2b267a55fde77464d5922610199a1c562c9d5f9dbbaf57c13d787e20a5ad57 t/04moose/trait_counter.t SHA256 3ac655c80e4a9dd332d6eeb1bfbef0137300545c9ec3d0aa3cfe78fd18ee4de5 t/04moose/trait_hash.t SHA256 03fc217d4a67794501c511f953d5eae159f7686858d0f3a1cae66e569e395661 t/04moose/trait_number.t SHA256 35588b43d1739b60c22f7235d8976d8a208c8b70773b79735f82255d1edce71c t/04moose/trait_string.t SHA256 cbc1e78776b7abe41c903b5483eb3874316ce8950e2284ebf33a8053c521690a t/05moose_nativetypes.t SHA256 c0c5b5c9d933cdf2441672e4d34e95164c2b65221a2bb5d42db282972911f578 t/05moose_nativetypes/role.t SHA256 1adfd15109492dccd7d17821ef4aa41967a5462b6c46045e7a4b1e335f9e736a t/05moose_nativetypes/trait_array.t SHA256 81521f31e834419b8152830c20120ffa1a303705c172e59e48ed536ffbe24679 t/05moose_nativetypes/trait_bool.t SHA256 6c35242af67ec42fb43af2ad4d0599d5bc8f1aa41480a86ceda56bd8c13e30b5 t/05moose_nativetypes/trait_code.t SHA256 849cd6db4d11fd5f1e3e5fb3e80537dc1d9331280963725aff6892d2c5239795 t/05moose_nativetypes/trait_counter.t SHA256 32e5a734405cb5a297e6e8432be1ed63c205213c3598d6ca66fc3fd39109aa81 t/05moose_nativetypes/trait_hash.t SHA256 81b7c2ab8960342cb25757fa62d1bb0c5a75026d58bbdddf7c5f65b2be6d0b9a t/05moose_nativetypes/trait_number.t SHA256 382228dd342b0fb1c84dc30028e1e0d48137d6cddbf9cd2b4338e8b20d03113c t/05moose_nativetypes/trait_string.t SHA256 2e1b2a16546d79afb096940ec2881d885ea56ef7811666d839c8af701cf4e440 t/06mouse.t SHA256 637b579d531439a5cbdf995c5c5e39e20cb333d135e94011cf423bafa0771ed2 t/06mouse/ext_attr.t SHA256 5d0c0e1fec6078628126d633b71f5071761d01c40cd1865fed386f98d320a441 t/06mouse/role.t SHA256 86816073507f342f1804b9b85ed9565c53b855a787184209059804446db646d5 t/06mouse/roles-multiple.t SHA256 70e8669c9beaa14325d439cbd319dd165121c90b805450ad51f61bd3c7c1a3dd t/06mouse/trait_array.t SHA256 a8a5a8ff9dc895f8c0954971451d56465110b2adb8df262e10e63fd8ea3d24ef t/06mouse/trait_bool.t SHA256 c0c650217744e56d13f887a7e73d6bb808164e961d85854cdb999b4988e43c43 t/06mouse/trait_code.t SHA256 92d979a6d59882a9136c121b4928b955adef20e63d9a426c1223cb2d16b8ea8f t/06mouse/trait_counter.t SHA256 bdaa82657b0f52d2e747eff80a7feb747713e15af308728255de2ffd8528afa9 t/06mouse/trait_hash.t SHA256 091c95d20a1957e89c7716fe2eb794acfbf042fde8346be06d7abe008fa2e13a t/06mouse/trait_number.t SHA256 c2a4020c853581a99d56a63336fbe4e9443bde3bb0205eafd330f2e5103e7c19 t/06mouse/trait_string.t SHA256 e37d702966198700b079d7d0c60f5e7f421c92b0d530876cc000415fa31f5c79 t/07mouse_nativetypes.t SHA256 95a948eabd66496d2b78f7efde69551c50e9b041904f9cdea7dc71c4486409b3 t/07mouse_nativetypes/role.t SHA256 88c9becce31cb032b253176f1334bde7d076bd9c8601b2ccbdf37b6127276c4f t/07mouse_nativetypes/trait_array.t SHA256 ed54ff0a113e995b3774e21de93b3926963ec098bdb6523dfc0064bee2b0b8ae t/07mouse_nativetypes/trait_bool.t SHA256 51e80aa97ac5469a459e700d4ccc8566f1e12fdeda0ff4fd30dd5fabfc043c04 t/07mouse_nativetypes/trait_code.t SHA256 253bae40e717c5aca36a970382a640e9f5bfda05084255b897a67c7e57cf3131 t/07mouse_nativetypes/trait_counter.t SHA256 49bfbf64f60e6d7ff330c0ea096a1f3cd58b3081996be55896f64f07a4f1b31f t/07mouse_nativetypes/trait_hash.t SHA256 29395195994c4336f5b2ada6c830f0802ac2cac67b881808b8a512a7714a4ad8 t/07mouse_nativetypes/trait_number.t SHA256 7154d310e7c543757c9278d33967fe49fa75fa70382b85c1b8245e6e9932319a t/07mouse_nativetypes/trait_string.t SHA256 94e78169f23e58952774492111a3fedc15a1ce193f25bf790cd30b69d9416966 t/08classtiny.t SHA256 3de49adbb2f81ceb14e03b8a8441708c6e073ff61ae9fc6395cc567bbe8aa857 t/09barebones.t SHA256 2ed26a82a80cc728d714d52cd68e015788a03c108af558536dc911879fdd4ecd t/10barebones_eagerbuilder.t SHA256 ecd0b6ab6195ec229323c968d94348e22cb144cae3646c736e1419c4ea1a13f0 t/11delegation.t SHA256 ae5ec80935fce3ac9631c5de490b183b030e3605fddd092e4679a0af86110dc9 t/12slotaccess.t SHA256 67d7a6716bebb962596d920281a19036656133a3d5086a069762d3172c05f9b0 t/14enum.t SHA256 4ec6afaf16f20cdaa0a19ee9bd676ad12a3afb8f69929b863118d216e06c6a4e t/15preludes.t SHA256 594fb0e5ed4386b77143e33533d9ac90c78258c0dbd8447ce61920cce63a6faa t/16stackqueue.t SHA256 406ab6fe3abf8ba6d1285481bec5bd239f08d4e28fad2ae011699287ee175a21 t/20moosex_extended.t SHA256 73ed937a82acf4ba01cb9dbae2144e25f6d0cecaa8438f8167505dd3a27af2c7 t/30egpod/array.t SHA256 fda4dd6bb965220614c69f76ae7147c3f8e78e7effcf098f444ff6b29407d5a4 t/30egpod/bool.t SHA256 8534a0a73e6d90197a84cd6f4541019c097be9013f69d7d55fddd7fdddce386f t/30egpod/code.t SHA256 02c154f26a0e80a16c9c9fbdf022c3bf56fe2746acbb6f6a66906cb2f5eb4bf3 t/30egpod/counter.t SHA256 06a534144cea44ebc2cb54ac34490cf3da53b358022a87aa1215464482efd835 t/30egpod/hash.t SHA256 b011635305d0ad941ed127ac4e8da2005cc61f31cbc163101bdaa444aaccfbad t/30egpod/number.t SHA256 fbc667741d6c338fdc55320066732f307695ee0a9016319598898f406ebe9a01 t/30egpod/scalar.t SHA256 ae267058620cc77af8aedf98cc35ad449d758fd87cea428a3dec998f1a456b7d t/30egpod/string.t SHA256 5c554a286988e45bf3b265183015573be57e07b1fdc8f3d31e6adfaf4f0629a4 t/31egpod_dummy.t SHA256 be2ea3f2f766193b9f3458abf20c75bd0668311056f86950375e7a15c95796df t/40mite/.mite/config SHA256 5b0fc54e6d755fdbb50b4064064d4b760b4cd13970da9e652e2a891d123b634a t/40mite/00-basic.t SHA256 686dc169070872949cab88c4692357d445c54c5f2f5a8662905df36ae8c945c4 t/40mite/01-roles.t SHA256 2d975d6ee9bb734faaae1b2048f74abfce6699101a3bdc854ec9f9354b8c0278 t/40mite/array.t SHA256 1407592aba71ef8bd390519291ebf45c29fdec62d3f689b25fc58766e6091f1f t/40mite/bool.t SHA256 f70d13824e7057c1046fcca5e34a5f075dd3eac8ddcb1ea577f6823d1f92c4b6 t/40mite/code.t SHA256 1a42383f79c8ce42b07d35fa29de47655463a198701ab00bf3f7704d0bf5976f t/40mite/counter.t SHA256 4bd4bafba5e511ed416292be4e4637487bba40ff2ece219508bfb2c363fd55c2 t/40mite/hash.t SHA256 a79697a794e6dfdeb586cd10bb43892cdefdc6e55e6700c2546bb4d9825d6492 t/40mite/lib/MyTest.pm SHA256 73a3285a69d6e049eaa4cda124822808e1126a2d5794a65caafc9886a285efaa t/40mite/lib/MyTest.pm.mite.pm SHA256 cf4b28a6aeab4c4b43230bddfe49bcaa8bfc527a1094a76ac46bc35c3e598237 t/40mite/lib/MyTest/Class1.pm SHA256 e5f7ad042566819deb9f522106e39f5ee2f2049fe2be28df0c9094fd8e58ac9c t/40mite/lib/MyTest/Class1.pm.mite.pm SHA256 3095869e8df65e4167f5d8360c318800cdfebc9d31683198b35853d4e2305d92 t/40mite/lib/MyTest/Mite.pm SHA256 661ce026aec4601357a50bd4e3cdb66fa1fb6d60bbd113a676d03a04dc1ab353 t/40mite/lib/MyTest/Role1.pm SHA256 02599205c8795fca83624a585909751798450b9f37ca8606b4653937f6073c31 t/40mite/lib/MyTest/Role1.pm.mite.pm SHA256 1b889e977d140bcad7748efd67daa5945d0b210059f78996b9bf0251e0c40275 t/40mite/lib/MyTest/Role2.pm SHA256 549047a7165072e6e9fe8624119b5c4615d7c7590ebdbcd2a3681afa56fb715f t/40mite/lib/MyTest/Role2.pm.mite.pm SHA256 6b30fd554d421bfe45162adbccb42b158737794025ec0cc0d19bd17fe5dab6ef t/40mite/lib/MyTest/TestClass/Array.pm SHA256 ff22e4bb81966ab9f389206126736158bedfa6827e626e481f5740c3f1ba5fdc t/40mite/lib/MyTest/TestClass/Array.pm.mite.pm SHA256 1a7a3233d07334bf519f12cde304571c71236b3f5eb597b73b2deb6e5b5a1fed t/40mite/lib/MyTest/TestClass/Bool.pm SHA256 43471671548a4e85dbe8ec06b7a284bb269af92004871bbb4be0f2596a5af9f2 t/40mite/lib/MyTest/TestClass/Bool.pm.mite.pm SHA256 d56bc316f6d8c89461a57c8b0c06c14041398ad2e524f5e4a2f26863cd1a6fc6 t/40mite/lib/MyTest/TestClass/Code.pm SHA256 abed0e8120ddb014cbdbe32cb682f568d46c88737517d229ab0c7c0ab2470dd1 t/40mite/lib/MyTest/TestClass/Code.pm.mite.pm SHA256 fb4ced712123070f05c1ce5418b7a2364ee926a2f67dbae6fe71e8c497c7b3c9 t/40mite/lib/MyTest/TestClass/Counter.pm SHA256 943ad01a0080119da66c7ff4b45d3975bccfd302cfd320a1aa1ccf4974091a14 t/40mite/lib/MyTest/TestClass/Counter.pm.mite.pm SHA256 8f6a42c07934403c637bdd4d34f9e9e51c5526913950ccfa081e315b6a43ecd1 t/40mite/lib/MyTest/TestClass/Hash.pm SHA256 8c29e29abe97e3ecfd869a751d1ccd97fc30eb80b65dab756e3dbd4fa0efbb31 t/40mite/lib/MyTest/TestClass/Hash.pm.mite.pm SHA256 e422158861ec08219883717a053e7a9635fd89a5cd35c54ded821e3095102c1f t/40mite/lib/MyTest/TestClass/Number.pm SHA256 0396277dd4cc27fd910fc09f5449079173025b4cd1fa34915676cdee8f0dea4f t/40mite/lib/MyTest/TestClass/Number.pm.mite.pm SHA256 4a5fdef7307f2aa9a65f717b1cab3e8dd9706e1108c74291d13bc3c142ef1207 t/40mite/lib/MyTest/TestClass/Scalar.pm SHA256 a20574315679ac5f553e3f28020318da3c6e206c1a419160d1ed21bd110ee356 t/40mite/lib/MyTest/TestClass/Scalar.pm.mite.pm SHA256 97913b2c7149a65f079374f37feb496ae1281e57306bb02cdd6c0cbdf0bc3130 t/40mite/lib/MyTest/TestClass/String.pm SHA256 7528ae0650c3811174b42f26237776b25b16cbed344e60fddd4533b83fd9d590 t/40mite/lib/MyTest/TestClass/String.pm.mite.pm SHA256 92d061d91832721b48e2a67b7d90b53bcfdcc82bc40251c8ef33d89d918bb7be t/40mite/number.t SHA256 63b015160f37736e157b203c0d6a9c52607950192812eee662a178f735da9cf0 t/40mite/scalar.t SHA256 5ff35a0b0b7f516b6ef16121d425d1560144b16fc5fa72801d85e6c4a36aed46 t/40mite/string.t SHA256 0bee5a9024aae118cd5400ae2194999bd7d48af50a0f4fa9198e048ba874240c t/50objectpad.t SHA256 505e577fb577a68e2589d6550de24341e53a8edef62e861d1f71f2917bb5f9b2 t/60detect.t SHA256 61f2ae84d2f187eff15ae6cd88adc5e2041d058569cbe59c8988244f3f7a39ff t/61moosemetagubbins.t SHA256 8f0e391fd0d3c36c7a8b6a3a450d2c27d1b1fa39735ddd69eec855eb8011a718 t/62mousemetagubbins.t SHA256 70287e9d00737e2b2631c0c9a4b3a191c11914ab29c8788fd84b8934af9e808a t/80beam.t SHA256 755e11ae7d5edfc7f71f444f0216d2323fc9852aaefdbe4117f0b5dfc1c108ac t/81mxpa.t SHA256 3dc956219599a77e77a038efcc753a822d57646ffdda8109433df635d7cf79f3 t/94cmp.t SHA256 c2b7cf16e9eab452e875e0303e5f4e7722d69ba4d5ada363caff9e807cfaa67c t/95any.t SHA256 f393205104cde3e714e7a078b801fed222fd941a366c2d9acde59e6ca93e282e t/96foreach.t SHA256 a21db55eaa70dd2775f35eb2537459446f4fbe9dd42910bdeda002b7de5eaf54 t/97pickrandom.t SHA256 18db1b856bacf0eff67b372a3802a85707d38e75a80d179cfcf85dcb1e63cfa2 t/98apply.t SHA256 202446ab285d312d164883a5131346924224a85fab9568ea605b1de6bd00da7f t/99headtail.t -----BEGIN PGP SIGNATURE----- iF0EAREDAB0WIQRVJKj/4+s6z4WzNujOv4Eoaip9OQUCZ+p9jQAKCRDOv4Eoaip9 OZddAJ9rxZEKOixBfeSQWf0iXv5kg1cnvQCgtGTXD7kdXUtSfyEb5eWCcf1845w= =htEO -----END PGP SIGNATURE----- dist.ini000664001750001750 21514772476615 14751 0ustar00taitai000000000000Sub-HandlesVia-0.050002;;class='Dist::Inkt::Profile::TOBYINK' ;;name='Sub-HandlesVia' ;;also_skip=[ qr!^\.mite!, ] ;;skip_whitespace_test=1 ;;skip_prebuild_tests=1 doap.ttl000664001750001750 13160014772476615 15040 0ustar00taitai000000000000Sub-HandlesVia-0.050002@prefix cpan-uri: . @prefix dc: . @prefix doap: . @prefix doap-changeset: . @prefix doap-deps: . @prefix foaf: . @prefix rdfs: . @prefix xsd: . dc:title "the same terms as the perl 5 programming language system itself". a doap:Project; dc:contributor ; doap-deps:develop-recommendation [ doap-deps:on "Dist::Inkt 0.001"^^doap-deps:CpanId ]; doap-deps:develop-requirement [ doap-deps:on "Mite 0.006001"^^doap-deps:CpanId ]; doap-deps:runtime-recommendation [ doap-deps:on "Sub::Util"^^doap-deps:CpanId ]; doap-deps:runtime-requirement [ doap-deps:on "perl 5.008001"^^doap-deps:CpanId ], [ doap-deps:on "Exporter::Shiny"^^doap-deps:CpanId ], [ doap-deps:on "Type::Tiny 1.004"^^doap-deps:CpanId ], [ doap-deps:on "Role::Tiny"^^doap-deps:CpanId ], [ doap-deps:on "Role::Hooks 0.008"^^doap-deps:CpanId ], [ doap-deps:on "Class::Method::Modifiers"^^doap-deps:CpanId; ], [ doap-deps:on "List::Util 1.54"^^doap-deps:CpanId ]; doap-deps:test-recommendation [ doap-deps:on "Moo"^^doap-deps:CpanId ], [ doap-deps:on "MooX::TypeTiny"^^doap-deps:CpanId ], [ doap-deps:on "Class::Tiny"^^doap-deps:CpanId ], [ doap-deps:on "Object::Pad 0.70"^^doap-deps:CpanId ], [ doap-deps:on "MooseX::Extended 0.22"^^doap-deps:CpanId; ], [ doap-deps:on "Moose"^^doap-deps:CpanId ], [ doap-deps:on "Mouse"^^doap-deps:CpanId ]; doap-deps:test-requirement [ doap-deps:on "Test::More 0.96"^^doap-deps:CpanId ], [ doap-deps:on "Test::Fatal"^^doap-deps:CpanId ], [ doap-deps:on "Try::Tiny"^^doap-deps:CpanId ], [ doap-deps:on "Test::Requires"^^doap-deps:CpanId ]; doap:bug-database ; doap:created "2020-01-18"^^xsd:date; doap:developer ; doap:download-page ; doap:homepage ; doap:license ; doap:maintainer ; doap:name "Sub-HandlesVia"; doap:programming-language "Perl"; doap:release , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , , ; doap:repository [ a doap:GitRepository; doap:browse ; ]; doap:shortdesc "alternative handles_via implementation". a doap:Version; rdfs:label "Initial release"; dc:identifier "Sub-HandlesVia-0.001"^^xsd:string; dc:issued "2020-01-21"^^xsd:date; doap-changeset:released-by ; doap:file-release ; doap:revision "0.001"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.002"^^xsd:string; dc:issued "2020-01-21"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Packaging; rdfs:label "Add missing dependency on Class::Tiny."; ], [ a doap-changeset:Change; rdfs:label "Drop dependency on List::MoreUtils by including our own copies of `natatime` and `firstidx`."; ], [ a doap-changeset:Documentation; rdfs:label "Fix some typos."; ], [ a doap-changeset:Documentation; rdfs:label "Remove some outdated information."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.002"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.003"^^xsd:string; dc:issued "2020-01-21"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Change; rdfs:label "A lot of refactoring, reducing duplication in Moo, Moose, and Mouse integration."; ], [ a doap-changeset:Documentation; rdfs:label "Document API for how Sub::HandlesVia interacts with OO frameworks."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.003"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.004"^^xsd:string; dc:issued "2020-01-22"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Change; rdfs:label "Support for Moo::Role, Moose::Role, and Mouse::Role."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.004"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.005"^^xsd:string; dc:issued "2020-01-23"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Addition; rdfs:label "`head` method for Array."; ], [ a doap-changeset:Addition; rdfs:label "`tail` method for Array."; ], [ a doap-changeset:Bugfix; rdfs:label "Stop accidentally setting coerce=>'' for some Moo attributes. It confuses Moo."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.005"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.006"^^xsd:string; dc:issued "2020-01-23"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Tests; rdfs:label "Output some version numbers and environment variables in test suite."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.006"^^xsd:string. a doap:Version; rdfs:label "Bond... James Bond"; dc:identifier "Sub-HandlesVia-0.007"^^xsd:string; dc:issued "2020-01-25"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Addition; rdfs:label "`scalar_ref` method for Scalar."; ], [ a doap-changeset:Bugfix; rdfs:label "Better handling for non-hashref-based Moose instances."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.007"^^xsd:string. a cpan-uri:DeveloperRelease, doap:Version; dc:identifier "Sub-HandlesVia-0.008_000"^^xsd:string; dc:issued "2020-01-26"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Tests; rdfs:label "Spew some output in t/03moo_mxtt/trait_hash.t."; ], [ a doap-changeset:Packaging; rdfs:label "Require MooX::TypeTiny and Moo."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.008_000"^^xsd:string. a cpan-uri:DeveloperRelease, doap:Version; dc:identifier "Sub-HandlesVia-0.008_001"^^xsd:string; dc:issued "2020-01-26"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Tests; rdfs:label "Load Carp::Always for failing test case."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.008_001"^^xsd:string. a cpan-uri:DeveloperRelease, doap:Version; dc:identifier "Sub-HandlesVia-0.008_002"^^xsd:string; dc:issued "2020-01-27"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Tests; rdfs:label "Spew even more output in t/03moo_mxtt/trait_hash.t."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.008_002"^^xsd:string. a cpan-uri:DeveloperRelease, doap:Version; dc:identifier "Sub-HandlesVia-0.008_003"^^xsd:string; dc:issued "2020-01-27"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Tests; rdfs:label "Skip t/03moo_mxtt/trait_hash.t if Type::Tiny is not using XS."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.008_003"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.009"^^xsd:string; dc:issued "2020-01-27"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Tests; rdfs:label "Revert MooX::TypeTiny test verbosity from 0.008_xxx."; ], [ a doap-changeset:Packaging; rdfs:label "Revert testing dependency additions from 0.008_xxx."; ], [ a doap-changeset:Tests; rdfs:label "Skip Array trait tests under Mouse if Mouse is not using XS due to Mouse::PurePerl bug."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.009"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.010"^^xsd:string; dc:issued "2020-01-27"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Addition; rdfs:label "`apply` method for Array."; ], [ a doap-changeset:Addition; rdfs:label "`for_each` method for Array."; ], [ a doap-changeset:Addition; rdfs:label "`for_each_pair` method for Array."; ], [ a doap-changeset:Addition; rdfs:label "`pick_random` method for Array."; ], [ a doap-changeset:Addition; rdfs:label "`for_each_pair` method for Hash."; ], [ a doap-changeset:Addition; rdfs:label "`for_each_key` method for Hash."; ], [ a doap-changeset:Addition; rdfs:label "`for_each_value` method for Hash."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.010"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.011"^^xsd:string; dc:issued "2020-01-27"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Addition; rdfs:label "`any` method for Array."; ], [ a doap-changeset:Documentation; rdfs:label "Document which aliases MouseX::NativeTraits provides."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.011"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.012"^^xsd:string; dc:issued "2020-02-02"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Addition; rdfs:label "Add missing methods from List::Util to Array. (These are mostly untested, but probably don't have bugs as they are simple non-mutator methods.)"; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.012"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.013"^^xsd:string; dc:issued "2020-02-04"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Tests; rdfs:label "Skip Moo tests on very old Moo."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.013"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.014"^^xsd:string; dc:issued "2020-08-25"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Bugfix; rdfs:label "Fix compilation errors caused by value coercions under some circumstances."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.014"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.015"^^xsd:string; dc:issued "2020-09-12"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Addition; rdfs:label "`reset` method for Array."; ], [ a doap-changeset:Addition; rdfs:label "`reset` method for Hash."; ], [ a doap-changeset:Change; rdfs:label "Plain toolkit (used by non-Moo/Moose/Mouse classes) now supports defaults/builders."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.015"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.016"^^xsd:string; dc:issued "2020-09-20"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Bugfix; rdfs:label "Fix load order issue where handles_via is used in a Moo::Role when Moo.pm isn't loaded yet."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.016"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.017"^^xsd:string; dc:issued "2022-06-11"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Addition; rdfs:label "Numeric comparison methods."; ], [ a doap-changeset:Addition; rdfs:label "String comparison methods."; ], [ a doap-changeset:Addition; rdfs:label "Case-insensitive versions of string comparison methods."; ], [ a doap-changeset:Addition; rdfs:label "String uc, lc, and fc methods."; ], [ a doap-changeset:Addition; rdfs:label "String match_i method."; ], [ a doap-changeset:Addition; rdfs:label "String starts_with, ends_with, and contains methods, plus case-insensitive versions of them."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.017"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.018"^^xsd:string; dc:issued "2022-06-11"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Addition; rdfs:label "Sub::HandlesVia::Handler objects now have a `documentation` attribute."; ], [ a doap-changeset:Documentation; rdfs:label "Generated pod for the HandlerLibrary modules."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.018"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.019"^^xsd:string; dc:issued "2022-06-11"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Documentation; rdfs:label "Include more examples in pod for HandlerLibrary modules."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.019"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.020"^^xsd:string; dc:issued "2022-06-11"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Documentation; rdfs:label "Improve and document the Sub::HandlesVia::HandlerLibrary::Scalar module."; ], [ a doap-changeset:Tests; rdfs:label "Additional tests based on pod examples."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.020"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.021"^^xsd:string; dc:issued "2022-06-12"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Documentation; rdfs:label "Provide extended examples in HandlerLibrary pod."; ], [ a doap-changeset:Tests; rdfs:label "Additional tests based on extended examples."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.021"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.022"^^xsd:string; dc:issued "2022-06-14"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Documentation; rdfs:label "Additional Array example: push and shift."; ], [ a doap-changeset:Documentation; rdfs:label "Other documentation improvements."; ], [ a doap-changeset:Change; rdfs:label "Cleaned up Sub::HandlesVia::Handler and moved a lot of code into a new class Sub::HandlesVia::CodeGenerator, which replaces the big hash of callbacks which was passed around everywhere."; ], [ a doap-changeset:Documentation; rdfs:label "Document Sub::HandlesVia::Handler and Sub::HandlesVia::CodeGenerator."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.022"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.023"^^xsd:string; dc:issued "2022-06-14"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Change; rdfs:label "Major Sub::HandlesVia::CodeGenerator cleanups."; ], [ a doap-changeset:Removal; rdfs:label "Sub::HandlesVia::CodeGenerator's simple_set concept has been removed; this was vestigial and had no effect."; ], [ a doap-changeset:Packaging; rdfs:label "Changed minimum required Perl from 5.8.0 to 5.8.1."; ], [ a doap-changeset:Documentation; rdfs:label "Minor documentation improvements."; ], [ a doap-changeset:Change; rdfs:label "Move some code from Sub::HandlesVia::Toolkit::Plain to its base class."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.023"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.024"^^xsd:string; dc:issued "2022-06-15"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Documentation; rdfs:label "Explicitly document that Sub::HandlesVia needs to be imported AFTER Moo/Moose/Mouse so that it can detect the class/role builder being used."; ], [ a doap-changeset:Tests; rdfs:label "Test that Sub::HandlesVia works okay with MooseX::Extended."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.024"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.025"^^xsd:string; dc:issued "2022-06-16"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Change; rdfs:label "Internally shift off the method invocant sometimes as benchmarking shows that to be faster."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.025"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.026"^^xsd:string; dc:issued "2022-06-30"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Addition; rdfs:label "Support classes built with Mite."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.026"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.027"^^xsd:string; dc:issued "2022-06-30"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Tests; rdfs:label "Skip Mite test on Perl < 5.10.1"; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.027"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.028"^^xsd:string; dc:issued "2022-07-02"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Update; rdfs:label "Support for Mite roles."; ], [ a doap-changeset:Tests; rdfs:label "Lots more tests for using Sub::HandlesVia with Mite."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.028"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.029"^^xsd:string; dc:issued "2022-07-09"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Packaging; rdfs:label "Use Mite internally, dropping the dependency on Class::Tiny."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.029"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.030"^^xsd:string; dc:issued "2022-07-09"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Packaging; rdfs:label "Drop dependency on Scope::Guard."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.030"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.031"^^xsd:string; dc:issued "2022-07-09"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Packaging; rdfs:label "Add dependencies on MRO::Compat and Devel::GlobalDestruction, but only on very old Perls."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.031"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.032"^^xsd:string; dc:issued "2022-07-12"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Packaging; rdfs:label "Require newer version of Role::Hooks."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.032"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.033"^^xsd:string; dc:issued "2022-07-12"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Update; rdfs:label "Recompile with newer Mite."; ], [ a doap-changeset:Change; rdfs:label "Optimizations to Sub::HandlesVia::CodeGenerator."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.033"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.034"^^xsd:string; dc:issued "2022-08-07"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Change; rdfs:label "Sub::HandlesVia::CodeGenerator now handles generating code for type assertions and coercions instead of relying on handlers to do it."; ], [ a doap-changeset:Change; rdfs:label "Sub::HandlesVia::CodeGenerator now has a configurable sandbox package."; ], [ a doap-changeset:Update; rdfs:label "Sub::HandlesVia::Toolkit::Mite supports recent Mite features such as lvalue accessors and new ways of specifying defaults."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.034"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.035"^^xsd:string; dc:issued "2022-08-12"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Change; rdfs:label "Sub::HandlesVia::CodeGenerator method_installer is now a rw attribute as Sub::Accessor::Small was relying on that."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.035"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.036"^^xsd:string; dc:issued "2022-08-26"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Bugfix; rdfs:label "Fix integration issues with newer versions of Mite."; ], [ a doap-changeset:Addition; rdfs:label "Add a delete_where method for hashes."; ], [ a doap-changeset:Addition; rdfs:label "Add execute_list, execute_scalar, execute_void, and corresponding _method variants for coderefs."; ], [ a doap-changeset:Addition; rdfs:label "The flatten_deep, natatime, and first_index methods for arrayrefs no longer use callbacks."; ], [ a doap-changeset:Documentation; rdfs:label "Examples for a few methods."; ], [ a doap-changeset:Documentation; rdfs:label "More tests for a few methods."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.036"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.037"^^xsd:string; dc:issued "2022-09-26"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Bugfix; rdfs:label "Hash:set shouldn't hardcode use of Carp::croak. Instead a CodeGenerator should decide how to deal with error messages."; ], [ a doap-changeset:Bugfix; rdfs:label "Fix test case broken by Type::Tiny v2."; doap-changeset:fixes ; doap-changeset:thanks ; rdfs:seeAlso ; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.037"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.038"^^xsd:string; dc:issued "2022-10-21"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Documentation; rdfs:label "Minor changes to documentation for Hash:accessor and Array:accessor."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.038"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.039"^^xsd:string; dc:issued "2022-10-26"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Tests; rdfs:label "Mite has supported Perl 5.8.x for a while now, so Mite-related tests shouldn't be restricted to running on Perl 5.10.1+."; ], [ a doap-changeset:Bugfix; rdfs:label "Fix application of Sub::HandlesVia Moose/Mouse traits to metaobjects that have other traits applied to them."; doap-changeset:fixes ; doap-changeset:thanks ; rdfs:seeAlso ; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.039"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.040"^^xsd:string; dc:issued "2022-10-27"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Bugfix; rdfs:label "Stricter detection of Moo::Role roles to prevent some false positives when given Mouse::Role and Moose::Role roles."; doap-changeset:fixes ; doap-changeset:thanks ; rdfs:seeAlso ; ], [ a doap-changeset:Tests; rdfs:label "Add a test using Sub::HandlesVia when Beam::Wire is loaded."; doap-changeset:fixes ; doap-changeset:thanks ; rdfs:seeAlso ; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.040"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.041"^^xsd:string; dc:issued "2022-10-29"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Addition; rdfs:label "Experimental support for Object::Pad."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.041"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.042"^^xsd:string; dc:issued "2022-10-30"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Change; rdfs:label "Improved support for Object::Pad, including support for non-scalar fields."; ], [ a doap-changeset:Addition; rdfs:label "Sub::HandlesVia::Declare for compile-time declaration of Sub::HandlesVia delegations."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.042"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.043"^^xsd:string; dc:issued "2022-10-31"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Addition; rdfs:label "Sub::HandlesVia::HandlerLibrary methods: handler_names, has_handler, and get_handler."; ], [ a doap-changeset:Addition; rdfs:label "Sub::HandlesVia::HandlerLibrary::Blessed."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.043"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.044"^^xsd:string; dc:issued "2022-10-31"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Documentation; rdfs:label "Moved a lot of pod out of Sub::HandlesVia and into Sub::HandlesVia::Manual::*."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.044"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.045"^^xsd:string; dc:issued "2022-11-08"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Bugfix; rdfs:label "Fix for `with qw(Role1 Role2)` in Moose where at least one role uses Sub::HandlesVia."; doap-changeset:fixes ; doap-changeset:thanks ; rdfs:seeAlso ; ], [ a doap-changeset:Bugfix; rdfs:label "Support attributes declared with `has '+name'`."; doap-changeset:fixes ; doap-changeset:thanks ; rdfs:seeAlso ; ], [ a doap-changeset:Addition; rdfs:label "Add a `generator_for_prelude` attribute to Sub::HandlesVia::CodeGenerator."; doap-changeset:fixes ; rdfs:seeAlso ; ], [ a doap-changeset:Documentation; rdfs:label "Document that `with qw(Role1 Role2)` in Mouse is currently broken if either role uses Sub::HandlesVia."; rdfs:seeAlso ; ], [ a doap-changeset:Tests; rdfs:label "Test that `with qw(Role1 Role2)` in Moo works if either role uses Sub::HandlesVia."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.045"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.046"^^xsd:string; dc:issued "2022-12-16"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Addition; rdfs:label "Sub::HandlesVia::HandlerLibrary::Enum module."; ], [ a doap-changeset:Change; rdfs:label "Handler libraries can now provide constants for shortcuts."; ], [ a doap-changeset:Update; rdfs:label "Rebuild with latest Mite."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.046"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.050000"^^xsd:string; dc:issued "2023-04-05"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Documentation; rdfs:label "Mention potential load-order bugs when importing multiple extensions for Moo into the same package."; ], [ a doap-changeset:Documentation; rdfs:label "Add a few missing references to the Sub::HandlesVia::HandlerLibrary::Enum module to the documentation."; ], [ a doap-changeset:Documentation; rdfs:label "Update Sub::HandlesVia::Manual::Comparison."; ], [ a doap-changeset:Packaging; rdfs:label "Change versioning scheme."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.050000"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.050001"^^xsd:string; dc:issued "2025-03-23"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:Update; rdfs:label "Fix test cases which failed due to Object::Pad dropping the `has` keyword."; ], [ a doap-changeset:Documentation; rdfs:label "Update documentation which is out of date due to Object::Pad dropping the `has` keyword."; ], [ a doap-changeset:Update; rdfs:label "Fix test cases which will fail due to changed error messages in next release of Type::Tiny."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.050001"^^xsd:string. a doap:Version; dc:identifier "Sub-HandlesVia-0.050002"^^xsd:string; dc:issued "2025-03-23"^^xsd:date; doap-changeset:changeset [ doap-changeset:item [ a doap-changeset:SecurityFix; rdfs:label "Rebuild using Mite 0.013000."; ]; ]; doap-changeset:released-by ; doap:file-release ; doap:revision "0.050002"^^xsd:string. a foaf:Person; foaf:homepage ; foaf:name "Bartosz Jarzyna"; foaf:nick "BRTASTIC"; foaf:page , . a foaf:Person; foaf:name "Peter Mottram"; foaf:nick "SYSPETE"; foaf:page , . a foaf:Person; foaf:mbox ; foaf:name "Toby Inkster"; foaf:nick "TOBYINK"; foaf:page . 00begin.t000664001750001750 321614772476615 15205 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse strict; use warnings; use Test::More; sub diag_version { my ($module, $version, $return) = @_; if ($module =~ /\//) { my @modules = split /\s*\/\s*/, $module; my @versions = map diag_version($_, undef, 1), @modules; return @versions if $return; return diag sprintf(' %-43s %s', join("/", @modules), join("/", @versions)); } unless (defined $version) { eval "use $module ()"; $version = $module->VERSION; } if (!defined $version) { return 'undef' if $return; return diag sprintf(' %-40s undef', $module); } my ($major, $rest) = split /\./, $version; $major =~ s/^v//; return "$major\.$rest" if $return; return diag sprintf(' %-40s % 4d.%s', $module, $major, $rest); } sub diag_env { require B; my $var = shift; return diag sprintf(' $%-40s %s', $var, exists $ENV{$var} ? B::perlstring($ENV{$var}) : "undef"); } while () { chomp; if (/^#\s*(.*)$/ or /^$/) { diag($1 || ""); next; } if (/^\$(.+)$/) { diag_env($1); next; } if (/^perl$/) { diag_version("Perl", $]); next; } diag_version($_) if /\S/; } require Types::Standard; diag(""); diag( !Types::Standard::Str()->_has_xsub ? ">>>> Type::Tiny is not using XS" : $INC{'Type/Tiny/XS.pm'} ? ">>>> Type::Tiny is using Type::Tiny::XS" : ">>>> Type::Tiny is using Mouse::XS" ); diag(""); ok 1; done_testing; __END__ perl Exporter::Tiny Type::Tiny/Type::Tiny::XS Scalar::Util/List::Util/Sub::Util Class::Tiny Role::Tiny Class::Method::Modifiers Moo/MooX::TypeTiny/Class::XSAccessor Moose Mouse Test::More/Test::Fatal/Test::Requires $AUTOMATED_TESTING $NONINTERACTIVE_TESTING $EXTENDED_TESTING $AUTHOR_TESTING $RELEASE_TESTING 01basic.t000664001750001750 70314772476615 15161 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t=pod =encoding utf-8 =head1 PURPOSE Test that Sub::HandlesVia compiles. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2020 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut use strict; use warnings; use Test::More; require Sub::HandlesVia; ok 1; done_testing; 02moo.t000664001750001750 516614772476615 14723 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse 5.008; use strict; use warnings; use Test::More; use Test::Fatal; { package Local::Dummy1; use Test::Requires { 'Moo' => '1.006' } }; note 'Local::Bleh'; { package Local::Bleh; use Moo; use Types::Standard -types; use Sub::HandlesVia; has nums => ( is => 'lazy', isa => ArrayRef[ Int->plus_coercions(Num, 'int($_)') ], coerce => 1, builder => sub { [1..2] }, handles_via => 'Array', handles => { splice_nums => 'splice', splice_nums_tap => 'splice...', first_num => [ 'get', 0 ], }, ); } my $bleh = Local::Bleh->new; my @r = $bleh->splice_nums(0, 2, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method worked'); is_deeply(\@r, [1..2], '... and returned correct value'); is($bleh->first_num, 3, 'curried delegated method worked'); my $e = exception { $bleh->splice_nums(1, 0, "foo"); }; like($e, qr/Value "foo" did not pass type constraint/, 'delegated method checked incoming types'); is_deeply($bleh->nums, [3..5], '... and kept the value safe'); my $ref = $bleh->nums; $bleh->splice_nums(1, 0, '3.111'); is_deeply($bleh->nums, [3, 3, 4, 5], 'delegated coerced value'); my $ref2 = $bleh->nums; is("$ref", "$ref2", '... without needing to build a new arrayref') or do { require B::Deparse; diag( B::Deparse->new->coderef2text(\&Local::Bleh::splice_nums) ); }; $bleh = Local::Bleh->new; @r = $bleh->splice_nums_tap(0, 2, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method with chaining worked'); is_deeply(\@r, [$bleh], '... and returned correct value'); note 'Local::Bleh2'; { package Local::Bleh2; use Moo; use Types::Standard -types; use Sub::HandlesVia; has nums => ( is => 'lazy', isa => ArrayRef->of(Int->plus_coercions(Num, 'int($_)'))->where('1', coercion=>1), builder => sub { [] }, coerce => 1, handles_via => 'Array', handles => { splice_nums => 'splice', first_num => [ 'get', 0 ], }, ); } $bleh = Local::Bleh2->new; $bleh->splice_nums(0, 0, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method worked'); is($bleh->first_num, 3, 'curried delegated method worked'); $e = exception { $bleh->splice_nums(1, 0, "foo"); }; like($e, qr/type constraint/, 'delegated method has to do naive type check') or do { require B::Deparse; diag( B::Deparse->new->coderef2text(\&Local::Bleh2::splice_nums) ); }; is_deeply($bleh->nums, [3..5], '... and kept the value safe'); $ref = $bleh->nums; $bleh->splice_nums(1, 0, '3.111'); is_deeply($bleh->nums, [3, 3, 4, 5], 'delegated coerced value'); $ref2 = $bleh->nums; isnt("$ref", "$ref2", '... but sadly needed to build a new arrayref'); done_testing; 03moo_mxtt.t000664001750001750 526714772476615 16002 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse 5.008; use strict; use warnings; use Test::More; use Test::Fatal; { package Local::Dummy1; use Test::Requires 'Moo'; use Test::Requires 'MooX::TypeTiny'; }; note 'Local::Bleh'; { package Local::Bleh; use Moo; use MooX::TypeTiny; use Types::Standard -types; use Sub::HandlesVia; has nums => ( is => 'lazy', isa => ArrayRef[ Int->plus_coercions(Num, 'int($_)') ], coerce => 1, builder => sub { [1..2] }, handles_via => 'Array', handles => { splice_nums => 'splice', splice_nums_tap => 'splice...', first_num => [ 'get', 0 ], }, ); } my $bleh = Local::Bleh->new; my @r = $bleh->splice_nums(0, 2, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method worked'); is_deeply(\@r, [1..2], '... and returned correct value'); is($bleh->first_num, 3, 'curried delegated method worked'); my $e = exception { $bleh->splice_nums(1, 0, "foo"); }; like($e, qr/Value "foo" did not pass type constraint/, 'delegated method checked incoming types'); is_deeply($bleh->nums, [3..5], '... and kept the value safe'); my $ref = $bleh->nums; $bleh->splice_nums(1, 0, '3.111'); is_deeply($bleh->nums, [3, 3, 4, 5], 'delegated coerced value'); my $ref2 = $bleh->nums; is("$ref", "$ref2", '... without needing to build a new arrayref') or do { require B::Deparse; diag( B::Deparse->new->coderef2text(\&Local::Bleh::splice_nums) ); }; $bleh = Local::Bleh->new; @r = $bleh->splice_nums_tap(0, 2, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method with chaining worked'); is_deeply(\@r, [$bleh], '... and returned correct value'); note 'Local::Bleh2'; { package Local::Bleh2; use Moo; use MooX::TypeTiny; use Types::Standard -types; use Sub::HandlesVia; has nums => ( is => 'lazy', isa => ArrayRef->of(Int->plus_coercions(Num, 'int($_)'))->where('1', coercion=>1), builder => sub { [] }, coerce => 1, handles_via => 'Array', handles => { splice_nums => 'splice', first_num => [ 'get', 0 ], }, ); } $bleh = Local::Bleh2->new; $bleh->splice_nums(0, 0, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method worked'); is($bleh->first_num, 3, 'curried delegated method worked'); $e = exception { $bleh->splice_nums(1, 0, "foo"); }; like($e, qr/type constraint/, 'delegated method has to do naive type check') or do { require B::Deparse; diag( B::Deparse->new->coderef2text(\&Local::Bleh2::splice_nums) ); }; is_deeply($bleh->nums, [3..5], '... and kept the value safe'); $ref = $bleh->nums; $bleh->splice_nums(1, 0, '3.111'); is_deeply($bleh->nums, [3, 3, 4, 5], 'delegated coerced value'); $ref2 = $bleh->nums; isnt("$ref", "$ref2", '... but sadly needed to build a new arrayref'); done_testing; 04moose.t000664001750001750 551414772476615 15252 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse 5.008; use strict; use warnings; use Test::More; use Test::Fatal; { package Local::Dummy1; use Test::Requires 'Moose' }; note 'Local::Bleh'; { package Local::Bleh; use Moose; use Types::Standard -types; use Sub::HandlesVia; has nums => ( is => 'ro', lazy => 1, isa => ArrayRef[ Int->plus_coercions(Num, 'int($_)') ], coerce => 1, builder => '_build_nums', handles_via => 'Array', handles => { splice_nums => 'splice', splice_nums_tap => 'splice...', first_num => [ 'get', 0 ], }, ); sub _build_nums { [1..2] } } my $bleh = Local::Bleh->new; my @r = $bleh->splice_nums(0, 2, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method worked'); is_deeply(\@r, [1..2], '... and returned correct value'); is($bleh->first_num, 3, 'curried delegated method worked'); my $e = exception { $bleh->splice_nums(1, 0, "foo"); }; like($e, qr/Value "foo" did not pass type constraint/, 'delegated method checked incoming types'); is_deeply($bleh->nums, [3..5], '... and kept the value safe'); my $ref = $bleh->nums; $bleh->splice_nums(1, 0, '3.111'); is_deeply($bleh->nums, [3, 3, 4, 5], 'delegated coerced value'); my $ref2 = $bleh->nums; isnt("$ref", "$ref2", '... but needed to build a new array') or do { require B::Deparse; diag( B::Deparse->new->coderef2text(\&Local::Bleh::splice_nums) ); }; $bleh = Local::Bleh->new; @r = $bleh->splice_nums_tap(0, 2, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method with chaining worked'); is_deeply(\@r, [$bleh], '... and returned correct value'); note 'Local::Bleh2'; { package Local::Bleh2; use Moose; use Types::Standard -types; use Sub::HandlesVia; has nums => ( is => 'ro', lazy => 1, isa => ArrayRef->of(Int->plus_coercions(Num, 'int($_)'))->where('1', coercion=>1), builder => '_build_nums', coerce => 1, handles_via => 'Array', handles => { splice_nums => 'splice', first_num => [ 'get', 0 ], }, ); sub _build_nums { [] } } $bleh = Local::Bleh2->new; $bleh->splice_nums(0, 0, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method worked') or do { diag explain($bleh->nums); require B::Deparse; diag( B::Deparse->new->coderef2text(\&Local::Bleh2::splice_nums) ); }; is($bleh->first_num, 3, 'curried delegated method worked'); $e = exception { $bleh->splice_nums(1, 0, "foo"); }; like($e, qr/type constraint/, 'delegated method has to do naive type check') or do { require B::Deparse; diag( B::Deparse->new->coderef2text(\&Local::Bleh::splice_nums) ); }; is_deeply($bleh->nums, [3..5], '... and kept the value safe'); $ref = $bleh->nums; $bleh->splice_nums(1, 0, '3.111'); is_deeply($bleh->nums, [3, 3, 4, 5], 'delegated coerced value'); $ref2 = $bleh->nums; isnt("$ref", "$ref2", '... but sadly needed to build a new arrayref'); done_testing; 05moose_nativetypes.t000664001750001750 331314772476615 17701 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse 5.008; use strict; use warnings; use Test::More; use Test::Fatal; { package Local::Dummy1; use Test::Requires 'Moose' }; use Moose::Util::TypeConstraints; type 'MyArrayRefOfInt', as 'ArrayRef[Int]'; coerce 'MyArrayRefOfInt', from 'ArrayRef[Num]', via { die "COERCION CALLED ON @$_"; [ map int($_), @$_ ] }; note 'Local::Bleh'; { package Local::Bleh; use Moose; use Sub::HandlesVia; has nums => ( is => 'ro', lazy => 1, isa => 'MyArrayRefOfInt', coerce => 1, builder => '_build_nums', handles_via => 'Array', handles => { splice_nums => 'splice', splice_nums_tap => 'splice...', first_num => [ 'get', 0 ], }, ); sub _build_nums { [1..2] } } my $bleh = Local::Bleh->new; my @r = $bleh->splice_nums(0, 2, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method worked'); is_deeply(\@r, [1..2], '... and returned correct value'); is($bleh->first_num, 3, 'curried delegated method worked'); { local $TODO = 'this is currently broken'; my $e = exception { $bleh->splice_nums(1, 0, "foo"); }; like($e, qr/does not pass the type constraint/, 'delegated method checked incoming types'); is_deeply($bleh->nums, [3..5], '... and kept the value safe'); } my $ref; { local $TODO = 'this is currently broken'; $ref = $bleh->nums; $bleh->splice_nums(1, 0, '3.111'); is_deeply($bleh->nums, [3, 3, 4, 5], 'delegated coerced value'); } my $ref2 = $bleh->nums; isnt("$ref", "$ref2", '... but sadly needed to build a new arrayref'); $bleh = Local::Bleh->new; @r = $bleh->splice_nums_tap(0, 2, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method with chaining worked'); is_deeply(\@r, [$bleh], '... and returned correct value'); done_testing; 06mouse.t000664001750001750 522314772476615 15257 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse 5.008; use strict; use warnings; use Test::More; use Test::Fatal; { package Local::Dummy1; use Test::Requires 'Mouse' }; note 'Local::Bleh'; { package Local::Bleh; use Mouse; use Types::Standard -types; use Sub::HandlesVia; has nums => ( is => 'ro', lazy => 1, isa => ArrayRef[ Int->plus_coercions(Num, 'int($_)') ], coerce => 1, builder => sub { [1..2] }, handles_via => 'Array', handles => { splice_nums => 'splice', splice_nums_tap => 'splice...', first_num => [ 'get', 0 ], }, ); } my $bleh = Local::Bleh->new; my @r = $bleh->splice_nums(0, 2, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method worked'); is_deeply(\@r, [1..2], '... and returned correct value'); is($bleh->first_num, 3, 'curried delegated method worked'); my $e = exception { $bleh->splice_nums(1, 0, "foo"); }; like($e, qr/Value "foo" did not pass type constraint/, 'delegated method checked incoming types'); is_deeply($bleh->nums, [3..5], '... and kept the value safe'); my $ref = $bleh->nums; $bleh->splice_nums(1, 0, '3.111'); is_deeply($bleh->nums, [3, 3, 4, 5], 'delegated coerced value'); my $ref2 = $bleh->nums; is("$ref", "$ref2", '... without needing to build a new arrayref') or do { require B::Deparse; diag( B::Deparse->new->coderef2text(\&Local::Bleh::splice_nums) ); }; $bleh = Local::Bleh->new; @r = $bleh->splice_nums_tap(0, 2, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method with chaining worked'); is_deeply(\@r, [$bleh], '... and returned correct value'); note 'Local::Bleh2'; { package Local::Bleh2; use Mouse; use Types::Standard -types; use Sub::HandlesVia; has nums => ( is => 'ro', lazy => 1, isa => ArrayRef->of(Int->plus_coercions(Num, 'int($_)'))->where('1', coercion=>1), builder => sub { [] }, coerce => 1, handles_via => 'Array', handles => { splice_nums => 'splice', first_num => [ 'get', 0 ], }, ); } $bleh = Local::Bleh2->new; $bleh->splice_nums(0, 0, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method worked'); is($bleh->first_num, 3, 'curried delegated method worked'); $e = exception { $bleh->splice_nums(1, 0, "foo"); }; like($e, qr/type constraint/, 'delegated method has to do naive type check') or do { require B::Deparse; diag( B::Deparse->new->coderef2text(\&Local::Bleh2::splice_nums) ); }; is_deeply($bleh->nums, [3..5], '... and kept the value safe'); $ref = $bleh->nums; $bleh->splice_nums(1, 0, '3.111'); is_deeply($bleh->nums, [3, 3, 4, 5], 'delegated coerced value'); $ref2 = $bleh->nums; isnt("$ref", "$ref2", '... but sadly needed to build a new arrayref'); done_testing; 07mouse_nativetypes.t000664001750001750 321514772476615 17712 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse 5.008; use strict; use warnings; use Test::More; use Test::Fatal; { package Local::Dummy1; use Test::Requires 'Mouse' }; use Mouse::Util::TypeConstraints; type 'MyArrayRefOfInt', as 'ArrayRef[Int]'; coerce 'MyArrayRefOfInt', from 'ArrayRef[Num]', via { [ map int($_), @$_ ] }; note 'Local::Bleh'; { package Local::Bleh; use Mouse; use Sub::HandlesVia; has nums => ( is => 'ro', lazy => 1, isa => 'MyArrayRefOfInt', coerce => 1, builder => sub { [1..2] }, handles_via => 'Array', handles => { splice_nums => 'splice', splice_nums_tap => 'splice...', first_num => [ 'get', 0 ], }, ); } my $bleh = Local::Bleh->new; my @r = $bleh->splice_nums(0, 2, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method worked'); is_deeply(\@r, [1..2], '... and returned correct value'); is($bleh->first_num, 3, 'curried delegated method worked'); my $e = exception { $bleh->splice_nums(1, 0, "foo"); }; like($e, qr/does not pass the type constraint/, 'delegated method checked incoming types'); is_deeply($bleh->nums, [3..5], '... and kept the value safe'); my $ref = $bleh->nums; $bleh->splice_nums(1, 0, '3.111'); is_deeply($bleh->nums, [3, 3, 4, 5], 'delegated coerced value'); my $ref2 = $bleh->nums; isnt("$ref", "$ref2", '... but sadly needed to build a new arrayref') or do { require B::Deparse; diag( B::Deparse->new->coderef2text(\&Local::Bleh::splice_nums) ); }; $bleh = Local::Bleh->new; @r = $bleh->splice_nums_tap(0, 2, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method with chaining worked'); is_deeply(\@r, [$bleh], '... and returned correct value'); done_testing; 08classtiny.t000664001750001750 166314772476615 16146 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse 5.008; use strict; use warnings; use Test::More; use Test::Fatal; { package Local::Dummy1; use Test::Requires 'Class::Tiny' }; note 'Local::Bleh'; { package Local::Bleh; use Sub::HandlesVia qw( delegations ); use Class::Tiny { nums => sub { [1..2] }, # lazy builder }; delegations( attribute => 'nums', handles_via => 'Array', handles => { splice_nums => 'splice', splice_nums_tap => 'splice...', first_num => [ 'get', 0 ], }, ); } my $bleh = Local::Bleh->new; my @r = $bleh->splice_nums(0, 2, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method worked'); is_deeply(\@r, [1..2], '... and returned correct value'); is($bleh->first_num, 3, 'curried delegated method worked'); $bleh = Local::Bleh->new; @r = $bleh->splice_nums_tap(0, 2, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method with chaining worked'); is_deeply(\@r, [$bleh], '... and returned correct value'); done_testing; 09barebones.t000664001750001750 220514772476615 16067 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse 5.008; use strict; use warnings; use Test::More; use Test::Fatal; note 'Local::Bleh'; { package Local::Bleh; use Sub::HandlesVia qw( delegations ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my %args = (@_==1) ? %{$_[0]} : @_; my $self = bless(\%args, $class); return $self; } sub nums { my $self = shift; if (@_) { return ($self->{nums} = $_[0]); } $self->{nums} ||= $self->_build_nums; } sub _build_nums { return [ 1..2 ]; } delegations( attribute => 'nums', handles_via => 'Array', handles => { splice_nums => 'splice', splice_nums_tap => 'splice...', first_num => [ 'get', 0 ], }, ); } my $bleh = Local::Bleh->new; my @r = $bleh->splice_nums(0, 2, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method worked'); is_deeply(\@r, [1..2], '... and returned correct value'); is($bleh->first_num, 3, 'curried delegated method worked'); $bleh = Local::Bleh->new; @r = $bleh->splice_nums_tap(0, 2, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method with chaining worked'); is_deeply(\@r, [$bleh], '... and returned correct value'); done_testing; 10barebones_eagerbuilder.t000664001750001750 241514772476615 20574 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse 5.008; use strict; use warnings; use Test::More; use Test::Fatal; note 'Local::Bleh'; { package Local::Bleh; use Sub::HandlesVia qw( delegations ); sub new { my $proto = shift; my $class = ref($proto) || $proto; my %args = (@_==1) ? %{$_[0]} : @_; my $self = bless(\%args, $class); $self->{nums} ||= $self->_build_nums; return $self; } sub nums { my $self = shift; if (@_) { return ($self->{nums} = $_[0]); } $self->{nums}; } sub _build_nums { return [ 1..2 ]; } delegations( attribute => '{nums}', handles_via => 'Array', handles => { splice_nums => 'splice', splice_nums_tap => 'splice...', first_num => [ 'get', 0 ], }, ); } my $bleh = Local::Bleh->new; my @r = $bleh->splice_nums(0, 2, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method worked'); is_deeply(\@r, [1..2], '... and returned correct value'); is($bleh->first_num, 3, 'curried delegated method worked'); $bleh = Local::Bleh->new; @r = $bleh->splice_nums_tap(0, 2, 3..5); is_deeply($bleh->nums, [3..5], 'delegated method with chaining worked'); is_deeply(\@r, [$bleh], '... and returned correct value'); #use B::Deparse; #my $bdp = B::Deparse->new; #diag explain( $bdp->coderef2text( \&Local::Bleh::splice_nums_tap ) ); done_testing; 11delegation.t000664001750001750 430714772476615 16240 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse 5.008; use strict; use warnings; use Test::More; use Test::Fatal; { package Local::Dummy1; use Test::Requires 'Moo' }; { package Local::Wheel; use Moo; has colour => (is => 'bare', default => 'black'); sub spin { 'spinning' } } { package Local::Unicycle; use Moo; use Sub::HandlesVia; use Types::Standard qw( Object ); has wheel => ( is => 'bare', isa => Object, traits => ['Hash'], handles => { spin => 'spin', wheel_ref => [ sub { join '|', map ref, @_ }, [] ], wheel_colour => [ get => 'colour' ], hack => 'Code->execute', }, default => sub { Local::Wheel->new }, ); } my $unicycle = Local::Unicycle->new; die if eval { $unicycle->wheel }; die if eval { $unicycle->{wheel}->colour }; for my $method (qw/spin wheel_ref wheel_colour/) { local $Data::Dumper::Deparse = 1; note "==== Local::Unicycle::$method ===="; note explain( $unicycle->can($method) ); } is( $unicycle->spin, 'spinning', ); is( $unicycle->wheel_ref({}), 'Local::Wheel|ARRAY|HASH', ); is( $unicycle->wheel_colour, 'black', ); $unicycle->{wheel} = sub { 'yay' }; is( $unicycle->hack, 'yay', ); { package Local::Bike; use Moo; use Sub::HandlesVia; use Types::Standard qw( Object ); has front_wheel => ( is => 'bare', isa => Object, traits => ['Blessed'], handles => { spin_front => 'spin', colour_front => [ 'Hash->get' => 'colour' ], bleh => '123foo', }, default => sub { Local::Wheel->new }, ); has back_wheel => ( is => 'bare', isa => Object, traits => ['Blessed'], handles => { spin_back => 'spin', colour_back => [ 'Hash->get' => 'colour' ], }, default => sub { Local::Wheel->new }, ); } { no strict 'refs'; *{'Local::Wheel::123foo'} = sub { 'wow' }; } my $bike = Local::Bike->new; is( $bike->spin_front, 'spinning' ); is( $bike->spin_back, 'spinning' ); is( $bike->colour_front, 'black' ); is( $bike->colour_back, 'black' ); is( $bike->bleh, 'wow' ); for my $method (qw/spin_front spin_back colour_front colour_back bleh/) { local $Data::Dumper::Deparse = 1; note "==== Local::Bike::$method ===="; note explain( $bike->can($method) ); } done_testing; 12slotaccess.t000664001750001750 354614772476615 16275 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse strict; use warnings; use Test::More; { package Local::Dummy1; use Test::Requires 'Moo' }; { package Local::Dummy1; use Test::Requires 'Moose' }; { package Local::Dummy1; use Test::Requires 'MooseX::ArrayRef' }; { package Local::Dummy1; use Test::Requires 'MooseX::InsideOut' }; { package Local::Dummy1; use Test::Requires 'Mouse' }; { package Local::Class1; use Moo; use Sub::HandlesVia; has foo => ( is => 'ro', lazy => 1, default => sub { 665 }, handles_via => 'Scalar', handles => { ref_to_foo => 'scalar_reference', }, ); } { package Local::Class2; use Moose; use Sub::HandlesVia; has foo => ( is => 'ro', lazy => 1, default => sub { 665 }, handles_via => 'Scalar', handles => { ref_to_foo => 'scalar_reference', }, ); } { package Local::Class3; use Mouse; use Sub::HandlesVia; has foo => ( is => 'ro', lazy => 1, default => sub { 665 }, handles_via => 'Scalar', handles => { ref_to_foo => 'scalar_reference', }, ); } { package Local::Class4; use MooseX::ArrayRef; use Sub::HandlesVia; has foo => ( is => 'ro', lazy => 1, default => sub { 665 }, handles_via => 'Scalar', handles => { ref_to_foo => 'scalar_reference', }, ); } { package Local::Class5; use MooseX::InsideOut; use Sub::HandlesVia; has foo => ( is => 'ro', lazy => 1, default => sub { 665 }, handles_via => 'Scalar', handles => { ref_to_foo => 'scalar_reference', }, ); } require B::Deparse; for my $i (1 .. 5) { my $class = "Local::Class$i"; note "sub $class\::ref_to_foo"; note(B::Deparse->new->coderef2text($class->can('ref_to_foo'))); my $obj = $class->new(); my $ref = $obj->ref_to_foo; is(ref($ref), 'SCALAR'); ++$$ref; is($obj->foo, 666); } done_testing;14enum.t000664001750001750 325614772476615 15076 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse 5.008; use strict; use warnings; use Test::More; use Test::Fatal; { package Local::Dummy1; use Test::Requires 'Moo' }; { package Local::Bleh; use Moo; use Types::Standard -types; use Sub::HandlesVia; has status => ( is => 'ro', lazy => 1, isa => Enum[qw/ pass fail unknown /], coerce => 1, builder => '_build_status', handles_via => 'Enum', handles => { is_pass => 'is_pass', is_fail => 'is_fail', is_unknown => 'is_unknown', assign_pass => 'assign_pass', assign_fail => 'assign_fail', assign_unknown => 'assign_unknown', is => 'is', assign => 'assign', }, ); sub _build_status { 'unknown' } } my $obj = Local::Bleh->new; is( $obj->status, 'unknown' ); ok( $obj->is( 'unknown' ) ); ok( $obj->is_unknown ); $obj->assign_pass; is( $obj->status, 'pass' ); ok( $obj->is( 'pass' ) ); ok( $obj->is_pass ); $obj->assign( 'fail' ); is( $obj->status, 'fail' ); ok( $obj->is( 'fail' ) ); ok( $obj->is_fail ); { package Local::Bleh2; use Moo; use Types::Standard -types; use Sub::HandlesVia; use Sub::HandlesVia::HandlerLibrary::Enum; has status => ( is => 'ro', lazy => 1, coerce => 1, builder => '_build_status', handles_via => 'Enum', enum => [qw/ pass fail unknown /], handles => HandleIs | HandleNamedSet, ); sub _build_status { 'unknown' } } my $obj2 = Local::Bleh2->new; is( $obj2->status, 'unknown' ); ok( $obj2->is_unknown ); $obj2->status_set_pass; is( $obj2->status, 'pass' ); ok( $obj2->is_pass ); $obj2->status_set_fail; is( $obj2->status, 'fail' ); ok( $obj2->is_fail ); done_testing; 15preludes.t000664001750001750 235514772476615 15755 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse strict; use warnings; use Test::More; use Sub::HandlesVia::CodeGenerator; use Sub::HandlesVia::HandlerLibrary::Array; my $gen = 'Sub::HandlesVia::CodeGenerator'->new( toolkit => __PACKAGE__, target => 'My::Class', attribute => 'attr', env => {}, coerce => !!0, generator_for_slot => sub { my $self = shift->generate_self; "$self\->{attr}" }, generator_for_get => sub { my $self = shift->generate_self; "$self\->{attr}" }, generator_for_set => sub { my $self = shift->generate_self; "( $self\->{attr} = @_ )" }, get_is_lvalue => !!0, set_checks_isa => !!1, set_strictly => !!1, generator_for_default => sub { 'undef' }, generator_for_prelude => sub { 'my $GUARD = undef;' }, ); my $push = 'Sub::HandlesVia::HandlerLibrary::Array'->get_handler( 'push' ); my $ec_args = $gen->_generate_ec_args_for_handler( 'my_push', $push ); my $coderef = $gen->generate_coderef_for_handler( 'my_push', $push ); my ( $found ) = grep /GUARD/, @{ $ec_args->{source} }; is( $found, 'my $GUARD = undef;' ); my $foo = bless { attr => [] }, 'My::Class'; $foo->$coderef( 1, 2, 3 ); $foo->$coderef( 4 ); is_deeply( $foo->{attr}, [1..4] ); done_testing;16stackqueue.t000664001750001750 277014772476615 16306 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse 5.008; use strict; use warnings; use Test::More; use Test::Fatal; { package Local::Dummy1; use Test::Requires 'Moo' }; { package Local::Stack; use Moo; use Sub::HandlesVia; use Sub::HandlesVia::HandlerLibrary::Array; has items => ( is => 'bare', lazy => 1, coerce => 1, builder => sub { [] }, handles_via => 'Array', handles => HandleStack, ); } my $stack = Local::Stack->new(); ok( $stack->items_is_empty ); $stack->items_push( 11 .. 15 ); ok( ! $stack->items_is_empty ); is( $stack->items_size, 5 ); is( $stack->items_peek, 15 ); is( $stack->items_pop, 15 ); is( $stack->items_pop, 14 ); is( $stack->items_pop, 13 ); is( $stack->items_pop, 12 ); is( $stack->items_pop, 11 ); ok( $stack->items_is_empty ); is( $stack->items_size, 0 ); { package Local::Queue; use Moo; use Sub::HandlesVia; use Sub::HandlesVia::HandlerLibrary::Array; has items => ( is => 'bare', lazy => 1, coerce => 1, builder => sub { [] }, handles_via => 'Array', handles => [ HandleQueue, { all_items => 'all' } ], ); } my $q = Local::Queue->new(); ok( $q->items_is_empty ); $q->items_enqueue( 11 .. 15 ); ok( ! $q->items_is_empty ); is( $q->items_size, 5 ); is( $q->items_peek, 11 ); is( $q->items_dequeue, 11 ); is( $q->items_dequeue, 12 ); is( $q->items_dequeue, 13 ); is_deeply( [ $q->all_items ], [ 14, 15 ] ); is( $q->items_dequeue, 14 ); is( $q->items_dequeue, 15 ); ok( $q->items_is_empty ); is( $q->items_size, 0 ); done_testing; 20moosex_extended.t000664001750001750 250314772476615 17313 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t=pod =encoding utf-8 =head1 PURPOSE Test that Sub::HandlesVia works with MooseX::Extended's C and C functions. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut use 5.008; use strict; use warnings; use Test::More; BEGIN { eval { require MooseX::Extended; 1 } or plan skip_all => 'test requires MooseX::Extended'; }; BEGIN { package Local::MyClass; use MooseX::Extended types => [ 'Str' ]; use Sub::HandlesVia; has eg1 => ( is => 'ro', isa => Str, handles_via => 'String', handles => { eg1_append => 'append...' }, ); field eg2 => ( is => 'ro', isa => Str, handles_via => 'String', handles => { eg2_append => 'append...' }, default => sub { 'eg2' }, ); param eg3 => ( is => 'ro', isa => Str, handles_via => 'String', handles => { eg3_append => 'append...' }, ); }; my $obj = Local::MyClass->new( eg1 => 'eg1', # eg2 => 'eg2', eg3 => 'eg3', )->eg1_append( 'x' )->eg2_append( 'x' )->eg3_append( 'x' ); is( $obj->eg1, 'eg1x', 'has attribute' ); is( $obj->eg2, 'eg2x', 'field attribute' ); is( $obj->eg3, 'eg3x', 'param attribute' ); done_testing; 31egpod_dummy.t000664001750001750 173214772476615 16437 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t=pod =encoding utf-8 =head1 PURPOSE Simple test file that just calls _example() on all handlers to ensure coverage. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut use strict; use warnings; use Test::More; use Test::Fatal; my @categories = qw( Array Bool Code Counter Hash Number Scalar String ); for my $c ( @categories ) { my $class = "Sub::HandlesVia::HandlerLibrary::$c"; eval "require $class" or die($@); my @funcs = do { no strict 'refs'; @{"$class\::METHODS"} }; for my $f ( @funcs ) { my $h = $class->$f; if ( $h->_examples ) { my $e = exception { my @eg = $h->_examples->( qw/ a b c / ); }; is( $e, undef, "$c->$f->_examples->( ... )" ); } else { ok( 1, "$c->$f skipped" ); } } } done_testing; 50objectpad.t000664001750001750 202514772476615 16056 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse strict; use warnings; use Test::More; { package Local::Dummy1; use Test::Requires { 'Object::Pad' => 0.73 }; } ############################################################################## use Object::Pad; class FooBar { field $x :reader = []; use Sub::HandlesVia::Declare '$x', Array => ( all_x => 'all', add_x => 'push', ); field @y; use Sub::HandlesVia::Declare '@y', ( all_y => 'all', add_y => 'push', ); field %z; use Sub::HandlesVia::Declare '%z', ( all_z => 'all', add_z => 'set', ); } my $o = FooBar->new; $o->add_x( 123 ); $o->add_x( 456 ); is_deeply( $o->x, [ 123, 456 ] ); is_deeply( [ $o->all_x ], [ 123, 456 ] ); $o->add_y( 123 ); $o->add_y( 456 ); is_deeply( [ $o->all_y ], [ 123, 456 ] ); $o->add_z( foo => 123 ); $o->add_z( bar => 456 ); is_deeply( { $o->all_z }, { bar => 456, foo => 123 } ); for my $method ( qw/ add_x all_x add_y all_y add_z all_z / ) { no warnings 'once'; local $Data::Dumper::Deparse = 1; note "==== $method ===="; note explain( $o->can($method) ); } done_testing; 60detect.t000664001750001750 45314772476615 15357 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse Test::More; { package Local::Dummy1; use Test::Requires 'Moo::Role' }; { package Local::Dummy2; use Test::Requires 'Mouse::Role' }; { package ThisFailsRole; use Mouse::Role; use Sub::HandlesVia; } is( Sub::HandlesVia->_detect_framework('ThisFailsRole'), 'Mouse', 'role ok' ); done_testing; 61moosemetagubbins.t000664001750001750 215714772476615 17476 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse 5.008001; use strict; use warnings; { package Local::Dummy1; use Test::Requires 'Moose' }; BEGIN { package My::Trait::AutoSetters; use Moose::Role; around add_attribute => sub { my ($orig, $self, $name, @args) = @_; my %params = @args == 1 ? %{$args[0]} : @args; if (exists $params{writer} && !$params{writer}) { delete $params{writer}; return $self->$orig($name, %params); } # exit early if it's not something we want or can alter return $self->$orig($name, @args) if $name =~ /^_/ || $name =~ /^\+/; $params{writer} //= "set_$name"; my $attribute = $self->$orig($name, %params); return $attribute; }; }; { package Parent; use Moose -traits => [qw( My::Trait::AutoSetters )]; use Sub::HandlesVia; } { package ThisFails; use Moose; use Sub::HandlesVia; extends 'Parent'; has test => ( is => 'ro', default => sub { [] }, handles_via => 'Array', handles => { 'add_test' => 'push...' } ); } my $t = ThisFails->new; $t->set_test([3]); $t->add_test(5)->add_test(6)->add_test(7); use Test::More; is_deeply( $t->test, [ 3, 5, 6, 7 ], 'yay', ); done_testing; 62mousemetagubbins.t000664001750001750 215614772476615 17504 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse 5.008001; use strict; use warnings; { package Local::Dummy1; use Test::Requires 'Mouse' }; BEGIN { package My::Trait::AutoSetters; use Mouse::Role; around add_attribute => sub { my ($orig, $self, $name, @args) = @_; my %params = @args == 1 ? %{$args[0]} : @args; if (exists $params{writer} && !$params{writer}) { delete $params{writer}; return $self->$orig($name, %params); } # exit early if it's not something we want or can alter return $self->$orig($name, @args) if $name =~ /^_/ || $name =~ /^\+/; $params{writer} //= "set_$name"; my $attribute = $self->$orig($name, %params); return $attribute; }; }; { package Parent; use Mouse -traits => [qw( My::Trait::AutoSetters )]; use Sub::HandlesVia; } { package ThisFails; use Mouse; use Sub::HandlesVia; extends 'Parent'; has test => ( is => 'ro', default => sub { [] }, handles_via => 'Array', handles => { 'add_test' => 'push...' } ); } my $t = ThisFails->new; $t->set_test([3]); $t->add_test(5)->add_test(6)->add_test(7); use Test::More; is_deeply( $t->test, [ 3, 5, 6, 7 ], 'yay', ); done_testing; 80beam.t000664001750001750 54514772476615 15017 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse strict; use warnings; use Test::More; use Test::Requires 'Beam::Wire'; { package Local::Dummy1; use Test::Requires 'Moose::Role' }; package ThisFailsRole { use Moose::Role; use Sub::HandlesVia; has 'test' => ( is => 'rw', default => sub { [] }, handles_via => 'Array', handles => { 'add_test' => 'push', } ); } pass; done_testing; 81mxpa.t000664001750001750 130514772476615 15074 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse strict; use warnings; use Test::More; { package Local::Dummy; use Test::Requires 'Moo'; use Test::Requires 'MooX::ProtectedAttributes'; use Test::Requires 'MooX::Should'; use Test::Requires 'Types::Standard'; }; { package Local::TestClass; use Moo; use MooX::Should; use Sub::HandlesVia; use MooX::ProtectedAttributes; use Types::Standard 'Bool'; protected_has _client_halted => ( is => 'rw', should => Bool, reader => '_has_client_halted', default => 0, handles_via => 'Bool', handles => { _halt_client => 'set', }, ); } my $client = Local::TestClass->new(); $client->_halt_client(); ok( $client->{_client_halted} ); done_testing; 94cmp.t000664001750001750 1141214772476615 14732 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse strict; use warnings; use Test::More; { package Local::Dummy; use Test::Requires { 'Moo' => '1.006' } }; { package Local::Class; use Moo; use Sub::HandlesVia; has my_num => ( is => 'rw', handles_via => 'Number', handles => { map { 1; "my_num_$_" => $_ } qw( cmp eq ne lt gt le ge ) }, default => 0, ); has my_str => ( is => 'rw', handles_via => 'String', handles => { ( map { 1; "my_str_$_" => $_ } qw( uc lc fc ) ), ( map { 1; "my_str_$_" => $_, "my_str_$_".'_i' => $_.'_i' } qw( match contains starts_with ends_with ) ), ( map { 1; "my_str_$_" => $_, "my_str_$_".'i' => $_.'i' } qw( cmp eq ne lt gt le ge ) ), }, default => '', ); } my $object = 'Local::Class'->new; my $ok = !!1; my $notok = !!0; my @cases = ( [ my_str => eq => ( 'foo', 'foo' ) => $ok ], [ my_str => eq => ( 'foo', 'bar' ) => $notok ], [ my_str => ne => ( 'foo', 'foo' ) => $notok ], [ my_str => ne => ( 'foo', 'bar' ) => $ok ], [ my_str => cmp => ( 'foo', 'foo' ) => $notok ], [ my_str => cmp => ( 'foo', 'bar' ) => $ok ], [ my_str => cmp => ( 'foo', 'xyz' ) => $ok ], [ my_str => lt => ( 'foo', 'foo' ) => $notok ], [ my_str => lt => ( 'foo', 'bar' ) => $notok ], [ my_str => lt => ( 'foo', 'xyz' ) => $ok ], [ my_str => le => ( 'foo', 'foo' ) => $ok ], [ my_str => le => ( 'foo', 'bar' ) => $notok ], [ my_str => le => ( 'foo', 'xyz' ) => $ok ], [ my_str => gt => ( 'foo', 'foo' ) => $notok ], [ my_str => gt => ( 'foo', 'bar' ) => $ok ], [ my_str => gt => ( 'foo', 'xyz' ) => $notok ], [ my_str => ge => ( 'foo', 'foo' ) => $ok ], [ my_str => ge => ( 'foo', 'bar' ) => $ok ], [ my_str => ge => ( 'foo', 'xyz' ) => $notok ], [ my_str => eq => ( 'foo', 'FOO' ) => $notok ], [ my_str => ne => ( 'foo', 'FOO' ) => $ok ], [ my_str => eqi => ( 'foo', 'FOO' ) => $ok ], [ my_str => nei => ( 'foo', 'FOO' ) => $notok ], [ my_num => eq => ( 42, 42 ) => $ok ], [ my_num => eq => ( 42, 18 ) => $notok ], [ my_num => ne => ( 42, 42 ) => $notok ], [ my_num => ne => ( 42, 18 ) => $ok ], [ my_num => cmp => ( 42, 42 ) => $notok ], [ my_num => cmp => ( 42, 18 ) => $ok ], [ my_num => cmp => ( 42, 69 ) => $ok ], [ my_num => lt => ( 42, 42 ) => $notok ], [ my_num => lt => ( 42, 18 ) => $notok ], [ my_num => lt => ( 42, 69 ) => $ok ], [ my_num => le => ( 42, 42 ) => $ok ], [ my_num => le => ( 42, 18 ) => $notok ], [ my_num => le => ( 42, 69 ) => $ok ], [ my_num => gt => ( 42, 42 ) => $notok ], [ my_num => gt => ( 42, 18 ) => $ok ], [ my_num => gt => ( 42, 69 ) => $notok ], [ my_num => ge => ( 42, 42 ) => $ok ], [ my_num => ge => ( 42, 18 ) => $ok ], [ my_num => ge => ( 42, 69 ) => $notok ], ); for my $case ( @cases ) { my ( $attr, $cmp, $val1, $val2, $truth ) = @$case; my $cmp_method = sprintf( '%s_%s', $attr, $cmp ); my $desc = sprintf( '$object->%s("%s")->%s("%s")', $attr, $val1, $cmp_method, $val2 ); $object->$attr( $val1 ); if ( $truth ) { ok( $object->$cmp_method( $val2 ), "ok $desc", ); } else { ok( !$object->$cmp_method( $val2 ), "ok !$desc", ); } } $object->my_str( 'Foo' ); is( $object->my_str_uc, 'FOO', '$object->my_str_uc', ); is( $object->my_str_lc, 'foo', '$object->my_str_lc', ); ok( !$object->my_str_match_i('BAR'), '!$object->my_str_match_i(Str)', ); ok( $object->my_str_match_i('FOO'), '$object->my_str_match_i(Str)', ); ok( $object->my_str_match_i(qr/FOO/i), '$object->my_str_match_i(RegexpRef)', ); ok( $object->my_str_starts_with('F') && !$object->my_str_starts_with('X') && !$object->my_str_starts_with('f'), '$object->my_str_starts_with', ); ok( $object->my_str_starts_with_i('F') && !$object->my_str_starts_with_i('X') && $object->my_str_starts_with_i('f'), '$object->my_str_starts_with_i', ); ok( $object->my_str_ends_with('o') && !$object->my_str_ends_with('X') && !$object->my_str_ends_with('O'), '$object->my_str_ends_with', ); ok( $object->my_str_ends_with_i('o') && !$object->my_str_ends_with_i('X') && $object->my_str_ends_with_i('O'), '$object->my_str_ends_with_i', ); ok( $object->my_str_contains('F') && $object->my_str_contains('o') && $object->my_str_contains('Fo') && $object->my_str_contains('oo') && $object->my_str_contains('Foo') && !$object->my_str_contains('f') && !$object->my_str_contains('X'), '$object->my_str_contains', ); ok( $object->my_str_contains_i('F') && $object->my_str_contains_i('o') && $object->my_str_contains_i('Fo') && $object->my_str_contains_i('oo') && $object->my_str_contains_i('Foo') && $object->my_str_contains_i('f') && $object->my_str_contains_i('Oo') && $object->my_str_contains_i('oO') && !$object->my_str_contains_i('X'), '$object->my_str_contains_i', ); done_testing; 95any.t000664001750001750 67514772476615 14714 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse strict; use warnings; use Test::More; { package Local::Dummy; use Test::Requires { 'Moo' => '1.006' } }; { package Local::Class; use Moo; use Sub::HandlesVia; has collection => ( is => 'ro', handles_via => 'Array', handles => [qw/ any /], ); } my $collection = Local::Class->new( collection => [qw/ 1 2 3 4 /], ); ok( $collection->any(sub { $_==3 }), ); ok( !$collection->any(sub { $_==5 }), ); done_testing; 96foreach.t000664001750001750 256014772476615 15550 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse strict; use warnings; use Test::More; { package Local::Dummy; use Test::Requires { 'Moo' => '1.006' } }; { package Local::Class; use Moo; use Sub::HandlesVia; has collection => ( is => 'ro', handles_via => 'Array', handles => [qw/ for_each for_each_pair /], ); } my $collection = Local::Class->new( collection => [qw/ 1 2 3 4 5 6 /], ); my @r = (); is_deeply( $collection->for_each(sub { push @r, [@_]; }), $collection, ); is_deeply( \@r, [[1,0], [2,1], [3,2], [4,3], [5,4], [6,5]], ); @r = (); is_deeply( $collection->for_each_pair(sub { push @r, [@_]; }), $collection, ); is_deeply( \@r, [[1,2], [3,4], [5,6]], ); { package Local::Class2; use Moo; use Sub::HandlesVia; has collection => ( is => 'ro', handles_via => 'Hash', handles => [qw/ for_each_pair for_each_key for_each_value /], ); } $collection = Local::Class2->new(collection => {foo => 1, bar => 2}); @r = (); is_deeply( $collection->for_each_pair(sub { push @r, join "|", @_; }), $collection, ); is_deeply( [sort @r], ["bar|2", "foo|1"], ); @r = (); is_deeply( $collection->for_each_key(sub { push @r, join "|", @_; }), $collection, ); is_deeply( [sort @r], ["bar", "foo"], ); @r = (); is_deeply( $collection->for_each_value(sub { push @r, join "|", @_; }), $collection, ); is_deeply( [sort @r], [1, 2], ); done_testing; 97pickrandom.t000664001750001750 140014772476615 16261 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse strict; use warnings; use Test::More; { package Local::Dummy; use Test::Requires { 'Moo' => '1.006' } }; { package Local::Class; use Moo; use Sub::HandlesVia; has collection => ( is => 'ro', handles_via => 'Array', handles => [qw/ pick_random /], ); } my $collection = Local::Class->new( collection => [qw/ 1 2 3 4 5 6 7 8 /], ); note( explain scalar $collection->pick_random(3), ); note( explain scalar $collection->pick_random(3), ); note( explain scalar $collection->pick_random(3), ); note( explain scalar $collection->pick_random(1), ); note( explain scalar $collection->pick_random(30), ); note( explain scalar $collection->pick_random(-5), ); note( explain scalar $collection->pick_random(), ); ok 1; done_testing;98apply.t000664001750001750 74414772476615 15252 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse strict; use warnings; use Test::More; { package Local::Dummy; use Test::Requires { 'Moo' => '1.006' } }; { package Local::Class; use Moo; use Sub::HandlesVia; has collection => ( is => 'ro', handles_via => 'Array', handles => [qw/ apply /], ); } my $collection = Local::Class->new( collection => [qw/ 1 2 3 4 /], ); my @r = $collection->apply(sub { $_ *= 2; 1 }); is_deeply(\@r, [2,4,6,8]); is_deeply($collection->collection, [1,2,3,4]); done_testing; 99headtail.t000664001750001750 240514772476615 15715 0ustar00taitai000000000000Sub-HandlesVia-0.050002/tuse strict; use warnings; use Test::More; use Test::Fatal; { package Local::Dummy; use Test::Requires { 'Moo' => '1.006' } }; { package Local::Class; use Moo; use Sub::HandlesVia; has collection => ( is => 'ro', handles_via => 'Array', handles => { front => 'head', back => 'tail', }, ); } my $collection = Local::Class->new( collection => [qw/ a b c d e f /], ); # head is_deeply [$collection->front(0)], [], 'head(0)'; is_deeply [$collection->front(3)], [qw{a b c}], 'head(3)'; is_deeply [$collection->front(30)], [qw{a b c d e f}], 'head(30)'; is_deeply [$collection->front(-2)], [qw{a b c d}], 'head(-2)' or diag explain[ $collection->front(-2) ]; is_deeply [$collection->front(-30)], [], 'head(-30)' or diag explain[ $collection->front(-30) ]; # tail is_deeply [$collection->back(0)], [], 'tail(0)'; is_deeply [$collection->back(3)], [qw{d e f}], 'tail(3)'; is_deeply [$collection->back(30)], [qw{a b c d e f}], 'tail(30)'; is_deeply [$collection->back(-2)], [qw{c d e f}], 'tail(-2)'; is_deeply [$collection->back(-30)], [], 'tail(-30)'; # exception like( exception { $collection->front(3, 4, 5) }, qr/Wrong number of parameters( to Local::Class::front)?; got 4; expected 2 at front=Array:head/, 'Correct exception', ); done_testing; HandlesVia.pm000664001750001750 1421614772476615 17226 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Subuse 5.008; use strict; use warnings; package Sub::HandlesVia; use Exporter::Shiny qw( delegations ); our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; sub _generate_delegations { my ($me, $name, $args, $globals) = (shift, @_); my $target = $globals->{into}; !defined $target and die; ref $target and die; my $toolkit = $me->detect_toolkit($target); return sub { $toolkit->install_delegations(target => $target, @_) }; } sub _exporter_validate_opts { my ($me, $globals) = (shift, @_); my $target = $globals->{into}; !defined $target and die; ref $target and die; my $toolkit = $me->detect_toolkit($target); $toolkit->setup_for($target) if $toolkit->can('setup_for'); } sub detect_toolkit { my $toolkit = sprintf( '%s::Toolkit::%s', __PACKAGE__, shift->_detect_framework(@_), ); eval "require $toolkit" or Exporter::Tiny::_croak($@); return $toolkit; } sub _detect_framework { my ($me, $target) = (shift, @_); # Need to ask Role::Tiny too because Moo::Role will pretend # that Moose::Role and Mouse::Role roles are Moo::Role roles! # if ($INC{'Moo/Role.pm'} and Role::Tiny->is_role($target) and Moo::Role->is_role($target)) { return 'Moo'; } if ($INC{'Moo.pm'} and $Moo::MAKERS{$target} and $Moo::MAKERS{$target}{is_class}) { return 'Moo'; } if ($INC{'Moose/Role.pm'} and $target->can('meta') and $target->meta->isa('Moose::Meta::Role')) { return 'Moose'; } if ($INC{'Moose.pm'} and $target->can('meta') and $target->meta->isa('Moose::Meta::Class')) { return 'Moose'; } if ($INC{'Mouse/Role.pm'} and $target->can('meta') and $target->meta->isa('Mouse::Meta::Role')) { return 'Mouse'; } if ($INC{'Mouse.pm'} and $target->can('meta') and $target->meta->isa('Mouse::Meta::Class')) { return 'Mouse'; } { no warnings; if ($INC{'Object/Pad.pm'} and 'Object::Pad'->VERSION ge 0.67 and do { require Object::Pad::MOP::Class; 1 } and eval { Object::Pad::MOP::Class->for_class($target) } ) { require Scalar::Util; my $META = Object::Pad::MOP::Class->for_class($target); return 'ObjectPad' if Scalar::Util::blessed($META) && $META->isa('Object::Pad::MOP::Class'); } } { no strict 'refs'; no warnings 'once'; if ( ${"$target\::USES_MITE"} ) { return 'Mite'; } } return 'Plain'; } 1; __END__ =pod =encoding utf-8 =head1 NAME Sub::HandlesVia - alternative handles_via implementation =head1 SYNOPSIS package Kitchen { use Moo; use Sub::HandlesVia; use Types::Standard qw( ArrayRef Str ); has food => ( is => 'ro', isa => ArrayRef[Str], handles_via => 'Array', default => sub { [] }, handles => { 'add_food' => 'push', 'find_food' => 'grep', }, ); } my $kitchen = Kitchen->new; $kitchen->add_food('Bacon'); $kitchen->add_food('Eggs'); $kitchen->add_food('Sausages'); $kitchen->add_food('Beans'); my @foods = $kitchen->find_food(sub { /^B/i }); =head1 DESCRIPTION If you've used L's native attribute traits, or L before, you should have a fairly good idea what this does. Why re-invent the wheel? Well, this is an implementation that should work okay with Moo, Moose, Mouse, and any other OO toolkit you throw at it. One ring to rule them all, so to speak. For details of how to use it, see the manual. =over =item L How to use Sub::HandlesVia with L and L. =item L How to use Sub::HandlesVia with L and L. =item L How to use Sub::HandlesVia with L and L. =item L How to use Sub::HandlesVia with L. =item L How to use Sub::HandlesVia with L. =item L How to use Sub::HandlesVia with L classes. =item L How to use Sub::HandlesVia with other OO toolkits, and hand-written Perl classes. =back Note: as Sub::HandlesVia needs to detect which toolkit you are using, and often needs to detect whether your package is a class or a role, it needs to be loaded I Moo/Moose/Mouse/etc. Your C<< use Moo >> or C<< use Moose::Role >> or whatever needs to be I your C<< use Sub::HandlesVia >>. =head1 BUGS Please report any bugs to L. (There are known bugs for Moose native types that do coercion.) =head1 SEE ALSO Guides for use with different OO toolkits: L, L, L, L, L, L, L. Documentation for delegatable methods: L, L, L, L, L, L, L, L, L, and L. Other implementations of the same concept: L, L, and L with L. Comparison of those: L L is a helper for declaring Sub::HandlesVia delegations at compile-time, useful for L and (to a lesser extent) L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2020, 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. ext_attr.t000664001750001750 72614772476615 16532 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/02moouse strict; use warnings; use Test::More; { package Local::Dummy1; use Test::Requires 'Moo' }; { package ParentClass; use Moo; has 'test' => ( is => 'ro', default => sub { [] }, ); } { package ThisFails; use Moo; use Sub::HandlesVia; extends 'ParentClass'; has '+test' => ( handles_via => 'Array', handles => { 'push' => 'push...' } ); } my $obj = ThisFails->new; is_deeply($obj->push('a')->push('test')->test, [qw(a test)]); done_testing; role.t000664001750001750 156414772476615 15662 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/02moouse strict; use warnings; use Test::More; use Test::Fatal; { package Local::Dummy1; use Test::Requires { 'Moo' => '1.006' } }; { package Local::Role1; use Moo::Role; use Sub::HandlesVia; use Types::Standard qw( ArrayRef Int ); has nums => ( is => 'ro', isa => ArrayRef[Int], builder => sub { [ 1..10 ] }, handles_via => 'Array', handles => { pop_num => 'pop', push_num => 'push' }, ); } { package Local::Class1; use Moo; with 'Local::Role1'; } #require B::Deparse; #::note( B::Deparse->new->coderef2text(\&Local::Class1::pop_num) ); my $obj = Local::Class1->new; is( $obj->pop_num, 10 ); is( $obj->pop_num, 9 ); is( $obj->pop_num, 8 ); is( $obj->pop_num, 7 ); isnt( exception { $obj->push_num(44.5) }, undef, ); is( $obj->pop_num, 6 ); is( exception { $obj->push_num(6) }, undef, ); is( $obj->pop_num, 6 ); done_testing; roles-multiple.t000664001750001750 112214772476615 17664 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/02moouse strict; use warnings; use Test::More; use Test::Fatal; { package Local::Dummy1; use Test::Requires 'Moo' }; { package TestRole1; use Moo::Role; } { package TestRole2; use Moo::Role; use Types::Standard qw(ArrayRef); use Sub::HandlesVia; has test => ( is => 'ro', isa => ArrayRef, default => sub { [] }, handles_via => 'Array', handles => { all_test => 'all' }, ); } { package TestClass; use Moo; with qw( TestRole1 TestRole2 ); } my $obj = TestClass->new( test => [ 1, 2 ] ); is_deeply( [ $obj->all_test ], [ 1, 2 ] ); done_testing; trait_array.t000664001750001750 6333214772476615 17263 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/02moouse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires { 'Moo' => '1.006' } }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my %handles = ( count => 'count', elements => 'elements', is_empty => 'is_empty', push => 'push', push_curried => [ push => 42, 84 ], unshift => 'unshift', unshift_curried => [ unshift => 42, 84 ], pop => 'pop', shift => 'shift', get => 'get', get_curried => [ get => 1 ], set => 'set', set_curried_1 => [ set => 1 ], set_curried_2 => [ set => ( 1, 98 ) ], accessor => 'accessor', accessor_curried_1 => [ accessor => 1 ], accessor_curried_2 => [ accessor => ( 1, 90 ) ], clear => 'clear', delete => 'delete', delete_curried => [ delete => 1 ], insert => 'insert', insert_curried => [ insert => ( 1, 101 ) ], splice => 'splice', splice_curried_1 => [ splice => 1 ], splice_curried_2 => [ splice => 1, 2 ], splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ], sort => 'sort', sort_curried => [ sort => ( sub { $_[1] <=> $_[0] } ) ], sort_in_place => 'sort_in_place', sort_in_place_curried => [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ], map => 'map', map_curried => [ map => ( sub { $_ + 1 } ) ], grep => 'grep', grep_curried => [ grep => ( sub { $_ < 5 } ) ], first => 'first', first_curried => [ first => ( sub { $_ % 2 } ) ], first_index => 'first_index', first_index_curried => [ first_index => ( sub { $_ % 2 } ) ], join => 'join', join_curried => [ join => '-' ], shuffle => 'shuffle', uniq => 'uniq', reduce => 'reduce', reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ], natatime => 'natatime', natatime_curried => [ natatime => 2 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Array'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moo; use Sub::HandlesVia; use Types::Standard qw(ArrayRef Int); has _values => ( traits => [\@traits], is => 'rw', isa => ArrayRef[Int], default => sub { [] }, handles => \\%handles_copy, clearer => '_clear_values', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { package Overloader; use overload '&{}' => sub { ${ $_[0] } }, bool => sub {1}; sub new { bless \$_[1], $_[0]; } } { package OverloadStr; use overload q{""} => sub { ${ $_[0] } }, fallback => 1; sub new { my $class = shift; my $str = shift; return bless \$str, $class; } } { package OverloadNum; use overload q{0+} => sub { ${ $_[0] } }, fallback => 1; sub new { my $class = shift; my $str = shift; return bless \$str, $class; } } use Types::Standard qw( ArrayRef Int ); { subtest( 'simple case', sub { run_tests(build_class) } ); subtest( 'lazy default attr', sub { run_tests( build_class( lazy => 1, default => sub { [ 42, 84 ] } ) ); } ); subtest( 'attr with trigger', sub { run_tests( build_class( trigger => sub { } ) ); } ); subtest( 'attr is not inlined', sub { run_tests( build_class( no_inline => 1 ) ) } ); subtest( 'attr type forces the inlining code to check the entire arrayref when it is modified', sub { run_tests( build_class( isa => ArrayRef->where(sub {1}) ) ); } ); subtest( 'attr type has coercion', sub { run_tests( build_class( isa => ArrayRef->plus_coercions(Int, '[$_]'), coerce => 1 ) ); } ); } subtest( 'setting value to undef with accessor', sub { my ( $class, $handles ) = build_class( isa => ArrayRef ); note "Testing class $class"; my $obj = $class->new; # with_immutable { is( exception { $obj->accessor( 0, undef ) }, undef, 'can use accessor to set value to undef' ); is( exception { $obj->accessor_curried_1(undef) }, undef, 'can use curried accessor to set value to undef' ); # } # $class; } ); sub run_tests { my ( $class, $handles ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new( _values => [ 10, 12, 42 ] ); is_deeply( $obj->_values, [ 10, 12, 42 ], 'values can be set in constructor' ); ok( !$obj->is_empty, 'values is not empty' ); is( $obj->count, 3, 'count returns 3' ); like( exception { $obj->count(22) }, qr/number of parameters/, 'throws an error when passing an argument passed to count' ); is( exception { $obj->push( 1, 2, 3 ) }, undef, 'pushed three new values and lived' ); is( exception { $obj->push() }, undef, 'call to push without arguments lives' ); is( exception { is( $obj->unshift( 101, 22 ), 8, 'unshift returns size of the new array' ); }, undef, 'unshifted two values and lived' ); is_deeply( $obj->_values, [ 101, 22, 10, 12, 42, 1, 2, 3 ], 'unshift changed the value of the array in the object' ); is( exception { $obj->unshift() }, undef, 'call to unshift without arguments lives' ); is( $obj->pop, 3, 'pop returns the last value in the array' ); is_deeply( $obj->_values, [ 101, 22, 10, 12, 42, 1, 2 ], 'pop changed the value of the array in the object' ); like( exception { $obj->pop(42) }, qr/number of parameters/, 'call to pop with arguments dies' ); is( $obj->shift, 101, 'shift returns the first value' ); like( exception { $obj->shift(42) }, qr/number of parameters/, 'call to shift with arguments dies' ); is_deeply( $obj->_values, [ 22, 10, 12, 42, 1, 2 ], 'shift changed the value of the array in the object' ); is_deeply( [ $obj->elements ], [ 22, 10, 12, 42, 1, 2 ], 'call to elements returns values as a list' ); is(scalar($obj->elements), 6, 'elements accessor in scalar context returns the number of elements in the list'); like( exception { $obj->elements(22) }, qr/number of parameters/, 'throws an error when passing an argument passed to elements' ); $obj->_values( [ 1, 2, 3 ] ); is( $obj->get(0), 1, 'get values at index 0' ); is( $obj->get(1), 2, 'get values at index 1' ); is( $obj->get(2), 3, 'get values at index 2' ); is( $obj->get_curried, 2, 'get_curried returns value at index 1' ); like( exception { $obj->get() }, qr/number of parameters/, 'throws an error when get is called without any arguments' ); like( exception { $obj->get( {} ) }, qr/did not pass type constraint/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get(2.2) }, qr/did not pass type constraint/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get('foo') }, qr/did not pass type constraint/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get_curried(2) }, qr/number of parameters/, 'throws an error when get_curried is called with an argument' ); is( exception { is( $obj->set( 1, 100 ), 100, 'set returns new value' ); }, undef, 'set value at index 1 lives' ); is( $obj->get(1), 100, 'get value at index 1 returns new value' ); like( exception { $obj->set( 1, 99, 42 ) }, qr/number of parameters/, 'throws an error when set is called with three arguments' ); is( exception { $obj->set_curried_1(99) }, undef, 'set_curried_1 lives' ); is( $obj->get(1), 99, 'get value at index 1 returns new value' ); like( exception { $obj->set_curried_1( 99, 42 ) }, qr/number of parameters/, 'throws an error when set_curried_1 is called with two arguments' ); is( exception { $obj->set_curried_2 }, undef, 'set_curried_2 lives' ); is( $obj->get(1), 98, 'get value at index 1 returns new value' ); like( exception { $obj->set_curried_2(42) }, qr/number of parameters/, 'throws an error when set_curried_2 is called with one argument' ); #use B::Deparse; #diag(B::Deparse->new->coderef2text($obj->can('accessor'))); is( $obj->accessor(1), 98, 'accessor with one argument returns value at index 1' ); is( exception { is( $obj->accessor( 1 => 97 ), 97, 'accessor returns new value' ); }, undef, 'accessor as writer lives' ); like( exception { $obj->accessor; }, qr/number of parameters/, 'throws an error when accessor is called without arguments' ); is( $obj->get(1), 97, 'accessor set value at index 1' ); like( exception { $obj->accessor( 1, 96, 42 ) }, qr/number of parameters/, 'throws an error when accessor is called with three arguments' ); is( $obj->accessor_curried_1, 97, 'accessor_curried_1 returns expected value when called with no arguments' ); is( exception { $obj->accessor_curried_1(95) }, undef, 'accessor_curried_1 as writer lives' ); is( $obj->get(1), 95, 'accessor_curried_1 set value at index 1' ); like( exception { $obj->accessor_curried_1( 96, 42 ) }, qr/number of parameters/, 'throws an error when accessor_curried_1 is called with two arguments' ); is( exception { $obj->accessor_curried_2 }, undef, 'accessor_curried_2 as writer lives' ); is( $obj->get(1), 90, 'accessor_curried_2 set value at index 1' ); like( exception { $obj->accessor_curried_2(42) }, qr/number of parameters/, 'throws an error when accessor_curried_2 is called with one argument' ); is( exception { $obj->clear }, undef, 'clear lives' ); ok( $obj->is_empty, 'values is empty after call to clear' ); is( exception { is( $obj->shift, undef, 'shift returns undef on an empty array' ); }, undef, 'shifted from an empty array and lived' ); $obj->set( 0 => 42 ); like( exception { $obj->clear(50) }, qr/number of parameters/, 'throws an error when clear is called with an argument' ); ok( !$obj->is_empty, 'values is not empty after failed call to clear' ); like( exception { $obj->is_empty(50) }, qr/number of parameters/, 'throws an error when is_empty is called with an argument' ); $obj->clear; is( $obj->push( 1, 5, 10, 42 ), 4, 'pushed 4 elements, got number of elements in the array back' ); is( exception { is( $obj->delete(2), 10, 'delete returns deleted value' ); }, undef, 'delete lives' ); is_deeply( $obj->_values, [ 1, 5, 42 ], 'delete removed the specified element' ); like( exception { $obj->delete( 2, 3 ) }, qr/number of parameters/, 'throws an error when delete is called with two arguments' ); is( exception { $obj->delete_curried }, undef, 'delete_curried lives' ); is_deeply( $obj->_values, [ 1, 42 ], 'delete removed the specified element' ); like( exception { $obj->delete_curried(2) }, qr/number of parameters/, 'throws an error when delete_curried is called with one argument' ); is( exception { $obj->insert( 1, 21 ) }, undef, 'insert lives' ); is_deeply( $obj->_values, [ 1, 21, 42 ], 'insert added the specified element' ); like( exception { $obj->insert( 1, 22, 44 ) }, qr/number of parameters/, 'throws an error when insert is called with three arguments' ); is( exception { is_deeply( [ $obj->splice( 1, 0, 2, 3 ) ], [], 'return value of splice is empty list when not removing elements' ); }, undef, 'splice lives' ); is_deeply( $obj->_values, [ 1, 2, 3, 21, 42 ], 'splice added the specified elements' ); is( exception { is_deeply( [ $obj->splice( 1, 2, 99 ) ], [ 2, 3 ], 'splice returns list of removed values' ); }, undef, 'splice lives' ); is_deeply( $obj->_values, [ 1, 99, 21, 42 ], 'splice added the specified elements' ); like( exception { $obj->splice() }, qr/number of parameters/, 'throws an error when splice is called with no arguments' ); like( exception { $obj->splice( 1, 'foo', ) }, qr/did not pass type constraint/, 'throws an error when splice is called with an invalid length' ); is( exception { $obj->splice_curried_1( 2, 101 ) }, undef, 'splice_curried_1 lives' ); is_deeply( $obj->_values, [ 1, 101, 42 ], 'splice added the specified elements' ); is( exception { $obj->splice_curried_2(102) }, undef, 'splice_curried_2 lives' ); is_deeply( $obj->_values, [ 1, 102 ], 'splice added the specified elements' ); is( exception { $obj->splice_curried_all }, undef, 'splice_curried_all lives' ); is_deeply( $obj->_values, [ 1, 3, 4, 5 ], 'splice added the specified elements' ); is_deeply( scalar $obj->splice( 1, 2 ), 4, 'splice in scalar context returns last element removed' ); is_deeply( scalar $obj->splice( 1, 0, 42 ), undef, 'splice in scalar context returns undef when no elements are removed' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); is_deeply( [ $obj->sort ], [ 11, 22, 3, 5, 9 ], 'sort returns sorted values' ); is(scalar($obj->sort), 5, 'sort accessor in scalar context returns the number of elements in the list'); is_deeply( [ $obj->sort( sub { $_[0] <=> $_[1] } ) ], [ 3, 5, 9, 11, 22 ], 'sort returns values sorted by provided function' ); is(scalar($obj->sort( sub { $_[0] <=> $_[1] } )), 5, 'sort accessor with sort sub in scalar context returns the number of elements in the list'); like( exception { $obj->sort(1) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to sort' ); like( exception { $obj->sort( sub { }, 27 ); }, qr/number of parameters/, 'throws an error when passing two arguments to sort' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); $obj->sort_in_place; is_deeply( $obj->_values, [ 11, 22, 3, 5, 9 ], 'sort_in_place sorts values' ); $obj->sort_in_place( sub { $_[0] <=> $_[1] } ); is_deeply( $obj->_values, [ 3, 5, 9, 11, 22 ], 'sort_in_place with function sorts values' ); like( exception { $obj->sort_in_place( 27 ); }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to sort_in_place' ); like( exception { $obj->sort_in_place( sub { }, 27 ); }, qr/number of parameters/, 'throws an error when passing two arguments to sort_in_place' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); $obj->sort_in_place_curried; is_deeply( $obj->_values, [ 22, 11, 9, 5, 3 ], 'sort_in_place_curried sorts values' ); like( exception { $obj->sort_in_place_curried(27) }, qr/number of parameters/, 'throws an error when passing one argument passed to sort_in_place_curried' ); $obj->_values( [ 1 .. 5 ] ); is_deeply( [ $obj->map( sub { $_ + 1 } ) ], [ 2 .. 6 ], 'map returns the expected values' ); like( exception { $obj->map }, qr/number of parameters/, 'throws an error when passing no arguments to map' ); like( exception { $obj->map( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to map' ); like( exception { $obj->map( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to map' ); $obj->_values( [ 1 .. 5 ] ); is_deeply( [ $obj->map_curried ], [ 2 .. 6 ], 'map_curried returns the expected values' ); like( exception { $obj->map_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to map_curried' ); $obj->_values( [ 2 .. 9 ] ); is_deeply( [ $obj->grep( sub { $_ < 5 } ) ], [ 2 .. 4 ], 'grep returns the expected values' ); like( exception { $obj->grep }, qr/number of parameters/, 'throws an error when passing no arguments to grep' ); like( exception { $obj->grep( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to grep' ); like( exception { $obj->grep( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to grep' ); # my $overloader = Overloader->new( sub { $_ < 5 } ); # is_deeply( # [ $obj->grep($overloader) ], # [ 2 .. 4 ], # 'grep works with obj that overload code dereferencing' # ); is_deeply( [ $obj->grep_curried ], [ 2 .. 4 ], 'grep_curried returns the expected values' ); like( exception { $obj->grep_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to grep_curried' ); $obj->_values( [ 2, 4, 22, 99, 101, 6 ] ); is( $obj->first( sub { $_ % 2 } ), 99, 'first returns expected value' ); like( exception { $obj->first }, qr/number of parameters/, 'throws an error when passing no arguments to first' ); like( exception { $obj->first( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to first' ); like( exception { $obj->first( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to first' ); is( $obj->first_curried, 99, 'first_curried returns expected value' ); like( exception { $obj->first_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to first_curried' ); is( $obj->first_index( sub { $_ % 2 } ), 3, 'first_index returns expected value' ); like( exception { $obj->first_index }, qr/number of parameters/, 'throws an error when passing no arguments to first_index' ); like( exception { $obj->first_index( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to first_index' ); like( exception { $obj->first_index( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to first_index' ); is( $obj->first_index_curried, 3, 'first_index_curried returns expected value' ); like( exception { $obj->first_index_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to first_index_curried' ); $obj->_values( [ 1 .. 4 ] ); is( $obj->join('-'), '1-2-3-4', 'join returns expected result' ); is( $obj->join(q{}), '1234', 'join returns expected result when joining with empty string' ); is( $obj->join(0), '1020304', 'join returns expected result when joining with 0 as number' ); is( $obj->join("0"), '1020304', 'join returns expected result when joining with 0 as string' ); # is( # $obj->join( OverloadStr->new(q{}) ), '1234', # 'join returns expected result when joining with object with string overload' # ); # # is( # $obj->join( OverloadNum->new(0) ), '1020304', # 'join returns expected result when joining with object with numify overload' # ); # like( exception { $obj->join }, qr/number of parameters/, 'throws an error when passing no arguments to join' ); like( exception { $obj->join( '-', 2 ) }, qr/number of parameters/, 'throws an error when passing two arguments to join' ); like( exception { $obj->join( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non string to join' ); is_deeply( [ sort $obj->shuffle ], [ 1 .. 4 ], 'shuffle returns all values (cannot check for a random order)' ); like( exception { $obj->shuffle(2) }, qr/number of parameters/, 'throws an error when passing an argument passed to shuffle' ); $obj->_values( [ 1 .. 4, 2, 5, 3, 7, 3, 3, 1 ] ); is_deeply( [ $obj->uniq ], [ 1 .. 4, 5, 7 ], 'uniq returns expected values (in original order)' ); like( exception { $obj->uniq(2) }, qr/number of parameters/, 'throws an error when passing an argument passed to uniq' ); $obj->_values( [ 1 .. 5 ] ); is( $obj->reduce( sub { $_[0] * $_[1] } ), 120, 'reduce returns expected value' ); like( exception { $obj->reduce }, qr/number of parameters/, 'throws an error when passing no arguments to reduce' ); like( exception { $obj->reduce( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to reduce' ); like( exception { $obj->reduce( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to reduce' ); is( $obj->reduce_curried, 120, 'reduce_curried returns expected value' ); like( exception { $obj->reduce_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to reduce_curried' ); $obj->_values( [ 1 .. 6 ] ); my $it = $obj->natatime(2); my @nat; while ( my @v = $it->() ) { push @nat, \@v; } is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime returns expected iterator' ) or diag(explain(\@nat)); @nat = (); $obj->natatime( 2, sub { push @nat, [@_] } ); is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime with function returns expected value' ); like( exception { $obj->natatime( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non integer to natatime' ); like( exception { $obj->natatime( 2, {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non code ref to natatime' ); $it = $obj->natatime_curried(); @nat = (); while ( my @v = $it->() ) { push @nat, \@v; } is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime_curried returns expected iterator' ); @nat = (); $obj->natatime_curried( sub { push @nat, [@_] } ); is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime_curried with function returns expected value' ); like( exception { $obj->natatime_curried( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non code ref to natatime_curried' ); if ( $class->class_is_lazy ) { my $obj = $class->new; is( $obj->count, 2, 'count is 2 (lazy init)' ); $obj->_clear_values; is_deeply( [ $obj->elements ], [ 42, 84 ], 'elements contains default with lazy init' ); $obj->_clear_values; $obj->push(2); is_deeply( $obj->_values, [ 42, 84, 2 ], 'push works with lazy init' ); $obj->_clear_values; $obj->unshift( 3, 4 ); is_deeply( $obj->_values, [ 3, 4, 42, 84 ], 'unshift works with lazy init' ); } # } # $class; } done_testing; trait_bool.t000664001750001750 552114772476615 17054 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/02moouse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires { 'Moo' => '1.006' } }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my %handles = ( illuminate => 'set', darken => 'unset', flip_switch => 'toggle', is_dark => 'not', ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Bool'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moo; use Sub::HandlesVia; use Types::Standard qw(Bool); has is_lit => ( traits => [\@traits], is => 'rw', isa => Bool, default => 1, handles => \\%handles_copy, clearer => '_clear_is_lit', %attr, ); 1; } or die($@); return ( $class, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); run_tests( build_class( isa => Types::Standard::Bool()->where(sub {1}) ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new; ok( $obj->illuminate, 'set returns true' ); ok( $obj->is_lit, 'set is_lit to 1 using ->illuminate' ); ok( !$obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->illuminate(1) }, qr/number of parameters/, 'set throws an error when an argument is passed' ); ok( !$obj->darken, 'unset returns false' ); ok( !$obj->is_lit, 'set is_lit to 0 using ->darken' ); ok( $obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->darken(1) }, qr/number of parameters/, 'unset throws an error when an argument is passed' ); ok( $obj->flip_switch, 'toggle returns new value' ); ok( $obj->is_lit, 'toggle is_lit back to 1 using ->flip_switch' ); ok( !$obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->flip_switch(1) }, qr/number of parameters/, 'toggle throws an error when an argument is passed' ); $obj->flip_switch; ok( !$obj->is_lit, 'toggle is_lit back to 0 again using ->flip_switch' ); ok( $obj->is_dark, 'check if is_dark does the right thing' ); # } # $class; } done_testing; trait_code.t000664001750001750 562714772476615 17042 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/02moouse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires { 'Moo' => '1.006' } }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my $name = 'Foo1'; sub build_class { my ( $attr1, $attr2, $attr3, $no_inline ) = @_; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Code'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moo; use Sub::HandlesVia; use Types::Standard qw(CodeRef); has( callback => ( is => 'bare', handles_via => [\@traits], isa => CodeRef, required => 1, handles => { 'invoke_callback' => 'execute' }, %{ \$attr1 || {} }, ) ); has( callback_method => ( is => 'bare', handles_via => [\@traits], isa => CodeRef, required => 1, handles => { 'invoke_method_callback' => 'execute_method' }, %{ \$attr2 || {} }, ) ); has( multiplier => ( is => 'bare', handles_via => [\@traits], isa => CodeRef, required => 1, handles => { 'multiply' => 'execute' }, %{ \$attr3 || {} }, ) ); 1; } or die($@); return $class; } } { my $i; my %subs = ( callback => sub { ++$i }, callback_method => sub { shift->multiply(@_) }, multiplier => sub { $_[0] * 2 }, ); run_tests( build_class, \$i, \%subs ); run_tests( build_class( undef, undef, undef, 1 ), \$i, \%subs ); run_tests( build_class( { lazy => 1, default => sub { $subs{callback} } }, { lazy => 1, default => sub { $subs{callback_method} } }, { lazy => 1, default => sub { $subs{multiplier} } }, ), \$i, ); } sub run_tests { my ( $class, $iref, @args ) = @_; note "Testing class $class"; ok( !$class->can($_), "Code trait didn't create reader method for $_" ) for qw(callback callback_method multiplier); # with_immutable { ${$iref} = 0; my $obj = $class->new(@args); $obj->invoke_callback; is( ${$iref}, 1, '$i is 1 after invoke_callback' ); is( $obj->invoke_method_callback(3), 6, 'invoke_method_callback calls multiply with @_' ); is( $obj->multiply(3), 6, 'multiple double value' ); # } # $class; } done_testing; trait_counter.t000664001750001750 1123414772476615 17616 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/02moouse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires { 'Moo' => '1.006' } }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; use Types::Standard (); { my %handles = ( inc_counter => 'inc', inc_counter_2 => [ inc => 2 ], dec_counter => 'dec', dec_counter_2 => [ dec => 2 ], reset_counter => 'reset', set_counter => 'set', set_counter_42 => [ set => 42 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Counter'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moo; use Sub::HandlesVia; use Types::Standard qw(Int); has counter => ( traits => [\@traits], is => 'rw', isa => Int, default => 0, handles => \\%handles_copy, clearer => '_clear_counter', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); run_tests( build_class( isa => Types::Standard::Int()->where(sub {1}) ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new(); is( $obj->counter, 0, '... got the default value' ); is( $obj->inc_counter, 1, 'inc returns new value' ); is( $obj->counter, 1, '... got the incremented value' ); is( $obj->inc_counter, 2, 'inc returns new value' ); is( $obj->counter, 2, '... got the incremented value (again)' ); like( exception { $obj->inc_counter( 1, 2 ) }, qr/number of parameters/, 'inc throws an error when two arguments are passed' ); is( $obj->dec_counter, 1, 'dec returns new value' ); is( $obj->counter, 1, '... got the decremented value' ); like( exception { $obj->dec_counter( 1, 2 ) }, qr/number of parameters/, 'dec throws an error when two arguments are passed' ); is( $obj->reset_counter, 0, 'reset returns new value' ); is( $obj->counter, 0, '... got the original value' ); like( exception { $obj->reset_counter(2) }, qr/number of parameters/, 'reset throws an error when an argument is passed' ); is( $obj->set_counter(5), 5, 'set returns new value' ); is( $obj->counter, 5, '... set the value' ); like( exception { $obj->set_counter( 1, 2 ) }, qr/number of parameters/, 'set throws an error when two arguments are passed' ); $obj->inc_counter(2); is( $obj->counter, 7, '... increment by arg' ); $obj->dec_counter(5); is( $obj->counter, 2, '... decrement by arg' ); $obj->inc_counter_2; is( $obj->counter, 4, '... curried increment' ); $obj->dec_counter_2; is( $obj->counter, 2, '... curried deccrement' ); $obj->set_counter_42; is( $obj->counter, 42, '... curried set' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->inc_counter; is( $obj->counter, 1, 'inc increments - with lazy default' ); $obj->_clear_counter; $obj->dec_counter; is( $obj->counter, -1, 'dec decrements - with lazy default' ); } } # $class; #} { package WithBuilder; use Moo; use Sub::HandlesVia; use Types::Standard 'Int'; has nonlazy => ( traits => ['Counter'], is => 'rw', isa => Int, builder => '_builder', handles => { reset_nonlazy => 'reset', }, ); has lazy => ( traits => ['Counter'], is => 'rw', isa => Int, lazy => 1, builder => '_builder', handles => { reset_lazy => 'reset', }, ); sub _builder { 1 } } for my $attr ('lazy', 'nonlazy') { my $obj = WithBuilder->new; is($obj->$attr, 1, "built properly"); $obj->$attr(0); is($obj->$attr, 0, "can be manually set"); $obj->${\"reset_$attr"}; is($obj->$attr, 1, "reset resets it to its default value"); } done_testing; trait_hash.t000664001750001750 2205114772476615 17061 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/02moouse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires { 'Moo' => '1.006' } }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my %handles = ( option_accessor => 'accessor', quantity => [ accessor => 'quantity' ], clear_options => 'clear', num_options => 'count', delete_option => 'delete', is_defined => 'defined', options_elements => 'elements', has_option => 'exists', get_option => 'get', has_no_options => 'is_empty', keys => 'keys', values => 'values', key_value => 'kv', set_option => 'set', ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Hash'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moo; use Sub::HandlesVia; use Types::Standard qw(HashRef Str); has options => ( traits => [\@traits], is => 'rw', isa => HashRef[Str], default => sub { {} }, handles => \\%handles_copy, clearer => '_clear_options', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } use Types::Standard qw( HashRef Str ); { run_tests(build_class); run_tests( build_class( lazy => 1, default => sub { { x => 1 } } ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); run_tests( build_class( isa => HashRef->of(Str)->where(sub {1}) ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new( options => {} ); ok( $obj->has_no_options, '... we have no options' ); is( $obj->num_options, 0, '... we have no options' ); is_deeply( $obj->options, {}, '... no options yet' ); ok( !$obj->has_option('foo'), '... we have no foo option' ); is( exception { is( $obj->set_option( foo => 'bar' ), 'bar', 'set return single new value in scalar context' ); }, undef, '... set the option okay' ); like( exception { $obj->set_option( foo => 'bar', 'baz' ) }, qr/number of parameters/, 'exception with odd number of arguments' ); like( exception { $obj->set_option( undef, 'bar' ) }, qr/did not pass type constraint/, 'exception when using undef as a key' ); ok( $obj->is_defined('foo'), '... foo is defined' ); ok( !$obj->has_no_options, '... we have options' ); is( $obj->num_options, 1, '... we have 1 option(s)' ); ok( $obj->has_option('foo'), '... we have a foo option' ); is_deeply( $obj->options, { foo => 'bar' }, '... got options now' ); is( exception { $obj->set_option( bar => 'baz' ); }, undef, '... set the option okay' ); is( $obj->num_options, 2, '... we have 2 option(s)' ); is_deeply( $obj->options, { foo => 'bar', bar => 'baz' }, '... got more options now' ); is( $obj->get_option('foo'), 'bar', '... got the right option' ); is_deeply( [ $obj->get_option(qw(foo bar)) ], [qw(bar baz)], "get multiple options at once" ); is( scalar( $obj->get_option(qw( foo bar)) ), "baz", '... got last option in scalar context' ); is( exception { $obj->set_option( oink => "blah", xxy => "flop" ); }, undef, '... set the option okay' ); is( $obj->num_options, 4, "4 options" ); is_deeply( [ $obj->get_option(qw(foo bar oink xxy)) ], [qw(bar baz blah flop)], "get multiple options at once" ); is( exception { is( scalar $obj->delete_option('bar'), 'baz', 'delete returns deleted value' ); }, undef, '... deleted the option okay' ); is( exception { is_deeply( [ $obj->delete_option( 'oink', 'xxy' ) ], [ 'blah', 'flop' ], 'delete returns all deleted values in list context' ); }, undef, '... deleted multiple option okay' ); is( $obj->num_options, 1, '... we have 1 option(s)' ); is_deeply( $obj->options, { foo => 'bar' }, '... got more options now' ); $obj->clear_options; is_deeply( $obj->options, {}, "... cleared options" ); is( exception { $obj->quantity(4); }, undef, '... options added okay with defaults' ); is( $obj->quantity, 4, 'reader part of curried accessor works' ); is( $obj->option_accessor('quantity'), 4, 'accessor as reader' ); is_deeply( $obj->options, { quantity => 4 }, '... returns what we expect' ); $obj->option_accessor( size => 42 ); like( exception { $obj->option_accessor; }, qr/number of parameters/, 'error when calling accessor with no arguments' ); like( exception { $obj->option_accessor( undef, 'bar' ) }, qr/did not pass type constraint/, 'exception when using undef as a key' ); is_deeply( $obj->options, { quantity => 4, size => 42 }, 'accessor as writer' ); is( exception { $class->new( options => { foo => 'BAR' } ); }, undef, '... good constructor params' ); isnt( exception { $obj->set_option( bar => {} ); }, undef, '... could not add a hash ref where an string is expected' ); isnt( exception { $class->new( options => { foo => [] } ); }, undef, '... bad constructor params' ); $obj->options( {} ); is_deeply( [ $obj->set_option( oink => "blah", xxy => "flop" ) ], [ 'blah', 'flop' ], 'set returns newly set values in order of keys provided' ); is_deeply( [ sort $obj->keys ], [ 'oink', 'xxy' ], 'keys returns expected keys' ); is_deeply( [ sort $obj->values ], [ 'blah', 'flop' ], 'values returns expected values' ); my @key_value = sort { $a->[0] cmp $b->[0] } $obj->key_value; is_deeply( \@key_value, [ sort { $a->[0] cmp $b->[0] }[ 'xxy', 'flop' ], [ 'oink', 'blah' ] ], '... got the right key value pairs' ) or do { require Data::Dumper; diag( Data::Dumper::Dumper( \@key_value ) ); }; my %options_elements = $obj->options_elements; is_deeply( \%options_elements, { 'oink' => 'blah', 'xxy' => 'flop' }, '... got the right hash elements' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->set_option( y => 2 ); is_deeply( $obj->options, { x => 1, y => 2 }, 'set_option with lazy default' ); $obj->_clear_options; ok( $obj->has_option('x'), 'key for x exists - lazy default' ); $obj->_clear_options; ok( $obj->is_defined('x'), 'key for x is defined - lazy default' ); $obj->_clear_options; is_deeply( [ $obj->key_value ], [ [ x => 1 ] ], 'kv returns lazy default' ); $obj->_clear_options; $obj->option_accessor( y => 2 ); is_deeply( [ sort $obj->keys ], [ 'x', 'y' ], 'accessor triggers lazy default generator' ); } # } # $class; } { my ( $class, $handles ) = build_class( isa => HashRef ); my $obj = $class->new; # with_immutable { is( exception { $obj->option_accessor( 'foo', undef ) }, undef, 'can use accessor to set value to undef' ); is( exception { $obj->quantity(undef) }, undef, 'can use accessor to set value to undef' ); # } # $class; } done_testing; trait_number.t000664001750001750 1025214772476615 17426 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/02moouse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires { 'Moo' => '1.006' } }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my %handles = ( abs => 'abs', add => 'add', inc => [ add => 1 ], div => 'div', cut_in_half => [ div => 2 ], mod => 'mod', odd => [ mod => 2 ], mul => 'mul', set => 'set', sub => 'sub', dec => [ sub => 1 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Number'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moo; use Sub::HandlesVia; use Types::Standard qw(Int); has integer => ( traits => [\@traits], is => 'rw', isa => Int, default => 5, handles => \\%handles_copy, clearer => '_clear_integer', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); run_tests( build_class( isa => Types::Standard::Num()->where(sub {1}) ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new; is( $obj->integer, 5, 'Default to five' ); is( $obj->add(10), 15, 'add returns new value' ); is( $obj->integer, 15, 'Add ten for fithteen' ); like( exception { $obj->add( 10, 2 ) }, qr/number of parameters/, 'add throws an error when 2 arguments are passed' ); is( $obj->sub(3), 12, 'sub returns new value' ); is( $obj->integer, 12, 'Subtract three for 12' ); like( exception { $obj->sub( 10, 2 ) }, qr/number of parameters/, 'sub throws an error when 2 arguments are passed' ); is( $obj->set(10), 10, 'set returns new value' ); is( $obj->integer, 10, 'Set to ten' ); like( exception { $obj->set( 10, 2 ) }, qr/number of parameters/, 'set throws an error when 2 arguments are passed' ); is( $obj->div(2), 5, 'div returns new value' ); is( $obj->integer, 5, 'divide by 2' ); like( exception { $obj->div( 10, 2 ) }, qr/number of parameters/, 'div throws an error when 2 arguments are passed' ); is( $obj->mul(2), 10, 'mul returns new value' ); is( $obj->integer, 10, 'multiplied by 2' ); like( exception { $obj->mul( 10, 2 ) }, qr/number of parameters/, 'mul throws an error when 2 arguments are passed' ); is( $obj->mod(2), 0, 'mod returns new value' ); is( $obj->integer, 0, 'Mod by 2' ); like( exception { $obj->mod( 10, 2 ) }, qr/number of parameters/, 'mod throws an error when 2 arguments are passed' ); $obj->set(7); $obj->mod(5); is( $obj->integer, 2, 'Mod by 5' ); $obj->set(-1); is( $obj->abs, 1, 'abs returns new value' ); like( exception { $obj->abs(10) }, qr/number of parameters/, 'abs throws an error when an argument is passed' ); is( $obj->integer, 1, 'abs 1' ); $obj->set(12); $obj->inc; is( $obj->integer, 13, 'inc 12' ); $obj->dec; is( $obj->integer, 12, 'dec 13' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->add(2); is( $obj->integer, 7, 'add with lazy default' ); $obj->_clear_integer; $obj->mod(2); is( $obj->integer, 1, 'mod with lazy default' ); } # } # $class; } done_testing; trait_string.t000664001750001750 2301114772476615 17441 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/02moouse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires { 'Moo' => '1.006' } }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my %handles = ( inc => 'inc', append => 'append', append_curried => [ append => '!' ], prepend => 'prepend', prepend_curried => [ prepend => '-' ], replace => 'replace', replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ], chop => 'chop', chomp => 'chomp', clear => 'clear', match => 'match', match_curried => [ match => qr/\D/ ], length => 'length', substr => 'substr', substr_curried_1 => [ substr => (1) ], substr_curried_2 => [ substr => ( 1, 3 ) ], substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'String'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moo; use Sub::HandlesVia; use Types::Standard qw(Str); has _string => ( traits => [\@traits], is => 'rw', isa => Str, default => q{}, handles => \\%handles_copy, clearer => '_clear_string', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1, default => q{} ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); run_tests( build_class( isa => Types::Standard::Str()->where(sub {1}) ) ); # coerce 'MyStr', from 'Str', via { $_ }; # # run_tests( build_class( isa => 'MyStr', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new(); is( $obj->length, 0, 'length returns zero' ); $obj->_string('a'); is( $obj->length, 1, 'length returns 1 for new string' ); like( exception { $obj->length(42) }, qr/number of parameters/, 'length throws an error when an argument is passed' ); is( $obj->inc, 'b', 'inc returns new value' ); is( $obj->_string, 'b', 'a becomes b after inc' ); like( exception { $obj->inc(42) }, qr/number of parameters/, 'inc throws an error when an argument is passed' ); is( $obj->append('foo'), 'bfoo', 'append returns new value' ); is( $obj->_string, 'bfoo', 'appended to the string' ); like( exception { $obj->append( 'foo', 2 ) }, qr/number of parameters/, 'append throws an error when two arguments are passed' ); $obj->append_curried; is( $obj->_string, 'bfoo!', 'append_curried appended to the string' ); like( exception { $obj->append_curried('foo') }, qr/number of parameters/, 'append_curried throws an error when two arguments are passed' ); $obj->_string("has nl$/"); is( $obj->chomp, 1, 'chomp returns number of characters removed' ); is( $obj->_string, 'has nl', 'chomped string' ); is( $obj->chomp, 0, 'chomp returns number of characters removed' ); is( $obj->_string, 'has nl', 'chomp is a no-op when string has no line ending' ); like( exception { $obj->chomp(42) }, qr/number of parameters/, 'chomp throws an error when an argument is passed' ); is( $obj->chop, 'l', 'chop returns character removed' ); is( $obj->_string, 'has n', 'chopped string' ); like( exception { $obj->chop(42) }, qr/number of parameters/, 'chop throws an error when an argument is passed' ); $obj->_string('x'); is( $obj->prepend('bar'), 'barx', 'prepend returns new value' ); is( $obj->_string, 'barx', 'prepended to string' ); $obj->prepend_curried; is( $obj->_string, '-barx', 'prepend_curried prepended to string' ); is( $obj->replace( qr/([ao])/, sub { uc($1) } ), '-bArx', 'replace returns new value' ); is( $obj->_string, '-bArx', 'substitution using coderef for replacement' ); $obj->replace( qr/A/, 'X' ); is( $obj->_string, '-bXrx', 'substitution using string as replacement' ); $obj->_string('foo'); $obj->replace( qr/oo/, q{} ); is( $obj->_string, 'f', 'replace accepts an empty string as second argument' ); $obj->replace( q{}, 'a' ); is( $obj->_string, 'af', 'replace accepts an empty string as first argument' ); like( exception { $obj->replace( {}, 'x' ) }, qr/did not pass type constraint/, 'replace throws an error when the first argument is not a string or regexp' ); like( exception { $obj->replace( qr/x/, {} ) }, qr/did not pass type constraint/, 'replace throws an error when the first argument is not a string or regexp' ); $obj->_string('Moosex'); $obj->replace_curried; is( $obj->_string, 'MooseX', 'capitalize last' ); $obj->_string('abcdef'); is_deeply( [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ], 'match -barx against /[aq]/ returns matches' ); is_deeply( [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ], 'match -barx against /[aq]/ returns matches' ); ok( scalar $obj->match('b'), 'match with string as argument returns true' ); ok( scalar $obj->match(q{}), 'match with empty string as argument returns true' ); like( exception { $obj->match }, qr/number of parameters/, 'match throws an error when no arguments are passed' ); like( exception { $obj->match( {} ) }, qr/did not pass type constraint/, 'match throws an error when an invalid argument is passed' ); $obj->_string('1234'); ok( !$obj->match_curried, 'match_curried returns false' ); $obj->_string('one two three four'); ok( $obj->match_curried, 'match curried returns true' ); $obj->clear; is( $obj->_string, q{}, 'clear' ); like( exception { $obj->clear(42) }, qr/number of parameters/, 'clear throws an error when an argument is passed' ); $obj->_string('some long string'); is( $obj->substr(1), 'ome long string', 'substr as getter with one argument' ); $obj->_string('some long string'); is( $obj->substr( 1, 3 ), 'ome', 'substr as getter with two arguments' ); is( $obj->substr( 1, 3, 'ong' ), 'ome', 'substr as setter returns replaced string' ); is( $obj->_string, 'song long string', 'substr as setter with three arguments' ); $obj->substr( 1, 3, '' ); is( $obj->_string, 's long string', 'substr as setter with three arguments, replacment is empty string' ); like( exception { $obj->substr }, qr/number of parameters/, 'substr throws an error when no argumemts are passed' ); like( exception { $obj->substr( 1, 2, 3, 4 ) }, qr/number of parameters/, 'substr throws an error when four argumemts are passed' ); like( exception { $obj->substr( {} ) }, qr/did not pass type constraint/, 'substr throws an error when first argument is not an integer' ); like( exception { $obj->substr( 1, {} ) }, qr/did not pass type constraint/, 'substr throws an error when second argument is not an integer' ); like( exception { $obj->substr( 1, 2, {} ) }, qr/did not pass type constraint/, 'substr throws an error when third argument is not a string' ); $obj->_string('some long string'); is( $obj->substr_curried_1, 'ome long string', 'substr_curried_1 returns expected value' ); is( $obj->substr_curried_1(3), 'ome', 'substr_curried_1 with one argument returns expected value' ); $obj->substr_curried_1( 3, 'ong' ); is( $obj->_string, 'song long string', 'substr_curried_1 as setter with two arguments' ); $obj->_string('some long string'); is( $obj->substr_curried_2, 'ome', 'substr_curried_2 returns expected value' ); $obj->substr_curried_2('ong'); is( $obj->_string, 'song long string', 'substr_curried_2 as setter with one arguments' ); $obj->_string('some long string'); $obj->substr_curried_3; is( $obj->_string, 'song long string', 'substr_curried_3 as setter' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->append('foo'); is( $obj->_string, 'foo', 'append with lazy default' ); } # } # $class; } done_testing; role.t000664001750001750 163714772476615 16740 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/03moo_mxttuse strict; use warnings; use Test::More; use Test::Fatal; { package Local::Dummy1; use Test::Requires 'Moo'; use Test::Requires 'MooX::TypeTiny' }; { package Local::Role1; use Moo::Role; use Sub::HandlesVia; use Types::Standard qw( ArrayRef Int ); has nums => ( is => 'ro', isa => ArrayRef[Int], builder => sub { [ 1..10 ] }, handles_via => 'Array', handles => { pop_num => 'pop', push_num => 'push' }, ); } { package Local::Class1; use Moo; use MooX::TypeTiny; with 'Local::Role1'; } #require B::Deparse; #::note( B::Deparse->new->coderef2text(\&Local::Class1::pop_num) ); my $obj = Local::Class1->new; is( $obj->pop_num, 10 ); is( $obj->pop_num, 9 ); is( $obj->pop_num, 8 ); is( $obj->pop_num, 7 ); isnt( exception { $obj->push_num(44.5) }, undef, ); is( $obj->pop_num, 6 ); is( exception { $obj->push_num(6) }, undef, ); is( $obj->pop_num, 6 ); done_testing; trait_array.t000664001750001750 6340514772476615 20341 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/03moo_mxttuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Moo'; use Test::Requires 'MooX::TypeTiny'; }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my %handles = ( count => 'count', elements => 'elements', is_empty => 'is_empty', push => 'push', push_curried => [ push => 42, 84 ], unshift => 'unshift', unshift_curried => [ unshift => 42, 84 ], pop => 'pop', shift => 'shift', get => 'get', get_curried => [ get => 1 ], set => 'set', set_curried_1 => [ set => 1 ], set_curried_2 => [ set => ( 1, 98 ) ], accessor => 'accessor', accessor_curried_1 => [ accessor => 1 ], accessor_curried_2 => [ accessor => ( 1, 90 ) ], clear => 'clear', delete => 'delete', delete_curried => [ delete => 1 ], insert => 'insert', insert_curried => [ insert => ( 1, 101 ) ], splice => 'splice', splice_curried_1 => [ splice => 1 ], splice_curried_2 => [ splice => 1, 2 ], splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ], sort => 'sort', sort_curried => [ sort => ( sub { $_[1] <=> $_[0] } ) ], sort_in_place => 'sort_in_place', sort_in_place_curried => [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ], map => 'map', map_curried => [ map => ( sub { $_ + 1 } ) ], grep => 'grep', grep_curried => [ grep => ( sub { $_ < 5 } ) ], first => 'first', first_curried => [ first => ( sub { $_ % 2 } ) ], first_index => 'first_index', first_index_curried => [ first_index => ( sub { $_ % 2 } ) ], join => 'join', join_curried => [ join => '-' ], shuffle => 'shuffle', uniq => 'uniq', reduce => 'reduce', reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ], natatime => 'natatime', natatime_curried => [ natatime => 2 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Array'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moo; use MooX::TypeTiny; use Sub::HandlesVia; use Types::Standard qw(ArrayRef Int); has _values => ( traits => [\@traits], is => 'rw', isa => ArrayRef[Int], default => sub { [] }, handles => \\%handles_copy, clearer => '_clear_values', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { package Overloader; use overload '&{}' => sub { ${ $_[0] } }, bool => sub {1}; sub new { bless \$_[1], $_[0]; } } { package OverloadStr; use overload q{""} => sub { ${ $_[0] } }, fallback => 1; sub new { my $class = shift; my $str = shift; return bless \$str, $class; } } { package OverloadNum; use overload q{0+} => sub { ${ $_[0] } }, fallback => 1; sub new { my $class = shift; my $str = shift; return bless \$str, $class; } } use Types::Standard qw( ArrayRef Int ); { subtest( 'simple case', sub { run_tests(build_class) } ); subtest( 'lazy default attr', sub { run_tests( build_class( lazy => 1, default => sub { [ 42, 84 ] } ) ); } ); subtest( 'attr with trigger', sub { run_tests( build_class( trigger => sub { } ) ); } ); subtest( 'attr is not inlined', sub { run_tests( build_class( no_inline => 1 ) ) } ); subtest( 'attr type forces the inlining code to check the entire arrayref when it is modified', sub { run_tests( build_class( isa => ArrayRef->where(sub {1}) ) ); } ); subtest( 'attr type has coercion', sub { run_tests( build_class( isa => ArrayRef->plus_coercions(Int, '[$_]'), coerce => 1 ) ); } ); } subtest( 'setting value to undef with accessor', sub { my ( $class, $handles ) = build_class( isa => ArrayRef ); note "Testing class $class"; my $obj = $class->new; # with_immutable { is( exception { $obj->accessor( 0, undef ) }, undef, 'can use accessor to set value to undef' ); is( exception { $obj->accessor_curried_1(undef) }, undef, 'can use curried accessor to set value to undef' ); # } # $class; } ); sub run_tests { my ( $class, $handles ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new( _values => [ 10, 12, 42 ] ); is_deeply( $obj->_values, [ 10, 12, 42 ], 'values can be set in constructor' ); ok( !$obj->is_empty, 'values is not empty' ); is( $obj->count, 3, 'count returns 3' ); like( exception { $obj->count(22) }, qr/number of parameters/, 'throws an error when passing an argument passed to count' ); is( exception { $obj->push( 1, 2, 3 ) }, undef, 'pushed three new values and lived' ); is( exception { $obj->push() }, undef, 'call to push without arguments lives' ); is( exception { is( $obj->unshift( 101, 22 ), 8, 'unshift returns size of the new array' ); }, undef, 'unshifted two values and lived' ); is_deeply( $obj->_values, [ 101, 22, 10, 12, 42, 1, 2, 3 ], 'unshift changed the value of the array in the object' ); is( exception { $obj->unshift() }, undef, 'call to unshift without arguments lives' ); is( $obj->pop, 3, 'pop returns the last value in the array' ); is_deeply( $obj->_values, [ 101, 22, 10, 12, 42, 1, 2 ], 'pop changed the value of the array in the object' ); like( exception { $obj->pop(42) }, qr/number of parameters/, 'call to pop with arguments dies' ); is( $obj->shift, 101, 'shift returns the first value' ); like( exception { $obj->shift(42) }, qr/number of parameters/, 'call to shift with arguments dies' ); is_deeply( $obj->_values, [ 22, 10, 12, 42, 1, 2 ], 'shift changed the value of the array in the object' ); is_deeply( [ $obj->elements ], [ 22, 10, 12, 42, 1, 2 ], 'call to elements returns values as a list' ); is(scalar($obj->elements), 6, 'elements accessor in scalar context returns the number of elements in the list'); like( exception { $obj->elements(22) }, qr/number of parameters/, 'throws an error when passing an argument passed to elements' ); $obj->_values( [ 1, 2, 3 ] ); is( $obj->get(0), 1, 'get values at index 0' ); is( $obj->get(1), 2, 'get values at index 1' ); is( $obj->get(2), 3, 'get values at index 2' ); is( $obj->get_curried, 2, 'get_curried returns value at index 1' ); like( exception { $obj->get() }, qr/number of parameters/, 'throws an error when get is called without any arguments' ); like( exception { $obj->get( {} ) }, qr/did not pass type constraint/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get(2.2) }, qr/did not pass type constraint/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get('foo') }, qr/did not pass type constraint/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get_curried(2) }, qr/number of parameters/, 'throws an error when get_curried is called with an argument' ); is( exception { is( $obj->set( 1, 100 ), 100, 'set returns new value' ); }, undef, 'set value at index 1 lives' ); is( $obj->get(1), 100, 'get value at index 1 returns new value' ); like( exception { $obj->set( 1, 99, 42 ) }, qr/number of parameters/, 'throws an error when set is called with three arguments' ); is( exception { $obj->set_curried_1(99) }, undef, 'set_curried_1 lives' ); is( $obj->get(1), 99, 'get value at index 1 returns new value' ); like( exception { $obj->set_curried_1( 99, 42 ) }, qr/number of parameters/, 'throws an error when set_curried_1 is called with two arguments' ); is( exception { $obj->set_curried_2 }, undef, 'set_curried_2 lives' ); is( $obj->get(1), 98, 'get value at index 1 returns new value' ); like( exception { $obj->set_curried_2(42) }, qr/number of parameters/, 'throws an error when set_curried_2 is called with one argument' ); #use B::Deparse; #diag(B::Deparse->new->coderef2text($obj->can('accessor'))); is( $obj->accessor(1), 98, 'accessor with one argument returns value at index 1' ); is( exception { is( $obj->accessor( 1 => 97 ), 97, 'accessor returns new value' ); }, undef, 'accessor as writer lives' ); like( exception { $obj->accessor; }, qr/number of parameters/, 'throws an error when accessor is called without arguments' ); is( $obj->get(1), 97, 'accessor set value at index 1' ); like( exception { $obj->accessor( 1, 96, 42 ) }, qr/number of parameters/, 'throws an error when accessor is called with three arguments' ); is( $obj->accessor_curried_1, 97, 'accessor_curried_1 returns expected value when called with no arguments' ); is( exception { $obj->accessor_curried_1(95) }, undef, 'accessor_curried_1 as writer lives' ); is( $obj->get(1), 95, 'accessor_curried_1 set value at index 1' ); like( exception { $obj->accessor_curried_1( 96, 42 ) }, qr/number of parameters/, 'throws an error when accessor_curried_1 is called with two arguments' ); is( exception { $obj->accessor_curried_2 }, undef, 'accessor_curried_2 as writer lives' ); is( $obj->get(1), 90, 'accessor_curried_2 set value at index 1' ); like( exception { $obj->accessor_curried_2(42) }, qr/number of parameters/, 'throws an error when accessor_curried_2 is called with one argument' ); is( exception { $obj->clear }, undef, 'clear lives' ); ok( $obj->is_empty, 'values is empty after call to clear' ); is( exception { is( $obj->shift, undef, 'shift returns undef on an empty array' ); }, undef, 'shifted from an empty array and lived' ); $obj->set( 0 => 42 ); like( exception { $obj->clear(50) }, qr/number of parameters/, 'throws an error when clear is called with an argument' ); ok( !$obj->is_empty, 'values is not empty after failed call to clear' ); like( exception { $obj->is_empty(50) }, qr/number of parameters/, 'throws an error when is_empty is called with an argument' ); $obj->clear; is( $obj->push( 1, 5, 10, 42 ), 4, 'pushed 4 elements, got number of elements in the array back' ); is( exception { is( $obj->delete(2), 10, 'delete returns deleted value' ); }, undef, 'delete lives' ); is_deeply( $obj->_values, [ 1, 5, 42 ], 'delete removed the specified element' ); like( exception { $obj->delete( 2, 3 ) }, qr/number of parameters/, 'throws an error when delete is called with two arguments' ); is( exception { $obj->delete_curried }, undef, 'delete_curried lives' ); is_deeply( $obj->_values, [ 1, 42 ], 'delete removed the specified element' ); like( exception { $obj->delete_curried(2) }, qr/number of parameters/, 'throws an error when delete_curried is called with one argument' ); is( exception { $obj->insert( 1, 21 ) }, undef, 'insert lives' ); is_deeply( $obj->_values, [ 1, 21, 42 ], 'insert added the specified element' ); like( exception { $obj->insert( 1, 22, 44 ) }, qr/number of parameters/, 'throws an error when insert is called with three arguments' ); is( exception { is_deeply( [ $obj->splice( 1, 0, 2, 3 ) ], [], 'return value of splice is empty list when not removing elements' ); }, undef, 'splice lives' ); is_deeply( $obj->_values, [ 1, 2, 3, 21, 42 ], 'splice added the specified elements' ); is( exception { is_deeply( [ $obj->splice( 1, 2, 99 ) ], [ 2, 3 ], 'splice returns list of removed values' ); }, undef, 'splice lives' ); is_deeply( $obj->_values, [ 1, 99, 21, 42 ], 'splice added the specified elements' ); like( exception { $obj->splice() }, qr/number of parameters/, 'throws an error when splice is called with no arguments' ); like( exception { $obj->splice( 1, 'foo', ) }, qr/did not pass type constraint/, 'throws an error when splice is called with an invalid length' ); is( exception { $obj->splice_curried_1( 2, 101 ) }, undef, 'splice_curried_1 lives' ); is_deeply( $obj->_values, [ 1, 101, 42 ], 'splice added the specified elements' ); is( exception { $obj->splice_curried_2(102) }, undef, 'splice_curried_2 lives' ); is_deeply( $obj->_values, [ 1, 102 ], 'splice added the specified elements' ); is( exception { $obj->splice_curried_all }, undef, 'splice_curried_all lives' ); is_deeply( $obj->_values, [ 1, 3, 4, 5 ], 'splice added the specified elements' ); is_deeply( scalar $obj->splice( 1, 2 ), 4, 'splice in scalar context returns last element removed' ); is_deeply( scalar $obj->splice( 1, 0, 42 ), undef, 'splice in scalar context returns undef when no elements are removed' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); is_deeply( [ $obj->sort ], [ 11, 22, 3, 5, 9 ], 'sort returns sorted values' ); is(scalar($obj->sort), 5, 'sort accessor in scalar context returns the number of elements in the list'); is_deeply( [ $obj->sort( sub { $_[0] <=> $_[1] } ) ], [ 3, 5, 9, 11, 22 ], 'sort returns values sorted by provided function' ); is(scalar($obj->sort( sub { $_[0] <=> $_[1] } )), 5, 'sort accessor with sort sub in scalar context returns the number of elements in the list'); like( exception { $obj->sort(1) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to sort' ); like( exception { $obj->sort( sub { }, 27 ); }, qr/number of parameters/, 'throws an error when passing two arguments to sort' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); $obj->sort_in_place; is_deeply( $obj->_values, [ 11, 22, 3, 5, 9 ], 'sort_in_place sorts values' ); $obj->sort_in_place( sub { $_[0] <=> $_[1] } ); is_deeply( $obj->_values, [ 3, 5, 9, 11, 22 ], 'sort_in_place with function sorts values' ); like( exception { $obj->sort_in_place( 27 ); }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to sort_in_place' ); like( exception { $obj->sort_in_place( sub { }, 27 ); }, qr/number of parameters/, 'throws an error when passing two arguments to sort_in_place' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); $obj->sort_in_place_curried; is_deeply( $obj->_values, [ 22, 11, 9, 5, 3 ], 'sort_in_place_curried sorts values' ); like( exception { $obj->sort_in_place_curried(27) }, qr/number of parameters/, 'throws an error when passing one argument passed to sort_in_place_curried' ); $obj->_values( [ 1 .. 5 ] ); is_deeply( [ $obj->map( sub { $_ + 1 } ) ], [ 2 .. 6 ], 'map returns the expected values' ); like( exception { $obj->map }, qr/number of parameters/, 'throws an error when passing no arguments to map' ); like( exception { $obj->map( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to map' ); like( exception { $obj->map( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to map' ); $obj->_values( [ 1 .. 5 ] ); is_deeply( [ $obj->map_curried ], [ 2 .. 6 ], 'map_curried returns the expected values' ); like( exception { $obj->map_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to map_curried' ); $obj->_values( [ 2 .. 9 ] ); is_deeply( [ $obj->grep( sub { $_ < 5 } ) ], [ 2 .. 4 ], 'grep returns the expected values' ); like( exception { $obj->grep }, qr/number of parameters/, 'throws an error when passing no arguments to grep' ); like( exception { $obj->grep( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to grep' ); like( exception { $obj->grep( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to grep' ); # my $overloader = Overloader->new( sub { $_ < 5 } ); # is_deeply( # [ $obj->grep($overloader) ], # [ 2 .. 4 ], # 'grep works with obj that overload code dereferencing' # ); is_deeply( [ $obj->grep_curried ], [ 2 .. 4 ], 'grep_curried returns the expected values' ); like( exception { $obj->grep_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to grep_curried' ); $obj->_values( [ 2, 4, 22, 99, 101, 6 ] ); is( $obj->first( sub { $_ % 2 } ), 99, 'first returns expected value' ); like( exception { $obj->first }, qr/number of parameters/, 'throws an error when passing no arguments to first' ); like( exception { $obj->first( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to first' ); like( exception { $obj->first( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to first' ); is( $obj->first_curried, 99, 'first_curried returns expected value' ); like( exception { $obj->first_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to first_curried' ); is( $obj->first_index( sub { $_ % 2 } ), 3, 'first_index returns expected value' ); like( exception { $obj->first_index }, qr/number of parameters/, 'throws an error when passing no arguments to first_index' ); like( exception { $obj->first_index( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to first_index' ); like( exception { $obj->first_index( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to first_index' ); is( $obj->first_index_curried, 3, 'first_index_curried returns expected value' ); like( exception { $obj->first_index_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to first_index_curried' ); $obj->_values( [ 1 .. 4 ] ); is( $obj->join('-'), '1-2-3-4', 'join returns expected result' ); is( $obj->join(q{}), '1234', 'join returns expected result when joining with empty string' ); is( $obj->join(0), '1020304', 'join returns expected result when joining with 0 as number' ); is( $obj->join("0"), '1020304', 'join returns expected result when joining with 0 as string' ); # is( # $obj->join( OverloadStr->new(q{}) ), '1234', # 'join returns expected result when joining with object with string overload' # ); # # is( # $obj->join( OverloadNum->new(0) ), '1020304', # 'join returns expected result when joining with object with numify overload' # ); # like( exception { $obj->join }, qr/number of parameters/, 'throws an error when passing no arguments to join' ); like( exception { $obj->join( '-', 2 ) }, qr/number of parameters/, 'throws an error when passing two arguments to join' ); like( exception { $obj->join( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non string to join' ); is_deeply( [ sort $obj->shuffle ], [ 1 .. 4 ], 'shuffle returns all values (cannot check for a random order)' ); like( exception { $obj->shuffle(2) }, qr/number of parameters/, 'throws an error when passing an argument passed to shuffle' ); $obj->_values( [ 1 .. 4, 2, 5, 3, 7, 3, 3, 1 ] ); is_deeply( [ $obj->uniq ], [ 1 .. 4, 5, 7 ], 'uniq returns expected values (in original order)' ); like( exception { $obj->uniq(2) }, qr/number of parameters/, 'throws an error when passing an argument passed to uniq' ); $obj->_values( [ 1 .. 5 ] ); is( $obj->reduce( sub { $_[0] * $_[1] } ), 120, 'reduce returns expected value' ); like( exception { $obj->reduce }, qr/number of parameters/, 'throws an error when passing no arguments to reduce' ); like( exception { $obj->reduce( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to reduce' ); like( exception { $obj->reduce( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to reduce' ); is( $obj->reduce_curried, 120, 'reduce_curried returns expected value' ); like( exception { $obj->reduce_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to reduce_curried' ); $obj->_values( [ 1 .. 6 ] ); my $it = $obj->natatime(2); my @nat; while ( my @v = $it->() ) { push @nat, \@v; } is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime returns expected iterator' ) or diag(explain(\@nat)); @nat = (); $obj->natatime( 2, sub { push @nat, [@_] } ); is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime with function returns expected value' ); like( exception { $obj->natatime( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non integer to natatime' ); like( exception { $obj->natatime( 2, {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non code ref to natatime' ); $it = $obj->natatime_curried(); @nat = (); while ( my @v = $it->() ) { push @nat, \@v; } is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime_curried returns expected iterator' ); @nat = (); $obj->natatime_curried( sub { push @nat, [@_] } ); is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime_curried with function returns expected value' ); like( exception { $obj->natatime_curried( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non code ref to natatime_curried' ); if ( $class->class_is_lazy ) { my $obj = $class->new; is( $obj->count, 2, 'count is 2 (lazy init)' ); $obj->_clear_values; is_deeply( [ $obj->elements ], [ 42, 84 ], 'elements contains default with lazy init' ); $obj->_clear_values; $obj->push(2); is_deeply( $obj->_values, [ 42, 84, 2 ], 'push works with lazy init' ); $obj->_clear_values; $obj->unshift( 3, 4 ); is_deeply( $obj->_values, [ 3, 4, 42, 84 ], 'unshift works with lazy init' ); } # } # $class; } done_testing; trait_bool.t000664001750001750 557414772476615 20141 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/03moo_mxttuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Moo'; use Test::Requires 'MooX::TypeTiny'; }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my %handles = ( illuminate => 'set', darken => 'unset', flip_switch => 'toggle', is_dark => 'not', ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Bool'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moo; use MooX::TypeTiny; use Sub::HandlesVia; use Types::Standard qw(Bool); has is_lit => ( traits => [\@traits], is => 'rw', isa => Bool, default => 1, handles => \\%handles_copy, clearer => '_clear_is_lit', %attr, ); 1; } or die($@); return ( $class, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); run_tests( build_class( isa => Types::Standard::Bool()->where(sub {1}) ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new; ok( $obj->illuminate, 'set returns true' ); ok( $obj->is_lit, 'set is_lit to 1 using ->illuminate' ); ok( !$obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->illuminate(1) }, qr/number of parameters/, 'set throws an error when an argument is passed' ); ok( !$obj->darken, 'unset returns false' ); ok( !$obj->is_lit, 'set is_lit to 0 using ->darken' ); ok( $obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->darken(1) }, qr/number of parameters/, 'unset throws an error when an argument is passed' ); ok( $obj->flip_switch, 'toggle returns new value' ); ok( $obj->is_lit, 'toggle is_lit back to 1 using ->flip_switch' ); ok( !$obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->flip_switch(1) }, qr/number of parameters/, 'toggle throws an error when an argument is passed' ); $obj->flip_switch; ok( !$obj->is_lit, 'toggle is_lit back to 0 again using ->flip_switch' ); ok( $obj->is_dark, 'check if is_dark does the right thing' ); # } # $class; } done_testing; trait_code.t000664001750001750 570214772476615 20111 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/03moo_mxttuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Moo'; use Test::Requires 'MooX::TypeTiny'; }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my $name = 'Foo1'; sub build_class { my ( $attr1, $attr2, $attr3, $no_inline ) = @_; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Code'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moo; use MooX::TypeTiny; use Sub::HandlesVia; use Types::Standard qw(CodeRef); has( callback => ( is => 'bare', handles_via => [\@traits], isa => CodeRef, required => 1, handles => { 'invoke_callback' => 'execute' }, %{ \$attr1 || {} }, ) ); has( callback_method => ( is => 'bare', handles_via => [\@traits], isa => CodeRef, required => 1, handles => { 'invoke_method_callback' => 'execute_method' }, %{ \$attr2 || {} }, ) ); has( multiplier => ( is => 'bare', handles_via => [\@traits], isa => CodeRef, required => 1, handles => { 'multiply' => 'execute' }, %{ \$attr3 || {} }, ) ); 1; } or die($@); return $class; } } { my $i; my %subs = ( callback => sub { ++$i }, callback_method => sub { shift->multiply(@_) }, multiplier => sub { $_[0] * 2 }, ); run_tests( build_class, \$i, \%subs ); run_tests( build_class( undef, undef, undef, 1 ), \$i, \%subs ); run_tests( build_class( { lazy => 1, default => sub { $subs{callback} } }, { lazy => 1, default => sub { $subs{callback_method} } }, { lazy => 1, default => sub { $subs{multiplier} } }, ), \$i, ); } sub run_tests { my ( $class, $iref, @args ) = @_; note "Testing class $class"; ok( !$class->can($_), "Code trait didn't create reader method for $_" ) for qw(callback callback_method multiplier); # with_immutable { ${$iref} = 0; my $obj = $class->new(@args); $obj->invoke_callback; is( ${$iref}, 1, '$i is 1 after invoke_callback' ); is( $obj->invoke_method_callback(3), 6, 'invoke_method_callback calls multiply with @_' ); is( $obj->multiply(3), 6, 'multiple double value' ); # } # $class; } done_testing; trait_counter.t000664001750001750 1130714772476615 20674 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/03moo_mxttuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Moo'; use Test::Requires 'MooX::TypeTiny'; }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; use Types::Standard (); { my %handles = ( inc_counter => 'inc', inc_counter_2 => [ inc => 2 ], dec_counter => 'dec', dec_counter_2 => [ dec => 2 ], reset_counter => 'reset', set_counter => 'set', set_counter_42 => [ set => 42 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Counter'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moo; use MooX::TypeTiny; use Sub::HandlesVia; use Types::Standard qw(Int); has counter => ( traits => [\@traits], is => 'rw', isa => Int, default => 0, handles => \\%handles_copy, clearer => '_clear_counter', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); run_tests( build_class( isa => Types::Standard::Int()->where(sub {1}) ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new(); is( $obj->counter, 0, '... got the default value' ); is( $obj->inc_counter, 1, 'inc returns new value' ); is( $obj->counter, 1, '... got the incremented value' ); is( $obj->inc_counter, 2, 'inc returns new value' ); is( $obj->counter, 2, '... got the incremented value (again)' ); like( exception { $obj->inc_counter( 1, 2 ) }, qr/number of parameters/, 'inc throws an error when two arguments are passed' ); is( $obj->dec_counter, 1, 'dec returns new value' ); is( $obj->counter, 1, '... got the decremented value' ); like( exception { $obj->dec_counter( 1, 2 ) }, qr/number of parameters/, 'dec throws an error when two arguments are passed' ); is( $obj->reset_counter, 0, 'reset returns new value' ); is( $obj->counter, 0, '... got the original value' ); like( exception { $obj->reset_counter(2) }, qr/number of parameters/, 'reset throws an error when an argument is passed' ); is( $obj->set_counter(5), 5, 'set returns new value' ); is( $obj->counter, 5, '... set the value' ); like( exception { $obj->set_counter( 1, 2 ) }, qr/number of parameters/, 'set throws an error when two arguments are passed' ); $obj->inc_counter(2); is( $obj->counter, 7, '... increment by arg' ); $obj->dec_counter(5); is( $obj->counter, 2, '... decrement by arg' ); $obj->inc_counter_2; is( $obj->counter, 4, '... curried increment' ); $obj->dec_counter_2; is( $obj->counter, 2, '... curried deccrement' ); $obj->set_counter_42; is( $obj->counter, 42, '... curried set' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->inc_counter; is( $obj->counter, 1, 'inc increments - with lazy default' ); $obj->_clear_counter; $obj->dec_counter; is( $obj->counter, -1, 'dec decrements - with lazy default' ); } } # $class; #} { package WithBuilder; use Moo; use Sub::HandlesVia; use Types::Standard 'Int'; has nonlazy => ( traits => ['Counter'], is => 'rw', isa => Int, builder => '_builder', handles => { reset_nonlazy => 'reset', }, ); has lazy => ( traits => ['Counter'], is => 'rw', isa => Int, lazy => 1, builder => '_builder', handles => { reset_lazy => 'reset', }, ); sub _builder { 1 } } for my $attr ('lazy', 'nonlazy') { my $obj = WithBuilder->new; is($obj->$attr, 1, "built properly"); $obj->$attr(0); is($obj->$attr, 0, "can be manually set"); $obj->${\"reset_$attr"}; is($obj->$attr, 1, "reset resets it to its default value"); } done_testing; trait_hash.t000664001750001750 2227314772476615 20144 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/03moo_mxttuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Moo'; use Test::Requires 'MooX::TypeTiny'; }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; BEGIN { require Type::Tiny; Type::Tiny::_USE_XS() or plan skip_all => 'https://rt.cpan.org/Ticket/Display.html?id=131576'; }; { my %handles = ( option_accessor => 'accessor', quantity => [ accessor => 'quantity' ], clear_options => 'clear', num_options => 'count', delete_option => 'delete', is_defined => 'defined', options_elements => 'elements', has_option => 'exists', get_option => 'get', has_no_options => 'is_empty', keys => 'keys', values => 'values', key_value => 'kv', set_option => 'set', ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Hash'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moo; use MooX::TypeTiny; use Sub::HandlesVia; use Types::Standard qw(HashRef Str); has options => ( traits => [\@traits], is => 'rw', isa => HashRef[Str], default => sub { {} }, handles => \\%handles_copy, clearer => '_clear_options', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } use Types::Standard qw( HashRef Str ); { run_tests(build_class); run_tests( build_class( lazy => 1, default => sub { { x => 1 } } ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); run_tests( build_class( isa => HashRef->of(Str)->where(sub {1}) ) ); } sub run_tests { my ( $class, $handles ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new( options => {} ); ok( $obj->has_no_options, '... we have no options' ); is( $obj->num_options, 0, '... we have no options' ); is_deeply( $obj->options, {}, '... no options yet' ); ok( !$obj->has_option('foo'), '... we have no foo option' ); is( exception { is( $obj->set_option( foo => 'bar' ), 'bar', 'set return single new value in scalar context' ); }, undef, '... set the option okay' ); like( exception { $obj->set_option( foo => 'bar', 'baz' ) }, qr/number of parameters/, 'exception with odd number of arguments' ); like( exception { $obj->set_option( undef, 'bar' ) }, qr/did not pass type constraint/, 'exception when using undef as a key' ); ok( $obj->is_defined('foo'), '... foo is defined' ); ok( !$obj->has_no_options, '... we have options' ); is( $obj->num_options, 1, '... we have 1 option(s)' ); ok( $obj->has_option('foo'), '... we have a foo option' ); is_deeply( $obj->options, { foo => 'bar' }, '... got options now' ); is( exception { $obj->set_option( bar => 'baz' ); }, undef, '... set the option okay' ); is( $obj->num_options, 2, '... we have 2 option(s)' ); is_deeply( $obj->options, { foo => 'bar', bar => 'baz' }, '... got more options now' ); is( $obj->get_option('foo'), 'bar', '... got the right option' ); is_deeply( [ $obj->get_option(qw(foo bar)) ], [qw(bar baz)], "get multiple options at once" ); is( scalar( $obj->get_option(qw( foo bar)) ), "baz", '... got last option in scalar context' ); is( exception { $obj->set_option( oink => "blah", xxy => "flop" ); }, undef, '... set the option okay' ); is( $obj->num_options, 4, "4 options" ); is_deeply( [ $obj->get_option(qw(foo bar oink xxy)) ], [qw(bar baz blah flop)], "get multiple options at once" ); is( exception { is( scalar $obj->delete_option('bar'), 'baz', 'delete returns deleted value' ); }, undef, '... deleted the option okay' ); is( exception { is_deeply( [ $obj->delete_option( 'oink', 'xxy' ) ], [ 'blah', 'flop' ], 'delete returns all deleted values in list context' ); }, undef, '... deleted multiple option okay' ); is( $obj->num_options, 1, '... we have 1 option(s)' ); is_deeply( $obj->options, { foo => 'bar' }, '... got more options now' ); $obj->clear_options; is_deeply( $obj->options, {}, "... cleared options" ); is( exception { $obj->quantity(4); }, undef, '... options added okay with defaults' ); is( $obj->quantity, 4, 'reader part of curried accessor works' ); is( $obj->option_accessor('quantity'), 4, 'accessor as reader' ); is_deeply( $obj->options, { quantity => 4 }, '... returns what we expect' ); $obj->option_accessor( size => 42 ); like( exception { $obj->option_accessor; }, qr/number of parameters/, 'error when calling accessor with no arguments' ); like( exception { $obj->option_accessor( undef, 'bar' ) }, qr/did not pass type constraint/, 'exception when using undef as a key' ); is_deeply( $obj->options, { quantity => 4, size => 42 }, 'accessor as writer' ); is( exception { $class->new( options => { foo => 'BAR' } ); }, undef, '... good constructor params' ); isnt( exception { $obj->set_option( bar => {} ); }, undef, '... could not add a hash ref where an string is expected' ); isnt( exception { $class->new( options => { foo => [] } ); }, undef, '... bad constructor params' ); $obj->options( {} ); is_deeply( [ $obj->set_option( oink => "blah", xxy => "flop" ) ], [ 'blah', 'flop' ], 'set returns newly set values in order of keys provided' ); is_deeply( [ sort $obj->keys ], [ 'oink', 'xxy' ], 'keys returns expected keys' ); is_deeply( [ sort $obj->values ], [ 'blah', 'flop' ], 'values returns expected values' ); my @key_value = sort { $a->[0] cmp $b->[0] } $obj->key_value; is_deeply( \@key_value, [ sort { $a->[0] cmp $b->[0] }[ 'xxy', 'flop' ], [ 'oink', 'blah' ] ], '... got the right key value pairs' ) or do { require Data::Dumper; diag( Data::Dumper::Dumper( \@key_value ) ); }; my %options_elements = $obj->options_elements; is_deeply( \%options_elements, { 'oink' => 'blah', 'xxy' => 'flop' }, '... got the right hash elements' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->set_option( y => 2 ); is_deeply( $obj->options, { x => 1, y => 2 }, 'set_option with lazy default' ); $obj->_clear_options; ok( $obj->has_option('x'), 'key for x exists - lazy default' ); $obj->_clear_options; ok( $obj->is_defined('x'), 'key for x is defined - lazy default' ); $obj->_clear_options; is_deeply( [ $obj->key_value ], [ [ x => 1 ] ], 'kv returns lazy default' ); $obj->_clear_options; $obj->option_accessor( y => 2 ); is_deeply( [ sort $obj->keys ], [ 'x', 'y' ], 'accessor triggers lazy default generator' ); } # } # $class; } { my ( $class, $handles ) = build_class( isa => HashRef ); my $obj = $class->new; # with_immutable { is( exception { $obj->option_accessor( 'foo', undef ) }, undef, 'can use accessor to set value to undef' ); is( exception { $obj->quantity(undef) }, undef, 'can use accessor to set value to undef' ); # } # $class; } done_testing; trait_number.t000664001750001750 1032514772476615 20504 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/03moo_mxttuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Moo'; use Test::Requires 'MooX::TypeTiny'; }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my %handles = ( abs => 'abs', add => 'add', inc => [ add => 1 ], div => 'div', cut_in_half => [ div => 2 ], mod => 'mod', odd => [ mod => 2 ], mul => 'mul', set => 'set', sub => 'sub', dec => [ sub => 1 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Number'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moo; use MooX::TypeTiny; use Sub::HandlesVia; use Types::Standard qw(Int); has integer => ( traits => [\@traits], is => 'rw', isa => Int, default => 5, handles => \\%handles_copy, clearer => '_clear_integer', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); run_tests( build_class( isa => Types::Standard::Num()->where(sub {1}) ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new; is( $obj->integer, 5, 'Default to five' ); is( $obj->add(10), 15, 'add returns new value' ); is( $obj->integer, 15, 'Add ten for fithteen' ); like( exception { $obj->add( 10, 2 ) }, qr/number of parameters/, 'add throws an error when 2 arguments are passed' ); is( $obj->sub(3), 12, 'sub returns new value' ); is( $obj->integer, 12, 'Subtract three for 12' ); like( exception { $obj->sub( 10, 2 ) }, qr/number of parameters/, 'sub throws an error when 2 arguments are passed' ); is( $obj->set(10), 10, 'set returns new value' ); is( $obj->integer, 10, 'Set to ten' ); like( exception { $obj->set( 10, 2 ) }, qr/number of parameters/, 'set throws an error when 2 arguments are passed' ); is( $obj->div(2), 5, 'div returns new value' ); is( $obj->integer, 5, 'divide by 2' ); like( exception { $obj->div( 10, 2 ) }, qr/number of parameters/, 'div throws an error when 2 arguments are passed' ); is( $obj->mul(2), 10, 'mul returns new value' ); is( $obj->integer, 10, 'multiplied by 2' ); like( exception { $obj->mul( 10, 2 ) }, qr/number of parameters/, 'mul throws an error when 2 arguments are passed' ); is( $obj->mod(2), 0, 'mod returns new value' ); is( $obj->integer, 0, 'Mod by 2' ); like( exception { $obj->mod( 10, 2 ) }, qr/number of parameters/, 'mod throws an error when 2 arguments are passed' ); $obj->set(7); $obj->mod(5); is( $obj->integer, 2, 'Mod by 5' ); $obj->set(-1); is( $obj->abs, 1, 'abs returns new value' ); like( exception { $obj->abs(10) }, qr/number of parameters/, 'abs throws an error when an argument is passed' ); is( $obj->integer, 1, 'abs 1' ); $obj->set(12); $obj->inc; is( $obj->integer, 13, 'inc 12' ); $obj->dec; is( $obj->integer, 12, 'dec 13' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->add(2); is( $obj->integer, 7, 'add with lazy default' ); $obj->_clear_integer; $obj->mod(2); is( $obj->integer, 1, 'mod with lazy default' ); } # } # $class; } done_testing; trait_string.t000664001750001750 2306414772476615 20526 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/03moo_mxttuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Moo'; use Test::Requires 'MooX::TypeTiny'; }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my %handles = ( inc => 'inc', append => 'append', append_curried => [ append => '!' ], prepend => 'prepend', prepend_curried => [ prepend => '-' ], replace => 'replace', replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ], chop => 'chop', chomp => 'chomp', clear => 'clear', match => 'match', match_curried => [ match => qr/\D/ ], length => 'length', substr => 'substr', substr_curried_1 => [ substr => (1) ], substr_curried_2 => [ substr => ( 1, 3 ) ], substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'String'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moo; use MooX::TypeTiny; use Sub::HandlesVia; use Types::Standard qw(Str); has _string => ( traits => [\@traits], is => 'rw', isa => Str, default => q{}, handles => \\%handles_copy, clearer => '_clear_string', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1, default => q{} ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); run_tests( build_class( isa => Types::Standard::Str()->where(sub {1}) ) ); # coerce 'MyStr', from 'Str', via { $_ }; # # run_tests( build_class( isa => 'MyStr', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new(); is( $obj->length, 0, 'length returns zero' ); $obj->_string('a'); is( $obj->length, 1, 'length returns 1 for new string' ); like( exception { $obj->length(42) }, qr/number of parameters/, 'length throws an error when an argument is passed' ); is( $obj->inc, 'b', 'inc returns new value' ); is( $obj->_string, 'b', 'a becomes b after inc' ); like( exception { $obj->inc(42) }, qr/number of parameters/, 'inc throws an error when an argument is passed' ); is( $obj->append('foo'), 'bfoo', 'append returns new value' ); is( $obj->_string, 'bfoo', 'appended to the string' ); like( exception { $obj->append( 'foo', 2 ) }, qr/number of parameters/, 'append throws an error when two arguments are passed' ); $obj->append_curried; is( $obj->_string, 'bfoo!', 'append_curried appended to the string' ); like( exception { $obj->append_curried('foo') }, qr/number of parameters/, 'append_curried throws an error when two arguments are passed' ); $obj->_string("has nl$/"); is( $obj->chomp, 1, 'chomp returns number of characters removed' ); is( $obj->_string, 'has nl', 'chomped string' ); is( $obj->chomp, 0, 'chomp returns number of characters removed' ); is( $obj->_string, 'has nl', 'chomp is a no-op when string has no line ending' ); like( exception { $obj->chomp(42) }, qr/number of parameters/, 'chomp throws an error when an argument is passed' ); is( $obj->chop, 'l', 'chop returns character removed' ); is( $obj->_string, 'has n', 'chopped string' ); like( exception { $obj->chop(42) }, qr/number of parameters/, 'chop throws an error when an argument is passed' ); $obj->_string('x'); is( $obj->prepend('bar'), 'barx', 'prepend returns new value' ); is( $obj->_string, 'barx', 'prepended to string' ); $obj->prepend_curried; is( $obj->_string, '-barx', 'prepend_curried prepended to string' ); is( $obj->replace( qr/([ao])/, sub { uc($1) } ), '-bArx', 'replace returns new value' ); is( $obj->_string, '-bArx', 'substitution using coderef for replacement' ); $obj->replace( qr/A/, 'X' ); is( $obj->_string, '-bXrx', 'substitution using string as replacement' ); $obj->_string('foo'); $obj->replace( qr/oo/, q{} ); is( $obj->_string, 'f', 'replace accepts an empty string as second argument' ); $obj->replace( q{}, 'a' ); is( $obj->_string, 'af', 'replace accepts an empty string as first argument' ); like( exception { $obj->replace( {}, 'x' ) }, qr/did not pass type constraint/, 'replace throws an error when the first argument is not a string or regexp' ); like( exception { $obj->replace( qr/x/, {} ) }, qr/did not pass type constraint/, 'replace throws an error when the first argument is not a string or regexp' ); $obj->_string('Moosex'); $obj->replace_curried; is( $obj->_string, 'MooseX', 'capitalize last' ); $obj->_string('abcdef'); is_deeply( [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ], 'match -barx against /[aq]/ returns matches' ); is_deeply( [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ], 'match -barx against /[aq]/ returns matches' ); ok( scalar $obj->match('b'), 'match with string as argument returns true' ); ok( scalar $obj->match(q{}), 'match with empty string as argument returns true' ); like( exception { $obj->match }, qr/number of parameters/, 'match throws an error when no arguments are passed' ); like( exception { $obj->match( {} ) }, qr/did not pass type constraint/, 'match throws an error when an invalid argument is passed' ); $obj->_string('1234'); ok( !$obj->match_curried, 'match_curried returns false' ); $obj->_string('one two three four'); ok( $obj->match_curried, 'match curried returns true' ); $obj->clear; is( $obj->_string, q{}, 'clear' ); like( exception { $obj->clear(42) }, qr/number of parameters/, 'clear throws an error when an argument is passed' ); $obj->_string('some long string'); is( $obj->substr(1), 'ome long string', 'substr as getter with one argument' ); $obj->_string('some long string'); is( $obj->substr( 1, 3 ), 'ome', 'substr as getter with two arguments' ); is( $obj->substr( 1, 3, 'ong' ), 'ome', 'substr as setter returns replaced string' ); is( $obj->_string, 'song long string', 'substr as setter with three arguments' ); $obj->substr( 1, 3, '' ); is( $obj->_string, 's long string', 'substr as setter with three arguments, replacment is empty string' ); like( exception { $obj->substr }, qr/number of parameters/, 'substr throws an error when no argumemts are passed' ); like( exception { $obj->substr( 1, 2, 3, 4 ) }, qr/number of parameters/, 'substr throws an error when four argumemts are passed' ); like( exception { $obj->substr( {} ) }, qr/did not pass type constraint/, 'substr throws an error when first argument is not an integer' ); like( exception { $obj->substr( 1, {} ) }, qr/did not pass type constraint/, 'substr throws an error when second argument is not an integer' ); like( exception { $obj->substr( 1, 2, {} ) }, qr/did not pass type constraint/, 'substr throws an error when third argument is not a string' ); $obj->_string('some long string'); is( $obj->substr_curried_1, 'ome long string', 'substr_curried_1 returns expected value' ); is( $obj->substr_curried_1(3), 'ome', 'substr_curried_1 with one argument returns expected value' ); $obj->substr_curried_1( 3, 'ong' ); is( $obj->_string, 'song long string', 'substr_curried_1 as setter with two arguments' ); $obj->_string('some long string'); is( $obj->substr_curried_2, 'ome', 'substr_curried_2 returns expected value' ); $obj->substr_curried_2('ong'); is( $obj->_string, 'song long string', 'substr_curried_2 as setter with one arguments' ); $obj->_string('some long string'); $obj->substr_curried_3; is( $obj->_string, 'song long string', 'substr_curried_3 as setter' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->append('foo'); is( $obj->_string, 'foo', 'append with lazy default' ); } # } # $class; } done_testing; ext_attr.t000664001750001750 73414772476615 17063 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/04mooseuse strict; use warnings; use Test::More; { package Local::Dummy1; use Test::Requires 'Moose' }; { package ParentClass; use Moose; has 'test' => ( is => 'ro', default => sub { [] }, ); } { package ThisFails; use Moose; use Sub::HandlesVia; extends 'ParentClass'; has '+test' => ( handles_via => 'Array', handles => { 'push' => 'push...' } ); } my $obj = ThisFails->new; is_deeply($obj->push('a')->push('test')->test, [qw(a test)]); done_testing; role.t000664001750001750 160614772476615 16211 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/04mooseuse strict; use warnings; use Test::More; use Test::Fatal; { package Local::Dummy1; use Test::Requires 'Moose' }; { package Local::Role1; use Moose::Role; use Sub::HandlesVia; use Types::Standard qw( ArrayRef Int ); has nums => ( is => 'ro', isa => ArrayRef[Int], builder => '_build_nums', handles_via => 'Array', handles => { pop_num => 'pop', push_num => 'push' }, ); sub _build_nums { [ 1..10 ] } } { package Local::Class1; use Moose; with 'Local::Role1'; } #require B::Deparse; #::note( B::Deparse->new->coderef2text(\&Local::Class1::pop_num) ); my $obj = Local::Class1->new; is( $obj->pop_num, 10 ); is( $obj->pop_num, 9 ); is( $obj->pop_num, 8 ); is( $obj->pop_num, 7 ); isnt( exception { $obj->push_num(44.5) }, undef, ); is( $obj->pop_num, 6 ); is( exception { $obj->push_num(6) }, undef, ); is( $obj->pop_num, 6 ); done_testing; roles-multiple.t000664001750001750 117614772476615 20227 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/04mooseuse strict; use warnings; use Test::More; use Test::Fatal; { package Local::Dummy1; use Test::Requires 'Moose' }; { package TestRole1; use Moose::Role; } { package TestRole2; use Moose::Role; use Types::Standard qw(ArrayRef); use Sub::HandlesVia; has test => ( is => 'ro', isa => ArrayRef, default => sub { [] }, handles_via => 'Array', handles => { all_test => 'all' }, ); } { package TestClass; use Moose; with qw( TestRole1 TestRole2 ); __PACKAGE__->meta->make_immutable; } my $obj = TestClass->new( test => [ 1, 2 ] ); is_deeply( [ $obj->all_test ], [ 1, 2 ] ); done_testing; trait_array.t000664001750001750 6334214772476615 17616 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/04mooseuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Moose' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; use Test::Moose; { my %handles = ( count => 'count', elements => 'elements', is_empty => 'is_empty', push => 'push', push_curried => [ push => 42, 84 ], unshift => 'unshift', unshift_curried => [ unshift => 42, 84 ], pop => 'pop', shift => 'shift', get => 'get', get_curried => [ get => 1 ], set => 'set', set_curried_1 => [ set => 1 ], set_curried_2 => [ set => ( 1, 98 ) ], accessor => 'accessor', accessor_curried_1 => [ accessor => 1 ], accessor_curried_2 => [ accessor => ( 1, 90 ) ], clear => 'clear', delete => 'delete', delete_curried => [ delete => 1 ], insert => 'insert', insert_curried => [ insert => ( 1, 101 ) ], splice => 'splice', splice_curried_1 => [ splice => 1 ], splice_curried_2 => [ splice => 1, 2 ], splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ], sort => 'sort', sort_curried => [ sort => ( sub { $_[1] <=> $_[0] } ) ], sort_in_place => 'sort_in_place', sort_in_place_curried => [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ], map => 'map', map_curried => [ map => ( sub { $_ + 1 } ) ], grep => 'grep', grep_curried => [ grep => ( sub { $_ < 5 } ) ], first => 'first', first_curried => [ first => ( sub { $_ % 2 } ) ], first_index => 'first_index', first_index_curried => [ first_index => ( sub { $_ % 2 } ) ], join => 'join', join_curried => [ join => '-' ], shuffle => 'shuffle', uniq => 'uniq', reduce => 'reduce', reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ], natatime => 'natatime', natatime_curried => [ natatime => 2 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Array'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moose; use Sub::HandlesVia; use Types::Standard qw(ArrayRef Int); has _values => ( traits => [\@traits], is => 'rw', isa => ArrayRef[Int], default => sub { [] }, handles => \\%handles_copy, clearer => '_clear_values', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { package Overloader; use overload '&{}' => sub { ${ $_[0] } }, bool => sub {1}; sub new { bless \$_[1], $_[0]; } } { package OverloadStr; use overload q{""} => sub { ${ $_[0] } }, fallback => 1; sub new { my $class = shift; my $str = shift; return bless \$str, $class; } } { package OverloadNum; use overload q{0+} => sub { ${ $_[0] } }, fallback => 1; sub new { my $class = shift; my $str = shift; return bless \$str, $class; } } use Types::Standard qw( ArrayRef Int ); { subtest( 'simple case', sub { run_tests(build_class) } ); subtest( 'lazy default attr', sub { run_tests( build_class( lazy => 1, default => sub { [ 42, 84 ] } ) ); } ); subtest( 'attr with trigger', sub { run_tests( build_class( trigger => sub { } ) ); } ); subtest( 'attr is not inlined', sub { run_tests( build_class( no_inline => 1 ) ) } ); subtest( 'attr type forces the inlining code to check the entire arrayref when it is modified', sub { run_tests( build_class( isa => ArrayRef->where(sub {1}) ) ); } ); subtest( 'attr type has coercion', sub { run_tests( build_class( isa => ArrayRef->plus_coercions(Int, '[$_]'), coerce => 1 ) ); } ); } subtest( 'setting value to undef with accessor', sub { my ( $class, $handles ) = build_class( isa => ArrayRef ); note "Testing class $class"; my $obj = $class->new; with_immutable { is( exception { $obj->accessor( 0, undef ) }, undef, 'can use accessor to set value to undef' ); is( exception { $obj->accessor_curried_1(undef) }, undef, 'can use curried accessor to set value to undef' ); } $class; } ); sub run_tests { my ( $class, $handles ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new( _values => [ 10, 12, 42 ] ); is_deeply( $obj->_values, [ 10, 12, 42 ], 'values can be set in constructor' ); ok( !$obj->is_empty, 'values is not empty' ); is( $obj->count, 3, 'count returns 3' ); like( exception { $obj->count(22) }, qr/number of parameters/, 'throws an error when passing an argument passed to count' ); is( exception { $obj->push( 1, 2, 3 ) }, undef, 'pushed three new values and lived' ); is( exception { $obj->push() }, undef, 'call to push without arguments lives' ); is( exception { is( $obj->unshift( 101, 22 ), 8, 'unshift returns size of the new array' ); }, undef, 'unshifted two values and lived' ); is_deeply( $obj->_values, [ 101, 22, 10, 12, 42, 1, 2, 3 ], 'unshift changed the value of the array in the object' ); is( exception { $obj->unshift() }, undef, 'call to unshift without arguments lives' ); is( $obj->pop, 3, 'pop returns the last value in the array' ); is_deeply( $obj->_values, [ 101, 22, 10, 12, 42, 1, 2 ], 'pop changed the value of the array in the object' ); like( exception { $obj->pop(42) }, qr/number of parameters/, 'call to pop with arguments dies' ); is( $obj->shift, 101, 'shift returns the first value' ); like( exception { $obj->shift(42) }, qr/number of parameters/, 'call to shift with arguments dies' ); is_deeply( $obj->_values, [ 22, 10, 12, 42, 1, 2 ], 'shift changed the value of the array in the object' ); is_deeply( [ $obj->elements ], [ 22, 10, 12, 42, 1, 2 ], 'call to elements returns values as a list' ); is(scalar($obj->elements), 6, 'elements accessor in scalar context returns the number of elements in the list'); like( exception { $obj->elements(22) }, qr/number of parameters/, 'throws an error when passing an argument passed to elements' ); $obj->_values( [ 1, 2, 3 ] ); is( $obj->get(0), 1, 'get values at index 0' ); is( $obj->get(1), 2, 'get values at index 1' ); is( $obj->get(2), 3, 'get values at index 2' ); is( $obj->get_curried, 2, 'get_curried returns value at index 1' ); like( exception { $obj->get() }, qr/number of parameters/, 'throws an error when get is called without any arguments' ); like( exception { $obj->get( {} ) }, qr/did not pass type constraint/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get(2.2) }, qr/did not pass type constraint/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get('foo') }, qr/did not pass type constraint/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get_curried(2) }, qr/number of parameters/, 'throws an error when get_curried is called with an argument' ); is( exception { is( $obj->set( 1, 100 ), 100, 'set returns new value' ); }, undef, 'set value at index 1 lives' ); is( $obj->get(1), 100, 'get value at index 1 returns new value' ); like( exception { $obj->set( 1, 99, 42 ) }, qr/number of parameters/, 'throws an error when set is called with three arguments' ); is( exception { $obj->set_curried_1(99) }, undef, 'set_curried_1 lives' ); is( $obj->get(1), 99, 'get value at index 1 returns new value' ); like( exception { $obj->set_curried_1( 99, 42 ) }, qr/number of parameters/, 'throws an error when set_curried_1 is called with two arguments' ); is( exception { $obj->set_curried_2 }, undef, 'set_curried_2 lives' ); is( $obj->get(1), 98, 'get value at index 1 returns new value' ); like( exception { $obj->set_curried_2(42) }, qr/number of parameters/, 'throws an error when set_curried_2 is called with one argument' ); #use B::Deparse; #diag(B::Deparse->new->coderef2text($obj->can('accessor'))); is( $obj->accessor(1), 98, 'accessor with one argument returns value at index 1' ); is( exception { is( $obj->accessor( 1 => 97 ), 97, 'accessor returns new value' ); }, undef, 'accessor as writer lives' ); like( exception { $obj->accessor; }, qr/number of parameters/, 'throws an error when accessor is called without arguments' ); is( $obj->get(1), 97, 'accessor set value at index 1' ); like( exception { $obj->accessor( 1, 96, 42 ) }, qr/number of parameters/, 'throws an error when accessor is called with three arguments' ); is( $obj->accessor_curried_1, 97, 'accessor_curried_1 returns expected value when called with no arguments' ); is( exception { $obj->accessor_curried_1(95) }, undef, 'accessor_curried_1 as writer lives' ); is( $obj->get(1), 95, 'accessor_curried_1 set value at index 1' ); like( exception { $obj->accessor_curried_1( 96, 42 ) }, qr/number of parameters/, 'throws an error when accessor_curried_1 is called with two arguments' ); is( exception { $obj->accessor_curried_2 }, undef, 'accessor_curried_2 as writer lives' ); is( $obj->get(1), 90, 'accessor_curried_2 set value at index 1' ); like( exception { $obj->accessor_curried_2(42) }, qr/number of parameters/, 'throws an error when accessor_curried_2 is called with one argument' ); is( exception { $obj->clear }, undef, 'clear lives' ); ok( $obj->is_empty, 'values is empty after call to clear' ); is( exception { is( $obj->shift, undef, 'shift returns undef on an empty array' ); }, undef, 'shifted from an empty array and lived' ); $obj->set( 0 => 42 ); like( exception { $obj->clear(50) }, qr/number of parameters/, 'throws an error when clear is called with an argument' ); ok( !$obj->is_empty, 'values is not empty after failed call to clear' ); like( exception { $obj->is_empty(50) }, qr/number of parameters/, 'throws an error when is_empty is called with an argument' ); $obj->clear; is( $obj->push( 1, 5, 10, 42 ), 4, 'pushed 4 elements, got number of elements in the array back' ); is( exception { is( $obj->delete(2), 10, 'delete returns deleted value' ); }, undef, 'delete lives' ); is_deeply( $obj->_values, [ 1, 5, 42 ], 'delete removed the specified element' ); like( exception { $obj->delete( 2, 3 ) }, qr/number of parameters/, 'throws an error when delete is called with two arguments' ); is( exception { $obj->delete_curried }, undef, 'delete_curried lives' ); is_deeply( $obj->_values, [ 1, 42 ], 'delete removed the specified element' ); like( exception { $obj->delete_curried(2) }, qr/number of parameters/, 'throws an error when delete_curried is called with one argument' ); is( exception { $obj->insert( 1, 21 ) }, undef, 'insert lives' ); is_deeply( $obj->_values, [ 1, 21, 42 ], 'insert added the specified element' ); like( exception { $obj->insert( 1, 22, 44 ) }, qr/number of parameters/, 'throws an error when insert is called with three arguments' ); is( exception { is_deeply( [ $obj->splice( 1, 0, 2, 3 ) ], [], 'return value of splice is empty list when not removing elements' ); }, undef, 'splice lives' ); is_deeply( $obj->_values, [ 1, 2, 3, 21, 42 ], 'splice added the specified elements' ); is( exception { is_deeply( [ $obj->splice( 1, 2, 99 ) ], [ 2, 3 ], 'splice returns list of removed values' ); }, undef, 'splice lives' ); is_deeply( $obj->_values, [ 1, 99, 21, 42 ], 'splice added the specified elements' ); like( exception { $obj->splice() }, qr/number of parameters/, 'throws an error when splice is called with no arguments' ); like( exception { $obj->splice( 1, 'foo', ) }, qr/did not pass type constraint/, 'throws an error when splice is called with an invalid length' ); is( exception { $obj->splice_curried_1( 2, 101 ) }, undef, 'splice_curried_1 lives' ); is_deeply( $obj->_values, [ 1, 101, 42 ], 'splice added the specified elements' ); is( exception { $obj->splice_curried_2(102) }, undef, 'splice_curried_2 lives' ); is_deeply( $obj->_values, [ 1, 102 ], 'splice added the specified elements' ); is( exception { $obj->splice_curried_all }, undef, 'splice_curried_all lives' ); is_deeply( $obj->_values, [ 1, 3, 4, 5 ], 'splice added the specified elements' ); is_deeply( scalar $obj->splice( 1, 2 ), 4, 'splice in scalar context returns last element removed' ); is_deeply( scalar $obj->splice( 1, 0, 42 ), undef, 'splice in scalar context returns undef when no elements are removed' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); is_deeply( [ $obj->sort ], [ 11, 22, 3, 5, 9 ], 'sort returns sorted values' ); is(scalar($obj->sort), 5, 'sort accessor in scalar context returns the number of elements in the list'); is_deeply( [ $obj->sort( sub { $_[0] <=> $_[1] } ) ], [ 3, 5, 9, 11, 22 ], 'sort returns values sorted by provided function' ); is(scalar($obj->sort( sub { $_[0] <=> $_[1] } )), 5, 'sort accessor with sort sub in scalar context returns the number of elements in the list'); like( exception { $obj->sort(1) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to sort' ); like( exception { $obj->sort( sub { }, 27 ); }, qr/number of parameters/, 'throws an error when passing two arguments to sort' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); $obj->sort_in_place; is_deeply( $obj->_values, [ 11, 22, 3, 5, 9 ], 'sort_in_place sorts values' ); $obj->sort_in_place( sub { $_[0] <=> $_[1] } ); is_deeply( $obj->_values, [ 3, 5, 9, 11, 22 ], 'sort_in_place with function sorts values' ); like( exception { $obj->sort_in_place( 27 ); }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to sort_in_place' ); like( exception { $obj->sort_in_place( sub { }, 27 ); }, qr/number of parameters/, 'throws an error when passing two arguments to sort_in_place' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); $obj->sort_in_place_curried; is_deeply( $obj->_values, [ 22, 11, 9, 5, 3 ], 'sort_in_place_curried sorts values' ); like( exception { $obj->sort_in_place_curried(27) }, qr/number of parameters/, 'throws an error when passing one argument passed to sort_in_place_curried' ); $obj->_values( [ 1 .. 5 ] ); is_deeply( [ $obj->map( sub { $_ + 1 } ) ], [ 2 .. 6 ], 'map returns the expected values' ); like( exception { $obj->map }, qr/number of parameters/, 'throws an error when passing no arguments to map' ); like( exception { $obj->map( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to map' ); like( exception { $obj->map( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to map' ); $obj->_values( [ 1 .. 5 ] ); is_deeply( [ $obj->map_curried ], [ 2 .. 6 ], 'map_curried returns the expected values' ); like( exception { $obj->map_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to map_curried' ); $obj->_values( [ 2 .. 9 ] ); is_deeply( [ $obj->grep( sub { $_ < 5 } ) ], [ 2 .. 4 ], 'grep returns the expected values' ); like( exception { $obj->grep }, qr/number of parameters/, 'throws an error when passing no arguments to grep' ); like( exception { $obj->grep( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to grep' ); like( exception { $obj->grep( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to grep' ); # my $overloader = Overloader->new( sub { $_ < 5 } ); # is_deeply( # [ $obj->grep($overloader) ], # [ 2 .. 4 ], # 'grep works with obj that overload code dereferencing' # ); is_deeply( [ $obj->grep_curried ], [ 2 .. 4 ], 'grep_curried returns the expected values' ); like( exception { $obj->grep_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to grep_curried' ); $obj->_values( [ 2, 4, 22, 99, 101, 6 ] ); is( $obj->first( sub { $_ % 2 } ), 99, 'first returns expected value' ); like( exception { $obj->first }, qr/number of parameters/, 'throws an error when passing no arguments to first' ); like( exception { $obj->first( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to first' ); like( exception { $obj->first( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to first' ); is( $obj->first_curried, 99, 'first_curried returns expected value' ); like( exception { $obj->first_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to first_curried' ); is( $obj->first_index( sub { $_ % 2 } ), 3, 'first_index returns expected value' ); like( exception { $obj->first_index }, qr/number of parameters/, 'throws an error when passing no arguments to first_index' ); like( exception { $obj->first_index( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to first_index' ); like( exception { $obj->first_index( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to first_index' ); is( $obj->first_index_curried, 3, 'first_index_curried returns expected value' ); like( exception { $obj->first_index_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to first_index_curried' ); $obj->_values( [ 1 .. 4 ] ); is( $obj->join('-'), '1-2-3-4', 'join returns expected result' ); is( $obj->join(q{}), '1234', 'join returns expected result when joining with empty string' ); is( $obj->join(0), '1020304', 'join returns expected result when joining with 0 as number' ); is( $obj->join("0"), '1020304', 'join returns expected result when joining with 0 as string' ); # is( # $obj->join( OverloadStr->new(q{}) ), '1234', # 'join returns expected result when joining with object with string overload' # ); # # is( # $obj->join( OverloadNum->new(0) ), '1020304', # 'join returns expected result when joining with object with numify overload' # ); # like( exception { $obj->join }, qr/number of parameters/, 'throws an error when passing no arguments to join' ); like( exception { $obj->join( '-', 2 ) }, qr/number of parameters/, 'throws an error when passing two arguments to join' ); like( exception { $obj->join( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non string to join' ); is_deeply( [ sort $obj->shuffle ], [ 1 .. 4 ], 'shuffle returns all values (cannot check for a random order)' ); like( exception { $obj->shuffle(2) }, qr/number of parameters/, 'throws an error when passing an argument passed to shuffle' ); $obj->_values( [ 1 .. 4, 2, 5, 3, 7, 3, 3, 1 ] ); is_deeply( [ $obj->uniq ], [ 1 .. 4, 5, 7 ], 'uniq returns expected values (in original order)' ); like( exception { $obj->uniq(2) }, qr/number of parameters/, 'throws an error when passing an argument passed to uniq' ); $obj->_values( [ 1 .. 5 ] ); is( $obj->reduce( sub { $_[0] * $_[1] } ), 120, 'reduce returns expected value' ); like( exception { $obj->reduce }, qr/number of parameters/, 'throws an error when passing no arguments to reduce' ); like( exception { $obj->reduce( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to reduce' ); like( exception { $obj->reduce( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to reduce' ); is( $obj->reduce_curried, 120, 'reduce_curried returns expected value' ); like( exception { $obj->reduce_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to reduce_curried' ); $obj->_values( [ 1 .. 6 ] ); my $it = $obj->natatime(2); my @nat; while ( my @v = $it->() ) { push @nat, \@v; } is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime returns expected iterator' ) or diag(explain(\@nat)); @nat = (); $obj->natatime( 2, sub { push @nat, [@_] } ); is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime with function returns expected value' ); like( exception { $obj->natatime( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non integer to natatime' ); like( exception { $obj->natatime( 2, {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non code ref to natatime' ); $it = $obj->natatime_curried(); @nat = (); while ( my @v = $it->() ) { push @nat, \@v; } is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime_curried returns expected iterator' ); @nat = (); $obj->natatime_curried( sub { push @nat, [@_] } ); is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime_curried with function returns expected value' ); like( exception { $obj->natatime_curried( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non code ref to natatime_curried' ); if ( $class->meta->get_attribute('_values')->is_lazy ) { my $obj = $class->new; is( $obj->count, 2, 'count is 2 (lazy init)' ); $obj->_clear_values; is_deeply( [ $obj->elements ], [ 42, 84 ], 'elements contains default with lazy init' ); $obj->_clear_values; $obj->push(2); is_deeply( $obj->_values, [ 42, 84, 2 ], 'push works with lazy init' ); $obj->_clear_values; $obj->unshift( 3, 4 ); is_deeply( $obj->_values, [ 3, 4, 42, 84 ], 'unshift works with lazy init' ); } } $class; } done_testing; trait_bool.t000664001750001750 550214772476615 17405 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/04mooseuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Moose' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; use Test::Moose; { my %handles = ( illuminate => 'set', darken => 'unset', flip_switch => 'toggle', is_dark => 'not', ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Bool'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moose; use Sub::HandlesVia; use Types::Standard qw(Bool); has is_lit => ( traits => [\@traits], is => 'rw', isa => Bool, default => 1, handles => \\%handles_copy, clearer => '_clear_is_lit', %attr, ); 1; } or die($@); return ( $class, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); run_tests( build_class( isa => Types::Standard::Bool()->where(sub {1}) ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new; ok( $obj->illuminate, 'set returns true' ); ok( $obj->is_lit, 'set is_lit to 1 using ->illuminate' ); ok( !$obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->illuminate(1) }, qr/number of parameters/, 'set throws an error when an argument is passed' ); ok( !$obj->darken, 'unset returns false' ); ok( !$obj->is_lit, 'set is_lit to 0 using ->darken' ); ok( $obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->darken(1) }, qr/number of parameters/, 'unset throws an error when an argument is passed' ); ok( $obj->flip_switch, 'toggle returns new value' ); ok( $obj->is_lit, 'toggle is_lit back to 1 using ->flip_switch' ); ok( !$obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->flip_switch(1) }, qr/number of parameters/, 'toggle throws an error when an argument is passed' ); $obj->flip_switch; ok( !$obj->is_lit, 'toggle is_lit back to 0 again using ->flip_switch' ); ok( $obj->is_dark, 'check if is_dark does the right thing' ); } $class; } done_testing; trait_code.t000664001750001750 561014772476615 17364 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/04mooseuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Moose' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; use Test::Moose; { my $name = 'Foo1'; sub build_class { my ( $attr1, $attr2, $attr3, $no_inline ) = @_; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Code'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moose; use Sub::HandlesVia; use Types::Standard qw(CodeRef); has( callback => ( is => 'bare', handles_via => [\@traits], isa => CodeRef, required => 1, handles => { 'invoke_callback' => 'execute' }, %{ \$attr1 || {} }, ) ); has( callback_method => ( is => 'bare', handles_via => [\@traits], isa => CodeRef, required => 1, handles => { 'invoke_method_callback' => 'execute_method' }, %{ \$attr2 || {} }, ) ); has( multiplier => ( is => 'bare', handles_via => [\@traits], isa => CodeRef, required => 1, handles => { 'multiply' => 'execute' }, %{ \$attr3 || {} }, ) ); 1; } or die($@); return $class; } } { my $i; my %subs = ( callback => sub { ++$i }, callback_method => sub { shift->multiply(@_) }, multiplier => sub { $_[0] * 2 }, ); run_tests( build_class, \$i, \%subs ); run_tests( build_class( undef, undef, undef, 1 ), \$i, \%subs ); run_tests( build_class( { lazy => 1, default => sub { $subs{callback} } }, { lazy => 1, default => sub { $subs{callback_method} } }, { lazy => 1, default => sub { $subs{multiplier} } }, ), \$i, ); } sub run_tests { my ( $class, $iref, @args ) = @_; note "Testing class $class"; ok( !$class->can($_), "Code trait didn't create reader method for $_" ) for qw(callback callback_method multiplier); with_immutable { ${$iref} = 0; my $obj = $class->new(@args); $obj->invoke_callback; is( ${$iref}, 1, '$i is 1 after invoke_callback' ); is( $obj->invoke_method_callback(3), 6, 'invoke_method_callback calls multiply with @_' ); is( $obj->multiply(3), 6, 'multiple double value' ); } $class; } done_testing; trait_counter.t000664001750001750 1121714772476615 20151 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/04mooseuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Moose' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; use Test::Moose; use Types::Standard (); { my %handles = ( inc_counter => 'inc', inc_counter_2 => [ inc => 2 ], dec_counter => 'dec', dec_counter_2 => [ dec => 2 ], reset_counter => 'reset', set_counter => 'set', set_counter_42 => [ set => 42 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Counter'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moose; use Sub::HandlesVia; use Types::Standard qw(Int); has counter => ( traits => [\@traits], is => 'rw', isa => Int, default => 0, handles => \\%handles_copy, clearer => '_clear_counter', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); run_tests( build_class( isa => Types::Standard::Int()->where(sub {1}) ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new(); is( $obj->counter, 0, '... got the default value' ); is( $obj->inc_counter, 1, 'inc returns new value' ); is( $obj->counter, 1, '... got the incremented value' ); is( $obj->inc_counter, 2, 'inc returns new value' ); is( $obj->counter, 2, '... got the incremented value (again)' ); like( exception { $obj->inc_counter( 1, 2 ) }, qr/number of parameters/, 'inc throws an error when two arguments are passed' ); is( $obj->dec_counter, 1, 'dec returns new value' ); is( $obj->counter, 1, '... got the decremented value' ); like( exception { $obj->dec_counter( 1, 2 ) }, qr/number of parameters/, 'dec throws an error when two arguments are passed' ); is( $obj->reset_counter, 0, 'reset returns new value' ); is( $obj->counter, 0, '... got the original value' ); like( exception { $obj->reset_counter(2) }, qr/number of parameters/, 'reset throws an error when an argument is passed' ); is( $obj->set_counter(5), 5, 'set returns new value' ); is( $obj->counter, 5, '... set the value' ); like( exception { $obj->set_counter( 1, 2 ) }, qr/number of parameters/, 'set throws an error when two arguments are passed' ); $obj->inc_counter(2); is( $obj->counter, 7, '... increment by arg' ); $obj->dec_counter(5); is( $obj->counter, 2, '... decrement by arg' ); $obj->inc_counter_2; is( $obj->counter, 4, '... curried increment' ); $obj->dec_counter_2; is( $obj->counter, 2, '... curried deccrement' ); $obj->set_counter_42; is( $obj->counter, 42, '... curried set' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->inc_counter; is( $obj->counter, 1, 'inc increments - with lazy default' ); $obj->_clear_counter; $obj->dec_counter; is( $obj->counter, -1, 'dec decrements - with lazy default' ); } } $class; } { package WithBuilder; use Moose; use Sub::HandlesVia; use Types::Standard 'Int'; has nonlazy => ( traits => ['Counter'], is => 'rw', isa => Int, builder => '_builder', handles => { reset_nonlazy => 'reset', }, ); has lazy => ( traits => ['Counter'], is => 'rw', isa => Int, lazy => 1, builder => '_builder', handles => { reset_lazy => 'reset', }, ); sub _builder { 1 } } for my $attr ('lazy', 'nonlazy') { my $obj = WithBuilder->new; is($obj->$attr, 1, "built properly"); $obj->$attr(0); is($obj->$attr, 0, "can be manually set"); $obj->${\"reset_$attr"}; is($obj->$attr, 1, "reset resets it to its default value"); } done_testing; trait_hash.t000664001750001750 2202714772476615 17416 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/04mooseuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Moose' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; use Test::Moose; { my %handles = ( option_accessor => 'accessor', quantity => [ accessor => 'quantity' ], clear_options => 'clear', num_options => 'count', delete_option => 'delete', is_defined => 'defined', options_elements => 'elements', has_option => 'exists', get_option => 'get', has_no_options => 'is_empty', keys => 'keys', values => 'values', key_value => 'kv', set_option => 'set', ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Hash'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moose; use Sub::HandlesVia; use Types::Standard qw(HashRef Str); has options => ( traits => [\@traits], is => 'rw', isa => HashRef[Str], default => sub { {} }, handles => \\%handles_copy, clearer => '_clear_options', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } use Types::Standard qw( HashRef Str ); { run_tests(build_class); run_tests( build_class( lazy => 1, default => sub { { x => 1 } } ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); run_tests( build_class( isa => HashRef->of(Str)->where(sub {1}) ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new( options => {} ); ok( $obj->has_no_options, '... we have no options' ); is( $obj->num_options, 0, '... we have no options' ); is_deeply( $obj->options, {}, '... no options yet' ); ok( !$obj->has_option('foo'), '... we have no foo option' ); is( exception { is( $obj->set_option( foo => 'bar' ), 'bar', 'set return single new value in scalar context' ); }, undef, '... set the option okay' ); like( exception { $obj->set_option( foo => 'bar', 'baz' ) }, qr/number of parameters/, 'exception with odd number of arguments' ); like( exception { $obj->set_option( undef, 'bar' ) }, qr/did not pass type constraint/, 'exception when using undef as a key' ); ok( $obj->is_defined('foo'), '... foo is defined' ); ok( !$obj->has_no_options, '... we have options' ); is( $obj->num_options, 1, '... we have 1 option(s)' ); ok( $obj->has_option('foo'), '... we have a foo option' ); is_deeply( $obj->options, { foo => 'bar' }, '... got options now' ); is( exception { $obj->set_option( bar => 'baz' ); }, undef, '... set the option okay' ); is( $obj->num_options, 2, '... we have 2 option(s)' ); is_deeply( $obj->options, { foo => 'bar', bar => 'baz' }, '... got more options now' ); is( $obj->get_option('foo'), 'bar', '... got the right option' ); is_deeply( [ $obj->get_option(qw(foo bar)) ], [qw(bar baz)], "get multiple options at once" ); is( scalar( $obj->get_option(qw( foo bar)) ), "baz", '... got last option in scalar context' ); is( exception { $obj->set_option( oink => "blah", xxy => "flop" ); }, undef, '... set the option okay' ); is( $obj->num_options, 4, "4 options" ); is_deeply( [ $obj->get_option(qw(foo bar oink xxy)) ], [qw(bar baz blah flop)], "get multiple options at once" ); is( exception { is( scalar $obj->delete_option('bar'), 'baz', 'delete returns deleted value' ); }, undef, '... deleted the option okay' ); is( exception { is_deeply( [ $obj->delete_option( 'oink', 'xxy' ) ], [ 'blah', 'flop' ], 'delete returns all deleted values in list context' ); }, undef, '... deleted multiple option okay' ); is( $obj->num_options, 1, '... we have 1 option(s)' ); is_deeply( $obj->options, { foo => 'bar' }, '... got more options now' ); $obj->clear_options; is_deeply( $obj->options, {}, "... cleared options" ); is( exception { $obj->quantity(4); }, undef, '... options added okay with defaults' ); is( $obj->quantity, 4, 'reader part of curried accessor works' ); is( $obj->option_accessor('quantity'), 4, 'accessor as reader' ); is_deeply( $obj->options, { quantity => 4 }, '... returns what we expect' ); $obj->option_accessor( size => 42 ); like( exception { $obj->option_accessor; }, qr/number of parameters/, 'error when calling accessor with no arguments' ); like( exception { $obj->option_accessor( undef, 'bar' ) }, qr/did not pass type constraint/, 'exception when using undef as a key' ); is_deeply( $obj->options, { quantity => 4, size => 42 }, 'accessor as writer' ); is( exception { $class->new( options => { foo => 'BAR' } ); }, undef, '... good constructor params' ); isnt( exception { $obj->set_option( bar => {} ); }, undef, '... could not add a hash ref where an string is expected' ); isnt( exception { $class->new( options => { foo => [] } ); }, undef, '... bad constructor params' ); $obj->options( {} ); is_deeply( [ $obj->set_option( oink => "blah", xxy => "flop" ) ], [ 'blah', 'flop' ], 'set returns newly set values in order of keys provided' ); is_deeply( [ sort $obj->keys ], [ 'oink', 'xxy' ], 'keys returns expected keys' ); is_deeply( [ sort $obj->values ], [ 'blah', 'flop' ], 'values returns expected values' ); my @key_value = sort { $a->[0] cmp $b->[0] } $obj->key_value; is_deeply( \@key_value, [ sort { $a->[0] cmp $b->[0] }[ 'xxy', 'flop' ], [ 'oink', 'blah' ] ], '... got the right key value pairs' ) or do { require Data::Dumper; diag( Data::Dumper::Dumper( \@key_value ) ); }; my %options_elements = $obj->options_elements; is_deeply( \%options_elements, { 'oink' => 'blah', 'xxy' => 'flop' }, '... got the right hash elements' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->set_option( y => 2 ); is_deeply( $obj->options, { x => 1, y => 2 }, 'set_option with lazy default' ); $obj->_clear_options; ok( $obj->has_option('x'), 'key for x exists - lazy default' ); $obj->_clear_options; ok( $obj->is_defined('x'), 'key for x is defined - lazy default' ); $obj->_clear_options; is_deeply( [ $obj->key_value ], [ [ x => 1 ] ], 'kv returns lazy default' ); $obj->_clear_options; $obj->option_accessor( y => 2 ); is_deeply( [ sort $obj->keys ], [ 'x', 'y' ], 'accessor triggers lazy default generator' ); } } $class; } { my ( $class, $handles ) = build_class( isa => HashRef ); my $obj = $class->new; with_immutable { is( exception { $obj->option_accessor( 'foo', undef ) }, undef, 'can use accessor to set value to undef' ); is( exception { $obj->quantity(undef) }, undef, 'can use accessor to set value to undef' ); } $class; } done_testing; trait_number.t000664001750001750 1023314772476615 17757 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/04mooseuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Moose' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; use Test::Moose; { my %handles = ( abs => 'abs', add => 'add', inc => [ add => 1 ], div => 'div', cut_in_half => [ div => 2 ], mod => 'mod', odd => [ mod => 2 ], mul => 'mul', set => 'set', sub => 'sub', dec => [ sub => 1 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Number'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moose; use Sub::HandlesVia; use Types::Standard qw(Int); has integer => ( traits => [\@traits], is => 'rw', isa => Int, default => 5, handles => \\%handles_copy, clearer => '_clear_integer', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); run_tests( build_class( isa => Types::Standard::Num()->where(sub {1}) ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new; is( $obj->integer, 5, 'Default to five' ); is( $obj->add(10), 15, 'add returns new value' ); is( $obj->integer, 15, 'Add ten for fithteen' ); like( exception { $obj->add( 10, 2 ) }, qr/number of parameters/, 'add throws an error when 2 arguments are passed' ); is( $obj->sub(3), 12, 'sub returns new value' ); is( $obj->integer, 12, 'Subtract three for 12' ); like( exception { $obj->sub( 10, 2 ) }, qr/number of parameters/, 'sub throws an error when 2 arguments are passed' ); is( $obj->set(10), 10, 'set returns new value' ); is( $obj->integer, 10, 'Set to ten' ); like( exception { $obj->set( 10, 2 ) }, qr/number of parameters/, 'set throws an error when 2 arguments are passed' ); is( $obj->div(2), 5, 'div returns new value' ); is( $obj->integer, 5, 'divide by 2' ); like( exception { $obj->div( 10, 2 ) }, qr/number of parameters/, 'div throws an error when 2 arguments are passed' ); is( $obj->mul(2), 10, 'mul returns new value' ); is( $obj->integer, 10, 'multiplied by 2' ); like( exception { $obj->mul( 10, 2 ) }, qr/number of parameters/, 'mul throws an error when 2 arguments are passed' ); is( $obj->mod(2), 0, 'mod returns new value' ); is( $obj->integer, 0, 'Mod by 2' ); like( exception { $obj->mod( 10, 2 ) }, qr/number of parameters/, 'mod throws an error when 2 arguments are passed' ); $obj->set(7); $obj->mod(5); is( $obj->integer, 2, 'Mod by 5' ); $obj->set(-1); is( $obj->abs, 1, 'abs returns new value' ); like( exception { $obj->abs(10) }, qr/number of parameters/, 'abs throws an error when an argument is passed' ); is( $obj->integer, 1, 'abs 1' ); $obj->set(12); $obj->inc; is( $obj->integer, 13, 'inc 12' ); $obj->dec; is( $obj->integer, 12, 'dec 13' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->add(2); is( $obj->integer, 7, 'add with lazy default' ); $obj->_clear_integer; $obj->mod(2); is( $obj->integer, 1, 'mod with lazy default' ); } } $class; } done_testing; trait_string.t000664001750001750 2277214772476615 20010 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/04mooseuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Moose' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; use Test::Moose; { my %handles = ( inc => 'inc', append => 'append', append_curried => [ append => '!' ], prepend => 'prepend', prepend_curried => [ prepend => '-' ], replace => 'replace', replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ], chop => 'chop', chomp => 'chomp', clear => 'clear', match => 'match', match_curried => [ match => qr/\D/ ], length => 'length', substr => 'substr', substr_curried_1 => [ substr => (1) ], substr_curried_2 => [ substr => ( 1, 3 ) ], substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'String'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moose; use Sub::HandlesVia; use Types::Standard qw(Str); has _string => ( traits => [\@traits], is => 'rw', isa => Str, default => q{}, handles => \\%handles_copy, clearer => '_clear_string', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1, default => q{} ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); run_tests( build_class( isa => Types::Standard::Str()->where(sub {1}) ) ); # coerce 'MyStr', from 'Str', via { $_ }; # # run_tests( build_class( isa => 'MyStr', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new(); is( $obj->length, 0, 'length returns zero' ); $obj->_string('a'); is( $obj->length, 1, 'length returns 1 for new string' ); like( exception { $obj->length(42) }, qr/number of parameters/, 'length throws an error when an argument is passed' ); is( $obj->inc, 'b', 'inc returns new value' ); is( $obj->_string, 'b', 'a becomes b after inc' ); like( exception { $obj->inc(42) }, qr/number of parameters/, 'inc throws an error when an argument is passed' ); is( $obj->append('foo'), 'bfoo', 'append returns new value' ); is( $obj->_string, 'bfoo', 'appended to the string' ); like( exception { $obj->append( 'foo', 2 ) }, qr/number of parameters/, 'append throws an error when two arguments are passed' ); $obj->append_curried; is( $obj->_string, 'bfoo!', 'append_curried appended to the string' ); like( exception { $obj->append_curried('foo') }, qr/number of parameters/, 'append_curried throws an error when two arguments are passed' ); $obj->_string("has nl$/"); is( $obj->chomp, 1, 'chomp returns number of characters removed' ); is( $obj->_string, 'has nl', 'chomped string' ); is( $obj->chomp, 0, 'chomp returns number of characters removed' ); is( $obj->_string, 'has nl', 'chomp is a no-op when string has no line ending' ); like( exception { $obj->chomp(42) }, qr/number of parameters/, 'chomp throws an error when an argument is passed' ); is( $obj->chop, 'l', 'chop returns character removed' ); is( $obj->_string, 'has n', 'chopped string' ); like( exception { $obj->chop(42) }, qr/number of parameters/, 'chop throws an error when an argument is passed' ); $obj->_string('x'); is( $obj->prepend('bar'), 'barx', 'prepend returns new value' ); is( $obj->_string, 'barx', 'prepended to string' ); $obj->prepend_curried; is( $obj->_string, '-barx', 'prepend_curried prepended to string' ); is( $obj->replace( qr/([ao])/, sub { uc($1) } ), '-bArx', 'replace returns new value' ); is( $obj->_string, '-bArx', 'substitution using coderef for replacement' ); $obj->replace( qr/A/, 'X' ); is( $obj->_string, '-bXrx', 'substitution using string as replacement' ); $obj->_string('foo'); $obj->replace( qr/oo/, q{} ); is( $obj->_string, 'f', 'replace accepts an empty string as second argument' ); $obj->replace( q{}, 'a' ); is( $obj->_string, 'af', 'replace accepts an empty string as first argument' ); like( exception { $obj->replace( {}, 'x' ) }, qr/did not pass type constraint/, 'replace throws an error when the first argument is not a string or regexp' ); like( exception { $obj->replace( qr/x/, {} ) }, qr/did not pass type constraint/, 'replace throws an error when the first argument is not a string or regexp' ); $obj->_string('Moosex'); $obj->replace_curried; is( $obj->_string, 'MooseX', 'capitalize last' ); $obj->_string('abcdef'); is_deeply( [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ], 'match -barx against /[aq]/ returns matches' ); is_deeply( [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ], 'match -barx against /[aq]/ returns matches' ); ok( scalar $obj->match('b'), 'match with string as argument returns true' ); ok( scalar $obj->match(q{}), 'match with empty string as argument returns true' ); like( exception { $obj->match }, qr/number of parameters/, 'match throws an error when no arguments are passed' ); like( exception { $obj->match( {} ) }, qr/did not pass type constraint/, 'match throws an error when an invalid argument is passed' ); $obj->_string('1234'); ok( !$obj->match_curried, 'match_curried returns false' ); $obj->_string('one two three four'); ok( $obj->match_curried, 'match curried returns true' ); $obj->clear; is( $obj->_string, q{}, 'clear' ); like( exception { $obj->clear(42) }, qr/number of parameters/, 'clear throws an error when an argument is passed' ); $obj->_string('some long string'); is( $obj->substr(1), 'ome long string', 'substr as getter with one argument' ); $obj->_string('some long string'); is( $obj->substr( 1, 3 ), 'ome', 'substr as getter with two arguments' ); is( $obj->substr( 1, 3, 'ong' ), 'ome', 'substr as setter returns replaced string' ); is( $obj->_string, 'song long string', 'substr as setter with three arguments' ); $obj->substr( 1, 3, '' ); is( $obj->_string, 's long string', 'substr as setter with three arguments, replacment is empty string' ); like( exception { $obj->substr }, qr/number of parameters/, 'substr throws an error when no argumemts are passed' ); like( exception { $obj->substr( 1, 2, 3, 4 ) }, qr/number of parameters/, 'substr throws an error when four argumemts are passed' ); like( exception { $obj->substr( {} ) }, qr/did not pass type constraint/, 'substr throws an error when first argument is not an integer' ); like( exception { $obj->substr( 1, {} ) }, qr/did not pass type constraint/, 'substr throws an error when second argument is not an integer' ); like( exception { $obj->substr( 1, 2, {} ) }, qr/did not pass type constraint/, 'substr throws an error when third argument is not a string' ); $obj->_string('some long string'); is( $obj->substr_curried_1, 'ome long string', 'substr_curried_1 returns expected value' ); is( $obj->substr_curried_1(3), 'ome', 'substr_curried_1 with one argument returns expected value' ); $obj->substr_curried_1( 3, 'ong' ); is( $obj->_string, 'song long string', 'substr_curried_1 as setter with two arguments' ); $obj->_string('some long string'); is( $obj->substr_curried_2, 'ome', 'substr_curried_2 returns expected value' ); $obj->substr_curried_2('ong'); is( $obj->_string, 'song long string', 'substr_curried_2 as setter with one arguments' ); $obj->_string('some long string'); $obj->substr_curried_3; is( $obj->_string, 'song long string', 'substr_curried_3 as setter' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->append('foo'); is( $obj->_string, 'foo', 'append with lazy default' ); } } $class; } done_testing; role.t000664001750001750 153714772476615 20650 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/05moose_nativetypesuse strict; use warnings; use Test::More; use Test::Fatal; { package Local::Dummy1; use Test::Requires 'Moose' }; { package Local::Role1; use Moose::Role; use Sub::HandlesVia; has nums => ( is => 'ro', isa => 'ArrayRef[Int]', builder => '_build_nums', handles_via => 'Array', handles => { pop_num => 'pop', push_num => 'push' }, ); sub _build_nums { [ 1..10 ] } } { package Local::Class1; use Moose; with 'Local::Role1'; } #require B::Deparse; #::note( B::Deparse->new->coderef2text(\&Local::Class1::pop_num) ); my $obj = Local::Class1->new; is( $obj->pop_num, 10 ); is( $obj->pop_num, 9 ); is( $obj->pop_num, 8 ); is( $obj->pop_num, 7 ); isnt( exception { $obj->push_num(44.5) }, undef, ); is( $obj->pop_num, 6 ); is( exception { $obj->push_num(6) }, undef, ); is( $obj->pop_num, 6 ); done_testing; trait_array.t000664001750001750 6335514772476615 22256 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/05moose_nativetypesuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Moose' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; use Test::Moose; { my %handles = ( count => 'count', elements => 'elements', is_empty => 'is_empty', push => 'push', push_curried => [ push => 42, 84 ], unshift => 'unshift', unshift_curried => [ unshift => 42, 84 ], pop => 'pop', shift => 'shift', get => 'get', get_curried => [ get => 1 ], set => 'set', set_curried_1 => [ set => 1 ], set_curried_2 => [ set => ( 1, 98 ) ], accessor => 'accessor', accessor_curried_1 => [ accessor => 1 ], accessor_curried_2 => [ accessor => ( 1, 90 ) ], clear => 'clear', delete => 'delete', delete_curried => [ delete => 1 ], insert => 'insert', insert_curried => [ insert => ( 1, 101 ) ], splice => 'splice', splice_curried_1 => [ splice => 1 ], splice_curried_2 => [ splice => 1, 2 ], splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ], sort => 'sort', sort_curried => [ sort => ( sub { $_[1] <=> $_[0] } ) ], sort_in_place => 'sort_in_place', sort_in_place_curried => [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ], map => 'map', map_curried => [ map => ( sub { $_ + 1 } ) ], grep => 'grep', grep_curried => [ grep => ( sub { $_ < 5 } ) ], first => 'first', first_curried => [ first => ( sub { $_ % 2 } ) ], first_index => 'first_index', first_index_curried => [ first_index => ( sub { $_ % 2 } ) ], join => 'join', join_curried => [ join => '-' ], shuffle => 'shuffle', uniq => 'uniq', reduce => 'reduce', reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ], natatime => 'natatime', natatime_curried => [ natatime => 2 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Array'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moose; use Sub::HandlesVia; has _values => ( traits => [\@traits], is => 'rw', isa => 'ArrayRef[Int]', default => sub { [] }, handles => \\%handles_copy, clearer => '_clear_values', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { package Overloader; use overload '&{}' => sub { ${ $_[0] } }, bool => sub {1}; sub new { bless \$_[1], $_[0]; } } { package OverloadStr; use overload q{""} => sub { ${ $_[0] } }, fallback => 1; sub new { my $class = shift; my $str = shift; return bless \$str, $class; } } { package OverloadNum; use overload q{0+} => sub { ${ $_[0] } }, fallback => 1; sub new { my $class = shift; my $str = shift; return bless \$str, $class; } } { use Moose::Util::TypeConstraints; subtest( 'simple case', sub { run_tests(build_class) } ); subtest( 'lazy default attr', sub { run_tests( build_class( lazy => 1, default => sub { [ 42, 84 ] } ) ); } ); subtest( 'attr with trigger', sub { run_tests( build_class( trigger => sub { } ) ); } ); subtest( 'attr is not inlined', sub { run_tests( build_class( no_inline => 1 ) ) } ); type 'MyArray', as 'ArrayRef', where { 1 }; subtest( 'attr type forces the inlining code to check the entire arrayref when it is modified', sub { run_tests( build_class( isa => 'MyArray') ); } ); coerce 'MyArray', from 'ArrayRef', via { $_ }; subtest( 'attr type has coercion', sub { run_tests( build_class( isa => 'MyArray', coerce => 1 ) ); } ); } subtest( 'setting value to undef with accessor', sub { my ( $class, $handles ) = build_class( isa => 'ArrayRef' ); note "Testing class $class"; my $obj = $class->new; with_immutable { is( exception { $obj->accessor( 0, undef ) }, undef, 'can use accessor to set value to undef' ); is( exception { $obj->accessor_curried_1(undef) }, undef, 'can use curried accessor to set value to undef' ); } $class; } ); sub run_tests { my ( $class, $handles ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new( _values => [ 10, 12, 42 ] ); is_deeply( $obj->_values, [ 10, 12, 42 ], 'values can be set in constructor' ); ok( !$obj->is_empty, 'values is not empty' ); is( $obj->count, 3, 'count returns 3' ); like( exception { $obj->count(22) }, qr/number of parameters/, 'throws an error when passing an argument passed to count' ); is( exception { $obj->push( 1, 2, 3 ) }, undef, 'pushed three new values and lived' ); is( exception { $obj->push() }, undef, 'call to push without arguments lives' ); is( exception { is( $obj->unshift( 101, 22 ), 8, 'unshift returns size of the new array' ); }, undef, 'unshifted two values and lived' ); is_deeply( $obj->_values, [ 101, 22, 10, 12, 42, 1, 2, 3 ], 'unshift changed the value of the array in the object' ); is( exception { $obj->unshift() }, undef, 'call to unshift without arguments lives' ); is( $obj->pop, 3, 'pop returns the last value in the array' ); is_deeply( $obj->_values, [ 101, 22, 10, 12, 42, 1, 2 ], 'pop changed the value of the array in the object' ); like( exception { $obj->pop(42) }, qr/number of parameters/, 'call to pop with arguments dies' ); is( $obj->shift, 101, 'shift returns the first value' ); like( exception { $obj->shift(42) }, qr/number of parameters/, 'call to shift with arguments dies' ); is_deeply( $obj->_values, [ 22, 10, 12, 42, 1, 2 ], 'shift changed the value of the array in the object' ); is_deeply( [ $obj->elements ], [ 22, 10, 12, 42, 1, 2 ], 'call to elements returns values as a list' ); is(scalar($obj->elements), 6, 'elements accessor in scalar context returns the number of elements in the list'); like( exception { $obj->elements(22) }, qr/number of parameters/, 'throws an error when passing an argument passed to elements' ); $obj->_values( [ 1, 2, 3 ] ); is( $obj->get(0), 1, 'get values at index 0' ); is( $obj->get(1), 2, 'get values at index 1' ); is( $obj->get(2), 3, 'get values at index 2' ); is( $obj->get_curried, 2, 'get_curried returns value at index 1' ); like( exception { $obj->get() }, qr/number of parameters/, 'throws an error when get is called without any arguments' ); like( exception { $obj->get( {} ) }, qr/did not pass type constraint/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get(2.2) }, qr/did not pass type constraint/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get('foo') }, qr/did not pass type constraint/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get_curried(2) }, qr/number of parameters/, 'throws an error when get_curried is called with an argument' ); is( exception { is( $obj->set( 1, 100 ), 100, 'set returns new value' ); }, undef, 'set value at index 1 lives' ); is( $obj->get(1), 100, 'get value at index 1 returns new value' ); like( exception { $obj->set( 1, 99, 42 ) }, qr/number of parameters/, 'throws an error when set is called with three arguments' ); is( exception { $obj->set_curried_1(99) }, undef, 'set_curried_1 lives' ); is( $obj->get(1), 99, 'get value at index 1 returns new value' ); like( exception { $obj->set_curried_1( 99, 42 ) }, qr/number of parameters/, 'throws an error when set_curried_1 is called with two arguments' ); is( exception { $obj->set_curried_2 }, undef, 'set_curried_2 lives' ); is( $obj->get(1), 98, 'get value at index 1 returns new value' ); like( exception { $obj->set_curried_2(42) }, qr/number of parameters/, 'throws an error when set_curried_2 is called with one argument' ); #use B::Deparse; #diag(B::Deparse->new->coderef2text($obj->can('accessor'))); is( $obj->accessor(1), 98, 'accessor with one argument returns value at index 1' ); is( exception { is( $obj->accessor( 1 => 97 ), 97, 'accessor returns new value' ); }, undef, 'accessor as writer lives' ); like( exception { $obj->accessor; }, qr/number of parameters/, 'throws an error when accessor is called without arguments' ); is( $obj->get(1), 97, 'accessor set value at index 1' ); like( exception { $obj->accessor( 1, 96, 42 ) }, qr/number of parameters/, 'throws an error when accessor is called with three arguments' ); is( $obj->accessor_curried_1, 97, 'accessor_curried_1 returns expected value when called with no arguments' ); is( exception { $obj->accessor_curried_1(95) }, undef, 'accessor_curried_1 as writer lives' ); is( $obj->get(1), 95, 'accessor_curried_1 set value at index 1' ); like( exception { $obj->accessor_curried_1( 96, 42 ) }, qr/number of parameters/, 'throws an error when accessor_curried_1 is called with two arguments' ); is( exception { $obj->accessor_curried_2 }, undef, 'accessor_curried_2 as writer lives' ); is( $obj->get(1), 90, 'accessor_curried_2 set value at index 1' ); like( exception { $obj->accessor_curried_2(42) }, qr/number of parameters/, 'throws an error when accessor_curried_2 is called with one argument' ); is( exception { $obj->clear }, undef, 'clear lives' ); ok( $obj->is_empty, 'values is empty after call to clear' ); is( exception { is( $obj->shift, undef, 'shift returns undef on an empty array' ); }, undef, 'shifted from an empty array and lived' ); $obj->set( 0 => 42 ); like( exception { $obj->clear(50) }, qr/number of parameters/, 'throws an error when clear is called with an argument' ); ok( !$obj->is_empty, 'values is not empty after failed call to clear' ); like( exception { $obj->is_empty(50) }, qr/number of parameters/, 'throws an error when is_empty is called with an argument' ); $obj->clear; is( $obj->push( 1, 5, 10, 42 ), 4, 'pushed 4 elements, got number of elements in the array back' ); is( exception { is( $obj->delete(2), 10, 'delete returns deleted value' ); }, undef, 'delete lives' ); is_deeply( $obj->_values, [ 1, 5, 42 ], 'delete removed the specified element' ); like( exception { $obj->delete( 2, 3 ) }, qr/number of parameters/, 'throws an error when delete is called with two arguments' ); is( exception { $obj->delete_curried }, undef, 'delete_curried lives' ); is_deeply( $obj->_values, [ 1, 42 ], 'delete removed the specified element' ); like( exception { $obj->delete_curried(2) }, qr/number of parameters/, 'throws an error when delete_curried is called with one argument' ); is( exception { $obj->insert( 1, 21 ) }, undef, 'insert lives' ); is_deeply( $obj->_values, [ 1, 21, 42 ], 'insert added the specified element' ); like( exception { $obj->insert( 1, 22, 44 ) }, qr/number of parameters/, 'throws an error when insert is called with three arguments' ); is( exception { is_deeply( [ $obj->splice( 1, 0, 2, 3 ) ], [], 'return value of splice is empty list when not removing elements' ); }, undef, 'splice lives' ); is_deeply( $obj->_values, [ 1, 2, 3, 21, 42 ], 'splice added the specified elements' ); is( exception { is_deeply( [ $obj->splice( 1, 2, 99 ) ], [ 2, 3 ], 'splice returns list of removed values' ); }, undef, 'splice lives' ); is_deeply( $obj->_values, [ 1, 99, 21, 42 ], 'splice added the specified elements' ); like( exception { $obj->splice() }, qr/number of parameters/, 'throws an error when splice is called with no arguments' ); like( exception { $obj->splice( 1, 'foo', ) }, qr/did not pass type constraint/, 'throws an error when splice is called with an invalid length' ); is( exception { $obj->splice_curried_1( 2, 101 ) }, undef, 'splice_curried_1 lives' ); is_deeply( $obj->_values, [ 1, 101, 42 ], 'splice added the specified elements' ); is( exception { $obj->splice_curried_2(102) }, undef, 'splice_curried_2 lives' ); is_deeply( $obj->_values, [ 1, 102 ], 'splice added the specified elements' ); is( exception { $obj->splice_curried_all }, undef, 'splice_curried_all lives' ); is_deeply( $obj->_values, [ 1, 3, 4, 5 ], 'splice added the specified elements' ); is_deeply( scalar $obj->splice( 1, 2 ), 4, 'splice in scalar context returns last element removed' ); is_deeply( scalar $obj->splice( 1, 0, 42 ), undef, 'splice in scalar context returns undef when no elements are removed' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); is_deeply( [ $obj->sort ], [ 11, 22, 3, 5, 9 ], 'sort returns sorted values' ); is(scalar($obj->sort), 5, 'sort accessor in scalar context returns the number of elements in the list'); is_deeply( [ $obj->sort( sub { $_[0] <=> $_[1] } ) ], [ 3, 5, 9, 11, 22 ], 'sort returns values sorted by provided function' ); is(scalar($obj->sort( sub { $_[0] <=> $_[1] } )), 5, 'sort accessor with sort sub in scalar context returns the number of elements in the list'); like( exception { $obj->sort(1) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to sort' ); like( exception { $obj->sort( sub { }, 27 ); }, qr/number of parameters/, 'throws an error when passing two arguments to sort' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); $obj->sort_in_place; is_deeply( $obj->_values, [ 11, 22, 3, 5, 9 ], 'sort_in_place sorts values' ); $obj->sort_in_place( sub { $_[0] <=> $_[1] } ); is_deeply( $obj->_values, [ 3, 5, 9, 11, 22 ], 'sort_in_place with function sorts values' ); like( exception { $obj->sort_in_place( 27 ); }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to sort_in_place' ); like( exception { $obj->sort_in_place( sub { }, 27 ); }, qr/number of parameters/, 'throws an error when passing two arguments to sort_in_place' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); $obj->sort_in_place_curried; is_deeply( $obj->_values, [ 22, 11, 9, 5, 3 ], 'sort_in_place_curried sorts values' ); like( exception { $obj->sort_in_place_curried(27) }, qr/number of parameters/, 'throws an error when passing one argument passed to sort_in_place_curried' ); $obj->_values( [ 1 .. 5 ] ); is_deeply( [ $obj->map( sub { $_ + 1 } ) ], [ 2 .. 6 ], 'map returns the expected values' ); like( exception { $obj->map }, qr/number of parameters/, 'throws an error when passing no arguments to map' ); like( exception { $obj->map( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to map' ); like( exception { $obj->map( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to map' ); $obj->_values( [ 1 .. 5 ] ); is_deeply( [ $obj->map_curried ], [ 2 .. 6 ], 'map_curried returns the expected values' ); like( exception { $obj->map_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to map_curried' ); $obj->_values( [ 2 .. 9 ] ); is_deeply( [ $obj->grep( sub { $_ < 5 } ) ], [ 2 .. 4 ], 'grep returns the expected values' ); like( exception { $obj->grep }, qr/number of parameters/, 'throws an error when passing no arguments to grep' ); like( exception { $obj->grep( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to grep' ); like( exception { $obj->grep( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to grep' ); # my $overloader = Overloader->new( sub { $_ < 5 } ); # is_deeply( # [ $obj->grep($overloader) ], # [ 2 .. 4 ], # 'grep works with obj that overload code dereferencing' # ); is_deeply( [ $obj->grep_curried ], [ 2 .. 4 ], 'grep_curried returns the expected values' ); like( exception { $obj->grep_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to grep_curried' ); $obj->_values( [ 2, 4, 22, 99, 101, 6 ] ); is( $obj->first( sub { $_ % 2 } ), 99, 'first returns expected value' ); like( exception { $obj->first }, qr/number of parameters/, 'throws an error when passing no arguments to first' ); like( exception { $obj->first( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to first' ); like( exception { $obj->first( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to first' ); is( $obj->first_curried, 99, 'first_curried returns expected value' ); like( exception { $obj->first_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to first_curried' ); is( $obj->first_index( sub { $_ % 2 } ), 3, 'first_index returns expected value' ); like( exception { $obj->first_index }, qr/number of parameters/, 'throws an error when passing no arguments to first_index' ); like( exception { $obj->first_index( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to first_index' ); like( exception { $obj->first_index( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to first_index' ); is( $obj->first_index_curried, 3, 'first_index_curried returns expected value' ); like( exception { $obj->first_index_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to first_index_curried' ); $obj->_values( [ 1 .. 4 ] ); is( $obj->join('-'), '1-2-3-4', 'join returns expected result' ); is( $obj->join(q{}), '1234', 'join returns expected result when joining with empty string' ); is( $obj->join(0), '1020304', 'join returns expected result when joining with 0 as number' ); is( $obj->join("0"), '1020304', 'join returns expected result when joining with 0 as string' ); # is( # $obj->join( OverloadStr->new(q{}) ), '1234', # 'join returns expected result when joining with object with string overload' # ); # # is( # $obj->join( OverloadNum->new(0) ), '1020304', # 'join returns expected result when joining with object with numify overload' # ); # like( exception { $obj->join }, qr/number of parameters/, 'throws an error when passing no arguments to join' ); like( exception { $obj->join( '-', 2 ) }, qr/number of parameters/, 'throws an error when passing two arguments to join' ); like( exception { $obj->join( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non string to join' ); is_deeply( [ sort $obj->shuffle ], [ 1 .. 4 ], 'shuffle returns all values (cannot check for a random order)' ); like( exception { $obj->shuffle(2) }, qr/number of parameters/, 'throws an error when passing an argument passed to shuffle' ); $obj->_values( [ 1 .. 4, 2, 5, 3, 7, 3, 3, 1 ] ); is_deeply( [ $obj->uniq ], [ 1 .. 4, 5, 7 ], 'uniq returns expected values (in original order)' ); like( exception { $obj->uniq(2) }, qr/number of parameters/, 'throws an error when passing an argument passed to uniq' ); $obj->_values( [ 1 .. 5 ] ); is( $obj->reduce( sub { $_[0] * $_[1] } ), 120, 'reduce returns expected value' ); like( exception { $obj->reduce }, qr/number of parameters/, 'throws an error when passing no arguments to reduce' ); like( exception { $obj->reduce( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to reduce' ); like( exception { $obj->reduce( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to reduce' ); is( $obj->reduce_curried, 120, 'reduce_curried returns expected value' ); like( exception { $obj->reduce_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to reduce_curried' ); $obj->_values( [ 1 .. 6 ] ); my $it = $obj->natatime(2); my @nat; while ( my @v = $it->() ) { push @nat, \@v; } is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime returns expected iterator' ) or diag(explain(\@nat)); @nat = (); $obj->natatime( 2, sub { push @nat, [@_] } ); is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime with function returns expected value' ); like( exception { $obj->natatime( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non integer to natatime' ); like( exception { $obj->natatime( 2, {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non code ref to natatime' ); $it = $obj->natatime_curried(); @nat = (); while ( my @v = $it->() ) { push @nat, \@v; } is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime_curried returns expected iterator' ); @nat = (); $obj->natatime_curried( sub { push @nat, [@_] } ); is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime_curried with function returns expected value' ); like( exception { $obj->natatime_curried( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non code ref to natatime_curried' ); if ( $class->meta->get_attribute('_values')->is_lazy ) { my $obj = $class->new; is( $obj->count, 2, 'count is 2 (lazy init)' ); $obj->_clear_values; is_deeply( [ $obj->elements ], [ 42, 84 ], 'elements contains default with lazy init' ); $obj->_clear_values; $obj->push(2); is_deeply( $obj->_values, [ 42, 84, 2 ], 'push works with lazy init' ); $obj->_clear_values; $obj->unshift( 3, 4 ); is_deeply( $obj->_values, [ 3, 4, 42, 84 ], 'unshift works with lazy init' ); } } $class; } done_testing; trait_bool.t000664001750001750 567514772476615 22054 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/05moose_nativetypesuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Moose' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; use Test::Moose; { my %handles = ( illuminate => 'set', darken => 'unset', flip_switch => 'toggle', is_dark => 'not', ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Bool'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moose; use Sub::HandlesVia; has is_lit => ( traits => [\@traits], is => 'rw', isa => 'Bool', default => 1, handles => \\%handles_copy, clearer => '_clear_is_lit', %attr, ); 1; } or die($@); return ( $class, \%handles ); } } { use Moose::Util::TypeConstraints; run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); type 'MyBool', as 'Bool', where { 1 }; run_tests( build_class( isa => 'MyBool' ) ); coerce 'MyBool', from 'Bool', via { $_ }; run_tests( build_class( isa => 'MyBool', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new; ok( $obj->illuminate, 'set returns true' ); ok( $obj->is_lit, 'set is_lit to 1 using ->illuminate' ); ok( !$obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->illuminate(1) }, qr/number of parameters/, 'set throws an error when an argument is passed' ); ok( !$obj->darken, 'unset returns false' ); ok( !$obj->is_lit, 'set is_lit to 0 using ->darken' ); ok( $obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->darken(1) }, qr/number of parameters/, 'unset throws an error when an argument is passed' ); ok( $obj->flip_switch, 'toggle returns new value' ); ok( $obj->is_lit, 'toggle is_lit back to 1 using ->flip_switch' ); ok( !$obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->flip_switch(1) }, qr/number of parameters/, 'toggle throws an error when an argument is passed' ); $obj->flip_switch; ok( !$obj->is_lit, 'toggle is_lit back to 0 again using ->flip_switch' ); ok( $obj->is_dark, 'check if is_dark does the right thing' ); } $class; } done_testing; trait_code.t000664001750001750 555114772476615 22024 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/05moose_nativetypesuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Moose' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; use Test::Moose; { my $name = 'Foo1'; sub build_class { my ( $attr1, $attr2, $attr3, $no_inline ) = @_; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Code'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moose; use Sub::HandlesVia; has( callback => ( is => 'bare', handles_via => [\@traits], isa => 'CodeRef', required => 1, handles => { 'invoke_callback' => 'execute' }, %{ \$attr1 || {} }, ) ); has( callback_method => ( is => 'bare', handles_via => [\@traits], isa => 'CodeRef', required => 1, handles => { 'invoke_method_callback' => 'execute_method' }, %{ \$attr2 || {} }, ) ); has( multiplier => ( is => 'bare', handles_via => [\@traits], isa => 'CodeRef', required => 1, handles => { 'multiply' => 'execute' }, %{ \$attr3 || {} }, ) ); 1; } or die($@); return $class; } } { my $i; my %subs = ( callback => sub { ++$i }, callback_method => sub { shift->multiply(@_) }, multiplier => sub { $_[0] * 2 }, ); run_tests( build_class, \$i, \%subs ); run_tests( build_class( undef, undef, undef, 1 ), \$i, \%subs ); run_tests( build_class( { lazy => 1, default => sub { $subs{callback} } }, { lazy => 1, default => sub { $subs{callback_method} } }, { lazy => 1, default => sub { $subs{multiplier} } }, ), \$i, ); } sub run_tests { my ( $class, $iref, @args ) = @_; note "Testing class $class"; ok( !$class->can($_), "Code trait didn't create reader method for $_" ) for qw(callback callback_method multiplier); with_immutable { ${$iref} = 0; my $obj = $class->new(@args); $obj->invoke_callback; is( ${$iref}, 1, '$i is 1 after invoke_callback' ); is( $obj->invoke_method_callback(3), 6, 'invoke_method_callback calls multiply with @_' ); is( $obj->multiply(3), 6, 'multiple double value' ); } $class; } done_testing; trait_counter.t000664001750001750 1132514772476615 22605 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/05moose_nativetypesuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Moose' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; use Test::Moose; { my %handles = ( inc_counter => 'inc', inc_counter_2 => [ inc => 2 ], dec_counter => 'dec', dec_counter_2 => [ dec => 2 ], reset_counter => 'reset', set_counter => 'set', set_counter_42 => [ set => 42 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Counter'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moose; use Sub::HandlesVia; has counter => ( traits => [\@traits], is => 'rw', isa => 'Int', default => 0, handles => \\%handles_copy, clearer => '_clear_counter', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { use Moose::Util::TypeConstraints; run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); type 'MyNum', as 'Int', where { 1 }; run_tests( build_class( isa => 'MyNum' ) ); coerce 'MyNum', from 'Int', via { $_ }; run_tests( build_class( isa => 'MyNum', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new(); is( $obj->counter, 0, '... got the default value' ); is( $obj->inc_counter, 1, 'inc returns new value' ); is( $obj->counter, 1, '... got the incremented value' ); is( $obj->inc_counter, 2, 'inc returns new value' ); is( $obj->counter, 2, '... got the incremented value (again)' ); like( exception { $obj->inc_counter( 1, 2 ) }, qr/number of parameters/, 'inc throws an error when two arguments are passed' ); is( $obj->dec_counter, 1, 'dec returns new value' ); is( $obj->counter, 1, '... got the decremented value' ); like( exception { $obj->dec_counter( 1, 2 ) }, qr/number of parameters/, 'dec throws an error when two arguments are passed' ); is( $obj->reset_counter, 0, 'reset returns new value' ); is( $obj->counter, 0, '... got the original value' ); like( exception { $obj->reset_counter(2) }, qr/number of parameters/, 'reset throws an error when an argument is passed' ); is( $obj->set_counter(5), 5, 'set returns new value' ); is( $obj->counter, 5, '... set the value' ); like( exception { $obj->set_counter( 1, 2 ) }, qr/number of parameters/, 'set throws an error when two arguments are passed' ); $obj->inc_counter(2); is( $obj->counter, 7, '... increment by arg' ); $obj->dec_counter(5); is( $obj->counter, 2, '... decrement by arg' ); $obj->inc_counter_2; is( $obj->counter, 4, '... curried increment' ); $obj->dec_counter_2; is( $obj->counter, 2, '... curried deccrement' ); $obj->set_counter_42; is( $obj->counter, 42, '... curried set' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->inc_counter; is( $obj->counter, 1, 'inc increments - with lazy default' ); $obj->_clear_counter; $obj->dec_counter; is( $obj->counter, -1, 'dec decrements - with lazy default' ); } } $class; } { package WithBuilder; use Moose; use Sub::HandlesVia; has nonlazy => ( traits => ['Counter'], is => 'rw', isa => 'Int', builder => '_builder', handles => { reset_nonlazy => 'reset', }, ); has lazy => ( traits => ['Counter'], is => 'rw', isa => 'Int', lazy => 1, builder => '_builder', handles => { reset_lazy => 'reset', }, ); sub _builder { 1 } } for my $attr ('lazy', 'nonlazy') { my $obj = WithBuilder->new; is($obj->$attr, 1, "built properly"); $obj->$attr(0); is($obj->$attr, 0, "can be manually set"); $obj->${\"reset_$attr"}; is($obj->$attr, 1, "reset resets it to its default value"); } done_testing; trait_hash.t000664001750001750 2217314772476615 22054 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/05moose_nativetypesuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Moose' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; use Test::Moose; { my %handles = ( option_accessor => 'accessor', quantity => [ accessor => 'quantity' ], clear_options => 'clear', num_options => 'count', delete_option => 'delete', is_defined => 'defined', options_elements => 'elements', has_option => 'exists', get_option => 'get', has_no_options => 'is_empty', keys => 'keys', values => 'values', key_value => 'kv', set_option => 'set', ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Hash'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moose; use Sub::HandlesVia; has options => ( traits => [\@traits], is => 'rw', isa => 'HashRef[Str]', default => sub { {} }, handles => \\%handles_copy, clearer => '_clear_options', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { use Moose::Util::TypeConstraints; run_tests(build_class); run_tests( build_class( lazy => 1, default => sub { { x => 1 } } ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); subtype 'MyHash', as 'HashRef[Str]', where { 1 }; run_tests( build_class( isa => 'MyHash' ) ); coerce 'MyHash', from 'HashRef', via { $_ }; run_tests( build_class( isa => 'MyHash', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new( options => {} ); ok( $obj->has_no_options, '... we have no options' ); is( $obj->num_options, 0, '... we have no options' ); is_deeply( $obj->options, {}, '... no options yet' ); ok( !$obj->has_option('foo'), '... we have no foo option' ); is( exception { is( $obj->set_option( foo => 'bar' ), 'bar', 'set return single new value in scalar context' ); }, undef, '... set the option okay' ); like( exception { $obj->set_option( foo => 'bar', 'baz' ) }, qr/number of parameters/, 'exception with odd number of arguments' ); like( exception { $obj->set_option( undef, 'bar' ) }, qr/did not pass type constraint/, 'exception when using undef as a key' ); ok( $obj->is_defined('foo'), '... foo is defined' ); ok( !$obj->has_no_options, '... we have options' ); is( $obj->num_options, 1, '... we have 1 option(s)' ); ok( $obj->has_option('foo'), '... we have a foo option' ); is_deeply( $obj->options, { foo => 'bar' }, '... got options now' ); is( exception { $obj->set_option( bar => 'baz' ); }, undef, '... set the option okay' ); is( $obj->num_options, 2, '... we have 2 option(s)' ); is_deeply( $obj->options, { foo => 'bar', bar => 'baz' }, '... got more options now' ); is( $obj->get_option('foo'), 'bar', '... got the right option' ); is_deeply( [ $obj->get_option(qw(foo bar)) ], [qw(bar baz)], "get multiple options at once" ); is( scalar( $obj->get_option(qw( foo bar)) ), "baz", '... got last option in scalar context' ); is( exception { $obj->set_option( oink => "blah", xxy => "flop" ); }, undef, '... set the option okay' ); is( $obj->num_options, 4, "4 options" ); is_deeply( [ $obj->get_option(qw(foo bar oink xxy)) ], [qw(bar baz blah flop)], "get multiple options at once" ); is( exception { is( scalar $obj->delete_option('bar'), 'baz', 'delete returns deleted value' ); }, undef, '... deleted the option okay' ); is( exception { is_deeply( [ $obj->delete_option( 'oink', 'xxy' ) ], [ 'blah', 'flop' ], 'delete returns all deleted values in list context' ); }, undef, '... deleted multiple option okay' ); is( $obj->num_options, 1, '... we have 1 option(s)' ); is_deeply( $obj->options, { foo => 'bar' }, '... got more options now' ); $obj->clear_options; is_deeply( $obj->options, {}, "... cleared options" ); is( exception { $obj->quantity(4); }, undef, '... options added okay with defaults' ); is( $obj->quantity, 4, 'reader part of curried accessor works' ); is( $obj->option_accessor('quantity'), 4, 'accessor as reader' ); is_deeply( $obj->options, { quantity => 4 }, '... returns what we expect' ); $obj->option_accessor( size => 42 ); like( exception { $obj->option_accessor; }, qr/number of parameters/, 'error when calling accessor with no arguments' ); like( exception { $obj->option_accessor( undef, 'bar' ) }, qr/did not pass type constraint/, 'exception when using undef as a key' ); is_deeply( $obj->options, { quantity => 4, size => 42 }, 'accessor as writer' ); is( exception { $class->new( options => { foo => 'BAR' } ); }, undef, '... good constructor params' ); isnt( exception { $obj->set_option( bar => {} ); }, undef, '... could not add a hash ref where an string is expected' ); isnt( exception { $class->new( options => { foo => [] } ); }, undef, '... bad constructor params' ); $obj->options( {} ); is_deeply( [ $obj->set_option( oink => "blah", xxy => "flop" ) ], [ 'blah', 'flop' ], 'set returns newly set values in order of keys provided' ); is_deeply( [ sort $obj->keys ], [ 'oink', 'xxy' ], 'keys returns expected keys' ); is_deeply( [ sort $obj->values ], [ 'blah', 'flop' ], 'values returns expected values' ); my @key_value = sort { $a->[0] cmp $b->[0] } $obj->key_value; is_deeply( \@key_value, [ sort { $a->[0] cmp $b->[0] }[ 'xxy', 'flop' ], [ 'oink', 'blah' ] ], '... got the right key value pairs' ) or do { require Data::Dumper; diag( Data::Dumper::Dumper( \@key_value ) ); }; my %options_elements = $obj->options_elements; is_deeply( \%options_elements, { 'oink' => 'blah', 'xxy' => 'flop' }, '... got the right hash elements' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->set_option( y => 2 ); is_deeply( $obj->options, { x => 1, y => 2 }, 'set_option with lazy default' ); $obj->_clear_options; ok( $obj->has_option('x'), 'key for x exists - lazy default' ); $obj->_clear_options; ok( $obj->is_defined('x'), 'key for x is defined - lazy default' ); $obj->_clear_options; is_deeply( [ $obj->key_value ], [ [ x => 1 ] ], 'kv returns lazy default' ); $obj->_clear_options; $obj->option_accessor( y => 2 ); is_deeply( [ sort $obj->keys ], [ 'x', 'y' ], 'accessor triggers lazy default generator' ); } } $class; } { my ( $class, $handles ) = build_class( isa => 'HashRef' ); my $obj = $class->new; with_immutable { is( exception { $obj->option_accessor( 'foo', undef ) }, undef, 'can use accessor to set value to undef' ); is( exception { $obj->quantity(undef) }, undef, 'can use accessor to set value to undef' ); } $class; } done_testing; trait_number.t000664001750001750 1042314772476615 22414 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/05moose_nativetypesuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Moose' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; use Test::Moose; { my %handles = ( abs => 'abs', add => 'add', inc => [ add => 1 ], div => 'div', cut_in_half => [ div => 2 ], mod => 'mod', odd => [ mod => 2 ], mul => 'mul', set => 'set', sub => 'sub', dec => [ sub => 1 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Number'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moose; use Sub::HandlesVia; has integer => ( traits => [\@traits], is => 'rw', isa => 'Int', default => 5, handles => \\%handles_copy, clearer => '_clear_integer', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { use Moose::Util::TypeConstraints; run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); type 'MyNum', as 'Num', where { 1 }; run_tests( build_class( isa => 'MyNum' ) ); coerce 'MyNum', from 'Num', via { $_ }; run_tests( build_class( isa => 'MyNum', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new; is( $obj->integer, 5, 'Default to five' ); is( $obj->add(10), 15, 'add returns new value' ); is( $obj->integer, 15, 'Add ten for fithteen' ); like( exception { $obj->add( 10, 2 ) }, qr/number of parameters/, 'add throws an error when 2 arguments are passed' ); is( $obj->sub(3), 12, 'sub returns new value' ); is( $obj->integer, 12, 'Subtract three for 12' ); like( exception { $obj->sub( 10, 2 ) }, qr/number of parameters/, 'sub throws an error when 2 arguments are passed' ); is( $obj->set(10), 10, 'set returns new value' ); is( $obj->integer, 10, 'Set to ten' ); like( exception { $obj->set( 10, 2 ) }, qr/number of parameters/, 'set throws an error when 2 arguments are passed' ); is( $obj->div(2), 5, 'div returns new value' ); is( $obj->integer, 5, 'divide by 2' ); like( exception { $obj->div( 10, 2 ) }, qr/number of parameters/, 'div throws an error when 2 arguments are passed' ); is( $obj->mul(2), 10, 'mul returns new value' ); is( $obj->integer, 10, 'multiplied by 2' ); like( exception { $obj->mul( 10, 2 ) }, qr/number of parameters/, 'mul throws an error when 2 arguments are passed' ); is( $obj->mod(2), 0, 'mod returns new value' ); is( $obj->integer, 0, 'Mod by 2' ); like( exception { $obj->mod( 10, 2 ) }, qr/number of parameters/, 'mod throws an error when 2 arguments are passed' ); $obj->set(7); $obj->mod(5); is( $obj->integer, 2, 'Mod by 5' ); $obj->set(-1); is( $obj->abs, 1, 'abs returns new value' ); like( exception { $obj->abs(10) }, qr/number of parameters/, 'abs throws an error when an argument is passed' ); is( $obj->integer, 1, 'abs 1' ); $obj->set(12); $obj->inc; is( $obj->integer, 13, 'inc 12' ); $obj->dec; is( $obj->integer, 12, 'dec 13' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->add(2); is( $obj->integer, 7, 'add with lazy default' ); $obj->_clear_integer; $obj->mod(2); is( $obj->integer, 1, 'mod with lazy default' ); } } $class; } done_testing; trait_string.t000664001750001750 2300414772476615 22431 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/05moose_nativetypesuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Moose' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; use Test::Moose; { my %handles = ( inc => 'inc', append => 'append', append_curried => [ append => '!' ], prepend => 'prepend', prepend_curried => [ prepend => '-' ], replace => 'replace', replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ], chop => 'chop', chomp => 'chomp', clear => 'clear', match => 'match', match_curried => [ match => qr/\D/ ], length => 'length', substr => 'substr', substr_curried_1 => [ substr => (1) ], substr_curried_2 => [ substr => ( 1, 3 ) ], substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'String'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Moose; use Sub::HandlesVia; has _string => ( traits => [\@traits], is => 'rw', isa => 'Str', default => q{}, handles => \\%handles_copy, clearer => '_clear_string', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { use Moose::Util::TypeConstraints; run_tests(build_class); run_tests( build_class( lazy => 1, default => q{} ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); type 'MyStr', as 'Str', where { 1 }; run_tests( build_class( isa => 'MyStr' ) ); coerce 'MyStr', from 'Str', via { $_ }; run_tests( build_class( isa => 'MyStr', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; with_immutable { my $obj = $class->new(); is( $obj->length, 0, 'length returns zero' ); $obj->_string('a'); is( $obj->length, 1, 'length returns 1 for new string' ); like( exception { $obj->length(42) }, qr/number of parameters/, 'length throws an error when an argument is passed' ); is( $obj->inc, 'b', 'inc returns new value' ); is( $obj->_string, 'b', 'a becomes b after inc' ); like( exception { $obj->inc(42) }, qr/number of parameters/, 'inc throws an error when an argument is passed' ); is( $obj->append('foo'), 'bfoo', 'append returns new value' ); is( $obj->_string, 'bfoo', 'appended to the string' ); like( exception { $obj->append( 'foo', 2 ) }, qr/number of parameters/, 'append throws an error when two arguments are passed' ); $obj->append_curried; is( $obj->_string, 'bfoo!', 'append_curried appended to the string' ); like( exception { $obj->append_curried('foo') }, qr/number of parameters/, 'append_curried throws an error when two arguments are passed' ); $obj->_string("has nl$/"); is( $obj->chomp, 1, 'chomp returns number of characters removed' ); is( $obj->_string, 'has nl', 'chomped string' ); is( $obj->chomp, 0, 'chomp returns number of characters removed' ); is( $obj->_string, 'has nl', 'chomp is a no-op when string has no line ending' ); like( exception { $obj->chomp(42) }, qr/number of parameters/, 'chomp throws an error when an argument is passed' ); is( $obj->chop, 'l', 'chop returns character removed' ); is( $obj->_string, 'has n', 'chopped string' ); like( exception { $obj->chop(42) }, qr/number of parameters/, 'chop throws an error when an argument is passed' ); $obj->_string('x'); is( $obj->prepend('bar'), 'barx', 'prepend returns new value' ); is( $obj->_string, 'barx', 'prepended to string' ); $obj->prepend_curried; is( $obj->_string, '-barx', 'prepend_curried prepended to string' ); is( $obj->replace( qr/([ao])/, sub { uc($1) } ), '-bArx', 'replace returns new value' ); is( $obj->_string, '-bArx', 'substitution using coderef for replacement' ); $obj->replace( qr/A/, 'X' ); is( $obj->_string, '-bXrx', 'substitution using string as replacement' ); $obj->_string('foo'); $obj->replace( qr/oo/, q{} ); is( $obj->_string, 'f', 'replace accepts an empty string as second argument' ); $obj->replace( q{}, 'a' ); is( $obj->_string, 'af', 'replace accepts an empty string as first argument' ); like( exception { $obj->replace( {}, 'x' ) }, qr/did not pass type constraint/, 'replace throws an error when the first argument is not a string or regexp' ); like( exception { $obj->replace( qr/x/, {} ) }, qr/did not pass type constraint/, 'replace throws an error when the first argument is not a string or regexp' ); $obj->_string('Moosex'); $obj->replace_curried; is( $obj->_string, 'MooseX', 'capitalize last' ); $obj->_string('abcdef'); is_deeply( [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ], 'match -barx against /[aq]/ returns matches' ); is_deeply( [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ], 'match -barx against /[aq]/ returns matches' ); ok( scalar $obj->match('b'), 'match with string as argument returns true' ); ok( scalar $obj->match(q{}), 'match with empty string as argument returns true' ); like( exception { $obj->match }, qr/number of parameters/, 'match throws an error when no arguments are passed' ); like( exception { $obj->match( {} ) }, qr/did not pass type constraint/, 'match throws an error when an invalid argument is passed' ); $obj->_string('1234'); ok( !$obj->match_curried, 'match_curried returns false' ); $obj->_string('one two three four'); ok( $obj->match_curried, 'match curried returns true' ); $obj->clear; is( $obj->_string, q{}, 'clear' ); like( exception { $obj->clear(42) }, qr/number of parameters/, 'clear throws an error when an argument is passed' ); $obj->_string('some long string'); is( $obj->substr(1), 'ome long string', 'substr as getter with one argument' ); $obj->_string('some long string'); is( $obj->substr( 1, 3 ), 'ome', 'substr as getter with two arguments' ); is( $obj->substr( 1, 3, 'ong' ), 'ome', 'substr as setter returns replaced string' ); is( $obj->_string, 'song long string', 'substr as setter with three arguments' ); $obj->substr( 1, 3, '' ); is( $obj->_string, 's long string', 'substr as setter with three arguments, replacment is empty string' ); like( exception { $obj->substr }, qr/number of parameters/, 'substr throws an error when no argumemts are passed' ); like( exception { $obj->substr( 1, 2, 3, 4 ) }, qr/number of parameters/, 'substr throws an error when four argumemts are passed' ); like( exception { $obj->substr( {} ) }, qr/did not pass type constraint/, 'substr throws an error when first argument is not an integer' ); like( exception { $obj->substr( 1, {} ) }, qr/did not pass type constraint/, 'substr throws an error when second argument is not an integer' ); like( exception { $obj->substr( 1, 2, {} ) }, qr/did not pass type constraint/, 'substr throws an error when third argument is not a string' ); $obj->_string('some long string'); is( $obj->substr_curried_1, 'ome long string', 'substr_curried_1 returns expected value' ); is( $obj->substr_curried_1(3), 'ome', 'substr_curried_1 with one argument returns expected value' ); $obj->substr_curried_1( 3, 'ong' ); is( $obj->_string, 'song long string', 'substr_curried_1 as setter with two arguments' ); $obj->_string('some long string'); is( $obj->substr_curried_2, 'ome', 'substr_curried_2 returns expected value' ); $obj->substr_curried_2('ong'); is( $obj->_string, 'song long string', 'substr_curried_2 as setter with one arguments' ); $obj->_string('some long string'); $obj->substr_curried_3; is( $obj->_string, 'song long string', 'substr_curried_3 as setter' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->append('foo'); is( $obj->_string, 'foo', 'append with lazy default' ); } } $class; } done_testing; ext_attr.t000664001750001750 73414772476615 17073 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/06mouseuse strict; use warnings; use Test::More; { package Local::Dummy1; use Test::Requires 'Mouse' }; { package ParentClass; use Mouse; has 'test' => ( is => 'ro', default => sub { [] }, ); } { package ThisFails; use Mouse; use Sub::HandlesVia; extends 'ParentClass'; has '+test' => ( handles_via => 'Array', handles => { 'push' => 'push...' } ); } my $obj = ThisFails->new; is_deeply($obj->push('a')->push('test')->test, [qw(a test)]); done_testing; role.t000664001750001750 160614772476615 16221 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/06mouseuse strict; use warnings; use Test::More; use Test::Fatal; { package Local::Dummy1; use Test::Requires 'Mouse' }; { package Local::Role1; use Mouse::Role; use Sub::HandlesVia; use Types::Standard qw( ArrayRef Int ); has nums => ( is => 'ro', isa => ArrayRef[Int], builder => '_build_nums', handles_via => 'Array', handles => { pop_num => 'pop', push_num => 'push' }, ); sub _build_nums { [ 1..10 ] } } { package Local::Class1; use Mouse; with 'Local::Role1'; } #require B::Deparse; #::note( B::Deparse->new->coderef2text(\&Local::Class1::pop_num) ); my $obj = Local::Class1->new; is( $obj->pop_num, 10 ); is( $obj->pop_num, 9 ); is( $obj->pop_num, 8 ); is( $obj->pop_num, 7 ); isnt( exception { $obj->push_num(44.5) }, undef, ); is( $obj->pop_num, 6 ); is( exception { $obj->push_num(6) }, undef, ); is( $obj->pop_num, 6 ); done_testing; roles-multiple.t000664001750001750 123414772476615 20232 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/06mouseuse strict; use warnings; use Test::More skip_all => 'TODO (issue #9)'; use Test::Fatal; { package Local::Dummy1; use Test::Requires 'Mouse' }; { package TestRole1; use Mouse::Role; } { package TestRole2; use Mouse::Role; use Types::Standard qw(ArrayRef); use Sub::HandlesVia; has test => ( is => 'ro', isa => ArrayRef, default => sub { [] }, handles_via => 'Array', handles => { all_test => 'all' }, ); } { package TestClass; use Mouse; with qw( TestRole1 TestRole2 ); __PACKAGE__->meta->make_immutable; } my $obj = TestClass->new( test => [ 1, 2 ] ); is_deeply( [ $obj->all_test ], [ 1, 2 ] ); done_testing; trait_array.t000664001750001750 6355314772476615 17632 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/06mouseuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Mouse' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; BEGIN { require Mouse::Util; Mouse::Util::MOUSE_XS() or plan skip_all => 'https://github.com/xslate/p5-Mouse/issues/106'; }; { my %handles = ( count => 'count', elements => 'elements', is_empty => 'is_empty', push => 'push', push_curried => [ push => 42, 84 ], unshift => 'unshift', unshift_curried => [ unshift => 42, 84 ], pop => 'pop', shift => 'shift', get => 'get', get_curried => [ get => 1 ], set => 'set', set_curried_1 => [ set => 1 ], set_curried_2 => [ set => ( 1, 98 ) ], accessor => 'accessor', accessor_curried_1 => [ accessor => 1 ], accessor_curried_2 => [ accessor => ( 1, 90 ) ], clear => 'clear', delete => 'delete', delete_curried => [ delete => 1 ], insert => 'insert', insert_curried => [ insert => ( 1, 101 ) ], splice => 'splice', splice_curried_1 => [ splice => 1 ], splice_curried_2 => [ splice => 1, 2 ], splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ], sort => 'sort', sort_curried => [ sort => ( sub { $_[1] <=> $_[0] } ) ], sort_in_place => 'sort_in_place', sort_in_place_curried => [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ], map => 'map', map_curried => [ map => ( sub { $_ + 1 } ) ], grep => 'grep', grep_curried => [ grep => ( sub { $_ < 5 } ) ], first => 'first', first_curried => [ first => ( sub { $_ % 2 } ) ], first_index => 'first_index', first_index_curried => [ first_index => ( sub { $_ % 2 } ) ], join => 'join', join_curried => [ join => '-' ], shuffle => 'shuffle', uniq => 'uniq', reduce => 'reduce', reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ], natatime => 'natatime', natatime_curried => [ natatime => 2 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Array'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Mouse; use Sub::HandlesVia; use Types::Standard qw(ArrayRef Int); has _values => ( traits => [\@traits], is => 'rw', isa => ArrayRef[Int], default => sub { [] }, handles => \\%handles_copy, clearer => '_clear_values', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { package Overloader; use overload '&{}' => sub { ${ $_[0] } }, bool => sub {1}; sub new { bless \$_[1], $_[0]; } } { package OverloadStr; use overload q{""} => sub { ${ $_[0] } }, fallback => 1; sub new { my $class = shift; my $str = shift; return bless \$str, $class; } } { package OverloadNum; use overload q{0+} => sub { ${ $_[0] } }, fallback => 1; sub new { my $class = shift; my $str = shift; return bless \$str, $class; } } use Types::Standard qw( ArrayRef Int ); { subtest( 'simple case', sub { run_tests(build_class) } ); subtest( 'lazy default attr', sub { run_tests( build_class( lazy => 1, default => sub { [ 42, 84 ] } ) ); } ); subtest( 'attr with trigger', sub { run_tests( build_class( trigger => sub { } ) ); } ); subtest( 'attr is not inlined', sub { run_tests( build_class( no_inline => 1 ) ) } ); subtest( 'attr type forces the inlining code to check the entire arrayref when it is modified', sub { run_tests( build_class( isa => ArrayRef->where(sub {1}) ) ); } ); subtest( 'attr type has coercion', sub { run_tests( build_class( isa => ArrayRef->plus_coercions(Int, '[$_]'), coerce => 1 ) ); } ); } subtest( 'setting value to undef with accessor', sub { my ( $class, $handles ) = build_class( isa => ArrayRef ); note "Testing class $class"; my $obj = $class->new; # with_immutable { is( exception { $obj->accessor( 0, undef ) }, undef, 'can use accessor to set value to undef' ); is( exception { $obj->accessor_curried_1(undef) }, undef, 'can use curried accessor to set value to undef' ); # } # $class; } ); sub run_tests { my ( $class, $handles ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new( _values => [ 10, 12, 42 ] ); is_deeply( $obj->_values, [ 10, 12, 42 ], 'values can be set in constructor' ); ok( !$obj->is_empty, 'values is not empty' ); is( $obj->count, 3, 'count returns 3' ); like( exception { $obj->count(22) }, qr/number of parameters/, 'throws an error when passing an argument passed to count' ); is( exception { $obj->push( 1, 2, 3 ) }, undef, 'pushed three new values and lived' ); is( exception { $obj->push() }, undef, 'call to push without arguments lives' ); is( exception { is( $obj->unshift( 101, 22 ), 8, 'unshift returns size of the new array' ); }, undef, 'unshifted two values and lived' ); is_deeply( $obj->_values, [ 101, 22, 10, 12, 42, 1, 2, 3 ], 'unshift changed the value of the array in the object' ); is( exception { $obj->unshift() }, undef, 'call to unshift without arguments lives' ); is( $obj->pop, 3, 'pop returns the last value in the array' ); is_deeply( $obj->_values, [ 101, 22, 10, 12, 42, 1, 2 ], 'pop changed the value of the array in the object' ); like( exception { $obj->pop(42) }, qr/number of parameters/, 'call to pop with arguments dies' ); is( $obj->shift, 101, 'shift returns the first value' ); like( exception { $obj->shift(42) }, qr/number of parameters/, 'call to shift with arguments dies' ); is_deeply( $obj->_values, [ 22, 10, 12, 42, 1, 2 ], 'shift changed the value of the array in the object' ); is_deeply( [ $obj->elements ], [ 22, 10, 12, 42, 1, 2 ], 'call to elements returns values as a list' ); is(scalar($obj->elements), 6, 'elements accessor in scalar context returns the number of elements in the list'); like( exception { $obj->elements(22) }, qr/number of parameters/, 'throws an error when passing an argument passed to elements' ); $obj->_values( [ 1, 2, 3 ] ); is( $obj->get(0), 1, 'get values at index 0' ); is( $obj->get(1), 2, 'get values at index 1' ); is( $obj->get(2), 3, 'get values at index 2' ); is( $obj->get_curried, 2, 'get_curried returns value at index 1' ); like( exception { $obj->get() }, qr/number of parameters/, 'throws an error when get is called without any arguments' ); like( exception { $obj->get( {} ) }, qr/did not pass type constraint/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get(2.2) }, qr/did not pass type constraint/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get('foo') }, qr/did not pass type constraint/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get_curried(2) }, qr/number of parameters/, 'throws an error when get_curried is called with an argument' ); is( exception { is( $obj->set( 1, 100 ), 100, 'set returns new value' ); }, undef, 'set value at index 1 lives' ); is( $obj->get(1), 100, 'get value at index 1 returns new value' ); like( exception { $obj->set( 1, 99, 42 ) }, qr/number of parameters/, 'throws an error when set is called with three arguments' ); is( exception { $obj->set_curried_1(99) }, undef, 'set_curried_1 lives' ); is( $obj->get(1), 99, 'get value at index 1 returns new value' ); like( exception { $obj->set_curried_1( 99, 42 ) }, qr/number of parameters/, 'throws an error when set_curried_1 is called with two arguments' ); is( exception { $obj->set_curried_2 }, undef, 'set_curried_2 lives' ); is( $obj->get(1), 98, 'get value at index 1 returns new value' ); like( exception { $obj->set_curried_2(42) }, qr/number of parameters/, 'throws an error when set_curried_2 is called with one argument' ); #use B::Deparse; #diag(B::Deparse->new->coderef2text($obj->can('accessor'))); is( $obj->accessor(1), 98, 'accessor with one argument returns value at index 1' ); is( exception { is( $obj->accessor( 1 => 97 ), 97, 'accessor returns new value' ); }, undef, 'accessor as writer lives' ); like( exception { $obj->accessor; }, qr/number of parameters/, 'throws an error when accessor is called without arguments' ); is( $obj->get(1), 97, 'accessor set value at index 1' ); like( exception { $obj->accessor( 1, 96, 42 ) }, qr/number of parameters/, 'throws an error when accessor is called with three arguments' ); is( $obj->accessor_curried_1, 97, 'accessor_curried_1 returns expected value when called with no arguments' ); is( exception { $obj->accessor_curried_1(95) }, undef, 'accessor_curried_1 as writer lives' ); is( $obj->get(1), 95, 'accessor_curried_1 set value at index 1' ); like( exception { $obj->accessor_curried_1( 96, 42 ) }, qr/number of parameters/, 'throws an error when accessor_curried_1 is called with two arguments' ); is( exception { $obj->accessor_curried_2 }, undef, 'accessor_curried_2 as writer lives' ); is( $obj->get(1), 90, 'accessor_curried_2 set value at index 1' ); like( exception { $obj->accessor_curried_2(42) }, qr/number of parameters/, 'throws an error when accessor_curried_2 is called with one argument' ); is( exception { $obj->clear }, undef, 'clear lives' ); ok( $obj->is_empty, 'values is empty after call to clear' ); is( exception { is( $obj->shift, undef, 'shift returns undef on an empty array' ); }, undef, 'shifted from an empty array and lived' ); $obj->set( 0 => 42 ); like( exception { $obj->clear(50) }, qr/number of parameters/, 'throws an error when clear is called with an argument' ); ok( !$obj->is_empty, 'values is not empty after failed call to clear' ); like( exception { $obj->is_empty(50) }, qr/number of parameters/, 'throws an error when is_empty is called with an argument' ); $obj->clear; is( $obj->push( 1, 5, 10, 42 ), 4, 'pushed 4 elements, got number of elements in the array back' ); is( exception { is( $obj->delete(2), 10, 'delete returns deleted value' ); }, undef, 'delete lives' ); is_deeply( $obj->_values, [ 1, 5, 42 ], 'delete removed the specified element' ); like( exception { $obj->delete( 2, 3 ) }, qr/number of parameters/, 'throws an error when delete is called with two arguments' ); is( exception { $obj->delete_curried }, undef, 'delete_curried lives' ); is_deeply( $obj->_values, [ 1, 42 ], 'delete removed the specified element' ); like( exception { $obj->delete_curried(2) }, qr/number of parameters/, 'throws an error when delete_curried is called with one argument' ); is( exception { $obj->insert( 1, 21 ) }, undef, 'insert lives' ); is_deeply( $obj->_values, [ 1, 21, 42 ], 'insert added the specified element' ); like( exception { $obj->insert( 1, 22, 44 ) }, qr/number of parameters/, 'throws an error when insert is called with three arguments' ); is( exception { is_deeply( [ $obj->splice( 1, 0, 2, 3 ) ], [], 'return value of splice is empty list when not removing elements' ); }, undef, 'splice lives' ); is_deeply( $obj->_values, [ 1, 2, 3, 21, 42 ], 'splice added the specified elements' ); is( exception { is_deeply( [ $obj->splice( 1, 2, 99 ) ], [ 2, 3 ], 'splice returns list of removed values' ); }, undef, 'splice lives' ); is_deeply( $obj->_values, [ 1, 99, 21, 42 ], 'splice added the specified elements' ); like( exception { $obj->splice() }, qr/number of parameters/, 'throws an error when splice is called with no arguments' ); like( exception { $obj->splice( 1, 'foo', ) }, qr/did not pass type constraint/, 'throws an error when splice is called with an invalid length' ); is( exception { $obj->splice_curried_1( 2, 101 ) }, undef, 'splice_curried_1 lives' ); is_deeply( $obj->_values, [ 1, 101, 42 ], 'splice added the specified elements' ); is( exception { $obj->splice_curried_2(102) }, undef, 'splice_curried_2 lives' ); is_deeply( $obj->_values, [ 1, 102 ], 'splice added the specified elements' ); is( exception { $obj->splice_curried_all }, undef, 'splice_curried_all lives' ); is_deeply( $obj->_values, [ 1, 3, 4, 5 ], 'splice added the specified elements' ); is_deeply( scalar $obj->splice( 1, 2 ), 4, 'splice in scalar context returns last element removed' ); is_deeply( scalar $obj->splice( 1, 0, 42 ), undef, 'splice in scalar context returns undef when no elements are removed' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); is_deeply( [ $obj->sort ], [ 11, 22, 3, 5, 9 ], 'sort returns sorted values' ); is(scalar($obj->sort), 5, 'sort accessor in scalar context returns the number of elements in the list'); is_deeply( [ $obj->sort( sub { $_[0] <=> $_[1] } ) ], [ 3, 5, 9, 11, 22 ], 'sort returns values sorted by provided function' ); is(scalar($obj->sort( sub { $_[0] <=> $_[1] } )), 5, 'sort accessor with sort sub in scalar context returns the number of elements in the list'); like( exception { $obj->sort(1) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to sort' ); like( exception { $obj->sort( sub { }, 27 ); }, qr/number of parameters/, 'throws an error when passing two arguments to sort' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); $obj->sort_in_place; is_deeply( $obj->_values, [ 11, 22, 3, 5, 9 ], 'sort_in_place sorts values' ); $obj->sort_in_place( sub { $_[0] <=> $_[1] } ); is_deeply( $obj->_values, [ 3, 5, 9, 11, 22 ], 'sort_in_place with function sorts values' ); like( exception { $obj->sort_in_place( 27 ); }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to sort_in_place' ); like( exception { $obj->sort_in_place( sub { }, 27 ); }, qr/number of parameters/, 'throws an error when passing two arguments to sort_in_place' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); $obj->sort_in_place_curried; is_deeply( $obj->_values, [ 22, 11, 9, 5, 3 ], 'sort_in_place_curried sorts values' ); like( exception { $obj->sort_in_place_curried(27) }, qr/number of parameters/, 'throws an error when passing one argument passed to sort_in_place_curried' ); $obj->_values( [ 1 .. 5 ] ); is_deeply( [ $obj->map( sub { $_ + 1 } ) ], [ 2 .. 6 ], 'map returns the expected values' ); like( exception { $obj->map }, qr/number of parameters/, 'throws an error when passing no arguments to map' ); like( exception { $obj->map( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to map' ); like( exception { $obj->map( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to map' ); $obj->_values( [ 1 .. 5 ] ); is_deeply( [ $obj->map_curried ], [ 2 .. 6 ], 'map_curried returns the expected values' ); like( exception { $obj->map_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to map_curried' ); $obj->_values( [ 2 .. 9 ] ); is_deeply( [ $obj->grep( sub { $_ < 5 } ) ], [ 2 .. 4 ], 'grep returns the expected values' ); like( exception { $obj->grep }, qr/number of parameters/, 'throws an error when passing no arguments to grep' ); like( exception { $obj->grep( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to grep' ); like( exception { $obj->grep( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to grep' ); # my $overloader = Overloader->new( sub { $_ < 5 } ); # is_deeply( # [ $obj->grep($overloader) ], # [ 2 .. 4 ], # 'grep works with obj that overload code dereferencing' # ); is_deeply( [ $obj->grep_curried ], [ 2 .. 4 ], 'grep_curried returns the expected values' ); like( exception { $obj->grep_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to grep_curried' ); $obj->_values( [ 2, 4, 22, 99, 101, 6 ] ); is( $obj->first( sub { $_ % 2 } ), 99, 'first returns expected value' ); like( exception { $obj->first }, qr/number of parameters/, 'throws an error when passing no arguments to first' ); like( exception { $obj->first( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to first' ); like( exception { $obj->first( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to first' ); is( $obj->first_curried, 99, 'first_curried returns expected value' ); like( exception { $obj->first_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to first_curried' ); is( $obj->first_index( sub { $_ % 2 } ), 3, 'first_index returns expected value' ); like( exception { $obj->first_index }, qr/number of parameters/, 'throws an error when passing no arguments to first_index' ); like( exception { $obj->first_index( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to first_index' ); like( exception { $obj->first_index( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to first_index' ); is( $obj->first_index_curried, 3, 'first_index_curried returns expected value' ); like( exception { $obj->first_index_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to first_index_curried' ); $obj->_values( [ 1 .. 4 ] ); is( $obj->join('-'), '1-2-3-4', 'join returns expected result' ); is( $obj->join(q{}), '1234', 'join returns expected result when joining with empty string' ); is( $obj->join(0), '1020304', 'join returns expected result when joining with 0 as number' ); is( $obj->join("0"), '1020304', 'join returns expected result when joining with 0 as string' ); # is( # $obj->join( OverloadStr->new(q{}) ), '1234', # 'join returns expected result when joining with object with string overload' # ); # # is( # $obj->join( OverloadNum->new(0) ), '1020304', # 'join returns expected result when joining with object with numify overload' # ); # like( exception { $obj->join }, qr/number of parameters/, 'throws an error when passing no arguments to join' ); like( exception { $obj->join( '-', 2 ) }, qr/number of parameters/, 'throws an error when passing two arguments to join' ); like( exception { $obj->join( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non string to join' ); is_deeply( [ sort $obj->shuffle ], [ 1 .. 4 ], 'shuffle returns all values (cannot check for a random order)' ); like( exception { $obj->shuffle(2) }, qr/number of parameters/, 'throws an error when passing an argument passed to shuffle' ); $obj->_values( [ 1 .. 4, 2, 5, 3, 7, 3, 3, 1 ] ); is_deeply( [ $obj->uniq ], [ 1 .. 4, 5, 7 ], 'uniq returns expected values (in original order)' ); like( exception { $obj->uniq(2) }, qr/number of parameters/, 'throws an error when passing an argument passed to uniq' ); $obj->_values( [ 1 .. 5 ] ); is( $obj->reduce( sub { $_[0] * $_[1] } ), 120, 'reduce returns expected value' ); like( exception { $obj->reduce }, qr/number of parameters/, 'throws an error when passing no arguments to reduce' ); like( exception { $obj->reduce( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to reduce' ); like( exception { $obj->reduce( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to reduce' ); is( $obj->reduce_curried, 120, 'reduce_curried returns expected value' ); like( exception { $obj->reduce_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to reduce_curried' ); $obj->_values( [ 1 .. 6 ] ); my $it = $obj->natatime(2); my @nat; while ( my @v = $it->() ) { push @nat, \@v; } is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime returns expected iterator' ) or diag(explain(\@nat)); @nat = (); $obj->natatime( 2, sub { push @nat, [@_] } ); is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime with function returns expected value' ); like( exception { $obj->natatime( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non integer to natatime' ); like( exception { $obj->natatime( 2, {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non code ref to natatime' ); $it = $obj->natatime_curried(); @nat = (); while ( my @v = $it->() ) { push @nat, \@v; } is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime_curried returns expected iterator' ); @nat = (); $obj->natatime_curried( sub { push @nat, [@_] } ); is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime_curried with function returns expected value' ); like( exception { $obj->natatime_curried( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non code ref to natatime_curried' ); if ( $class->meta->get_attribute('_values')->is_lazy ) { my $obj = $class->new; is( $obj->count, 2, 'count is 2 (lazy init)' ); $obj->_clear_values; is_deeply( [ $obj->elements ], [ 42, 84 ], 'elements contains default with lazy init' ); $obj->_clear_values; $obj->push(2); is_deeply( $obj->_values, [ 42, 84, 2 ], 'push works with lazy init' ); $obj->_clear_values; $obj->unshift( 3, 4 ); is_deeply( $obj->_values, [ 3, 4, 42, 84 ], 'unshift works with lazy init' ); } # } # $class; } done_testing; trait_bool.t000664001750001750 550614772476615 17421 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/06mouseuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Mouse' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my %handles = ( illuminate => 'set', darken => 'unset', flip_switch => 'toggle', is_dark => 'not', ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Bool'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Mouse; use Sub::HandlesVia; use Types::Standard qw(Bool); has is_lit => ( traits => [\@traits], is => 'rw', isa => Bool, default => 1, handles => \\%handles_copy, clearer => '_clear_is_lit', %attr, ); 1; } or die($@); return ( $class, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); run_tests( build_class( isa => Types::Standard::Bool()->where(sub {1}) ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new; ok( $obj->illuminate, 'set returns true' ); ok( $obj->is_lit, 'set is_lit to 1 using ->illuminate' ); ok( !$obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->illuminate(1) }, qr/number of parameters/, 'set throws an error when an argument is passed' ); ok( !$obj->darken, 'unset returns false' ); ok( !$obj->is_lit, 'set is_lit to 0 using ->darken' ); ok( $obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->darken(1) }, qr/number of parameters/, 'unset throws an error when an argument is passed' ); ok( $obj->flip_switch, 'toggle returns new value' ); ok( $obj->is_lit, 'toggle is_lit back to 1 using ->flip_switch' ); ok( !$obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->flip_switch(1) }, qr/number of parameters/, 'toggle throws an error when an argument is passed' ); $obj->flip_switch; ok( !$obj->is_lit, 'toggle is_lit back to 0 again using ->flip_switch' ); ok( $obj->is_dark, 'check if is_dark does the right thing' ); # } # $class; } done_testing; trait_code.t000664001750001750 561414772476615 17400 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/06mouseuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Mouse' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my $name = 'Foo1'; sub build_class { my ( $attr1, $attr2, $attr3, $no_inline ) = @_; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Code'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Mouse; use Sub::HandlesVia; use Types::Standard qw(CodeRef); has( callback => ( is => 'bare', handles_via => [\@traits], isa => CodeRef, required => 1, handles => { 'invoke_callback' => 'execute' }, %{ \$attr1 || {} }, ) ); has( callback_method => ( is => 'bare', handles_via => [\@traits], isa => CodeRef, required => 1, handles => { 'invoke_method_callback' => 'execute_method' }, %{ \$attr2 || {} }, ) ); has( multiplier => ( is => 'bare', handles_via => [\@traits], isa => CodeRef, required => 1, handles => { 'multiply' => 'execute' }, %{ \$attr3 || {} }, ) ); 1; } or die($@); return $class; } } { my $i; my %subs = ( callback => sub { ++$i }, callback_method => sub { shift->multiply(@_) }, multiplier => sub { $_[0] * 2 }, ); run_tests( build_class, \$i, \%subs ); run_tests( build_class( undef, undef, undef, 1 ), \$i, \%subs ); run_tests( build_class( { lazy => 1, default => sub { $subs{callback} } }, { lazy => 1, default => sub { $subs{callback_method} } }, { lazy => 1, default => sub { $subs{multiplier} } }, ), \$i, ); } sub run_tests { my ( $class, $iref, @args ) = @_; note "Testing class $class"; ok( !$class->can($_), "Code trait didn't create reader method for $_" ) for qw(callback callback_method multiplier); # with_immutable { ${$iref} = 0; my $obj = $class->new(@args); $obj->invoke_callback; is( ${$iref}, 1, '$i is 1 after invoke_callback' ); is( $obj->invoke_method_callback(3), 6, 'invoke_method_callback calls multiply with @_' ); is( $obj->multiply(3), 6, 'multiple double value' ); # } # $class; } done_testing; trait_counter.t000664001750001750 1122314772476615 20156 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/06mouseuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Mouse' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; use Types::Standard (); { my %handles = ( inc_counter => 'inc', inc_counter_2 => [ inc => 2 ], dec_counter => 'dec', dec_counter_2 => [ dec => 2 ], reset_counter => 'reset', set_counter => 'set', set_counter_42 => [ set => 42 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Counter'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Mouse; use Sub::HandlesVia; use Types::Standard qw(Int); has counter => ( traits => [\@traits], is => 'rw', isa => Int, default => 0, handles => \\%handles_copy, clearer => '_clear_counter', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); run_tests( build_class( isa => Types::Standard::Int()->where(sub {1}) ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new(); is( $obj->counter, 0, '... got the default value' ); is( $obj->inc_counter, 1, 'inc returns new value' ); is( $obj->counter, 1, '... got the incremented value' ); is( $obj->inc_counter, 2, 'inc returns new value' ); is( $obj->counter, 2, '... got the incremented value (again)' ); like( exception { $obj->inc_counter( 1, 2 ) }, qr/number of parameters/, 'inc throws an error when two arguments are passed' ); is( $obj->dec_counter, 1, 'dec returns new value' ); is( $obj->counter, 1, '... got the decremented value' ); like( exception { $obj->dec_counter( 1, 2 ) }, qr/number of parameters/, 'dec throws an error when two arguments are passed' ); is( $obj->reset_counter, 0, 'reset returns new value' ); is( $obj->counter, 0, '... got the original value' ); like( exception { $obj->reset_counter(2) }, qr/number of parameters/, 'reset throws an error when an argument is passed' ); is( $obj->set_counter(5), 5, 'set returns new value' ); is( $obj->counter, 5, '... set the value' ); like( exception { $obj->set_counter( 1, 2 ) }, qr/number of parameters/, 'set throws an error when two arguments are passed' ); $obj->inc_counter(2); is( $obj->counter, 7, '... increment by arg' ); $obj->dec_counter(5); is( $obj->counter, 2, '... decrement by arg' ); $obj->inc_counter_2; is( $obj->counter, 4, '... curried increment' ); $obj->dec_counter_2; is( $obj->counter, 2, '... curried deccrement' ); $obj->set_counter_42; is( $obj->counter, 42, '... curried set' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->inc_counter; is( $obj->counter, 1, 'inc increments - with lazy default' ); $obj->_clear_counter; $obj->dec_counter; is( $obj->counter, -1, 'dec decrements - with lazy default' ); } } # $class; #} { package WithBuilder; use Mouse; use Sub::HandlesVia; use Types::Standard 'Int'; has nonlazy => ( traits => ['Counter'], is => 'rw', isa => Int, builder => '_builder', handles => { reset_nonlazy => 'reset', }, ); has lazy => ( traits => ['Counter'], is => 'rw', isa => Int, lazy => 1, builder => '_builder', handles => { reset_lazy => 'reset', }, ); sub _builder { 1 } } for my $attr ('lazy', 'nonlazy') { my $obj = WithBuilder->new; is($obj->$attr, 1, "built properly"); $obj->$attr(0); is($obj->$attr, 0, "can be manually set"); $obj->${\"reset_$attr"}; is($obj->$attr, 1, "reset resets it to its default value"); } done_testing; trait_hash.t000664001750001750 2203614772476615 17426 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/06mouseuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Mouse' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my %handles = ( option_accessor => 'accessor', quantity => [ accessor => 'quantity' ], clear_options => 'clear', num_options => 'count', delete_option => 'delete', is_defined => 'defined', options_elements => 'elements', has_option => 'exists', get_option => 'get', has_no_options => 'is_empty', keys => 'keys', values => 'values', key_value => 'kv', set_option => 'set', ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Hash'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Mouse; use Sub::HandlesVia; use Types::Standard qw(HashRef Str); has options => ( traits => [\@traits], is => 'rw', isa => HashRef[Str], default => sub { {} }, handles => \\%handles_copy, clearer => '_clear_options', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } use Types::Standard qw( HashRef Str ); { run_tests(build_class); run_tests( build_class( lazy => 1, default => sub { { x => 1 } } ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); run_tests( build_class( isa => HashRef->of(Str)->where(sub {1}) ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new( options => {} ); ok( $obj->has_no_options, '... we have no options' ); is( $obj->num_options, 0, '... we have no options' ); is_deeply( $obj->options, {}, '... no options yet' ); ok( !$obj->has_option('foo'), '... we have no foo option' ); is( exception { is( $obj->set_option( foo => 'bar' ), 'bar', 'set return single new value in scalar context' ); }, undef, '... set the option okay' ); like( exception { $obj->set_option( foo => 'bar', 'baz' ) }, qr/number of parameters/, 'exception with odd number of arguments' ); like( exception { $obj->set_option( undef, 'bar' ) }, qr/did not pass type constraint/, 'exception when using undef as a key' ); ok( $obj->is_defined('foo'), '... foo is defined' ); ok( !$obj->has_no_options, '... we have options' ); is( $obj->num_options, 1, '... we have 1 option(s)' ); ok( $obj->has_option('foo'), '... we have a foo option' ); is_deeply( $obj->options, { foo => 'bar' }, '... got options now' ); is( exception { $obj->set_option( bar => 'baz' ); }, undef, '... set the option okay' ); is( $obj->num_options, 2, '... we have 2 option(s)' ); is_deeply( $obj->options, { foo => 'bar', bar => 'baz' }, '... got more options now' ); is( $obj->get_option('foo'), 'bar', '... got the right option' ); is_deeply( [ $obj->get_option(qw(foo bar)) ], [qw(bar baz)], "get multiple options at once" ); is( scalar( $obj->get_option(qw( foo bar)) ), "baz", '... got last option in scalar context' ); is( exception { $obj->set_option( oink => "blah", xxy => "flop" ); }, undef, '... set the option okay' ); is( $obj->num_options, 4, "4 options" ); is_deeply( [ $obj->get_option(qw(foo bar oink xxy)) ], [qw(bar baz blah flop)], "get multiple options at once" ); is( exception { is( scalar $obj->delete_option('bar'), 'baz', 'delete returns deleted value' ); }, undef, '... deleted the option okay' ); is( exception { is_deeply( [ $obj->delete_option( 'oink', 'xxy' ) ], [ 'blah', 'flop' ], 'delete returns all deleted values in list context' ); }, undef, '... deleted multiple option okay' ); is( $obj->num_options, 1, '... we have 1 option(s)' ); is_deeply( $obj->options, { foo => 'bar' }, '... got more options now' ); $obj->clear_options; is_deeply( $obj->options, {}, "... cleared options" ); is( exception { $obj->quantity(4); }, undef, '... options added okay with defaults' ); is( $obj->quantity, 4, 'reader part of curried accessor works' ); is( $obj->option_accessor('quantity'), 4, 'accessor as reader' ); is_deeply( $obj->options, { quantity => 4 }, '... returns what we expect' ); $obj->option_accessor( size => 42 ); like( exception { $obj->option_accessor; }, qr/number of parameters/, 'error when calling accessor with no arguments' ); like( exception { $obj->option_accessor( undef, 'bar' ) }, qr/did not pass type constraint/, 'exception when using undef as a key' ); is_deeply( $obj->options, { quantity => 4, size => 42 }, 'accessor as writer' ); is( exception { $class->new( options => { foo => 'BAR' } ); }, undef, '... good constructor params' ); isnt( exception { $obj->set_option( bar => {} ); }, undef, '... could not add a hash ref where an string is expected' ); isnt( exception { $class->new( options => { foo => [] } ); }, undef, '... bad constructor params' ); $obj->options( {} ); is_deeply( [ $obj->set_option( oink => "blah", xxy => "flop" ) ], [ 'blah', 'flop' ], 'set returns newly set values in order of keys provided' ); is_deeply( [ sort $obj->keys ], [ 'oink', 'xxy' ], 'keys returns expected keys' ); is_deeply( [ sort $obj->values ], [ 'blah', 'flop' ], 'values returns expected values' ); my @key_value = sort { $a->[0] cmp $b->[0] } $obj->key_value; is_deeply( \@key_value, [ sort { $a->[0] cmp $b->[0] }[ 'xxy', 'flop' ], [ 'oink', 'blah' ] ], '... got the right key value pairs' ) or do { require Data::Dumper; diag( Data::Dumper::Dumper( \@key_value ) ); }; my %options_elements = $obj->options_elements; is_deeply( \%options_elements, { 'oink' => 'blah', 'xxy' => 'flop' }, '... got the right hash elements' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->set_option( y => 2 ); is_deeply( $obj->options, { x => 1, y => 2 }, 'set_option with lazy default' ); $obj->_clear_options; ok( $obj->has_option('x'), 'key for x exists - lazy default' ); $obj->_clear_options; ok( $obj->is_defined('x'), 'key for x is defined - lazy default' ); $obj->_clear_options; is_deeply( [ $obj->key_value ], [ [ x => 1 ] ], 'kv returns lazy default' ); $obj->_clear_options; $obj->option_accessor( y => 2 ); is_deeply( [ sort $obj->keys ], [ 'x', 'y' ], 'accessor triggers lazy default generator' ); } # } # $class; } { my ( $class, $handles ) = build_class( isa => HashRef ); my $obj = $class->new; # with_immutable { is( exception { $obj->option_accessor( 'foo', undef ) }, undef, 'can use accessor to set value to undef' ); is( exception { $obj->quantity(undef) }, undef, 'can use accessor to set value to undef' ); # } # $class; } done_testing; trait_number.t000664001750001750 1023714772476615 17773 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/06mouseuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Mouse' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my %handles = ( abs => 'abs', add => 'add', inc => [ add => 1 ], div => 'div', cut_in_half => [ div => 2 ], mod => 'mod', odd => [ mod => 2 ], mul => 'mul', set => 'set', sub => 'sub', dec => [ sub => 1 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Number'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Mouse; use Sub::HandlesVia; use Types::Standard qw(Int); has integer => ( traits => [\@traits], is => 'rw', isa => Int, default => 5, handles => \\%handles_copy, clearer => '_clear_integer', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); run_tests( build_class( isa => Types::Standard::Num()->where(sub {1}) ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new; is( $obj->integer, 5, 'Default to five' ); is( $obj->add(10), 15, 'add returns new value' ); is( $obj->integer, 15, 'Add ten for fithteen' ); like( exception { $obj->add( 10, 2 ) }, qr/number of parameters/, 'add throws an error when 2 arguments are passed' ); is( $obj->sub(3), 12, 'sub returns new value' ); is( $obj->integer, 12, 'Subtract three for 12' ); like( exception { $obj->sub( 10, 2 ) }, qr/number of parameters/, 'sub throws an error when 2 arguments are passed' ); is( $obj->set(10), 10, 'set returns new value' ); is( $obj->integer, 10, 'Set to ten' ); like( exception { $obj->set( 10, 2 ) }, qr/number of parameters/, 'set throws an error when 2 arguments are passed' ); is( $obj->div(2), 5, 'div returns new value' ); is( $obj->integer, 5, 'divide by 2' ); like( exception { $obj->div( 10, 2 ) }, qr/number of parameters/, 'div throws an error when 2 arguments are passed' ); is( $obj->mul(2), 10, 'mul returns new value' ); is( $obj->integer, 10, 'multiplied by 2' ); like( exception { $obj->mul( 10, 2 ) }, qr/number of parameters/, 'mul throws an error when 2 arguments are passed' ); is( $obj->mod(2), 0, 'mod returns new value' ); is( $obj->integer, 0, 'Mod by 2' ); like( exception { $obj->mod( 10, 2 ) }, qr/number of parameters/, 'mod throws an error when 2 arguments are passed' ); $obj->set(7); $obj->mod(5); is( $obj->integer, 2, 'Mod by 5' ); $obj->set(-1); is( $obj->abs, 1, 'abs returns new value' ); like( exception { $obj->abs(10) }, qr/number of parameters/, 'abs throws an error when an argument is passed' ); is( $obj->integer, 1, 'abs 1' ); $obj->set(12); $obj->inc; is( $obj->integer, 13, 'inc 12' ); $obj->dec; is( $obj->integer, 12, 'dec 13' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->add(2); is( $obj->integer, 7, 'add with lazy default' ); $obj->_clear_integer; $obj->mod(2); is( $obj->integer, 1, 'mod with lazy default' ); } # } # $class; } done_testing; trait_string.t000664001750001750 2277614772476615 20024 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/06mouseuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Mouse' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my %handles = ( inc => 'inc', append => 'append', append_curried => [ append => '!' ], prepend => 'prepend', prepend_curried => [ prepend => '-' ], replace => 'replace', replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ], chop => 'chop', chomp => 'chomp', clear => 'clear', match => 'match', match_curried => [ match => qr/\D/ ], length => 'length', substr => 'substr', substr_curried_1 => [ substr => (1) ], substr_curried_2 => [ substr => ( 1, 3 ) ], substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'String'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Mouse; use Sub::HandlesVia; use Types::Standard qw(Str); has _string => ( traits => [\@traits], is => 'rw', isa => Str, default => q{}, handles => \\%handles_copy, clearer => '_clear_string', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1, default => q{} ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); run_tests( build_class( isa => Types::Standard::Str()->where(sub {1}) ) ); # coerce 'MyStr', from 'Str', via { $_ }; # # run_tests( build_class( isa => 'MyStr', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new(); is( $obj->length, 0, 'length returns zero' ); $obj->_string('a'); is( $obj->length, 1, 'length returns 1 for new string' ); like( exception { $obj->length(42) }, qr/number of parameters/, 'length throws an error when an argument is passed' ); is( $obj->inc, 'b', 'inc returns new value' ); is( $obj->_string, 'b', 'a becomes b after inc' ); like( exception { $obj->inc(42) }, qr/number of parameters/, 'inc throws an error when an argument is passed' ); is( $obj->append('foo'), 'bfoo', 'append returns new value' ); is( $obj->_string, 'bfoo', 'appended to the string' ); like( exception { $obj->append( 'foo', 2 ) }, qr/number of parameters/, 'append throws an error when two arguments are passed' ); $obj->append_curried; is( $obj->_string, 'bfoo!', 'append_curried appended to the string' ); like( exception { $obj->append_curried('foo') }, qr/number of parameters/, 'append_curried throws an error when two arguments are passed' ); $obj->_string("has nl$/"); is( $obj->chomp, 1, 'chomp returns number of characters removed' ); is( $obj->_string, 'has nl', 'chomped string' ); is( $obj->chomp, 0, 'chomp returns number of characters removed' ); is( $obj->_string, 'has nl', 'chomp is a no-op when string has no line ending' ); like( exception { $obj->chomp(42) }, qr/number of parameters/, 'chomp throws an error when an argument is passed' ); is( $obj->chop, 'l', 'chop returns character removed' ); is( $obj->_string, 'has n', 'chopped string' ); like( exception { $obj->chop(42) }, qr/number of parameters/, 'chop throws an error when an argument is passed' ); $obj->_string('x'); is( $obj->prepend('bar'), 'barx', 'prepend returns new value' ); is( $obj->_string, 'barx', 'prepended to string' ); $obj->prepend_curried; is( $obj->_string, '-barx', 'prepend_curried prepended to string' ); is( $obj->replace( qr/([ao])/, sub { uc($1) } ), '-bArx', 'replace returns new value' ); is( $obj->_string, '-bArx', 'substitution using coderef for replacement' ); $obj->replace( qr/A/, 'X' ); is( $obj->_string, '-bXrx', 'substitution using string as replacement' ); $obj->_string('foo'); $obj->replace( qr/oo/, q{} ); is( $obj->_string, 'f', 'replace accepts an empty string as second argument' ); $obj->replace( q{}, 'a' ); is( $obj->_string, 'af', 'replace accepts an empty string as first argument' ); like( exception { $obj->replace( {}, 'x' ) }, qr/did not pass type constraint/, 'replace throws an error when the first argument is not a string or regexp' ); like( exception { $obj->replace( qr/x/, {} ) }, qr/did not pass type constraint/, 'replace throws an error when the first argument is not a string or regexp' ); $obj->_string('Moosex'); $obj->replace_curried; is( $obj->_string, 'MooseX', 'capitalize last' ); $obj->_string('abcdef'); is_deeply( [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ], 'match -barx against /[aq]/ returns matches' ); is_deeply( [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ], 'match -barx against /[aq]/ returns matches' ); ok( scalar $obj->match('b'), 'match with string as argument returns true' ); ok( scalar $obj->match(q{}), 'match with empty string as argument returns true' ); like( exception { $obj->match }, qr/number of parameters/, 'match throws an error when no arguments are passed' ); like( exception { $obj->match( {} ) }, qr/did not pass type constraint/, 'match throws an error when an invalid argument is passed' ); $obj->_string('1234'); ok( !$obj->match_curried, 'match_curried returns false' ); $obj->_string('one two three four'); ok( $obj->match_curried, 'match curried returns true' ); $obj->clear; is( $obj->_string, q{}, 'clear' ); like( exception { $obj->clear(42) }, qr/number of parameters/, 'clear throws an error when an argument is passed' ); $obj->_string('some long string'); is( $obj->substr(1), 'ome long string', 'substr as getter with one argument' ); $obj->_string('some long string'); is( $obj->substr( 1, 3 ), 'ome', 'substr as getter with two arguments' ); is( $obj->substr( 1, 3, 'ong' ), 'ome', 'substr as setter returns replaced string' ); is( $obj->_string, 'song long string', 'substr as setter with three arguments' ); $obj->substr( 1, 3, '' ); is( $obj->_string, 's long string', 'substr as setter with three arguments, replacment is empty string' ); like( exception { $obj->substr }, qr/number of parameters/, 'substr throws an error when no argumemts are passed' ); like( exception { $obj->substr( 1, 2, 3, 4 ) }, qr/number of parameters/, 'substr throws an error when four argumemts are passed' ); like( exception { $obj->substr( {} ) }, qr/did not pass type constraint/, 'substr throws an error when first argument is not an integer' ); like( exception { $obj->substr( 1, {} ) }, qr/did not pass type constraint/, 'substr throws an error when second argument is not an integer' ); like( exception { $obj->substr( 1, 2, {} ) }, qr/did not pass type constraint/, 'substr throws an error when third argument is not a string' ); $obj->_string('some long string'); is( $obj->substr_curried_1, 'ome long string', 'substr_curried_1 returns expected value' ); is( $obj->substr_curried_1(3), 'ome', 'substr_curried_1 with one argument returns expected value' ); $obj->substr_curried_1( 3, 'ong' ); is( $obj->_string, 'song long string', 'substr_curried_1 as setter with two arguments' ); $obj->_string('some long string'); is( $obj->substr_curried_2, 'ome', 'substr_curried_2 returns expected value' ); $obj->substr_curried_2('ong'); is( $obj->_string, 'song long string', 'substr_curried_2 as setter with one arguments' ); $obj->_string('some long string'); $obj->substr_curried_3; is( $obj->_string, 'song long string', 'substr_curried_3 as setter' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->append('foo'); is( $obj->_string, 'foo', 'append with lazy default' ); } # } # $class; } done_testing; role.t000664001750001750 153714772476615 20660 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/07mouse_nativetypesuse strict; use warnings; use Test::More; use Test::Fatal; { package Local::Dummy1; use Test::Requires 'Mouse' }; { package Local::Role1; use Mouse::Role; use Sub::HandlesVia; has nums => ( is => 'ro', isa => 'ArrayRef[Int]', builder => '_build_nums', handles_via => 'Array', handles => { pop_num => 'pop', push_num => 'push' }, ); sub _build_nums { [ 1..10 ] } } { package Local::Class1; use Mouse; with 'Local::Role1'; } #require B::Deparse; #::note( B::Deparse->new->coderef2text(\&Local::Class1::pop_num) ); my $obj = Local::Class1->new; is( $obj->pop_num, 10 ); is( $obj->pop_num, 9 ); is( $obj->pop_num, 8 ); is( $obj->pop_num, 7 ); isnt( exception { $obj->push_num(44.5) }, undef, ); is( $obj->pop_num, 6 ); is( exception { $obj->push_num(6) }, undef, ); is( $obj->pop_num, 6 ); done_testing; trait_array.t000664001750001750 6356614772476615 22272 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/07mouse_nativetypesuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Mouse' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; BEGIN { require Mouse::Util; Mouse::Util::MOUSE_XS() or plan skip_all => 'https://github.com/xslate/p5-Mouse/issues/106'; }; { my %handles = ( count => 'count', elements => 'elements', is_empty => 'is_empty', push => 'push', push_curried => [ push => 42, 84 ], unshift => 'unshift', unshift_curried => [ unshift => 42, 84 ], pop => 'pop', shift => 'shift', get => 'get', get_curried => [ get => 1 ], set => 'set', set_curried_1 => [ set => 1 ], set_curried_2 => [ set => ( 1, 98 ) ], accessor => 'accessor', accessor_curried_1 => [ accessor => 1 ], accessor_curried_2 => [ accessor => ( 1, 90 ) ], clear => 'clear', delete => 'delete', delete_curried => [ delete => 1 ], insert => 'insert', insert_curried => [ insert => ( 1, 101 ) ], splice => 'splice', splice_curried_1 => [ splice => 1 ], splice_curried_2 => [ splice => 1, 2 ], splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ], sort => 'sort', sort_curried => [ sort => ( sub { $_[1] <=> $_[0] } ) ], sort_in_place => 'sort_in_place', sort_in_place_curried => [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ], map => 'map', map_curried => [ map => ( sub { $_ + 1 } ) ], grep => 'grep', grep_curried => [ grep => ( sub { $_ < 5 } ) ], first => 'first', first_curried => [ first => ( sub { $_ % 2 } ) ], first_index => 'first_index', first_index_curried => [ first_index => ( sub { $_ % 2 } ) ], join => 'join', join_curried => [ join => '-' ], shuffle => 'shuffle', uniq => 'uniq', reduce => 'reduce', reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ], natatime => 'natatime', natatime_curried => [ natatime => 2 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Array'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Mouse; use Sub::HandlesVia; has _values => ( traits => [\@traits], is => 'rw', isa => 'ArrayRef[Int]', default => sub { [] }, handles => \\%handles_copy, clearer => '_clear_values', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { package Overloader; use overload '&{}' => sub { ${ $_[0] } }, bool => sub {1}; sub new { bless \$_[1], $_[0]; } } { package OverloadStr; use overload q{""} => sub { ${ $_[0] } }, fallback => 1; sub new { my $class = shift; my $str = shift; return bless \$str, $class; } } { package OverloadNum; use overload q{0+} => sub { ${ $_[0] } }, fallback => 1; sub new { my $class = shift; my $str = shift; return bless \$str, $class; } } { use Mouse::Util::TypeConstraints; subtest( 'simple case', sub { run_tests(build_class) } ); subtest( 'lazy default attr', sub { run_tests( build_class( lazy => 1, default => sub { [ 42, 84 ] } ) ); } ); subtest( 'attr with trigger', sub { run_tests( build_class( trigger => sub { } ) ); } ); subtest( 'attr is not inlined', sub { run_tests( build_class( no_inline => 1 ) ) } ); type 'MyArray', as 'ArrayRef', where { 1 }; subtest( 'attr type forces the inlining code to check the entire arrayref when it is modified', sub { run_tests( build_class( isa => 'MyArray') ); } ); coerce 'MyArray', from 'ArrayRef', via { $_ }; subtest( 'attr type has coercion', sub { run_tests( build_class( isa => 'MyArray', coerce => 1 ) ); } ); } subtest( 'setting value to undef with accessor', sub { my ( $class, $handles ) = build_class( isa => 'ArrayRef' ); note "Testing class $class"; my $obj = $class->new; # with_immutable { is( exception { $obj->accessor( 0, undef ) }, undef, 'can use accessor to set value to undef' ); is( exception { $obj->accessor_curried_1(undef) }, undef, 'can use curried accessor to set value to undef' ); # } # $class; } ); sub run_tests { my ( $class, $handles ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new( _values => [ 10, 12, 42 ] ); is_deeply( $obj->_values, [ 10, 12, 42 ], 'values can be set in constructor' ); ok( !$obj->is_empty, 'values is not empty' ); is( $obj->count, 3, 'count returns 3' ); like( exception { $obj->count(22) }, qr/number of parameters/, 'throws an error when passing an argument passed to count' ); is( exception { $obj->push( 1, 2, 3 ) }, undef, 'pushed three new values and lived' ); is( exception { $obj->push() }, undef, 'call to push without arguments lives' ); is( exception { is( $obj->unshift( 101, 22 ), 8, 'unshift returns size of the new array' ); }, undef, 'unshifted two values and lived' ); is_deeply( $obj->_values, [ 101, 22, 10, 12, 42, 1, 2, 3 ], 'unshift changed the value of the array in the object' ); is( exception { $obj->unshift() }, undef, 'call to unshift without arguments lives' ); is( $obj->pop, 3, 'pop returns the last value in the array' ); is_deeply( $obj->_values, [ 101, 22, 10, 12, 42, 1, 2 ], 'pop changed the value of the array in the object' ); like( exception { $obj->pop(42) }, qr/number of parameters/, 'call to pop with arguments dies' ); is( $obj->shift, 101, 'shift returns the first value' ); like( exception { $obj->shift(42) }, qr/number of parameters/, 'call to shift with arguments dies' ); is_deeply( $obj->_values, [ 22, 10, 12, 42, 1, 2 ], 'shift changed the value of the array in the object' ); is_deeply( [ $obj->elements ], [ 22, 10, 12, 42, 1, 2 ], 'call to elements returns values as a list' ); is(scalar($obj->elements), 6, 'elements accessor in scalar context returns the number of elements in the list'); like( exception { $obj->elements(22) }, qr/number of parameters/, 'throws an error when passing an argument passed to elements' ); $obj->_values( [ 1, 2, 3 ] ); is( $obj->get(0), 1, 'get values at index 0' ); is( $obj->get(1), 2, 'get values at index 1' ); is( $obj->get(2), 3, 'get values at index 2' ); is( $obj->get_curried, 2, 'get_curried returns value at index 1' ); like( exception { $obj->get() }, qr/number of parameters/, 'throws an error when get is called without any arguments' ); like( exception { $obj->get( {} ) }, qr/did not pass type constraint/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get(2.2) }, qr/did not pass type constraint/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get('foo') }, qr/did not pass type constraint/, 'throws an error when get is called with an invalid argument' ); like( exception { $obj->get_curried(2) }, qr/number of parameters/, 'throws an error when get_curried is called with an argument' ); is( exception { is( $obj->set( 1, 100 ), 100, 'set returns new value' ); }, undef, 'set value at index 1 lives' ); is( $obj->get(1), 100, 'get value at index 1 returns new value' ); like( exception { $obj->set( 1, 99, 42 ) }, qr/number of parameters/, 'throws an error when set is called with three arguments' ); is( exception { $obj->set_curried_1(99) }, undef, 'set_curried_1 lives' ); is( $obj->get(1), 99, 'get value at index 1 returns new value' ); like( exception { $obj->set_curried_1( 99, 42 ) }, qr/number of parameters/, 'throws an error when set_curried_1 is called with two arguments' ); is( exception { $obj->set_curried_2 }, undef, 'set_curried_2 lives' ); is( $obj->get(1), 98, 'get value at index 1 returns new value' ); like( exception { $obj->set_curried_2(42) }, qr/number of parameters/, 'throws an error when set_curried_2 is called with one argument' ); #use B::Deparse; #diag(B::Deparse->new->coderef2text($obj->can('accessor'))); is( $obj->accessor(1), 98, 'accessor with one argument returns value at index 1' ); is( exception { is( $obj->accessor( 1 => 97 ), 97, 'accessor returns new value' ); }, undef, 'accessor as writer lives' ); like( exception { $obj->accessor; }, qr/number of parameters/, 'throws an error when accessor is called without arguments' ); is( $obj->get(1), 97, 'accessor set value at index 1' ); like( exception { $obj->accessor( 1, 96, 42 ) }, qr/number of parameters/, 'throws an error when accessor is called with three arguments' ); is( $obj->accessor_curried_1, 97, 'accessor_curried_1 returns expected value when called with no arguments' ); is( exception { $obj->accessor_curried_1(95) }, undef, 'accessor_curried_1 as writer lives' ); is( $obj->get(1), 95, 'accessor_curried_1 set value at index 1' ); like( exception { $obj->accessor_curried_1( 96, 42 ) }, qr/number of parameters/, 'throws an error when accessor_curried_1 is called with two arguments' ); is( exception { $obj->accessor_curried_2 }, undef, 'accessor_curried_2 as writer lives' ); is( $obj->get(1), 90, 'accessor_curried_2 set value at index 1' ); like( exception { $obj->accessor_curried_2(42) }, qr/number of parameters/, 'throws an error when accessor_curried_2 is called with one argument' ); is( exception { $obj->clear }, undef, 'clear lives' ); ok( $obj->is_empty, 'values is empty after call to clear' ); is( exception { is( $obj->shift, undef, 'shift returns undef on an empty array' ); }, undef, 'shifted from an empty array and lived' ); $obj->set( 0 => 42 ); like( exception { $obj->clear(50) }, qr/number of parameters/, 'throws an error when clear is called with an argument' ); ok( !$obj->is_empty, 'values is not empty after failed call to clear' ); like( exception { $obj->is_empty(50) }, qr/number of parameters/, 'throws an error when is_empty is called with an argument' ); $obj->clear; is( $obj->push( 1, 5, 10, 42 ), 4, 'pushed 4 elements, got number of elements in the array back' ); is( exception { is( $obj->delete(2), 10, 'delete returns deleted value' ); }, undef, 'delete lives' ); is_deeply( $obj->_values, [ 1, 5, 42 ], 'delete removed the specified element' ); like( exception { $obj->delete( 2, 3 ) }, qr/number of parameters/, 'throws an error when delete is called with two arguments' ); is( exception { $obj->delete_curried }, undef, 'delete_curried lives' ); is_deeply( $obj->_values, [ 1, 42 ], 'delete removed the specified element' ); like( exception { $obj->delete_curried(2) }, qr/number of parameters/, 'throws an error when delete_curried is called with one argument' ); is( exception { $obj->insert( 1, 21 ) }, undef, 'insert lives' ); is_deeply( $obj->_values, [ 1, 21, 42 ], 'insert added the specified element' ); like( exception { $obj->insert( 1, 22, 44 ) }, qr/number of parameters/, 'throws an error when insert is called with three arguments' ); is( exception { is_deeply( [ $obj->splice( 1, 0, 2, 3 ) ], [], 'return value of splice is empty list when not removing elements' ); }, undef, 'splice lives' ); is_deeply( $obj->_values, [ 1, 2, 3, 21, 42 ], 'splice added the specified elements' ); is( exception { is_deeply( [ $obj->splice( 1, 2, 99 ) ], [ 2, 3 ], 'splice returns list of removed values' ); }, undef, 'splice lives' ); is_deeply( $obj->_values, [ 1, 99, 21, 42 ], 'splice added the specified elements' ); like( exception { $obj->splice() }, qr/number of parameters/, 'throws an error when splice is called with no arguments' ); like( exception { $obj->splice( 1, 'foo', ) }, qr/did not pass type constraint/, 'throws an error when splice is called with an invalid length' ); is( exception { $obj->splice_curried_1( 2, 101 ) }, undef, 'splice_curried_1 lives' ); is_deeply( $obj->_values, [ 1, 101, 42 ], 'splice added the specified elements' ); is( exception { $obj->splice_curried_2(102) }, undef, 'splice_curried_2 lives' ); is_deeply( $obj->_values, [ 1, 102 ], 'splice added the specified elements' ); is( exception { $obj->splice_curried_all }, undef, 'splice_curried_all lives' ); is_deeply( $obj->_values, [ 1, 3, 4, 5 ], 'splice added the specified elements' ); is_deeply( scalar $obj->splice( 1, 2 ), 4, 'splice in scalar context returns last element removed' ); is_deeply( scalar $obj->splice( 1, 0, 42 ), undef, 'splice in scalar context returns undef when no elements are removed' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); is_deeply( [ $obj->sort ], [ 11, 22, 3, 5, 9 ], 'sort returns sorted values' ); is(scalar($obj->sort), 5, 'sort accessor in scalar context returns the number of elements in the list'); is_deeply( [ $obj->sort( sub { $_[0] <=> $_[1] } ) ], [ 3, 5, 9, 11, 22 ], 'sort returns values sorted by provided function' ); is(scalar($obj->sort( sub { $_[0] <=> $_[1] } )), 5, 'sort accessor with sort sub in scalar context returns the number of elements in the list'); like( exception { $obj->sort(1) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to sort' ); like( exception { $obj->sort( sub { }, 27 ); }, qr/number of parameters/, 'throws an error when passing two arguments to sort' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); $obj->sort_in_place; is_deeply( $obj->_values, [ 11, 22, 3, 5, 9 ], 'sort_in_place sorts values' ); $obj->sort_in_place( sub { $_[0] <=> $_[1] } ); is_deeply( $obj->_values, [ 3, 5, 9, 11, 22 ], 'sort_in_place with function sorts values' ); like( exception { $obj->sort_in_place( 27 ); }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to sort_in_place' ); like( exception { $obj->sort_in_place( sub { }, 27 ); }, qr/number of parameters/, 'throws an error when passing two arguments to sort_in_place' ); $obj->_values( [ 3, 9, 5, 22, 11 ] ); $obj->sort_in_place_curried; is_deeply( $obj->_values, [ 22, 11, 9, 5, 3 ], 'sort_in_place_curried sorts values' ); like( exception { $obj->sort_in_place_curried(27) }, qr/number of parameters/, 'throws an error when passing one argument passed to sort_in_place_curried' ); $obj->_values( [ 1 .. 5 ] ); is_deeply( [ $obj->map( sub { $_ + 1 } ) ], [ 2 .. 6 ], 'map returns the expected values' ); like( exception { $obj->map }, qr/number of parameters/, 'throws an error when passing no arguments to map' ); like( exception { $obj->map( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to map' ); like( exception { $obj->map( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to map' ); $obj->_values( [ 1 .. 5 ] ); is_deeply( [ $obj->map_curried ], [ 2 .. 6 ], 'map_curried returns the expected values' ); like( exception { $obj->map_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to map_curried' ); $obj->_values( [ 2 .. 9 ] ); is_deeply( [ $obj->grep( sub { $_ < 5 } ) ], [ 2 .. 4 ], 'grep returns the expected values' ); like( exception { $obj->grep }, qr/number of parameters/, 'throws an error when passing no arguments to grep' ); like( exception { $obj->grep( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to grep' ); like( exception { $obj->grep( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to grep' ); # my $overloader = Overloader->new( sub { $_ < 5 } ); # is_deeply( # [ $obj->grep($overloader) ], # [ 2 .. 4 ], # 'grep works with obj that overload code dereferencing' # ); is_deeply( [ $obj->grep_curried ], [ 2 .. 4 ], 'grep_curried returns the expected values' ); like( exception { $obj->grep_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to grep_curried' ); $obj->_values( [ 2, 4, 22, 99, 101, 6 ] ); is( $obj->first( sub { $_ % 2 } ), 99, 'first returns expected value' ); like( exception { $obj->first }, qr/number of parameters/, 'throws an error when passing no arguments to first' ); like( exception { $obj->first( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to first' ); like( exception { $obj->first( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to first' ); is( $obj->first_curried, 99, 'first_curried returns expected value' ); like( exception { $obj->first_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to first_curried' ); is( $obj->first_index( sub { $_ % 2 } ), 3, 'first_index returns expected value' ); like( exception { $obj->first_index }, qr/number of parameters/, 'throws an error when passing no arguments to first_index' ); like( exception { $obj->first_index( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to first_index' ); like( exception { $obj->first_index( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to first_index' ); is( $obj->first_index_curried, 3, 'first_index_curried returns expected value' ); like( exception { $obj->first_index_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to first_index_curried' ); $obj->_values( [ 1 .. 4 ] ); is( $obj->join('-'), '1-2-3-4', 'join returns expected result' ); is( $obj->join(q{}), '1234', 'join returns expected result when joining with empty string' ); is( $obj->join(0), '1020304', 'join returns expected result when joining with 0 as number' ); is( $obj->join("0"), '1020304', 'join returns expected result when joining with 0 as string' ); # is( # $obj->join( OverloadStr->new(q{}) ), '1234', # 'join returns expected result when joining with object with string overload' # ); # # is( # $obj->join( OverloadNum->new(0) ), '1020304', # 'join returns expected result when joining with object with numify overload' # ); # like( exception { $obj->join }, qr/number of parameters/, 'throws an error when passing no arguments to join' ); like( exception { $obj->join( '-', 2 ) }, qr/number of parameters/, 'throws an error when passing two arguments to join' ); like( exception { $obj->join( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non string to join' ); is_deeply( [ sort $obj->shuffle ], [ 1 .. 4 ], 'shuffle returns all values (cannot check for a random order)' ); like( exception { $obj->shuffle(2) }, qr/number of parameters/, 'throws an error when passing an argument passed to shuffle' ); $obj->_values( [ 1 .. 4, 2, 5, 3, 7, 3, 3, 1 ] ); is_deeply( [ $obj->uniq ], [ 1 .. 4, 5, 7 ], 'uniq returns expected values (in original order)' ); like( exception { $obj->uniq(2) }, qr/number of parameters/, 'throws an error when passing an argument passed to uniq' ); $obj->_values( [ 1 .. 5 ] ); is( $obj->reduce( sub { $_[0] * $_[1] } ), 120, 'reduce returns expected value' ); like( exception { $obj->reduce }, qr/number of parameters/, 'throws an error when passing no arguments to reduce' ); like( exception { $obj->reduce( sub { }, 2 ); }, qr/number of parameters/, 'throws an error when passing two arguments to reduce' ); like( exception { $obj->reduce( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non coderef to reduce' ); is( $obj->reduce_curried, 120, 'reduce_curried returns expected value' ); like( exception { $obj->reduce_curried( sub { } ); }, qr/number of parameters/, 'throws an error when passing one argument passed to reduce_curried' ); $obj->_values( [ 1 .. 6 ] ); my $it = $obj->natatime(2); my @nat; while ( my @v = $it->() ) { push @nat, \@v; } is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime returns expected iterator' ) or diag(explain(\@nat)); @nat = (); $obj->natatime( 2, sub { push @nat, [@_] } ); is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime with function returns expected value' ); like( exception { $obj->natatime( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non integer to natatime' ); like( exception { $obj->natatime( 2, {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non code ref to natatime' ); $it = $obj->natatime_curried(); @nat = (); while ( my @v = $it->() ) { push @nat, \@v; } is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime_curried returns expected iterator' ); @nat = (); $obj->natatime_curried( sub { push @nat, [@_] } ); is_deeply( [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ], \@nat, 'natatime_curried with function returns expected value' ); like( exception { $obj->natatime_curried( {} ) }, qr/did not pass type constraint/, 'throws an error when passing a non code ref to natatime_curried' ); if ( $class->meta->get_attribute('_values')->is_lazy ) { my $obj = $class->new; is( $obj->count, 2, 'count is 2 (lazy init)' ); $obj->_clear_values; is_deeply( [ $obj->elements ], [ 42, 84 ], 'elements contains default with lazy init' ); $obj->_clear_values; $obj->push(2); is_deeply( $obj->_values, [ 42, 84, 2 ], 'push works with lazy init' ); $obj->_clear_values; $obj->unshift( 3, 4 ); is_deeply( $obj->_values, [ 3, 4, 42, 84 ], 'unshift works with lazy init' ); } # } # $class; } done_testing; trait_bool.t000664001750001750 570114772476615 22052 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/07mouse_nativetypesuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Mouse' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my %handles = ( illuminate => 'set', darken => 'unset', flip_switch => 'toggle', is_dark => 'not', ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Bool'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Mouse; use Sub::HandlesVia; has is_lit => ( traits => [\@traits], is => 'rw', isa => 'Bool', default => 1, handles => \\%handles_copy, clearer => '_clear_is_lit', %attr, ); 1; } or die($@); return ( $class, \%handles ); } } { use Mouse::Util::TypeConstraints; run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); type 'MyBool', as 'Bool', where { 1 }; run_tests( build_class( isa => 'MyBool' ) ); coerce 'MyBool', from 'Bool', via { $_ }; run_tests( build_class( isa => 'MyBool', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new; ok( $obj->illuminate, 'set returns true' ); ok( $obj->is_lit, 'set is_lit to 1 using ->illuminate' ); ok( !$obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->illuminate(1) }, qr/number of parameters/, 'set throws an error when an argument is passed' ); ok( !$obj->darken, 'unset returns false' ); ok( !$obj->is_lit, 'set is_lit to 0 using ->darken' ); ok( $obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->darken(1) }, qr/number of parameters/, 'unset throws an error when an argument is passed' ); ok( $obj->flip_switch, 'toggle returns new value' ); ok( $obj->is_lit, 'toggle is_lit back to 1 using ->flip_switch' ); ok( !$obj->is_dark, 'check if is_dark does the right thing' ); like( exception { $obj->flip_switch(1) }, qr/number of parameters/, 'toggle throws an error when an argument is passed' ); $obj->flip_switch; ok( !$obj->is_lit, 'toggle is_lit back to 0 again using ->flip_switch' ); ok( $obj->is_dark, 'check if is_dark does the right thing' ); # } # $class; } done_testing; trait_code.t000664001750001750 555514772476615 22040 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/07mouse_nativetypesuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Mouse' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my $name = 'Foo1'; sub build_class { my ( $attr1, $attr2, $attr3, $no_inline ) = @_; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Code'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Mouse; use Sub::HandlesVia; has( callback => ( is => 'bare', handles_via => [\@traits], isa => 'CodeRef', required => 1, handles => { 'invoke_callback' => 'execute' }, %{ \$attr1 || {} }, ) ); has( callback_method => ( is => 'bare', handles_via => [\@traits], isa => 'CodeRef', required => 1, handles => { 'invoke_method_callback' => 'execute_method' }, %{ \$attr2 || {} }, ) ); has( multiplier => ( is => 'bare', handles_via => [\@traits], isa => 'CodeRef', required => 1, handles => { 'multiply' => 'execute' }, %{ \$attr3 || {} }, ) ); 1; } or die($@); return $class; } } { my $i; my %subs = ( callback => sub { ++$i }, callback_method => sub { shift->multiply(@_) }, multiplier => sub { $_[0] * 2 }, ); run_tests( build_class, \$i, \%subs ); run_tests( build_class( undef, undef, undef, 1 ), \$i, \%subs ); run_tests( build_class( { lazy => 1, default => sub { $subs{callback} } }, { lazy => 1, default => sub { $subs{callback_method} } }, { lazy => 1, default => sub { $subs{multiplier} } }, ), \$i, ); } sub run_tests { my ( $class, $iref, @args ) = @_; note "Testing class $class"; ok( !$class->can($_), "Code trait didn't create reader method for $_" ) for qw(callback callback_method multiplier); # with_immutable { ${$iref} = 0; my $obj = $class->new(@args); $obj->invoke_callback; is( ${$iref}, 1, '$i is 1 after invoke_callback' ); is( $obj->invoke_method_callback(3), 6, 'invoke_method_callback calls multiply with @_' ); is( $obj->multiply(3), 6, 'multiple double value' ); # } # $class; } done_testing; trait_counter.t000664001750001750 1133114772476615 22612 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/07mouse_nativetypesuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Mouse' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my %handles = ( inc_counter => 'inc', inc_counter_2 => [ inc => 2 ], dec_counter => 'dec', dec_counter_2 => [ dec => 2 ], reset_counter => 'reset', set_counter => 'set', set_counter_42 => [ set => 42 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Counter'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Mouse; use Sub::HandlesVia; has counter => ( traits => [\@traits], is => 'rw', isa => 'Int', default => 0, handles => \\%handles_copy, clearer => '_clear_counter', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { use Mouse::Util::TypeConstraints; run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); type 'MyNum', as 'Int', where { 1 }; run_tests( build_class( isa => 'MyNum' ) ); coerce 'MyNum', from 'Int', via { $_ }; run_tests( build_class( isa => 'MyNum', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new(); is( $obj->counter, 0, '... got the default value' ); is( $obj->inc_counter, 1, 'inc returns new value' ); is( $obj->counter, 1, '... got the incremented value' ); is( $obj->inc_counter, 2, 'inc returns new value' ); is( $obj->counter, 2, '... got the incremented value (again)' ); like( exception { $obj->inc_counter( 1, 2 ) }, qr/number of parameters/, 'inc throws an error when two arguments are passed' ); is( $obj->dec_counter, 1, 'dec returns new value' ); is( $obj->counter, 1, '... got the decremented value' ); like( exception { $obj->dec_counter( 1, 2 ) }, qr/number of parameters/, 'dec throws an error when two arguments are passed' ); is( $obj->reset_counter, 0, 'reset returns new value' ); is( $obj->counter, 0, '... got the original value' ); like( exception { $obj->reset_counter(2) }, qr/number of parameters/, 'reset throws an error when an argument is passed' ); is( $obj->set_counter(5), 5, 'set returns new value' ); is( $obj->counter, 5, '... set the value' ); like( exception { $obj->set_counter( 1, 2 ) }, qr/number of parameters/, 'set throws an error when two arguments are passed' ); $obj->inc_counter(2); is( $obj->counter, 7, '... increment by arg' ); $obj->dec_counter(5); is( $obj->counter, 2, '... decrement by arg' ); $obj->inc_counter_2; is( $obj->counter, 4, '... curried increment' ); $obj->dec_counter_2; is( $obj->counter, 2, '... curried deccrement' ); $obj->set_counter_42; is( $obj->counter, 42, '... curried set' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->inc_counter; is( $obj->counter, 1, 'inc increments - with lazy default' ); $obj->_clear_counter; $obj->dec_counter; is( $obj->counter, -1, 'dec decrements - with lazy default' ); } } # $class; #} { package WithBuilder; use Mouse; use Sub::HandlesVia; has nonlazy => ( traits => ['Counter'], is => 'rw', isa => 'Int', builder => '_builder', handles => { reset_nonlazy => 'reset', }, ); has lazy => ( traits => ['Counter'], is => 'rw', isa => 'Int', lazy => 1, builder => '_builder', handles => { reset_lazy => 'reset', }, ); sub _builder { 1 } } for my $attr ('lazy', 'nonlazy') { my $obj = WithBuilder->new; is($obj->$attr, 1, "built properly"); $obj->$attr(0); is($obj->$attr, 0, "can be manually set"); $obj->${\"reset_$attr"}; is($obj->$attr, 1, "reset resets it to its default value"); } done_testing; trait_hash.t000664001750001750 2220214772476615 22055 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/07mouse_nativetypesuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Mouse' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my %handles = ( option_accessor => 'accessor', quantity => [ accessor => 'quantity' ], clear_options => 'clear', num_options => 'count', delete_option => 'delete', is_defined => 'defined', options_elements => 'elements', has_option => 'exists', get_option => 'get', has_no_options => 'is_empty', keys => 'keys', values => 'values', key_value => 'kv', set_option => 'set', ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Hash'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Mouse; use Sub::HandlesVia; has options => ( traits => [\@traits], is => 'rw', isa => 'HashRef[Str]', default => sub { {} }, handles => \\%handles_copy, clearer => '_clear_options', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { use Mouse::Util::TypeConstraints; run_tests(build_class); run_tests( build_class( lazy => 1, default => sub { { x => 1 } } ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); subtype 'MyHash', as 'HashRef[Str]', where { 1 }; run_tests( build_class( isa => 'MyHash' ) ); coerce 'MyHash', from 'HashRef', via { $_ }; run_tests( build_class( isa => 'MyHash', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new( options => {} ); ok( $obj->has_no_options, '... we have no options' ); is( $obj->num_options, 0, '... we have no options' ); is_deeply( $obj->options, {}, '... no options yet' ); ok( !$obj->has_option('foo'), '... we have no foo option' ); is( exception { is( $obj->set_option( foo => 'bar' ), 'bar', 'set return single new value in scalar context' ); }, undef, '... set the option okay' ); like( exception { $obj->set_option( foo => 'bar', 'baz' ) }, qr/number of parameters/, 'exception with odd number of arguments' ); like( exception { $obj->set_option( undef, 'bar' ) }, qr/did not pass type constraint/, 'exception when using undef as a key' ); ok( $obj->is_defined('foo'), '... foo is defined' ); ok( !$obj->has_no_options, '... we have options' ); is( $obj->num_options, 1, '... we have 1 option(s)' ); ok( $obj->has_option('foo'), '... we have a foo option' ); is_deeply( $obj->options, { foo => 'bar' }, '... got options now' ); is( exception { $obj->set_option( bar => 'baz' ); }, undef, '... set the option okay' ); is( $obj->num_options, 2, '... we have 2 option(s)' ); is_deeply( $obj->options, { foo => 'bar', bar => 'baz' }, '... got more options now' ); is( $obj->get_option('foo'), 'bar', '... got the right option' ); is_deeply( [ $obj->get_option(qw(foo bar)) ], [qw(bar baz)], "get multiple options at once" ); is( scalar( $obj->get_option(qw( foo bar)) ), "baz", '... got last option in scalar context' ); is( exception { $obj->set_option( oink => "blah", xxy => "flop" ); }, undef, '... set the option okay' ); is( $obj->num_options, 4, "4 options" ); is_deeply( [ $obj->get_option(qw(foo bar oink xxy)) ], [qw(bar baz blah flop)], "get multiple options at once" ); is( exception { is( scalar $obj->delete_option('bar'), 'baz', 'delete returns deleted value' ); }, undef, '... deleted the option okay' ); is( exception { is_deeply( [ $obj->delete_option( 'oink', 'xxy' ) ], [ 'blah', 'flop' ], 'delete returns all deleted values in list context' ); }, undef, '... deleted multiple option okay' ); is( $obj->num_options, 1, '... we have 1 option(s)' ); is_deeply( $obj->options, { foo => 'bar' }, '... got more options now' ); $obj->clear_options; is_deeply( $obj->options, {}, "... cleared options" ); is( exception { $obj->quantity(4); }, undef, '... options added okay with defaults' ); is( $obj->quantity, 4, 'reader part of curried accessor works' ); is( $obj->option_accessor('quantity'), 4, 'accessor as reader' ); is_deeply( $obj->options, { quantity => 4 }, '... returns what we expect' ); $obj->option_accessor( size => 42 ); like( exception { $obj->option_accessor; }, qr/number of parameters/, 'error when calling accessor with no arguments' ); like( exception { $obj->option_accessor( undef, 'bar' ) }, qr/did not pass type constraint/, 'exception when using undef as a key' ); is_deeply( $obj->options, { quantity => 4, size => 42 }, 'accessor as writer' ); is( exception { $class->new( options => { foo => 'BAR' } ); }, undef, '... good constructor params' ); isnt( exception { $obj->set_option( bar => {} ); }, undef, '... could not add a hash ref where an string is expected' ); isnt( exception { $class->new( options => { foo => [] } ); }, undef, '... bad constructor params' ); $obj->options( {} ); is_deeply( [ $obj->set_option( oink => "blah", xxy => "flop" ) ], [ 'blah', 'flop' ], 'set returns newly set values in order of keys provided' ); is_deeply( [ sort $obj->keys ], [ 'oink', 'xxy' ], 'keys returns expected keys' ); is_deeply( [ sort $obj->values ], [ 'blah', 'flop' ], 'values returns expected values' ); my @key_value = sort { $a->[0] cmp $b->[0] } $obj->key_value; is_deeply( \@key_value, [ sort { $a->[0] cmp $b->[0] }[ 'xxy', 'flop' ], [ 'oink', 'blah' ] ], '... got the right key value pairs' ) or do { require Data::Dumper; diag( Data::Dumper::Dumper( \@key_value ) ); }; my %options_elements = $obj->options_elements; is_deeply( \%options_elements, { 'oink' => 'blah', 'xxy' => 'flop' }, '... got the right hash elements' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->set_option( y => 2 ); is_deeply( $obj->options, { x => 1, y => 2 }, 'set_option with lazy default' ); $obj->_clear_options; ok( $obj->has_option('x'), 'key for x exists - lazy default' ); $obj->_clear_options; ok( $obj->is_defined('x'), 'key for x is defined - lazy default' ); $obj->_clear_options; is_deeply( [ $obj->key_value ], [ [ x => 1 ] ], 'kv returns lazy default' ); $obj->_clear_options; $obj->option_accessor( y => 2 ); is_deeply( [ sort $obj->keys ], [ 'x', 'y' ], 'accessor triggers lazy default generator' ); } # } # $class; } { my ( $class, $handles ) = build_class( isa => 'HashRef' ); my $obj = $class->new; # with_immutable { is( exception { $obj->option_accessor( 'foo', undef ) }, undef, 'can use accessor to set value to undef' ); is( exception { $obj->quantity(undef) }, undef, 'can use accessor to set value to undef' ); # } # $class; } done_testing; trait_number.t000664001750001750 1042714772476615 22430 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/07mouse_nativetypesuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Mouse' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my %handles = ( abs => 'abs', add => 'add', inc => [ add => 1 ], div => 'div', cut_in_half => [ div => 2 ], mod => 'mod', odd => [ mod => 2 ], mul => 'mul', set => 'set', sub => 'sub', dec => [ sub => 1 ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'Number'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Mouse; use Sub::HandlesVia; has integer => ( traits => [\@traits], is => 'rw', isa => 'Int', default => 5, handles => \\%handles_copy, clearer => '_clear_integer', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { use Mouse::Util::TypeConstraints; run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); type 'MyNum', as 'Num', where { 1 }; run_tests( build_class( isa => 'MyNum' ) ); coerce 'MyNum', from 'Num', via { $_ }; run_tests( build_class( isa => 'MyNum', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new; is( $obj->integer, 5, 'Default to five' ); is( $obj->add(10), 15, 'add returns new value' ); is( $obj->integer, 15, 'Add ten for fithteen' ); like( exception { $obj->add( 10, 2 ) }, qr/number of parameters/, 'add throws an error when 2 arguments are passed' ); is( $obj->sub(3), 12, 'sub returns new value' ); is( $obj->integer, 12, 'Subtract three for 12' ); like( exception { $obj->sub( 10, 2 ) }, qr/number of parameters/, 'sub throws an error when 2 arguments are passed' ); is( $obj->set(10), 10, 'set returns new value' ); is( $obj->integer, 10, 'Set to ten' ); like( exception { $obj->set( 10, 2 ) }, qr/number of parameters/, 'set throws an error when 2 arguments are passed' ); is( $obj->div(2), 5, 'div returns new value' ); is( $obj->integer, 5, 'divide by 2' ); like( exception { $obj->div( 10, 2 ) }, qr/number of parameters/, 'div throws an error when 2 arguments are passed' ); is( $obj->mul(2), 10, 'mul returns new value' ); is( $obj->integer, 10, 'multiplied by 2' ); like( exception { $obj->mul( 10, 2 ) }, qr/number of parameters/, 'mul throws an error when 2 arguments are passed' ); is( $obj->mod(2), 0, 'mod returns new value' ); is( $obj->integer, 0, 'Mod by 2' ); like( exception { $obj->mod( 10, 2 ) }, qr/number of parameters/, 'mod throws an error when 2 arguments are passed' ); $obj->set(7); $obj->mod(5); is( $obj->integer, 2, 'Mod by 5' ); $obj->set(-1); is( $obj->abs, 1, 'abs returns new value' ); like( exception { $obj->abs(10) }, qr/number of parameters/, 'abs throws an error when an argument is passed' ); is( $obj->integer, 1, 'abs 1' ); $obj->set(12); $obj->inc; is( $obj->integer, 13, 'inc 12' ); $obj->dec; is( $obj->integer, 12, 'dec 13' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->add(2); is( $obj->integer, 7, 'add with lazy default' ); $obj->_clear_integer; $obj->mod(2); is( $obj->integer, 1, 'mod with lazy default' ); } # } # $class; } done_testing; trait_string.t000664001750001750 2301014772476615 22436 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/07mouse_nativetypesuse strict; use warnings; ## skip Test::Tabs use lib 't/lib'; { package Local::Dummy1; use Test::Requires 'Mouse' }; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::More; use Test::Fatal; #use Test::Moose; { my %handles = ( inc => 'inc', append => 'append', append_curried => [ append => '!' ], prepend => 'prepend', prepend_curried => [ prepend => '-' ], replace => 'replace', replace_curried => [ replace => qr/(.)$/, sub { uc $1 } ], chop => 'chop', chomp => 'chomp', clear => 'clear', match => 'match', match_curried => [ match => qr/\D/ ], length => 'length', substr => 'substr', substr_curried_1 => [ substr => (1) ], substr_curried_2 => [ substr => ( 1, 3 ) ], substr_curried_3 => [ substr => ( 1, 3, 'ong' ) ], ); my $name = 'Foo1'; sub build_class { my %attr = @_; my %handles_copy = %handles; my $class = ++$name; # my $class = Moose::Meta::Class->create( # $name++, # superclasses => ['Moose::Object'], # ); my @traits = 'String'; # push @traits, 'NoInlineAttribute' # if delete $attr{no_inline}; eval qq{ package $class; use Mouse; use Sub::HandlesVia; has _string => ( traits => [\@traits], is => 'rw', isa => 'Str', default => q{}, handles => \\%handles_copy, clearer => '_clear_string', %attr, ); sub class_is_lazy { \$attr{lazy} } 1; } or die($@); return ( $class, \%handles ); } } { use Mouse::Util::TypeConstraints; run_tests(build_class); run_tests( build_class( lazy => 1, default => q{} ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); type 'MyStr', as 'Str', where { 1 }; run_tests( build_class( isa => 'MyStr' ) ); coerce 'MyStr', from 'Str', via { $_ }; run_tests( build_class( isa => 'MyStr', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; note "Testing class $class"; can_ok( $class, $_ ) for sort keys %{$handles}; # with_immutable { my $obj = $class->new(); is( $obj->length, 0, 'length returns zero' ); $obj->_string('a'); is( $obj->length, 1, 'length returns 1 for new string' ); like( exception { $obj->length(42) }, qr/number of parameters/, 'length throws an error when an argument is passed' ); is( $obj->inc, 'b', 'inc returns new value' ); is( $obj->_string, 'b', 'a becomes b after inc' ); like( exception { $obj->inc(42) }, qr/number of parameters/, 'inc throws an error when an argument is passed' ); is( $obj->append('foo'), 'bfoo', 'append returns new value' ); is( $obj->_string, 'bfoo', 'appended to the string' ); like( exception { $obj->append( 'foo', 2 ) }, qr/number of parameters/, 'append throws an error when two arguments are passed' ); $obj->append_curried; is( $obj->_string, 'bfoo!', 'append_curried appended to the string' ); like( exception { $obj->append_curried('foo') }, qr/number of parameters/, 'append_curried throws an error when two arguments are passed' ); $obj->_string("has nl$/"); is( $obj->chomp, 1, 'chomp returns number of characters removed' ); is( $obj->_string, 'has nl', 'chomped string' ); is( $obj->chomp, 0, 'chomp returns number of characters removed' ); is( $obj->_string, 'has nl', 'chomp is a no-op when string has no line ending' ); like( exception { $obj->chomp(42) }, qr/number of parameters/, 'chomp throws an error when an argument is passed' ); is( $obj->chop, 'l', 'chop returns character removed' ); is( $obj->_string, 'has n', 'chopped string' ); like( exception { $obj->chop(42) }, qr/number of parameters/, 'chop throws an error when an argument is passed' ); $obj->_string('x'); is( $obj->prepend('bar'), 'barx', 'prepend returns new value' ); is( $obj->_string, 'barx', 'prepended to string' ); $obj->prepend_curried; is( $obj->_string, '-barx', 'prepend_curried prepended to string' ); is( $obj->replace( qr/([ao])/, sub { uc($1) } ), '-bArx', 'replace returns new value' ); is( $obj->_string, '-bArx', 'substitution using coderef for replacement' ); $obj->replace( qr/A/, 'X' ); is( $obj->_string, '-bXrx', 'substitution using string as replacement' ); $obj->_string('foo'); $obj->replace( qr/oo/, q{} ); is( $obj->_string, 'f', 'replace accepts an empty string as second argument' ); $obj->replace( q{}, 'a' ); is( $obj->_string, 'af', 'replace accepts an empty string as first argument' ); like( exception { $obj->replace( {}, 'x' ) }, qr/did not pass type constraint/, 'replace throws an error when the first argument is not a string or regexp' ); like( exception { $obj->replace( qr/x/, {} ) }, qr/did not pass type constraint/, 'replace throws an error when the first argument is not a string or regexp' ); $obj->_string('Moosex'); $obj->replace_curried; is( $obj->_string, 'MooseX', 'capitalize last' ); $obj->_string('abcdef'); is_deeply( [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ], 'match -barx against /[aq]/ returns matches' ); is_deeply( [ $obj->match(qr/([az]).*([fy])/) ], [ 'a', 'f' ], 'match -barx against /[aq]/ returns matches' ); ok( scalar $obj->match('b'), 'match with string as argument returns true' ); ok( scalar $obj->match(q{}), 'match with empty string as argument returns true' ); like( exception { $obj->match }, qr/number of parameters/, 'match throws an error when no arguments are passed' ); like( exception { $obj->match( {} ) }, qr/did not pass type constraint/, 'match throws an error when an invalid argument is passed' ); $obj->_string('1234'); ok( !$obj->match_curried, 'match_curried returns false' ); $obj->_string('one two three four'); ok( $obj->match_curried, 'match curried returns true' ); $obj->clear; is( $obj->_string, q{}, 'clear' ); like( exception { $obj->clear(42) }, qr/number of parameters/, 'clear throws an error when an argument is passed' ); $obj->_string('some long string'); is( $obj->substr(1), 'ome long string', 'substr as getter with one argument' ); $obj->_string('some long string'); is( $obj->substr( 1, 3 ), 'ome', 'substr as getter with two arguments' ); is( $obj->substr( 1, 3, 'ong' ), 'ome', 'substr as setter returns replaced string' ); is( $obj->_string, 'song long string', 'substr as setter with three arguments' ); $obj->substr( 1, 3, '' ); is( $obj->_string, 's long string', 'substr as setter with three arguments, replacment is empty string' ); like( exception { $obj->substr }, qr/number of parameters/, 'substr throws an error when no argumemts are passed' ); like( exception { $obj->substr( 1, 2, 3, 4 ) }, qr/number of parameters/, 'substr throws an error when four argumemts are passed' ); like( exception { $obj->substr( {} ) }, qr/did not pass type constraint/, 'substr throws an error when first argument is not an integer' ); like( exception { $obj->substr( 1, {} ) }, qr/did not pass type constraint/, 'substr throws an error when second argument is not an integer' ); like( exception { $obj->substr( 1, 2, {} ) }, qr/did not pass type constraint/, 'substr throws an error when third argument is not a string' ); $obj->_string('some long string'); is( $obj->substr_curried_1, 'ome long string', 'substr_curried_1 returns expected value' ); is( $obj->substr_curried_1(3), 'ome', 'substr_curried_1 with one argument returns expected value' ); $obj->substr_curried_1( 3, 'ong' ); is( $obj->_string, 'song long string', 'substr_curried_1 as setter with two arguments' ); $obj->_string('some long string'); is( $obj->substr_curried_2, 'ome', 'substr_curried_2 returns expected value' ); $obj->substr_curried_2('ong'); is( $obj->_string, 'song long string', 'substr_curried_2 as setter with one arguments' ); $obj->_string('some long string'); $obj->substr_curried_3; is( $obj->_string, 'song long string', 'substr_curried_3 as setter' ); if ( $class->class_is_lazy ) { my $obj = $class->new; $obj->append('foo'); is( $obj->_string, 'foo', 'append with lazy default' ); } # } # $class; } done_testing; array.t000664001750001750 3776614772476615 16401 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/30egpoduse 5.008; use strict; use warnings; use Test::More; use Test::Fatal; ## skip Test::Tabs { package Local::Dummy1; use Test::Requires { 'Moo' => '1.006' } }; use constant { true => !!1, false => !!0 }; BEGIN { package My::Class; use Moo; use Sub::HandlesVia; use Types::Standard 'ArrayRef'; has attr => ( is => 'rwp', isa => ArrayRef, handles_via => 'Array', handles => { 'my_accessor' => 'accessor', 'my_all' => 'all', 'my_all_true' => 'all_true', 'my_any' => 'any', 'my_apply' => 'apply', 'my_clear' => 'clear', 'my_count' => 'count', 'my_delete' => 'delete', 'my_elements' => 'elements', 'my_first' => 'first', 'my_first_index' => 'first_index', 'my_flatten' => 'flatten', 'my_flatten_deep' => 'flatten_deep', 'my_for_each' => 'for_each', 'my_for_each_pair' => 'for_each_pair', 'my_get' => 'get', 'my_grep' => 'grep', 'my_head' => 'head', 'my_insert' => 'insert', 'my_is_empty' => 'is_empty', 'my_join' => 'join', 'my_map' => 'map', 'my_max' => 'max', 'my_maxstr' => 'maxstr', 'my_min' => 'min', 'my_minstr' => 'minstr', 'my_natatime' => 'natatime', 'my_not_all_true' => 'not_all_true', 'my_pairfirst' => 'pairfirst', 'my_pairgrep' => 'pairgrep', 'my_pairkeys' => 'pairkeys', 'my_pairmap' => 'pairmap', 'my_pairs' => 'pairs', 'my_pairvalues' => 'pairvalues', 'my_pick_random' => 'pick_random', 'my_pop' => 'pop', 'my_print' => 'print', 'my_product' => 'product', 'my_push' => 'push', 'my_reduce' => 'reduce', 'my_reductions' => 'reductions', 'my_reset' => 'reset', 'my_reverse' => 'reverse', 'my_sample' => 'sample', 'my_set' => 'set', 'my_shallow_clone' => 'shallow_clone', 'my_shift' => 'shift', 'my_shuffle' => 'shuffle', 'my_shuffle_in_place' => 'shuffle_in_place', 'my_sort' => 'sort', 'my_sort_in_place' => 'sort_in_place', 'my_splice' => 'splice', 'my_sum' => 'sum', 'my_tail' => 'tail', 'my_uniq' => 'uniq', 'my_uniq_in_place' => 'uniq_in_place', 'my_uniqnum' => 'uniqnum', 'my_uniqnum_in_place' => 'uniqnum_in_place', 'my_uniqstr' => 'uniqstr', 'my_uniqstr_in_place' => 'uniqstr_in_place', 'my_unshift' => 'unshift', }, default => sub { [] }, ); }; ## accessor can_ok( 'My::Class', 'my_accessor' ); subtest 'Testing my_accessor' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); $object->my_accessor( 1, 'quux' ); is_deeply( $object->attr, [ 'foo', 'quux', 'baz' ], q{$object->attr deep match} ); is( $object->my_accessor( 2 ), 'baz', q{$object->my_accessor( 2 ) is 'baz'} ); }; is( $e, undef, 'no exception thrown running accessor example' ); }; ## all can_ok( 'My::Class', 'my_all' ); subtest 'Testing my_all' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo', 'bar' ] ); my @list = $object->my_all; is_deeply( \@list, [ 'foo', 'bar' ], q{\@list deep match} ); }; is( $e, undef, 'no exception thrown running all example' ); }; ## all_true can_ok( 'My::Class', 'my_all_true' ); ## any can_ok( 'My::Class', 'my_any' ); subtest 'Testing my_any' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); my $truth = $object->my_any( sub { /a/ } ); ok( $truth, q{$truth is true} ); }; is( $e, undef, 'no exception thrown running any example' ); }; ## apply can_ok( 'My::Class', 'my_apply' ); ## clear can_ok( 'My::Class', 'my_clear' ); subtest 'Testing my_clear' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo' ] ); $object->my_clear; is_deeply( $object->attr, [], q{$object->attr deep match} ); }; is( $e, undef, 'no exception thrown running clear example' ); }; ## count can_ok( 'My::Class', 'my_count' ); subtest 'Testing my_count' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo', 'bar' ] ); is( $object->my_count, 2, q{$object->my_count is 2} ); }; is( $e, undef, 'no exception thrown running count example' ); }; ## delete can_ok( 'My::Class', 'my_delete' ); ## elements can_ok( 'My::Class', 'my_elements' ); subtest 'Testing my_elements' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo', 'bar' ] ); my @list = $object->my_elements; is_deeply( \@list, [ 'foo', 'bar' ], q{\@list deep match} ); }; is( $e, undef, 'no exception thrown running elements example' ); }; ## first can_ok( 'My::Class', 'my_first' ); subtest 'Testing my_first' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); my $found = $object->my_first( sub { /a/ } ); is( $found, 'bar', q{$found is 'bar'} ); }; is( $e, undef, 'no exception thrown running first example' ); }; ## first_index can_ok( 'My::Class', 'my_first_index' ); subtest 'Testing my_first_index' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); my $found = $object->my_first_index( sub { /z$/ } ); is( $found, 2, q{$found is 2} ); }; is( $e, undef, 'no exception thrown running first_index example' ); }; ## flatten can_ok( 'My::Class', 'my_flatten' ); subtest 'Testing my_flatten' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo', 'bar' ] ); my @list = $object->my_flatten; is_deeply( \@list, [ 'foo', 'bar' ], q{\@list deep match} ); }; is( $e, undef, 'no exception thrown running flatten example' ); }; ## flatten_deep can_ok( 'My::Class', 'my_flatten_deep' ); subtest 'Testing my_flatten_deep' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo', [ 'bar', [ 'baz' ] ] ] ); is_deeply( [ $object->my_flatten_deep ], [ 'foo', 'bar', 'baz' ], q{[ $object->my_flatten_deep ] deep match} ); my $object2 = My::Class->new( attr => [ 'foo', [ 'bar', [ 'baz' ] ] ] ); is_deeply( [ $object->my_flatten_deep(1) ], [ 'foo', 'bar', [ 'baz' ] ], q{[ $object->my_flatten_deep(1) ] deep match} ); }; is( $e, undef, 'no exception thrown running flatten_deep example' ); }; ## for_each can_ok( 'My::Class', 'my_for_each' ); subtest 'Testing my_for_each' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); $object->my_for_each( sub { note "Item $_[1] is $_[0]." } ); }; is( $e, undef, 'no exception thrown running for_each example' ); }; ## for_each_pair can_ok( 'My::Class', 'my_for_each_pair' ); ## get can_ok( 'My::Class', 'my_get' ); subtest 'Testing my_get' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); is( $object->my_get( 0 ), 'foo', q{$object->my_get( 0 ) is 'foo'} ); is( $object->my_get( 1 ), 'bar', q{$object->my_get( 1 ) is 'bar'} ); is( $object->my_get( -1 ), 'baz', q{$object->my_get( -1 ) is 'baz'} ); }; is( $e, undef, 'no exception thrown running get example' ); }; ## grep can_ok( 'My::Class', 'my_grep' ); ## head can_ok( 'My::Class', 'my_head' ); ## insert can_ok( 'My::Class', 'my_insert' ); subtest 'Testing my_insert' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); $object->my_insert( 1, 'quux' ); is_deeply( $object->attr, [ 'foo', 'quux', 'bar', 'baz' ], q{$object->attr deep match} ); }; is( $e, undef, 'no exception thrown running insert example' ); }; ## is_empty can_ok( 'My::Class', 'my_is_empty' ); subtest 'Testing my_is_empty' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo', 'bar' ] ); ok( !($object->my_is_empty), q{$object->my_is_empty is false} ); $object->_set_attr( [] ); ok( $object->my_is_empty, q{$object->my_is_empty is true} ); }; is( $e, undef, 'no exception thrown running is_empty example' ); }; ## join can_ok( 'My::Class', 'my_join' ); subtest 'Testing my_join' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); is( $object->my_join, 'foo,bar,baz', q{$object->my_join is 'foo,bar,baz'} ); is( $object->my_join( '|' ), 'foo|bar|baz', q{$object->my_join( '|' ) is 'foo|bar|baz'} ); }; is( $e, undef, 'no exception thrown running join example' ); }; ## map can_ok( 'My::Class', 'my_map' ); ## max can_ok( 'My::Class', 'my_max' ); ## maxstr can_ok( 'My::Class', 'my_maxstr' ); ## min can_ok( 'My::Class', 'my_min' ); ## minstr can_ok( 'My::Class', 'my_minstr' ); ## natatime can_ok( 'My::Class', 'my_natatime' ); subtest 'Testing my_natatime' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); my $iter = $object->my_natatime( 2 ); is_deeply( [ $iter->() ], [ 'foo', 'bar' ], q{[ $iter->() ] deep match} ); is_deeply( [ $iter->() ], [ 'baz' ], q{[ $iter->() ] deep match} ); }; is( $e, undef, 'no exception thrown running natatime example' ); }; ## not_all_true can_ok( 'My::Class', 'my_not_all_true' ); ## pairfirst can_ok( 'My::Class', 'my_pairfirst' ); ## pairgrep can_ok( 'My::Class', 'my_pairgrep' ); ## pairkeys can_ok( 'My::Class', 'my_pairkeys' ); ## pairmap can_ok( 'My::Class', 'my_pairmap' ); ## pairs can_ok( 'My::Class', 'my_pairs' ); ## pairvalues can_ok( 'My::Class', 'my_pairvalues' ); ## pick_random can_ok( 'My::Class', 'my_pick_random' ); ## pop can_ok( 'My::Class', 'my_pop' ); subtest 'Testing my_pop' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); is( $object->my_pop, 'baz', q{$object->my_pop is 'baz'} ); is( $object->my_pop, 'bar', q{$object->my_pop is 'bar'} ); is_deeply( $object->attr, [ 'foo' ], q{$object->attr deep match} ); }; is( $e, undef, 'no exception thrown running pop example' ); }; ## print can_ok( 'My::Class', 'my_print' ); ## product can_ok( 'My::Class', 'my_product' ); ## push can_ok( 'My::Class', 'my_push' ); subtest 'Testing my_push' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo' ] ); $object->my_push( 'bar', 'baz' ); is_deeply( $object->attr, [ 'foo', 'bar', 'baz' ], q{$object->attr deep match} ); }; is( $e, undef, 'no exception thrown running push example' ); }; ## reduce can_ok( 'My::Class', 'my_reduce' ); ## reductions can_ok( 'My::Class', 'my_reductions' ); ## reset can_ok( 'My::Class', 'my_reset' ); subtest 'Testing my_reset' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); $object->my_reset; is_deeply( $object->attr, [], q{$object->attr deep match} ); }; is( $e, undef, 'no exception thrown running reset example' ); }; ## reverse can_ok( 'My::Class', 'my_reverse' ); ## sample can_ok( 'My::Class', 'my_sample' ); ## set can_ok( 'My::Class', 'my_set' ); subtest 'Testing my_set' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); $object->my_set( 1, 'quux' ); is_deeply( $object->attr, [ 'foo', 'quux', 'baz' ], q{$object->attr deep match} ); }; is( $e, undef, 'no exception thrown running set example' ); }; ## shallow_clone can_ok( 'My::Class', 'my_shallow_clone' ); ## shift can_ok( 'My::Class', 'my_shift' ); subtest 'Testing my_shift' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); is( $object->my_shift, 'foo', q{$object->my_shift is 'foo'} ); is( $object->my_shift, 'bar', q{$object->my_shift is 'bar'} ); is_deeply( $object->attr, [ 'baz' ], q{$object->attr deep match} ); }; is( $e, undef, 'no exception thrown running shift example' ); }; ## shuffle can_ok( 'My::Class', 'my_shuffle' ); ## shuffle_in_place can_ok( 'My::Class', 'my_shuffle_in_place' ); ## sort can_ok( 'My::Class', 'my_sort' ); ## sort_in_place can_ok( 'My::Class', 'my_sort_in_place' ); ## splice can_ok( 'My::Class', 'my_splice' ); ## sum can_ok( 'My::Class', 'my_sum' ); ## tail can_ok( 'My::Class', 'my_tail' ); ## uniq can_ok( 'My::Class', 'my_uniq' ); ## uniq_in_place can_ok( 'My::Class', 'my_uniq_in_place' ); ## uniqnum can_ok( 'My::Class', 'my_uniqnum' ); ## uniqnum_in_place can_ok( 'My::Class', 'my_uniqnum_in_place' ); ## uniqstr can_ok( 'My::Class', 'my_uniqstr' ); ## uniqstr_in_place can_ok( 'My::Class', 'my_uniqstr_in_place' ); ## unshift can_ok( 'My::Class', 'my_unshift' ); subtest 'Testing my_unshift' => sub { my $e = exception { my $object = My::Class->new( attr => [ 'foo' ] ); $object->my_unshift( 'bar', 'baz' ); is_deeply( $object->attr, [ 'bar', 'baz', 'foo' ], q{$object->attr deep match} ); }; is( $e, undef, 'no exception thrown running unshift example' ); }; ## Using for_each subtest q{Using for_each (extended example)} => sub { my $e = exception { use strict; use warnings; { package My::Plugin; use Moo::Role; sub initialize {} sub finalize {} } { package My::Processor; use Moo; use Sub::HandlesVia; use Types::Standard qw( ArrayRef ConsumerOf ); has plugins => ( is => 'ro', isa => ArrayRef[ ConsumerOf['My::Plugin'] ], handles_via => 'Array', handles => { add_plugin => 'push', plugin_do => 'for_each', }, default => sub { [] }, ); sub _do_stuff { return; } sub run_process { my ( $self, @args ) = @_; $self->plugin_do( sub { my $plugin = shift; $plugin->initialize( $self, @args ); } ); $self->_do_stuff( @args ); $self->plugin_do( sub { my $plugin = shift; $plugin->finalize( $self, @args ); } ); } } my $p = My::Processor->new(); { package My::Plugin::Noisy; use Moo; with 'My::Plugin'; sub initialize { my ( $self, $processor, @args ) = @_; ::is( "initialize @args", 'initialize 1 2 3', q{"initialize @args" is 'initialize 1 2 3'} ); } sub finalize { my ( $self, $processor, @args ) = @_; ::is( "finalize @args", 'finalize 1 2 3', q{"finalize @args" is 'finalize 1 2 3'} ); } } $p->add_plugin( My::Plugin::Noisy->new ); $p->run_process( 1, 2, 3 ); }; is( $e, undef, 'no exception thrown running example' ); }; ## Job queue using push and shift subtest q{Job queue using push and shift (extended example)} => sub { my $e = exception { use strict; use warnings; use Try::Tiny; { package My::JobQueue; use Moo; use Sub::HandlesVia; use Types::Standard qw( Bool ArrayRef CodeRef HasMethods is_Object ); use Try::Tiny; has auto_requeue => ( is => 'ro', isa => Bool, default => 0, ); has jobs => ( is => 'ro', isa => ArrayRef[ CodeRef | HasMethods['run'] ], handles_via => 'Array', handles => { add_job => 'push', _get_job => 'shift', is_empty => 'is_empty', }, default => sub { [] }, ); sub _handle_failed_job { my ( $self, $job ) = @_; $self->add_job( $job ) if $self->auto_requeue; } sub run_jobs { my $self = shift; while ( not $self->is_empty ) { my $job = $self->_get_job; try { is_Object($job) ? $job->run() : $job->(); } catch { $self->_handle_failed_job( $job ); }; } } } my $q = My::JobQueue->new(); my $str = ''; $q->add_job( sub { $str .= 'A' } ); $q->add_job( sub { $str .= 'B' } ); $q->add_job( sub { $str .= 'C' } ); $q->run_jobs; is( $str, 'ABC', q{$str is 'ABC'} ); # Attempt to push invalid value on the queue # try { $q->add_job( "jobs cannot be strings" ); } catch { ok( $q->is_empty, q{$q->is_empty is true} ); }; }; is( $e, undef, 'no exception thrown running example' ); }; done_testing; bool.t000664001750001750 347614772476615 16165 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/30egpoduse 5.008; use strict; use warnings; use Test::More; use Test::Fatal; ## skip Test::Tabs { package Local::Dummy1; use Test::Requires { 'Moo' => '1.006' } }; use constant { true => !!1, false => !!0 }; BEGIN { package My::Class; use Moo; use Sub::HandlesVia; use Types::Standard 'Bool'; has attr => ( is => 'rwp', isa => Bool, handles_via => 'Bool', handles => { 'my_not' => 'not', 'my_reset' => 'reset', 'my_set' => 'set', 'my_toggle' => 'toggle', 'my_unset' => 'unset', }, default => sub { 0 }, ); }; ## not can_ok( 'My::Class', 'my_not' ); subtest 'Testing my_not' => sub { my $e = exception { my $object = My::Class->new( attr => 1 ); ok( !($object->my_not()), q{$object->my_not() is false} ); }; is( $e, undef, 'no exception thrown running not example' ); }; ## reset can_ok( 'My::Class', 'my_reset' ); ## set can_ok( 'My::Class', 'my_set' ); subtest 'Testing my_set' => sub { my $e = exception { my $object = My::Class->new(); $object->my_set(); ok( $object->attr, q{$object->attr is true} ); }; is( $e, undef, 'no exception thrown running set example' ); }; ## toggle can_ok( 'My::Class', 'my_toggle' ); subtest 'Testing my_toggle' => sub { my $e = exception { my $object = My::Class->new(); $object->my_toggle(); ok( $object->attr, q{$object->attr is true} ); $object->my_toggle(); ok( !($object->attr), q{$object->attr is false} ); }; is( $e, undef, 'no exception thrown running toggle example' ); }; ## unset can_ok( 'My::Class', 'my_unset' ); subtest 'Testing my_unset' => sub { my $e = exception { my $object = My::Class->new(); $object->my_unset(); ok( !($object->attr), q{$object->attr is false} ); }; is( $e, undef, 'no exception thrown running unset example' ); }; done_testing; code.t000664001750001750 1463414772476615 16162 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/30egpoduse 5.008; use strict; use warnings; use Test::More; use Test::Fatal; ## skip Test::Tabs { package Local::Dummy1; use Test::Requires { 'Moo' => '1.006' } }; use constant { true => !!1, false => !!0 }; BEGIN { package My::Class; use Moo; use Sub::HandlesVia; use Types::Standard 'CodeRef'; has attr => ( is => 'rwp', isa => CodeRef, handles_via => 'Code', handles => { 'my_execute' => 'execute', 'my_execute_list' => 'execute_list', 'my_execute_method' => 'execute_method', 'my_execute_method_list' => 'execute_method_list', 'my_execute_method_scalar' => 'execute_method_scalar', 'my_execute_method_void' => 'execute_method_void', 'my_execute_scalar' => 'execute_scalar', 'my_execute_void' => 'execute_void', }, default => sub { sub {} }, ); }; ## execute can_ok( 'My::Class', 'my_execute' ); subtest 'Testing my_execute' => sub { my $e = exception { my $coderef = sub { 'code' }; my $object = My::Class->new( attr => $coderef ); # Calls: $coderef->( 1, 2, 3 ) $object->my_execute( 1, 2, 3 ); }; is( $e, undef, 'no exception thrown running execute example' ); }; ## execute_list can_ok( 'My::Class', 'my_execute_list' ); subtest 'Testing my_execute_list' => sub { my $e = exception { my $context; my $coderef = sub { $context = wantarray(); 'code' }; my $object = My::Class->new( attr => $coderef ); # Calls: $coderef->( 1, 2, 3 ) my $result = $object->my_execute_list( 1, 2, 3 ); is_deeply( $result, [ 'code' ], q{$result deep match} ); ok( $context, q{$context is true} ); }; is( $e, undef, 'no exception thrown running execute_list example' ); }; ## execute_method can_ok( 'My::Class', 'my_execute_method' ); subtest 'Testing my_execute_method' => sub { my $e = exception { my $coderef = sub { 'code' }; my $object = My::Class->new( attr => $coderef ); # Calls: $coderef->( $object, 1, 2, 3 ) $object->my_execute_method( 1, 2, 3 ); }; is( $e, undef, 'no exception thrown running execute_method example' ); }; ## execute_method_list can_ok( 'My::Class', 'my_execute_method_list' ); subtest 'Testing my_execute_method_list' => sub { my $e = exception { my $context; my $coderef = sub { $context = wantarray(); 'code' }; my $object = My::Class->new( attr => $coderef ); # Calls: $coderef->( $object, 1, 2, 3 ) my $result = $object->my_execute_method_list( 1, 2, 3 ); is_deeply( $result, [ 'code' ], q{$result deep match} ); ok( $context, q{$context is true} ); }; is( $e, undef, 'no exception thrown running execute_method_list example' ); }; ## execute_method_scalar can_ok( 'My::Class', 'my_execute_method_scalar' ); subtest 'Testing my_execute_method_scalar' => sub { my $e = exception { my $context; my $coderef = sub { $context = wantarray(); 'code' }; my $object = My::Class->new( attr => $coderef ); # Calls: $coderef->( $object, 1, 2, 3 ) my $result = $object->my_execute_method_scalar( 1, 2, 3 ); is( $result, 'code', q{$result is 'code'} ); ok( !($context), q{$context is false} ); }; is( $e, undef, 'no exception thrown running execute_method_scalar example' ); }; ## execute_method_void can_ok( 'My::Class', 'my_execute_method_void' ); subtest 'Testing my_execute_method_void' => sub { my $e = exception { my $context; my $coderef = sub { $context = wantarray(); 'code' }; my $object = My::Class->new( attr => $coderef ); # Calls: $coderef->( $object, 1, 2, 3 ) my $result = $object->my_execute_method_void( 1, 2, 3 ); is( $result, undef, q{$result is undef} ); is( $context, undef, q{$context is undef} ); }; is( $e, undef, 'no exception thrown running execute_method_void example' ); }; ## execute_scalar can_ok( 'My::Class', 'my_execute_scalar' ); subtest 'Testing my_execute_scalar' => sub { my $e = exception { my $context; my $coderef = sub { $context = wantarray(); 'code' }; my $object = My::Class->new( attr => $coderef ); # Calls: $coderef->( 1, 2, 3 ) my $result = $object->my_execute_scalar( 1, 2, 3 ); is( $result, 'code', q{$result is 'code'} ); ok( !($context), q{$context is false} ); }; is( $e, undef, 'no exception thrown running execute_scalar example' ); }; ## execute_void can_ok( 'My::Class', 'my_execute_void' ); subtest 'Testing my_execute_void' => sub { my $e = exception { my $context; my $coderef = sub { $context = wantarray(); 'code' }; my $object = My::Class->new( attr => $coderef ); # Calls: $coderef->( 1, 2, 3 ) my $result = $object->my_execute_void( 1, 2, 3 ); is( $result, undef, q{$result is undef} ); is( $context, undef, q{$context is undef} ); }; is( $e, undef, 'no exception thrown running execute_void example' ); }; ## Using execute_method subtest q{Using execute_method (extended example)} => sub { my $e = exception { use strict; use warnings; use Data::Dumper; { package My::Processor; use Moo; use Sub::HandlesVia; use Types::Standard qw( Str CodeRef ); has name => ( is => 'ro', isa => Str, default => 'Main Process', ); my $NULL_CODEREF = sub {}; has _debug => ( is => 'ro', isa => CodeRef, handles_via => 'Code', handles => { debug => 'execute_method' }, default => sub { $NULL_CODEREF }, init_arg => 'debug', ); sub _do_stuff { my $self = shift; $self->debug( 'continuing process' ); return; } sub run_process { my $self = shift; $self->debug( 'starting process' ); $self->_do_stuff; $self->debug( 'ending process' ); } } my $p1 = My::Processor->new( name => 'First Process' ); $p1->run_process; # no output my @got; my $p2 = My::Processor->new( name => 'Second Process', debug => sub { my ( $processor, $message ) = @_; push @got, sprintf( '%s: %s', $processor->name, $message ); }, ); $p2->run_process; # logged output my @expected = ( 'Second Process: starting process', 'Second Process: continuing process', 'Second Process: ending process', ); is_deeply( \@got, \@expected, q{\@got deep match} ); }; is( $e, undef, 'no exception thrown running example' ); }; done_testing; counter.t000664001750001750 357114772476615 16705 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/30egpoduse 5.008; use strict; use warnings; use Test::More; use Test::Fatal; ## skip Test::Tabs { package Local::Dummy1; use Test::Requires { 'Moo' => '1.006' } }; use constant { true => !!1, false => !!0 }; BEGIN { package My::Class; use Moo; use Sub::HandlesVia; use Types::Standard 'Int'; has attr => ( is => 'rwp', isa => Int, handles_via => 'Counter', handles => { 'my_dec' => 'dec', 'my_inc' => 'inc', 'my_reset' => 'reset', 'my_set' => 'set', }, default => sub { 0 }, ); }; ## dec can_ok( 'My::Class', 'my_dec' ); subtest 'Testing my_dec' => sub { my $e = exception { my $object = My::Class->new( attr => 10 ); $object->my_dec; $object->my_dec; is( $object->attr, 8, q{$object->attr is 8} ); $object->my_dec( 5 ); is( $object->attr, 3, q{$object->attr is 3} ); }; is( $e, undef, 'no exception thrown running dec example' ); }; ## inc can_ok( 'My::Class', 'my_inc' ); subtest 'Testing my_inc' => sub { my $e = exception { my $object = My::Class->new( attr => 0 ); $object->my_inc; $object->my_inc; is( $object->attr, 2, q{$object->attr is 2} ); $object->my_inc( 3 ); is( $object->attr, 5, q{$object->attr is 5} ); }; is( $e, undef, 'no exception thrown running inc example' ); }; ## reset can_ok( 'My::Class', 'my_reset' ); subtest 'Testing my_reset' => sub { my $e = exception { my $object = My::Class->new( attr => 10 ); $object->my_reset; is( $object->attr, 0, q{$object->attr is 0} ); }; is( $e, undef, 'no exception thrown running reset example' ); }; ## set can_ok( 'My::Class', 'my_set' ); subtest 'Testing my_set' => sub { my $e = exception { my $object = My::Class->new( attr => 0 ); $object->my_set( 5 ); is( $object->attr, 5, q{$object->attr is 5} ); }; is( $e, undef, 'no exception thrown running set example' ); }; done_testing; hash.t000664001750001750 1516014772476615 16166 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/30egpoduse 5.008; use strict; use warnings; use Test::More; use Test::Fatal; ## skip Test::Tabs { package Local::Dummy1; use Test::Requires { 'Moo' => '1.006' } }; use constant { true => !!1, false => !!0 }; BEGIN { package My::Class; use Moo; use Sub::HandlesVia; use Types::Standard 'HashRef'; has attr => ( is => 'rwp', isa => HashRef, handles_via => 'Hash', handles => { 'my_accessor' => 'accessor', 'my_all' => 'all', 'my_clear' => 'clear', 'my_count' => 'count', 'my_defined' => 'defined', 'my_delete' => 'delete', 'my_delete_where' => 'delete_where', 'my_elements' => 'elements', 'my_exists' => 'exists', 'my_for_each_key' => 'for_each_key', 'my_for_each_pair' => 'for_each_pair', 'my_for_each_value' => 'for_each_value', 'my_get' => 'get', 'my_is_empty' => 'is_empty', 'my_keys' => 'keys', 'my_kv' => 'kv', 'my_reset' => 'reset', 'my_set' => 'set', 'my_shallow_clone' => 'shallow_clone', 'my_sorted_keys' => 'sorted_keys', 'my_values' => 'values', }, default => sub { {} }, ); }; ## accessor can_ok( 'My::Class', 'my_accessor' ); ## all can_ok( 'My::Class', 'my_all' ); subtest 'Testing my_all' => sub { my $e = exception { my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); my %hash = $object->my_all; }; is( $e, undef, 'no exception thrown running all example' ); }; ## clear can_ok( 'My::Class', 'my_clear' ); subtest 'Testing my_clear' => sub { my $e = exception { my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); $object->my_clear; ok( !(exists $object->attr->{foo}), q{exists $object->attr->{foo} is false} ); ok( !(exists $object->attr->{bar}), q{exists $object->attr->{bar} is false} ); }; is( $e, undef, 'no exception thrown running clear example' ); }; ## count can_ok( 'My::Class', 'my_count' ); subtest 'Testing my_count' => sub { my $e = exception { my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); is( $object->my_count, 2, q{$object->my_count is 2} ); }; is( $e, undef, 'no exception thrown running count example' ); }; ## defined can_ok( 'My::Class', 'my_defined' ); subtest 'Testing my_defined' => sub { my $e = exception { my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); is( $object->my_defined( 'foo' ), 1, q{$object->my_defined( 'foo' ) is 1} ); }; is( $e, undef, 'no exception thrown running defined example' ); }; ## delete can_ok( 'My::Class', 'my_delete' ); subtest 'Testing my_delete' => sub { my $e = exception { my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); $object->my_delete( 'foo' ); ok( !(exists $object->attr->{foo}), q{exists $object->attr->{foo} is false} ); }; is( $e, undef, 'no exception thrown running delete example' ); }; ## delete_where can_ok( 'My::Class', 'my_delete_where' ); subtest 'Testing my_delete_where' => sub { my $e = exception { my $object = My::Class->new( attr => { foo => 0, bar => 1, baz => 2 } ); $object->my_delete_where( sub { $_ eq 'foo' or $_ eq 'bar' } ); is_deeply( $object->attr, { baz => 2 }, q{$object->attr deep match} ); my $object2 = My::Class->new( attr => { foo => 0, bar => 1, baz => 2 } ); $object2->my_delete_where( qr/^b/ ); is_deeply( $object2->attr, { foo => 0 }, q{$object2->attr deep match} ); }; is( $e, undef, 'no exception thrown running delete_where example' ); }; ## elements can_ok( 'My::Class', 'my_elements' ); subtest 'Testing my_elements' => sub { my $e = exception { my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); my %hash = $object->my_elements; }; is( $e, undef, 'no exception thrown running elements example' ); }; ## exists can_ok( 'My::Class', 'my_exists' ); subtest 'Testing my_exists' => sub { my $e = exception { my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); ok( $object->my_exists( 'foo' ), q{$object->my_exists( 'foo' ) is true} ); ok( !($object->my_exists( 'baz' )), q{$object->my_exists( 'baz' ) is false} ); }; is( $e, undef, 'no exception thrown running exists example' ); }; ## for_each_key can_ok( 'My::Class', 'my_for_each_key' ); ## for_each_pair can_ok( 'My::Class', 'my_for_each_pair' ); ## for_each_value can_ok( 'My::Class', 'my_for_each_value' ); ## get can_ok( 'My::Class', 'my_get' ); subtest 'Testing my_get' => sub { my $e = exception { my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); is( $object->my_get( 'bar' ), 1, q{$object->my_get( 'bar' ) is 1} ); }; is( $e, undef, 'no exception thrown running get example' ); }; ## is_empty can_ok( 'My::Class', 'my_is_empty' ); subtest 'Testing my_is_empty' => sub { my $e = exception { my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); ok( !($object->my_is_empty), q{$object->my_is_empty is false} ); $object->_set_attr( {} ); ok( $object->my_is_empty, q{$object->my_is_empty is true} ); }; is( $e, undef, 'no exception thrown running is_empty example' ); }; ## keys can_ok( 'My::Class', 'my_keys' ); subtest 'Testing my_keys' => sub { my $e = exception { my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); # says 'foo' and 'bar' in an unpredictable order note for $object->my_keys; }; is( $e, undef, 'no exception thrown running keys example' ); }; ## kv can_ok( 'My::Class', 'my_kv' ); ## reset can_ok( 'My::Class', 'my_reset' ); ## set can_ok( 'My::Class', 'my_set' ); subtest 'Testing my_set' => sub { my $e = exception { my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); $object->my_set( bar => 2, baz => 1 ); is( $object->attr->{foo}, 0, q{$object->attr->{foo} is 0} ); is( $object->attr->{baz}, 1, q{$object->attr->{baz} is 1} ); is( $object->attr->{bar}, 2, q{$object->attr->{bar} is 2} ); }; is( $e, undef, 'no exception thrown running set example' ); }; ## shallow_clone can_ok( 'My::Class', 'my_shallow_clone' ); ## sorted_keys can_ok( 'My::Class', 'my_sorted_keys' ); subtest 'Testing my_sorted_keys' => sub { my $e = exception { my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); # says 'bar' then 'foo' note for $object->my_sorted_keys; }; is( $e, undef, 'no exception thrown running sorted_keys example' ); }; ## values can_ok( 'My::Class', 'my_values' ); subtest 'Testing my_values' => sub { my $e = exception { my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); # says '0' and '1' in an unpredictable order note for $object->my_values; }; is( $e, undef, 'no exception thrown running values example' ); }; done_testing; number.t000664001750001750 651414772476615 16516 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/30egpoduse 5.008; use strict; use warnings; use Test::More; use Test::Fatal; ## skip Test::Tabs { package Local::Dummy1; use Test::Requires { 'Moo' => '1.006' } }; use constant { true => !!1, false => !!0 }; BEGIN { package My::Class; use Moo; use Sub::HandlesVia; use Types::Standard 'Num'; has attr => ( is => 'rwp', isa => Num, handles_via => 'Number', handles => { 'my_abs' => 'abs', 'my_add' => 'add', 'my_cmp' => 'cmp', 'my_div' => 'div', 'my_eq' => 'eq', 'my_ge' => 'ge', 'my_get' => 'get', 'my_gt' => 'gt', 'my_le' => 'le', 'my_lt' => 'lt', 'my_mod' => 'mod', 'my_mul' => 'mul', 'my_ne' => 'ne', 'my_set' => 'set', 'my_sub' => 'sub', }, default => sub { 0 }, ); }; ## abs can_ok( 'My::Class', 'my_abs' ); subtest 'Testing my_abs' => sub { my $e = exception { my $object = My::Class->new( attr => -5 ); $object->my_abs; is( $object->attr, 5, q{$object->attr is 5} ); }; is( $e, undef, 'no exception thrown running abs example' ); }; ## add can_ok( 'My::Class', 'my_add' ); subtest 'Testing my_add' => sub { my $e = exception { my $object = My::Class->new( attr => 4 ); $object->my_add( 5 ); is( $object->attr, 9, q{$object->attr is 9} ); }; is( $e, undef, 'no exception thrown running add example' ); }; ## cmp can_ok( 'My::Class', 'my_cmp' ); ## div can_ok( 'My::Class', 'my_div' ); subtest 'Testing my_div' => sub { my $e = exception { my $object = My::Class->new( attr => 6 ); $object->my_div( 2 ); is( $object->attr, 3, q{$object->attr is 3} ); }; is( $e, undef, 'no exception thrown running div example' ); }; ## eq can_ok( 'My::Class', 'my_eq' ); ## ge can_ok( 'My::Class', 'my_ge' ); ## get can_ok( 'My::Class', 'my_get' ); subtest 'Testing my_get' => sub { my $e = exception { my $object = My::Class->new( attr => 4 ); is( $object->my_get, 4, q{$object->my_get is 4} ); }; is( $e, undef, 'no exception thrown running get example' ); }; ## gt can_ok( 'My::Class', 'my_gt' ); ## le can_ok( 'My::Class', 'my_le' ); ## lt can_ok( 'My::Class', 'my_lt' ); ## mod can_ok( 'My::Class', 'my_mod' ); subtest 'Testing my_mod' => sub { my $e = exception { my $object = My::Class->new( attr => 5 ); $object->my_mod( 2 ); is( $object->attr, 1, q{$object->attr is 1} ); }; is( $e, undef, 'no exception thrown running mod example' ); }; ## mul can_ok( 'My::Class', 'my_mul' ); subtest 'Testing my_mul' => sub { my $e = exception { my $object = My::Class->new( attr => 2 ); $object->my_mul( 5 ); is( $object->attr, 10, q{$object->attr is 10} ); }; is( $e, undef, 'no exception thrown running mul example' ); }; ## ne can_ok( 'My::Class', 'my_ne' ); ## set can_ok( 'My::Class', 'my_set' ); subtest 'Testing my_set' => sub { my $e = exception { my $object = My::Class->new( attr => 4 ); $object->my_set( 5 ); is( $object->attr, 5, q{$object->attr is 5} ); }; is( $e, undef, 'no exception thrown running set example' ); }; ## sub can_ok( 'My::Class', 'my_sub' ); subtest 'Testing my_sub' => sub { my $e = exception { my $object = My::Class->new( attr => 9 ); $object->my_sub( 6 ); is( $object->attr, 3, q{$object->attr is 3} ); }; is( $e, undef, 'no exception thrown running sub example' ); }; done_testing; scalar.t000664001750001750 323514772476615 16470 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/30egpoduse 5.008; use strict; use warnings; use Test::More; use Test::Fatal; ## skip Test::Tabs { package Local::Dummy1; use Test::Requires { 'Moo' => '1.006' } }; use constant { true => !!1, false => !!0 }; BEGIN { package My::Class; use Moo; use Sub::HandlesVia; use Types::Standard 'Any'; has attr => ( is => 'rwp', isa => Any, handles_via => 'Scalar', handles => { 'my_make_getter' => 'make_getter', 'my_make_setter' => 'make_setter', 'my_scalar_reference' => 'scalar_reference', }, default => sub { q[] }, ); }; ## make_getter can_ok( 'My::Class', 'my_make_getter' ); subtest 'Testing my_make_getter' => sub { my $e = exception { my $object = My::Class->new( attr => 10 ); my $getter = $object->my_make_getter; $object->_set_attr( 11 ); is( $getter->(), 11, q{$getter->() is 11} ); }; is( $e, undef, 'no exception thrown running make_getter example' ); }; ## make_setter can_ok( 'My::Class', 'my_make_setter' ); subtest 'Testing my_make_setter' => sub { my $e = exception { my $object = My::Class->new( attr => 10 ); my $setter = $object->my_make_setter; $setter->( 11 ); is( $object->attr, 11, q{$object->attr is 11} ); }; is( $e, undef, 'no exception thrown running make_setter example' ); }; ## scalar_reference can_ok( 'My::Class', 'my_scalar_reference' ); subtest 'Testing my_scalar_reference' => sub { my $e = exception { my $object = My::Class->new( attr => 10 ); my $ref = $object->my_scalar_reference; $$ref++; is( $object->attr, 11, q{$object->attr is 11} ); }; is( $e, undef, 'no exception thrown running scalar_reference example' ); }; done_testing; string.t000664001750001750 2113714772476615 16552 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/30egpoduse 5.008; use strict; use warnings; use Test::More; use Test::Fatal; ## skip Test::Tabs { package Local::Dummy1; use Test::Requires { 'Moo' => '1.006' } }; use constant { true => !!1, false => !!0 }; BEGIN { package My::Class; use Moo; use Sub::HandlesVia; use Types::Standard 'Str'; has attr => ( is => 'rwp', isa => Str, handles_via => 'String', handles => { 'my_append' => 'append', 'my_chomp' => 'chomp', 'my_chop' => 'chop', 'my_clear' => 'clear', 'my_cmp' => 'cmp', 'my_cmpi' => 'cmpi', 'my_contains' => 'contains', 'my_contains_i' => 'contains_i', 'my_ends_with' => 'ends_with', 'my_ends_with_i' => 'ends_with_i', 'my_eq' => 'eq', 'my_eqi' => 'eqi', 'my_fc' => 'fc', 'my_ge' => 'ge', 'my_gei' => 'gei', 'my_get' => 'get', 'my_gt' => 'gt', 'my_gti' => 'gti', 'my_inc' => 'inc', 'my_lc' => 'lc', 'my_le' => 'le', 'my_lei' => 'lei', 'my_length' => 'length', 'my_lt' => 'lt', 'my_lti' => 'lti', 'my_match' => 'match', 'my_match_i' => 'match_i', 'my_ne' => 'ne', 'my_nei' => 'nei', 'my_prepend' => 'prepend', 'my_replace' => 'replace', 'my_replace_globally' => 'replace_globally', 'my_reset' => 'reset', 'my_set' => 'set', 'my_starts_with' => 'starts_with', 'my_starts_with_i' => 'starts_with_i', 'my_substr' => 'substr', 'my_uc' => 'uc', }, default => sub { q[] }, ); }; ## append can_ok( 'My::Class', 'my_append' ); subtest 'Testing my_append' => sub { my $e = exception { my $object = My::Class->new( attr => 'foo' ); $object->my_append( 'bar' ); is( $object->attr, 'foobar', q{$object->attr is 'foobar'} ); }; is( $e, undef, 'no exception thrown running append example' ); }; ## chomp can_ok( 'My::Class', 'my_chomp' ); ## chop can_ok( 'My::Class', 'my_chop' ); ## clear can_ok( 'My::Class', 'my_clear' ); subtest 'Testing my_clear' => sub { my $e = exception { my $object = My::Class->new( attr => 'foo' ); $object->my_clear; note $object->attr; ## nothing }; is( $e, undef, 'no exception thrown running clear example' ); }; ## cmp can_ok( 'My::Class', 'my_cmp' ); ## cmpi can_ok( 'My::Class', 'my_cmpi' ); ## contains can_ok( 'My::Class', 'my_contains' ); ## contains_i can_ok( 'My::Class', 'my_contains_i' ); ## ends_with can_ok( 'My::Class', 'my_ends_with' ); ## ends_with_i can_ok( 'My::Class', 'my_ends_with_i' ); ## eq can_ok( 'My::Class', 'my_eq' ); ## eqi can_ok( 'My::Class', 'my_eqi' ); ## fc can_ok( 'My::Class', 'my_fc' ); ## ge can_ok( 'My::Class', 'my_ge' ); ## gei can_ok( 'My::Class', 'my_gei' ); ## get can_ok( 'My::Class', 'my_get' ); subtest 'Testing my_get' => sub { my $e = exception { my $object = My::Class->new( attr => 'foo' ); is( $object->my_get, 'foo', q{$object->my_get is 'foo'} ); }; is( $e, undef, 'no exception thrown running get example' ); }; ## gt can_ok( 'My::Class', 'my_gt' ); ## gti can_ok( 'My::Class', 'my_gti' ); ## inc can_ok( 'My::Class', 'my_inc' ); ## lc can_ok( 'My::Class', 'my_lc' ); ## le can_ok( 'My::Class', 'my_le' ); ## lei can_ok( 'My::Class', 'my_lei' ); ## length can_ok( 'My::Class', 'my_length' ); subtest 'Testing my_length' => sub { my $e = exception { my $object = My::Class->new( attr => 'foo' ); is( $object->my_length, 3, q{$object->my_length is 3} ); }; is( $e, undef, 'no exception thrown running length example' ); }; ## lt can_ok( 'My::Class', 'my_lt' ); ## lti can_ok( 'My::Class', 'my_lti' ); ## match can_ok( 'My::Class', 'my_match' ); subtest 'Testing my_match' => sub { my $e = exception { my $object = My::Class->new( attr => 'foo' ); if ( $object->my_match( '^f..$' ) ) { note 'matched!'; } }; is( $e, undef, 'no exception thrown running match example' ); }; ## match_i can_ok( 'My::Class', 'my_match_i' ); subtest 'Testing my_match_i' => sub { my $e = exception { my $object = My::Class->new( attr => 'foo' ); if ( $object->my_match_i( '^F..$' ) ) { note 'matched!'; } }; is( $e, undef, 'no exception thrown running match_i example' ); }; ## ne can_ok( 'My::Class', 'my_ne' ); ## nei can_ok( 'My::Class', 'my_nei' ); ## prepend can_ok( 'My::Class', 'my_prepend' ); subtest 'Testing my_prepend' => sub { my $e = exception { my $object = My::Class->new( attr => 'foo' ); $object->my_prepend( 'bar' ); is( $object->attr, 'barfoo', q{$object->attr is 'barfoo'} ); }; is( $e, undef, 'no exception thrown running prepend example' ); }; ## replace can_ok( 'My::Class', 'my_replace' ); subtest 'Testing my_replace' => sub { my $e = exception { my $object = My::Class->new( attr => 'foo' ); $object->my_replace( 'o' => 'a' ); is( $object->attr, 'fao', q{$object->attr is 'fao'} ); my $object2 = My::Class->new( attr => 'foo' ); $object2->my_replace( qr/O/i => sub { return 'e' } ); is( $object2->attr, 'feo', q{$object2->attr is 'feo'} ); }; is( $e, undef, 'no exception thrown running replace example' ); }; ## replace_globally can_ok( 'My::Class', 'my_replace_globally' ); subtest 'Testing my_replace_globally' => sub { my $e = exception { my $object = My::Class->new( attr => 'foo' ); $object->my_replace_globally( 'o' => 'a' ); is( $object->attr, 'faa', q{$object->attr is 'faa'} ); my $object2 = My::Class->new( attr => 'foo' ); $object2->my_replace_globally( qr/O/i => sub { return 'e' } ); is( $object2->attr, 'fee', q{$object2->attr is 'fee'} ); }; is( $e, undef, 'no exception thrown running replace_globally example' ); }; ## reset can_ok( 'My::Class', 'my_reset' ); ## set can_ok( 'My::Class', 'my_set' ); subtest 'Testing my_set' => sub { my $e = exception { my $object = My::Class->new( attr => 'foo' ); $object->my_set( 'bar' ); is( $object->attr, 'bar', q{$object->attr is 'bar'} ); }; is( $e, undef, 'no exception thrown running set example' ); }; ## starts_with can_ok( 'My::Class', 'my_starts_with' ); ## starts_with_i can_ok( 'My::Class', 'my_starts_with_i' ); ## substr can_ok( 'My::Class', 'my_substr' ); ## uc can_ok( 'My::Class', 'my_uc' ); ## Using eq for Enum subtest q{Using eq for Enum (extended example)} => sub { my $e = exception { use strict; use warnings; { package My::Person; use Moo; use Sub::HandlesVia; use Types::Standard qw( Str Enum ); has name => ( is => 'ro', isa => Str, required => 1, ); has status => ( is => 'rwp', isa => Enum[ 'alive', 'dead' ], handles_via => 'String', handles => { is_alive => [ eq => 'alive' ], is_dead => [ eq => 'dead' ], kill => [ set => 'dead' ], }, default => 'alive', ); # Note: method modifiers work on delegated methods # before kill => sub { my $self = shift; warn "overkill" if $self->is_dead; }; } my $bob = My::Person->new( name => 'Robert' ); ok( $bob->is_alive, q{$bob->is_alive is true} ); ok( !($bob->is_dead), q{$bob->is_dead is false} ); $bob->kill; ok( !($bob->is_alive), q{$bob->is_alive is false} ); ok( $bob->is_dead, q{$bob->is_dead is true} ); }; is( $e, undef, 'no exception thrown running example' ); }; ## Match with curried regexp subtest q{Match with curried regexp (extended example)} => sub { my $e = exception { use strict; use warnings; { package My::Component; use Moo; use Sub::HandlesVia; use Types::Standard qw( Str Int ); has id => ( is => 'ro', isa => Int, required => 1, ); has name => ( is => 'ro', isa => Str, required => 1, handles_via => 'String', handles => { name_is_safe_filename => [ match => qr/\A[A-Za-z0-9]+\z/ ], _lc_name => 'lc', }, ); sub config_filename { my $self = shift; if ( $self->name_is_safe_filename ) { return sprintf( '%s.ini', $self->_lc_name ); } return sprintf( 'component-%d.ini', $self->id ); } } my $foo = My::Component->new( id => 42, name => 'Foo' ); is( $foo->config_filename, 'foo.ini', q{$foo->config_filename is 'foo.ini'} ); my $bar4 = My::Component->new( id => 99, name => 'Bar #4' ); is( $bar4->config_filename, 'component-99.ini', q{$bar4->config_filename is 'component-99.ini'} ); }; is( $e, undef, 'no exception thrown running example' ); }; done_testing; 00-basic.t000664001750001750 142714772476615 16363 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite=pod =encoding utf-8 =head1 PURPOSE Test that Sub::HandlesVia works with L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut use strict; use warnings; use Test::More; use Test::Requires '5.008001'; use FindBin qw($Bin); use lib "$Bin/lib"; use MyTest; my $object = MyTest->new; $object->push( 22 ); $object->push( 33 ); $object->push( 44 ); is( $object->pop, 44 ); is_deeply( $object->list, [ 11, 22, 33 ] ); is( $object->pop, 33 ); is_deeply( $object->list, [ 11, 22 ] ); $object->reset; is_deeply( $object->list, [ 11 ] ); done_testing; 01-roles.t000664001750001750 132614772476615 16425 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite=pod =encoding utf-8 =head1 PURPOSE Test that Sub::HandlesVia works with L roles. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut use strict; use warnings; use Test::More; use Test::Requires '5.008001'; use FindBin qw($Bin); use lib "$Bin/lib"; use MyTest::Class1; ok !exists &MyTest::Role1::pop; ok !exists &MyTest::Role2::pop; ok exists &MyTest::Class1::pop; ok !exists &MyTest::Role1::push; ok !exists &MyTest::Role2::push; ok exists &MyTest::Class1::push; done_testing; array.t000664001750001750 2415614772476615 16227 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40miteuse strict; use warnings; ## skip Test::Tabs use Test::More; use Test::Requires '5.008001'; use Test::Fatal; use FindBin qw($Bin); use lib "$Bin/lib"; use MyTest::TestClass::Array; my $CLASS = q[MyTest::TestClass::Array]; ## accessor can_ok( $CLASS, 'my_accessor' ); subtest 'Testing my_accessor' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo', 'bar', 'baz' ] ); $object->my_accessor( 1, 'quux' ); is_deeply( $object->attr, [ 'foo', 'quux', 'baz' ], q{$object->attr deep match} ); is( $object->my_accessor( 2 ), 'baz', q{$object->my_accessor( 2 ) is 'baz'} ); }; is( $e, undef, 'no exception thrown running accessor example' ); }; ## all can_ok( $CLASS, 'my_all' ); subtest 'Testing my_all' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo', 'bar' ] ); my @list = $object->my_all; is_deeply( \@list, [ 'foo', 'bar' ], q{\@list deep match} ); }; is( $e, undef, 'no exception thrown running all example' ); }; ## all_true can_ok( $CLASS, 'my_all_true' ); ## any can_ok( $CLASS, 'my_any' ); subtest 'Testing my_any' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo', 'bar', 'baz' ] ); my $truth = $object->my_any( sub { /a/ } ); ok( $truth, q{$truth is true} ); }; is( $e, undef, 'no exception thrown running any example' ); }; ## apply can_ok( $CLASS, 'my_apply' ); ## clear can_ok( $CLASS, 'my_clear' ); subtest 'Testing my_clear' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo' ] ); $object->my_clear; is_deeply( $object->attr, [], q{$object->attr deep match} ); }; is( $e, undef, 'no exception thrown running clear example' ); }; ## count can_ok( $CLASS, 'my_count' ); subtest 'Testing my_count' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo', 'bar' ] ); is( $object->my_count, 2, q{$object->my_count is 2} ); }; is( $e, undef, 'no exception thrown running count example' ); }; ## delete can_ok( $CLASS, 'my_delete' ); ## elements can_ok( $CLASS, 'my_elements' ); subtest 'Testing my_elements' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo', 'bar' ] ); my @list = $object->my_elements; is_deeply( \@list, [ 'foo', 'bar' ], q{\@list deep match} ); }; is( $e, undef, 'no exception thrown running elements example' ); }; ## first can_ok( $CLASS, 'my_first' ); subtest 'Testing my_first' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo', 'bar', 'baz' ] ); my $found = $object->my_first( sub { /a/ } ); is( $found, 'bar', q{$found is 'bar'} ); }; is( $e, undef, 'no exception thrown running first example' ); }; ## first_index can_ok( $CLASS, 'my_first_index' ); subtest 'Testing my_first_index' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo', 'bar', 'baz' ] ); my $found = $object->my_first_index( sub { /z$/ } ); is( $found, 2, q{$found is 2} ); }; is( $e, undef, 'no exception thrown running first_index example' ); }; ## flatten can_ok( $CLASS, 'my_flatten' ); subtest 'Testing my_flatten' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo', 'bar' ] ); my @list = $object->my_flatten; is_deeply( \@list, [ 'foo', 'bar' ], q{\@list deep match} ); }; is( $e, undef, 'no exception thrown running flatten example' ); }; ## flatten_deep can_ok( $CLASS, 'my_flatten_deep' ); subtest 'Testing my_flatten_deep' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo', [ 'bar', [ 'baz' ] ] ] ); is_deeply( [ $object->my_flatten_deep ], [ 'foo', 'bar', 'baz' ], q{[ $object->my_flatten_deep ] deep match} ); my $object2 = $CLASS->new( attr => [ 'foo', [ 'bar', [ 'baz' ] ] ] ); is_deeply( [ $object->my_flatten_deep(1) ], [ 'foo', 'bar', [ 'baz' ] ], q{[ $object->my_flatten_deep(1) ] deep match} ); }; is( $e, undef, 'no exception thrown running flatten_deep example' ); }; ## for_each can_ok( $CLASS, 'my_for_each' ); subtest 'Testing my_for_each' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo', 'bar', 'baz' ] ); $object->my_for_each( sub { note "Item $_[1] is $_[0]." } ); }; is( $e, undef, 'no exception thrown running for_each example' ); }; ## for_each_pair can_ok( $CLASS, 'my_for_each_pair' ); ## get can_ok( $CLASS, 'my_get' ); subtest 'Testing my_get' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo', 'bar', 'baz' ] ); is( $object->my_get( 0 ), 'foo', q{$object->my_get( 0 ) is 'foo'} ); is( $object->my_get( 1 ), 'bar', q{$object->my_get( 1 ) is 'bar'} ); is( $object->my_get( -1 ), 'baz', q{$object->my_get( -1 ) is 'baz'} ); }; is( $e, undef, 'no exception thrown running get example' ); }; ## grep can_ok( $CLASS, 'my_grep' ); ## head can_ok( $CLASS, 'my_head' ); ## insert can_ok( $CLASS, 'my_insert' ); subtest 'Testing my_insert' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo', 'bar', 'baz' ] ); $object->my_insert( 1, 'quux' ); is_deeply( $object->attr, [ 'foo', 'quux', 'bar', 'baz' ], q{$object->attr deep match} ); }; is( $e, undef, 'no exception thrown running insert example' ); }; ## is_empty can_ok( $CLASS, 'my_is_empty' ); subtest 'Testing my_is_empty' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo', 'bar' ] ); ok( !($object->my_is_empty), q{$object->my_is_empty is false} ); $object->_set_attr( [] ); ok( $object->my_is_empty, q{$object->my_is_empty is true} ); }; is( $e, undef, 'no exception thrown running is_empty example' ); }; ## join can_ok( $CLASS, 'my_join' ); subtest 'Testing my_join' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo', 'bar', 'baz' ] ); is( $object->my_join, 'foo,bar,baz', q{$object->my_join is 'foo,bar,baz'} ); is( $object->my_join( '|' ), 'foo|bar|baz', q{$object->my_join( '|' ) is 'foo|bar|baz'} ); }; is( $e, undef, 'no exception thrown running join example' ); }; ## map can_ok( $CLASS, 'my_map' ); ## max can_ok( $CLASS, 'my_max' ); ## maxstr can_ok( $CLASS, 'my_maxstr' ); ## min can_ok( $CLASS, 'my_min' ); ## minstr can_ok( $CLASS, 'my_minstr' ); ## natatime can_ok( $CLASS, 'my_natatime' ); subtest 'Testing my_natatime' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo', 'bar', 'baz' ] ); my $iter = $object->my_natatime( 2 ); is_deeply( [ $iter->() ], [ 'foo', 'bar' ], q{[ $iter->() ] deep match} ); is_deeply( [ $iter->() ], [ 'baz' ], q{[ $iter->() ] deep match} ); }; is( $e, undef, 'no exception thrown running natatime example' ); }; ## not_all_true can_ok( $CLASS, 'my_not_all_true' ); ## pairfirst can_ok( $CLASS, 'my_pairfirst' ); ## pairgrep can_ok( $CLASS, 'my_pairgrep' ); ## pairkeys can_ok( $CLASS, 'my_pairkeys' ); ## pairmap can_ok( $CLASS, 'my_pairmap' ); ## pairs can_ok( $CLASS, 'my_pairs' ); ## pairvalues can_ok( $CLASS, 'my_pairvalues' ); ## pick_random can_ok( $CLASS, 'my_pick_random' ); ## pop can_ok( $CLASS, 'my_pop' ); subtest 'Testing my_pop' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo', 'bar', 'baz' ] ); is( $object->my_pop, 'baz', q{$object->my_pop is 'baz'} ); is( $object->my_pop, 'bar', q{$object->my_pop is 'bar'} ); is_deeply( $object->attr, [ 'foo' ], q{$object->attr deep match} ); }; is( $e, undef, 'no exception thrown running pop example' ); }; ## print can_ok( $CLASS, 'my_print' ); ## product can_ok( $CLASS, 'my_product' ); ## push can_ok( $CLASS, 'my_push' ); subtest 'Testing my_push' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo' ] ); $object->my_push( 'bar', 'baz' ); is_deeply( $object->attr, [ 'foo', 'bar', 'baz' ], q{$object->attr deep match} ); }; is( $e, undef, 'no exception thrown running push example' ); }; ## reduce can_ok( $CLASS, 'my_reduce' ); ## reductions can_ok( $CLASS, 'my_reductions' ); ## reset can_ok( $CLASS, 'my_reset' ); subtest 'Testing my_reset' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo', 'bar', 'baz' ] ); $object->my_reset; is_deeply( $object->attr, [], q{$object->attr deep match} ); }; is( $e, undef, 'no exception thrown running reset example' ); }; ## reverse can_ok( $CLASS, 'my_reverse' ); ## sample can_ok( $CLASS, 'my_sample' ); ## set can_ok( $CLASS, 'my_set' ); subtest 'Testing my_set' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo', 'bar', 'baz' ] ); $object->my_set( 1, 'quux' ); is_deeply( $object->attr, [ 'foo', 'quux', 'baz' ], q{$object->attr deep match} ); }; is( $e, undef, 'no exception thrown running set example' ); }; ## shallow_clone can_ok( $CLASS, 'my_shallow_clone' ); ## shift can_ok( $CLASS, 'my_shift' ); subtest 'Testing my_shift' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo', 'bar', 'baz' ] ); is( $object->my_shift, 'foo', q{$object->my_shift is 'foo'} ); is( $object->my_shift, 'bar', q{$object->my_shift is 'bar'} ); is_deeply( $object->attr, [ 'baz' ], q{$object->attr deep match} ); }; is( $e, undef, 'no exception thrown running shift example' ); }; ## shuffle can_ok( $CLASS, 'my_shuffle' ); ## shuffle_in_place can_ok( $CLASS, 'my_shuffle_in_place' ); ## sort can_ok( $CLASS, 'my_sort' ); ## sort_in_place can_ok( $CLASS, 'my_sort_in_place' ); ## splice can_ok( $CLASS, 'my_splice' ); ## sum can_ok( $CLASS, 'my_sum' ); ## tail can_ok( $CLASS, 'my_tail' ); ## uniq can_ok( $CLASS, 'my_uniq' ); ## uniq_in_place can_ok( $CLASS, 'my_uniq_in_place' ); ## uniqnum can_ok( $CLASS, 'my_uniqnum' ); ## uniqnum_in_place can_ok( $CLASS, 'my_uniqnum_in_place' ); ## uniqstr can_ok( $CLASS, 'my_uniqstr' ); ## uniqstr_in_place can_ok( $CLASS, 'my_uniqstr_in_place' ); ## unshift can_ok( $CLASS, 'my_unshift' ); subtest 'Testing my_unshift' => sub { my $e = exception { my $object = $CLASS->new( attr => [ 'foo' ] ); $object->my_unshift( 'bar', 'baz' ); is_deeply( $object->attr, [ 'bar', 'baz', 'foo' ], q{$object->attr deep match} ); }; is( $e, undef, 'no exception thrown running unshift example' ); }; done_testing; bool.t000664001750001750 267314772476615 16024 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40miteuse strict; use warnings; ## skip Test::Tabs use Test::More; use Test::Requires '5.008001'; use Test::Fatal; use FindBin qw($Bin); use lib "$Bin/lib"; use MyTest::TestClass::Bool; my $CLASS = q[MyTest::TestClass::Bool]; ## not can_ok( $CLASS, 'my_not' ); subtest 'Testing my_not' => sub { my $e = exception { my $object = $CLASS->new( attr => 1 ); ok( !($object->my_not()), q{$object->my_not() is false} ); }; is( $e, undef, 'no exception thrown running not example' ); }; ## reset can_ok( $CLASS, 'my_reset' ); ## set can_ok( $CLASS, 'my_set' ); subtest 'Testing my_set' => sub { my $e = exception { my $object = $CLASS->new(); $object->my_set(); ok( $object->attr, q{$object->attr is true} ); }; is( $e, undef, 'no exception thrown running set example' ); }; ## toggle can_ok( $CLASS, 'my_toggle' ); subtest 'Testing my_toggle' => sub { my $e = exception { my $object = $CLASS->new(); $object->my_toggle(); ok( $object->attr, q{$object->attr is true} ); $object->my_toggle(); ok( !($object->attr), q{$object->attr is false} ); }; is( $e, undef, 'no exception thrown running toggle example' ); }; ## unset can_ok( $CLASS, 'my_unset' ); subtest 'Testing my_unset' => sub { my $e = exception { my $object = $CLASS->new(); $object->my_unset(); ok( !($object->attr), q{$object->attr is false} ); }; is( $e, undef, 'no exception thrown running unset example' ); }; done_testing; code.t000664001750001750 1023014772476615 16007 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40miteuse strict; use warnings; ## skip Test::Tabs use Test::More; use Test::Requires '5.008001'; use Test::Fatal; use FindBin qw($Bin); use lib "$Bin/lib"; use MyTest::TestClass::Code; my $CLASS = q[MyTest::TestClass::Code]; ## execute can_ok( $CLASS, 'my_execute' ); subtest 'Testing my_execute' => sub { my $e = exception { my $coderef = sub { 'code' }; my $object = $CLASS->new( attr => $coderef ); # Calls: $coderef->( 1, 2, 3 ) $object->my_execute( 1, 2, 3 ); }; is( $e, undef, 'no exception thrown running execute example' ); }; ## execute_list can_ok( $CLASS, 'my_execute_list' ); subtest 'Testing my_execute_list' => sub { my $e = exception { my $context; my $coderef = sub { $context = wantarray(); 'code' }; my $object = $CLASS->new( attr => $coderef ); # Calls: $coderef->( 1, 2, 3 ) my $result = $object->my_execute_list( 1, 2, 3 ); is_deeply( $result, [ 'code' ], q{$result deep match} ); ok( $context, q{$context is true} ); }; is( $e, undef, 'no exception thrown running execute_list example' ); }; ## execute_method can_ok( $CLASS, 'my_execute_method' ); subtest 'Testing my_execute_method' => sub { my $e = exception { my $coderef = sub { 'code' }; my $object = $CLASS->new( attr => $coderef ); # Calls: $coderef->( $object, 1, 2, 3 ) $object->my_execute_method( 1, 2, 3 ); }; is( $e, undef, 'no exception thrown running execute_method example' ); }; ## execute_method_list can_ok( $CLASS, 'my_execute_method_list' ); subtest 'Testing my_execute_method_list' => sub { my $e = exception { my $context; my $coderef = sub { $context = wantarray(); 'code' }; my $object = $CLASS->new( attr => $coderef ); # Calls: $coderef->( $object, 1, 2, 3 ) my $result = $object->my_execute_method_list( 1, 2, 3 ); is_deeply( $result, [ 'code' ], q{$result deep match} ); ok( $context, q{$context is true} ); }; is( $e, undef, 'no exception thrown running execute_method_list example' ); }; ## execute_method_scalar can_ok( $CLASS, 'my_execute_method_scalar' ); subtest 'Testing my_execute_method_scalar' => sub { my $e = exception { my $context; my $coderef = sub { $context = wantarray(); 'code' }; my $object = $CLASS->new( attr => $coderef ); # Calls: $coderef->( $object, 1, 2, 3 ) my $result = $object->my_execute_method_scalar( 1, 2, 3 ); is( $result, 'code', q{$result is 'code'} ); ok( !($context), q{$context is false} ); }; is( $e, undef, 'no exception thrown running execute_method_scalar example' ); }; ## execute_method_void can_ok( $CLASS, 'my_execute_method_void' ); subtest 'Testing my_execute_method_void' => sub { my $e = exception { my $context; my $coderef = sub { $context = wantarray(); 'code' }; my $object = $CLASS->new( attr => $coderef ); # Calls: $coderef->( $object, 1, 2, 3 ) my $result = $object->my_execute_method_void( 1, 2, 3 ); is( $result, undef, q{$result is undef} ); is( $context, undef, q{$context is undef} ); }; is( $e, undef, 'no exception thrown running execute_method_void example' ); }; ## execute_scalar can_ok( $CLASS, 'my_execute_scalar' ); subtest 'Testing my_execute_scalar' => sub { my $e = exception { my $context; my $coderef = sub { $context = wantarray(); 'code' }; my $object = $CLASS->new( attr => $coderef ); # Calls: $coderef->( 1, 2, 3 ) my $result = $object->my_execute_scalar( 1, 2, 3 ); is( $result, 'code', q{$result is 'code'} ); ok( !($context), q{$context is false} ); }; is( $e, undef, 'no exception thrown running execute_scalar example' ); }; ## execute_void can_ok( $CLASS, 'my_execute_void' ); subtest 'Testing my_execute_void' => sub { my $e = exception { my $context; my $coderef = sub { $context = wantarray(); 'code' }; my $object = $CLASS->new( attr => $coderef ); # Calls: $coderef->( 1, 2, 3 ) my $result = $object->my_execute_void( 1, 2, 3 ); is( $result, undef, q{$result is undef} ); is( $context, undef, q{$context is undef} ); }; is( $e, undef, 'no exception thrown running execute_void example' ); }; done_testing; counter.t000664001750001750 304314772476615 16540 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40miteuse strict; use warnings; ## skip Test::Tabs use Test::More; use Test::Requires '5.008001'; use Test::Fatal; use FindBin qw($Bin); use lib "$Bin/lib"; use MyTest::TestClass::Counter; my $CLASS = q[MyTest::TestClass::Counter]; ## dec can_ok( $CLASS, 'my_dec' ); subtest 'Testing my_dec' => sub { my $e = exception { my $object = $CLASS->new( attr => 10 ); $object->my_dec; $object->my_dec; is( $object->attr, 8, q{$object->attr is 8} ); $object->my_dec( 5 ); is( $object->attr, 3, q{$object->attr is 3} ); }; is( $e, undef, 'no exception thrown running dec example' ); }; ## inc can_ok( $CLASS, 'my_inc' ); subtest 'Testing my_inc' => sub { my $e = exception { my $object = $CLASS->new( attr => 0 ); $object->my_inc; $object->my_inc; is( $object->attr, 2, q{$object->attr is 2} ); $object->my_inc( 3 ); is( $object->attr, 5, q{$object->attr is 5} ); }; is( $e, undef, 'no exception thrown running inc example' ); }; ## reset can_ok( $CLASS, 'my_reset' ); subtest 'Testing my_reset' => sub { my $e = exception { my $object = $CLASS->new( attr => 10 ); $object->my_reset; is( $object->attr, 0, q{$object->attr is 0} ); }; is( $e, undef, 'no exception thrown running reset example' ); }; ## set can_ok( $CLASS, 'my_set' ); subtest 'Testing my_set' => sub { my $e = exception { my $object = $CLASS->new( attr => 0 ); $object->my_set( 5 ); is( $object->attr, 5, q{$object->attr is 5} ); }; is( $e, undef, 'no exception thrown running set example' ); }; done_testing; hash.t000664001750001750 1307514772476615 16032 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40miteuse strict; use warnings; ## skip Test::Tabs use Test::More; use Test::Requires '5.008001'; use Test::Fatal; use FindBin qw($Bin); use lib "$Bin/lib"; use MyTest::TestClass::Hash; my $CLASS = q[MyTest::TestClass::Hash]; ## accessor can_ok( $CLASS, 'my_accessor' ); ## all can_ok( $CLASS, 'my_all' ); subtest 'Testing my_all' => sub { my $e = exception { my $object = $CLASS->new( attr => { foo => 0, bar => 1 } ); my %hash = $object->my_all; }; is( $e, undef, 'no exception thrown running all example' ); }; ## clear can_ok( $CLASS, 'my_clear' ); subtest 'Testing my_clear' => sub { my $e = exception { my $object = $CLASS->new( attr => { foo => 0, bar => 1 } ); $object->my_clear; ok( !(exists $object->attr->{foo}), q{exists $object->attr->{foo} is false} ); ok( !(exists $object->attr->{bar}), q{exists $object->attr->{bar} is false} ); }; is( $e, undef, 'no exception thrown running clear example' ); }; ## count can_ok( $CLASS, 'my_count' ); subtest 'Testing my_count' => sub { my $e = exception { my $object = $CLASS->new( attr => { foo => 0, bar => 1 } ); is( $object->my_count, 2, q{$object->my_count is 2} ); }; is( $e, undef, 'no exception thrown running count example' ); }; ## defined can_ok( $CLASS, 'my_defined' ); subtest 'Testing my_defined' => sub { my $e = exception { my $object = $CLASS->new( attr => { foo => 0, bar => 1 } ); is( $object->my_defined( 'foo' ), 1, q{$object->my_defined( 'foo' ) is 1} ); }; is( $e, undef, 'no exception thrown running defined example' ); }; ## delete can_ok( $CLASS, 'my_delete' ); subtest 'Testing my_delete' => sub { my $e = exception { my $object = $CLASS->new( attr => { foo => 0, bar => 1 } ); $object->my_delete( 'foo' ); ok( !(exists $object->attr->{foo}), q{exists $object->attr->{foo} is false} ); }; is( $e, undef, 'no exception thrown running delete example' ); }; ## delete_where can_ok( $CLASS, 'my_delete_where' ); subtest 'Testing my_delete_where' => sub { my $e = exception { my $object = $CLASS->new( attr => { foo => 0, bar => 1, baz => 2 } ); $object->my_delete_where( sub { $_ eq 'foo' or $_ eq 'bar' } ); is_deeply( $object->attr, { baz => 2 }, q{$object->attr deep match} ); my $object2 = $CLASS->new( attr => { foo => 0, bar => 1, baz => 2 } ); $object2->my_delete_where( qr/^b/ ); is_deeply( $object2->attr, { foo => 0 }, q{$object2->attr deep match} ); }; is( $e, undef, 'no exception thrown running delete_where example' ); }; ## elements can_ok( $CLASS, 'my_elements' ); subtest 'Testing my_elements' => sub { my $e = exception { my $object = $CLASS->new( attr => { foo => 0, bar => 1 } ); my %hash = $object->my_elements; }; is( $e, undef, 'no exception thrown running elements example' ); }; ## exists can_ok( $CLASS, 'my_exists' ); subtest 'Testing my_exists' => sub { my $e = exception { my $object = $CLASS->new( attr => { foo => 0, bar => 1 } ); ok( $object->my_exists( 'foo' ), q{$object->my_exists( 'foo' ) is true} ); ok( !($object->my_exists( 'baz' )), q{$object->my_exists( 'baz' ) is false} ); }; is( $e, undef, 'no exception thrown running exists example' ); }; ## for_each_key can_ok( $CLASS, 'my_for_each_key' ); ## for_each_pair can_ok( $CLASS, 'my_for_each_pair' ); ## for_each_value can_ok( $CLASS, 'my_for_each_value' ); ## get can_ok( $CLASS, 'my_get' ); subtest 'Testing my_get' => sub { my $e = exception { my $object = $CLASS->new( attr => { foo => 0, bar => 1 } ); is( $object->my_get( 'bar' ), 1, q{$object->my_get( 'bar' ) is 1} ); }; is( $e, undef, 'no exception thrown running get example' ); }; ## is_empty can_ok( $CLASS, 'my_is_empty' ); subtest 'Testing my_is_empty' => sub { my $e = exception { my $object = $CLASS->new( attr => { foo => 0, bar => 1 } ); ok( !($object->my_is_empty), q{$object->my_is_empty is false} ); $object->_set_attr( {} ); ok( $object->my_is_empty, q{$object->my_is_empty is true} ); }; is( $e, undef, 'no exception thrown running is_empty example' ); }; ## keys can_ok( $CLASS, 'my_keys' ); subtest 'Testing my_keys' => sub { my $e = exception { my $object = $CLASS->new( attr => { foo => 0, bar => 1 } ); # says 'foo' and 'bar' in an unpredictable order note for $object->my_keys; }; is( $e, undef, 'no exception thrown running keys example' ); }; ## kv can_ok( $CLASS, 'my_kv' ); ## reset can_ok( $CLASS, 'my_reset' ); ## set can_ok( $CLASS, 'my_set' ); subtest 'Testing my_set' => sub { my $e = exception { my $object = $CLASS->new( attr => { foo => 0, bar => 1 } ); $object->my_set( bar => 2, baz => 1 ); is( $object->attr->{foo}, 0, q{$object->attr->{foo} is 0} ); is( $object->attr->{baz}, 1, q{$object->attr->{baz} is 1} ); is( $object->attr->{bar}, 2, q{$object->attr->{bar} is 2} ); }; is( $e, undef, 'no exception thrown running set example' ); }; ## shallow_clone can_ok( $CLASS, 'my_shallow_clone' ); ## sorted_keys can_ok( $CLASS, 'my_sorted_keys' ); subtest 'Testing my_sorted_keys' => sub { my $e = exception { my $object = $CLASS->new( attr => { foo => 0, bar => 1 } ); # says 'bar' then 'foo' note for $object->my_sorted_keys; }; is( $e, undef, 'no exception thrown running sorted_keys example' ); }; ## values can_ok( $CLASS, 'my_values' ); subtest 'Testing my_values' => sub { my $e = exception { my $object = $CLASS->new( attr => { foo => 0, bar => 1 } ); # says '0' and '1' in an unpredictable order note for $object->my_values; }; is( $e, undef, 'no exception thrown running values example' ); }; done_testing; number.t000664001750001750 525714772476615 16362 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40miteuse strict; use warnings; ## skip Test::Tabs use Test::More; use Test::Requires '5.008001'; use Test::Fatal; use FindBin qw($Bin); use lib "$Bin/lib"; use MyTest::TestClass::Number; my $CLASS = q[MyTest::TestClass::Number]; ## abs can_ok( $CLASS, 'my_abs' ); subtest 'Testing my_abs' => sub { my $e = exception { my $object = $CLASS->new( attr => -5 ); $object->my_abs; is( $object->attr, 5, q{$object->attr is 5} ); }; is( $e, undef, 'no exception thrown running abs example' ); }; ## add can_ok( $CLASS, 'my_add' ); subtest 'Testing my_add' => sub { my $e = exception { my $object = $CLASS->new( attr => 4 ); $object->my_add( 5 ); is( $object->attr, 9, q{$object->attr is 9} ); }; is( $e, undef, 'no exception thrown running add example' ); }; ## cmp can_ok( $CLASS, 'my_cmp' ); ## div can_ok( $CLASS, 'my_div' ); subtest 'Testing my_div' => sub { my $e = exception { my $object = $CLASS->new( attr => 6 ); $object->my_div( 2 ); is( $object->attr, 3, q{$object->attr is 3} ); }; is( $e, undef, 'no exception thrown running div example' ); }; ## eq can_ok( $CLASS, 'my_eq' ); ## ge can_ok( $CLASS, 'my_ge' ); ## get can_ok( $CLASS, 'my_get' ); subtest 'Testing my_get' => sub { my $e = exception { my $object = $CLASS->new( attr => 4 ); is( $object->my_get, 4, q{$object->my_get is 4} ); }; is( $e, undef, 'no exception thrown running get example' ); }; ## gt can_ok( $CLASS, 'my_gt' ); ## le can_ok( $CLASS, 'my_le' ); ## lt can_ok( $CLASS, 'my_lt' ); ## mod can_ok( $CLASS, 'my_mod' ); subtest 'Testing my_mod' => sub { my $e = exception { my $object = $CLASS->new( attr => 5 ); $object->my_mod( 2 ); is( $object->attr, 1, q{$object->attr is 1} ); }; is( $e, undef, 'no exception thrown running mod example' ); }; ## mul can_ok( $CLASS, 'my_mul' ); subtest 'Testing my_mul' => sub { my $e = exception { my $object = $CLASS->new( attr => 2 ); $object->my_mul( 5 ); is( $object->attr, 10, q{$object->attr is 10} ); }; is( $e, undef, 'no exception thrown running mul example' ); }; ## ne can_ok( $CLASS, 'my_ne' ); ## set can_ok( $CLASS, 'my_set' ); subtest 'Testing my_set' => sub { my $e = exception { my $object = $CLASS->new( attr => 4 ); $object->my_set( 5 ); is( $object->attr, 5, q{$object->attr is 5} ); }; is( $e, undef, 'no exception thrown running set example' ); }; ## sub can_ok( $CLASS, 'my_sub' ); subtest 'Testing my_sub' => sub { my $e = exception { my $object = $CLASS->new( attr => 9 ); $object->my_sub( 6 ); is( $object->attr, 3, q{$object->attr is 3} ); }; is( $e, undef, 'no exception thrown running sub example' ); }; done_testing; scalar.t000664001750001750 245714772476615 16336 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40miteuse strict; use warnings; ## skip Test::Tabs use Test::More; use Test::Requires '5.008001'; use Test::Fatal; use FindBin qw($Bin); use lib "$Bin/lib"; use MyTest::TestClass::Scalar; my $CLASS = q[MyTest::TestClass::Scalar]; ## make_getter can_ok( $CLASS, 'my_make_getter' ); subtest 'Testing my_make_getter' => sub { my $e = exception { my $object = $CLASS->new( attr => 10 ); my $getter = $object->my_make_getter; $object->_set_attr( 11 ); is( $getter->(), 11, q{$getter->() is 11} ); }; is( $e, undef, 'no exception thrown running make_getter example' ); }; ## make_setter can_ok( $CLASS, 'my_make_setter' ); subtest 'Testing my_make_setter' => sub { my $e = exception { my $object = $CLASS->new( attr => 10 ); my $setter = $object->my_make_setter; $setter->( 11 ); is( $object->attr, 11, q{$object->attr is 11} ); }; is( $e, undef, 'no exception thrown running make_setter example' ); }; ## scalar_reference can_ok( $CLASS, 'my_scalar_reference' ); subtest 'Testing my_scalar_reference' => sub { my $e = exception { my $object = $CLASS->new( attr => 10 ); my $ref = $object->my_scalar_reference; $$ref++; is( $object->attr, 11, q{$object->attr is 11} ); }; is( $e, undef, 'no exception thrown running scalar_reference example' ); }; done_testing; string.t000664001750001750 1125414772476615 16412 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40miteuse strict; use warnings; ## skip Test::Tabs use Test::More; use Test::Requires '5.008001'; use Test::Fatal; use FindBin qw($Bin); use lib "$Bin/lib"; use MyTest::TestClass::String; my $CLASS = q[MyTest::TestClass::String]; ## append can_ok( $CLASS, 'my_append' ); subtest 'Testing my_append' => sub { my $e = exception { my $object = $CLASS->new( attr => 'foo' ); $object->my_append( 'bar' ); is( $object->attr, 'foobar', q{$object->attr is 'foobar'} ); }; is( $e, undef, 'no exception thrown running append example' ); }; ## chomp can_ok( $CLASS, 'my_chomp' ); ## chop can_ok( $CLASS, 'my_chop' ); ## clear can_ok( $CLASS, 'my_clear' ); subtest 'Testing my_clear' => sub { my $e = exception { my $object = $CLASS->new( attr => 'foo' ); $object->my_clear; note $object->attr; ## nothing }; is( $e, undef, 'no exception thrown running clear example' ); }; ## cmp can_ok( $CLASS, 'my_cmp' ); ## cmpi can_ok( $CLASS, 'my_cmpi' ); ## contains can_ok( $CLASS, 'my_contains' ); ## contains_i can_ok( $CLASS, 'my_contains_i' ); ## ends_with can_ok( $CLASS, 'my_ends_with' ); ## ends_with_i can_ok( $CLASS, 'my_ends_with_i' ); ## eq can_ok( $CLASS, 'my_eq' ); ## eqi can_ok( $CLASS, 'my_eqi' ); ## fc can_ok( $CLASS, 'my_fc' ); ## ge can_ok( $CLASS, 'my_ge' ); ## gei can_ok( $CLASS, 'my_gei' ); ## get can_ok( $CLASS, 'my_get' ); subtest 'Testing my_get' => sub { my $e = exception { my $object = $CLASS->new( attr => 'foo' ); is( $object->my_get, 'foo', q{$object->my_get is 'foo'} ); }; is( $e, undef, 'no exception thrown running get example' ); }; ## gt can_ok( $CLASS, 'my_gt' ); ## gti can_ok( $CLASS, 'my_gti' ); ## inc can_ok( $CLASS, 'my_inc' ); ## lc can_ok( $CLASS, 'my_lc' ); ## le can_ok( $CLASS, 'my_le' ); ## lei can_ok( $CLASS, 'my_lei' ); ## length can_ok( $CLASS, 'my_length' ); subtest 'Testing my_length' => sub { my $e = exception { my $object = $CLASS->new( attr => 'foo' ); is( $object->my_length, 3, q{$object->my_length is 3} ); }; is( $e, undef, 'no exception thrown running length example' ); }; ## lt can_ok( $CLASS, 'my_lt' ); ## lti can_ok( $CLASS, 'my_lti' ); ## match can_ok( $CLASS, 'my_match' ); subtest 'Testing my_match' => sub { my $e = exception { my $object = $CLASS->new( attr => 'foo' ); if ( $object->my_match( '^f..$' ) ) { note 'matched!'; } }; is( $e, undef, 'no exception thrown running match example' ); }; ## match_i can_ok( $CLASS, 'my_match_i' ); subtest 'Testing my_match_i' => sub { my $e = exception { my $object = $CLASS->new( attr => 'foo' ); if ( $object->my_match_i( '^F..$' ) ) { note 'matched!'; } }; is( $e, undef, 'no exception thrown running match_i example' ); }; ## ne can_ok( $CLASS, 'my_ne' ); ## nei can_ok( $CLASS, 'my_nei' ); ## prepend can_ok( $CLASS, 'my_prepend' ); subtest 'Testing my_prepend' => sub { my $e = exception { my $object = $CLASS->new( attr => 'foo' ); $object->my_prepend( 'bar' ); is( $object->attr, 'barfoo', q{$object->attr is 'barfoo'} ); }; is( $e, undef, 'no exception thrown running prepend example' ); }; ## replace can_ok( $CLASS, 'my_replace' ); subtest 'Testing my_replace' => sub { my $e = exception { my $object = $CLASS->new( attr => 'foo' ); $object->my_replace( 'o' => 'a' ); is( $object->attr, 'fao', q{$object->attr is 'fao'} ); my $object2 = $CLASS->new( attr => 'foo' ); $object2->my_replace( qr/O/i => sub { return 'e' } ); is( $object2->attr, 'feo', q{$object2->attr is 'feo'} ); }; is( $e, undef, 'no exception thrown running replace example' ); }; ## replace_globally can_ok( $CLASS, 'my_replace_globally' ); subtest 'Testing my_replace_globally' => sub { my $e = exception { my $object = $CLASS->new( attr => 'foo' ); $object->my_replace_globally( 'o' => 'a' ); is( $object->attr, 'faa', q{$object->attr is 'faa'} ); my $object2 = $CLASS->new( attr => 'foo' ); $object2->my_replace_globally( qr/O/i => sub { return 'e' } ); is( $object2->attr, 'fee', q{$object2->attr is 'fee'} ); }; is( $e, undef, 'no exception thrown running replace_globally example' ); }; ## reset can_ok( $CLASS, 'my_reset' ); ## set can_ok( $CLASS, 'my_set' ); subtest 'Testing my_set' => sub { my $e = exception { my $object = $CLASS->new( attr => 'foo' ); $object->my_set( 'bar' ); is( $object->attr, 'bar', q{$object->attr is 'bar'} ); }; is( $e, undef, 'no exception thrown running set example' ); }; ## starts_with can_ok( $CLASS, 'my_starts_with' ); ## starts_with_i can_ok( $CLASS, 'my_starts_with_i' ); ## substr can_ok( $CLASS, 'my_substr' ); ## uc can_ok( $CLASS, 'my_uc' ); done_testing; CodeGenerator.pm000664001750001750 6151514772476615 21753 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesViause 5.008; use strict; use warnings; package Sub::HandlesVia::CodeGenerator; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Sub::HandlesVia::Mite -all; has toolkit => ( is => ro, ); has target => ( is => ro, ); has attribute => ( is => ro, ); has attribute_spec => ( is => ro, isa => 'HashRef', ); has isa => ( is => ro, ); has coerce => ( is => ro, isa => 'Bool', ); has env => ( is => ro, isa => 'HashRef', default => \ '{}', default_is_trusted => true, ); has sandboxing_package => ( is => ro, isa => 'Str|Undef', default => sprintf( '%s::__SANDBOX__', __PACKAGE__ ), default_is_trusted => true, ); has [ 'generator_for_slot', 'generator_for_get', 'generator_for_set', 'generator_for_default' ] => ( is => ro, isa => 'CodeRef', ); has generator_for_args => ( is => ro, isa => 'CodeRef', builder => sub { return sub { '@_[1..$#_]'; }; }, default_is_trusted => true, ); has generator_for_arg => ( is => ro, isa => 'CodeRef', builder => sub { return sub { @_==2 or die; my $n = pop; "\$_[$n]"; }; }, default_is_trusted => true, ); has generator_for_argc => ( is => ro, isa => 'CodeRef', builder => sub { return sub { '(@_-1)'; }; }, default_is_trusted => true, ); has generator_for_currying => ( is => ro, isa => 'CodeRef', builder => sub { return sub { @_==2 or die; my $arr = pop; "splice(\@_,1,0,$arr);"; }; }, default_is_trusted => true, ); has generator_for_usage_string => ( is => ro, isa => 'CodeRef', builder => sub { return sub { @_==3 or die; shift; my $method_name = shift; my $guts = shift; "\$instance->$method_name($guts)"; }; }, default_is_trusted => true, ); has generator_for_self => ( is => ro, isa => 'CodeRef', builder => sub { return sub { '$_[0]'; }; }, default_is_trusted => true, ); has generator_for_type_assertion => ( is => ro, isa => 'CodeRef', builder => sub { return sub { my ( $gen, $env, $type, $varname ) = @_; my $i = 0; my $type_varname = sprintf '$shv_type_constraint_%d', $type->{uniq}; $env->{$type_varname} = \$type; if ( $gen->coerce and $type->has_coercion ) { if ( $type->coercion->can_be_inlined ) { return sprintf '%s=%s;%s;', $varname, $type->coercion->inline_coercion($varname), $type->inline_assert( $varname, $type_varname ); } else { return sprintf '%s=%s->assert_coerce(%s);', $varname, $type_varname, $varname; } } return $type->inline_assert( $varname, $type_varname ); }; }, default_is_trusted => true, ); has generator_for_error => ( is => ro, isa => 'CodeRef', builder => sub { return sub { my ( $gen, $error ) = @_; sprintf 'do { require Carp; Carp::croak(%s) }', $error; }; }, default_is_trusted => true, ); has generator_for_prelude => ( is => ro, isa => 'CodeRef', builder => sub { return sub { '' }; }, default_is_trusted => true, ); has method_installer => ( is => rw, isa => 'CodeRef', ); has _override => ( is => rw, init_arg => undef, ); has is_method => ( is => ro, default => true, ); has get_is_lvalue => ( is => ro, default => false, ); has set_checks_isa => ( is => ro, default => false, ); has set_strictly => ( is => ro, default => true, ); my $REASONABLE_SCALAR = qr/^ \$ # scalar access [^\W0-9]\w* # normal-looking variable name (including $_) (?: # then... (?:\-\>)? # dereference maybe [\[\{] # opening [ or { [\'\"]? # quote maybe \w+ # word characters (includes digits) [\'\"]? # quote maybe [\]\}] # closing ] or } ){0,3} # ... up to thrice $/x; my @generatable_things = qw( slot get set default arg args argc currying usage_string self type_assertion error prelude ); for my $thing ( @generatable_things ) { my $generator = "generator_for_$thing"; my $method_name = "generate_$thing"; my $method = sub { my $gen = shift; local ${^GENERATOR} = $gen; if ( @{ $gen->_override->{$thing} || [] } ) { my $coderef = pop @{ $gen->_override->{$thing} }; my $guard = guard { push @{ $gen->_override->{$thing} ||= [] }, $coderef; }; return $gen->$coderef( @_ ); } return $gen->$generator->( $gen, @_ ); }; no strict 'refs'; *$method_name = $method; } sub attribute_name { my $self = shift; my $attr = $self->attribute; return $attr if !ref $attr; return sprintf '$instance->%s', $attr->[0] if ref($attr) eq 'ARRAY'; return '$attribute_value'; } sub _start_overriding_generators { my $self = shift; $self->_override( {} ); return guard { $self->_override( {} ); }; } { my %generatable_thing = map +( $_ => 1 ), @generatable_things; sub _add_generator_override { my ( $self, %overrides ) = @_; while ( my ( $key, $value ) = each %overrides ) { next if !defined $value; next if !$generatable_thing{$key}; push @{ $self->_override->{$key} ||= [] }, $value; } return $self; } } sub generate_and_install_method { my ( $self, $method_name, $handler ) = @_; $self->install_method( $method_name, $self->generate_coderef_for_handler( $method_name, $handler ), ); } { my $sub_rename; if ( eval { require Sub::Util } ) { $sub_rename = Sub::Util->can('set_subname'); } elsif ( eval { require Sub::Name } ) { $sub_rename = Sub::Name->can('subname'); } sub install_method { my ( $self, $method_name, $coderef ) = @_; my $target = $self->target; eval { $coderef = $sub_rename->( "$target\::$method_name", $coderef ) } if ref $sub_rename; if ( $self->method_installer ) { $self->method_installer->( $method_name, $coderef ); } else { no strict 'refs'; *{"$target\::$method_name"} = $coderef; } } } sub generate_coderef_for_handler { my ( $self, $method_name, $handler ) = @_; my $ec_args = $self->_generate_ec_args_for_handler( $method_name, $handler ); # warn "#### $method_name"; # warn join("\n", @{$ec_args->{source}}); # for my $key (sort keys %{$ec_args->{environment}}) { # warn ">> $key : ".ref($ec_args->{environment}{$key}); # if ( ref($ec_args->{environment}{$key}) eq 'REF' and ref(${$ec_args->{environment}{$key}}) eq 'CODE' ) { # require B::Deparse; # warn B::Deparse->new->coderef2text(${$ec_args->{environment}{$key}}); # } # } require Eval::TypeTiny; Eval::TypeTiny::eval_closure( %$ec_args ); } sub _generate_ec_args_for_handler { my ( $self, $method_name, $handler ) = @_; # Later on, we might need to override the generators for # arg, argc, args, set, etc. # my $guard = $self->_start_overriding_generators; # Make a COPY of $self->env! # my $env = { %{$self->env} }; # Preamble code. # my $code = [ 'sub {', ]; push @$code, sprintf( 'package %s;', $self->sandboxing_package ) if $self->sandboxing_package; # Need to maintain state between following method calls. A proper # object might be nice, but a hashref will do for now. # my $state = { signature_check_needed => true, # hasn't been done yet final_type_check_needed => $handler->is_mutator, getter => scalar($self->generate_get), getter_is_lvalue => $self->get_is_lvalue, template_wrapper => undef, # nothing yet add_later => undef, # nothing yet shifted_self => false, }; # use Hash::Util qw( lock_ref_keys ); # lock_ref_keys( $state ); my @args = ( $method_name, # Intended name for the coderef being generated $handler, # Info about the functionality being delegated $env, # Variables which need to be closed over $code, # Lines of code in the method $state, # Shared state while building method. (Minimal!) ); $self ->_handle_sigcheck( @args ) # check method sigs ->_handle_prelude( @args ) # insert any prelude ->_handle_shiftself( @args ) # $self = shift ->_handle_currying( @args ) # push curried values to @_ ->_handle_additional_validation( @args ) # additional type checks ->_handle_getter_code( @args ) # optimize calling getter ->_handle_setter_code( @args ) # make calling setter safer ->_handle_template( @args ) # perform code substitutes ->_handle_chaining( @args ); # return $self if requested # Postamble code. Can't really do much here because the template # might want to be able to return something. # push @$code, "}"; # Allow the handler to inject variables into the environment. # Rarely needed. # $handler->_tweak_env( $env ); return { source => $code, environment => $env, description => sprintf( "%s=%s", $method_name || '__ANON__', $handler->name, ), }; } sub _handle_sigcheck { my ( $self, $method_name, $handler, $env, $code, $state ) = @_; # If there's a proper signature for the method... # if ( @{ $handler->signature || [] } ) { # Generate code using Type::Params to check the signature. # We also need to close over the signature. # require Type::Params; unshift @$code, 'my $__sigcheck;'; $env->{'@__sig'} = $handler->signature; if ( $state->{shifted_self} ) { push @$code, '$__sigcheck||=Type::Params::compile(@__sig);@_=&$__sigcheck;'; } else { push @$code, '$__sigcheck||=Type::Params::compile(1, @__sig);@_=&$__sigcheck;'; } # As we've now inserted a signature check, we can stop worrying # about signature checks. # $state->{signature_check_needed} = 0; } # There is no proper signature, but there's still check the # arity of the method. # else { # What is the arity? # my $min_args = $handler->min_args || 0; my $max_args = $handler->max_args; my $plus = 1; if ( $state->{shifted_self} ) { $plus = 0; } # What usage message do we want to print if wrong arity? # my $usg = $self->generate_error( sprintf( ' "Wrong number of parameters; usage: " . %s ', B::perlstring( $self->generate_usage_string( $method_name, $handler->usage ) ), ) ); # Insert the check into the code. # if (defined $min_args and defined $max_args and $min_args==$max_args) { push @$code, sprintf('@_==%d or %s;', $min_args + $plus, $usg); } elsif (defined $min_args and defined $max_args) { push @$code, sprintf('(@_ >= %d and @_ <= %d) or %s;', $min_args + $plus, $max_args + $plus, $usg); } elsif (defined $min_args and $min_args > 0) { push @$code, sprintf('@_ >= %d or %s;', $min_args + $plus, $usg); } # We are still lacking a proper signature check though, so note # that in the state. The information can be used by # additional_validation coderefs. # $state->{signature_check_needed} = true; } return $self; } sub _handle_prelude { my ( $self, $method_name, $handler, $env, $code, $state ) = @_; push @$code, grep !!$_, $self->generate_prelude(); return $self; } sub _handle_shiftself { my ( $self, $method_name, $handler, $env, $code, $state ) = @_; # Handlers which use @ARG will benefit from shifting $self # off @_, but for other handlers, this will just slow compilation # down (but not much). # return $self unless $handler->curried || $handler->prefer_shift_self; # Shift off the invocant. # push @$code, 'my $shv_self=shift;'; $self->_add_generator_override( # Override $ARG[$n] because the array has been reindexed. # arg => sub { my ($gen, $n) = @_; $gen->generate_arg( $n - 1 ) }, # Overrride @ARG to point to the whole array. This is the # real speed-up! # args => sub { '@_' }, # Override #ARG to no longer subtract 1. # argc => sub { 'scalar(@_)' }, # $SELF is now '$shv_self'. # self => sub { '$shv_self' }, # The default currying callback will splice the list into # @_ at index 1. Instead unshift the list at the start of @_. # currying => sub { my ($gen, $list) = @_; "CORE::unshift(\@_, $list);"; }, ); # Getter was cached in $state and needs update. # $state->{getter} = $self->generate_get; $state->{shifted_self} = true; return $self; } # Insert code into method for currying. # sub _handle_currying { my ( $self, $method_name, $handler, $env, $code, $state ) = @_; if ( my $curried = $handler->curried ) { # If the curried values are non-simple, we close over an array # called @curry. # if ( grep ref, @$curried ) { # Note that generate_currying will generate code that unshifts whatever # parameters it is given onto @_. push @$code, $self->generate_currying('@curry'); $env->{'@curry'} = $curried; } # If it's just strings, numbers, and undef, it should be pretty # trivial to hard-code the values into the generated Perl string. # else { require B; my $values = join( ',', map { defined($_) ? B::perlstring($_) : 'undef' } @$curried, ); push @$code, $self->generate_currying( "($values)" ); } } return $self; } sub _handle_additional_validation { my ( $self, $method_name, $handler, $env, $code, $state ) = @_; # If the handler specifies no validation needed, or the attribute # simply has no type check, we don't need to check the type of the # final attribute value. # if ( $handler->no_validation_needed or not $self->isa ) { $state->{final_type_check_needed} = false; } # The handler can define some additional validation to be performed # on arguments either now or later, such that if this additional # validation is performed, the type check we were planning later # will be known to be unnecessary. # # An example for this is that is the attribute value is already an # arrayref of numbers, and we're pushing a new value onto it, by checking # up front that the INCOMING value is a number, it becomes unnecessary # to check the whole arrayref contains numbers after the push. # # Not all handlers define an additional_validation coderef to do # this, because in many cases it doesn't make sense to. # # Also if we've already decided a final type check isn't needed, we # can skip this step. # if ( $state->{final_type_check_needed} and defined $handler->additional_validation ) { my $real_av_method = $handler->_real_additional_validation; # The additional_validation coderef is called as a method and takes # two additional parameters: # my $opt = $handler->$real_av_method( !$state->{signature_check_needed}, # $sig_was_checked $self, # $gen ); $opt ||= {}; # can return undef # The additional_validation coderef will often generate code which # coerces incoming data, thus moving it from @_ to some other array. # This means that the generators for @ARG, $ARG, etc will need to # need to be overridden to point to the new array. # $self->_add_generator_override( %$opt ); # The additional_validation coderef may supply extra variables # to close over. # $env->{$_} = $opt->{env}{$_} for keys %{ $opt->{env} || {} }; # The additional_validation coderef will normally generate # new code. # if ( defined $opt->{code} ) { # Code can be inserted into the generated method straight away, # or may need to be inserted in a special placeholder position # later. # $opt->{add_later} ? ( $state->{add_later} = $opt->{code} ) : push( @$code, $opt->{code} ); # Final type check is often no longer needed. # $state->{final_type_check_needed} = $opt->{final_type_check_needed} || false; } } return $self; } sub _handle_getter_code { my ( $self, $method_name, $handler, $env, $code, $state ) = @_; # If there's a complicated way to fetch the attribute value (perhaps # involving a lazy builder)... # if ( $state->{getter} !~ $REASONABLE_SCALAR ) { # And if it's definitely a reference anyway, then get it straight away, # and store it in $shv_ref_invocant so we don't have to keep doing the # complicated thing. # if ( $handler->name =~ /^(Array|Hash):/ ) { push @$code, "my \$shv_ref_invocant = do { $state->{getter} };"; $state->{getter} = '$shv_ref_invocant'; $state->{getter_is_lvalue} = true; } # Alternatively, unless the handler doesn't want us to, or the template # doesn't want to get the attribute value anyway, then we'll do something # similar. Here it can't be used as an lvalue though. # elsif ( $handler->allow_getter_shortcuts and $handler->template.($handler->lvalue_template||'') =~ /\$GET/ ) { ( my $g = $state->{getter} ) =~ s/%/%%/g; $state->{template_wrapper} = "do { my \$shv_real_invocant = $g; %s }"; $state->{getter} = '$shv_real_invocant'; } } return $self; } sub _handle_setter_code { my ( $self, $method_name, $handler, $env, $code, $state ) = @_; # If a type check is needed, but the setter doesn't do type checks, # then override the setter. Now the setter does the type check, so # we no longer need to worry about it. # # XXX: I don't think any of the tests currently exercise this. # if ( $state->{final_type_check_needed} and not $self->set_checks_isa ) { $self->_add_generator_override( set => sub { my ( $me, $value_code ) = @_; $me->generate_set( sprintf( 'do { my $shv_final_unchecked = %s; %s }', $value_code, $me->generate_type_assertion( $env, $me->isa, '$shv_final_unchecked' ), ) ); } ); # In this case we can no longer use the getter as an lvalue, if we # ever could. # $state->{getter_is_lvalue} = false; # Stop worrying about the final type check. The setter does that now. # $state->{final_type_check_needed} = false; } return $self; } sub _handle_template { my ( $self, $method_name, $handler, $env, $code, $state ) = @_; my $template; # If the getter is an lvalue, the handler has a special template # for lvalues, we haven't been told to set strictly, and we have taken # care of any type checks, then use the special lvalue template. # if ( $state->{getter_is_lvalue} and $handler->lvalue_template and !$self->set_strictly and !$state->{final_type_check_needed} ) { $template = $handler->lvalue_template; } else { $template = $handler->template; } # Perform substitutions of special codes in the template string. # $template =~ s/\$SLOT/$self->generate_slot()/eg; $template =~ s/\$GET/$state->{getter}/g; $template =~ s/\$ATTRNAME/$self->attribute_name()/eg; $template =~ s/\$ARG\[([0-9]+)\]/$self->generate_arg($1)/eg; $template =~ s/\$ARG/$self->generate_arg(1)/eg; $template =~ s/\#ARG/$self->generate_argc()/eg; $template =~ s/\@ARG/$self->generate_args()/eg; $template =~ s/⸨(.+?)⸩/$self->generate_error($1)/eg; $template =~ s/«(.+?)»/$self->generate_set($1)/eg; $template =~ s/\$DEFAULT/$self->generate_default($handler)/eg; $template =~ s/\$SELF/$self->generate_self()/eg; # Apply wrapper (if any). This wrapper is given # by _handle_getter_code (sometimes). # $template = sprintf( $state->{template_wrapper}, $template ) if $state->{template_wrapper}; # If validation needs to be added late... # $template =~ s/\"?____VALIDATION_HERE____\"?/$state->{add_later}/ if defined $state->{add_later}; push @$code, $template; return $self; } sub _handle_chaining { my ( $self, $method_name, $handler, $env, $code, $state ) = @_; # Will just insert a string like ';$_[0]' at the end # push @$code, ';' . $self->generate_self, if $handler->is_chainable; return $self; } 1; __END__ =pod =encoding utf-8 =head1 NAME Sub::HandlesVia::CodeGenerator - looks at a Handler and generates a string of Perl code for it =head1 DESCRIPTION B<< This module is part of Sub::HandlesVia's internal API. >> It is mostly of interest to people extending Sub::HandlesVia. Sub::HandlesVia toolkits create a code generator for each attribute they're dealing with, and use the code generator to generate Perl code for one or more delegated methods. =head1 CONSTRUCTORS =head2 C<< new( %attributes ) >> Standard Moose-like constructor. =head1 ATTRIBUTES =head2 C B The toolkit which made this code generator. =head2 C B<< ClassName|RoleName >> The target package for generated methods. =head2 C B<< ClassName|RoleName|Undef >> Package name to use as a sandbox; the default is usually fine. =head2 C B<< Str|ArrayRef >> The attribute delegated to. =head2 C B<< HashRef >> Informational only. =head2 C B<< Bool >> Indicates whether the generated code should be methods rather than functions. This defaults to true, and false isn't really tested or well-defined. =head2 C B<< HashRef >> Variables which need to be closed over when compiling coderefs. =head2 C B<< Maybe[TypeTiny] >> The type constraint for the attribute. =head2 C B<< Bool >> Should the attribute coerce? =head2 C B A coderef which can be called with C<< $method_name >> and C<< $coderef >>, will install the method. Note that it isn't passed the package to install into (which can be found in C), so that would need to be closed over. =head2 C B<< CodeRef >> A coderef which if called, generates a string like C<< '$_[0]' >>. Has a sensible default. All the C methods are called as methods, so have the code generator object as an invocant. =head2 C B<< CodeRef >> A coderef which if called, generates a string like C<< '$_[0]{attrname}' >>. =head2 C B<< CodeRef >> A coderef which if called, generates a string like C<< '$_[0]->attrname' >>. =head2 C B<< CodeRef >> A coderef which if called with a parameter, generates a string like C<< "\$_[0]->_set_attrname( $parameter )" >>. =head2 C B<< CodeRef >> A coderef which if called with a parameter, generates a string like C<< 'undef' >> or C<< 'q[]' >> or C<< '{}' >>. The parameter is a handler object, which offers a C attribute which might be able to provide a useful fallback. =head2 C B<< CodeRef >> A coderef which if called, generates a string like C<< '@_[1..$#_]' >>. Has a sensible default. =head2 C B<< CodeRef >> A coderef which if called, generates a string like C<< '$#_' >>. Has a sensible default. =head2 C B<< CodeRef >> A coderef which if called with a parameter, generates a string like C<< "\$_[$parameter + 1]" >>. Has a sensible default. =head2 C B<< CodeRef >> A coderef which if called with a parameter, generates a string like C<< "splice(\@_,1,0,$parameter);" >>. Has a sensible default. =head2 C B<< CodeRef >> The default is this coderef: sub { @_==3 or die; shift; my $method_name = shift; my $guts = shift; return "\$instance->$method_name($guts)"; } =head2 C B<< CodeRef >> Called as a method and passed a hashref compilation environment, a type constraint, and a variable name. Generates code to assert that the variable value meets the type constraint, with coercion if appropriate. =head2 C B<< CodeRef >> Called as a method and passed a Perl string which is an expression evaluating to an error message. Generates code to throw the error. =head2 C B<< CodeRef >> By default is a coderef returning the empty string. Can be used to generate some additional statements which will be inserted near the top of the method being generated. (Typically after parameter checks but before doing anything serious.) This can be used to unlock a read-only attribute, for example. =head2 C B Indicates wheter the code generated by C will be suitable for used as an lvalue. =head2 C B Indicates wheter the code generated by C will do type checks. =head2 C B Indicates wheter we want to ensure that the setter is always called, and we should not try to bypass it, even if we have an lvalue getter. =head1 METHODS For each C attribute, there's a corresponding C method to actually call the coderef, possibly including additional processing. =head2 C<< generate_and_install_method( $method_name, $handler ) >> Given a handler and a method name, will generate a coderef for the handler and install it into the target package. =head2 C<< generate_coderef_for_handler( $method_name, $handler ) >> As above, but just returns the coderef rather than installs it. =head2 C<< install_method( $method_name, $coderef ) >> Installs a coderef into the target package with the given name. =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2020, 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. CodeGenerator.pm.mite.pm000664001750001750 10126514772476615 23340 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia{ package Sub::HandlesVia::CodeGenerator; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Class"; our $MITE_SHIM = "Sub::HandlesVia::Mite"; our $MITE_VERSION = "0.013000"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "Sub::HandlesVia::Mite", "Sub::HandlesVia::CodeGenerator" ); ( *after, *around, *before, *extends, *field, *has, *param, *signature_for, *with ) = do { package Sub::HandlesVia::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "class", @_ ) }, sub { }, sub { $SHIM->HANDLE_has( $CALLER, field => @_ ) }, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub { $SHIM->HANDLE_has( $CALLER, param => @_ ) }, sub { $SHIM->HANDLE_signature_for( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; } # Mite imports BEGIN { require Scalar::Util; *STRICT = \&Sub::HandlesVia::Mite::STRICT; *bare = \&Sub::HandlesVia::Mite::bare; *blessed = \&Scalar::Util::blessed; *carp = \&Sub::HandlesVia::Mite::carp; *confess = \&Sub::HandlesVia::Mite::confess; *croak = \&Sub::HandlesVia::Mite::croak; *false = \&Sub::HandlesVia::Mite::false; *guard = \&Sub::HandlesVia::Mite::guard; *lazy = \&Sub::HandlesVia::Mite::lazy; *lock = \&Sub::HandlesVia::Mite::lock; *ro = \&Sub::HandlesVia::Mite::ro; *rw = \&Sub::HandlesVia::Mite::rw; *rwp = \&Sub::HandlesVia::Mite::rwp; *true = \&Sub::HandlesVia::Mite::true; *unlock = \&Sub::HandlesVia::Mite::unlock; } # Gather metadata for constructor and destructor sub __META__ { no strict 'refs'; my $class = shift; $class = ref($class) || $class; my $linear_isa = mro::get_linear_isa($class); return { BUILD => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::BUILD" } reverse @$linear_isa ], DEMOLISH => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::DEMOLISH" } @$linear_isa ], HAS_BUILDARGS => $class->can('BUILDARGS'), HAS_FOREIGNBUILDARGS => $class->can('FOREIGNBUILDARGS'), }; } # Standard Moose/Moo-style constructor sub new { my $class = ref( $_[0] ) ? ref(shift) : shift; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $self = bless {}, $class; my $args = $meta->{HAS_BUILDARGS} ? $class->BUILDARGS(@_) : { ( @_ == 1 ) ? %{ $_[0] } : @_ }; my $no_build = delete $args->{__no_BUILD__}; # Attribute toolkit # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 12 if ( exists $args->{"toolkit"} ) { $self->{"toolkit"} = $args->{"toolkit"}; } # Attribute target # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 16 if ( exists $args->{"target"} ) { $self->{"target"} = $args->{"target"}; } # Attribute attribute # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 20 if ( exists $args->{"attribute"} ) { $self->{"attribute"} = $args->{"attribute"}; } # Attribute attribute_spec (type: HashRef) # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 24 if ( exists $args->{"attribute_spec"} ) { do { package Sub::HandlesVia::Mite; ref( $args->{"attribute_spec"} ) eq 'HASH'; } or croak "Type check failed in constructor: %s should be %s", "attribute_spec", "HashRef"; $self->{"attribute_spec"} = $args->{"attribute_spec"}; } # Attribute isa # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 29 if ( exists $args->{"isa"} ) { $self->{"isa"} = $args->{"isa"}; } # Attribute coerce (type: Bool) # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 33 if ( exists $args->{"coerce"} ) { do { package Sub::HandlesVia::Mite; !ref $args->{"coerce"} and ( !defined $args->{"coerce"} or $args->{"coerce"} eq q() or $args->{"coerce"} eq '0' or $args->{"coerce"} eq '1' ); } or croak "Type check failed in constructor: %s should be %s", "coerce", "Bool"; $self->{"coerce"} = $args->{"coerce"}; } # Attribute env (type: HashRef) # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 38 do { my $value = exists( $args->{"env"} ) ? ( ( do { package Sub::HandlesVia::Mite; ref( $args->{"env"} ) eq 'HASH'; } ) ? $args->{"env"} : croak( "Type check failed in constructor: %s should be %s", "env", "HashRef" ) ) : {}; $self->{"env"} = $value; }; # Attribute sandboxing_package (type: Str|Undef) # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 45 do { my $value = exists( $args->{"sandboxing_package"} ) ? ( ( do { package Sub::HandlesVia::Mite; ( do { package Sub::HandlesVia::Mite; defined( $args->{"sandboxing_package"} ) and do { ref( \$args->{"sandboxing_package"} ) eq 'SCALAR' or ref( \( my $val = $args->{"sandboxing_package"} ) ) eq 'SCALAR'; } } or do { package Sub::HandlesVia::Mite; !defined( $args->{"sandboxing_package"} ); } ); } ) ? $args->{"sandboxing_package"} : croak( "Type check failed in constructor: %s should be %s", "sandboxing_package", "Str|Undef" ) ) : "Sub::HandlesVia::CodeGenerator::__SANDBOX__"; $self->{"sandboxing_package"} = $value; }; # Attribute generator_for_slot (type: CodeRef) # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 52 if ( exists $args->{"generator_for_slot"} ) { do { package Sub::HandlesVia::Mite; ref( $args->{"generator_for_slot"} ) eq 'CODE'; } or croak "Type check failed in constructor: %s should be %s", "generator_for_slot", "CodeRef"; $self->{"generator_for_slot"} = $args->{"generator_for_slot"}; } # Attribute generator_for_get (type: CodeRef) # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 52 if ( exists $args->{"generator_for_get"} ) { do { package Sub::HandlesVia::Mite; ref( $args->{"generator_for_get"} ) eq 'CODE'; } or croak "Type check failed in constructor: %s should be %s", "generator_for_get", "CodeRef"; $self->{"generator_for_get"} = $args->{"generator_for_get"}; } # Attribute generator_for_set (type: CodeRef) # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 52 if ( exists $args->{"generator_for_set"} ) { do { package Sub::HandlesVia::Mite; ref( $args->{"generator_for_set"} ) eq 'CODE'; } or croak "Type check failed in constructor: %s should be %s", "generator_for_set", "CodeRef"; $self->{"generator_for_set"} = $args->{"generator_for_set"}; } # Attribute generator_for_default (type: CodeRef) # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 52 if ( exists $args->{"generator_for_default"} ) { do { package Sub::HandlesVia::Mite; ref( $args->{"generator_for_default"} ) eq 'CODE'; } or croak "Type check failed in constructor: %s should be %s", "generator_for_default", "CodeRef"; $self->{"generator_for_default"} = $args->{"generator_for_default"}; } # Attribute generator_for_args (type: CodeRef) # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 65 do { my $value = exists( $args->{"generator_for_args"} ) ? ( ( do { package Sub::HandlesVia::Mite; ref( $args->{"generator_for_args"} ) eq 'CODE'; } ) ? $args->{"generator_for_args"} : croak( "Type check failed in constructor: %s should be %s", "generator_for_args", "CodeRef" ) ) : $self->_build_generator_for_args; $self->{"generator_for_args"} = $value; }; # Attribute generator_for_arg (type: CodeRef) # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 78 do { my $value = exists( $args->{"generator_for_arg"} ) ? ( ( do { package Sub::HandlesVia::Mite; ref( $args->{"generator_for_arg"} ) eq 'CODE'; } ) ? $args->{"generator_for_arg"} : croak( "Type check failed in constructor: %s should be %s", "generator_for_arg", "CodeRef" ) ) : $self->_build_generator_for_arg; $self->{"generator_for_arg"} = $value; }; # Attribute generator_for_argc (type: CodeRef) # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 89 do { my $value = exists( $args->{"generator_for_argc"} ) ? ( ( do { package Sub::HandlesVia::Mite; ref( $args->{"generator_for_argc"} ) eq 'CODE'; } ) ? $args->{"generator_for_argc"} : croak( "Type check failed in constructor: %s should be %s", "generator_for_argc", "CodeRef" ) ) : $self->_build_generator_for_argc; $self->{"generator_for_argc"} = $value; }; # Attribute generator_for_currying (type: CodeRef) # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 102 do { my $value = exists( $args->{"generator_for_currying"} ) ? ( ( do { package Sub::HandlesVia::Mite; ref( $args->{"generator_for_currying"} ) eq 'CODE'; } ) ? $args->{"generator_for_currying"} : croak( "Type check failed in constructor: %s should be %s", "generator_for_currying", "CodeRef" ) ) : $self->_build_generator_for_currying; $self->{"generator_for_currying"} = $value; }; # Attribute generator_for_usage_string (type: CodeRef) # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 117 do { my $value = exists( $args->{"generator_for_usage_string"} ) ? ( ( do { package Sub::HandlesVia::Mite; ref( $args->{"generator_for_usage_string"} ) eq 'CODE'; } ) ? $args->{"generator_for_usage_string"} : croak( "Type check failed in constructor: %s should be %s", "generator_for_usage_string", "CodeRef" ) ) : $self->_build_generator_for_usage_string; $self->{"generator_for_usage_string"} = $value; }; # Attribute generator_for_self (type: CodeRef) # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 128 do { my $value = exists( $args->{"generator_for_self"} ) ? ( ( do { package Sub::HandlesVia::Mite; ref( $args->{"generator_for_self"} ) eq 'CODE'; } ) ? $args->{"generator_for_self"} : croak( "Type check failed in constructor: %s should be %s", "generator_for_self", "CodeRef" ) ) : $self->_build_generator_for_self; $self->{"generator_for_self"} = $value; }; # Attribute generator_for_type_assertion (type: CodeRef) # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 155 do { my $value = exists( $args->{"generator_for_type_assertion"} ) ? ( ( do { package Sub::HandlesVia::Mite; ref( $args->{"generator_for_type_assertion"} ) eq 'CODE'; } ) ? $args->{"generator_for_type_assertion"} : croak( "Type check failed in constructor: %s should be %s", "generator_for_type_assertion", "CodeRef" ) ) : $self->_build_generator_for_type_assertion; $self->{"generator_for_type_assertion"} = $value; }; # Attribute generator_for_error (type: CodeRef) # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 167 do { my $value = exists( $args->{"generator_for_error"} ) ? ( ( do { package Sub::HandlesVia::Mite; ref( $args->{"generator_for_error"} ) eq 'CODE'; } ) ? $args->{"generator_for_error"} : croak( "Type check failed in constructor: %s should be %s", "generator_for_error", "CodeRef" ) ) : $self->_build_generator_for_error; $self->{"generator_for_error"} = $value; }; # Attribute generator_for_prelude (type: CodeRef) # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 176 do { my $value = exists( $args->{"generator_for_prelude"} ) ? ( ( do { package Sub::HandlesVia::Mite; ref( $args->{"generator_for_prelude"} ) eq 'CODE'; } ) ? $args->{"generator_for_prelude"} : croak( "Type check failed in constructor: %s should be %s", "generator_for_prelude", "CodeRef" ) ) : $self->_build_generator_for_prelude; $self->{"generator_for_prelude"} = $value; }; # Attribute method_installer (type: CodeRef) # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 179 if ( exists $args->{"method_installer"} ) { do { package Sub::HandlesVia::Mite; ref( $args->{"method_installer"} ) eq 'CODE'; } or croak "Type check failed in constructor: %s should be %s", "method_installer", "CodeRef"; $self->{"method_installer"} = $args->{"method_installer"}; } # Attribute is_method # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 189 $self->{"is_method"} = ( exists( $args->{"is_method"} ) ? $args->{"is_method"} : "1" ); # Attribute get_is_lvalue # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 194 $self->{"get_is_lvalue"} = ( exists( $args->{"get_is_lvalue"} ) ? $args->{"get_is_lvalue"} : "" ); # Attribute set_checks_isa # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 199 $self->{"set_checks_isa"} = ( exists( $args->{"set_checks_isa"} ) ? $args->{"set_checks_isa"} : "" ); # Attribute set_strictly # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 204 $self->{"set_strictly"} = ( exists( $args->{"set_strictly"} ) ? $args->{"set_strictly"} : "1" ); # Call BUILD methods $self->BUILDALL($args) if ( !$no_build and @{ $meta->{BUILD} || [] } ); # Unrecognized parameters my @unknown = grep not( /\A(?:attribute(?:_spec)?|coerce|env|ge(?:nerator_for_(?:arg[cs]?|currying|default|error|get|prelude|s(?:e(?:lf|t)|lot)|type_assertion|usage_string)|t_is_lvalue)|is(?:_method|a)|method_installer|s(?:andboxing_package|et_(?:checks_isa|strictly))|t(?:arget|oolkit))\z/ ), keys %{$args}; @unknown and croak( "Unexpected keys in constructor: " . join( q[, ], sort @unknown ) ); return $self; } # Used by constructor to call BUILD methods sub BUILDALL { my $class = ref( $_[0] ); my $meta = ( $Mite::META{$class} ||= $class->__META__ ); $_->(@_) for @{ $meta->{BUILD} || [] }; } # Destructor should call DEMOLISH methods sub DESTROY { my $self = shift; my $class = ref($self) || $self; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $in_global_destruction = defined ${^GLOBAL_PHASE} ? ${^GLOBAL_PHASE} eq 'DESTRUCT' : Devel::GlobalDestruction::in_global_destruction(); for my $demolisher ( @{ $meta->{DEMOLISH} || [] } ) { my $e = do { local ( $?, $@ ); eval { $demolisher->( $self, $in_global_destruction ) }; $@; }; no warnings 'misc'; # avoid (in cleanup) warnings die $e if $e; # rethrow } return; } my $__XS = !$ENV{PERL_ONLY} && eval { require Class::XSAccessor; Class::XSAccessor->VERSION("1.19") }; # Accessors for _override # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 184 if ($__XS) { Class::XSAccessor->import( chained => 1, "accessors" => { "_override" => "_override" }, ); } else { *_override = sub { @_ > 1 ? do { $_[0]{"_override"} = $_[1]; $_[0]; } : ( $_[0]{"_override"} ); }; } # Accessors for attribute # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 20 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "attribute" => "attribute" }, ); } else { *attribute = sub { @_ == 1 or croak('Reader "attribute" usage: $self->attribute()'); $_[0]{"attribute"}; }; } # Accessors for attribute_spec # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 24 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "attribute_spec" => "attribute_spec" }, ); } else { *attribute_spec = sub { @_ == 1 or croak('Reader "attribute_spec" usage: $self->attribute_spec()'); $_[0]{"attribute_spec"}; }; } # Accessors for coerce # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 33 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "coerce" => "coerce" }, ); } else { *coerce = sub { @_ == 1 or croak('Reader "coerce" usage: $self->coerce()'); $_[0]{"coerce"}; }; } # Accessors for env # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 38 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "env" => "env" }, ); } else { *env = sub { @_ == 1 or croak('Reader "env" usage: $self->env()'); $_[0]{"env"}; }; } # Accessors for generator_for_arg # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 78 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "generator_for_arg" => "generator_for_arg" }, ); } else { *generator_for_arg = sub { @_ == 1 or croak( 'Reader "generator_for_arg" usage: $self->generator_for_arg()'); $_[0]{"generator_for_arg"}; }; } # Accessors for generator_for_argc # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 89 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "generator_for_argc" => "generator_for_argc" }, ); } else { *generator_for_argc = sub { @_ == 1 or croak( 'Reader "generator_for_argc" usage: $self->generator_for_argc()' ); $_[0]{"generator_for_argc"}; }; } # Accessors for generator_for_args # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 65 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "generator_for_args" => "generator_for_args" }, ); } else { *generator_for_args = sub { @_ == 1 or croak( 'Reader "generator_for_args" usage: $self->generator_for_args()' ); $_[0]{"generator_for_args"}; }; } # Accessors for generator_for_currying # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 102 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "generator_for_currying" => "generator_for_currying" }, ); } else { *generator_for_currying = sub { @_ == 1 or croak( 'Reader "generator_for_currying" usage: $self->generator_for_currying()' ); $_[0]{"generator_for_currying"}; }; } # Accessors for generator_for_default # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 52 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "generator_for_default" => "generator_for_default" }, ); } else { *generator_for_default = sub { @_ == 1 or croak( 'Reader "generator_for_default" usage: $self->generator_for_default()' ); $_[0]{"generator_for_default"}; }; } # Accessors for generator_for_error # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 167 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "generator_for_error" => "generator_for_error" }, ); } else { *generator_for_error = sub { @_ == 1 or croak( 'Reader "generator_for_error" usage: $self->generator_for_error()' ); $_[0]{"generator_for_error"}; }; } # Accessors for generator_for_get # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 52 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "generator_for_get" => "generator_for_get" }, ); } else { *generator_for_get = sub { @_ == 1 or croak( 'Reader "generator_for_get" usage: $self->generator_for_get()'); $_[0]{"generator_for_get"}; }; } # Accessors for generator_for_prelude # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 176 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "generator_for_prelude" => "generator_for_prelude" }, ); } else { *generator_for_prelude = sub { @_ == 1 or croak( 'Reader "generator_for_prelude" usage: $self->generator_for_prelude()' ); $_[0]{"generator_for_prelude"}; }; } # Accessors for generator_for_self # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 128 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "generator_for_self" => "generator_for_self" }, ); } else { *generator_for_self = sub { @_ == 1 or croak( 'Reader "generator_for_self" usage: $self->generator_for_self()' ); $_[0]{"generator_for_self"}; }; } # Accessors for generator_for_set # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 52 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "generator_for_set" => "generator_for_set" }, ); } else { *generator_for_set = sub { @_ == 1 or croak( 'Reader "generator_for_set" usage: $self->generator_for_set()'); $_[0]{"generator_for_set"}; }; } # Accessors for generator_for_slot # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 52 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "generator_for_slot" => "generator_for_slot" }, ); } else { *generator_for_slot = sub { @_ == 1 or croak( 'Reader "generator_for_slot" usage: $self->generator_for_slot()' ); $_[0]{"generator_for_slot"}; }; } # Accessors for generator_for_type_assertion # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 155 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "generator_for_type_assertion" => "generator_for_type_assertion" }, ); } else { *generator_for_type_assertion = sub { @_ == 1 or croak( 'Reader "generator_for_type_assertion" usage: $self->generator_for_type_assertion()' ); $_[0]{"generator_for_type_assertion"}; }; } # Accessors for generator_for_usage_string # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 117 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "generator_for_usage_string" => "generator_for_usage_string" }, ); } else { *generator_for_usage_string = sub { @_ == 1 or croak( 'Reader "generator_for_usage_string" usage: $self->generator_for_usage_string()' ); $_[0]{"generator_for_usage_string"}; }; } # Accessors for get_is_lvalue # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 194 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "get_is_lvalue" => "get_is_lvalue" }, ); } else { *get_is_lvalue = sub { @_ == 1 or croak('Reader "get_is_lvalue" usage: $self->get_is_lvalue()'); $_[0]{"get_is_lvalue"}; }; } # Accessors for is_method # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 189 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "is_method" => "is_method" }, ); } else { *is_method = sub { @_ == 1 or croak('Reader "is_method" usage: $self->is_method()'); $_[0]{"is_method"}; }; } # Accessors for isa # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 29 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "isa" => "isa" }, ); } else { *isa = sub { @_ == 1 or croak('Reader "isa" usage: $self->isa()'); $_[0]{"isa"}; }; } # Accessors for method_installer # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 179 sub method_installer { @_ > 1 ? do { ( ref( $_[1] ) eq 'CODE' ) or croak( "Type check failed in %s: value should be %s", "accessor", "CodeRef" ); $_[0]{"method_installer"} = $_[1]; $_[0]; } : ( $_[0]{"method_installer"} ); } # Accessors for sandboxing_package # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 45 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "sandboxing_package" => "sandboxing_package" }, ); } else { *sandboxing_package = sub { @_ == 1 or croak( 'Reader "sandboxing_package" usage: $self->sandboxing_package()' ); $_[0]{"sandboxing_package"}; }; } # Accessors for set_checks_isa # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 199 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "set_checks_isa" => "set_checks_isa" }, ); } else { *set_checks_isa = sub { @_ == 1 or croak('Reader "set_checks_isa" usage: $self->set_checks_isa()'); $_[0]{"set_checks_isa"}; }; } # Accessors for set_strictly # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 204 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "set_strictly" => "set_strictly" }, ); } else { *set_strictly = sub { @_ == 1 or croak('Reader "set_strictly" usage: $self->set_strictly()'); $_[0]{"set_strictly"}; }; } # Accessors for target # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 16 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "target" => "target" }, ); } else { *target = sub { @_ == 1 or croak('Reader "target" usage: $self->target()'); $_[0]{"target"}; }; } # Accessors for toolkit # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 12 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "toolkit" => "toolkit" }, ); } else { *toolkit = sub { @_ == 1 or croak('Reader "toolkit" usage: $self->toolkit()'); $_[0]{"toolkit"}; }; } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can('does_role') and $meta->does_role($role) and return 1; } return $self->SUPER::DOES($role); } # Alias for Moose/Moo-compatibility sub does { shift->DOES(@_); } 1; } Declare.pm000664001750001750 553514772476615 20551 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesViause 5.008; use strict; use warnings; package Sub::HandlesVia::Declare; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Sub::HandlesVia (); my %cache; sub import { my ( $class, $attr ) = ( shift, shift ); my ( $via, %delegations ) = ( @_ % 2 ) ? @_ : ( undef, @_ ); if ( not defined $via ) { $via = 'Array' if $attr =~ /^@/; $via = 'Hash' if $attr =~ /^%/; if ( not defined $via ) { require Sub::HandlesVia::Mite; Sub::HandlesVia::Mite::croak( 'Expected usage: '. 'use Sub::HandlesVia::Declare ( $attr, $via, %delegations );' ); } } my $caller = caller; if ( not $cache{$caller} ) { 'Sub::HandlesVia'->import( { into => $caller, installer => sub { $cache{$caller} = $_[1][1] }, }, qw( delegations ), ); } $cache{$caller}->( attribute => $attr, handles_via => $via, handles => \%delegations, ); } 1; __END__ =pod =encoding utf-8 =head1 NAME Sub::HandlesVia::Declare - declare delegations at compile-time =head1 SYNOPSIS use Sub::HandlesVia::Declare( $attr, $via => %delegations ); This is roughly equivalent to the following: use Sub::HandlesVia qw(delegations); BEGIN { delegations( attribute => $attr, handles_via => $via, handles => \%delegations, ); }; Except it doesn't import the C function into your namespace. =head1 DESCRIPTION Useful for L and kind of nice for L. Basically any class builder than does its stuff at compile time. =head2 Object::Pad use Object::Pad; class Kitchen { has @foods; use Sub::HandlesVia::Declare '@foods', Array => ( all_foods => 'all', add_food => 'push', ); } If an attribute begins with a '@' or '%', C<< $via >> can be omitted. use Object::Pad; class Kitchen { has @foods; use Sub::HandlesVia::Declare '@foods', ( all_foods => 'all', add_food => 'push', ); } =head2 Class::Tiny package Kitchen; use Class::Tiny { foods => sub { [] }, drinks => sub { [ 'water' ] }, }; use Sub::HandlesVia::Declare 'foods', Array => ( all_foods => 'all', add_food => 'push', ); use Sub::HandlesVia::Declare 'drinks', Array => ( all_drinks => 'all', add_drink => 'push', ); =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. Handler.pm000664001750001750 3034714772476615 20606 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesViause 5.008; use strict; use warnings; package Sub::HandlesVia::Handler; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Sub::HandlesVia::Mite -all; has name => ( is => ro, isa => 'Str', ); has template => ( is => ro, isa => 'Str', ); has lvalue_template => ( is => ro, isa => 'Str', ); has args => ( is => ro, isa => 'Int|Undef', default => undef, ); has [ 'min_args', 'max_args' ] => ( is => lazy, isa => 'Int|Undef', builder => sub { shift->args }, ); # Not proper predicates because they check definedness sub has_min_args { defined shift->min_args } sub has_max_args { defined shift->max_args } has signature => ( is => ro, isa => 'ArrayRef|Undef', ); has usage => ( is => lazy, isa => 'Str', builder => true, ); has curried => ( is => ro, isa => 'ArrayRef', ); has [ 'is_chainable', 'no_validation_needed' ] => ( is => ro, isa => 'Bool', coerce => true, ); has is_mutator => ( is => lazy, isa => 'Bool', coerce => true, default => sub { defined $_[0]{lvalue_template} or $_[0]{template} =~ /«/ } ); has allow_getter_shortcuts => ( is => ro, isa => 'Bool', coerce => true, default => true, ); has prefer_shift_self => ( is => ro, isa => 'Bool', coerce => true, default => false, ); has additional_validation => ( is => ro, isa => 'CodeRef|Str|Undef', ); has default_for_reset => ( is => ro, isa => 'CodeRef', ); has documentation => ( is => ro, isa => 'Str', ); has _examples => ( is => ro, isa => 'CodeRef', ); sub _build_usage { no warnings 'uninitialized'; my $self = shift; if ($self->has_max_args and $self->max_args==0) { return ''; } elsif ($self->min_args==0 and $self->max_args==1) { return '$arg?'; } elsif ($self->min_args==1 and $self->max_args==1) { return '$arg'; } elsif ($self->min_args > 0 and $self->max_args > 0) { return sprintf('@min_%d_max_%d_args', $self->min_args, $self->max_args); } elsif ($self->max_args > 0) { return sprintf('@max_%d_args', $self->max_args); } return '@args'; } sub curry { my ($self, @curried) = @_; if ($self->has_max_args and @curried > $self->max_args) { die "too many arguments to curry"; } my %copy = %$self; delete $copy{usage}; ref($self)->new( %copy, name => sprintf('%s[curried]', $self->name), max_args => $self->has_max_args ? $self->max_args - @curried : undef, min_args => $self->has_min_args ? $self->min_args - @curried : undef, signature => $self->signature ? do { my @sig = @{$self->{signature}}; splice(@sig,0,scalar(@curried)); \@sig } : undef, curried => \@curried, ); } sub loose { my $self = shift; ref($self)->new(%$self, signature => undef); } sub chainable { my $self = shift; ref($self)->new(%$self, is_chainable => 1); } sub _real_additional_validation { my $me = shift; my $av = $me->additional_validation; return $av if ref $av; my ($lib) = split /:/, $me->name; return sub { my $self = shift; my ($sig_was_checked, $callbacks) = @_; my $ti = "Sub::HandlesVia::HandlerLibrary::$lib"->_type_inspector($callbacks->{isa}); if ($ti and $ti->{trust_mutated} eq 'always') { return { code => '1;', env => {} }; } if ($ti and $ti->{trust_mutated} eq 'maybe') { return { code => '1;', env => {} }; } return; } if $av eq 'no incoming values'; return; } sub lookup { my $class = shift; my ($method, $traits) = map { ref($_) eq 'ARRAY' ? $_ : [$_] } @_; my ($method_name, @curry) = @$method; my $handler; my $make_chainable = 0; my $make_loose = 0; if (ref $method_name eq 'CODE') { $handler = Sub::HandlesVia::Handler::CodeRef->new( name => '__ANON__', delegated_coderef => $method_name, ); } else { if ($method_name =~ /\s*\.\.\.$/) { $method_name =~ s/\s*\.\.\.$//; ++$make_chainable; } if ($method_name =~ /^\~\s*/) { $method_name =~ s/^\~\s*//; ++$make_loose; } if ($method_name =~ /^(.+?)\s*\-\>\s*(.+?)$/) { $traits = [$1]; $method_name = $2; } } if (not $handler) { SEARCH: for my $trait (@$traits) { my $class = $trait =~ /:/ ? $trait : "Sub::HandlesVia::HandlerLibrary::$trait"; if ( $class ne $trait ) { local $@; eval "require $class; 1" or warn $@; } if ($class->isa('Sub::HandlesVia::HandlerLibrary') and $class->has_handler($method_name)) { $handler = $class->get_handler($method_name); } } } if (not $handler) { $handler = Sub::HandlesVia::Handler::Traditional->new(name => $method_name); } $handler = $handler->curry(@curry) if @curry; $handler = $handler->loose if $make_loose; $handler = $handler->chainable if $make_chainable; return $handler; } sub install_method { my ( $self, %arg ) = @_; my $gen = $arg{code_generator} or die; $gen->generate_and_install_method( $arg{method_name}, $self ); return; } sub code_as_string { my ($self, %arg ) = @_; my $gen = $arg{code_generator} or die; my $eval = $gen->_generate_ec_args_for_handler( $arg{method_name}, $self ); my $code = join "\n", @{$eval->{source}}; if ($arg{method_name}) { $code =~ s/sub/sub $arg{method_name}/xs; } if (eval { require Perl::Tidy }) { my $tidy = ''; Perl::Tidy::perltidy( source => \$code, destination => \$tidy, ); $code = $tidy; } $code; } sub _tweak_env {} use Exporter::Shiny qw( handler ); sub _generate_handler { my $me = shift; return sub { my (%args) = @_%2 ? (template=>@_) : @_; $me->new(%args); }; } package Sub::HandlesVia::Handler::Traditional; # XXX: can this be replaced by Blessed trait? our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Sub::HandlesVia::Mite -all; extends 'Sub::HandlesVia::Handler'; has '+name' => ( required => true ); sub is_mutator { 0 } sub template { my $self = shift; require B; my $q_name = B::perlstring( $self->name ); return sprintf( '$GET->${\\ '.$q_name.'}( @ARG )', ); } package Sub::HandlesVia::Handler::CodeRef; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Sub::HandlesVia::Mite -all; extends 'Sub::HandlesVia::Handler'; has delegated_coderef => ( is => 'ro', isa => 'CodeRef', required => true, ); sub is_mutator { 0 } sub BUILD { $_[1]{delegated_coderef} or die 'delegated_coderef required'; } sub _tweak_env { my ( $self, $env ) = @_; $env->{'$shv_callback'} = \($self->delegated_coderef); } sub template { return '$shv_callback->(my $shvtmp = $GET, @ARG)'; } 1; __END__ =pod =encoding utf-8 =head1 NAME Sub::HandlesVia::Handler - template for a method that can be delegated to =head1 DESCRIPTION B<< This module is part of Sub::HandlesVia's internal API. >> It is mostly of interest to people extending Sub::HandlesVia. This module works in conjunction with L and subclasses of L to build a string of Perl code which can be compiled into a method to install into your class. =head1 CONSTRUCTORS =head2 C<< new( %attributes ) >> Standard Moose-like constructor. =head2 C<< lookup( $method, $trait ) >> Looks up a method from existing handler libraries. my $h = Sub::HandlesVia::Handler->lookup( 'get', 'Array' ); Curried version: my $h = Sub::HandlesVia::Handler->lookup( [ 'get', 0 ], 'Array' ); The C<< $trait >> may be an arrayref of possible traits. =head1 EXPORTS Nothing is exported by default. =head2 C<< handler %attributes >> Shortcut for the C constructor. use Sub::HandlesVia::Handler 'handler'; my $h = handler( %attr ); # is the same as my $h = Sub::HandlesVia::Handler->new( %attr ); =head1 ATTRIBUTES =head2 C<< name >> B<< Str >> The name of the function being delegated to. =head2 C<< is_mutator >> B Indicates whether this handler might mutate an attribute value. The default is to try to detect it based on analysis of the templates. =head2 C<< template >> B<< Str >> Specially formatted string (see section below) containing the Perl code to implement the method. =head2 C<< lvalue_template >> B<< Maybe[Str] >> If defined, a shortcut for implementing it when the attribute slot value can be used as an lvalue. =head2 C<< args >> B<< Maybe[PositiveOrZeroInt] >> The number of arguments which the method being generated expects (does not include the attibute value itself). =head2 C<< min_args >> and C<< max_args >> B<< Maybe[PositiveOrZeroInt] >> For methods which take a variable number of arguments. If omitted, default to C. =head2 C<< signature >> B<< Maybe[ArrayRef[TypeTiny]] >> A signature for said arguments. =head2 C<< usage >> B<< Str >> A signature to show in documentation, like C<< '$index, $value' >>. If not provided, will be generated magically from C, C, and C. =head2 C<< curried >> B<< Maybe[ArrayRef[Item]] >> An arrayref of curried arguments. =head2 C<< is_chainable >> B Whether to force the generated method to be chainable. =head2 C<< no_validation_needed >> B Whether to do less validation of input data. =head2 C<< default_for_reset >> B<< Maybe[Str] >> If this handler has to "reset" an attribute value to its default, and the attribute doesn't have a default, this string of Perl code is evaluated to provide a default. An example might be C<< "[]" >>. =head2 C<< prefer_shift_self >> B Indicates this handler would prefer the code generator to shift C<< $self >> off C<< @_ >>. =head2 C<< documentation >> B<< Maybe[Str] >> String of pod to describe the handler. =head2 C<< _examples >> B<< Maybe[CodeRef] >> This coderef, if called with parameters C<< $class >>, C<< $attr >>, and C<< $method >>, will generate a code example to insert into the pod. =head2 C<< additional_validation >> B<< Maybe[CodeRef] >> Coderef providing a slightly annoying API. To be described later. =head2 C<< allow_getter_shortcuts >> B Defaults to true. Rarely useful to override. =head1 METHODS =head2 C<< has_min_args() >> and C<< has_max_args() >> Indicate whether this handler has a defined min or max args. =head2 C<< install_method( %args ) >> The required arguments are C and C. Installs the delegated method into the target class (taken from the code generator). =head2 C<< code_as_string( %args ) >> Same required arguments as C, but returns the Perl code for the method as a string. =head2 C<< curry( @args ) >> Pseudo-constructor. Creates a new Sub::HandlesVia::Handler object like this one, but with the given arguments curried. =head2 C<< loose >> Pseudo-constructor. Creates a new Sub::HandlesVia::Handler object like this one, but with looser argument validation. =head2 C<< chainable >> Pseudo-constructor. Creates a new Sub::HandlesVia::Handler object like this one, but chainable. =head1 TEMPLATE FORMAT The template is a string of Perl code, except if the following special things are found in it, they are substituted. =over =item C<< $SELF >> The invocant. =item C<< $SLOT >> Direct hashref access for the attribute. =item C<< $GET >> The current value of the attribute. =item C<< @ARG >> Any additional arguments passed to the delegated method. C<< $ARG[$n] >> will also work. =item C<< #ARG >> The number of additional arguments passed to the delegated method. =item C<< $ARG >> The first element in C<< @ARG >>. =item C<< $DEFAULT >> The attribute's default value, if known. =item C<< « EXPR » >> An expression in double angled quotes sets the attribute's value to the expression. =back For example, a handler to halve the value of a numeric attribute might be: 'Sub::HandlesVia::Handler'->new( name => 'MyNumber:halve', args => 0, template => '« $GET / 2 »', lvalue_template => '$GET /= 2', ); =head1 SUBCLASSES Sub::HandlesVia::Handler::Traditional and Sub::HandlesVia::Handler::CodeRef are provided. See source code for this module for more info. =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2020, 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. Handler.pm.mite.pm000664001750001750 22174114772476615 22176 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia{ package Sub::HandlesVia::Handler; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Class"; our $MITE_SHIM = "Sub::HandlesVia::Mite"; our $MITE_VERSION = "0.013000"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "Sub::HandlesVia::Mite", "Sub::HandlesVia::Handler" ); ( *after, *around, *before, *extends, *field, *has, *param, *signature_for, *with ) = do { package Sub::HandlesVia::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "class", @_ ) }, sub { }, sub { $SHIM->HANDLE_has( $CALLER, field => @_ ) }, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub { $SHIM->HANDLE_has( $CALLER, param => @_ ) }, sub { $SHIM->HANDLE_signature_for( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; } # Mite imports BEGIN { require Scalar::Util; *STRICT = \&Sub::HandlesVia::Mite::STRICT; *bare = \&Sub::HandlesVia::Mite::bare; *blessed = \&Scalar::Util::blessed; *carp = \&Sub::HandlesVia::Mite::carp; *confess = \&Sub::HandlesVia::Mite::confess; *croak = \&Sub::HandlesVia::Mite::croak; *false = \&Sub::HandlesVia::Mite::false; *guard = \&Sub::HandlesVia::Mite::guard; *lazy = \&Sub::HandlesVia::Mite::lazy; *lock = \&Sub::HandlesVia::Mite::lock; *ro = \&Sub::HandlesVia::Mite::ro; *rw = \&Sub::HandlesVia::Mite::rw; *rwp = \&Sub::HandlesVia::Mite::rwp; *true = \&Sub::HandlesVia::Mite::true; *unlock = \&Sub::HandlesVia::Mite::unlock; } # Gather metadata for constructor and destructor sub __META__ { no strict 'refs'; my $class = shift; $class = ref($class) || $class; my $linear_isa = mro::get_linear_isa($class); return { BUILD => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::BUILD" } reverse @$linear_isa ], DEMOLISH => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::DEMOLISH" } @$linear_isa ], HAS_BUILDARGS => $class->can('BUILDARGS'), HAS_FOREIGNBUILDARGS => $class->can('FOREIGNBUILDARGS'), }; } # Standard Moose/Moo-style constructor sub new { my $class = ref( $_[0] ) ? ref(shift) : shift; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $self = bless {}, $class; my $args = $meta->{HAS_BUILDARGS} ? $class->BUILDARGS(@_) : { ( @_ == 1 ) ? %{ $_[0] } : @_ }; my $no_build = delete $args->{__no_BUILD__}; # Attribute name (type: Str) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 12 if ( exists $args->{"name"} ) { do { package Sub::HandlesVia::Mite; defined( $args->{"name"} ) and do { ref( \$args->{"name"} ) eq 'SCALAR' or ref( \( my $val = $args->{"name"} ) ) eq 'SCALAR'; } } or croak "Type check failed in constructor: %s should be %s", "name", "Str"; $self->{"name"} = $args->{"name"}; } # Attribute template (type: Str) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 17 if ( exists $args->{"template"} ) { do { package Sub::HandlesVia::Mite; defined( $args->{"template"} ) and do { ref( \$args->{"template"} ) eq 'SCALAR' or ref( \( my $val = $args->{"template"} ) ) eq 'SCALAR'; } } or croak "Type check failed in constructor: %s should be %s", "template", "Str"; $self->{"template"} = $args->{"template"}; } # Attribute lvalue_template (type: Str) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 22 if ( exists $args->{"lvalue_template"} ) { do { package Sub::HandlesVia::Mite; defined( $args->{"lvalue_template"} ) and do { ref( \$args->{"lvalue_template"} ) eq 'SCALAR' or ref( \( my $val = $args->{"lvalue_template"} ) ) eq 'SCALAR'; } } or croak "Type check failed in constructor: %s should be %s", "lvalue_template", "Str"; $self->{"lvalue_template"} = $args->{"lvalue_template"}; } # Attribute args (type: Int|Undef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 27 do { my $value = exists( $args->{"args"} ) ? $args->{"args"} : undef; do { package Sub::HandlesVia::Mite; ( ( do { my $tmp = $value; defined($tmp) and !ref($tmp) and $tmp =~ /\A-?[0-9]+\z/; } ) or ( !defined($value) ) ); } or croak "Type check failed in constructor: %s should be %s", "args", "Int|Undef"; $self->{"args"} = $value; }; # Attribute min_args (type: Int|Undef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 37 if ( exists $args->{"min_args"} ) { do { package Sub::HandlesVia::Mite; ( ( do { my $tmp = $args->{"min_args"}; defined($tmp) and !ref($tmp) and $tmp =~ /\A-?[0-9]+\z/; } ) or do { package Sub::HandlesVia::Mite; !defined( $args->{"min_args"} ); } ); } or croak "Type check failed in constructor: %s should be %s", "min_args", "Int|Undef"; $self->{"min_args"} = $args->{"min_args"}; } # Attribute max_args (type: Int|Undef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 37 if ( exists $args->{"max_args"} ) { do { package Sub::HandlesVia::Mite; ( ( do { my $tmp = $args->{"max_args"}; defined($tmp) and !ref($tmp) and $tmp =~ /\A-?[0-9]+\z/; } ) or do { package Sub::HandlesVia::Mite; !defined( $args->{"max_args"} ); } ); } or croak "Type check failed in constructor: %s should be %s", "max_args", "Int|Undef"; $self->{"max_args"} = $args->{"max_args"}; } # Attribute signature (type: ArrayRef|Undef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 43 if ( exists $args->{"signature"} ) { do { package Sub::HandlesVia::Mite; ( do { package Sub::HandlesVia::Mite; ref( $args->{"signature"} ) eq 'ARRAY'; } or do { package Sub::HandlesVia::Mite; !defined( $args->{"signature"} ); } ); } or croak "Type check failed in constructor: %s should be %s", "signature", "ArrayRef|Undef"; $self->{"signature"} = $args->{"signature"}; } # Attribute usage (type: Str) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 48 if ( exists $args->{"usage"} ) { do { package Sub::HandlesVia::Mite; defined( $args->{"usage"} ) and do { ref( \$args->{"usage"} ) eq 'SCALAR' or ref( \( my $val = $args->{"usage"} ) ) eq 'SCALAR'; } } or croak "Type check failed in constructor: %s should be %s", "usage", "Str"; $self->{"usage"} = $args->{"usage"}; } # Attribute curried (type: ArrayRef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 54 if ( exists $args->{"curried"} ) { do { package Sub::HandlesVia::Mite; ref( $args->{"curried"} ) eq 'ARRAY'; } or croak "Type check failed in constructor: %s should be %s", "curried", "ArrayRef"; $self->{"curried"} = $args->{"curried"}; } # Attribute is_chainable (type: Bool) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 59 if ( exists $args->{"is_chainable"} ) { do { my $coerced_value = do { my $to_coerce = $args->{"is_chainable"}; ( ( !ref $to_coerce and ( !defined $to_coerce or $to_coerce eq q() or $to_coerce eq '0' or $to_coerce eq '1' ) ) ) ? $to_coerce : ( ( !!1 ) ) ? scalar( do { local $_ = $to_coerce; !!$_ } ) : $to_coerce; }; ( !ref $coerced_value and ( !defined $coerced_value or $coerced_value eq q() or $coerced_value eq '0' or $coerced_value eq '1' ) ) or croak "Type check failed in constructor: %s should be %s", "is_chainable", "Bool"; $self->{"is_chainable"} = $coerced_value; }; } # Attribute no_validation_needed (type: Bool) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 59 if ( exists $args->{"no_validation_needed"} ) { do { my $coerced_value = do { my $to_coerce = $args->{"no_validation_needed"}; ( ( !ref $to_coerce and ( !defined $to_coerce or $to_coerce eq q() or $to_coerce eq '0' or $to_coerce eq '1' ) ) ) ? $to_coerce : ( ( !!1 ) ) ? scalar( do { local $_ = $to_coerce; !!$_ } ) : $to_coerce; }; ( !ref $coerced_value and ( !defined $coerced_value or $coerced_value eq q() or $coerced_value eq '0' or $coerced_value eq '1' ) ) or croak "Type check failed in constructor: %s should be %s", "no_validation_needed", "Bool"; $self->{"no_validation_needed"} = $coerced_value; }; } # Attribute is_mutator (type: Bool) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 70 if ( exists $args->{"is_mutator"} ) { do { my $coerced_value = do { my $to_coerce = $args->{"is_mutator"}; ( ( !ref $to_coerce and ( !defined $to_coerce or $to_coerce eq q() or $to_coerce eq '0' or $to_coerce eq '1' ) ) ) ? $to_coerce : ( ( !!1 ) ) ? scalar( do { local $_ = $to_coerce; !!$_ } ) : $to_coerce; }; ( !ref $coerced_value and ( !defined $coerced_value or $coerced_value eq q() or $coerced_value eq '0' or $coerced_value eq '1' ) ) or croak "Type check failed in constructor: %s should be %s", "is_mutator", "Bool"; $self->{"is_mutator"} = $coerced_value; }; } # Attribute allow_getter_shortcuts (type: Bool) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 72 do { my $value = exists( $args->{"allow_getter_shortcuts"} ) ? $args->{"allow_getter_shortcuts"} : true; do { my $coerced_value = do { my $to_coerce = $value; ( ( !ref $to_coerce and ( !defined $to_coerce or $to_coerce eq q() or $to_coerce eq '0' or $to_coerce eq '1' ) ) ) ? $to_coerce : ( ( !!1 ) ) ? scalar( do { local $_ = $to_coerce; !!$_ } ) : $to_coerce; }; ( !ref $coerced_value and ( !defined $coerced_value or $coerced_value eq q() or $coerced_value eq '0' or $coerced_value eq '1' ) ) or croak "Type check failed in constructor: %s should be %s", "allow_getter_shortcuts", "Bool"; $self->{"allow_getter_shortcuts"} = $coerced_value; }; }; # Attribute prefer_shift_self (type: Bool) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 79 do { my $value = exists( $args->{"prefer_shift_self"} ) ? $args->{"prefer_shift_self"} : false; do { my $coerced_value = do { my $to_coerce = $value; ( ( !ref $to_coerce and ( !defined $to_coerce or $to_coerce eq q() or $to_coerce eq '0' or $to_coerce eq '1' ) ) ) ? $to_coerce : ( ( !!1 ) ) ? scalar( do { local $_ = $to_coerce; !!$_ } ) : $to_coerce; }; ( !ref $coerced_value and ( !defined $coerced_value or $coerced_value eq q() or $coerced_value eq '0' or $coerced_value eq '1' ) ) or croak "Type check failed in constructor: %s should be %s", "prefer_shift_self", "Bool"; $self->{"prefer_shift_self"} = $coerced_value; }; }; # Attribute additional_validation (type: CodeRef|Str|Undef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 86 if ( exists $args->{"additional_validation"} ) { do { package Sub::HandlesVia::Mite; ( do { package Sub::HandlesVia::Mite; ref( $args->{"additional_validation"} ) eq 'CODE'; } or do { package Sub::HandlesVia::Mite; defined( $args->{"additional_validation"} ) and do { ref( \$args->{"additional_validation"} ) eq 'SCALAR' or ref( \( my $val = $args->{"additional_validation"} ) ) eq 'SCALAR'; } } or do { package Sub::HandlesVia::Mite; !defined( $args->{"additional_validation"} ); } ); } or croak "Type check failed in constructor: %s should be %s", "additional_validation", "CodeRef|Str|Undef"; $self->{"additional_validation"} = $args->{"additional_validation"}; } # Attribute default_for_reset (type: CodeRef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 91 if ( exists $args->{"default_for_reset"} ) { do { package Sub::HandlesVia::Mite; ref( $args->{"default_for_reset"} ) eq 'CODE'; } or croak "Type check failed in constructor: %s should be %s", "default_for_reset", "CodeRef"; $self->{"default_for_reset"} = $args->{"default_for_reset"}; } # Attribute documentation (type: Str) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 96 if ( exists $args->{"documentation"} ) { do { package Sub::HandlesVia::Mite; defined( $args->{"documentation"} ) and do { ref( \$args->{"documentation"} ) eq 'SCALAR' or ref( \( my $val = $args->{"documentation"} ) ) eq 'SCALAR'; } } or croak "Type check failed in constructor: %s should be %s", "documentation", "Str"; $self->{"documentation"} = $args->{"documentation"}; } # Attribute _examples (type: CodeRef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 101 if ( exists $args->{"_examples"} ) { do { package Sub::HandlesVia::Mite; ref( $args->{"_examples"} ) eq 'CODE'; } or croak "Type check failed in constructor: %s should be %s", "_examples", "CodeRef"; $self->{"_examples"} = $args->{"_examples"}; } # Call BUILD methods $self->BUILDALL($args) if ( !$no_build and @{ $meta->{BUILD} || [] } ); # Unrecognized parameters my @unknown = grep not( /\A(?:_examples|a(?:dditional_validation|llow_getter_shortcuts|rgs)|curried|d(?:efault_for_reset|ocumentation)|is_(?:chainable|mutator)|lvalue_template|m(?:ax_args|in_args)|n(?:ame|o_validation_needed)|prefer_shift_self|signature|template|usage)\z/ ), keys %{$args}; @unknown and croak( "Unexpected keys in constructor: " . join( q[, ], sort @unknown ) ); return $self; } # Used by constructor to call BUILD methods sub BUILDALL { my $class = ref( $_[0] ); my $meta = ( $Mite::META{$class} ||= $class->__META__ ); $_->(@_) for @{ $meta->{BUILD} || [] }; } # Destructor should call DEMOLISH methods sub DESTROY { my $self = shift; my $class = ref($self) || $self; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $in_global_destruction = defined ${^GLOBAL_PHASE} ? ${^GLOBAL_PHASE} eq 'DESTRUCT' : Devel::GlobalDestruction::in_global_destruction(); for my $demolisher ( @{ $meta->{DEMOLISH} || [] } ) { my $e = do { local ( $?, $@ ); eval { $demolisher->( $self, $in_global_destruction ) }; $@; }; no warnings 'misc'; # avoid (in cleanup) warnings die $e if $e; # rethrow } return; } my $__XS = !$ENV{PERL_ONLY} && eval { require Class::XSAccessor; Class::XSAccessor->VERSION("1.19") }; # Accessors for _examples # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 101 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "_examples" => "_examples" }, ); } else { *_examples = sub { @_ == 1 or croak('Reader "_examples" usage: $self->_examples()'); $_[0]{"_examples"}; }; } # Accessors for additional_validation # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 86 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "additional_validation" => "additional_validation" }, ); } else { *additional_validation = sub { @_ == 1 or croak( 'Reader "additional_validation" usage: $self->additional_validation()' ); $_[0]{"additional_validation"}; }; } # Accessors for allow_getter_shortcuts # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 72 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "allow_getter_shortcuts" => "allow_getter_shortcuts" }, ); } else { *allow_getter_shortcuts = sub { @_ == 1 or croak( 'Reader "allow_getter_shortcuts" usage: $self->allow_getter_shortcuts()' ); $_[0]{"allow_getter_shortcuts"}; }; } # Accessors for args # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 27 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "args" => "args" }, ); } else { *args = sub { @_ == 1 or croak('Reader "args" usage: $self->args()'); $_[0]{"args"}; }; } # Accessors for curried # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 54 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "curried" => "curried" }, ); } else { *curried = sub { @_ == 1 or croak('Reader "curried" usage: $self->curried()'); $_[0]{"curried"}; }; } # Accessors for default_for_reset # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 91 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "default_for_reset" => "default_for_reset" }, ); } else { *default_for_reset = sub { @_ == 1 or croak( 'Reader "default_for_reset" usage: $self->default_for_reset()'); $_[0]{"default_for_reset"}; }; } # Accessors for documentation # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 96 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "documentation" => "documentation" }, ); } else { *documentation = sub { @_ == 1 or croak('Reader "documentation" usage: $self->documentation()'); $_[0]{"documentation"}; }; } # Accessors for is_chainable # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 59 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "is_chainable" => "is_chainable" }, ); } else { *is_chainable = sub { @_ == 1 or croak('Reader "is_chainable" usage: $self->is_chainable()'); $_[0]{"is_chainable"}; }; } # Accessors for is_mutator # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 70 sub is_mutator { @_ == 1 or croak('Reader "is_mutator" usage: $self->is_mutator()'); ( exists( $_[0]{"is_mutator"} ) ? $_[0]{"is_mutator"} : ( $_[0]{"is_mutator"} = do { my $default_value = do { my $to_coerce = $Sub::HandlesVia::Handler::__is_mutator_DEFAULT__->( $_[0] ); ( ( !ref $to_coerce and ( !defined $to_coerce or $to_coerce eq q() or $to_coerce eq '0' or $to_coerce eq '1' ) ) ) ? $to_coerce : ( ( !!1 ) ) ? scalar( do { local $_ = $to_coerce; !!$_ } ) : $to_coerce; }; ( !ref $default_value and ( !defined $default_value or $default_value eq q() or $default_value eq '0' or $default_value eq '1' ) ) or croak( "Type check failed in default: %s should be %s", "is_mutator", "Bool" ); $default_value; } ) ); } # Accessors for lvalue_template # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 22 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "lvalue_template" => "lvalue_template" }, ); } else { *lvalue_template = sub { @_ == 1 or croak('Reader "lvalue_template" usage: $self->lvalue_template()'); $_[0]{"lvalue_template"}; }; } # Accessors for max_args # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 37 sub max_args { @_ == 1 or croak('Reader "max_args" usage: $self->max_args()'); ( exists( $_[0]{"max_args"} ) ? $_[0]{"max_args"} : ( $_[0]{"max_args"} = do { my $default_value = $_[0]->_build_max_args; do { package Sub::HandlesVia::Mite; ( ( do { my $tmp = $default_value; defined($tmp) and !ref($tmp) and $tmp =~ /\A-?[0-9]+\z/; } ) or ( !defined($default_value) ) ); } or croak( "Type check failed in default: %s should be %s", "max_args", "Int|Undef" ); $default_value; } ) ); } # Accessors for min_args # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 37 sub min_args { @_ == 1 or croak('Reader "min_args" usage: $self->min_args()'); ( exists( $_[0]{"min_args"} ) ? $_[0]{"min_args"} : ( $_[0]{"min_args"} = do { my $default_value = $_[0]->_build_min_args; do { package Sub::HandlesVia::Mite; ( ( do { my $tmp = $default_value; defined($tmp) and !ref($tmp) and $tmp =~ /\A-?[0-9]+\z/; } ) or ( !defined($default_value) ) ); } or croak( "Type check failed in default: %s should be %s", "min_args", "Int|Undef" ); $default_value; } ) ); } # Accessors for name # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 12 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "name" => "name" }, ); } else { *name = sub { @_ == 1 or croak('Reader "name" usage: $self->name()'); $_[0]{"name"}; }; } # Accessors for no_validation_needed # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 59 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "no_validation_needed" => "no_validation_needed" }, ); } else { *no_validation_needed = sub { @_ == 1 or croak( 'Reader "no_validation_needed" usage: $self->no_validation_needed()' ); $_[0]{"no_validation_needed"}; }; } # Accessors for prefer_shift_self # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 79 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "prefer_shift_self" => "prefer_shift_self" }, ); } else { *prefer_shift_self = sub { @_ == 1 or croak( 'Reader "prefer_shift_self" usage: $self->prefer_shift_self()'); $_[0]{"prefer_shift_self"}; }; } # Accessors for signature # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 43 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "signature" => "signature" }, ); } else { *signature = sub { @_ == 1 or croak('Reader "signature" usage: $self->signature()'); $_[0]{"signature"}; }; } # Accessors for template # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 17 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "template" => "template" }, ); } else { *template = sub { @_ == 1 or croak('Reader "template" usage: $self->template()'); $_[0]{"template"}; }; } # Accessors for usage # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 48 sub usage { @_ == 1 or croak('Reader "usage" usage: $self->usage()'); ( exists( $_[0]{"usage"} ) ? $_[0]{"usage"} : ( $_[0]{"usage"} = do { my $default_value = $_[0]->_build_usage; do { package Sub::HandlesVia::Mite; defined($default_value) and do { ref( \$default_value ) eq 'SCALAR' or ref( \( my $val = $default_value ) ) eq 'SCALAR'; } } or croak( "Type check failed in default: %s should be %s", "usage", "Str" ); $default_value; } ) ); } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can('does_role') and $meta->does_role($role) and return 1; } return $self->SUPER::DOES($role); } # Alias for Moose/Moo-compatibility sub does { shift->DOES(@_); } 1; } { package Sub::HandlesVia::Handler::Traditional; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Class"; our $MITE_SHIM = "Sub::HandlesVia::Mite"; our $MITE_VERSION = "0.013000"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "Sub::HandlesVia::Mite", "Sub::HandlesVia::Handler::Traditional" ); ( *after, *around, *before, *extends, *field, *has, *param, *signature_for, *with ) = do { package Sub::HandlesVia::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "class", @_ ) }, sub { }, sub { $SHIM->HANDLE_has( $CALLER, field => @_ ) }, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub { $SHIM->HANDLE_has( $CALLER, param => @_ ) }, sub { $SHIM->HANDLE_signature_for( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; } # Mite imports BEGIN { require Scalar::Util; *STRICT = \&Sub::HandlesVia::Mite::STRICT; *bare = \&Sub::HandlesVia::Mite::bare; *blessed = \&Scalar::Util::blessed; *carp = \&Sub::HandlesVia::Mite::carp; *confess = \&Sub::HandlesVia::Mite::confess; *croak = \&Sub::HandlesVia::Mite::croak; *false = \&Sub::HandlesVia::Mite::false; *guard = \&Sub::HandlesVia::Mite::guard; *lazy = \&Sub::HandlesVia::Mite::lazy; *lock = \&Sub::HandlesVia::Mite::lock; *ro = \&Sub::HandlesVia::Mite::ro; *rw = \&Sub::HandlesVia::Mite::rw; *rwp = \&Sub::HandlesVia::Mite::rwp; *true = \&Sub::HandlesVia::Mite::true; *unlock = \&Sub::HandlesVia::Mite::unlock; } BEGIN { use mro 'c3'; our @ISA; push @ISA, "Sub::HandlesVia::Handler"; } # Standard Moose/Moo-style constructor sub new { my $class = ref( $_[0] ) ? ref(shift) : shift; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $self = bless {}, $class; my $args = $meta->{HAS_BUILDARGS} ? $class->BUILDARGS(@_) : { ( @_ == 1 ) ? %{ $_[0] } : @_ }; my $no_build = delete $args->{__no_BUILD__}; # Attribute template (type: Str) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 17 if ( exists $args->{"template"} ) { do { package Sub::HandlesVia::Mite; defined( $args->{"template"} ) and do { ref( \$args->{"template"} ) eq 'SCALAR' or ref( \( my $val = $args->{"template"} ) ) eq 'SCALAR'; } } or croak "Type check failed in constructor: %s should be %s", "template", "Str"; $self->{"template"} = $args->{"template"}; } # Attribute lvalue_template (type: Str) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 22 if ( exists $args->{"lvalue_template"} ) { do { package Sub::HandlesVia::Mite; defined( $args->{"lvalue_template"} ) and do { ref( \$args->{"lvalue_template"} ) eq 'SCALAR' or ref( \( my $val = $args->{"lvalue_template"} ) ) eq 'SCALAR'; } } or croak "Type check failed in constructor: %s should be %s", "lvalue_template", "Str"; $self->{"lvalue_template"} = $args->{"lvalue_template"}; } # Attribute args (type: Int|Undef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 27 do { my $value = exists( $args->{"args"} ) ? $args->{"args"} : undef; do { package Sub::HandlesVia::Mite; ( ( do { my $tmp = $value; defined($tmp) and !ref($tmp) and $tmp =~ /\A-?[0-9]+\z/; } ) or ( !defined($value) ) ); } or croak "Type check failed in constructor: %s should be %s", "args", "Int|Undef"; $self->{"args"} = $value; }; # Attribute min_args (type: Int|Undef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 37 if ( exists $args->{"min_args"} ) { do { package Sub::HandlesVia::Mite; ( ( do { my $tmp = $args->{"min_args"}; defined($tmp) and !ref($tmp) and $tmp =~ /\A-?[0-9]+\z/; } ) or do { package Sub::HandlesVia::Mite; !defined( $args->{"min_args"} ); } ); } or croak "Type check failed in constructor: %s should be %s", "min_args", "Int|Undef"; $self->{"min_args"} = $args->{"min_args"}; } # Attribute max_args (type: Int|Undef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 37 if ( exists $args->{"max_args"} ) { do { package Sub::HandlesVia::Mite; ( ( do { my $tmp = $args->{"max_args"}; defined($tmp) and !ref($tmp) and $tmp =~ /\A-?[0-9]+\z/; } ) or do { package Sub::HandlesVia::Mite; !defined( $args->{"max_args"} ); } ); } or croak "Type check failed in constructor: %s should be %s", "max_args", "Int|Undef"; $self->{"max_args"} = $args->{"max_args"}; } # Attribute signature (type: ArrayRef|Undef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 43 if ( exists $args->{"signature"} ) { do { package Sub::HandlesVia::Mite; ( do { package Sub::HandlesVia::Mite; ref( $args->{"signature"} ) eq 'ARRAY'; } or do { package Sub::HandlesVia::Mite; !defined( $args->{"signature"} ); } ); } or croak "Type check failed in constructor: %s should be %s", "signature", "ArrayRef|Undef"; $self->{"signature"} = $args->{"signature"}; } # Attribute usage (type: Str) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 48 if ( exists $args->{"usage"} ) { do { package Sub::HandlesVia::Mite; defined( $args->{"usage"} ) and do { ref( \$args->{"usage"} ) eq 'SCALAR' or ref( \( my $val = $args->{"usage"} ) ) eq 'SCALAR'; } } or croak "Type check failed in constructor: %s should be %s", "usage", "Str"; $self->{"usage"} = $args->{"usage"}; } # Attribute curried (type: ArrayRef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 54 if ( exists $args->{"curried"} ) { do { package Sub::HandlesVia::Mite; ref( $args->{"curried"} ) eq 'ARRAY'; } or croak "Type check failed in constructor: %s should be %s", "curried", "ArrayRef"; $self->{"curried"} = $args->{"curried"}; } # Attribute is_chainable (type: Bool) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 59 if ( exists $args->{"is_chainable"} ) { do { my $coerced_value = do { my $to_coerce = $args->{"is_chainable"}; ( ( !ref $to_coerce and ( !defined $to_coerce or $to_coerce eq q() or $to_coerce eq '0' or $to_coerce eq '1' ) ) ) ? $to_coerce : ( ( !!1 ) ) ? scalar( do { local $_ = $to_coerce; !!$_ } ) : $to_coerce; }; ( !ref $coerced_value and ( !defined $coerced_value or $coerced_value eq q() or $coerced_value eq '0' or $coerced_value eq '1' ) ) or croak "Type check failed in constructor: %s should be %s", "is_chainable", "Bool"; $self->{"is_chainable"} = $coerced_value; }; } # Attribute no_validation_needed (type: Bool) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 59 if ( exists $args->{"no_validation_needed"} ) { do { my $coerced_value = do { my $to_coerce = $args->{"no_validation_needed"}; ( ( !ref $to_coerce and ( !defined $to_coerce or $to_coerce eq q() or $to_coerce eq '0' or $to_coerce eq '1' ) ) ) ? $to_coerce : ( ( !!1 ) ) ? scalar( do { local $_ = $to_coerce; !!$_ } ) : $to_coerce; }; ( !ref $coerced_value and ( !defined $coerced_value or $coerced_value eq q() or $coerced_value eq '0' or $coerced_value eq '1' ) ) or croak "Type check failed in constructor: %s should be %s", "no_validation_needed", "Bool"; $self->{"no_validation_needed"} = $coerced_value; }; } # Attribute is_mutator (type: Bool) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 70 if ( exists $args->{"is_mutator"} ) { do { my $coerced_value = do { my $to_coerce = $args->{"is_mutator"}; ( ( !ref $to_coerce and ( !defined $to_coerce or $to_coerce eq q() or $to_coerce eq '0' or $to_coerce eq '1' ) ) ) ? $to_coerce : ( ( !!1 ) ) ? scalar( do { local $_ = $to_coerce; !!$_ } ) : $to_coerce; }; ( !ref $coerced_value and ( !defined $coerced_value or $coerced_value eq q() or $coerced_value eq '0' or $coerced_value eq '1' ) ) or croak "Type check failed in constructor: %s should be %s", "is_mutator", "Bool"; $self->{"is_mutator"} = $coerced_value; }; } # Attribute allow_getter_shortcuts (type: Bool) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 72 do { my $value = exists( $args->{"allow_getter_shortcuts"} ) ? $args->{"allow_getter_shortcuts"} : true; do { my $coerced_value = do { my $to_coerce = $value; ( ( !ref $to_coerce and ( !defined $to_coerce or $to_coerce eq q() or $to_coerce eq '0' or $to_coerce eq '1' ) ) ) ? $to_coerce : ( ( !!1 ) ) ? scalar( do { local $_ = $to_coerce; !!$_ } ) : $to_coerce; }; ( !ref $coerced_value and ( !defined $coerced_value or $coerced_value eq q() or $coerced_value eq '0' or $coerced_value eq '1' ) ) or croak "Type check failed in constructor: %s should be %s", "allow_getter_shortcuts", "Bool"; $self->{"allow_getter_shortcuts"} = $coerced_value; }; }; # Attribute prefer_shift_self (type: Bool) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 79 do { my $value = exists( $args->{"prefer_shift_self"} ) ? $args->{"prefer_shift_self"} : false; do { my $coerced_value = do { my $to_coerce = $value; ( ( !ref $to_coerce and ( !defined $to_coerce or $to_coerce eq q() or $to_coerce eq '0' or $to_coerce eq '1' ) ) ) ? $to_coerce : ( ( !!1 ) ) ? scalar( do { local $_ = $to_coerce; !!$_ } ) : $to_coerce; }; ( !ref $coerced_value and ( !defined $coerced_value or $coerced_value eq q() or $coerced_value eq '0' or $coerced_value eq '1' ) ) or croak "Type check failed in constructor: %s should be %s", "prefer_shift_self", "Bool"; $self->{"prefer_shift_self"} = $coerced_value; }; }; # Attribute additional_validation (type: CodeRef|Str|Undef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 86 if ( exists $args->{"additional_validation"} ) { do { package Sub::HandlesVia::Mite; ( do { package Sub::HandlesVia::Mite; ref( $args->{"additional_validation"} ) eq 'CODE'; } or do { package Sub::HandlesVia::Mite; defined( $args->{"additional_validation"} ) and do { ref( \$args->{"additional_validation"} ) eq 'SCALAR' or ref( \( my $val = $args->{"additional_validation"} ) ) eq 'SCALAR'; } } or do { package Sub::HandlesVia::Mite; !defined( $args->{"additional_validation"} ); } ); } or croak "Type check failed in constructor: %s should be %s", "additional_validation", "CodeRef|Str|Undef"; $self->{"additional_validation"} = $args->{"additional_validation"}; } # Attribute default_for_reset (type: CodeRef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 91 if ( exists $args->{"default_for_reset"} ) { do { package Sub::HandlesVia::Mite; ref( $args->{"default_for_reset"} ) eq 'CODE'; } or croak "Type check failed in constructor: %s should be %s", "default_for_reset", "CodeRef"; $self->{"default_for_reset"} = $args->{"default_for_reset"}; } # Attribute documentation (type: Str) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 96 if ( exists $args->{"documentation"} ) { do { package Sub::HandlesVia::Mite; defined( $args->{"documentation"} ) and do { ref( \$args->{"documentation"} ) eq 'SCALAR' or ref( \( my $val = $args->{"documentation"} ) ) eq 'SCALAR'; } } or croak "Type check failed in constructor: %s should be %s", "documentation", "Str"; $self->{"documentation"} = $args->{"documentation"}; } # Attribute _examples (type: CodeRef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 101 if ( exists $args->{"_examples"} ) { do { package Sub::HandlesVia::Mite; ref( $args->{"_examples"} ) eq 'CODE'; } or croak "Type check failed in constructor: %s should be %s", "_examples", "CodeRef"; $self->{"_examples"} = $args->{"_examples"}; } # Attribute name (type: Str) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 282 croak "Missing key in constructor: name" unless exists $args->{"name"}; do { package Sub::HandlesVia::Mite; defined( $args->{"name"} ) and do { ref( \$args->{"name"} ) eq 'SCALAR' or ref( \( my $val = $args->{"name"} ) ) eq 'SCALAR'; } } or croak "Type check failed in constructor: %s should be %s", "name", "Str"; $self->{"name"} = $args->{"name"}; # Call BUILD methods $self->BUILDALL($args) if ( !$no_build and @{ $meta->{BUILD} || [] } ); # Unrecognized parameters my @unknown = grep not( /\A(?:_examples|a(?:dditional_validation|llow_getter_shortcuts|rgs)|curried|d(?:efault_for_reset|ocumentation)|is_(?:chainable|mutator)|lvalue_template|m(?:ax_args|in_args)|n(?:ame|o_validation_needed)|prefer_shift_self|signature|template|usage)\z/ ), keys %{$args}; @unknown and croak( "Unexpected keys in constructor: " . join( q[, ], sort @unknown ) ); return $self; } my $__XS = !$ENV{PERL_ONLY} && eval { require Class::XSAccessor; Class::XSAccessor->VERSION("1.19") }; # Accessors for name # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 282 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "name" => "name" }, ); } else { *name = sub { @_ == 1 or croak('Reader "name" usage: $self->name()'); $_[0]{"name"}; }; } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can('does_role') and $meta->does_role($role) and return 1; } return $self->SUPER::DOES($role); } # Alias for Moose/Moo-compatibility sub does { shift->DOES(@_); } 1; } { package Sub::HandlesVia::Handler::CodeRef; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Class"; our $MITE_SHIM = "Sub::HandlesVia::Mite"; our $MITE_VERSION = "0.013000"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "Sub::HandlesVia::Mite", "Sub::HandlesVia::Handler::CodeRef" ); ( *after, *around, *before, *extends, *field, *has, *param, *signature_for, *with ) = do { package Sub::HandlesVia::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "class", @_ ) }, sub { }, sub { $SHIM->HANDLE_has( $CALLER, field => @_ ) }, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub { $SHIM->HANDLE_has( $CALLER, param => @_ ) }, sub { $SHIM->HANDLE_signature_for( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; } # Mite imports BEGIN { require Scalar::Util; *STRICT = \&Sub::HandlesVia::Mite::STRICT; *bare = \&Sub::HandlesVia::Mite::bare; *blessed = \&Scalar::Util::blessed; *carp = \&Sub::HandlesVia::Mite::carp; *confess = \&Sub::HandlesVia::Mite::confess; *croak = \&Sub::HandlesVia::Mite::croak; *false = \&Sub::HandlesVia::Mite::false; *guard = \&Sub::HandlesVia::Mite::guard; *lazy = \&Sub::HandlesVia::Mite::lazy; *lock = \&Sub::HandlesVia::Mite::lock; *ro = \&Sub::HandlesVia::Mite::ro; *rw = \&Sub::HandlesVia::Mite::rw; *rwp = \&Sub::HandlesVia::Mite::rwp; *true = \&Sub::HandlesVia::Mite::true; *unlock = \&Sub::HandlesVia::Mite::unlock; } BEGIN { use mro 'c3'; our @ISA; push @ISA, "Sub::HandlesVia::Handler"; } # Standard Moose/Moo-style constructor sub new { my $class = ref( $_[0] ) ? ref(shift) : shift; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $self = bless {}, $class; my $args = $meta->{HAS_BUILDARGS} ? $class->BUILDARGS(@_) : { ( @_ == 1 ) ? %{ $_[0] } : @_ }; my $no_build = delete $args->{__no_BUILD__}; # Attribute name (type: Str) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 12 if ( exists $args->{"name"} ) { do { package Sub::HandlesVia::Mite; defined( $args->{"name"} ) and do { ref( \$args->{"name"} ) eq 'SCALAR' or ref( \( my $val = $args->{"name"} ) ) eq 'SCALAR'; } } or croak "Type check failed in constructor: %s should be %s", "name", "Str"; $self->{"name"} = $args->{"name"}; } # Attribute template (type: Str) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 17 if ( exists $args->{"template"} ) { do { package Sub::HandlesVia::Mite; defined( $args->{"template"} ) and do { ref( \$args->{"template"} ) eq 'SCALAR' or ref( \( my $val = $args->{"template"} ) ) eq 'SCALAR'; } } or croak "Type check failed in constructor: %s should be %s", "template", "Str"; $self->{"template"} = $args->{"template"}; } # Attribute lvalue_template (type: Str) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 22 if ( exists $args->{"lvalue_template"} ) { do { package Sub::HandlesVia::Mite; defined( $args->{"lvalue_template"} ) and do { ref( \$args->{"lvalue_template"} ) eq 'SCALAR' or ref( \( my $val = $args->{"lvalue_template"} ) ) eq 'SCALAR'; } } or croak "Type check failed in constructor: %s should be %s", "lvalue_template", "Str"; $self->{"lvalue_template"} = $args->{"lvalue_template"}; } # Attribute args (type: Int|Undef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 27 do { my $value = exists( $args->{"args"} ) ? $args->{"args"} : undef; do { package Sub::HandlesVia::Mite; ( ( do { my $tmp = $value; defined($tmp) and !ref($tmp) and $tmp =~ /\A-?[0-9]+\z/; } ) or ( !defined($value) ) ); } or croak "Type check failed in constructor: %s should be %s", "args", "Int|Undef"; $self->{"args"} = $value; }; # Attribute min_args (type: Int|Undef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 37 if ( exists $args->{"min_args"} ) { do { package Sub::HandlesVia::Mite; ( ( do { my $tmp = $args->{"min_args"}; defined($tmp) and !ref($tmp) and $tmp =~ /\A-?[0-9]+\z/; } ) or do { package Sub::HandlesVia::Mite; !defined( $args->{"min_args"} ); } ); } or croak "Type check failed in constructor: %s should be %s", "min_args", "Int|Undef"; $self->{"min_args"} = $args->{"min_args"}; } # Attribute max_args (type: Int|Undef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 37 if ( exists $args->{"max_args"} ) { do { package Sub::HandlesVia::Mite; ( ( do { my $tmp = $args->{"max_args"}; defined($tmp) and !ref($tmp) and $tmp =~ /\A-?[0-9]+\z/; } ) or do { package Sub::HandlesVia::Mite; !defined( $args->{"max_args"} ); } ); } or croak "Type check failed in constructor: %s should be %s", "max_args", "Int|Undef"; $self->{"max_args"} = $args->{"max_args"}; } # Attribute signature (type: ArrayRef|Undef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 43 if ( exists $args->{"signature"} ) { do { package Sub::HandlesVia::Mite; ( do { package Sub::HandlesVia::Mite; ref( $args->{"signature"} ) eq 'ARRAY'; } or do { package Sub::HandlesVia::Mite; !defined( $args->{"signature"} ); } ); } or croak "Type check failed in constructor: %s should be %s", "signature", "ArrayRef|Undef"; $self->{"signature"} = $args->{"signature"}; } # Attribute usage (type: Str) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 48 if ( exists $args->{"usage"} ) { do { package Sub::HandlesVia::Mite; defined( $args->{"usage"} ) and do { ref( \$args->{"usage"} ) eq 'SCALAR' or ref( \( my $val = $args->{"usage"} ) ) eq 'SCALAR'; } } or croak "Type check failed in constructor: %s should be %s", "usage", "Str"; $self->{"usage"} = $args->{"usage"}; } # Attribute curried (type: ArrayRef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 54 if ( exists $args->{"curried"} ) { do { package Sub::HandlesVia::Mite; ref( $args->{"curried"} ) eq 'ARRAY'; } or croak "Type check failed in constructor: %s should be %s", "curried", "ArrayRef"; $self->{"curried"} = $args->{"curried"}; } # Attribute is_chainable (type: Bool) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 59 if ( exists $args->{"is_chainable"} ) { do { my $coerced_value = do { my $to_coerce = $args->{"is_chainable"}; ( ( !ref $to_coerce and ( !defined $to_coerce or $to_coerce eq q() or $to_coerce eq '0' or $to_coerce eq '1' ) ) ) ? $to_coerce : ( ( !!1 ) ) ? scalar( do { local $_ = $to_coerce; !!$_ } ) : $to_coerce; }; ( !ref $coerced_value and ( !defined $coerced_value or $coerced_value eq q() or $coerced_value eq '0' or $coerced_value eq '1' ) ) or croak "Type check failed in constructor: %s should be %s", "is_chainable", "Bool"; $self->{"is_chainable"} = $coerced_value; }; } # Attribute no_validation_needed (type: Bool) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 59 if ( exists $args->{"no_validation_needed"} ) { do { my $coerced_value = do { my $to_coerce = $args->{"no_validation_needed"}; ( ( !ref $to_coerce and ( !defined $to_coerce or $to_coerce eq q() or $to_coerce eq '0' or $to_coerce eq '1' ) ) ) ? $to_coerce : ( ( !!1 ) ) ? scalar( do { local $_ = $to_coerce; !!$_ } ) : $to_coerce; }; ( !ref $coerced_value and ( !defined $coerced_value or $coerced_value eq q() or $coerced_value eq '0' or $coerced_value eq '1' ) ) or croak "Type check failed in constructor: %s should be %s", "no_validation_needed", "Bool"; $self->{"no_validation_needed"} = $coerced_value; }; } # Attribute is_mutator (type: Bool) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 70 if ( exists $args->{"is_mutator"} ) { do { my $coerced_value = do { my $to_coerce = $args->{"is_mutator"}; ( ( !ref $to_coerce and ( !defined $to_coerce or $to_coerce eq q() or $to_coerce eq '0' or $to_coerce eq '1' ) ) ) ? $to_coerce : ( ( !!1 ) ) ? scalar( do { local $_ = $to_coerce; !!$_ } ) : $to_coerce; }; ( !ref $coerced_value and ( !defined $coerced_value or $coerced_value eq q() or $coerced_value eq '0' or $coerced_value eq '1' ) ) or croak "Type check failed in constructor: %s should be %s", "is_mutator", "Bool"; $self->{"is_mutator"} = $coerced_value; }; } # Attribute allow_getter_shortcuts (type: Bool) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 72 do { my $value = exists( $args->{"allow_getter_shortcuts"} ) ? $args->{"allow_getter_shortcuts"} : true; do { my $coerced_value = do { my $to_coerce = $value; ( ( !ref $to_coerce and ( !defined $to_coerce or $to_coerce eq q() or $to_coerce eq '0' or $to_coerce eq '1' ) ) ) ? $to_coerce : ( ( !!1 ) ) ? scalar( do { local $_ = $to_coerce; !!$_ } ) : $to_coerce; }; ( !ref $coerced_value and ( !defined $coerced_value or $coerced_value eq q() or $coerced_value eq '0' or $coerced_value eq '1' ) ) or croak "Type check failed in constructor: %s should be %s", "allow_getter_shortcuts", "Bool"; $self->{"allow_getter_shortcuts"} = $coerced_value; }; }; # Attribute prefer_shift_self (type: Bool) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 79 do { my $value = exists( $args->{"prefer_shift_self"} ) ? $args->{"prefer_shift_self"} : false; do { my $coerced_value = do { my $to_coerce = $value; ( ( !ref $to_coerce and ( !defined $to_coerce or $to_coerce eq q() or $to_coerce eq '0' or $to_coerce eq '1' ) ) ) ? $to_coerce : ( ( !!1 ) ) ? scalar( do { local $_ = $to_coerce; !!$_ } ) : $to_coerce; }; ( !ref $coerced_value and ( !defined $coerced_value or $coerced_value eq q() or $coerced_value eq '0' or $coerced_value eq '1' ) ) or croak "Type check failed in constructor: %s should be %s", "prefer_shift_self", "Bool"; $self->{"prefer_shift_self"} = $coerced_value; }; }; # Attribute additional_validation (type: CodeRef|Str|Undef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 86 if ( exists $args->{"additional_validation"} ) { do { package Sub::HandlesVia::Mite; ( do { package Sub::HandlesVia::Mite; ref( $args->{"additional_validation"} ) eq 'CODE'; } or do { package Sub::HandlesVia::Mite; defined( $args->{"additional_validation"} ) and do { ref( \$args->{"additional_validation"} ) eq 'SCALAR' or ref( \( my $val = $args->{"additional_validation"} ) ) eq 'SCALAR'; } } or do { package Sub::HandlesVia::Mite; !defined( $args->{"additional_validation"} ); } ); } or croak "Type check failed in constructor: %s should be %s", "additional_validation", "CodeRef|Str|Undef"; $self->{"additional_validation"} = $args->{"additional_validation"}; } # Attribute default_for_reset (type: CodeRef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 91 if ( exists $args->{"default_for_reset"} ) { do { package Sub::HandlesVia::Mite; ref( $args->{"default_for_reset"} ) eq 'CODE'; } or croak "Type check failed in constructor: %s should be %s", "default_for_reset", "CodeRef"; $self->{"default_for_reset"} = $args->{"default_for_reset"}; } # Attribute documentation (type: Str) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 96 if ( exists $args->{"documentation"} ) { do { package Sub::HandlesVia::Mite; defined( $args->{"documentation"} ) and do { ref( \$args->{"documentation"} ) eq 'SCALAR' or ref( \( my $val = $args->{"documentation"} ) ) eq 'SCALAR'; } } or croak "Type check failed in constructor: %s should be %s", "documentation", "Str"; $self->{"documentation"} = $args->{"documentation"}; } # Attribute _examples (type: CodeRef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 101 if ( exists $args->{"_examples"} ) { do { package Sub::HandlesVia::Mite; ref( $args->{"_examples"} ) eq 'CODE'; } or croak "Type check failed in constructor: %s should be %s", "_examples", "CodeRef"; $self->{"_examples"} = $args->{"_examples"}; } # Attribute delegated_coderef (type: CodeRef) # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 303 croak "Missing key in constructor: delegated_coderef" unless exists $args->{"delegated_coderef"}; do { package Sub::HandlesVia::Mite; ref( $args->{"delegated_coderef"} ) eq 'CODE'; } or croak "Type check failed in constructor: %s should be %s", "delegated_coderef", "CodeRef"; $self->{"delegated_coderef"} = $args->{"delegated_coderef"}; # Call BUILD methods $self->BUILDALL($args) if ( !$no_build and @{ $meta->{BUILD} || [] } ); # Unrecognized parameters my @unknown = grep not( /\A(?:_examples|a(?:dditional_validation|llow_getter_shortcuts|rgs)|curried|d(?:e(?:fault_for_reset|legated_coderef)|ocumentation)|is_(?:chainable|mutator)|lvalue_template|m(?:ax_args|in_args)|n(?:ame|o_validation_needed)|prefer_shift_self|signature|template|usage)\z/ ), keys %{$args}; @unknown and croak( "Unexpected keys in constructor: " . join( q[, ], sort @unknown ) ); return $self; } my $__XS = !$ENV{PERL_ONLY} && eval { require Class::XSAccessor; Class::XSAccessor->VERSION("1.19") }; # Accessors for delegated_coderef # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 303 if ($__XS) { Class::XSAccessor->import( chained => 1, "getters" => { "delegated_coderef" => "delegated_coderef" }, ); } else { *delegated_coderef = sub { @_ == 1 or croak( 'Reader "delegated_coderef" usage: $self->delegated_coderef()'); $_[0]{"delegated_coderef"}; }; } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can('does_role') and $meta->does_role($role) and return 1; } return $self->SUPER::DOES($role); } # Alias for Moose/Moo-compatibility sub does { shift->DOES(@_); } 1; } HandlerLibrary.pm000664001750001750 206114772476615 22103 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesViause 5.008; use strict; use warnings; package Sub::HandlesVia::HandlerLibrary; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Types::Standard qw( Any Item ); sub _type_inspector { my ($me, $type) = @_; if (!$type or $type == Any or $type == Item) { return { trust_mutated => 'always', }; } return { trust_mutated => 'never' }; } { my %cache; sub get_handler { my ($me, $handler_name) = @_; $cache{$me} ||= $me->_populate_cache; $cache{$me}{$handler_name} ? $me->$handler_name : undef; } sub has_handler { my ($me, $handler_name) = @_; $cache{$me} ||= $me->_populate_cache; exists $cache{$me}{$handler_name}; } } # This is not necessarily an exhaustive list, however if it is non-exhaustive # then subclasses must override get_handler and has_handler. # sub handler_names { no strict 'refs'; @{ $_[0] . '::METHODS' } } sub _populate_cache { my %hash; $hash{$_} = 1 for $_[0]->handler_names; \%hash; } sub expand_shortcut { use Carp; Carp::croak( "Not implemented" ); } sub preprocess_spec { return; } 1; Mite.pm000664001750001750 2313114772476615 20120 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia# NOTE: Since the intention is to ship this file with a project, this file # cannot have any non-core dependencies. package Sub::HandlesVia::Mite; use 5.008001; use strict; use warnings; no strict 'refs'; if ( $] < 5.009005 ) { require MRO::Compat; } else { require mro; } defined ${^GLOBAL_PHASE} or eval { require Devel::GlobalDestruction; 1 } or do { carp( "WARNING: Devel::GlobalDestruction recommended!" ); *Devel::GlobalDestruction::in_global_destruction = sub { undef; }; }; # Constants sub true () { !!1 } sub false () { !!0 } sub ro () { 'ro' } sub rw () { 'rw' } sub rwp () { 'rwp' } sub lazy () { 'lazy' } sub bare () { 'bare' } # More complicated constants BEGIN { my @bool = ( \&false, \&true ); *_HAS_AUTOCLEAN = $bool[ 0+!! eval { require namespace::autoclean } ]; *STRICT = $bool[ 0+!! ( $ENV{PERL_STRICT} || $ENV{EXTENDED_TESTING} || $ENV{AUTHOR_TESTING} || $ENV{RELEASE_TESTING} ) ]; }; # Exportable error handlers sub _error_handler { my ( $func, $message, @args ) = @_; if ( @args ) { require Data::Dumper; local $Data::Dumper::Terse = 1; local $Data::Dumper::Indent = 0; $message = sprintf $message, map { ref($_) ? Data::Dumper::Dumper($_) : defined($_) ? $_ : '(undef)' } @args; } my $next = do { require Carp; \&{"Carp::$func"} }; @_ = ( $message ); goto $next; } sub carp { unshift @_, 'carp' ; goto \&_error_handler } sub croak { unshift @_, 'croak' ; goto \&_error_handler } sub confess { unshift @_, 'confess'; goto \&_error_handler } # Exportable guard function { my $GUARD_PACKAGE = __PACKAGE__ . '::Guard'; *{"$GUARD_PACKAGE\::DESTROY"} = sub { $_[0][0] or $_[0][1]->() }; *{"$GUARD_PACKAGE\::restore"} = sub { $_[0]->DESTROY; $_[0][0] = true }; *{"$GUARD_PACKAGE\::dismiss"} = sub { $_[0][0] = true }; *{"$GUARD_PACKAGE\::peek"} = sub { $_[0][2] }; *guard = sub (&) { bless [ 0, @_ ] => $GUARD_PACKAGE }; } # Exportable lock and unlock sub _lul { my ( $lul, $ref ) = @_; if ( ref $ref eq 'ARRAY' ) { &Internals::SvREADONLY( $ref, $lul ); &Internals::SvREADONLY( \$_, $lul ) for @$ref; return; } if ( ref $ref eq 'HASH' ) { &Internals::hv_clear_placeholders( $ref ); &Internals::SvREADONLY( $ref, $lul ); &Internals::SvREADONLY( \$_, $lul ) for values %$ref; return; } return; } sub lock { unshift @_, true; goto \&_lul; } sub unlock { my $ref = shift; _lul( 0 , $ref ); &guard( sub { _lul( 1, $ref ) } ); } sub _is_compiling { defined $Mite::COMPILING and $Mite::COMPILING eq __PACKAGE__; } sub import { my $me = shift; my %arg = map +( lc($_) => true ), @_; my ( $caller, $file ) = caller; if( _is_compiling() ) { require Mite::Project; 'Mite::Project'->default->inject_mite_functions( 'package' => $caller, 'file' => $file, 'arg' => \%arg, 'shim' => $me, ); } else { # Try to determine original filename for caller, minus libdir. # This would normally be in %INC but caller hasn't finished loading yet. require File::Spec; my $orig = $file; for my $base ( @INC ) { $base eq substr $file, 0, length $base and -f File::Spec->catfile( $base, substr $file, 1 + length $base ) and $orig = File::Spec->abs2rel( $file, $base ) and last; } # Changes to this filename must be coordinated with Mite::Compiled my $mite_file = $orig . '.mite.pm'; local $@; if ( not eval { require $mite_file; 1 } ) { my $e = $@; croak "Compiled Mite file ($mite_file) for $file is missing or an error occurred loading it: $e"; } } 'warnings'->import; 'strict'->import; 'namespace::autoclean'->import( -cleanee => $caller ) if _HAS_AUTOCLEAN && !$arg{'-unclean'}; } { my ( $cb_before, $cb_after ); sub _finalize_application_roletiny { my ( $me, $role, $caller, $args ) = @_; if ( $INC{'Role/Hooks.pm'} ) { $cb_before ||= \%Role::Hooks::CALLBACKS_BEFORE_APPLY; $cb_after ||= \%Role::Hooks::CALLBACKS_AFTER_APPLY; } if ( $cb_before ) { $_->( $role, $caller ) for @{ $cb_before->{$role} || [] }; } 'Role::Tiny'->_check_requires( $caller, $role ); my $info = $Role::Tiny::INFO{$role}; for ( @{ $info->{modifiers} || [] } ) { my @args = @$_; my $modification = shift @args; my $handler = "HANDLE_$modification"; $me->$handler( $caller, undef, @args ); } if ( $cb_after ) { $_->( $role, $caller ) for @{ $cb_after->{$role} || [] }; } return; } # Usage: $me, $caller, @with_args sub HANDLE_with { my ( $me, $caller ) = ( shift, shift ); while ( @_ ) { my $role = shift; my $args = ref($_[0]) ? shift : undef; if ( $INC{'Role/Tiny.pm'} and 'Role::Tiny'->is_role( $role ) ) { $me->_finalize_application_roletiny( $role, $caller, $args ); } else { $role->__FINALIZE_APPLICATION__( $caller, $args ); } } return; } } # Usage: $me, $caller, $keyword, @has_args sub HANDLE_has { my ( $me, $caller, $keyword, $names ) = ( shift, shift, shift, shift ); if ( @_ % 2 ) { my $default = shift; unshift @_, ( 'CODE' eq ref( $default ) ) ? ( is => lazy, builder => $default ) : ( is => ro, default => $default ); } my %spec = @_; my $code; for my $name ( ref($names) ? @$names : $names ) { $name =~ s/^\+//; 'CODE' eq ref( $code = $spec{default} ) and ${"$caller\::__$name\_DEFAULT__"} = $code; 'CODE' eq ref( $code = $spec{builder} ) and *{"$caller\::_build_$name"} = $code; 'CODE' eq ref( $code = $spec{trigger} ) and *{"$caller\::_trigger_$name"} = $code; 'CODE' eq ref( $code = $spec{clone} ) and *{"$caller\::_clone_$name"} = $code; } return; } { my $_kind = sub { ${ shift() . '::USES_MITE' } =~ /Role/ ? 'role' : 'class' }; sub _get_orig_method { my ( $caller, $name ) = @_; my $orig = $caller->can( $name ); return $orig if $orig; croak "Cannot modify method $name in $caller: no such method"; } sub _parse_mm_args { my $coderef = pop; my $names = [ map { ref($_) ? @$_ : $_ } @_ ]; ( $names, $coderef ); } # Usage: $me, $caller, $caller_kind, @before_args sub HANDLE_before { my ( $me, $caller, $kind ) = ( shift, shift, shift ); my ( $names, $coderef ) = &_parse_mm_args; $kind ||= $caller->$_kind; if ( $kind eq 'role' ) { push @{"$caller\::METHOD_MODIFIERS"}, [ before => $names, $coderef ]; return; } for my $name ( @$names ) { my $orig = _get_orig_method( $caller, $name ); local $@; eval <<"BEFORE" or die $@; package $caller; no warnings 'redefine'; sub $name { \$coderef->( \@_ ); \$orig->( \@_ ); } 1; BEFORE } return; } # Usage: $me, $caller, $caller_kind, @after_args sub HANDLE_after { my ( $me, $caller, $kind ) = ( shift, shift, shift ); my ( $names, $coderef ) = &_parse_mm_args; $kind ||= $caller->$_kind; if ( $kind eq 'role' ) { push @{"$caller\::METHOD_MODIFIERS"}, [ after => $names, $coderef ]; return; } for my $name ( @$names ) { my $orig = _get_orig_method( $caller, $name ); local $@; eval <<"AFTER" or die $@; package $caller; no warnings 'redefine'; sub $name { my \@r; if ( wantarray ) { \@r = \$orig->( \@_ ); } elsif ( defined wantarray ) { \@r = scalar \$orig->( \@_ ); } else { \$orig->( \@_ ); 1; } \$coderef->( \@_ ); wantarray ? \@r : \$r[0]; } 1; AFTER } return; } # Usage: $me, $caller, $caller_kind, @around_args sub HANDLE_around { my ( $me, $caller, $kind ) = ( shift, shift, shift ); my ( $names, $coderef ) = &_parse_mm_args; $kind ||= $caller->$_kind; if ( $kind eq 'role' ) { push @{"$caller\::METHOD_MODIFIERS"}, [ around => $names, $coderef ]; return; } for my $name ( @$names ) { my $orig = _get_orig_method( $caller, $name ); local $@; eval <<"AROUND" or die $@; package $caller; no warnings 'redefine'; sub $name { \$coderef->( \$orig, \@_ ); } 1; AROUND } return; } } # Usage: $me, $caller, $caller_kind, @signature_for_args sub HANDLE_signature_for { my ( $me, $caller, $kind, $name ) = @_; $name =~ s/^\+//; $me->HANDLE_around( $caller, $kind, $name, ${"$caller\::SIGNATURE_FOR"}{$name} ); return; } 1; Toolkit.pm000664001750001750 1635714772476615 20663 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesViause 5.008; use strict; use warnings; package Sub::HandlesVia::Toolkit; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Sub::HandlesVia::Mite; use Type::Params qw(compile_named_oo); use Types::Standard qw( ArrayRef HashRef Str Num Int CodeRef Bool Item Object ); use Types::Standard qw( is_ArrayRef is_HashRef is_Str is_Int is_CodeRef ); my $sig; sub install_delegations { $sig ||= compile_named_oo( target => Str, attribute => ArrayRef->of(Str|CodeRef)->plus_coercions(Str|CodeRef, '[$_]'), handles_via => ArrayRef->of(Str)->plus_coercions(Str, '[$_]'), handles => HashRef->plus_coercions(ArrayRef, '+{map(+($_,$_),@$_)}'), ); my $me = shift; my $arg = &$sig; my $gen = $me->code_generator_for_attribute( $arg->target, $arg->attribute, ); use Sub::HandlesVia::Handler; my %handles = %{ $arg->handles }; for my $h (sort keys %handles) { my $handler = 'Sub::HandlesVia::Handler'->lookup( $handles{$h}, $arg->handles_via, ); $handler->install_method( method_name => $h, code_generator => $gen, ); } } my %native = qw( Array 1 Blessed 1 Bool 1 Code 1 Counter 1 Hash 1 Number 1 Scalar 1 String 1 ); sub known_handler_libraries { sort keys %native; } my %default_type = ( Array => ArrayRef, Hash => HashRef, String => Str, Number => Num, Counter => Int, Code => CodeRef, Bool => Bool, Scalar => Item, Blessed => Object, ); my $trait_to_class = sub { my $hv_trait = shift; my $hv_class = $hv_trait =~ /:/ ? $hv_trait : "Sub::HandlesVia::HandlerLibrary::$hv_trait"; if ( $hv_class ne $hv_trait ) { local $@; eval "require $hv_class; 1" or warn $@; } $hv_class; }; sub clean_spec { my ($me, $target, $attr, $spec) = (shift, @_); delete $spec->{no_inline}; # Clean our stuff out of traits list... if (ref $spec->{traits} and not $spec->{handles_via}) { my @keep = grep !$native{$_}, @{$spec->{traits}}; my @cull = grep $native{$_}, @{$spec->{traits}}; delete $spec->{traits}; if (@keep) { $spec->{traits} = \@keep; } if (@cull) { $spec->{handles_via} = \@cull; } } return unless $spec->{handles_via}; my @handles_via = ref($spec->{handles_via}) ? @{$spec->{handles_via}} : $spec->{handles_via}; my $joined = join('|', @handles_via); for my $hv ( @handles_via ) { $trait_to_class->( $hv )->preprocess_spec( $target, $attr, $spec ); } if ($default_type{$joined} and not exists $spec->{isa}) { $spec->{isa} = $default_type{$joined}; $spec->{coerce} = 1 if $default_type{$joined}->has_coercion; } # Canonicalize handles hashref my %canon_handles; my @handles = is_ArrayRef( $spec->{handles} ) ? @{ delete $spec->{handles} } : delete( $spec->{handles} ); while ( @handles ) { my $item = shift @handles; $item = $trait_to_class->( $handles_via[0] )->expand_shortcut( $target, $attr, $spec, $item ) if is_Int $item; if ( is_Str $item ) { $canon_handles{$item} = $item; } elsif ( is_HashRef $item ) { %canon_handles = ( %canon_handles, %$item ); } else { require Carp; Carp::croak( "Unknown item as handles option: $item" ); } } return { target => $target, attribute => $attr, handles_via => delete( $spec->{handles_via} ), handles => \%canon_handles, }; } sub code_generator_for_attribute { my ($me, $target, $attr) = (shift, @_); my ($get_slot, $set_slot, $default) = @$attr; $set_slot = $get_slot if @$attr < 2; my $captures = {}; my ($get, $set, $slot, $get_is_lvalue) = (undef, undef, undef, 0); require B; if (ref $get_slot) { $get = sub { shift->generate_self . '->$shv_reader' }; $captures->{'$shv_reader'} = \$get_slot; } elsif ($get_slot =~ /\A \[ ([0-9]+) \] \z/sx) { my $index = $1; $get = sub { shift->generate_self . "->[$index]" }; $slot = $get; ++$get_is_lvalue; } elsif ($get_slot =~ /\A \{ (.+) \} \z/sx) { my $key = B::perlstring($1); $get = sub { shift->generate_self . "->{$key}" }; $slot = $get; ++$get_is_lvalue; } else { my $method = B::perlstring($get_slot); $get = sub { shift->generate_self . "->\${\\ $method}" }; } if (ref $set_slot) { $set = sub { my ($gen, $val) = @_; $gen->generate_self . "->\$shv_writer($val)"; }; $captures->{'$shv_writer'} = \$set_slot; } elsif ($set_slot =~ /\A \[ ([0-9]+) \] \z/sx) { my $index = $1; $set = sub { my ($gen, $val) = @_; my $self = $gen->generate_self; "($self\->[$index] = $val)"; }; } elsif ($set_slot =~ /\A \{ (.+) \} \z/sx) { my $key = B::perlstring($1); $set = sub { my ($gen, $val) = @_; my $self = $gen->generate_self; "($self\->{$key} = $val)"; }; } else { my $method = B::perlstring($set_slot); $set = sub { my ($gen, $val) = @_; my $self = $gen->generate_self; "$self\->\${\\ $method}($val)"; }; } if (is_CodeRef $default) { $captures->{'$shv_default_for_reset'} = \$default; } require Sub::HandlesVia::CodeGenerator; return 'Sub::HandlesVia::CodeGenerator'->new( toolkit => $me, target => $target, attribute => $attr, env => $captures, coerce => !!0, generator_for_get => $get, generator_for_set => $set, get_is_lvalue => $get_is_lvalue, set_checks_isa => !!1, set_strictly => !!1, generator_for_default => sub { my ( $gen, $handler ) = @_ or die; if ( !$default and $handler ) { return $handler->default_for_reset->(); } elsif ( is_CodeRef $default ) { return sprintf( '(%s)->$shv_default_for_reset', $gen->generate_self, ); } elsif ( is_Str $default ) { require B; return sprintf( '(%s)->${\ %s }', $gen->generate_self, B::perlstring( $default ), ); } return; }, ( $slot ? ( generator_for_slot => $slot ) : () ), ); } 1; __END__ =pod =encoding utf-8 =head1 NAME Sub::HandlesVia::Toolkit - integration with OO frameworks for Sub::HandlesVia =head1 DESCRIPTION B<< This module is part of Sub::HandlesVia's internal API. >> It is mostly of interest to people extending Sub::HandlesVia. Detect what subclass of Sub::HandlesVia::Toolkit is suitable for a class: my $toolkit = Sub::HandlesVia->detect_toolkit($class); Extract handles_via information from a C attribute spec hash: my $shvdata = $toolkit->clean_spec($class, $attrname, \%spec); This not only returns the data that Sub::HandlesVia needs, it also cleans C<< %spec >> so that it can be passed to a Moose-like C function without it complaining about unrecognized options. $toolkit->install_delegations($shvdata) if $shvdata; =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2020, 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. Toolkit.pm.mite.pm000664001750001750 1025414772476615 22221 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia{ package Sub::HandlesVia::Toolkit; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Class"; our $MITE_SHIM = "Sub::HandlesVia::Mite"; our $MITE_VERSION = "0.013000"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "Sub::HandlesVia::Mite", "Sub::HandlesVia::Toolkit" ); ( *after, *around, *before, *extends, *has, *signature_for, *with ) = do { package Sub::HandlesVia::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "class", @_ ) }, sub { }, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub { $SHIM->HANDLE_signature_for( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; } # Gather metadata for constructor and destructor sub __META__ { no strict 'refs'; my $class = shift; $class = ref($class) || $class; my $linear_isa = mro::get_linear_isa($class); return { BUILD => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::BUILD" } reverse @$linear_isa ], DEMOLISH => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::DEMOLISH" } @$linear_isa ], HAS_BUILDARGS => $class->can('BUILDARGS'), HAS_FOREIGNBUILDARGS => $class->can('FOREIGNBUILDARGS'), }; } # Standard Moose/Moo-style constructor sub new { my $class = ref( $_[0] ) ? ref(shift) : shift; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $self = bless {}, $class; my $args = $meta->{HAS_BUILDARGS} ? $class->BUILDARGS(@_) : { ( @_ == 1 ) ? %{ $_[0] } : @_ }; my $no_build = delete $args->{__no_BUILD__}; # Call BUILD methods $self->BUILDALL($args) if ( !$no_build and @{ $meta->{BUILD} || [] } ); # Unrecognized parameters my @unknown = grep not( do { package Sub::HandlesVia::Mite; defined($_) and do { ref( \$_ ) eq 'SCALAR' or ref( \( my $val = $_ ) ) eq 'SCALAR'; } } ), keys %{$args}; @unknown and Sub::HandlesVia::Mite::croak( "Unexpected keys in constructor: " . join( q[, ], sort @unknown ) ); return $self; } # Used by constructor to call BUILD methods sub BUILDALL { my $class = ref( $_[0] ); my $meta = ( $Mite::META{$class} ||= $class->__META__ ); $_->(@_) for @{ $meta->{BUILD} || [] }; } # Destructor should call DEMOLISH methods sub DESTROY { my $self = shift; my $class = ref($self) || $self; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $in_global_destruction = defined ${^GLOBAL_PHASE} ? ${^GLOBAL_PHASE} eq 'DESTRUCT' : Devel::GlobalDestruction::in_global_destruction(); for my $demolisher ( @{ $meta->{DEMOLISH} || [] } ) { my $e = do { local ( $?, $@ ); eval { $demolisher->( $self, $in_global_destruction ) }; $@; }; no warnings 'misc'; # avoid (in cleanup) warnings die $e if $e; # rethrow } return; } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can('does_role') and $meta->does_role($role) and return 1; } return $self->SUPER::DOES($role); } # Alias for Moose/Moo-compatibility sub does { shift->DOES(@_); } 1; } config000664001750001750 11114772476615 17051 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/.mite--- compiled_to: lib project: MyTest shim: MyTest::Mite source_from: lib MyTest.pm000664001750001750 35114772476615 17204 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/libpackage MyTest; use MyTest::Mite; use Sub::HandlesVia; has list => ( is => 'ro', isa => 'ArrayRef', default => \ '[11]', handles_via => 'Array', handles => { push => 'push', pop => 'pop', reset => 'reset', }, ); 1; MyTest.pm.mite.pm000664001750001750 1007614772476615 20621 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib{ package MyTest; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Class"; our $MITE_SHIM = "MyTest::Mite"; our $MITE_VERSION = "0.010008"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "MyTest::Mite", "MyTest" ); ( *after, *around, *before, *extends, *has, *signature_for, *with ) = do { package MyTest::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "class", @_ ) }, sub {}, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub { $SHIM->HANDLE_signature_for( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; }; # Gather metadata for constructor and destructor sub __META__ { no strict 'refs'; my $class = shift; $class = ref($class) || $class; my $linear_isa = mro::get_linear_isa( $class ); return { BUILD => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::BUILD" } reverse @$linear_isa ], DEMOLISH => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::DEMOLISH" } @$linear_isa ], HAS_BUILDARGS => $class->can('BUILDARGS'), HAS_FOREIGNBUILDARGS => $class->can('FOREIGNBUILDARGS'), }; } # Standard Moose/Moo-style constructor sub new { my $class = ref($_[0]) ? ref(shift) : shift; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $self = bless {}, $class; my $args = $meta->{HAS_BUILDARGS} ? $class->BUILDARGS( @_ ) : { ( @_ == 1 ) ? %{$_[0]} : @_ }; my $no_build = delete $args->{__no_BUILD__}; # Attribute list (type: ArrayRef) # has declaration, file lib/MyTest.pm, line 42 do { my $value = exists( $args->{"list"} ) ? $args->{"list"} : [11]; (ref($value) eq 'ARRAY') or MyTest::Mite::croak "Type check failed in constructor: %s should be %s", "list", "ArrayRef"; $self->{"list"} = $value; }; # Call BUILD methods $self->BUILDALL( $args ) if ( ! $no_build and @{ $meta->{BUILD} || [] } ); # Unrecognized parameters my @unknown = grep not( /\Alist\z/ ), keys %{$args}; @unknown and MyTest::Mite::croak( "Unexpected keys in constructor: " . join( q[, ], sort @unknown ) ); return $self; } # Used by constructor to call BUILD methods sub BUILDALL { my $class = ref( $_[0] ); my $meta = ( $Mite::META{$class} ||= $class->__META__ ); $_->( @_ ) for @{ $meta->{BUILD} || [] }; } # Destructor should call DEMOLISH methods sub DESTROY { my $self = shift; my $class = ref( $self ) || $self; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $in_global_destruction = defined ${^GLOBAL_PHASE} ? ${^GLOBAL_PHASE} eq 'DESTRUCT' : Devel::GlobalDestruction::in_global_destruction(); for my $demolisher ( @{ $meta->{DEMOLISH} || [] } ) { my $e = do { local ( $?, $@ ); eval { $demolisher->( $self, $in_global_destruction ) }; $@; }; no warnings 'misc'; # avoid (in cleanup) warnings die $e if $e; # rethrow } return; } my $__XS = !$ENV{PERL_ONLY} && eval { require Class::XSAccessor; Class::XSAccessor->VERSION("1.19") }; # Accessors for list # has declaration, file lib/MyTest.pm, line 42 if ( $__XS ) { Class::XSAccessor->import( chained => 1, "getters" => { "list" => "list" }, ); } else { *list = sub { @_ == 1 or MyTest::Mite::croak( 'Reader "list" usage: $self->list()' ); $_[0]{"list"} }; } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can( 'does_role' ) and $meta->does_role( $role ) and return 1; } return $self->SUPER::DOES( $role ); } # Alias for Moose/Moo-compatibility sub does { shift->DOES( @_ ); } 1; }Array.pm000664001750001750 10100714772476615 23221 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/HandlerLibraryuse 5.008; use strict; use warnings; package Sub::HandlesVia::HandlerLibrary::Array; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Exporter::Tiny; use Sub::HandlesVia::HandlerLibrary; our @ISA = qw( Exporter::Tiny Sub::HandlesVia::HandlerLibrary ); use Sub::HandlesVia::Handler qw( handler ); use Types::Standard qw( ArrayRef Optional Str CodeRef Int Item Any Ref Defined FileHandle ); sub HandleQueue () { 1 } sub HandleStack () { 2 } our @EXPORT = qw( HandleQueue HandleStack ); sub expand_shortcut { require Carp; my ( $class, $target, $attrname, $spec, $shortcut ) = @_; my %handlers; if ( HandleQueue & $shortcut ) { $handlers{"$attrname\_is_empty"} = 'is_empty'; $handlers{"$attrname\_size"} = 'count'; $handlers{"$attrname\_enqueue"} = 'push...'; $handlers{"$attrname\_dequeue"} = 'shift'; $handlers{"$attrname\_peek"} = [ get => 0 ]; } if ( HandleStack & $shortcut ) { $handlers{"$attrname\_is_empty"} = 'is_empty'; $handlers{"$attrname\_size"} = 'count'; $handlers{"$attrname\_push"} = 'push...'; $handlers{"$attrname\_pop"} = 'pop'; $handlers{"$attrname\_peek"} = [ get => -1 ]; } return \%handlers; } our @METHODS = qw( count is_empty all elements flatten get pop push shift unshift clear first first_index reduce set accessor natatime any shallow_clone map grep sort reverse sort_in_place splice shuffle shuffle_in_place uniq uniq_in_place delete insert flatten flatten_deep join print head tail apply pick_random for_each for_each_pair all_true not_all_true min minstr max maxstr sum product reductions sample uniqnum uniqnum_in_place uniqstr uniqstr_in_place pairs pairkeys pairvalues pairgrep pairfirst pairmap reset ); sub _type_inspector { my ($me, $type) = @_; if ($type == ArrayRef or $type == Defined or $type == Ref) { return { trust_mutated => 'always', }; } if ($type->is_parameterized and $type->parent->name eq 'ArrayRef' and $type->parent->library eq 'Types::Standard' and 1==@{$type->parameters}) { return { trust_mutated => 'maybe', value_type => $type->type_parameter, }; } return $me->SUPER::_type_inspector($type); } my $additional_validation_for_push_and_unshift = sub { my $self = CORE::shift; my ($sig_was_checked, $gen) = @_; my $ti = __PACKAGE__->_type_inspector($gen->isa); if ($ti and $ti->{trust_mutated} eq 'always') { return { code => '1;', env => {} }; } if ($ti and $ti->{trust_mutated} eq 'maybe') { my $coercion = ( $gen->coerce and $ti->{value_type}->has_coercion ); if ( $coercion ) { my $env = {}; my $code = sprintf( 'my @shv_values = map { my $shv_value = $_; %s } %s;', $gen->generate_type_assertion( $env, $ti->{value_type}, '$shv_value' ), $gen->generate_args, ); return { code => $code, env => $env, arg => sub { "\$shv_values[($_[0])-1]" }, args => sub { '@shv_values' }, argc => sub { 'scalar(@shv_values)' }, }; } else { my $env = {}; my $code = sprintf( 'for my $shv_value (%s) { %s }', $gen->generate_args, $gen->generate_type_assertion( $env, $ti->{value_type}, '$shv_value' ), ); return { code => $code, env => $env, }; } } return; }; my $additional_validation_for_set_and_insert = sub { my $self = CORE::shift; my ($sig_was_checked, $gen) = @_; my $ti = __PACKAGE__->_type_inspector($gen->isa); if ($ti and $ti->{trust_mutated} eq 'always') { return { code => '1;', env => {} }; } my ( $arg, $code, $env ); $env = {}; if ($ti and $ti->{trust_mutated} eq 'maybe') { $arg = sub { my $gen = CORE::shift; return '$shv_index' if $_[0]=='1'; return '$shv_value' if $_[0]=='2'; $gen->generate_arg( @_ ); }; if ( $sig_was_checked ) { $code = sprintf( 'my($shv_index,$shv_value)=%s; %s;', $gen->generate_args, $gen->generate_type_assertion( $env, $ti->{value_type}, '$shv_value' ), ); } else { $code = sprintf( 'my($shv_index,$shv_value)=%s; %s; %s;', $gen->generate_args, $gen->generate_type_assertion( $env, Int, '$shv_index' ), $gen->generate_type_assertion( $env, $ti->{value_type}, '$shv_value' ), ); } } return { code => $code, env => $env, arg => $arg, }; }; sub count { handler name => 'Array:count', args => 0, template => 'scalar(@{$GET})', documentation => 'The number of elements in the referenced array.', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo', 'bar' ] );\n", " say \$object->$method; ## ==> 2\n", "\n"; }, } sub is_empty { handler name => 'Array:is_empty', args => 0, template => '!scalar(@{$GET})', documentation => 'Boolean indicating if the referenced array is empty.', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo', 'bar' ] );\n", " say \$object->$method; ## ==> false\n", " \$object->_set_$attr( [] );\n", " say \$object->$method; ## ==> true\n", "\n"; }, } sub all { handler name => 'Array:all', args => 0, template => '@{$GET}', documentation => 'All elements in the array, in list context.', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo', 'bar' ] );\n", " my \@list = \$object->$method;\n", " say Dumper( \\\@list ); ## ==> [ 'foo', 'bar' ]\n", "\n"; }, } sub elements { handler name => 'Array:elements', args => 0, template => '@{$GET}', documentation => 'All elements in the array, in list context. (Essentially the same as C.)', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo', 'bar' ] );\n", " my \@list = \$object->$method;\n", " say Dumper( \\\@list ); ## ==> [ 'foo', 'bar' ]\n", "\n"; }, } sub flatten { handler name => 'Array:flatten', args => 0, template => '@{$GET}', documentation => 'All elements in the array, in list context. (Essentially the same as C.)', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo', 'bar' ] );\n", " my \@list = \$object->$method;\n", " say Dumper( \\\@list ); ## ==> [ 'foo', 'bar' ]\n", "\n"; }, } sub get { handler name => 'Array:get', args => 1, signature => [Int], usage => '$index', template => '($GET)->[$ARG]', documentation => 'Returns a single element from the array by index.', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n", " say \$object->$method( 0 ); ## ==> 'foo'\n", " say \$object->$method( 1 ); ## ==> 'bar'\n", " say \$object->$method( -1 ); ## ==> 'baz'\n", "\n"; }, } sub pop { my $me = CORE::shift; handler name => 'Array:pop', args => 0, template => 'my @shv_tmp = @{$GET}; my $shv_return = pop @shv_tmp; «\\@shv_tmp»; $shv_return', lvalue_template => 'pop(@{$GET})', additional_validation => 'no incoming values', documentation => 'Removes the last element from the array and returns it.', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n", " say \$object->$method; ## ==> 'baz'\n", " say \$object->$method; ## ==> 'bar'\n", " say Dumper( \$object->$attr ); ## ==> [ 'foo' ]\n", "\n"; }, } sub push { my $me = CORE::shift; handler name => 'Array:push', usage => '@values', template => 'my @shv_tmp = @{$GET}; my $shv_return = push(@shv_tmp, @ARG); «\\@shv_tmp»; $shv_return', lvalue_template => 'push(@{$GET}, @ARG)', prefer_shift_self => 1, additional_validation => $additional_validation_for_push_and_unshift, documentation => 'Adds elements to the end of the array.', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo' ] );\n", " \$object->$method( 'bar', 'baz' );\n", " say Dumper( \$object->$attr ); ## ==> [ 'foo', 'bar', 'baz' ]\n", "\n"; }, } sub shift { my $me = CORE::shift; handler name => 'Array:shift', args => 0, template => 'my @shv_tmp = @{$GET}; my $shv_return = shift @shv_tmp; «\\@shv_tmp»; $shv_return', lvalue_template => 'shift(@{$GET})', additional_validation => 'no incoming values', documentation => 'Removes an element from the start of the array and returns it.', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n", " say \$object->$method; ## ==> 'foo'\n", " say \$object->$method; ## ==> 'bar'\n", " say Dumper( \$object->$attr ); ## ==> [ 'baz' ]\n", "\n"; }, } sub unshift { my $me = CORE::shift; handler name => 'Array:unshift', usage => '@values', template => 'my @shv_tmp = @{$GET}; my $shv_return = unshift(@shv_tmp, @ARG); «\\@shv_tmp»; $shv_return', lvalue_template => 'unshift(@{$GET}, @ARG)', prefer_shift_self => 1, additional_validation => $additional_validation_for_push_and_unshift, documentation => 'Adds an element to the start of the array.', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo' ] );\n", " \$object->$method( 'bar', 'baz' );\n", " say Dumper( \$object->$attr ); ## ==> [ 'bar', 'baz', 'foo' ]\n", "\n"; }, } sub clear { my $me = CORE::shift; handler name => 'Array:clear', args => 0, template => '«[]»', lvalue_template => '@{$GET} = ()', additional_validation => 'no incoming values', documentation => 'Empties the array.', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo' ] );\n", " \$object->$method;\n", " say Dumper( \$object->$attr ); ## ==> []\n", "\n"; }, } sub first { require List::Util; handler name => 'Array:first', args => 1, signature => [CodeRef], usage => '$coderef', template => '&List::Util::first($ARG, @{$GET})', documentation => 'Like C<< List::Util::first() >>.', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n", " my \$found = \$object->$method( sub { /a/ } );\n", " say \$found; ## ==> 'bar'\n", "\n"; }, } sub any { require List::Util; handler name => 'Array:any', args => 1, signature => [CodeRef], usage => '$coderef', template => '&List::Util::any($ARG, @{$GET})', documentation => 'Like C<< List::Util::any() >>.', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n", " my \$truth = \$object->$method( sub { /a/ } );\n", " say \$truth; ## ==> true\n", "\n"; }, } sub first_index { my $me = __PACKAGE__; handler name => 'Array:first_index', args => 1, signature => [CodeRef], usage => '$coderef', template => 'for my $i ( 0 .. $#{$GET} ) { local *_ = \$GET->[$i]; return $i if $ARG->($_) }; return -1;', documentation => 'Like C<< List::MoreUtils::first_index() >>.', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n", " my \$found = \$object->$method( sub { /z\$/ } );\n", " say \$found; ## ==> 2\n", "\n"; }, } sub reduce { require List::Util; handler name => 'Array:reduce', args => 1, signature => [CodeRef], usage => '$coderef', template => 'my $shv_callback = $ARG; List::Util::reduce { $shv_callback->($a,$b) } @{$GET}', documentation => 'Like C<< List::Util::reduce() >>.', } sub set { my $me = CORE::shift; handler name => 'Array:set', args => 2, signature => [Int, Any], usage => '$index, $value', template => 'my @shv_tmp = @{$GET}; $shv_tmp[$ARG[1]] = $ARG[2]; «\\@shv_tmp»; $ARG[2]', lvalue_template => '($GET)->[ $ARG[1] ] = $ARG[2]', additional_validation => $additional_validation_for_set_and_insert, documentation => 'Sets the element with the given index to the supplied value.', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n", " \$object->$method( 1, 'quux' );\n", " say Dumper( \$object->$attr ); ## ==> [ 'foo', 'quux', 'baz' ]\n", "\n"; }, } sub accessor { handler name => 'Array:accessor', min_args => 1, max_args => 2, signature => [Int, Optional[Any]], usage => '$index, $value?', template => 'if (#ARG == 1) { ($GET)->[ $ARG[1] ] } else { my @shv_tmp = @{$GET}; $shv_tmp[$ARG[1]] = $ARG[2]; «\\@shv_tmp»; $ARG[2] }', lvalue_template => '(#ARG == 1) ? ($GET)->[ $ARG[1] ] : (($GET)->[ $ARG[1] ] = $ARG[2])', additional_validation => sub { my $self = CORE::shift; my ($sig_was_checked, $gen) = @_; my $ti = __PACKAGE__->_type_inspector($gen->isa); if ($ti and $ti->{trust_mutated} eq 'always') { return { code => '1;', env => {} }; } my ( $code, $env, $arg ); $env = {}; if ($ti and $ti->{trust_mutated} eq 'maybe') { $arg = sub { my $gen = CORE::shift; return '$shv_index' if $_[0]=='1'; return '$shv_value' if $_[0]=='2'; $gen->generate_arg( @_ ); }; if ( $sig_was_checked ) { $code = sprintf( 'my($shv_index,$shv_value)=%s; if (%s>1) { %s };', $gen->generate_args, $gen->generate_argc, $gen->generate_type_assertion( $env, $ti->{value_type}, '$shv_value' ), ); } else { $code = sprintf( 'my($shv_index,$shv_value)=%s; %s; if (%s>1) { %s };', $gen->generate_args, $gen->generate_type_assertion( $env, Int, '$shv_index' ), $gen->generate_argc, $gen->generate_type_assertion( $env, $ti->{value_type}, '$shv_value' ), ); } } return { code => $code, env => $env, arg => $arg, }; }, documentation => 'Acts like C if given just an index, or C if given an index and value.', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n", " \$object->$method( 1, 'quux' );\n", " say Dumper( \$object->$attr ); ## ==> [ 'foo', 'quux', 'baz' ]\n", " say \$object->$method( 2 ); ## ==> 'baz'\n", "\n"; }, } sub natatime { my $me = __PACKAGE__; handler name => 'Array:natatime', min_args => 1, max_args => 2, signature => [Int, Optional[CodeRef]], usage => '$n, $callback?', template => 'my @shv_remaining = @{$GET}; my $shv_n = $ARG[1]; my $shv_iterator = sub { CORE::splice @shv_remaining, 0, $shv_n }; if ($ARG[2]) { while (my @shv_values = $shv_iterator->()) { $ARG[2]->(@shv_values) } } else { $shv_iterator }', documentation => 'Given just a number, returns an iterator which reads that many elements from the array at a time. If also given a callback, calls the callback repeatedly with those values.', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n", " my \$iter = \$object->$method( 2 );\n", " say Dumper( [ \$iter->() ] ); ## ==> [ 'foo', 'bar' ]\n", " say Dumper( [ \$iter->() ] ); ## ==> [ 'baz' ]\n", "\n"; }, } sub shallow_clone { handler name => 'Array:shallow_clone', args => 0, template => '[@{$GET}]', documentation => 'Creates a new arrayref with the same elements as the original.', } sub map { handler name => 'Array:map', args => 1, signature => [CodeRef], usage => '$coderef', template => 'map($ARG->($_), @{$GET})', documentation => 'Like C from L.', } sub grep { handler name => 'Array:grep', args => 1, signature => [CodeRef], usage => '$coderef', template => 'grep($ARG->($_), @{$GET})', documentation => 'Like C from L.', } sub sort { handler name => 'Array:sort', min_args => 0, max_args => 1, signature => [Optional[CodeRef]], usage => '$coderef?', template => 'my @shv_return = $ARG ? (sort {$ARG->($a,$b)} @{$GET}) : (sort @{$GET})', documentation => 'Like C from L.', } sub reverse { handler name => 'Array:reverse', args => 0, template => 'reverse @{$GET}', documentation => 'Returns the reversed array in list context.', } sub sort_in_place { handler name => 'Array:sort_in_place', min_args => 0, max_args => 1, signature => [Optional[CodeRef]], usage => '$coderef?', template => 'my @shv_return = $ARG ? (sort {$ARG->($a,$b)} @{$GET}) : (sort @{$GET}); «\@shv_return»', additional_validation => 'no incoming values', documentation => 'Like C from L, but changes the attribute to point to the newly sorted array.', } sub shuffle { require List::Util; handler name => 'Array:shuffle', args => 0, template => 'my @shv_return = List::Util::shuffle(@{$GET}); wantarray ? @shv_return : \@shv_return', documentation => 'Returns the array in a random order; can be called in list context or scalar context and will return an arrayref in the latter case.', } sub shuffle_in_place { require List::Util; handler name => 'Array:shuffle_in_place', args => 0, template => 'my @shv_return = List::Util::shuffle(@{$GET}); «\@shv_return»', additional_validation => 'no incoming values', documentation => 'Rearranges the array in a random order, and changes the attribute to point to the new order.', } sub uniq { require List::Util; handler name => 'Array:uniq', args => 0, template => 'my @shv_return = List::Util::uniq(@{$GET}); wantarray ? @shv_return : \@shv_return', documentation => 'Returns the array filtered to remove duplicates; can be called in list context or scalar context and will return an arrayref in the latter case.', } sub uniq_in_place { require List::Util; handler name => 'Array:uniq_in_place', args => 0, template => 'my @shv_return = List::Util::uniq(@{$GET}); «\@shv_return»', additional_validation => 'no incoming values', documentation => 'Filters the array to remove duplicates, and changes the attribute to point to the filtered array.', } sub uniqnum { require List::Util; handler name => 'Array:uniqnum', args => 0, template => 'my @shv_return = List::Util::uniqnum(@{$GET}); wantarray ? @shv_return : \@shv_return', documentation => 'Returns the array filtered to remove duplicates numerically; can be called in list context or scalar context and will return an arrayref in the latter case.', } sub uniqnum_in_place { require List::Util; handler name => 'Array:uniqnum_in_place', args => 0, template => 'my @shv_return = List::Util::uniqnum(@{$GET}); «\@shv_return»', additional_validation => 'no incoming values', documentation => 'Filters the array to remove duplicates numerically, and changes the attribute to point to the filtered array.', } sub uniqstr { require List::Util; handler name => 'Array:uniqstr', args => 0, template => 'my @shv_return = List::Util::uniqstr(@{$GET}); wantarray ? @shv_return : \@shv_return', documentation => 'Returns the array filtered to remove duplicates stringwise; can be called in list context or scalar context and will return an arrayref in the latter case.', } sub uniqstr_in_place { require List::Util; handler name => 'Array:uniqstr_in_place', args => 0, template => 'my @shv_return = List::Util::uniqstr(@{$GET}); «\@shv_return»', additional_validation => 'no incoming values', documentation => 'Filters the array to remove duplicates stringwise, and changes the attribute to point to the filtered array.', } sub splice { handler name => 'Array:splice', min_args => 1, usage => '$index, $length, @values', template => 'my @shv_tmp = @{$GET}; my ($shv_index, $shv_length, @shv_values) = @ARG;defined($shv_index) or $shv_index=0; defined($shv_length) or $shv_length=0; my @shv_return = splice(@shv_tmp, $shv_index, $shv_length, @shv_values); «\\@shv_tmp»; wantarray ? @shv_return : $shv_return[-1]', lvalue_template => 'my ($shv_index, $shv_length, @shv_values) = @ARG;splice(@{$GET}, $shv_index, $shv_length, @shv_values)', additional_validation => sub { my $self = CORE::shift; my ($sig_was_checked, $gen) = @_; my $env = {}; my $code = sprintf 'if (%s >= 1) { %s }; if (%s >= 2) { %s };', $gen->generate_argc, $gen->generate_type_assertion( $env, Int, $gen->generate_arg( 1 ) ), $gen->generate_argc, $gen->generate_type_assertion( $env, Int, $gen->generate_arg( 2 ) ); my $ti = __PACKAGE__->_type_inspector($gen->isa); if ($ti and $ti->{trust_mutated} eq 'always') { return { code => $code, env => $env }; } if ($ti and $ti->{trust_mutated} eq 'maybe') { my $coercion = ( $gen->coerce and $ti->{value_type}->has_coercion ); if ( $coercion ) { $code .= sprintf( 'my @shv_unprocessed=%s;my @shv_processed=splice(@shv_unprocessed,0,2); push @shv_processed, map { my $shv_value = $_; %s } @shv_unprocessed;', $gen->generate_args, $gen->generate_type_assertion( $env, $ti->{value_type}, '$shv_value' ), ); } else { $code .= sprintf( 'my @shv_unprocessed=%s;my @shv_processed=splice(@shv_unprocessed,0,2);for my $shv_value (@shv_unprocessed) { %s };push @shv_processed, @shv_unprocessed;', $gen->generate_args, $gen->generate_type_assertion( $env, $ti->{value_type}, '$shv_value' ), ); } return { code => $code, env => $env, arg => sub { "\$shv_processed[($_[0])-1]" }, args => sub { '@shv_processed' }, argc => sub { 'scalar(@shv_processed)' }, }; } return { code => $code, env => $env, final_type_check_needed => !!1 }; }, documentation => 'Like C from L.', } sub delete { handler name => 'Array:delete', args => 1, signature => [Int], usage => '$index', template => 'my @shv_tmp = @{$GET}; my ($shv_return) = splice(@shv_tmp, $ARG, 1); «\\@shv_tmp»; $shv_return', lvalue_template => 'splice(@{$GET}, $ARG, 1)', additional_validation => 'no incoming values', documentation => 'Removes the indexed element from the array and returns it. Elements after it will be "moved up".', } sub insert { my $me = CORE::shift; handler name => 'Array:insert', args => 2, signature => [Int, Any], usage => '$index, $value', template => 'my @shv_tmp = @{$GET}; my ($shv_return) = splice(@shv_tmp, $ARG[1], 0, $ARG[2]); «\\@shv_tmp»;', lvalue_template => 'splice(@{$GET}, $ARG[1], 0, $ARG[2])', additional_validation => $additional_validation_for_set_and_insert, documentation => 'Inserts a value into the array with the given index. Elements after it will be "moved down".', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n", " \$object->$method( 1, 'quux' );\n", " say Dumper( \$object->$attr ); ## ==> [ 'foo', 'quux', 'bar', 'baz' ]\n", "\n"; }, } sub flatten_deep { my $me = __PACKAGE__; handler name => 'Array:flatten_deep', min_args => 0, max_args => 1, signature => [Optional[Int]], usage => '$depth?', template => 'my $shv_fd; $shv_fd = sub { my $d=pop; --$d if defined $d; map ref() eq "ARRAY" ? (defined $d && $d < 0) ? $_ : $shv_fd->(@$_, $d) : $_, @_ }; $shv_fd->(@{$GET}, $ARG)', documentation => 'Flattens the arrayref into a list, including any nested arrayrefs. (Has the potential to loop infinitely.)', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo', [ 'bar', [ 'baz' ] ] ] );\n", " say Dumper( [ \$object->$method ] ); ## ==> [ 'foo', 'bar', 'baz' ]\n", "\n", " my \$object2 = $class\->new( $attr => [ 'foo', [ 'bar', [ 'baz' ] ] ] );\n", " say Dumper( [ \$object->$method(1) ] ); ## ==> [ 'foo', 'bar', [ 'baz' ] ]\n", "\n"; }, } sub join { handler name => 'Array:join', min_args => 0, max_args => 1, signature => [Optional[Str]], usage => '$with?', template => 'my $shv_param_with = #ARG ? $ARG : q[,]; join($shv_param_with, @{$GET})', documentation => 'Returns a string joining all the elements in the array; if C<< $with >> is omitted, defaults to a comma.', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n", " say \$object->$method; ## ==> 'foo,bar,baz'\n", " say \$object->$method( '|' ); ## ==> 'foo|bar|baz'\n", "\n"; }, } sub print { handler name => 'Array:print', min_args => 0, max_args => 2, signature => [Optional[FileHandle], Optional[Str]], usage => '$fh?, $with?', template => 'my $shv_param_with = (#ARG>1) ? $ARG[2] : q[,]; print {$ARG[1]||*STDOUT} join($shv_param_with, @{$GET})', documentation => 'Prints a string joining all the elements in the array; if C<< $fh >> is omitted, defaults to STDOUT; if C<< $with >> is omitted, defaults to a comma.', } sub head { handler name => 'Array:head', args => 1, signature => [Int], usage => '$count', template => 'my $shv_count=$ARG; $shv_count=@{$GET} if $shv_count>@{$GET}; $shv_count=@{$GET}+$shv_count if $shv_count<0; (@{$GET})[0..($shv_count-1)]', documentation => 'Returns the first C<< $count >> elements of the array in list context.', } sub tail { handler name => 'Array:tail', args => 1, signature => [Int], usage => '$count', template => 'my $shv_count=$ARG; $shv_count=@{$GET} if $shv_count>@{$GET}; $shv_count=@{$GET}+$shv_count if $shv_count<0; my $shv_start = scalar(@{$GET})-$shv_count; my $shv_end = scalar(@{$GET})-1; (@{$GET})[$shv_start..$shv_end]', documentation => 'Returns the last C<< $count >> elements of the array in list context.', } sub apply { handler name => 'Array:apply', args => 1, signature => [CodeRef], usage => '$coderef', template => 'my @shv_tmp = @{$GET}; &{$ARG} foreach @shv_tmp; wantarray ? @shv_tmp : $shv_tmp[-1]', documentation => 'Executes the coderef (which should modify C<< $_ >>) against each element of the array; returns the resulting array in list context.', } sub pick_random { require List::Util; handler name => 'Array:pick_random', min_args => 0, max_args => 1, signature => [Optional[Int]], usage => '$count', template => 'my @shv_tmp = List::Util::shuffle(@{$GET}); my $shv_count = $ARG; $shv_count=@{$GET} if $shv_count > @{$GET}; $shv_count=@{$GET}+$shv_count if $shv_count<0; if (wantarray and #ARG) { @shv_tmp[0..$shv_count-1] } elsif (#ARG) { [@shv_tmp[0..$shv_count-1]] } else { $shv_tmp[0] }', documentation => 'If no C<< $count >> is given, returns one element of the array at random. If C<< $count >> is given, creates a new array with that many random elements from the original array (or fewer if the original array is not long enough) and returns that as an arrayref or list depending on context', } sub for_each { handler name => 'Array:for_each', args => 1, signature => [CodeRef], usage => '$coderef', template => 'foreach my $shv_index (0 .. $#{$GET}) { &{$ARG}(($GET)->[$shv_index], $shv_index) }; $SELF', documentation => 'Chainable method which executes the coderef on each element of the array. The coderef will be passed two values: the element and its index.', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n", " \$object->$method( sub { say \"Item \$_[1] is \$_[0].\" } );\n", "\n"; }, } sub for_each_pair { handler name => 'Array:for_each_pair', args => 1, signature => [CodeRef], usage => '$coderef', template => 'for (my $shv_index=0; $shv_index<@{$GET}; $shv_index+=2) { &{$ARG}(($GET)->[$shv_index], ($GET)->[$shv_index+1]) }; $SELF', documentation => 'Chainable method which executes the coderef on each pair of elements in the array. The coderef will be passed the two elements.', } sub all_true { require List::Util; handler name => 'Array:all_true', args => 1, signature => [CodeRef], usage => '$coderef', template => '&List::Util::all($ARG, @{$GET})', documentation => 'Like C<< List::Util::all() >>.', } sub not_all_true { require List::Util; handler name => 'Array:not_all_true', args => 1, signature => [CodeRef], usage => '$coderef', template => '&List::Util::notall($ARG, @{$GET})', documentation => 'Like C<< List::Util::notall() >>.', } sub min { require List::Util; handler name => 'Array:min', args => 0, template => '&List::Util::min(@{$GET})', documentation => 'Like C<< List::Util::min() >>.', } sub max { require List::Util; handler name => 'Array:max', args => 0, template => '&List::Util::max(@{$GET})', documentation => 'Like C<< List::Util::max() >>.', } sub minstr { require List::Util; handler name => 'Array:minstr', args => 0, template => '&List::Util::minstr(@{$GET})', documentation => 'Like C<< List::Util::minstr() >>.', } sub maxstr { require List::Util; handler name => 'Array:maxstr', args => 0, template => '&List::Util::maxstr(@{$GET})', documentation => 'Like C<< List::Util::maxstr() >>.', } sub sum { require List::Util; handler name => 'Array:sum', args => 0, template => '&List::Util::sum(0, @{$GET})', documentation => 'Like C<< List::Util::sum0() >>.', } sub product { require List::Util; handler name => 'Array:product', args => 0, template => '&List::Util::product(1, @{$GET})', documentation => 'Like C<< List::Util::product() >>.', } sub sample { require List::Util; handler name => 'Array:sample', args => 1, signature => [Int], usage => '$count', template => '&List::Util::sample($ARG, @{$GET})', documentation => 'Like C<< List::Util::sample() >>.', } sub reductions { require List::Util; handler name => 'Array:reductions', args => 1, signature => [CodeRef], usage => '$coderef', template => 'my $shv_callback = $ARG; List::Util::reductions { $shv_callback->($a,$b) } @{$GET}', documentation => 'Like C<< List::Util::reductions() >>.', } sub pairs { require List::Util; handler name => 'Array:pairs', args => 0, template => '&List::Util::pairs(@{$GET})', documentation => 'Like C<< List::Util::pairs() >>.', } sub pairkeys { require List::Util; handler name => 'Array:pairkeys', args => 0, template => '&List::Util::pairkeys(@{$GET})', documentation => 'Like C<< List::Util::pairkeys() >>.', } sub pairvalues { require List::Util; handler name => 'Array:pairvalues', args => 0, template => '&List::Util::pairvalues(@{$GET})', documentation => 'Like C<< List::Util::pairvalues() >>.', } sub pairgrep { require List::Util; handler name => 'Array:pairgrep', args => 1, signature => [CodeRef], usage => '$coderef', template => 'List::Util::pairgrep { $ARG->($_) } @{$GET}', documentation => 'Like C<< List::Util::pairgrep() >>.', } sub pairfirst { require List::Util; handler name => 'Array:pairfirst', args => 1, signature => [CodeRef], usage => '$coderef', template => 'List::Util::pairfirst { $ARG->($_) } @{$GET}', documentation => 'Like C<< List::Util::pairfirst() >>.', } sub pairmap { require List::Util; handler name => 'Array:pairmap', args => 1, signature => [CodeRef], usage => '$coderef', template => 'List::Util::pairmap { $ARG->($_) } @{$GET}', documentation => 'Like C<< List::Util::pairmap() >>.', } sub reset { handler name => 'Array:reset', args => 0, template => '« $DEFAULT »', default_for_reset => sub { '[]' }, documentation => 'Resets the attribute to its default value, or an empty arrayref if it has no default.', _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => [ 'foo', 'bar', 'baz' ] );\n", " \$object->$method;\n", " say Dumper( \$object->$attr ); ## ==> []\n", "\n"; }, } 1; Array.pod000664001750001750 4262214772476615 23356 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/HandlerLibrary=head1 NAME Sub::HandlesVia::HandlerLibrary::Array - library of array-related methods =head1 SYNOPSIS package My::Class { use Moo; use Sub::HandlesVia; use Types::Standard 'ArrayRef'; has attr => ( is => 'rwp', isa => ArrayRef, handles_via => 'Array', handles => { 'my_accessor' => 'accessor', 'my_all' => 'all', 'my_all_true' => 'all_true', 'my_any' => 'any', 'my_apply' => 'apply', 'my_clear' => 'clear', 'my_count' => 'count', 'my_delete' => 'delete', 'my_elements' => 'elements', 'my_first' => 'first', 'my_first_index' => 'first_index', 'my_flatten' => 'flatten', 'my_flatten_deep' => 'flatten_deep', 'my_for_each' => 'for_each', 'my_for_each_pair' => 'for_each_pair', 'my_get' => 'get', 'my_grep' => 'grep', 'my_head' => 'head', 'my_insert' => 'insert', 'my_is_empty' => 'is_empty', 'my_join' => 'join', 'my_map' => 'map', 'my_max' => 'max', 'my_maxstr' => 'maxstr', 'my_min' => 'min', 'my_minstr' => 'minstr', 'my_natatime' => 'natatime', 'my_not_all_true' => 'not_all_true', 'my_pairfirst' => 'pairfirst', 'my_pairgrep' => 'pairgrep', 'my_pairkeys' => 'pairkeys', 'my_pairmap' => 'pairmap', 'my_pairs' => 'pairs', 'my_pairvalues' => 'pairvalues', 'my_pick_random' => 'pick_random', 'my_pop' => 'pop', 'my_print' => 'print', 'my_product' => 'product', 'my_push' => 'push', 'my_reduce' => 'reduce', 'my_reductions' => 'reductions', 'my_reset' => 'reset', 'my_reverse' => 'reverse', 'my_sample' => 'sample', 'my_set' => 'set', 'my_shallow_clone' => 'shallow_clone', 'my_shift' => 'shift', 'my_shuffle' => 'shuffle', 'my_shuffle_in_place' => 'shuffle_in_place', 'my_sort' => 'sort', 'my_sort_in_place' => 'sort_in_place', 'my_splice' => 'splice', 'my_sum' => 'sum', 'my_tail' => 'tail', 'my_uniq' => 'uniq', 'my_uniq_in_place' => 'uniq_in_place', 'my_uniqnum' => 'uniqnum', 'my_uniqnum_in_place' => 'uniqnum_in_place', 'my_uniqstr' => 'uniqstr', 'my_uniqstr_in_place' => 'uniqstr_in_place', 'my_unshift' => 'unshift', }, ); } =head1 DESCRIPTION This is a library of methods for L. =head1 DELEGATABLE METHODS =head2 C<< accessor( $index, $value? ) >> Arguments: B<< Int >>, B<< Optional[Any] >>. Acts like C if given just an index, or C if given an index and value. my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); $object->my_accessor( 1, 'quux' ); say Dumper( $object->attr ); ## ==> [ 'foo', 'quux', 'baz' ] say $object->my_accessor( 2 ); ## ==> 'baz' =head2 C<< all() >> All elements in the array, in list context. my $object = My::Class->new( attr => [ 'foo', 'bar' ] ); my @list = $object->my_all; say Dumper( \@list ); ## ==> [ 'foo', 'bar' ] =head2 C<< all_true( $coderef ) >> Arguments: B<< CodeRef >>. Like C<< List::Util::all() >>. =head2 C<< any( $coderef ) >> Arguments: B<< CodeRef >>. Like C<< List::Util::any() >>. my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); my $truth = $object->my_any( sub { /a/ } ); say $truth; ## ==> true =head2 C<< apply( $coderef ) >> Arguments: B<< CodeRef >>. Executes the coderef (which should modify C<< $_ >>) against each element of the array; returns the resulting array in list context. =head2 C<< clear() >> Empties the array. my $object = My::Class->new( attr => [ 'foo' ] ); $object->my_clear; say Dumper( $object->attr ); ## ==> [] =head2 C<< count() >> The number of elements in the referenced array. my $object = My::Class->new( attr => [ 'foo', 'bar' ] ); say $object->my_count; ## ==> 2 =head2 C<< delete( $index ) >> Arguments: B<< Int >>. Removes the indexed element from the array and returns it. Elements after it will be "moved up". =head2 C<< elements() >> All elements in the array, in list context. (Essentially the same as C.) my $object = My::Class->new( attr => [ 'foo', 'bar' ] ); my @list = $object->my_elements; say Dumper( \@list ); ## ==> [ 'foo', 'bar' ] =head2 C<< first( $coderef ) >> Arguments: B<< CodeRef >>. Like C<< List::Util::first() >>. my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); my $found = $object->my_first( sub { /a/ } ); say $found; ## ==> 'bar' =head2 C<< first_index( $coderef ) >> Arguments: B<< CodeRef >>. Like C<< List::MoreUtils::first_index() >>. my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); my $found = $object->my_first_index( sub { /z$/ } ); say $found; ## ==> 2 =head2 C<< flatten() >> All elements in the array, in list context. (Essentially the same as C.) my $object = My::Class->new( attr => [ 'foo', 'bar' ] ); my @list = $object->my_flatten; say Dumper( \@list ); ## ==> [ 'foo', 'bar' ] =head2 C<< flatten_deep( $depth? ) >> Arguments: B<< Optional[Int] >>. Flattens the arrayref into a list, including any nested arrayrefs. (Has the potential to loop infinitely.) my $object = My::Class->new( attr => [ 'foo', [ 'bar', [ 'baz' ] ] ] ); say Dumper( [ $object->my_flatten_deep ] ); ## ==> [ 'foo', 'bar', 'baz' ] my $object2 = My::Class->new( attr => [ 'foo', [ 'bar', [ 'baz' ] ] ] ); say Dumper( [ $object->my_flatten_deep(1) ] ); ## ==> [ 'foo', 'bar', [ 'baz' ] ] =head2 C<< for_each( $coderef ) >> Arguments: B<< CodeRef >>. Chainable method which executes the coderef on each element of the array. The coderef will be passed two values: the element and its index. my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); $object->my_for_each( sub { say "Item $_[1] is $_[0]." } ); =head2 C<< for_each_pair( $coderef ) >> Arguments: B<< CodeRef >>. Chainable method which executes the coderef on each pair of elements in the array. The coderef will be passed the two elements. =head2 C<< get( $index ) >> Arguments: B<< Int >>. Returns a single element from the array by index. my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); say $object->my_get( 0 ); ## ==> 'foo' say $object->my_get( 1 ); ## ==> 'bar' say $object->my_get( -1 ); ## ==> 'baz' =head2 C<< grep( $coderef ) >> Arguments: B<< CodeRef >>. Like C from L. =head2 C<< head( $count ) >> Arguments: B<< Int >>. Returns the first C<< $count >> elements of the array in list context. =head2 C<< insert( $index, $value ) >> Arguments: B<< Int >>, B<< Any >>. Inserts a value into the array with the given index. Elements after it will be "moved down". my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); $object->my_insert( 1, 'quux' ); say Dumper( $object->attr ); ## ==> [ 'foo', 'quux', 'bar', 'baz' ] =head2 C<< is_empty() >> Boolean indicating if the referenced array is empty. my $object = My::Class->new( attr => [ 'foo', 'bar' ] ); say $object->my_is_empty; ## ==> false $object->_set_attr( [] ); say $object->my_is_empty; ## ==> true =head2 C<< join( $with? ) >> Arguments: B<< Optional[Str] >>. Returns a string joining all the elements in the array; if C<< $with >> is omitted, defaults to a comma. my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); say $object->my_join; ## ==> 'foo,bar,baz' say $object->my_join( '|' ); ## ==> 'foo|bar|baz' =head2 C<< map( $coderef ) >> Arguments: B<< CodeRef >>. Like C from L. =head2 C<< max() >> Like C<< List::Util::max() >>. =head2 C<< maxstr() >> Like C<< List::Util::maxstr() >>. =head2 C<< min() >> Like C<< List::Util::min() >>. =head2 C<< minstr() >> Like C<< List::Util::minstr() >>. =head2 C<< natatime( $n, $callback? ) >> Arguments: B<< Int >>, B<< Optional[CodeRef] >>. Given just a number, returns an iterator which reads that many elements from the array at a time. If also given a callback, calls the callback repeatedly with those values. my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); my $iter = $object->my_natatime( 2 ); say Dumper( [ $iter->() ] ); ## ==> [ 'foo', 'bar' ] say Dumper( [ $iter->() ] ); ## ==> [ 'baz' ] =head2 C<< not_all_true( $coderef ) >> Arguments: B<< CodeRef >>. Like C<< List::Util::notall() >>. =head2 C<< pairfirst( $coderef ) >> Arguments: B<< CodeRef >>. Like C<< List::Util::pairfirst() >>. =head2 C<< pairgrep( $coderef ) >> Arguments: B<< CodeRef >>. Like C<< List::Util::pairgrep() >>. =head2 C<< pairkeys() >> Like C<< List::Util::pairkeys() >>. =head2 C<< pairmap( $coderef ) >> Arguments: B<< CodeRef >>. Like C<< List::Util::pairmap() >>. =head2 C<< pairs() >> Like C<< List::Util::pairs() >>. =head2 C<< pairvalues() >> Like C<< List::Util::pairvalues() >>. =head2 C<< pick_random( $count ) >> Arguments: B<< Optional[Int] >>. If no C<< $count >> is given, returns one element of the array at random. If C<< $count >> is given, creates a new array with that many random elements from the original array (or fewer if the original array is not long enough) and returns that as an arrayref or list depending on context =head2 C<< pop() >> Removes the last element from the array and returns it. my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); say $object->my_pop; ## ==> 'baz' say $object->my_pop; ## ==> 'bar' say Dumper( $object->attr ); ## ==> [ 'foo' ] =head2 C<< print( $fh?, $with? ) >> Arguments: B<< Optional[FileHandle] >>, B<< Optional[Str] >>. Prints a string joining all the elements in the array; if C<< $fh >> is omitted, defaults to STDOUT; if C<< $with >> is omitted, defaults to a comma. =head2 C<< product() >> Like C<< List::Util::product() >>. =head2 C<< push( @values ) >> Adds elements to the end of the array. my $object = My::Class->new( attr => [ 'foo' ] ); $object->my_push( 'bar', 'baz' ); say Dumper( $object->attr ); ## ==> [ 'foo', 'bar', 'baz' ] =head2 C<< reduce( $coderef ) >> Arguments: B<< CodeRef >>. Like C<< List::Util::reduce() >>. =head2 C<< reductions( $coderef ) >> Arguments: B<< CodeRef >>. Like C<< List::Util::reductions() >>. =head2 C<< reset() >> Resets the attribute to its default value, or an empty arrayref if it has no default. my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); $object->my_reset; say Dumper( $object->attr ); ## ==> [] =head2 C<< reverse() >> Returns the reversed array in list context. =head2 C<< sample( $count ) >> Arguments: B<< Int >>. Like C<< List::Util::sample() >>. =head2 C<< set( $index, $value ) >> Arguments: B<< Int >>, B<< Any >>. Sets the element with the given index to the supplied value. my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); $object->my_set( 1, 'quux' ); say Dumper( $object->attr ); ## ==> [ 'foo', 'quux', 'baz' ] =head2 C<< shallow_clone() >> Creates a new arrayref with the same elements as the original. =head2 C<< shift() >> Removes an element from the start of the array and returns it. my $object = My::Class->new( attr => [ 'foo', 'bar', 'baz' ] ); say $object->my_shift; ## ==> 'foo' say $object->my_shift; ## ==> 'bar' say Dumper( $object->attr ); ## ==> [ 'baz' ] =head2 C<< shuffle() >> Returns the array in a random order; can be called in list context or scalar context and will return an arrayref in the latter case. =head2 C<< shuffle_in_place() >> Rearranges the array in a random order, and changes the attribute to point to the new order. =head2 C<< sort( $coderef? ) >> Arguments: B<< Optional[CodeRef] >>. Like C from L. =head2 C<< sort_in_place( $coderef? ) >> Arguments: B<< Optional[CodeRef] >>. Like C from L, but changes the attribute to point to the newly sorted array. =head2 C<< splice( $index, $length, @values ) >> Like C from L. =head2 C<< sum() >> Like C<< List::Util::sum0() >>. =head2 C<< tail( $count ) >> Arguments: B<< Int >>. Returns the last C<< $count >> elements of the array in list context. =head2 C<< uniq() >> Returns the array filtered to remove duplicates; can be called in list context or scalar context and will return an arrayref in the latter case. =head2 C<< uniq_in_place() >> Filters the array to remove duplicates, and changes the attribute to point to the filtered array. =head2 C<< uniqnum() >> Returns the array filtered to remove duplicates numerically; can be called in list context or scalar context and will return an arrayref in the latter case. =head2 C<< uniqnum_in_place() >> Filters the array to remove duplicates numerically, and changes the attribute to point to the filtered array. =head2 C<< uniqstr() >> Returns the array filtered to remove duplicates stringwise; can be called in list context or scalar context and will return an arrayref in the latter case. =head2 C<< uniqstr_in_place() >> Filters the array to remove duplicates stringwise, and changes the attribute to point to the filtered array. =head2 C<< unshift( @values ) >> Adds an element to the start of the array. my $object = My::Class->new( attr => [ 'foo' ] ); $object->my_unshift( 'bar', 'baz' ); say Dumper( $object->attr ); ## ==> [ 'bar', 'baz', 'foo' ] =head1 SHORTCUT CONSTANTS This module provides some shortcut constants for indicating a list of delegations. package My::Class { use Moo; use Sub::HandlesVia; use Sub::HandlesVia::HandlerLibrary::Array qw( HandleQueue ); has things => ( is => 'ro', handles_via => 'Array', handles => HandleQueue, default => sub { [] }, ); } These shortcuts can be combined using the C< | > operator. has things => ( is => 'ro', handles_via => 'Array', handles => HandleQueue | HandleStack, default => sub { [] }, ); =head2 C<< HandleQueue >> Creates delegations named like C<< things_is_empty >>, C<< things_size >>, C<< things_enqueue >>, C<< things_dequeue >>, and C<< things_peek >>. =head2 C<< HandleStack >> Creates delegations named like C<< things_is_empty >>, C<< things_size >>, C<< things_push >>, C<< things_pop >>, and C<< things_peek >>. =head1 EXTENDED EXAMPLES =head2 Using for_each use strict; use warnings; package My::Plugin { use Moo::Role; sub initialize {} sub finalize {} } package My::Processor { use Moo; use Sub::HandlesVia; use Types::Standard qw( ArrayRef ConsumerOf ); has plugins => ( is => 'ro', isa => ArrayRef[ ConsumerOf['My::Plugin'] ], handles_via => 'Array', handles => { add_plugin => 'push', plugin_do => 'for_each', }, default => sub { [] }, ); sub _do_stuff { return; } sub run_process { my ( $self, @args ) = @_; $self->plugin_do( sub { my $plugin = shift; $plugin->initialize( $self, @args ); } ); $self->_do_stuff( @args ); $self->plugin_do( sub { my $plugin = shift; $plugin->finalize( $self, @args ); } ); } } my $p = My::Processor->new(); package My::Plugin::Noisy { use Moo; with 'My::Plugin'; sub initialize { my ( $self, $processor, @args ) = @_; say "initialize @args"; ## ==> 'initialize 1 2 3' } sub finalize { my ( $self, $processor, @args ) = @_; say "finalize @args"; ## ==> 'finalize 1 2 3' } } $p->add_plugin( My::Plugin::Noisy->new ); $p->run_process( 1, 2, 3 ); =head2 Job queue using push and shift use strict; use warnings; use Try::Tiny; package My::JobQueue { use Moo; use Sub::HandlesVia; use Types::Standard qw( Bool ArrayRef CodeRef HasMethods is_Object ); use Try::Tiny; has auto_requeue => ( is => 'ro', isa => Bool, default => 0, ); has jobs => ( is => 'ro', isa => ArrayRef[ CodeRef | HasMethods['run'] ], handles_via => 'Array', handles => { add_job => 'push', _get_job => 'shift', is_empty => 'is_empty', }, default => sub { [] }, ); sub _handle_failed_job { my ( $self, $job ) = @_; $self->add_job( $job ) if $self->auto_requeue; } sub run_jobs { my $self = shift; while ( not $self->is_empty ) { my $job = $self->_get_job; try { is_Object($job) ? $job->run() : $job->(); } catch { $self->_handle_failed_job( $job ); }; } } } my $q = My::JobQueue->new(); my $str = ''; $q->add_job( sub { $str .= 'A' } ); $q->add_job( sub { $str .= 'B' } ); $q->add_job( sub { $str .= 'C' } ); $q->run_jobs; say $str; ## ==> 'ABC' # Attempt to push invalid value on the queue # try { $q->add_job( "jobs cannot be strings" ); } catch { say $q->is_empty; ## ==> true }; =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2020, 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. Blessed.pm000664001750001750 544714772476615 23477 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/HandlerLibraryuse 5.008; use strict; use warnings; package Sub::HandlesVia::HandlerLibrary::Blessed; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Sub::HandlesVia::HandlerLibrary; our @ISA = 'Sub::HandlesVia::HandlerLibrary'; use Sub::HandlesVia::Handler qw( handler ); use Types::Standard qw( is_Str ); # Non-exhaustive list! sub handler_names { return; } sub has_handler { my ($me, $handler_name) = @_; is_Str $handler_name; } my $simple_method_name = qr/\A[^\W0-9]\w*\z/; sub get_handler { my ($me, $handler_name) = @_; if ( $handler_name =~ $simple_method_name ) { return handler( name => 'Blessed:' . $handler_name, template => sprintf( 'use Scalar::Util (); ⸨q{$ATTRNAME is not a blessed object}⸩ unless Scalar::Util::blessed( $GET ); $GET->%s(@ARG)', $handler_name, ), is_mutator => 0, ); } else { return handler( name => 'Blessed:' . $handler_name, template => sprintf( 'use Scalar::Util (); ⸨q{$ATTRNAME is not a blessed object}⸩ unless Scalar::Util::blessed( $GET ); $GET->${\ %s }(@ARG)', B::perlstring($handler_name), ), is_mutator => 0, ); } } 1; __END__ =head1 NAME Sub::HandlesVia::HandlerLibrary::Blessed - library of object-related methods =head1 SYNOPSIS package My::Class { use Moo; use Sub::HandlesVia; use Types::Standard 'Object'; use HTTP::Tiny; has http_ua => ( is => 'rwp', isa => Object, handles_via => 'Blessed', handles => { 'http_get' => 'get', 'http_post' => 'post', }, default => sub { HTTP::Tiny->new }, ); } =head1 DESCRIPTION This is a library of methods for L. =head1 DELEGATABLE METHODS Unlike the other libraries supplied by Sub::HandlesVia, this library allows you to delegate to I method name. It assumes that the attribute value is a blessed object, and calls the correspondingly named method on it. L, L, L, and L all have this kind of delegation built-in anyway, but this module allows you to perform the delegation using Sub::HandlesVia. This may be useful for L and L, which don't have a built-in delegation feature. =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. Bool.pm000664001750001750 407614772476615 23006 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/HandlerLibraryuse 5.008; use strict; use warnings; package Sub::HandlesVia::HandlerLibrary::Bool; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Sub::HandlesVia::HandlerLibrary; our @ISA = 'Sub::HandlesVia::HandlerLibrary'; use Sub::HandlesVia::Handler qw( handler ); our @METHODS = qw( set unset toggle not reset ); sub set { handler name => 'Bool:set', args => 0, template => '« !!1 »', documentation => 'Sets the value of the boolean to true.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new();\n", " \$object->$method\();\n", " say \$object->$attr; ## ==> true\n", "\n"; }, } sub unset { handler name => 'Bool:unset', args => 0, template => '« !!0 »', documentation => 'Sets the value of the boolean to false.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new();\n", " \$object->$method\();\n", " say \$object->$attr; ## ==> false\n", "\n"; }, } sub toggle { handler name => 'Bool:toggle', args => 0, template => '« !$GET »', documentation => 'Toggles the truth value of the boolean.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new();\n", " \$object->$method\();\n", " say \$object->$attr; ## ==> true\n", " \$object->$method\();\n", " say \$object->$attr; ## ==> false\n", "\n"; }, } sub not { handler name => 'Bool:not', args => 0, template => '!$GET', documentation => 'Returns the opposite value of the boolean.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 1 );\n", " say \$object->$method\(); ## ==> false\n", "\n"; }, } sub reset { handler name => 'Bool:reset', args => 0, template => '« $DEFAULT »', default_for_reset => sub { 0 }, documentation => 'Sets the boolean to its default value, or false if it has no default.', } 1; Bool.pod000664001750001750 366514772476615 23157 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/HandlerLibrary=head1 NAME Sub::HandlesVia::HandlerLibrary::Bool - library of bool-related methods =head1 SYNOPSIS package My::Class { use Moo; use Sub::HandlesVia; use Types::Standard 'Bool'; has attr => ( is => 'rwp', isa => Bool, handles_via => 'Bool', handles => { 'my_not' => 'not', 'my_reset' => 'reset', 'my_set' => 'set', 'my_toggle' => 'toggle', 'my_unset' => 'unset', }, ); } =head1 DESCRIPTION This is a library of methods for L. =head1 DELEGATABLE METHODS =head2 C<< not() >> Returns the opposite value of the boolean. my $object = My::Class->new( attr => 1 ); say $object->my_not(); ## ==> false =head2 C<< reset() >> Sets the boolean to its default value, or false if it has no default. =head2 C<< set() >> Sets the value of the boolean to true. my $object = My::Class->new(); $object->my_set(); say $object->attr; ## ==> true =head2 C<< toggle() >> Toggles the truth value of the boolean. my $object = My::Class->new(); $object->my_toggle(); say $object->attr; ## ==> true $object->my_toggle(); say $object->attr; ## ==> false =head2 C<< unset() >> Sets the value of the boolean to false. my $object = My::Class->new(); $object->my_unset(); say $object->attr; ## ==> false =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2020, 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. Code.pm000664001750001750 1375014772476615 23004 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/HandlerLibraryuse 5.008; use strict; use warnings; package Sub::HandlesVia::HandlerLibrary::Code; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Sub::HandlesVia::HandlerLibrary; our @ISA = 'Sub::HandlesVia::HandlerLibrary'; use Sub::HandlesVia::Handler qw( handler ); our @METHODS = qw( execute execute_method execute_list execute_method_list execute_scalar execute_method_scalar execute_void execute_method_void ); sub execute { handler name => 'Code:execute', template => '$GET->(@ARG)', usage => '@args', prefer_shift_self => 1, documentation => 'Calls the coderef, passing it any arguments.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$coderef = sub { 'code' };\n", " my \$object = $class\->new( $attr => \$coderef );\n", " \n", " # Calls: \$coderef->( 1, 2, 3 )\n", " \$object->$method\( 1, 2, 3 );\n", "\n"; }, } sub execute_method { handler name => 'Code:execute_method', template => '$GET->($SELF, @ARG)', prefer_shift_self => 1, usage => '@args', documentation => 'Calls the coderef as if it were a method, passing any arguments.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$coderef = sub { 'code' };\n", " my \$object = $class\->new( $attr => \$coderef );\n", " \n", " # Calls: \$coderef->( \$object, 1, 2, 3 )\n", " \$object->$method\( 1, 2, 3 );\n", "\n"; }, } sub execute_list { handler name => 'Code:execute_list', template => 'my @shv_list = $GET->(@ARG); wantarray ? @shv_list : \@shv_list', usage => '@args', prefer_shift_self => 1, documentation => 'Calls the coderef, passing it any arguments, and forcing list context. If called in scalar context, returns an arrayref.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$context;\n", " my \$coderef = sub { \$context = wantarray(); 'code' };\n", " my \$object = $class\->new( $attr => \$coderef );\n", " \n", " # Calls: \$coderef->( 1, 2, 3 )\n", " my \$result = \$object->$method\( 1, 2, 3 );\n", " \n", " say Dumper( \$result ); ## ==> [ 'code' ]\n", " say \$context; ## ==> true\n", "\n"; }, } sub execute_method_list { handler name => 'Code:execute_method_list', template => 'my @shv_list = $GET->($SELF, @ARG); wantarray ? @shv_list : \@shv_list', prefer_shift_self => 1, usage => '@args', documentation => 'Calls the coderef as if it were a method, passing any arguments, and forcing list context. If called in scalar context, returns an arrayref.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$context;\n", " my \$coderef = sub { \$context = wantarray(); 'code' };\n", " my \$object = $class\->new( $attr => \$coderef );\n", " \n", " # Calls: \$coderef->( \$object, 1, 2, 3 )\n", " my \$result = \$object->$method\( 1, 2, 3 );\n", " \n", " say Dumper( \$result ); ## ==> [ 'code' ]\n", " say \$context; ## ==> true\n", "\n"; }, } sub execute_scalar { handler name => 'Code:execute_scalar', template => 'scalar( $GET->(@ARG) )', usage => '@args', prefer_shift_self => 1, documentation => 'Calls the coderef, passing it any arguments, and forcing scalar context.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$context;\n", " my \$coderef = sub { \$context = wantarray(); 'code' };\n", " my \$object = $class\->new( $attr => \$coderef );\n", " \n", " # Calls: \$coderef->( 1, 2, 3 )\n", " my \$result = \$object->$method\( 1, 2, 3 );\n", " \n", " say \$result; ## ==> 'code'\n", " say \$context; ## ==> false\n", "\n"; }, } sub execute_method_scalar { handler name => 'Code:execute_method_scalar', template => 'scalar( $GET->($SELF, @ARG) )', prefer_shift_self => 1, usage => '@args', documentation => 'Calls the coderef as if it were a method, passing any arguments, and forcing scalar context.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$context;\n", " my \$coderef = sub { \$context = wantarray(); 'code' };\n", " my \$object = $class\->new( $attr => \$coderef );\n", " \n", " # Calls: \$coderef->( \$object, 1, 2, 3 )\n", " my \$result = \$object->$method\( 1, 2, 3 );\n", " \n", " say \$result; ## ==> 'code'\n", " say \$context; ## ==> false\n", "\n"; }, } sub execute_void { handler name => 'Code:execute_void', template => '$GET->(@ARG); undef', usage => '@args', prefer_shift_self => 1, documentation => 'Calls the coderef, passing it any arguments, and forcing void context. Returns undef.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$context;\n", " my \$coderef = sub { \$context = wantarray(); 'code' };\n", " my \$object = $class\->new( $attr => \$coderef );\n", " \n", " # Calls: \$coderef->( 1, 2, 3 )\n", " my \$result = \$object->$method\( 1, 2, 3 );\n", " \n", " say \$result; ## ==> undef\n", " say \$context; ## ==> undef\n", "\n"; }, } sub execute_method_void { handler name => 'Code:execute_method_void', template => '$GET->($SELF, @ARG); undef', prefer_shift_self => 1, usage => '@args', documentation => 'Calls the coderef as if it were a method, passing any arguments, and forcing void context. Returns undef.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$context;\n", " my \$coderef = sub { \$context = wantarray(); 'code' };\n", " my \$object = $class\->new( $attr => \$coderef );\n", " \n", " # Calls: \$coderef->( \$object, 1, 2, 3 )\n", " my \$result = \$object->$method\( 1, 2, 3 );\n", " \n", " say \$result; ## ==> undef\n", " say \$context; ## ==> undef\n", "\n"; }, } 1; Code.pod000664001750001750 1374014772476615 23151 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/HandlerLibrary=head1 NAME Sub::HandlesVia::HandlerLibrary::Code - library of code-related methods =head1 SYNOPSIS package My::Class { use Moo; use Sub::HandlesVia; use Types::Standard 'CodeRef'; has attr => ( is => 'rwp', isa => CodeRef, handles_via => 'Code', handles => { 'my_execute' => 'execute', 'my_execute_list' => 'execute_list', 'my_execute_method' => 'execute_method', 'my_execute_method_list' => 'execute_method_list', 'my_execute_method_scalar' => 'execute_method_scalar', 'my_execute_method_void' => 'execute_method_void', 'my_execute_scalar' => 'execute_scalar', 'my_execute_void' => 'execute_void', }, ); } =head1 DESCRIPTION This is a library of methods for L. =head1 DELEGATABLE METHODS =head2 C<< execute( @args ) >> Calls the coderef, passing it any arguments. my $coderef = sub { 'code' }; my $object = My::Class->new( attr => $coderef ); # Calls: $coderef->( 1, 2, 3 ) $object->my_execute( 1, 2, 3 ); =head2 C<< execute_list( @args ) >> Calls the coderef, passing it any arguments, and forcing list context. If called in scalar context, returns an arrayref. my $context; my $coderef = sub { $context = wantarray(); 'code' }; my $object = My::Class->new( attr => $coderef ); # Calls: $coderef->( 1, 2, 3 ) my $result = $object->my_execute_list( 1, 2, 3 ); say Dumper( $result ); ## ==> [ 'code' ] say $context; ## ==> true =head2 C<< execute_method( @args ) >> Calls the coderef as if it were a method, passing any arguments. my $coderef = sub { 'code' }; my $object = My::Class->new( attr => $coderef ); # Calls: $coderef->( $object, 1, 2, 3 ) $object->my_execute_method( 1, 2, 3 ); =head2 C<< execute_method_list( @args ) >> Calls the coderef as if it were a method, passing any arguments, and forcing list context. If called in scalar context, returns an arrayref. my $context; my $coderef = sub { $context = wantarray(); 'code' }; my $object = My::Class->new( attr => $coderef ); # Calls: $coderef->( $object, 1, 2, 3 ) my $result = $object->my_execute_method_list( 1, 2, 3 ); say Dumper( $result ); ## ==> [ 'code' ] say $context; ## ==> true =head2 C<< execute_method_scalar( @args ) >> Calls the coderef as if it were a method, passing any arguments, and forcing scalar context. my $context; my $coderef = sub { $context = wantarray(); 'code' }; my $object = My::Class->new( attr => $coderef ); # Calls: $coderef->( $object, 1, 2, 3 ) my $result = $object->my_execute_method_scalar( 1, 2, 3 ); say $result; ## ==> 'code' say $context; ## ==> false =head2 C<< execute_method_void( @args ) >> Calls the coderef as if it were a method, passing any arguments, and forcing void context. Returns undef. my $context; my $coderef = sub { $context = wantarray(); 'code' }; my $object = My::Class->new( attr => $coderef ); # Calls: $coderef->( $object, 1, 2, 3 ) my $result = $object->my_execute_method_void( 1, 2, 3 ); say $result; ## ==> undef say $context; ## ==> undef =head2 C<< execute_scalar( @args ) >> Calls the coderef, passing it any arguments, and forcing scalar context. my $context; my $coderef = sub { $context = wantarray(); 'code' }; my $object = My::Class->new( attr => $coderef ); # Calls: $coderef->( 1, 2, 3 ) my $result = $object->my_execute_scalar( 1, 2, 3 ); say $result; ## ==> 'code' say $context; ## ==> false =head2 C<< execute_void( @args ) >> Calls the coderef, passing it any arguments, and forcing void context. Returns undef. my $context; my $coderef = sub { $context = wantarray(); 'code' }; my $object = My::Class->new( attr => $coderef ); # Calls: $coderef->( 1, 2, 3 ) my $result = $object->my_execute_void( 1, 2, 3 ); say $result; ## ==> undef say $context; ## ==> undef =head1 EXTENDED EXAMPLES =head2 Using execute_method The execute_method handler allows a class to effectively provide certain methods which can be overridden by parameters in the constructor. use strict; use warnings; use Data::Dumper; package My::Processor { use Moo; use Sub::HandlesVia; use Types::Standard qw( Str CodeRef ); has name => ( is => 'ro', isa => Str, default => 'Main Process', ); my $NULL_CODEREF = sub {}; has _debug => ( is => 'ro', isa => CodeRef, handles_via => 'Code', handles => { debug => 'execute_method' }, default => sub { $NULL_CODEREF }, init_arg => 'debug', ); sub _do_stuff { my $self = shift; $self->debug( 'continuing process' ); return; } sub run_process { my $self = shift; $self->debug( 'starting process' ); $self->_do_stuff; $self->debug( 'ending process' ); } } my $p1 = My::Processor->new( name => 'First Process' ); $p1->run_process; # no output my @got; my $p2 = My::Processor->new( name => 'Second Process', debug => sub { my ( $processor, $message ) = @_; push @got, sprintf( '%s: %s', $processor->name, $message ); }, ); $p2->run_process; # logged output my @expected = ( 'Second Process: starting process', 'Second Process: continuing process', 'Second Process: ending process', ); say Dumper( \@got ); ## ==> \@expected =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2020, 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. Counter.pm000664001750001750 546114772476615 23531 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/HandlerLibraryuse 5.008; use strict; use warnings; package Sub::HandlesVia::HandlerLibrary::Counter; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Sub::HandlesVia::HandlerLibrary; our @ISA = 'Sub::HandlesVia::HandlerLibrary'; use Sub::HandlesVia::Handler qw( handler ); use Types::Standard qw( Optional Int Any Item Defined Num ); our @METHODS = qw( set inc dec reset ); sub _type_inspector { my ($me, $type) = @_; if ($type == Defined) { return { trust_mutated => 'always', }; } if ($type==Num or $type==Int) { return { trust_mutated => 'maybe', value_type => $type, }; } return $me->SUPER::_type_inspector($type); } sub set { handler name => 'Counter:set', args => 1, signature => [Int], template => '« $ARG »', usage => '$value', documentation => 'Sets the counter to the given value.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 0 );\n", " \$object->$method\( 5 );\n", " say \$object->$attr; ## ==> 5\n", "\n"; }, } sub inc { handler name => 'Counter:inc', min_args => 0, max_args => 1, signature => [Optional[Int]], template => '« $GET + (#ARG ? $ARG : 1) »', lvalue_template => '$GET += (#ARG ? $ARG : 1)', usage => '$amount?', documentation => 'Increments the counter by C<< $amount >>, or by 1 if no value is given.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 0 );\n", " \$object->$method;\n", " \$object->$method;\n", " say \$object->$attr; ## ==> 2\n", " \$object->$method( 3 );\n", " say \$object->$attr; ## ==> 5\n", "\n"; }, } sub dec { handler name => 'Counter:dec', min_args => 0, max_args => 1, signature => [Optional[Int]], template => '« $GET - (#ARG ? $ARG : 1) »', lvalue_template => '$GET -= (#ARG ? $ARG : 1)', usage => '$amount?', documentation => 'Decrements the counter by C<< $amount >>, or by 1 if no value is given.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 10 );\n", " \$object->$method;\n", " \$object->$method;\n", " say \$object->$attr; ## ==> 8\n", " \$object->$method( 5 );\n", " say \$object->$attr; ## ==> 3\n", "\n"; }, } sub reset { handler name => 'Counter:reset', args => 0, template => '« $DEFAULT »', default_for_reset => sub { 0 }, documentation => 'Sets the counter to its default value, or 0 if it has no default.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 10 );\n", " \$object->$method;\n", " say \$object->$attr; ## ==> 0\n", "\n"; }, } 1;Counter.pod000664001750001750 417314772476615 23676 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/HandlerLibrary=head1 NAME Sub::HandlesVia::HandlerLibrary::Counter - library of counter-related methods =head1 SYNOPSIS package My::Class { use Moo; use Sub::HandlesVia; use Types::Standard 'Int'; has attr => ( is => 'rwp', isa => Int, handles_via => 'Counter', handles => { 'my_dec' => 'dec', 'my_inc' => 'inc', 'my_reset' => 'reset', 'my_set' => 'set', }, ); } =head1 DESCRIPTION This is a library of methods for L. =head1 DELEGATABLE METHODS =head2 C<< dec( $amount? ) >> Arguments: B<< Optional[Int] >>. Decrements the counter by C<< $amount >>, or by 1 if no value is given. my $object = My::Class->new( attr => 10 ); $object->my_dec; $object->my_dec; say $object->attr; ## ==> 8 $object->my_dec( 5 ); say $object->attr; ## ==> 3 =head2 C<< inc( $amount? ) >> Arguments: B<< Optional[Int] >>. Increments the counter by C<< $amount >>, or by 1 if no value is given. my $object = My::Class->new( attr => 0 ); $object->my_inc; $object->my_inc; say $object->attr; ## ==> 2 $object->my_inc( 3 ); say $object->attr; ## ==> 5 =head2 C<< reset() >> Sets the counter to its default value, or 0 if it has no default. my $object = My::Class->new( attr => 10 ); $object->my_reset; say $object->attr; ## ==> 0 =head2 C<< set( $value ) >> Arguments: B<< Int >>. Sets the counter to the given value. my $object = My::Class->new( attr => 0 ); $object->my_set( 5 ); say $object->attr; ## ==> 5 =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2020, 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. Enum.pm000664001750001750 1544714772476615 23043 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/HandlerLibraryuse 5.008; use strict; use warnings; package Sub::HandlesVia::HandlerLibrary::Enum; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Exporter::Tiny; use Sub::HandlesVia::HandlerLibrary; our @ISA = qw( Exporter::Tiny Sub::HandlesVia::HandlerLibrary ); use Sub::HandlesVia::Handler qw( handler ); use Types::Standard qw( is_Str Any ); sub HandleIs () { 1 } sub HandleNamedIs () { 2 } sub HandleSet () { 4 } sub HandleNamedSet () { 8 } our @EXPORT = qw( HandleIs HandleNamedIs HandleSet HandleNamedSet ); sub preprocess_spec { my ( $class, $target, $attrname, $spec ) = @_; if ( my $values = delete $spec->{enum} ) { require Type::Tiny::Enum; $spec->{isa} ||= 'Type::Tiny::Enum'->new( values => $values ); } } sub expand_shortcut { require Carp; my ( $class, $target, $attrname, $spec, $shortcut ) = @_; my %handlers; my $type = $spec->{isa} or Carp::croak( "No type constraint!" ); $type->can( 'values' ) or Carp::croak( "Type constraint does not have a `values` method!" ); my @values = @{ $type->values }; if ( HandleIs & $shortcut ) { $handlers{"is_$_"} = [ is => $_ ] for @values; } if ( HandleNamedIs & $shortcut ) { $handlers{"$attrname\_is_$_"} = [ is => $_ ] for @values; } if ( HandleSet & $shortcut ) { $handlers{"set_$_"} = [ set => $_ ] for @values; } if ( HandleNamedSet & $shortcut ) { $handlers{"$attrname\_set_$_"} = [ set => $_ ] for @values; } return \%handlers; } # Non-exhaustive list! sub handler_names { qw( is assign set ); } sub has_handler { my ($me, $handler_name) = @_; return 1 if $handler_name =~ /^(is|assign|set)$/; return 1 if is_Str $handler_name and $handler_name =~ /^(is|assign|set)_(.+)$/; return 0; } sub get_handler { my ($me, $handler_name) = @_; $handler_name =~ /^(is|assign|set)_(.+)$/ or return $me->SUPER::get_handler( $handler_name ); my $handler_type = $1; my $param = $2; return $me->get_handler( $handler_type )->curry( $param ); } sub assign { handler name => 'Enum:assign', args => 1, signature => [Any], template => '« $ARG »', lvalue_template => '$GET = $ARG', usage => '$value', documentation => "Sets the enum to a new value.", } sub set { handler name => 'Enum:set', args => 1, signature => [Any], template => '« $ARG »', lvalue_template => '$GET = $ARG', usage => '$value', documentation => "Sets the enum to a new value.", } sub is { handler name => "Enum:is", args => 1, signature => [Any], template => "\$GET eq \$ARG", documentation => "Returns C<< \$object->attr eq \$str >>.", }; 1; __END__ =head1 NAME Sub::HandlesVia::HandlerLibrary::Enum - library of enum-related methods =head1 SYNOPSIS package My::Class { use Moo; use Sub::HandlesVia; use Types::Standard 'Enum'; has status => ( is => 'ro', isa => Enum[ 'pass', 'fail' ], handles_via => 'Enum', handles => { 'is_pass' => [ is => 'pass' ], 'is_fail' => [ is => 'fail' ], 'assign_pass' => [ assign => 'pass' ], 'assign_fail' => [ assign => 'fail' ], }, default => sub { 'fail' }, ); } Or, using a shortcut: package My::Class { use Moo; use Sub::HandlesVia; use Types::Standard 'Enum'; has status => ( is => 'ro', isa => Enum[ 'pass', 'fail' ], handles_via => 'Enum', handles => { 'is_pass' => 'is_pass', 'is_fail' => 'is_fail', 'assign_pass' => 'assign_pass', 'assign_fail' => 'assign_fail', }, default => sub { 'fail' }, ); } (Sub::HandlesVia::HandlerLibrary::Enum will split on "_".) =head1 DESCRIPTION This is a library of methods for L. =head1 DELEGATABLE METHODS This allows for delegation roughly compatible with L and L, even though that's basically a renamed subset of L anyway. =head2 C<< is( $value ) >> Returns a boolean indicating whether the enum is that value. my $object = My::Class->new( status => 'pass' ); say $object->is_pass(); ## ==> true say $object->is_fail(); ## ==> false =head2 C<< assign( $value ) >> Sets the enum to the value. my $object = My::Class->new( status => 'pass' ); say $object->is_pass(); ## ==> true say $object->is_fail(); ## ==> false $object->assign_fail(); say $object->is_pass(); ## ==> false say $object->is_fail(); ## ==> true =head2 C<< set( $value ) >> An alias for C. =head1 TYPE CONSTRAINT SHORTCUT The Enum handler library also allows an C shortcut in the attribute spec. package My::Class { use Moo; use Sub::HandlesVia; has status => ( is => 'ro', enum => [ 'pass', 'fail' ], handles_via => 'Enum', handles => { 'is_pass' => [ is => 'pass' ], 'is_fail' => [ is => 'fail' ], 'assign_pass' => [ assign => 'pass' ], 'assign_fail' => [ assign => 'fail' ], }, default => sub { 'fail' }, ); } =head1 SHORTCUT CONSTANTS This module provides some shortcut constants for indicating a list of delegations. package My::Class { use Moo; use Types::Standard qw( Enum ); use Sub::HandlesVia; use Sub::HandlesVia::HandlerLibrary::Enum qw( HandleIs ); has status => ( is => 'ro', isa => Enum[ 'pass', 'fail' ], handles_via => 'Enum', handles => HandleIs, default => sub { 'fail' }, ); } Any of these shortcuts can be combined using the C< | > operator. has status => ( is => 'ro', isa => Enum[ 'pass', 'fail' ], handles_via => 'Enum', handles => HandleIs | HandleSet, default => sub { 'fail' }, ); =head2 C<< HandleIs >> Creates delegations named like C<< is_pass >> and C<< is_fail >>. =head2 C<< HandleNamedIs >> Creates delegations named like C<< status_is_pass >> and C<< status_is_fail >>. =head2 C<< HandleSet >> Creates delegations named like C<< set_pass >> and C<< set_fail >>. =head2 C<< HandleNamedSet >> Creates delegations named like C<< status_set_pass >> and C<< status_set_fail >>. =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. Hash.pm000664001750001750 3314014772476615 23010 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/HandlerLibraryuse 5.008; use strict; use warnings; package Sub::HandlesVia::HandlerLibrary::Hash; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Sub::HandlesVia::HandlerLibrary; our @ISA = 'Sub::HandlesVia::HandlerLibrary'; use Sub::HandlesVia::Handler qw( handler ); use Types::Standard qw( HashRef ArrayRef Optional Str CodeRef Item Any Ref Defined RegexpRef ); our @METHODS = qw( all accessor clear count defined delete elements exists get is_empty keys kv set shallow_clone values sorted_keys reset delete_where for_each_key for_each_value for_each_pair ); sub _type_inspector { my ($me, $type) = @_; if ($type == HashRef or $type == Ref or $type == Ref['HASH']) { return { trust_mutated => 'always', }; } if ($type->is_parameterized and $type->parent->name eq 'HashRef' and $type->parent->library eq 'Types::Standard') { return { trust_mutated => 'maybe', value_type => $type->type_parameter, key_type => Str, }; } if ($type->is_parameterized and $type->parent->name eq 'Map' and $type->parent->library eq 'Types::Standard') { return { trust_mutated => 'maybe', value_type => $type->parameters->[1], key_type => $type->parameters->[0], }; } return $me->SUPER::_type_inspector($type); } my $additional_validation_for_set_and_insert = sub { my $self = CORE::shift; my ($sig_was_checked, $gen) = @_; my $ti = __PACKAGE__->_type_inspector($gen->isa); if ($ti and $ti->{trust_mutated} eq 'always') { return { code => '1;', env => {} }; } if ($ti and $ti->{trust_mutated} eq 'maybe') { my ( $env, $code, $arg ); $env = {}; $arg = sub { my $gen = shift; return '$shv_key' if $_[0]=='1'; return '$shv_value' if $_[0]=='2'; $gen->generate_arg( @_ ); }; $code = sprintf( 'my($shv_key,$shv_value)=%s; if (%s>0) { %s }; if (%s>1) { %s };', $gen->generate_args, $gen->generate_argc, $gen->generate_type_assertion( $env, $ti->{key_type} || Str, '$shv_key' ), $gen->generate_argc, $gen->generate_type_assertion( $env, $ti->{value_type}, '$shv_value' ), ); return { code => $code, env => $env, arg => $arg, }; } return; }; sub count { handler name => 'Hash:count', args => 0, template => 'scalar keys %{$GET}', documentation => 'Returns the number of keys in the hash.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n", " say \$object->$method; ## ==> 2\n", "\n"; }, } sub is_empty { handler name => 'Hash:is_empty', args => 0, template => '!scalar keys %{$GET}', documentation => 'Returns true iff there are no keys in the hash.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n", " say \$object->$method; ## ==> false\n", " \$object->_set_$attr( {} );\n", " say \$object->$method; ## ==> true\n", "\n"; }, } sub keys { handler name => 'Hash:keys', args => 0, template => 'keys %{$GET}', documentation => 'Returns the list of keys in the hash.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n", " # says 'foo' and 'bar' in an unpredictable order\n", " say for \$object->$method;\n", "\n"; }, } sub sorted_keys { handler name => 'Hash:sorted_keys', args => 0, template => 'sort(keys %{$GET})', documentation => 'Returns an alphabetically sorted list of keys in the hash.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n", " # says 'bar' then 'foo'\n", " say for \$object->$method;\n", "\n"; }, } sub values { handler name => 'Hash:values', args => 0, template => 'values %{$GET}', documentation => 'Returns the list of values in the hash.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n", " # says '0' and '1' in an unpredictable order\n", " say for \$object->$method;\n", "\n"; }, } sub all { handler name => 'Hash:all', args => 0, template => '%{$GET}', documentation => 'Returns the hash in list context.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n", " my \%hash = \$object->$method;\n", "\n"; }, } sub elements { handler name => 'Hash:elements', args => 0, template => '%{$GET}', documentation => 'Returns the hash in list context.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n", " my \%hash = \$object->$method;\n", "\n"; }, } sub kv { handler name => 'Hash:kv', args => 0, template => 'map [ $_ => ($GET)->{$_} ], keys %{$GET}', documentation => 'Returns a list of arrayrefs, where each arrayref is a key-value pair.', } sub get { handler name => 'Hash:get', min_args => 1, usage => '$key', prefer_shift_self => 1, template => '#ARG>1 ? @{$GET}{@ARG} : ($GET)->{$ARG}', documentation => 'Returns a value from the hashref by its key.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n", " say \$object->$method( 'bar' ); ## ==> 1\n", "\n"; }, } sub defined { handler name => 'Hash:defined', args => 1, signature => [Str], usage => '$key', template => 'defined(($GET)->{$ARG})', documentation => 'Indicates whether a value exists and is defined in the hashref by its key.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n", " say \$object->$method( 'foo' ); ## ==> 1\n", "\n"; }, } sub exists { handler name => 'Hash:exists', args => 1, signature => [Str], usage => '$key', template => 'defined(($GET)->{$ARG})', documentation => 'Indicates whether a value exists in the hashref by its key.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n", " say \$object->$method( 'foo' ); ## ==> true\n", " say \$object->$method( 'baz' ); ## ==> false\n", "\n"; }, } sub delete { handler name => 'Hash:delete', min_args => 1, usage => '$key', template => 'my %shv_tmp = %{$GET}; my @shv_return = delete @shv_tmp{@ARG}; «\%shv_tmp»; wantarray ? @shv_return : $shv_return[-1]', lvalue_template => 'delete(@{$GET}{@ARG})', prefer_shift_self => 1, additional_validation => 'no incoming values', documentation => 'Removes a value from the hashref by its key.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n", " \$object->$method( 'foo' );\n", " say exists \$object->$attr\->{foo}; ## ==> false\n", "\n"; }, } sub delete_where { handler name => 'Hash:delete_where', min_args => 1, usage => '$match', signature => [ CodeRef | RegexpRef ], template => 'my %shv_tmp = %{$GET}; my $shv_match = $ARG; my @shv_keys = ("CODE" eq ref $shv_match) ? grep($shv_match->($_), keys %shv_tmp) : grep(/$shv_match/, keys %shv_tmp); my @shv_return = delete @shv_tmp{@shv_keys}; «\%shv_tmp»; wantarray ? @shv_return : $shv_return[-1]', prefer_shift_self => 1, documentation => 'Removes values from the hashref by matching keys against a coderef or regexp.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => { foo => 0, bar => 1, baz => 2 } );\n", " \$object->$method( sub { \$_ eq 'foo' or \$_ eq 'bar' } );\n", " say Dumper( \$object->$attr ); ## ==> { baz => 2 }\n", " \n", " my \$object2 = $class\->new( $attr => { foo => 0, bar => 1, baz => 2 } );\n", " \$object2->$method( qr/^b/ );\n", " say Dumper( \$object2->$attr ); ## ==> { foo => 0 }\n", "\n"; }, } sub clear { handler name => 'Hash:clear', args => 0, template => '«{}»', lvalue_template => '%{$GET} = ()', additional_validation => 'no incoming values', documentation => 'Empties the hash.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n", " \$object->$method;\n", " say exists \$object->$attr\->{foo}; ## ==> false\n", " say exists \$object->$attr\->{bar}; ## ==> false\n", "\n"; }, } sub shallow_clone { handler name => 'Hash:shallow_clone', args => 0, template => '+{%{$GET}}', documentation => 'Creates a new hashref with the same keys and values as the original.', } sub set { my $me = CORE::shift; handler name => 'Hash:set', min_args => 2, usage => '$key, $value, ...', prefer_shift_self => 1, template => ( 'my (@shv_params) = @ARG; ' . 'scalar(@shv_params) % 2 and ⸨"Wrong number of parameters; expected even-sized list of keys and values"⸩;' . 'my (@shv_keys_idx) = grep(!($_ % 2), 0..$#shv_params); ' . 'my (@shv_values_idx) = grep(($_ % 2), 0..$#shv_params); ' . 'grep(!defined, @shv_params[@shv_keys_idx]) and ⸨"Undef did not pass type constraint; keys must be defined"⸩;'. '"____VALIDATION_HERE____"; '. 'my %shv_tmp = %{$GET}; @shv_tmp{@shv_params[@shv_keys_idx]} = @shv_params[@shv_values_idx]; «\\%shv_tmp»;' . 'wantarray ? @shv_tmp{@shv_params[@shv_keys_idx]} : $shv_tmp{$shv_params[$shv_keys_idx[0]]}' ), lvalue_template => ( 'my (@shv_params) = @ARG; ' . 'scalar(@shv_params) % 2 and ⸨"Wrong number of parameters; expected even-sized list of keys and values"⸩;' . 'my (@shv_keys_idx) = grep(!($_ % 2), 0..$#shv_params); ' . 'my (@shv_values_idx) = grep(($_ % 2), 0..$#shv_params); ' . 'grep(!defined, @shv_params[@shv_keys_idx]) and ⸨"Undef did not pass type constraint; keys must be defined"⸩;'. '"____VALIDATION_HERE____"; '. '@{$GET}{@shv_params[@shv_keys_idx]} = @shv_params[@shv_values_idx];' . 'wantarray ? @{$GET}{@shv_params[@shv_keys_idx]} : ($GET)->{$shv_params[$shv_keys_idx[0]]}' ), additional_validation => sub { my $self = CORE::shift; my ($sig_was_checked, $gen) = @_; my $ti = __PACKAGE__->_type_inspector($gen->isa); my $env = {}; if ($ti and $ti->{trust_mutated} eq 'always') { # still need to check keys are strings return { code => sprintf( 'for my $shv_tmp (@shv_keys_idx) { %s };', $gen->generate_type_assertion( $env, Str, '$shv_params[$shv_tmp]' ), ), env => $env, add_later => 1, }; } if ($ti and $ti->{trust_mutated} eq 'maybe') { return { code => sprintf( 'for my $shv_tmp (@shv_keys_idx) { %s }; for my $shv_tmp (@shv_values_idx) { %s };', $gen->generate_type_assertion( $env, $ti->{key_type}, '$shv_params[$shv_tmp]' ), $gen->generate_type_assertion( $env, $ti->{value_type}, '$shv_params[$shv_tmp]' ), ), env => $env, add_later => 1, }; } return; }, documentation => 'Given a key and value, adds the key to the hashref with the given value.', _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => { foo => 0, bar => 1 } );\n", " \$object->$method( bar => 2, baz => 1 );\n", " say \$object->$attr\->{foo}; ## ==> 0\n", " say \$object->$attr\->{baz}; ## ==> 1\n", " say \$object->$attr\->{bar}; ## ==> 2\n", "\n"; }, } sub accessor { handler name => 'Hash:accessor', min_args => 1, max_args => 2, signature => [Str, Optional[Any]], usage => '$key, $value?', template => 'if (#ARG == 1) { ($GET)->{ $ARG[1] } } else { my %shv_tmp = %{$GET}; $shv_tmp{$ARG[1]} = $ARG[2]; «\\%shv_tmp» }', lvalue_template => '(#ARG == 1) ? ($GET)->{ $ARG[1] } : (($GET)->{ $ARG[1] } = $ARG[2])', additional_validation => $additional_validation_for_set_and_insert, documentation => 'Acts like C if given just a key, or C if given a key and a value.', } sub for_each_pair { handler name => 'Hash:for_each_pair', args => 1, signature => [CodeRef], usage => '$coderef', template => 'while (my ($shv_key,$shv_value)=each %{$GET}) { &{$ARG}($shv_key,$shv_value) }; $SELF', documentation => 'Chainable method which calls the coderef for each key in the hash, passing the key and value to the coderef.', } sub for_each_key { handler name => 'Hash:for_each_key', args => 1, signature => [CodeRef], usage => '$coderef', template => 'for my $shv_key (keys %{$GET}) { &{$ARG}($shv_key) }; $SELF', documentation => 'Chainable method which calls the coderef for each key in the hash, passing just the key to the coderef.', } sub for_each_value { handler name => 'Hash:for_each_value', args => 1, signature => [CodeRef], usage => '$coderef', template => 'for my $shv_value (values %{$GET}) { &{$ARG}($shv_value) }; $SELF', documentation => 'Chainable method which calls the coderef for each value in the hash, passing just the value to the coderef.', } sub reset { handler name => 'Hash:reset', args => 0, template => '« $DEFAULT »', default_for_reset => sub { '{}' }, documentation => 'Resets the attribute to its default value, or an empty hashref if it has no default.', } 1; Hash.pod000664001750001750 1402714772476615 23161 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/HandlerLibrary=head1 NAME Sub::HandlesVia::HandlerLibrary::Hash - library of hash-related methods =head1 SYNOPSIS package My::Class { use Moo; use Sub::HandlesVia; use Types::Standard 'HashRef'; has attr => ( is => 'rwp', isa => HashRef, handles_via => 'Hash', handles => { 'my_accessor' => 'accessor', 'my_all' => 'all', 'my_clear' => 'clear', 'my_count' => 'count', 'my_defined' => 'defined', 'my_delete' => 'delete', 'my_delete_where' => 'delete_where', 'my_elements' => 'elements', 'my_exists' => 'exists', 'my_for_each_key' => 'for_each_key', 'my_for_each_pair' => 'for_each_pair', 'my_for_each_value' => 'for_each_value', 'my_get' => 'get', 'my_is_empty' => 'is_empty', 'my_keys' => 'keys', 'my_kv' => 'kv', 'my_reset' => 'reset', 'my_set' => 'set', 'my_shallow_clone' => 'shallow_clone', 'my_sorted_keys' => 'sorted_keys', 'my_values' => 'values', }, ); } =head1 DESCRIPTION This is a library of methods for L. =head1 DELEGATABLE METHODS =head2 C<< accessor( $key, $value? ) >> Arguments: B<< Str >>, B<< Optional[Any] >>. Acts like C if given just a key, or C if given a key and a value. =head2 C<< all() >> Returns the hash in list context. my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); my %hash = $object->my_all; =head2 C<< clear() >> Empties the hash. my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); $object->my_clear; say exists $object->attr->{foo}; ## ==> false say exists $object->attr->{bar}; ## ==> false =head2 C<< count() >> Returns the number of keys in the hash. my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); say $object->my_count; ## ==> 2 =head2 C<< defined( $key ) >> Arguments: B<< Str >>. Indicates whether a value exists and is defined in the hashref by its key. my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); say $object->my_defined( 'foo' ); ## ==> 1 =head2 C<< delete( $key ) >> Removes a value from the hashref by its key. my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); $object->my_delete( 'foo' ); say exists $object->attr->{foo}; ## ==> false =head2 C<< delete_where( $match ) >> Arguments: B<< CodeRef|RegexpRef >>. Removes values from the hashref by matching keys against a coderef or regexp. my $object = My::Class->new( attr => { foo => 0, bar => 1, baz => 2 } ); $object->my_delete_where( sub { $_ eq 'foo' or $_ eq 'bar' } ); say Dumper( $object->attr ); ## ==> { baz => 2 } my $object2 = My::Class->new( attr => { foo => 0, bar => 1, baz => 2 } ); $object2->my_delete_where( qr/^b/ ); say Dumper( $object2->attr ); ## ==> { foo => 0 } =head2 C<< elements() >> Returns the hash in list context. my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); my %hash = $object->my_elements; =head2 C<< exists( $key ) >> Arguments: B<< Str >>. Indicates whether a value exists in the hashref by its key. my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); say $object->my_exists( 'foo' ); ## ==> true say $object->my_exists( 'baz' ); ## ==> false =head2 C<< for_each_key( $coderef ) >> Arguments: B<< CodeRef >>. Chainable method which calls the coderef for each key in the hash, passing just the key to the coderef. =head2 C<< for_each_pair( $coderef ) >> Arguments: B<< CodeRef >>. Chainable method which calls the coderef for each key in the hash, passing the key and value to the coderef. =head2 C<< for_each_value( $coderef ) >> Arguments: B<< CodeRef >>. Chainable method which calls the coderef for each value in the hash, passing just the value to the coderef. =head2 C<< get( $key ) >> Returns a value from the hashref by its key. my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); say $object->my_get( 'bar' ); ## ==> 1 =head2 C<< is_empty() >> Returns true iff there are no keys in the hash. my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); say $object->my_is_empty; ## ==> false $object->_set_attr( {} ); say $object->my_is_empty; ## ==> true =head2 C<< keys() >> Returns the list of keys in the hash. my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); # says 'foo' and 'bar' in an unpredictable order say for $object->my_keys; =head2 C<< kv() >> Returns a list of arrayrefs, where each arrayref is a key-value pair. =head2 C<< reset() >> Resets the attribute to its default value, or an empty hashref if it has no default. =head2 C<< set( $key, $value, ... ) >> Given a key and value, adds the key to the hashref with the given value. my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); $object->my_set( bar => 2, baz => 1 ); say $object->attr->{foo}; ## ==> 0 say $object->attr->{baz}; ## ==> 1 say $object->attr->{bar}; ## ==> 2 =head2 C<< shallow_clone() >> Creates a new hashref with the same keys and values as the original. =head2 C<< sorted_keys() >> Returns an alphabetically sorted list of keys in the hash. my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); # says 'bar' then 'foo' say for $object->my_sorted_keys; =head2 C<< values() >> Returns the list of values in the hash. my $object = My::Class->new( attr => { foo => 0, bar => 1 } ); # says '0' and '1' in an unpredictable order say for $object->my_values; =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2020, 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. Number.pm000664001750001750 1106014772476615 23352 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/HandlerLibraryuse 5.008; use strict; use warnings; package Sub::HandlesVia::HandlerLibrary::Number; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Sub::HandlesVia::HandlerLibrary; our @ISA = 'Sub::HandlesVia::HandlerLibrary'; use Sub::HandlesVia::Handler qw( handler ); use Types::Standard qw( Num Any Item Defined ); our @METHODS = qw( set get add sub mul div mod abs cmp eq ne gt lt ge le ); sub _type_inspector { my ($me, $type) = @_; if ($type==Num or $type==Defined) { return { trust_mutated => 'maybe', value_type => $type, }; } return $me->SUPER::_type_inspector($type); } sub set { handler name => 'Number:set', args => 1, signature => [Num], template => '« $ARG »', lvalue_template => '$GET = $ARG', usage => '$value', documentation => "Sets the number to a new value.", _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 4 );\n", " \$object->$method\( 5 );\n", " say \$object->$attr; ## ==> 5\n", "\n"; }, } sub get { handler name => 'Number:get', args => 0, template => '$GET', documentation => "Returns the current value of the number.", _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 4 );\n", " say \$object->$method; ## ==> 4\n", "\n"; }, } sub add { handler name => 'Number:add', args => 1, signature => [Num], template => '« $GET + $ARG »', usage => '$addend', documentation => "Adds a number to the existing number, updating the attribute.", _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 4 );\n", " \$object->$method( 5 );\n", " say \$object->$attr; ## ==> 9\n", "\n"; }, } sub sub { handler name => 'Number:sub', args => 1, signature => [Num], template => '« $GET - $ARG »', usage => '$subtrahend', documentation => "Subtracts a number from the existing number, updating the attribute.", _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 9 );\n", " \$object->$method( 6 );\n", " say \$object->$attr; ## ==> 3\n", "\n"; }, } sub mul { handler name => 'Number:mul', args => 1, signature => [Num], template => '« $GET * $ARG »', usage => '$factor', documentation => "Multiplies the existing number by a number, updating the attribute.", _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 2 );\n", " \$object->$method( 5 );\n", " say \$object->$attr; ## ==> 10\n", "\n"; }, } sub div { handler name => 'Number:div', args => 1, signature => [Num], template => '« $GET / $ARG »', usage => '$divisor', documentation => "Divides the existing number by a number, updating the attribute.", _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 6 );\n", " \$object->$method( 2 );\n", " say \$object->$attr; ## ==> 3\n", "\n"; }, } sub mod { handler name => 'Number:mod', args => 1, signature => [Num], template => '« $GET % $ARG »', usage => '$divisor', documentation => "Finds the current number modulo a divisor, updating the attribute.", _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 5 );\n", " \$object->$method( 2 );\n", " say \$object->$attr; ## ==> 1\n", "\n"; }, } sub abs { handler name => 'Number:abs', args => 0, template => '« abs($GET) »', additional_validation => 'no incoming values', documentation => "Finds the absolute value of the current number, updating the attribute.", _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => -5 );\n", " \$object->$method;\n", " say \$object->$attr; ## ==> 5\n", "\n"; }, } for my $comparison ( qw/ cmp eq ne lt gt le ge / ) { my $op = { cmp => '<=>', eq => '==', ne => '!=', lt => '<', gt => '>', le => '<=', ge => '>=', }->{$comparison}; no strict 'refs'; *$comparison = sub { handler name => "Number:$comparison", args => 1, signature => [Num], usage => '$num', template => "\$GET $op \$ARG", documentation => "Returns C<< \$object->attr $op \$num >>.", }; } 1; Number.pod000664001750001750 717214772476615 23511 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/HandlerLibrary=head1 NAME Sub::HandlesVia::HandlerLibrary::Number - library of number-related methods =head1 SYNOPSIS package My::Class { use Moo; use Sub::HandlesVia; use Types::Standard 'Num'; has attr => ( is => 'rwp', isa => Num, handles_via => 'Number', handles => { 'my_abs' => 'abs', 'my_add' => 'add', 'my_cmp' => 'cmp', 'my_div' => 'div', 'my_eq' => 'eq', 'my_ge' => 'ge', 'my_get' => 'get', 'my_gt' => 'gt', 'my_le' => 'le', 'my_lt' => 'lt', 'my_mod' => 'mod', 'my_mul' => 'mul', 'my_ne' => 'ne', 'my_set' => 'set', 'my_sub' => 'sub', }, ); } =head1 DESCRIPTION This is a library of methods for L. =head1 DELEGATABLE METHODS =head2 C<< abs() >> Finds the absolute value of the current number, updating the attribute. my $object = My::Class->new( attr => -5 ); $object->my_abs; say $object->attr; ## ==> 5 =head2 C<< add( $addend ) >> Arguments: B<< Num >>. Adds a number to the existing number, updating the attribute. my $object = My::Class->new( attr => 4 ); $object->my_add( 5 ); say $object->attr; ## ==> 9 =head2 C<< cmp( $num ) >> Arguments: B<< Num >>. Returns C<< $object->attr <=> $num >>. =head2 C<< div( $divisor ) >> Arguments: B<< Num >>. Divides the existing number by a number, updating the attribute. my $object = My::Class->new( attr => 6 ); $object->my_div( 2 ); say $object->attr; ## ==> 3 =head2 C<< eq( $num ) >> Arguments: B<< Num >>. Returns C<< $object->attr == $num >>. =head2 C<< ge( $num ) >> Arguments: B<< Num >>. Returns C<< $object->attr >= $num >>. =head2 C<< get() >> Returns the current value of the number. my $object = My::Class->new( attr => 4 ); say $object->my_get; ## ==> 4 =head2 C<< gt( $num ) >> Arguments: B<< Num >>. Returns C<< $object->attr > $num >>. =head2 C<< le( $num ) >> Arguments: B<< Num >>. Returns C<< $object->attr <= $num >>. =head2 C<< lt( $num ) >> Arguments: B<< Num >>. Returns C<< $object->attr < $num >>. =head2 C<< mod( $divisor ) >> Arguments: B<< Num >>. Finds the current number modulo a divisor, updating the attribute. my $object = My::Class->new( attr => 5 ); $object->my_mod( 2 ); say $object->attr; ## ==> 1 =head2 C<< mul( $factor ) >> Arguments: B<< Num >>. Multiplies the existing number by a number, updating the attribute. my $object = My::Class->new( attr => 2 ); $object->my_mul( 5 ); say $object->attr; ## ==> 10 =head2 C<< ne( $num ) >> Arguments: B<< Num >>. Returns C<< $object->attr != $num >>. =head2 C<< set( $value ) >> Arguments: B<< Num >>. Sets the number to a new value. my $object = My::Class->new( attr => 4 ); $object->my_set( 5 ); say $object->attr; ## ==> 5 =head2 C<< sub( $subtrahend ) >> Arguments: B<< Num >>. Subtracts a number from the existing number, updating the attribute. my $object = My::Class->new( attr => 9 ); $object->my_sub( 6 ); say $object->attr; ## ==> 3 =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2020, 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. Scalar.pm000664001750001750 353214772476615 23314 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/HandlerLibraryuse 5.008; use strict; use warnings; package Sub::HandlesVia::HandlerLibrary::Scalar; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Sub::HandlesVia::HandlerLibrary; our @ISA = 'Sub::HandlesVia::HandlerLibrary'; use Sub::HandlesVia::Handler qw( handler ); our @METHODS = qw( scalar_reference make_getter make_setter ); sub scalar_reference { handler name => 'Scalar:scalar_reference', args => 0, template => '$GET;\\($SLOT)', documentation => "Returns a scalar reference to the attribute value's slot within its object.", _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => 10 );\n", " my \$ref = \$object->$method;\n", " \$\$ref++;\n", " say \$object->$attr; ## ==> 11\n", "\n"; }, allow_getter_shortcuts => 0, } sub make_getter { handler name => 'Scalar:make_getter', args => 0, template => 'my $s = $SELF; sub { unshift @_, $s; $GET }', documentation => "Returns a getter coderef.", _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => 10 );\n", " my \$getter = \$object->$method;\n", " \$object->_set_$attr( 11 );\n", " say \$getter->(); ## ==> 11\n", "\n"; }, allow_getter_shortcuts => 0, } sub make_setter { handler name => 'Scalar:make_setter', args => 0, template => 'my $s = $SELF; sub { my $val = shift; unshift @_, $s; « $val » }', documentation => "Returns a setter coderef.", _examples => sub { my ( $class, $attr, $method ) = @_; return CORE::join "", " my \$object = $class\->new( $attr => 10 );\n", " my \$setter = \$object->$method;\n", " \$setter->( 11 );\n", " say \$object->$attr; ## ==> 11\n", "\n"; }, allow_getter_shortcuts => 0, } 1; Scalar.pod000664001750001750 345714772476615 23470 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/HandlerLibrary=head1 NAME Sub::HandlesVia::HandlerLibrary::Scalar - library of scalar-related methods =head1 SYNOPSIS package My::Class { use Moo; use Sub::HandlesVia; use Types::Standard 'Any'; has attr => ( is => 'rwp', isa => Any, handles_via => 'Scalar', handles => { 'my_make_getter' => 'make_getter', 'my_make_setter' => 'make_setter', 'my_scalar_reference' => 'scalar_reference', }, ); } =head1 DESCRIPTION This is a library of methods for L. =head1 DELEGATABLE METHODS =head2 C<< make_getter() >> Returns a getter coderef. my $object = My::Class->new( attr => 10 ); my $getter = $object->my_make_getter; $object->_set_attr( 11 ); say $getter->(); ## ==> 11 =head2 C<< make_setter() >> Returns a setter coderef. my $object = My::Class->new( attr => 10 ); my $setter = $object->my_make_setter; $setter->( 11 ); say $object->attr; ## ==> 11 =head2 C<< scalar_reference() >> Returns a scalar reference to the attribute value's slot within its object. my $object = My::Class->new( attr => 10 ); my $ref = $object->my_scalar_reference; $$ref++; say $object->attr; ## ==> 11 =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2020, 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. String.pm000664001750001750 2575314772476615 23406 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/HandlerLibraryuse 5.008; use strict; use warnings; package Sub::HandlesVia::HandlerLibrary::String; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Sub::HandlesVia::HandlerLibrary; our @ISA = 'Sub::HandlesVia::HandlerLibrary'; use Sub::HandlesVia::Handler qw( handler ); use Types::Standard qw( Optional Str CodeRef RegexpRef Int Any Item Defined ); our @METHODS = qw( set get inc append prepend chop chomp clear reset length substr replace replace_globally uc lc fc starts_with ends_with contains match cmp eq ne gt lt ge le starts_with_i ends_with_i contains_i match_i cmpi eqi nei gti lti gei lei ); my $fold = ( $] >= 5.016 ) ? 'CORE::fc' : 'lc'; sub _type_inspector { my ($me, $type) = @_; if ($type == Str or $type == Defined) { return { trust_mutated => 'always', }; } return $me->SUPER::_type_inspector($type); } sub set { handler name => 'String:set', args => 1, signature => [Str], template => '« $ARG »', lvalue_template => '$GET = $ARG', usage => '$value', documentation => "Sets the string to a new value.", _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 'foo' );\n", " \$object->$method\( 'bar' );\n", " say \$object->$attr; ## ==> 'bar'\n", "\n"; }, } sub get { handler name => 'String:get', args => 0, template => '$GET', documentation => "Gets the current value of the string.", _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 'foo' );\n", " say \$object->$method; ## ==> 'foo'\n", "\n"; }, } sub inc { handler name => 'String:inc', args => 0, template => '« do { my $shv_tmp = $GET; ++$shv_tmp } »', lvalue_template => '++$GET', additional_validation => 'no incoming values', documentation => "Performs C<< ++ >> on the string.", } sub append { handler name => 'String:append', args => 1, signature => [Str], template => '« $GET . $ARG »', lvalue_template => '$GET .= $ARG', usage => '$tail', documentation => "Appends another string to the end of the current string and updates the attribute.", _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 'foo' );\n", " \$object->$method( 'bar' );\n", " say \$object->$attr; ## ==> 'foobar'\n", "\n"; }, } sub prepend { handler args => 1, name => 'String:prepend', signature => [Str], template => '« $ARG . $GET »', usage => '$head', documentation => "Prepends another string to the start of the current string and updates the attribute.", _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 'foo' );\n", " \$object->$method( 'bar' );\n", " say \$object->$attr; ## ==> 'barfoo'\n", "\n"; }, } sub replace { handler name => 'String:replace', args => 2, signature => [ Str|RegexpRef, Str|CodeRef ], usage => '$regexp, $replacement', template => sprintf( 'my $shv_tmp = $GET; if (%s) { my $shv_callback = $ARG[2]; $shv_tmp =~ s/$ARG[1]/$shv_callback->()/e } else { $shv_tmp =~ s/$ARG[1]/$ARG[2]/ } «$shv_tmp»', CodeRef->inline_check('$ARG[2]'), ), lvalue_template => sprintf( 'if (%s) { my $shv_callback = $ARG[2]; $GET =~ s/$ARG[1]/$shv_callback->()/e } else { $GET =~ s/$ARG[1]/$ARG[2]/ } $GET', CodeRef->inline_check('$ARG[2]'), ), documentation => "Replaces the first regexp match within the string with the replacement string.", _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 'foo' );\n", " \$object->$method( 'o' => 'a' );\n", " say \$object->$attr; ## ==> 'fao'\n", "\n", " my \$object2 = $class\->new( $attr => 'foo' );\n", " \$object2->$method( qr/O/i => sub { return 'e' } );\n", " say \$object2->$attr; ## ==> 'feo'\n", "\n"; }, } sub replace_globally { handler name => 'String:replace_globally', args => 2, signature => [ Str|RegexpRef, Str|CodeRef ], usage => '$regexp, $replacement', template => sprintf( 'my $shv_tmp = $GET; if (%s) { my $shv_callback = $ARG[2]; $shv_tmp =~ s/$ARG[1]/$shv_callback->()/eg } else { $shv_tmp =~ s/$ARG[1]/$ARG[2]/g } «$shv_tmp»', CodeRef->inline_check('$ARG[2]'), ), lvalue_template => sprintf( 'if (%s) { my $shv_callback = $ARG[2]; $GET =~ s/$ARG[1]/$shv_callback->()/eg } else { $GET =~ s/$ARG[1]/$ARG[2]/g } $GET', CodeRef->inline_check('$ARG[2]'), ), documentation => "Replaces the all regexp matches within the string with the replacement string.", _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 'foo' );\n", " \$object->$method( 'o' => 'a' );\n", " say \$object->$attr; ## ==> 'faa'\n", "\n", " my \$object2 = $class\->new( $attr => 'foo' );\n", " \$object2->$method( qr/O/i => sub { return 'e' } );\n", " say \$object2->$attr; ## ==> 'fee'\n", "\n"; }, } sub match { handler name => 'String:match', args => 1, signature => [ Str|RegexpRef ], usage => '$regexp', template => '$GET =~ /$ARG/', documentation => "Returns true iff the string matches the regexp.", _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 'foo' );\n", " if ( \$object->$method\( '^f..\$' ) ) {\n", " say 'matched!';\n", " }\n", "\n"; }, } sub match_i { handler name => 'String:match_i', args => 1, signature => [ Str|RegexpRef ], usage => '$regexp', template => '$GET =~ /$ARG/i', documentation => "Returns true iff the string matches the regexp case-insensitively.", _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 'foo' );\n", " if ( \$object->$method\( '^F..\$' ) ) {\n", " say 'matched!';\n", " }\n", "\n"; }, } sub starts_with { handler name => 'String:starts_with', args => 1, signature => [ Str ], usage => '$head', template => 'substr($GET, 0, length $ARG) eq $ARG', documentation => "Returns true iff the string starts with C<< \$head >>.", } sub starts_with_i { handler name => 'String:starts_with_i', args => 1, signature => [ Str ], usage => '$head', template => sprintf( '%s(substr($GET, 0, length $ARG)) eq %s($ARG)', $fold, $fold ), documentation => "Returns true iff the string starts with C<< \$head >> case-insensitvely.", } sub ends_with { handler name => 'String:ends_with', args => 1, signature => [ Str ], usage => '$tail', template => 'substr($GET, -length $ARG) eq $ARG', documentation => "Returns true iff the string ends with C<< \$tail >>.", } sub ends_with_i { handler name => 'String:ends_with_i', args => 1, signature => [ Str ], usage => '$tail', template => sprintf( '%s(substr($GET, -length $ARG)) eq %s($ARG)', $fold, $fold ), documentation => "Returns true iff the string ends with C<< \$tail >> case-insensitvely.", } sub contains { handler name => 'String:contains', args => 1, signature => [ Str ], usage => '$str', template => 'index($GET, $ARG) != -1', documentation => "Returns true iff the string contains C<< \$str >>.", } sub contains_i { handler name => 'String:contains_i', args => 1, signature => [ Str ], usage => '$str', template => sprintf( 'index(%s($GET), %s($ARG)) != -1', $fold, $fold ), documentation => "Returns true iff the string contains C<< \$str >> case-insensitvely.", } sub chop { handler name => 'String:chop', args => 0, template => 'my $shv_return = chop(my $shv_tmp = $GET); «$shv_tmp»; $shv_return', lvalue_template => 'chop($GET)', additional_validation => 'no incoming values', documentation => "Like C from L.", } sub chomp { handler name => 'String:chomp', args => 0, template => 'my $shv_return = chomp(my $shv_tmp = $GET); «$shv_tmp»; $shv_return', lvalue_template => 'chomp($GET)', additional_validation => 'no incoming values', documentation => "Like C from L.", } sub clear { handler name => 'String:clear', args => 0, template => '«q()»', additional_validation => 'no incoming values', documentation => "Sets the string to the empty string.", _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 'foo' );\n", " \$object->$method;\n", " say \$object->$attr; ## nothing\n", "\n"; }, } sub reset { handler name => 'String:reset', args => 0, template => '« $DEFAULT »', default_for_reset => sub { 'q()' }, documentation => 'Resets the attribute to its default value, or an empty string if it has no default.', } sub length { handler name => 'String:length', args => 0, template => 'length($GET)', documentation => "Like C from L.", _examples => sub { my ( $class, $attr, $method ) = @_; return join "", " my \$object = $class\->new( $attr => 'foo' );\n", " say \$object->$method; ## ==> 3\n", "\n"; }, } sub substr { handler name => 'String:substr', min_args => 1, max_args => 3, signature => [Int, Optional[Int], Optional[Str]], usage => '$start, $length?, $replacement?', template => 'if (#ARG==1) { substr($GET, $ARG[1]) } elsif (#ARG==2) { substr($GET, $ARG[1], $ARG[2]) } elsif (#ARG==3) { my $shv_tmp = $GET; my $shv_return = substr($shv_tmp, $ARG[1], $ARG[2], $ARG[3]); «$shv_tmp»; $shv_return } ', lvalue_template => 'if (#ARG==1) { substr($GET, $ARG[1]) } elsif (#ARG==2) { substr($GET, $ARG[1], $ARG[2]) } elsif (#ARG==3) { substr($GET, $ARG[1], $ARG[2], $ARG[3]) } ', documentation => "Like C from L, but is not an lvalue.", } for my $comparison ( qw/ cmp eq ne lt gt le ge / ) { no strict 'refs'; *$comparison = sub { handler name => "String:$comparison", args => 1, signature => [Str], usage => '$str', template => "\$GET $comparison \$ARG", documentation => "Returns C<< \$object->attr $comparison \$str >>.", }; *{ $comparison . 'i' } = sub { handler name => "String:$comparison" . 'i', args => 1, signature => [Str], usage => '$str', template => "$fold(\$GET) $comparison $fold(\$ARG)", documentation => "Returns C<< fc(\$object->attr) $comparison fc(\$str) >>. Uses C instead of C in versions of Perl older than 5.16.", }; } for my $mutation ( qw/ uc fc lc / ) { no strict 'refs'; my $mutationf = $mutation; if ( $mutationf eq 'fc' ) { $mutationf = $fold; } *$mutation = sub { handler name => "String:$mutation", args => 0, template => "$mutationf(\$GET)", documentation => "Returns C<< $mutation(\$object->attr) >>.", }; } 1; String.pod000664001750001750 2326714772476615 23552 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/HandlerLibrary=head1 NAME Sub::HandlesVia::HandlerLibrary::String - library of string-related methods =head1 SYNOPSIS package My::Class { use Moo; use Sub::HandlesVia; use Types::Standard 'Str'; has attr => ( is => 'rwp', isa => Str, handles_via => 'String', handles => { 'my_append' => 'append', 'my_chomp' => 'chomp', 'my_chop' => 'chop', 'my_clear' => 'clear', 'my_cmp' => 'cmp', 'my_cmpi' => 'cmpi', 'my_contains' => 'contains', 'my_contains_i' => 'contains_i', 'my_ends_with' => 'ends_with', 'my_ends_with_i' => 'ends_with_i', 'my_eq' => 'eq', 'my_eqi' => 'eqi', 'my_fc' => 'fc', 'my_ge' => 'ge', 'my_gei' => 'gei', 'my_get' => 'get', 'my_gt' => 'gt', 'my_gti' => 'gti', 'my_inc' => 'inc', 'my_lc' => 'lc', 'my_le' => 'le', 'my_lei' => 'lei', 'my_length' => 'length', 'my_lt' => 'lt', 'my_lti' => 'lti', 'my_match' => 'match', 'my_match_i' => 'match_i', 'my_ne' => 'ne', 'my_nei' => 'nei', 'my_prepend' => 'prepend', 'my_replace' => 'replace', 'my_replace_globally' => 'replace_globally', 'my_reset' => 'reset', 'my_set' => 'set', 'my_starts_with' => 'starts_with', 'my_starts_with_i' => 'starts_with_i', 'my_substr' => 'substr', 'my_uc' => 'uc', }, ); } =head1 DESCRIPTION This is a library of methods for L. =head1 DELEGATABLE METHODS =head2 C<< append( $tail ) >> Arguments: B<< Str >>. Appends another string to the end of the current string and updates the attribute. my $object = My::Class->new( attr => 'foo' ); $object->my_append( 'bar' ); say $object->attr; ## ==> 'foobar' =head2 C<< chomp() >> Like C from L. =head2 C<< chop() >> Like C from L. =head2 C<< clear() >> Sets the string to the empty string. my $object = My::Class->new( attr => 'foo' ); $object->my_clear; say $object->attr; ## nothing =head2 C<< cmp( $str ) >> Arguments: B<< Str >>. Returns C<< $object->attr cmp $str >>. =head2 C<< cmpi( $str ) >> Arguments: B<< Str >>. Returns C<< fc($object->attr) cmp fc($str) >>. Uses C instead of C in versions of Perl older than 5.16. =head2 C<< contains( $str ) >> Arguments: B<< Str >>. Returns true iff the string contains C<< $str >>. =head2 C<< contains_i( $str ) >> Arguments: B<< Str >>. Returns true iff the string contains C<< $str >> case-insensitvely. =head2 C<< ends_with( $tail ) >> Arguments: B<< Str >>. Returns true iff the string ends with C<< $tail >>. =head2 C<< ends_with_i( $tail ) >> Arguments: B<< Str >>. Returns true iff the string ends with C<< $tail >> case-insensitvely. =head2 C<< eq( $str ) >> Arguments: B<< Str >>. Returns C<< $object->attr eq $str >>. =head2 C<< eqi( $str ) >> Arguments: B<< Str >>. Returns C<< fc($object->attr) eq fc($str) >>. Uses C instead of C in versions of Perl older than 5.16. =head2 C<< fc() >> Returns C<< fc($object->attr) >>. =head2 C<< ge( $str ) >> Arguments: B<< Str >>. Returns C<< $object->attr ge $str >>. =head2 C<< gei( $str ) >> Arguments: B<< Str >>. Returns C<< fc($object->attr) ge fc($str) >>. Uses C instead of C in versions of Perl older than 5.16. =head2 C<< get() >> Gets the current value of the string. my $object = My::Class->new( attr => 'foo' ); say $object->my_get; ## ==> 'foo' =head2 C<< gt( $str ) >> Arguments: B<< Str >>. Returns C<< $object->attr gt $str >>. =head2 C<< gti( $str ) >> Arguments: B<< Str >>. Returns C<< fc($object->attr) gt fc($str) >>. Uses C instead of C in versions of Perl older than 5.16. =head2 C<< inc() >> Performs C<< ++ >> on the string. =head2 C<< lc() >> Returns C<< lc($object->attr) >>. =head2 C<< le( $str ) >> Arguments: B<< Str >>. Returns C<< $object->attr le $str >>. =head2 C<< lei( $str ) >> Arguments: B<< Str >>. Returns C<< fc($object->attr) le fc($str) >>. Uses C instead of C in versions of Perl older than 5.16. =head2 C<< length() >> Like C from L. my $object = My::Class->new( attr => 'foo' ); say $object->my_length; ## ==> 3 =head2 C<< lt( $str ) >> Arguments: B<< Str >>. Returns C<< $object->attr lt $str >>. =head2 C<< lti( $str ) >> Arguments: B<< Str >>. Returns C<< fc($object->attr) lt fc($str) >>. Uses C instead of C in versions of Perl older than 5.16. =head2 C<< match( $regexp ) >> Arguments: B<< Str|RegexpRef >>. Returns true iff the string matches the regexp. my $object = My::Class->new( attr => 'foo' ); if ( $object->my_match( '^f..$' ) ) { say 'matched!'; } =head2 C<< match_i( $regexp ) >> Arguments: B<< Str|RegexpRef >>. Returns true iff the string matches the regexp case-insensitively. my $object = My::Class->new( attr => 'foo' ); if ( $object->my_match_i( '^F..$' ) ) { say 'matched!'; } =head2 C<< ne( $str ) >> Arguments: B<< Str >>. Returns C<< $object->attr ne $str >>. =head2 C<< nei( $str ) >> Arguments: B<< Str >>. Returns C<< fc($object->attr) ne fc($str) >>. Uses C instead of C in versions of Perl older than 5.16. =head2 C<< prepend( $head ) >> Arguments: B<< Str >>. Prepends another string to the start of the current string and updates the attribute. my $object = My::Class->new( attr => 'foo' ); $object->my_prepend( 'bar' ); say $object->attr; ## ==> 'barfoo' =head2 C<< replace( $regexp, $replacement ) >> Arguments: B<< Str|RegexpRef >>, B<< Str|CodeRef >>. Replaces the first regexp match within the string with the replacement string. my $object = My::Class->new( attr => 'foo' ); $object->my_replace( 'o' => 'a' ); say $object->attr; ## ==> 'fao' my $object2 = My::Class->new( attr => 'foo' ); $object2->my_replace( qr/O/i => sub { return 'e' } ); say $object2->attr; ## ==> 'feo' =head2 C<< replace_globally( $regexp, $replacement ) >> Arguments: B<< Str|RegexpRef >>, B<< Str|CodeRef >>. Replaces the all regexp matches within the string with the replacement string. my $object = My::Class->new( attr => 'foo' ); $object->my_replace_globally( 'o' => 'a' ); say $object->attr; ## ==> 'faa' my $object2 = My::Class->new( attr => 'foo' ); $object2->my_replace_globally( qr/O/i => sub { return 'e' } ); say $object2->attr; ## ==> 'fee' =head2 C<< reset() >> Resets the attribute to its default value, or an empty string if it has no default. =head2 C<< set( $value ) >> Arguments: B<< Str >>. Sets the string to a new value. my $object = My::Class->new( attr => 'foo' ); $object->my_set( 'bar' ); say $object->attr; ## ==> 'bar' =head2 C<< starts_with( $head ) >> Arguments: B<< Str >>. Returns true iff the string starts with C<< $head >>. =head2 C<< starts_with_i( $head ) >> Arguments: B<< Str >>. Returns true iff the string starts with C<< $head >> case-insensitvely. =head2 C<< substr( $start, $length?, $replacement? ) >> Arguments: B<< Int >>, B<< Optional[Int] >>, B<< Optional[Str] >>. Like C from L, but is not an lvalue. =head2 C<< uc() >> Returns C<< uc($object->attr) >>. =head1 EXTENDED EXAMPLES =head2 Using eq for Enum use strict; use warnings; package My::Person { use Moo; use Sub::HandlesVia; use Types::Standard qw( Str Enum ); has name => ( is => 'ro', isa => Str, required => 1, ); has status => ( is => 'rwp', isa => Enum[ 'alive', 'dead' ], handles_via => 'String', handles => { is_alive => [ eq => 'alive' ], is_dead => [ eq => 'dead' ], kill => [ set => 'dead' ], }, default => 'alive', ); # Note: method modifiers work on delegated methods # before kill => sub { my $self = shift; warn "overkill" if $self->is_dead; }; } my $bob = My::Person->new( name => 'Robert' ); say $bob->is_alive; ## ==> true say $bob->is_dead; ## ==> false $bob->kill; say $bob->is_alive; ## ==> false say $bob->is_dead; ## ==> true See also L, L and L. =head2 Match with curried regexp use strict; use warnings; package My::Component { use Moo; use Sub::HandlesVia; use Types::Standard qw( Str Int ); has id => ( is => 'ro', isa => Int, required => 1, ); has name => ( is => 'ro', isa => Str, required => 1, handles_via => 'String', handles => { name_is_safe_filename => [ match => qr/\A[A-Za-z0-9]+\z/ ], _lc_name => 'lc', }, ); sub config_filename { my $self = shift; if ( $self->name_is_safe_filename ) { return sprintf( '%s.ini', $self->_lc_name ); } return sprintf( 'component-%d.ini', $self->id ); } } my $foo = My::Component->new( id => 42, name => 'Foo' ); say $foo->config_filename; ## ==> 'foo.ini' my $bar4 = My::Component->new( id => 99, name => 'Bar #4' ); say $bar4->config_filename; ## ==> 'component-99.ini' =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2020, 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. Advanced.pod000664001750001750 1432014772476615 22312 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/Manual=pod =encoding utf-8 =head1 NAME Sub::HandlesVia::Manual::Advanced - misc advanced documentation =head1 MANUAL The following information applies no matter which OO toolkit you are using. =head2 Method Chaining Say you have the following handles_via => 'Array', handles => { 'add_food' => 'push', 'find_food' => 'grep', 'remove_food' => 'pop', }, Now C<< $kitchen->remove_food >> will remove the last food on the list and return it. But what if we don't care about what food was removed? We just want to remove the food and discard it. You can do this: handles_via => 'Array', handles => { 'add_food' => 'push', 'find_food' => 'grep', 'remove_food' => 'pop...', }, Now the C method will return the kitchen object instead of returning the food. This makes it suitable for chaining method calls: # remove the three most recent foods $kitchen->remove_food->remove_food->remove_food; =head2 Delegating to CodeRefs You can delegate to coderefs: handles_via => 'Array', handles => { 'find_healthiest' => sub { my $foods = shift; ... }, } =head2 Delegating to Named Methods The L handler library allows you to delegate to named methods of a blessed object. isa => InstanceOf['HTTP::Tiny'], handles_via => 'Blessed', handles => { 'http_get' => 'get', 'http_post' => 'post', }, However, in L, L, L, and L, this kind of delegation is baked in, so you don't even need Sub::HandlesVia! isa => InstanceOf['HTTP::Tiny'], handles => { 'http_get' => 'get', 'http_post' => 'post', }, Still, the L handler library may still be useful if you wish to use other Sub::HandlesVia features like chaining, or if you're using a different OO toolkit. An example of combining delegation to named methods with "native trait" style delegation... let's say "FoodList" is a class where instances are blessed arrayrefs of strings. isa => InstanceOf['FoodList'], handles_via => 'Array', 'Blessed', handles => { 'find_food' => 'grep', 'find_healthiest_food' => 'find_healthiest', }, Now C<< $kitchen->find_food($coderef) >> does this (which breaks encapsulation ): my @result = grep $coderef->(), @{ $kitchen->food }; But because C isn't one of the methods offered by L, Sub::HandlesVia assumes you want to call it on the arrayref like a proper method, so C<< $kitchen->find_healthiest_food >> does this: $kitchen->food->find_healthiest It can be useful to be explicit about which methods you wish to delegate to a "native trait" style array and which are named methods to be called on a blessed object: isa => InstanceOf['FoodList'], handles_via => [ 'Array', 'Blessed' ], handles => { 'find_food' => 'Array->grep', 'find_healthiest_food' => 'Blessed->find_healthiest', }, See L. =head2 Curried Arguments All this talk of food is making me hungry, but as much as I'd like to eat a curry right now, that's not the kind of currying we're talking about. handles_via => 'Array', handles => { 'get_food' => 'get', }, C<< $kitchen->get_food(0) >> will return the first item on the list. C<< $kitchen->get_food(1) >> will return the second item on the list. And so on. handles_via => 'Array', handles => { 'first_food' => [ 'get' => 0 ], 'second_food' => [ 'get' => 1 ], }, I think you already know what this does. Right? And yes, currying works with coderefs. handles_via => 'Array', handles => { 'blargy' => [ sub { ... }, @curried ], }, =head2 Looser Argument Checking Sub::HandlesVia tries to be strict by default. For example, if your attribute specifies C<< isa => ArrayRef[Int] >> then your method which delegates to C will check that its arguments are integers. You can tell it to be less rigourous checking method arguments using the C<< ~ >> prefix: handles_via => 'Array', handles => { 'find_food' => '~grep', }, =head2 Delegating to Multiple Handler Libraries Sometimes you may wish to pick methods to delegate to from multiple handler libraries. This is possible by setting C to an arrayref. isa => ArrayRef|HashRef, handles_via => [ 'Array', 'Hash' ], handles => { the_keys => 'keys', ship_shape => 'sort_in_place', } Here you have an attribute which might be an arrayref or a hashref. When it's an arrayref, C<< $object->ship_shape >> will work nicely, but C<< $object->the_keys >> will fail badly. Still, this sort of thing I kind of make sense if you have an object that overloads both C<< @{} >> and C<< %{} >>. In particular, the L library often makes sense to combine with the other libraries because strings, integers, numbers, booleans, and even arrayrefs, hashrefs, and coderefs, are all scalars. Sometimes a method name will be ambiguous. For example, there's a C method for both hashes and arrays. In this case, the array one will win because you listed it first in C. But you can be specific: isa => ArrayRef|HashRef, handles_via => [ 'Array', 'Hash' ], handles => { get_by_index => 'Array->get', get_by_key => 'Hash->get', } =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. Comparison.pod000664001750001750 2462314772476615 22726 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/Manual=pod =encoding utf-8 =head1 NAME Sub::HandlesVia::Manual::Comparison - comparing Sub::HandlesVia against similar modules =head1 MANUAL The following table compares Sub::HandlesVia with L, L native traits, and L. Array ============================================== accessor : SubHV DataP Moose Mouse all : SubHV DataP all_true : SubHV any : SubHV Mouse apply : SubHV Mouse clear : SubHV DataP Moose Mouse count : SubHV DataP Moose Mouse delete : SubHV DataP Moose Mouse elements : SubHV DataP Moose Mouse fetch : Mouse (alias: get) first : SubHV DataP Moose Mouse first_index : SubHV DataP Moose flatten : SubHV DataP flatten_deep : SubHV DataP for_each : SubHV Mouse for_each_pair : SubHV Mouse get : SubHV DataP Moose Mouse grep : SubHV DataP Moose Mouse head : SubHV DataP insert : SubHV DataP Moose Mouse is_empty : SubHV DataP Moose Mouse join : SubHV DataP Moose Mouse map : SubHV DataP Moose Mouse max : SubHV maxstr : SubHV min : SubHV minstr : SubHV natatime : SubHV DataP Moose not_all_true : SubHV pairfirst : SubHV pairgrep : SubHV pairkeys : SubHV pairmap : SubHV pairs : SubHV pairvalues : SubHV pick_random : SubHV pop : SubHV DataP Moose Mouse print : SubHV DataP product : SubHV push : SubHV DataP Moose Mouse reduce : SubHV DataP Moose Mouse reductions : SubHV remove : Mouse (alias: delete) reset : SubHV reverse : SubHV DataP sample : SubHV set : SubHV DataP Moose Mouse shallow_clone : SubHV DataP Moose shift : SubHV DataP Moose Mouse shuffle : SubHV DataP Moose Mouse shuffle_in_place : SubHV sort : SubHV DataP Moose Mouse sort_by : Mouse (sort) sort_in_place : SubHV DataP Moose Mouse sort_in_place_by : Mouse (sort_in_place) splice : SubHV DataP Moose Mouse store : Mouse (alias: set) sum : SubHV tail : SubHV DataP uniq : SubHV DataP Moose Mouse uniq_in_place : SubHV uniqnum : SubHV uniqnum_in_place : SubHV uniqstr : SubHV uniqstr_in_place : SubHV unshift : SubHV DataP Moose Mouse Blessed ============================================ (Accepts any method name.) Bool =============================================== not : SubHV DataP Moose Mouse reset : SubHV set : SubHV DataP Moose Mouse toggle : SubHV DataP Moose Mouse unset : SubHV DataP Moose Mouse Code =============================================== execute : SubHV DataP Moose Mouse execute_list : SubHV execute_method : SubHV Moose Mouse execute_method_list : SubHV execute_method_scalar : SubHV execute_method_void : SubHV execute_scalar : SubHV execute_void : SubHV Counter ============================================ dec : SubHV DataP Moose Mouse inc : SubHV DataP Moose Mouse reset : SubHV DataP Moose Mouse set : SubHV Moose Mouse Enum =============================================== assign : SubHV is : SubHV set : SubHV Hash =============================================== accessor : SubHV DataP Moose Mouse all : SubHV DataP clear : SubHV DataP Moose Mouse count : SubHV DataP Moose Mouse defined : SubHV DataP Moose Mouse delete : SubHV DataP Moose Mouse delete_where : SubHV elements : SubHV DataP Moose Mouse exists : SubHV DataP Moose Mouse fetch : Mouse (alias: get) for_each_key : SubHV Mouse for_each_pair : SubHV Mouse for_each_value : SubHV Mouse get : SubHV DataP Moose Mouse is_empty : SubHV DataP Moose Mouse keys : SubHV DataP Moose Mouse kv : SubHV DataP Moose Mouse reset : SubHV set : SubHV DataP Moose Mouse shallow_clone : SubHV DataP Moose sorted_keys : SubHV Mouse store : Mouse (alias: set) values : SubHV DataP Moose Mouse Number ============================================= abs : SubHV DataP Moose Mouse add : SubHV DataP Moose Mouse cmp : SubHV div : SubHV DataP Moose Mouse eq : SubHV ge : SubHV get : SubHV gt : SubHV le : SubHV lt : SubHV mod : SubHV DataP Moose Mouse mul : SubHV DataP Moose Mouse ne : SubHV set : SubHV Moose sub : SubHV DataP Moose Mouse Scalar ============================================= make_getter : SubHV make_setter : SubHV scalar_reference : SubHV String ============================================= append : SubHV DataP Moose Mouse chomp : SubHV DataP Moose Mouse chop : SubHV DataP Moose Mouse clear : SubHV DataP Moose Mouse cmp : SubHV cmpi : SubHV contains : SubHV contains_i : SubHV ends_with : SubHV ends_with_i : SubHV eq : SubHV eqi : SubHV fc : SubHV ge : SubHV gei : SubHV get : SubHV gt : SubHV gti : SubHV inc : SubHV DataP Moose Mouse lc : SubHV le : SubHV lei : SubHV length : SubHV DataP Moose Mouse lt : SubHV lti : SubHV match : SubHV DataP Moose Mouse match_i : SubHV ne : SubHV nei : SubHV prepend : SubHV DataP Moose Mouse replace : SubHV DataP Moose Mouse replace_globally : SubHV Mouse reset : SubHV set : SubHV starts_with : SubHV starts_with_i : SubHV substr : SubHV DataP Moose Mouse uc : SubHV =head1 BUGS Please report any bugs to L. =head1 SEE ALSO L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. WithClassTiny.pod000664001750001750 667214772476615 23345 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/Manual=pod =encoding utf-8 =head1 NAME Sub::HandlesVia::Manual::WithClassTiny - using Sub::HandlesVia with Class::Tiny =head1 SYNOPSIS package Kitchen; use Class::Tiny { foods => sub { [] }, drinks => sub { [ 'water' ] }, }; use Sub::HandlesVia::Declare 'foods', Array => ( all_foods => 'all', add_food => 'push', ); use Sub::HandlesVia::Declare 'drinks', Array => ( all_drinks => 'all', add_drink => 'push', ); =head1 MANUAL Sub::HandlesVia allows you to delegate methods from your class to the values of your objects' attributes. Conceptually, it allows you to define C<< $object->push_number($n) >> to be a shortcut for C<< $object->numbers->push($n) >> except that C<< $object->numbers >> is an arrayref, so doesn't have methods you can call on it like C. =head2 Which Methods Can Be Delegated To? The second parameter ("Array" in the synopsis) indicates which library of methods should be available. Valid values include L, L, L, L, L, L, L, L, L, and L. An arrayref can be provided, though many of the options are conceptually contradictory. use Sub::HandlesVia::Declare 'num', [ 'Number', 'Scalar' ] => ( ..., ); =head2 Run-Time Delegation Rather than using L which operates at compile time, you can use the C function at run time. Which you choose is largely down to style and personal preference. package Kitchen; use Class::Tiny { foods => sub { [] }, drinks => sub { [ 'water' ] }, }; use Sub::HandlesVia qw( delegations ); delegations( attribute => 'foods', handles_via => 'Array', handles => { all_foods => 'all', add_food => 'push', }, ); delegations( attribute => 'drinks', handles_via => 'Array', handles => { all_drinks => 'all', add_drink => 'push', }, ); =head1 BUGS Please report any bugs to L. =head1 SEE ALSO Misc advanced documentation: L. L. Documentation for delegatable methods: L, L, L, L, L, L, L, L, L, and L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. WithGeneric.pod000664001750001750 754014772476615 23003 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/Manual=pod =encoding utf-8 =head1 NAME Sub::HandlesVia::Manual::WithGeneric - using Sub::HandlesVia with generic Perl classes =head1 MANUAL Sub::HandlesVia allows you to delegate methods from your class to the values of your objects' attributes. Conceptually, it allows you to define C<< $object->push_number($n) >> to be a shortcut for C<< $object->numbers->push($n) >> except that C<< $object->numbers >> is an arrayref, so doesn't have methods you can call on it like C. For Moose and Mouse, Sub::HandlesVia can use their metaobject protocols to grab an attribute's definition and install the methods it needs to. For Moo, it can wrap C and do its stuff that way. For other classes, you need to be more explicit and tell it what methods to delegate to what attributes. package Kitchen { # constructor sub new { my ( $class, %arg ) = @_; $arg{food} ||= []; return bless( \%arg, $class ); } # getter/setter for `food` sub food { (@_ == 1) ? $_[0]{food} : ( $_[0]{food} = $_[1] ); } use Sub::HandlesVia qw( delegations ); delegations( attribute => 'food' handles_via => 'Array', handles => { 'add_food' => 'push', 'find_food' => 'grep', }, ); } Setting C to "food" means that when Sub::HandlesVia needs to get the food list, it will call C<< $kitchen->food >> and when it needs to set the food list, it will call C<< $kitchen->food($value) >>. If you have separate getter and setter methods, just do: attribute => [ 'get_food', 'set_food' ], Or if you don't have any accessors and want Sub::HandlesVia to directly access the underlying hashref: attribute => '{food}', Or maybe you have a setter, but want to use hashref access for the getter: attribute => [ '{food}', 'set_food' ], Or maybe you still want direct access for the getter, but your object is a blessed arrayref instead of a blessed hashref: attribute => [ '[7]', 'set_food' ], Or maybe your needs are crazy unique: attribute => [ \&getter, \&setter ], The coderefs are passed the instance as their first argument, and the setter is also passed a value to set. Really, I don't think there's any object system that this won't work for! If you supply an arrayref with a getter and setter, it's also possible to supply a third argument which is a coderef or string which will be called as a method if needing to "reset" the value. This can be thought of like a default or builder. (The C function can be imported into Moo/Mouse/Moose classes too, in which case the C needs to be the same attribute name you passed to C. You cannot use a arrayref, coderef, hash key, or array index.) =head1 BUGS Please report any bugs to L. =head1 SEE ALSO Misc advanced documentation: L. L. Documentation for delegatable methods: L, L, L, L, L, L, L, L, L, and L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. WithMite.pod000664001750001750 761614772476615 22331 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/Manual=pod =encoding utf-8 =head1 NAME Sub::HandlesVia::Manual::WithMite - using Sub::HandlesVia with Mite =head1 SYNOPSIS package MyApp::Kitchen { use MyApp::Mite; has food => ( is => 'ro', isa => 'ArrayRef[Str]', handles_via => 'Array', default => sub { [] }, handles => { 'add_food' => 'push', 'find_food' => 'grep', }, ); } =head1 MANUAL Sub::HandlesVia allows you to delegate methods from your class to the values of your objects' attributes. Conceptually, it allows you to define C<< $object->push_number($n) >> to be a shortcut for C<< $object->numbers->push($n) >> except that C<< $object->numbers >> is an arrayref, so doesn't have methods you can call on it like C. Mite 0.009000 and above have built-in C support. Mite will co-operate with Sub::HandlesVia to implement C and avoid your project having a Sub::HandlesVia dependency! =head2 Which Methods Can Be Delegated To? The C option indicates which library of methods should be available. Valid values include L, L, L, L, L, L, L, L, L, and L. An arrayref can be provided for C, though many of the options are conceptually contradictory. handles_via => [ 'Number', 'Scalar' ] =head2 C<< use Sub::HandlesVia >> Mite goes to a lot of effort to avoid you needing to C<< use Sub::HandlesVia >> directly in your classes and roles, and thus avoid you needing to add it as a dependency. However, there are edge cases that it might not handle. In these cases, you should be able to C<< use SubHandlesVia >> in your code I<< after >> your C<< use MyApp::Mite >> and Sub::HandlesVia will intervene and make things work. This adds a dependency on Sub::HandlesVia though. package MyApp::Kitchen { use MyApp::Mite; use Sub::HandlesVia; has food => ( is => 'ro', isa => 'ArrayRef[Str]', handles_via => 'Array', default => sub { [] }, handles => { 'add_food' => 'push', 'find_food' => 'grep', }, ); } Now Mite will no longer generate C and C methods in your F file when you run C<< mite compile >>. Instead, Sub::HandlesVia will generate them at run-time when your application runs. =head1 BUGS Please report any bugs to L. =head1 SEE ALSO Misc advanced documentation: L. L, L. Documentation for delegatable methods: L, L, L, L, L, L, L, L, L, and L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. WithMoo.pod000664001750001750 732114772476615 22156 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/Manual=pod =encoding utf-8 =head1 NAME Sub::HandlesVia::Manual::WithMoo - using Sub::HandlesVia with Moo =head1 SYNOPSIS package Kitchen { use Moo; use Sub::HandlesVia; use Types::Standard qw( ArrayRef Str ); has food => ( is => 'ro', isa => ArrayRef[Str], handles_via => 'Array', default => sub { [] }, handles => { 'add_food' => 'push', 'find_food' => 'grep', }, ); } =head1 MANUAL Sub::HandlesVia allows you to delegate methods from your class to the values of your objects' attributes. Conceptually, it allows you to define C<< $object->push_number($n) >> to be a shortcut for C<< $object->numbers->push($n) >> except that C<< $object->numbers >> is an arrayref, so doesn't have methods you can call on it like C. You should be able to use Sub::HandlesVia as a drop-in replacement for L, which provides a similar feature, though has a more limited implementation. Sub::HandlesVia honours type constraints, plus it can mutate non-reference values. =head2 Which Methods Can Be Delegated To? The C option indicates which library of methods should be available. Valid values include L, L, L, L, L, L, L, L, L, and L. An arrayref can be provided for C, though many of the options are conceptually contradictory. handles_via => [ 'Number', 'Scalar' ] =head1 BUGS Please report any bugs to L. =head2 Potential load order bugs Unlike L, Moo doesn't really offer much of an API for extensions. As a result, most modules that provide extensions do so by wrapping the Moo keywords (especially C). Sub::HandlesVia is no exception to this. If you are using multiple Moo extensions, you may need to adjust the order you C them for them to work properly together. In some combinations, there may be no order that fully works! Some known modules that should be imported I Sub::HandlesVia if you're using them: L. Some known modules that should be imported I Sub::HandlesVia if you're using them: L. Some known modules that conflict with Sub::HandlesVia: none so far! =head1 SEE ALSO Misc advanced documentation: L. L. Documentation for delegatable methods: L, L, L, L, L, L, L, L, L, and L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. WithMoose.pod000664001750001750 747414772476615 22517 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/Manual=pod =encoding utf-8 =head1 NAME Sub::HandlesVia::Manual::WithMoose - using Sub::HandlesVia with Moose =head1 SYNOPSIS package Kitchen { use Moose; use Sub::HandlesVia; use Types::Standard qw( ArrayRef Str ); has food => ( is => 'ro', isa => ArrayRef[Str], handles_via => 'Array', default => sub { [] }, handles => { 'add_food' => 'push', 'find_food' => 'grep', }, ); } (If you have a moose in your kitchen, that might be a disaster!) =head1 MANUAL Sub::HandlesVia allows you to delegate methods from your class to the values of your objects' attributes. Conceptually, it allows you to define C<< $object->push_number($n) >> to be a shortcut for C<< $object->numbers->push($n) >> except that C<< $object->numbers >> is an arrayref, so doesn't have methods you can call on it like C. Moose does have a built-in feature (native traits) which provides a more limited version of this. =head2 Which Methods Can Be Delegated To? The C option indicates which library of methods should be available. Valid values include L, L, L, L, L, L, L, L, L, and L. An arrayref can be provided for C, though many of the options are conceptually contradictory. handles_via => [ 'Number', 'Scalar' ] =head2 Moose Native Types Although the synopsis shows L being used for type constraints, Moose native types should also work fine. package Kitchen { use Moose; use Sub::HandlesVia; has food => ( is => 'ro', isa => 'ArrayRef[Str]', handles_via => 'Array', default => sub { [] }, handles => { 'add_food' => 'push', 'find_food' => 'grep', }, ); } =head2 True Moose Native Traits Drop-In Syntax Sub::HandlesVia will also recognize native-traits-style traits. It will jump in and handle them before Moose notices! package Kitchen { use Moose; use Sub::HandlesVia; has food => ( is => 'ro', isa => 'ArrayRef[Str]', traits => ['Array'], default => sub { [] }, handles => { 'add_food' => 'push', 'find_food' => 'grep', }, ); } =head1 BUGS Please report any bugs to L. =head1 SEE ALSO Misc advanced documentation: L. L. Documentation for delegatable methods: L, L, L, L, L, L, L, L, L, and L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. WithMouse.pod000664001750001750 1070314772476615 22532 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/Manual=pod =encoding utf-8 =head1 NAME Sub::HandlesVia::Manual::WithMouse - using Sub::HandlesVia with Mouse =head1 SYNOPSIS package Kitchen { use Mouse; use Sub::HandlesVia; use Types::Standard qw( ArrayRef Str ); has food => ( is => 'ro', isa => ArrayRef[Str], handles_via => 'Array', default => sub { [] }, handles => { 'add_food' => 'push', 'find_food' => 'grep', }, ); } (If you have a mouse in your kitchen, that might not be very hygienic.) =head1 MANUAL Sub::HandlesVia allows you to delegate methods from your class to the values of your objects' attributes. Conceptually, it allows you to define C<< $object->push_number($n) >> to be a shortcut for C<< $object->numbers->push($n) >> except that C<< $object->numbers >> is an arrayref, so doesn't have methods you can call on it like C. You should be able to use Sub::HandlesVia as a drop-in replacement for L, just replacing C<< traits => ['Array'] >> in an attribute definition with C<< handles_via => 'Array' >>. =head2 Usage in Mouse Roles Mouse roles are only partially supported. package R1 { use Mouse:Role; } package R2 { use Mouse:Role; use Sub::HandlesVia; # define some attributes with delegation } # This class is broken. package C1 { use Mouse; with 'R1', 'R2'; } # This class should work. package C2 { use Mouse; with 'R1'; with 'R2'; } For details, see L. Patches to fix the issue are very welcome! =head2 Which Methods Can Be Delegated To? The C option indicates which library of methods should be available. Valid values include L, L, L, L, L, L, L, L, L, and L. An arrayref can be provided for C, though many of the options are conceptually contradictory. handles_via => [ 'Number', 'Scalar' ] =head2 Mouse Native Types Although the synopsis shows L being used for type constraints, Mouse native types should also work fine. package Kitchen { use Mouse; use Sub::HandlesVia; has food => ( is => 'ro', isa => 'ArrayRef[Str]', handles_via => 'Array', default => sub { [] }, handles => { 'add_food' => 'push', 'find_food' => 'grep', }, ); } =head2 True MouseX::NativeTraits Drop-In Syntax Sub::HandlesVia will also recognize L-style C. It will jump in and handle them before L notices! package Kitchen { use Mouse; use Sub::HandlesVia; has food => ( is => 'ro', isa => 'ArrayRef[Str]', traits => ['Array'], default => sub { [] }, handles => { 'add_food' => 'push', 'find_food' => 'grep', }, ); } =head1 BUGS Please report any bugs to L. =head1 SEE ALSO Misc advanced documentation: L. L. Documentation for delegatable methods: L, L, L, L, L, L, L, L, L, and L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. WithObjectPad.pod000664001750001750 673314772476615 23265 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/Manual=pod =encoding utf-8 =head1 NAME Sub::HandlesVia::Manual::WithObjectPad - using Sub::HandlesVia with Object::Pad =head1 SYNOPSIS use Object::Pad; class Kitchen { field @foods; use Sub::HandlesVia::Declare '@foods', Array => ( all_foods => 'all', add_food => 'push', ); } =head1 MANUAL Sub::HandlesVia allows you to delegate methods from your class to the values of your objects' attributes. Conceptually, it allows you to define C<< $object->push_number($n) >> to be a shortcut for C<< $object->numbers->push($n) >> except that C<< $object->numbers >> is an arrayref, so doesn't have methods you can call on it like C. Experimental L support is provided by Sub::HandlesVia, including for array and hash fields. Object::Pad classes are "sealed" after compile time, preventing new methods from being installed at run-time. (It's actually trivially easy to add them at runtime, but not using the API provided by the Object::Pad MOP, so we don't do that.) This is why L is used, as it creates delegated methods at compile-time. The first argument is the field name, including its sigil. The second argument is the handler library. If the field name begins with a '@' or '%', this is implied to be "Array"/"Hash". use Object::Pad; class Kitchen { field @foods; use Sub::HandlesVia::Declare '@foods', ( all_foods => 'all', add_food => 'push', ); } The third argument is a hash of methods to delegate. =head2 Which Methods Can Be Delegated To? The second parameter ("Array" in the synopsis) indicates which library of methods should be available. Valid values include L, L, L, L, L, L, L, L, L, and L. An arrayref can be provided, though many of the options are conceptually contradictory. use Sub::HandlesVia::Declare 'num', [ 'Number', 'Scalar' ] => ( ..., ); =head1 BUGS Please report any bugs to L. =head1 SEE ALSO Misc advanced documentation: L. L, L. Documentation for delegatable methods: L, L, L, L, L, L, L, L, L, and L. =head1 AUTHOR Toby Inkster Etobyink@cpan.orgE. =head1 COPYRIGHT AND LICENCE This software is copyright (c) 2022 by Toby Inkster. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =head1 DISCLAIMER OF WARRANTIES 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. Mite.pm000664001750001750 1302614772476615 21547 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/Toolkituse 5.008; use strict; use warnings; package Sub::HandlesVia::Toolkit::Mite; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Sub::HandlesVia::Mite -all; extends 'Sub::HandlesVia::Toolkit'; use Types::Standard -types, -is; sub setup_for { my $me = shift; my ($target) = @_; $me->install_has_wrapper($target); } my %SPECS; sub install_has_wrapper { my $me = shift; my ($target) = @_; no strict 'refs'; no warnings 'redefine'; my $orig = \&{ "$target\::has" }; my $uses_mite = ${ "$target\::USES_MITE" }; my $mite_shim = ${ "$target\::MITE_SHIM" }; *{ "$target\::has" } = sub { my ( $names, %spec ) = @_; return $orig->($names, %spec) unless $spec{handles}; # shortcut my @shv; for my $name ( ref($names) ? @$names : $names) { ( my $real_name = $name ) =~ s/^[+]//; my $shv = $me->clean_spec( $target, $real_name, \%spec ); $SPECS{$target}{$real_name} = \%spec; $orig->( $name, %spec ); push @shv, $shv if $shv; } if ( $ENV{MITE_COMPILE} or defined($Mite::COMPILING) && ( $Mite::COMPILING eq $mite_shim )) { return; } if ( $uses_mite eq 'Mite::Role' ) { require Role::Hooks; 'Role::Hooks'->after_apply( $target, sub { my ( $from, $to ) = @_; return if 'Role::Hooks'->is_role( $to ); for my $shv ( @shv ) { $me->install_delegations( { %$shv, target => $to } ); } } ); } else { for my $shv ( @shv ) { $me->install_delegations( $shv ); } } return; }; } my @method_name_generator = ( { # public reader => sub { "get_$_" }, writer => sub { "set_$_" }, accessor => sub { $_ }, lvalue => sub { $_ }, clearer => sub { "clear_$_" }, predicate => sub { "has_$_" }, builder => sub { "_build_$_" }, trigger => sub { "_trigger_$_" }, }, { # private reader => sub { "_get_$_" }, writer => sub { "_set_$_" }, accessor => sub { $_ }, lvalue => sub { $_ }, clearer => sub { "_clear_$_" }, predicate => sub { "_has_$_" }, builder => sub { "_build_$_" }, trigger => sub { "_trigger_$_" }, }, ); sub code_generator_for_attribute { my ( $me, $target, $attrname ) = ( shift, @_ ); my $name = $attrname->[0]; my $spec = $SPECS{$target}{$name}; my $env = {}; my $private = 0+!! ( $name =~ /^_/ ); $spec->{is} ||= bare; if ( $spec->{is} eq lazy ) { $spec->{builder} = 1 unless exists $spec->{builder}; $spec->{is} = ro; } if ( $spec->{is} eq ro ) { $spec->{reader} = '%s' unless exists $spec->{reader}; } if ( $spec->{is} eq rw ) { $spec->{accessor} = '%s' unless exists $spec->{accessor}; } if ( $spec->{is} eq rwp ) { $spec->{reader} = '%s' unless exists $spec->{reader}; $spec->{writer} = '_set_%s' unless exists $spec->{writer}; } for my $property ( 'reader', 'writer', 'accessor', 'builder', 'lvalue' ) { defined( my $methodname = $spec->{$property} ) or next; if ( $methodname eq 1 ) { my $gen = $method_name_generator[$private]{$property}; local $_ = $name; $spec->{$property} = $gen->( $_ ); } $spec->{$property} =~ s/\%s/$name/g; } my ( $get, $set, $get_is_lvalue, $set_checks_isa, $default, $slot ); if ( my $reader = $spec->{reader} || $spec->{accessor} || $spec->{lvalue} ) { $get = sub { shift->generate_self . "->$reader" }; $get_is_lvalue = false; } else { $get = sub { shift->generate_self . "->{q[$name]}" }; $get_is_lvalue = true; } if ( my $writer = $spec->{writer} || $spec->{accessor} ) { $set = sub { my ( $gen, $expr ) = @_; $gen->generate_self . "->$writer($expr)"; }; $set_checks_isa = true; } elsif ( $writer = $spec->{lvalue} ) { $set = sub { my ( $gen, $expr ) = @_; "( " . $gen->generate_self . "->$writer = $expr )"; }; $set_checks_isa = false; } else { $set = sub { my ( $gen, $expr ) = @_; "( " . $gen->generate_self . "->{q[$name]} = $expr )"; }; $set_checks_isa = false; } $slot = sub { shift->generate_self . "->{q[$name]}" }; if ( ref $spec->{builder} ) { $default = $spec->{builder}; $env->{'$shv_default_for_reset'} = \$default; } elsif ( $spec->{builder} ) { $default = $spec->{builder}; } elsif ( ref $spec->{default} ) { $default = $spec->{default}; $env->{'$shv_default_for_reset'} = \$default; } elsif ( exists $spec->{default} ) { my $value = $spec->{default}; $default = sub { $value }; $env->{'$shv_default_for_reset'} = \$default; } require Sub::HandlesVia::CodeGenerator; return 'Sub::HandlesVia::CodeGenerator'->new( toolkit => $me, target => $target, attribute => $name, env => $env, isa => $spec->{type}, coerce => $spec->{coerce}, generator_for_get => $get, generator_for_set => $set, get_is_lvalue => $get_is_lvalue, set_checks_isa => $set_checks_isa, set_strictly => true, generator_for_default => sub { my ( $gen, $handler ) = @_ or die; if ( !$default and $handler ) { return $handler->default_for_reset->(); } elsif ( is_CodeRef $default ) { return sprintf( '(%s)->$shv_default_for_reset', $gen->generate_self, ); } elsif ( is_Str $default ) { require B; return sprintf( '(%s)->${\ %s }', $gen->generate_self, B::perlstring( $default ), ); } elsif ( is_ScalarRef $default ) { return $$default; } elsif ( is_HashRef $default ) { return '{}'; } elsif ( is_ArrayRef $default ) { return '[]'; } return; }, ( $slot ? ( generator_for_slot => $slot ) : () ), ); } 1; Mite.pm.mite.pm000664001750001750 526514772476615 23105 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/Toolkit{ package Sub::HandlesVia::Toolkit::Mite; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Class"; our $MITE_SHIM = "Sub::HandlesVia::Mite"; our $MITE_VERSION = "0.013000"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "Sub::HandlesVia::Mite", "Sub::HandlesVia::Toolkit::Mite" ); ( *after, *around, *before, *extends, *field, *has, *param, *signature_for, *with ) = do { package Sub::HandlesVia::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "class", @_ ) }, sub { }, sub { $SHIM->HANDLE_has( $CALLER, field => @_ ) }, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub { $SHIM->HANDLE_has( $CALLER, param => @_ ) }, sub { $SHIM->HANDLE_signature_for( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; } # Mite imports BEGIN { require Scalar::Util; *STRICT = \&Sub::HandlesVia::Mite::STRICT; *bare = \&Sub::HandlesVia::Mite::bare; *blessed = \&Scalar::Util::blessed; *carp = \&Sub::HandlesVia::Mite::carp; *confess = \&Sub::HandlesVia::Mite::confess; *croak = \&Sub::HandlesVia::Mite::croak; *false = \&Sub::HandlesVia::Mite::false; *guard = \&Sub::HandlesVia::Mite::guard; *lazy = \&Sub::HandlesVia::Mite::lazy; *lock = \&Sub::HandlesVia::Mite::lock; *ro = \&Sub::HandlesVia::Mite::ro; *rw = \&Sub::HandlesVia::Mite::rw; *rwp = \&Sub::HandlesVia::Mite::rwp; *true = \&Sub::HandlesVia::Mite::true; *unlock = \&Sub::HandlesVia::Mite::unlock; } BEGIN { require Sub::HandlesVia::Toolkit; use mro 'c3'; our @ISA; push @ISA, "Sub::HandlesVia::Toolkit"; } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can('does_role') and $meta->does_role($role) and return 1; } return $self->SUPER::DOES($role); } # Alias for Moose/Moo-compatibility sub does { shift->DOES(@_); } 1; } Moo.pm000664001750001750 2407114772476615 21405 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/Toolkituse 5.008; use strict; use warnings; package Sub::HandlesVia::Toolkit::Moo; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Sub::HandlesVia::Mite; extends 'Sub::HandlesVia::Toolkit'; use Types::Standard qw( is_ArrayRef is_Str assert_HashRef is_CodeRef is_Undef ); use Types::Standard qw( ArrayRef HashRef Str Num Int CodeRef Bool ); sub setup_for { my $me = shift; my ($target) = @_; $me->install_has_wrapper($target); } sub install_has_wrapper { my $me = shift; my ($target) = @_; my ($installer, $orig); if ($INC{'Moo/Role.pm'} && 'Moo::Role'->is_role($target)) { $installer = 'Moo::Role::_install_tracked'; $orig = $Moo::Role::INFO{$target}{exports}{has}; } else { require Moo; $installer = 'Moo::_install_tracked'; $orig = $Moo::MAKERS{$target}{exports}{has} || $Moo::MAKERS{$target}{non_methods}{has}; } $orig ||= $target->can('has'); ref($orig) or croak("$target doesn't have a `has` function"); $target->$installer(has => sub { if (@_ % 2 == 0) { require Carp; Carp::croak("Invalid options for attribute(s): even number of arguments expected, got " . scalar @_); } my ($attrs, %spec) = @_; return $orig->($attrs, %spec) unless $spec{handles}; # shortcut for my $attr ( ref($attrs) ? @$attrs : $attrs ) { ( my $real_attr = $attr ) =~ s/^[+]//; my $shv = $me->clean_spec($target, $real_attr, \%spec); $orig->($attr, %spec); $me->install_delegations($shv) if $shv; } return; }); } sub code_generator_for_attribute { my ($me, $target, $attrname) = (shift, @_); if (ref $attrname) { @$attrname==1 or die; ($attrname) = @$attrname; } my $ctor_maker = $INC{'Moo.pm'} && 'Moo'->_constructor_maker_for($target); if (!$ctor_maker) { return $me->_code_generator_for_role_attribute($target, $attrname); } my $spec = $ctor_maker->all_attribute_specs->{$attrname}; my $maker = 'Moo'->_accessor_maker_for($target); my $type = $spec->{isa} ? Types::TypeTiny::to_TypeTiny($spec->{isa}) : undef; my $coerce = exists($spec->{coerce}) ? $spec->{coerce} : 0; if ((ref($coerce)||'') eq 'CODE') { $type = $type->plus_coercions(Types::Standard::Any(), $coerce); $coerce = 1; } my $slot = sub { my $gen = shift; my ($code) = $maker->generate_simple_get($gen->generate_self, $attrname, $spec); $code; }; my $captures = {}; my ($is_simple_get, $get) = $maker->is_simple_get($attrname, $spec) ? (1, sub { my $gen = shift; my $selfvar = $gen ? $gen->generate_self : '$_[0]'; my ($return) = $maker->generate_simple_get($selfvar, $attrname, $spec); %$captures = ( %$captures, %{ delete($maker->{captures}) or {} } ); $return; }) : (0, sub { my $gen = shift; my $selfvar = $gen ? $gen->generate_self : '$_[0]'; my ($return) = $maker->_generate_use_default( $selfvar, $attrname, $spec, $maker->_generate_simple_has($selfvar, $attrname, $spec), ); %$captures = ( %$captures, %{ delete($maker->{captures}) or {} } ); $return; }); my ($is_simple_set, $set) = $maker->is_simple_set($attrname, $spec) ? (1, sub { my ($gen, $var) = @_; my $selfvar = $gen ? $gen->generate_self : '$_[0]'; my $code = $maker->_generate_simple_set($selfvar, $attrname, $spec, $var); $captures = { %$captures, %{ delete($maker->{captures}) or {} } }; # merge environments $code; }) : (0, sub { # that allows us to avoid going down this yucky code path my ($gen, $var) = @_; my $selfvar = $gen ? $gen->generate_self : '$_[0]'; my $code = $maker->_generate_set($attrname, $spec); $captures = { %$captures, %{ delete($maker->{captures}) or {} } }; # merge environments $code = "do { local \@_ = ($selfvar, $var); $code }"; $code; }); # force $captures to be updated $get->(undef, '$dummy'); $set->(undef, '$dummy'); my $default; if (exists $spec->{default}) { $default = [ default => $spec->{default} ]; } elsif (exists $spec->{builder}) { $default = [ builder => $spec->{builder} ]; } if (is_CodeRef $default->[1]) { $captures->{'$shv_default_for_reset'} = \$default->[1]; } require Sub::HandlesVia::CodeGenerator; return 'Sub::HandlesVia::CodeGenerator'->new( toolkit => $me, target => $target, attribute => $attrname, attribute_spec => $spec, env => $captures, isa => $type, coerce => !!$coerce, generator_for_slot => $slot, generator_for_get => $get, generator_for_set => $set, get_is_lvalue => $is_simple_get, set_checks_isa => !$is_simple_set, set_strictly => $spec->{weak_ref} || $spec->{trigger}, generator_for_default => sub { my ( $gen, $handler ) = @_ or die; if ( !$default and $handler ) { return $handler->default_for_reset->(); } elsif ( $default->[0] eq 'builder' ) { return sprintf( '(%s)->%s', $gen->generate_self, $default->[1], ); } elsif ( $default->[0] eq 'default' and is_CodeRef $default->[1] ) { return sprintf( '(%s)->$shv_default_for_reset', $gen->generate_self, ); } elsif ( $default->[0] eq 'default' and is_Undef $default->[1] ) { return 'undef'; } elsif ( $default->[0] eq 'default' and is_Str $default->[1] ) { require B; return B::perlstring( $default->[1] ); } return; }, ); } sub _code_generator_for_role_attribute { my ($me, $target, $attrname) = (shift, @_); if (ref $attrname) { @$attrname==1 or die; ($attrname) = @$attrname; } require B; my %all_specs = @{ $Moo::Role::INFO{$target}{attributes} }; my $spec = $all_specs{$attrname}; my ($reader_name, $writer_name); if ($spec->{is} eq 'ro') { $reader_name = $attrname; } elsif ($spec->{is} eq 'rw') { $reader_name = $attrname; $writer_name = $attrname; } elsif ($spec->{is} eq 'rwp') { $reader_name = $attrname; $writer_name = "_set_$attrname"; } if (exists $spec->{reader}) { $reader_name = $spec->{reader}; } if (exists $spec->{writer}) { $writer_name = $spec->{reader}; } if (exists $spec->{accessor}) { $reader_name = $spec->{accessor} unless defined $reader_name; $writer_name = $spec->{accessor} unless defined $writer_name; } my $type = $spec->{isa} ? Types::TypeTiny::to_TypeTiny($spec->{isa}) : undef; my $coerce = $spec->{coerce}; if ((ref($coerce)||'') eq 'CODE') { $type = $type->plus_coercions(Types::Standard::Any(), $coerce); $coerce = 1; } my $captures = {}; my ($get, $set); if (defined $reader_name) { $get = ($reader_name =~ /^[\W0-9]\w*$/s) ? sub { my $gen = shift; sprintf "%s->%s", $gen->generate_self, $reader_name } : sub { my $gen = shift; sprintf "%s->\${\\ %s }", $gen->generate_self, B::perlstring($reader_name) }; } else { my ($default, $default_literal) = (undef, 0); if (is_Coderef $spec->{default}) { $default = $spec->{default}; } elsif (exists $spec->{default}) { ++$default_literal; $default = $spec->{default}; } elsif (is_CodeRef $spec->{builder} or (($spec->{builder}||0) eq 1)) { $default = '_build_'.$attrname; } elsif ($spec->{builder}) { $default = $spec->{builder}; } else { ++$default_literal; } my $dammit_i_need_to_build_a_reader = sub { my $instance = shift; exists($instance->{$attrname}) or do { $instance->{$attrname} ||= $default_literal ? $default : $instance->$default; }; $instance->{$attrname}; }; $captures->{'$shv_reader'} = \$dammit_i_need_to_build_a_reader; $get = sub { my $gen = shift; $gen->generate_self . '->$shv_reader()' }; } if (defined $writer_name) { $set = $writer_name =~ /^[\W0-9]\w*$/s ? sub { my ($gen, $val) = @_; sprintf "%s->%s(%s)", $gen->generate_self, $writer_name, $val } : sub { my ($gen, $val) = @_; sprintf "%s->\${\\ %s }(%s)", $gen->generate_self, B::perlstring($writer_name), $val }; } else { my $trigger; if (($spec->{trigger}||0) eq 1) { $trigger = "_trigger_$attrname"; } my $weaken = $spec->{weak_ref} || 0; my $dammit_i_need_to_build_a_writer = sub { my ($instance, $new_value) = (shift, @_); if ($type) { ($type->has_coercion && $coerce) ? ($new_value = $type->assert_coerce($new_value)) : $type->assert_valid($new_value); } if ($trigger) { $instance->$trigger($new_value, exists($instance->{$attrname}) ? $instance->{$attrname} : ()) } $instance->{$attrname} = $new_value; if ($weaken and ref $new_value) { Scalar::Util::weaken($instance->{$attrname}); } $instance->{$attrname}; }; $captures->{'$shv_writer'} = \$dammit_i_need_to_build_a_writer; $set = sub { my ($gen, $val) = @_; $gen->generate_self . "->\$shv_writer($val)" }; } my $default; if (exists $spec->{default}) { $default = [ default => $spec->{default} ]; } elsif (exists $spec->{builder}) { $default = [ builder => $spec->{builder} ]; } if (is_CodeRef $default->[1]) { $captures->{'$shv_default_for_reset'} = \$default->[1]; } require Sub::HandlesVia::CodeGenerator; return 'Sub::HandlesVia::CodeGenerator'->new( toolkit => $me, target => $target, attribute => $attrname, attribute_spec => $spec, env => $captures, isa => $type, coerce => !!$coerce, generator_for_slot => sub { shift->generate_self.'->{'.B::perlstring($attrname).'}' }, # icky generator_for_get => $get, generator_for_set => $set, get_is_lvalue => !!0, set_checks_isa => !!1, set_strictly => !!0, generator_for_default => sub { my ( $gen, $handler ) = @_ or die; if ( !$default and $handler ) { return $handler->default_for_reset->(); } elsif ( $default->[0] eq 'builder' ) { return sprintf( '(%s)->%s', $gen->generate_self, $default->[1], ); } elsif ( $default->[0] eq 'default' and is_CodeRef $default->[1] ) { return sprintf( '(%s)->$shv_default_for_reset', $gen->generate_self, ); } elsif ( $default->[0] eq 'default' and is_Undef $default->[1] ) { return 'undef'; } elsif ( $default->[0] eq 'default' and is_Str $default->[1] ) { require B; return B::perlstring( $default->[1] ); } return; }, ); } 1; Moo.pm.mite.pm000664001750001750 327614772476615 22741 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/Toolkit{ package Sub::HandlesVia::Toolkit::Moo; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Class"; our $MITE_SHIM = "Sub::HandlesVia::Mite"; our $MITE_VERSION = "0.013000"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "Sub::HandlesVia::Mite", "Sub::HandlesVia::Toolkit::Moo" ); ( *after, *around, *before, *extends, *has, *signature_for, *with ) = do { package Sub::HandlesVia::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "class", @_ ) }, sub { }, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub { $SHIM->HANDLE_signature_for( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; } BEGIN { require Sub::HandlesVia::Toolkit; use mro 'c3'; our @ISA; push @ISA, "Sub::HandlesVia::Toolkit"; } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can('does_role') and $meta->does_role($role) and return 1; } return $self->SUPER::DOES($role); } # Alias for Moose/Moo-compatibility sub does { shift->DOES(@_); } 1; } Moose.pm000664001750001750 1330314772476615 21731 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/Toolkituse 5.008; use strict; use warnings; package Sub::HandlesVia::Toolkit::Moose; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Sub::HandlesVia::Mite; extends 'Sub::HandlesVia::Toolkit'; sub setup_for { my $me = shift; my ($target) = @_; require Moose::Util; my $meta = Moose::Util::find_meta($target); $me->meta_hack( $meta ); } sub meta_hack { my ( $me, $meta ) = ( shift, @_ ); require Moose::Util::MetaRole; if ( $meta->isa('Moose::Meta::Role') ) { return Moose::Util::MetaRole::apply_metaroles( for => $meta, role_metaroles => { role => [ $me->package_trait, $me->role_trait ] }, ); } else { return Moose::Util::MetaRole::apply_metaroles( for => $meta, class_metaroles => { class => [ $me->package_trait ] }, ); } } sub package_trait { __PACKAGE__ . "::PackageTrait"; } sub role_trait { __PACKAGE__ . "::RoleTrait"; } sub code_generator_for_attribute { my ($me, $target, $attrname) = (shift, @_); if (ref $attrname) { @$attrname==1 or die; ($attrname) = @$attrname; } my $meta; if (ref $target) { $meta = $target; $target = $meta->name; } else { require Moose::Util; $meta = Moose::Util::find_meta($target); } my $attr = $meta->get_attribute($attrname); my $spec = +{%$attr}; my $captures = {}; my $slot = sub { my $gen = shift; $meta->get_meta_instance->inline_slot_access($gen->generate_self, $attrname); }; my ($get, $set, $get_is_lvalue, $set_checks_isa); if (!$spec->{lazy} and !$spec->{traits} and !$spec->{auto_deref}) { $get = $slot; ++$get_is_lvalue; } elsif ($attr->has_read_method) { my $read_method = $attr->get_read_method; $get = sub { my $self = shift->generate_self; "scalar($self\->$read_method)" }; } else { my $read_method = $attr->get_read_method_ref; eval { $read_method = $read_method->{body} }; # Moose docs lie! $captures->{'$shv_read_method'} = \$read_method; $get = sub { my $self = shift->generate_self; "scalar($self\->\$shv_read_method)" }; } if ($attr->has_write_method) { my $write_method = $attr->get_write_method; $set = sub { my ($gen, $val) = @_; my $self = $gen->generate_self; "$self\->$write_method\($val)" }; ++$set_checks_isa; } else { $captures->{'$shv_write_method'} = \( $attr->can('set_value') ? sub { $attr->set_value(@_) } : sub { my ($instance, $value) = @_; $instance->meta->get_attribute($attrname)->set_value($instance, $value) } ); $set = sub { my ($gen, $val) = @_; my $self = $gen->generate_self; $self.'->$shv_write_method('.$val.')'; }; ++$set_checks_isa; } my $default; if (exists $spec->{default}) { $default = [ default => $spec->{default} ]; } elsif (exists $spec->{builder}) { $default = [ builder => $spec->{builder} ]; } if (ref $default->[1] eq 'CODE') { $captures->{'$shv_default_for_reset'} = \$default->[1]; } require Sub::HandlesVia::CodeGenerator; return 'Sub::HandlesVia::CodeGenerator'->new( toolkit => $me, target => $target, attribute => $attrname, attribute_spec => $spec, env => $captures, isa => Types::TypeTiny::to_TypeTiny($attr->type_constraint), coerce => !!$spec->{coerce}, generator_for_slot => $slot, generator_for_get => $get, generator_for_set => $set, get_is_lvalue => $get_is_lvalue, set_checks_isa => $set_checks_isa, set_strictly => !!1, method_installer => sub { $meta->add_method(@_) }, generator_for_default => sub { my ( $gen, $handler ) = @_ or die; if ( !$default and $handler ) { return $handler->default_for_reset->(); } elsif ( $default->[0] eq 'builder' ) { return sprintf( '(%s)->%s', $gen->generate_self, $default->[1], ); } elsif ( $default->[0] eq 'default' and ref $default->[1] eq 'CODE' ) { return sprintf( '(%s)->$shv_default_for_reset', $gen->generate_self, ); } elsif ( $default->[0] eq 'default' and !defined $default->[1] ) { return 'undef'; } elsif ( $default->[0] eq 'default' and !ref $default->[1] ) { require B; return B::perlstring( $default->[1] ); } return; }, ); } package Sub::HandlesVia::Toolkit::Moose::PackageTrait; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Moose::Role; sub _shv_toolkit { 'Sub::HandlesVia::Toolkit::Moose', } around add_attribute => sub { my ($next, $self, @args) = (shift, shift, @_); my ($spec, $attrobj, $attrname); if (@args == 1) { $spec = $attrobj = $_[0]; $attrname = $attrobj->name; } elsif (@args == 2) { ($attrname, $spec) = @args; } else { my %spec; ($attrname, %spec) = @args; $spec = \%spec; } ( my $real_attrname = $attrname ) =~ s/^[+]//; $spec->{definition_context}{shv} = $self->_shv_toolkit->clean_spec($self->name, $real_attrname, $spec) unless $spec->{definition_context}{shv}; my $attr = $self->$next($attrobj ? $attrobj : ($attrname, %$spec)); if ($spec->{definition_context}{shv} and $self->isa('Moose::Meta::Class')) { $self->_shv_toolkit->install_delegations(+{ %{ $spec->{definition_context}{shv} }, target => $self->name, }); } return $attr; }; package Sub::HandlesVia::Toolkit::Moose::RoleTrait; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Moose::Role; requires '_shv_toolkit'; around apply => sub { my ($next, $self, $other, %args) = (shift, shift, @_); $other = $self->_shv_toolkit->meta_hack( $other ); $self->$next( $other, %args ); }; around composition_class_roles => sub { my ( $next, $self ) = ( shift, shift ); my @return = $self->$next( @_ ); return ( @return, $self->_shv_toolkit->package_trait, $self->_shv_toolkit->role_trait, ); }; 1; Moose.pm.mite.pm000664001750001750 330214772476615 23257 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/Toolkit{ package Sub::HandlesVia::Toolkit::Moose; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Class"; our $MITE_SHIM = "Sub::HandlesVia::Mite"; our $MITE_VERSION = "0.013000"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "Sub::HandlesVia::Mite", "Sub::HandlesVia::Toolkit::Moose" ); ( *after, *around, *before, *extends, *has, *signature_for, *with ) = do { package Sub::HandlesVia::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "class", @_ ) }, sub { }, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub { $SHIM->HANDLE_signature_for( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; } BEGIN { require Sub::HandlesVia::Toolkit; use mro 'c3'; our @ISA; push @ISA, "Sub::HandlesVia::Toolkit"; } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can('does_role') and $meta->does_role($role) and return 1; } return $self->SUPER::DOES($role); } # Alias for Moose/Moo-compatibility sub does { shift->DOES(@_); } 1; } Mouse.pm000664001750001750 1346514772476615 21750 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/Toolkituse 5.008; use strict; use warnings; package Sub::HandlesVia::Toolkit::Mouse; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Sub::HandlesVia::Mite; extends 'Sub::HandlesVia::Toolkit'; sub setup_for { my $me = shift; my ($target) = @_; require Mouse::Util; my $meta = Mouse::Util::find_meta($target); $me->meta_hack( $meta ); } sub meta_hack { my ( $me, $meta ) = ( shift, @_ ); require Mouse::Util::MetaRole; if ( $meta->isa('Mouse::Meta::Role') ) { return Mouse::Util::MetaRole::apply_metaroles( for => $meta, role_metaroles => { role => [ $me->package_trait, $me->role_trait ] }, ); } else { return Mouse::Util::MetaRole::apply_metaroles( for => $meta, class_metaroles => { class => [ $me->package_trait ] }, ); } } sub package_trait { __PACKAGE__ . "::PackageTrait"; } sub role_trait { __PACKAGE__ . "::RoleTrait"; } sub code_generator_for_attribute { my ($me, $target, $attrname) = (shift, @_); if (ref $attrname) { @$attrname==1 or die; ($attrname) = @$attrname; } my $meta; if (ref $target) { $meta = $target; $target = $meta->name; } else { require Mouse::Util; $meta = Mouse::Util::find_meta($target); } my $attr = $meta->get_attribute($attrname); my $spec = +{%$attr}; my $captures = {}; my ($get, $set, $get_is_lvalue, $set_checks_isa); if (!$spec->{lazy} and !$spec->{traits} and !$spec->{auto_deref}) { require B; my $slot = B::perlstring($attrname); $get = sub { my $self = shift->generate_self; "$self\->{$slot}"; }; ++$get_is_lvalue; } elsif ($attr->has_read_method) { my $read_method = $attr->reader || $attr->accessor; $get = sub { my $self = shift->generate_self; "scalar($self\->$read_method)"; }; } else { my $read_method = $attr->get_read_method_ref; $captures->{'$shv_read_method'} = \$read_method; $get = sub { my $self = shift->generate_self; "scalar($self\->\$shv_read_method)"; }; } if ($attr->has_write_method) { my $write_method = $attr->writer || $attr->accessor; $set = sub { my ($gen, $val) = @_; $gen->generate_self . "->$write_method\($val)" }; ++$set_checks_isa; } else { my $write_method = $attr->get_write_method_ref; $captures->{'$shv_write_method'} = \$write_method; $set = sub { my ($gen, $val) = @_; $gen->generate_self . '->$shv_write_method('.$val.')'; }; ++$set_checks_isa; } my $default; if (exists $spec->{default}) { $default = [ default => $spec->{default} ]; } elsif (exists $spec->{builder}) { $default = [ builder => $spec->{builder} ]; } if (ref $default->[1] eq 'CODE') { $captures->{'$shv_default_for_reset'} = \$default->[1]; } require Sub::HandlesVia::CodeGenerator; return 'Sub::HandlesVia::CodeGenerator'->new( toolkit => $me, target => $target, attribute => $attrname, attribute_spec => $spec, env => $captures, isa => Types::TypeTiny::to_TypeTiny($attr->type_constraint), coerce => !!$spec->{coerce}, generator_for_slot => sub { shift->generate_self.'->{'.B::perlstring($attrname).'}' }, # icky generator_for_get => $get, generator_for_set => $set, get_is_lvalue => $get_is_lvalue, set_checks_isa => $set_checks_isa, set_strictly => !!0, method_installer => sub { $meta->add_method(@_) }, generator_for_default => sub { my ( $gen, $handler ) = @_ or die; if ( !$default and $handler ) { return $handler->default_for_reset->(); } elsif ( $default->[0] eq 'builder' ) { return sprintf( '(%s)->%s', $gen->generate_self, $default->[1], ); } elsif ( $default->[0] eq 'default' and ref $default->[1] eq 'CODE' ) { return sprintf( '(%s)->$shv_default_for_reset', $gen->generate_self, ); } elsif ( $default->[0] eq 'default' and !defined $default->[1] ) { return 'undef'; } elsif ( $default->[0] eq 'default' and !ref $default->[1] ) { require B; return B::perlstring( $default->[1] ); } return; }, ); } package Sub::HandlesVia::Toolkit::Mouse::PackageTrait; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Mouse::Role; sub _shv_toolkit { 'Sub::HandlesVia::Toolkit::Mouse', } around add_attribute => sub { my ($next, $self, @args) = (shift, shift, @_); my ($spec, $attrobj, $attrname); if (@args == 1) { $spec = $attrobj = $_[0]; $attrname = $attrobj->name; } elsif (@args == 2) { ($attrname, $spec) = @args; } else { my %spec; ($attrname, %spec) = @args; $spec = \%spec; } ( my $real_attrname = $attrname ) =~ s/^[+]//; $spec->{provides}{shv} = $self->_shv_toolkit->clean_spec($self->name, $real_attrname, $spec) unless $spec->{provides}{shv}; my $attr = $self->$next($attrobj ? $attrobj : ($attrname, %$spec)); if ($spec->{provides}{shv} and $self->isa('Mouse::Meta::Class')) { $self->_shv_toolkit->install_delegations(+{ %{ $spec->{provides}{shv} }, target => $self->name, }); } return $attr; }; package Sub::HandlesVia::Toolkit::Mouse::RoleTrait; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Mouse::Role; requires '_shv_toolkit'; around apply => sub { my ($next, $self, $other, %args) = (shift, shift, @_); $other = $self->_shv_toolkit->meta_hack( $other ); $self->$next( $other, %args ); }; # This is a horrible hack. do { no warnings 'redefine'; require Mouse::Meta::Role; require Scalar::Util; my $next = \&Mouse::Meta::Role::combine; *Mouse::Meta::Role::combine = sub { my ( $class, @roles ) = ( shift, @_ ); my $combined = $class->$next( @roles ); my ($hack) = map { ( ref $_ and blessed $_->[0] and $_->[0]->can( '_shv_toolkit' ) ) ? $_->[0]->_shv_toolkit : (); } @roles; if ($hack) { $combined = $hack->meta_hack( $combined ); } return $combined; }; }; 1; Mouse.pm.mite.pm000664001750001750 330214772476615 23265 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/Toolkit{ package Sub::HandlesVia::Toolkit::Mouse; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Class"; our $MITE_SHIM = "Sub::HandlesVia::Mite"; our $MITE_VERSION = "0.013000"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "Sub::HandlesVia::Mite", "Sub::HandlesVia::Toolkit::Mouse" ); ( *after, *around, *before, *extends, *has, *signature_for, *with ) = do { package Sub::HandlesVia::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "class", @_ ) }, sub { }, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub { $SHIM->HANDLE_signature_for( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; } BEGIN { require Sub::HandlesVia::Toolkit; use mro 'c3'; our @ISA; push @ISA, "Sub::HandlesVia::Toolkit"; } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can('does_role') and $meta->does_role($role) and return 1; } return $self->SUPER::DOES($role); } # Alias for Moose/Moo-compatibility sub does { shift->DOES(@_); } 1; } ObjectPad.pm000664001750001750 601014772476615 22457 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/Toolkituse 5.008; use strict; use warnings; package Sub::HandlesVia::Toolkit::ObjectPad; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Sub::HandlesVia::Mite -all; extends 'Sub::HandlesVia::Toolkit'; around code_generator_for_attribute => sub { my ( $next, $me, $target, $attr ) = ( shift, shift, @_ ); if ( @$attr > 1 or $attr->[0] =~ /^\w/ ) { return $me->$next( @_ ); } my $attrname = $attr->[0]; use Object::Pad qw( :experimental(mop) ); use Object::Pad::MetaFunctions (); my $metaclass = Object::Pad::MOP::Class->for_class($target); my $metafield = $metaclass->get_field( $attrname ); my ( $get, $set, $slot, $get_is_lvalue ); if ( $attrname =~ /^\$/ ) { $get = sub { my ( $gen ) = ( shift ); sprintf( '$metafield->value(%s)', $gen->generate_self ); }; $set = sub { my ( $gen, $value ) = ( shift, @_ ); sprintf( '( $metafield->value(%s) = %s )', $gen->generate_self, $value ); }; $slot = sub { my ( $gen, $value ) = ( shift, @_ ); sprintf( '${ Object::Pad::MetaFunctions::ref_field(%s, %s) }', B::perlstring($attrname), $gen->generate_self ); }; $get_is_lvalue = false; } elsif ( $attrname =~ /^\@/ ) { $get = sub { my ( $gen ) = ( shift ); sprintf( 'Object::Pad::MetaFunctions::ref_field(%s, %s)', B::perlstring($attrname), $gen->generate_self ); }; $set = sub { my ( $gen, $value ) = ( shift, @_ ); sprintf( '( @{Object::Pad::MetaFunctions::ref_field(%s, %s)} = @{%s} )', B::perlstring($attrname), $gen->generate_self, $value ); }; $slot = sub { my ( $gen, $value ) = ( shift, @_ ); sprintf( 'Object::Pad::MetaFunctions::ref_field(%s, %s)', B::perlstring($attrname), $gen->generate_self ); }; $get_is_lvalue = true; } elsif ( $attrname =~ /^\%/ ) { $get = sub { my ( $gen ) = ( shift ); sprintf( 'Object::Pad::MetaFunctions::ref_field(%s, %s)', B::perlstring($attrname), $gen->generate_self ); }; $set = sub { my ( $gen, $value ) = ( shift, @_ ); sprintf( '( %%{Object::Pad::MetaFunctions::ref_field(%s, %s)} = %%{%s} )', B::perlstring($attrname), $gen->generate_self, $value ); }; $slot = sub { my ( $gen, $value ) = ( shift, @_ ); sprintf( 'Object::Pad::MetaFunctions::ref_field(%s, %s)', B::perlstring($attrname), $gen->generate_self ); }; $get_is_lvalue = true; } else { croak 'Unexpected name for Object::Pad attribute: %s', $attr; } require Sub::HandlesVia::CodeGenerator; return 'Sub::HandlesVia::CodeGenerator'->new( toolkit => $me, target => $target, attribute => $attrname, env => { '$metafield' => \$metafield }, method_installer => sub { $metaclass->add_method( @_ ) }, # compile-time! coerce => false, generator_for_get => $get, generator_for_set => $set, generator_for_slot => $slot, get_is_lvalue => $get_is_lvalue, set_checks_isa => true, set_strictly => false, generator_for_default => sub { my ( $gen, $handler ) = @_ or die; return; }, ); }; 1; ObjectPad.pm.mite.pm000664001750001750 527714772476615 24045 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/Toolkit{ package Sub::HandlesVia::Toolkit::ObjectPad; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Class"; our $MITE_SHIM = "Sub::HandlesVia::Mite"; our $MITE_VERSION = "0.013000"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "Sub::HandlesVia::Mite", "Sub::HandlesVia::Toolkit::ObjectPad" ); ( *after, *around, *before, *extends, *field, *has, *param, *signature_for, *with ) = do { package Sub::HandlesVia::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "class", @_ ) }, sub { }, sub { $SHIM->HANDLE_has( $CALLER, field => @_ ) }, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub { $SHIM->HANDLE_has( $CALLER, param => @_ ) }, sub { $SHIM->HANDLE_signature_for( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; } # Mite imports BEGIN { require Scalar::Util; *STRICT = \&Sub::HandlesVia::Mite::STRICT; *bare = \&Sub::HandlesVia::Mite::bare; *blessed = \&Scalar::Util::blessed; *carp = \&Sub::HandlesVia::Mite::carp; *confess = \&Sub::HandlesVia::Mite::confess; *croak = \&Sub::HandlesVia::Mite::croak; *false = \&Sub::HandlesVia::Mite::false; *guard = \&Sub::HandlesVia::Mite::guard; *lazy = \&Sub::HandlesVia::Mite::lazy; *lock = \&Sub::HandlesVia::Mite::lock; *ro = \&Sub::HandlesVia::Mite::ro; *rw = \&Sub::HandlesVia::Mite::rw; *rwp = \&Sub::HandlesVia::Mite::rwp; *true = \&Sub::HandlesVia::Mite::true; *unlock = \&Sub::HandlesVia::Mite::unlock; } BEGIN { require Sub::HandlesVia::Toolkit; use mro 'c3'; our @ISA; push @ISA, "Sub::HandlesVia::Toolkit"; } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can('does_role') and $meta->does_role($role) and return 1; } return $self->SUPER::DOES($role); } # Alias for Moose/Moo-compatibility sub does { shift->DOES(@_); } 1; } Plain.pm000664001750001750 32314772476615 21650 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/Toolkituse 5.008; use strict; use warnings; package Sub::HandlesVia::Toolkit::Plain; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.050002'; use Sub::HandlesVia::Mite; extends 'Sub::HandlesVia::Toolkit'; 1; Plain.pm.mite.pm000664001750001750 330214772476615 23240 0ustar00taitai000000000000Sub-HandlesVia-0.050002/lib/Sub/HandlesVia/Toolkit{ package Sub::HandlesVia::Toolkit::Plain; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Class"; our $MITE_SHIM = "Sub::HandlesVia::Mite"; our $MITE_VERSION = "0.013000"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "Sub::HandlesVia::Mite", "Sub::HandlesVia::Toolkit::Plain" ); ( *after, *around, *before, *extends, *has, *signature_for, *with ) = do { package Sub::HandlesVia::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "class", @_ ) }, sub { }, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub { $SHIM->HANDLE_signature_for( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; } BEGIN { require Sub::HandlesVia::Toolkit; use mro 'c3'; our @ISA; push @ISA, "Sub::HandlesVia::Toolkit"; } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can('does_role') and $meta->does_role($role) and return 1; } return $self->SUPER::DOES($role); } # Alias for Moose/Moo-compatibility sub does { shift->DOES(@_); } 1; } Class1.pm000664001750001750 10514772476615 20327 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTestpackage MyTest::Class1; use MyTest::Mite; with 'MyTest::Role2'; 1; Class1.pm.mite.pm000664001750001750 1040314772476615 21741 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTest{ package MyTest::Class1; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Class"; our $MITE_SHIM = "MyTest::Mite"; our $MITE_VERSION = "0.010008"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "MyTest::Mite", "MyTest::Class1" ); ( *after, *around, *before, *extends, *has, *signature_for, *with ) = do { package MyTest::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "class", @_ ) }, sub {}, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub { $SHIM->HANDLE_signature_for( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; }; # Gather metadata for constructor and destructor sub __META__ { no strict 'refs'; my $class = shift; $class = ref($class) || $class; my $linear_isa = mro::get_linear_isa( $class ); return { BUILD => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::BUILD" } reverse @$linear_isa ], DEMOLISH => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::DEMOLISH" } @$linear_isa ], HAS_BUILDARGS => $class->can('BUILDARGS'), HAS_FOREIGNBUILDARGS => $class->can('FOREIGNBUILDARGS'), }; } # Standard Moose/Moo-style constructor sub new { my $class = ref($_[0]) ? ref(shift) : shift; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $self = bless {}, $class; my $args = $meta->{HAS_BUILDARGS} ? $class->BUILDARGS( @_ ) : { ( @_ == 1 ) ? %{$_[0]} : @_ }; my $no_build = delete $args->{__no_BUILD__}; # Attribute list (type: ArrayRef) # has declaration, file lib/MyTest/Role1.pm, line 42 do { my $value = exists( $args->{"list"} ) ? $args->{"list"} : $MyTest::Role1::__list_DEFAULT__->( $self ); (ref($value) eq 'ARRAY') or MyTest::Mite::croak "Type check failed in constructor: %s should be %s", "list", "ArrayRef"; $self->{"list"} = $value; }; # Call BUILD methods $self->BUILDALL( $args ) if ( ! $no_build and @{ $meta->{BUILD} || [] } ); # Unrecognized parameters my @unknown = grep not( /\Alist\z/ ), keys %{$args}; @unknown and MyTest::Mite::croak( "Unexpected keys in constructor: " . join( q[, ], sort @unknown ) ); return $self; } # Used by constructor to call BUILD methods sub BUILDALL { my $class = ref( $_[0] ); my $meta = ( $Mite::META{$class} ||= $class->__META__ ); $_->( @_ ) for @{ $meta->{BUILD} || [] }; } # Destructor should call DEMOLISH methods sub DESTROY { my $self = shift; my $class = ref( $self ) || $self; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $in_global_destruction = defined ${^GLOBAL_PHASE} ? ${^GLOBAL_PHASE} eq 'DESTRUCT' : Devel::GlobalDestruction::in_global_destruction(); for my $demolisher ( @{ $meta->{DEMOLISH} || [] } ) { my $e = do { local ( $?, $@ ); eval { $demolisher->( $self, $in_global_destruction ) }; $@; }; no warnings 'misc'; # avoid (in cleanup) warnings die $e if $e; # rethrow } return; } my $__XS = !$ENV{PERL_ONLY} && eval { require Class::XSAccessor; Class::XSAccessor->VERSION("1.19") }; # Accessors for list # has declaration, file lib/MyTest/Role1.pm, line 42 if ( $__XS ) { Class::XSAccessor->import( chained => 1, "getters" => { "list" => "list" }, ); } else { *list = sub { @_ == 1 or MyTest::Mite::croak( 'Reader "list" usage: $self->list()' ); $_[0]{"list"} }; } BEGIN { require MyTest::Role2; our %DOES = ( "MyTest::Class1" => 1, "MyTest::Role2" => 1, "MyTest::Role1" => 1 ); } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can( 'does_role' ) and $meta->does_role( $role ) and return 1; } return $self->SUPER::DOES( $role ); } # Alias for Moose/Moo-compatibility sub does { shift->DOES( @_ ); } 1; }Mite.pm000664001750001750 2101014772476615 20135 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTest# NOTE: Since the intention is to ship this file with a project, this file # cannot have any non-core dependencies. package MyTest::Mite; use 5.008001; use strict; use warnings; no strict 'refs'; if ( $] < 5.009005 ) { require MRO::Compat; } else { require mro; } defined ${^GLOBAL_PHASE} or eval { require Devel::GlobalDestruction; 1 } or do { carp( "WARNING: Devel::GlobalDestruction recommended!" ); *Devel::GlobalDestruction::in_global_destruction = sub { undef; }; }; # Constants sub true () { !!1 } sub false () { !!0 } sub ro () { 'ro' } sub rw () { 'rw' } sub rwp () { 'rwp' } sub lazy () { 'lazy' } sub bare () { 'bare' } # More complicated constants BEGIN { my @bool = ( \&false, \&true ); *_HAS_AUTOCLEAN = $bool[ 0+!! eval { require namespace::autoclean } ]; *STRICT = $bool[ 0+!! ( $ENV{PERL_STRICT} || $ENV{EXTENDED_TESTING} || $ENV{AUTHOR_TESTING} || $ENV{RELEASE_TESTING} ) ]; }; # Exportable error handlers sub _error_handler { my ( $func, $message, @args ) = @_; if ( @args ) { require Data::Dumper; local $Data::Dumper::Terse = 1; local $Data::Dumper::Indent = 0; $message = sprintf $message, map { ref($_) ? Data::Dumper::Dumper($_) : defined($_) ? $_ : '(undef)' } @args; } my $next = do { require Carp; \&{"Carp::$func"} }; @_ = ( $message ); goto $next; } sub carp { unshift @_, 'carp' ; goto \&_error_handler } sub croak { unshift @_, 'croak' ; goto \&_error_handler } sub confess { unshift @_, 'confess'; goto \&_error_handler } # Exportable guard function { my $GUARD_PACKAGE = __PACKAGE__ . '::Guard'; *{"$GUARD_PACKAGE\::DESTROY"} = sub { $_[0][0] or $_[0][1]->() }; *{"$GUARD_PACKAGE\::restore"} = sub { $_[0]->DESTROY; $_[0][0] = true }; *{"$GUARD_PACKAGE\::dismiss"} = sub { $_[0][0] = true }; *{"$GUARD_PACKAGE\::peek"} = sub { $_[0][2] }; *guard = sub (&) { bless [ 0, @_ ] => $GUARD_PACKAGE }; } sub _is_compiling { defined $Mite::COMPILING and $Mite::COMPILING eq __PACKAGE__; } sub import { my $me = shift; my %arg = map { lc($_) => true } @_; my ( $caller, $file ) = caller; if( _is_compiling() ) { require Mite::Project; Mite::Project->default->inject_mite_functions( package => $caller, file => $file, arg => \%arg, shim => $me, ); } else { # Changes to this filename must be coordinated with Mite::Compiled my $mite_file = $file . ".mite.pm"; if( !-e $mite_file ) { croak "Compiled Mite file ($mite_file) for $file is missing"; } { local @INC = ('.', @INC); require $mite_file; } } warnings->import; strict->import; 'namespace::autoclean'->import( -cleanee => $caller ) if _HAS_AUTOCLEAN && !$arg{'-unclean'}; } { my ( $cb_before, $cb_after ); sub _finalize_application_roletiny { my ( $me, $role, $caller, $args ) = @_; if ( $INC{'Role/Hooks.pm'} ) { $cb_before ||= \%Role::Hooks::CALLBACKS_BEFORE_APPLY; $cb_after ||= \%Role::Hooks::CALLBACKS_AFTER_APPLY; } if ( $cb_before ) { $_->( $role, $caller ) for @{ $cb_before->{$role} || [] }; } 'Role::Tiny'->_check_requires( $caller, $role ); my $info = $Role::Tiny::INFO{$role}; for ( @{ $info->{modifiers} || [] } ) { my @args = @$_; my $modification = shift @args; my $handler = "HANDLE_$modification"; $me->$handler( $caller, undef, @args ); } if ( $cb_after ) { $_->( $role, $caller ) for @{ $cb_after->{$role} || [] }; } return; } # Usage: $me, $caller, @with_args sub HANDLE_with { my ( $me, $caller ) = ( shift, shift ); while ( @_ ) { my $role = shift; my $args = ref($_[0]) ? shift : undef; if ( $INC{'Role/Tiny.pm'} and 'Role::Tiny'->is_role( $role ) ) { $me->_finalize_application_roletiny( $role, $caller, $args ); } else { $role->__FINALIZE_APPLICATION__( $caller, $args ); } } return; } } # Usage: $me, $caller, $keyword, @has_args sub HANDLE_has { my ( $me, $caller, $keyword, $names ) = ( shift, shift, shift, shift ); if ( @_ % 2 ) { my $default = shift; unshift @_, ( 'CODE' eq ref( $default ) ) ? ( is => lazy, builder => $default ) : ( is => ro, default => $default ); } my %spec = @_; my $code; for my $name ( ref($names) ? @$names : $names ) { $name =~ s/^\+//; 'CODE' eq ref( $code = $spec{default} ) and ${"$caller\::__$name\_DEFAULT__"} = $code; 'CODE' eq ref( $code = $spec{builder} ) and *{"$caller\::_build_$name"} = $code; 'CODE' eq ref( $code = $spec{trigger} ) and *{"$caller\::_trigger_$name"} = $code; 'CODE' eq ref( $code = $spec{clone} ) and *{"$caller\::_clone_$name"} = $code; } return; } { my $_kind = sub { ${ shift() . '::USES_MITE' } =~ /Role/ ? 'role' : 'class' }; sub _get_orig_method { my ( $caller, $name ) = @_; my $orig = $caller->can( $name ); return $orig if $orig; croak "Cannot modify method $name in $caller: no such method"; } sub _parse_mm_args { my $coderef = pop; my $names = [ map { ref($_) ? @$_ : $_ } @_ ]; ( $names, $coderef ); } # Usage: $me, $caller, $caller_kind, @before_args sub HANDLE_before { my ( $me, $caller, $kind ) = ( shift, shift, shift ); my ( $names, $coderef ) = &_parse_mm_args; $kind ||= $caller->$_kind; if ( $kind eq 'role' ) { push @{"$caller\::METHOD_MODIFIERS"}, [ before => $names, $coderef ]; return; } for my $name ( @$names ) { my $orig = _get_orig_method( $caller, $name ); local $@; eval <<"BEFORE" or die $@; package $caller; no warnings 'redefine'; sub $name { \$coderef->( \@_ ); \$orig->( \@_ ); } 1; BEFORE } return; } # Usage: $me, $caller, $caller_kind, @after_args sub HANDLE_after { my ( $me, $caller, $kind ) = ( shift, shift, shift ); my ( $names, $coderef ) = &_parse_mm_args; $kind ||= $caller->$_kind; if ( $kind eq 'role' ) { push @{"$caller\::METHOD_MODIFIERS"}, [ after => $names, $coderef ]; return; } for my $name ( @$names ) { my $orig = _get_orig_method( $caller, $name ); local $@; eval <<"AFTER" or die $@; package $caller; no warnings 'redefine'; sub $name { my \@r; if ( wantarray ) { \@r = \$orig->( \@_ ); } elsif ( defined wantarray ) { \@r = scalar \$orig->( \@_ ); } else { \$orig->( \@_ ); 1; } \$coderef->( \@_ ); wantarray ? \@r : \$r[0]; } 1; AFTER } return; } # Usage: $me, $caller, $caller_kind, @around_args sub HANDLE_around { my ( $me, $caller, $kind ) = ( shift, shift, shift ); my ( $names, $coderef ) = &_parse_mm_args; $kind ||= $caller->$_kind; if ( $kind eq 'role' ) { push @{"$caller\::METHOD_MODIFIERS"}, [ around => $names, $coderef ]; return; } for my $name ( @$names ) { my $orig = _get_orig_method( $caller, $name ); local $@; eval <<"AROUND" or die $@; package $caller; no warnings 'redefine'; sub $name { \$coderef->( \$orig, \@_ ); } 1; AROUND } return; } } # Usage: $me, $caller, $caller_kind, @signature_for_args sub HANDLE_signature_for { my ( $me, $caller, $kind, $name ) = @_; $name =~ s/^\+//; $me->HANDLE_around( $caller, $kind, $name, ${"$caller\::SIGNATURE_FOR"}{$name} ); return; } 1; Role1.pm000664001750001750 34214772476615 20166 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTestpackage MyTest::Role1; use MyTest::Mite -role; use Sub::HandlesVia; has list => ( is => 'ro', isa => 'ArrayRef', default => sub { [] }, handles_via => 'Array', handles => { push => 'push', pop => 'pop', }, ); 1; Role1.pm.mite.pm000664001750001750 575514772476615 21573 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTest{ package MyTest::Role1; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Role"; our $MITE_SHIM = "MyTest::Mite"; our $MITE_VERSION = "0.010008"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "MyTest::Mite", "MyTest::Role1" ); ( *after, *around, *before, *has, *requires, *signature_for, *with ) = do { package MyTest::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "role", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "role", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "role", @_ ) }, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub {}, sub { $SHIM->HANDLE_signature_for( $CALLER, "role", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; }; # Gather metadata for constructor and destructor sub __META__ { no strict 'refs'; my $class = shift; $class = ref($class) || $class; my $linear_isa = mro::get_linear_isa( $class ); return { BUILD => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::BUILD" } reverse @$linear_isa ], DEMOLISH => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::DEMOLISH" } @$linear_isa ], HAS_BUILDARGS => $class->can('BUILDARGS'), HAS_FOREIGNBUILDARGS => $class->can('FOREIGNBUILDARGS'), }; } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can( 'does_role' ) and $meta->does_role( $role ) and return 1; } return $self->SUPER::DOES( $role ); } # Alias for Moose/Moo-compatibility sub does { shift->DOES( @_ ); } # Callback which classes consuming this role will call sub __FINALIZE_APPLICATION__ { my ( $me, $target, $args ) = @_; our ( %CONSUMERS, @METHOD_MODIFIERS ); # Ensure a given target only consumes this role once. if ( exists $CONSUMERS{$target} ) { return; } $CONSUMERS{$target} = 1; my $type = do { no strict 'refs'; ${"$target\::USES_MITE"} }; return if $type ne 'Mite::Class'; my @missing_methods; @missing_methods = () and MyTest::Mite::croak( "$me requires $target to implement methods: " . join q[, ], @missing_methods ); my @roles = ( ); my %nextargs = %{ $args || {} }; ( $nextargs{-indirect} ||= 0 )++; MyTest::Mite::croak( "PANIC!" ) if $nextargs{-indirect} > 100; for my $role ( @roles ) { $role->__FINALIZE_APPLICATION__( $target, { %nextargs } ); } my $shim = "MyTest::Mite"; for my $modifier_rule ( @METHOD_MODIFIERS ) { my ( $modification, $names, $coderef ) = @$modifier_rule; my $handler = "HANDLE_$modification"; $shim->$handler( $target, "class", $names, $coderef ); } return; } 1; }Role2.pm000664001750001750 11214772476615 20162 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTestpackage MyTest::Role2; use MyTest::Mite -role; with 'MyTest::Role1'; 1; Role2.pm.mite.pm000664001750001750 614714772476615 21570 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTest{ package MyTest::Role2; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Role"; our $MITE_SHIM = "MyTest::Mite"; our $MITE_VERSION = "0.010008"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "MyTest::Mite", "MyTest::Role2" ); ( *after, *around, *before, *has, *requires, *signature_for, *with ) = do { package MyTest::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "role", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "role", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "role", @_ ) }, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub {}, sub { $SHIM->HANDLE_signature_for( $CALLER, "role", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; }; # Gather metadata for constructor and destructor sub __META__ { no strict 'refs'; my $class = shift; $class = ref($class) || $class; my $linear_isa = mro::get_linear_isa( $class ); return { BUILD => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::BUILD" } reverse @$linear_isa ], DEMOLISH => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::DEMOLISH" } @$linear_isa ], HAS_BUILDARGS => $class->can('BUILDARGS'), HAS_FOREIGNBUILDARGS => $class->can('FOREIGNBUILDARGS'), }; } BEGIN { require MyTest::Role1; our %DOES = ( "MyTest::Role2" => 1, "MyTest::Role1" => 1 ); } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can( 'does_role' ) and $meta->does_role( $role ) and return 1; } return $self->SUPER::DOES( $role ); } # Alias for Moose/Moo-compatibility sub does { shift->DOES( @_ ); } # Callback which classes consuming this role will call sub __FINALIZE_APPLICATION__ { my ( $me, $target, $args ) = @_; our ( %CONSUMERS, @METHOD_MODIFIERS ); # Ensure a given target only consumes this role once. if ( exists $CONSUMERS{$target} ) { return; } $CONSUMERS{$target} = 1; my $type = do { no strict 'refs'; ${"$target\::USES_MITE"} }; return if $type ne 'Mite::Class'; my @missing_methods; @missing_methods = () and MyTest::Mite::croak( "$me requires $target to implement methods: " . join q[, ], @missing_methods ); my @roles = ( "MyTest::Role1" ); my %nextargs = %{ $args || {} }; ( $nextargs{-indirect} ||= 0 )++; MyTest::Mite::croak( "PANIC!" ) if $nextargs{-indirect} > 100; for my $role ( @roles ) { $role->__FINALIZE_APPLICATION__( $target, { %nextargs } ); } my $shim = "MyTest::Mite"; for my $modifier_rule ( @METHOD_MODIFIERS ) { my ( $modification, $names, $coderef ) = @$modifier_rule; my $handler = "HANDLE_$modification"; $shim->$handler( $target, "class", $names, $coderef ); } return; } 1; }Array.pm000664001750001750 407114772476615 22212 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTest/TestClasspackage MyTest::TestClass::Array; use MyTest::Mite; use Sub::HandlesVia; has attr => ( is => 'rwp', isa => 'ArrayRef', handles_via => 'Array', handles => { 'my_accessor' => 'accessor', 'my_all' => 'all', 'my_all_true' => 'all_true', 'my_any' => 'any', 'my_apply' => 'apply', 'my_clear' => 'clear', 'my_count' => 'count', 'my_delete' => 'delete', 'my_elements' => 'elements', 'my_first' => 'first', 'my_first_index' => 'first_index', 'my_flatten' => 'flatten', 'my_flatten_deep' => 'flatten_deep', 'my_for_each' => 'for_each', 'my_for_each_pair' => 'for_each_pair', 'my_get' => 'get', 'my_grep' => 'grep', 'my_head' => 'head', 'my_insert' => 'insert', 'my_is_empty' => 'is_empty', 'my_join' => 'join', 'my_map' => 'map', 'my_max' => 'max', 'my_maxstr' => 'maxstr', 'my_min' => 'min', 'my_minstr' => 'minstr', 'my_natatime' => 'natatime', 'my_not_all_true' => 'not_all_true', 'my_pairfirst' => 'pairfirst', 'my_pairgrep' => 'pairgrep', 'my_pairkeys' => 'pairkeys', 'my_pairmap' => 'pairmap', 'my_pairs' => 'pairs', 'my_pairvalues' => 'pairvalues', 'my_pick_random' => 'pick_random', 'my_pop' => 'pop', 'my_print' => 'print', 'my_product' => 'product', 'my_push' => 'push', 'my_reduce' => 'reduce', 'my_reductions' => 'reductions', 'my_reset' => 'reset', 'my_reverse' => 'reverse', 'my_sample' => 'sample', 'my_set' => 'set', 'my_shallow_clone' => 'shallow_clone', 'my_shift' => 'shift', 'my_shuffle' => 'shuffle', 'my_shuffle_in_place' => 'shuffle_in_place', 'my_sort' => 'sort', 'my_sort_in_place' => 'sort_in_place', 'my_splice' => 'splice', 'my_sum' => 'sum', 'my_tail' => 'tail', 'my_uniq' => 'uniq', 'my_uniq_in_place' => 'uniq_in_place', 'my_uniqnum' => 'uniqnum', 'my_uniqnum_in_place' => 'uniqnum_in_place', 'my_uniqstr' => 'uniqstr', 'my_uniqstr_in_place' => 'uniqstr_in_place', 'my_unshift' => 'unshift', }, default => sub { [] }, ); 1; Array.pm.mite.pm000664001750001750 1067014772476615 23604 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTest/TestClass{ package MyTest::TestClass::Array; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Class"; our $MITE_SHIM = "MyTest::Mite"; our $MITE_VERSION = "0.010008"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "MyTest::Mite", "MyTest::TestClass::Array" ); ( *after, *around, *before, *extends, *has, *signature_for, *with ) = do { package MyTest::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "class", @_ ) }, sub {}, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub { $SHIM->HANDLE_signature_for( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; }; # Gather metadata for constructor and destructor sub __META__ { no strict 'refs'; my $class = shift; $class = ref($class) || $class; my $linear_isa = mro::get_linear_isa( $class ); return { BUILD => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::BUILD" } reverse @$linear_isa ], DEMOLISH => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::DEMOLISH" } @$linear_isa ], HAS_BUILDARGS => $class->can('BUILDARGS'), HAS_FOREIGNBUILDARGS => $class->can('FOREIGNBUILDARGS'), }; } # Standard Moose/Moo-style constructor sub new { my $class = ref($_[0]) ? ref(shift) : shift; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $self = bless {}, $class; my $args = $meta->{HAS_BUILDARGS} ? $class->BUILDARGS( @_ ) : { ( @_ == 1 ) ? %{$_[0]} : @_ }; my $no_build = delete $args->{__no_BUILD__}; # Attribute attr (type: ArrayRef) # has declaration, file lib/MyTest/TestClass/Array.pm, line 42 do { my $value = exists( $args->{"attr"} ) ? $args->{"attr"} : $MyTest::TestClass::Array::__attr_DEFAULT__->( $self ); (ref($value) eq 'ARRAY') or MyTest::Mite::croak "Type check failed in constructor: %s should be %s", "attr", "ArrayRef"; $self->{"attr"} = $value; }; # Call BUILD methods $self->BUILDALL( $args ) if ( ! $no_build and @{ $meta->{BUILD} || [] } ); # Unrecognized parameters my @unknown = grep not( /\Aattr\z/ ), keys %{$args}; @unknown and MyTest::Mite::croak( "Unexpected keys in constructor: " . join( q[, ], sort @unknown ) ); return $self; } # Used by constructor to call BUILD methods sub BUILDALL { my $class = ref( $_[0] ); my $meta = ( $Mite::META{$class} ||= $class->__META__ ); $_->( @_ ) for @{ $meta->{BUILD} || [] }; } # Destructor should call DEMOLISH methods sub DESTROY { my $self = shift; my $class = ref( $self ) || $self; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $in_global_destruction = defined ${^GLOBAL_PHASE} ? ${^GLOBAL_PHASE} eq 'DESTRUCT' : Devel::GlobalDestruction::in_global_destruction(); for my $demolisher ( @{ $meta->{DEMOLISH} || [] } ) { my $e = do { local ( $?, $@ ); eval { $demolisher->( $self, $in_global_destruction ) }; $@; }; no warnings 'misc'; # avoid (in cleanup) warnings die $e if $e; # rethrow } return; } my $__XS = !$ENV{PERL_ONLY} && eval { require Class::XSAccessor; Class::XSAccessor->VERSION("1.19") }; # Accessors for attr # has declaration, file lib/MyTest/TestClass/Array.pm, line 42 if ( $__XS ) { Class::XSAccessor->import( chained => 1, "getters" => { "attr" => "attr" }, ); } else { *attr = sub { @_ == 1 or MyTest::Mite::croak( 'Reader "attr" usage: $self->attr()' ); $_[0]{"attr"} }; } sub _set_attr { @_ == 2 or MyTest::Mite::croak( 'Writer "_set_attr" usage: $self->_set_attr( $newvalue )' ); (ref($_[1]) eq 'ARRAY') or MyTest::Mite::croak( "Type check failed in %s: value should be %s", "writer", "ArrayRef" ); $_[0]{"attr"} = $_[1]; $_[0]; } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can( 'does_role' ) and $meta->does_role( $role ) and return 1; } return $self->SUPER::DOES( $role ); } # Alias for Moose/Moo-compatibility sub does { shift->DOES( @_ ); } 1; }Bool.pm000664001750001750 50614772476615 22006 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTest/TestClasspackage MyTest::TestClass::Bool; use MyTest::Mite; use Sub::HandlesVia; has attr => ( is => 'rwp', isa => 'Bool', handles_via => 'Bool', handles => { 'my_not' => 'not', 'my_reset' => 'reset', 'my_set' => 'set', 'my_toggle' => 'toggle', 'my_unset' => 'unset', }, default => sub { 0 }, ); 1; Bool.pm.mite.pm000664001750001750 1103714772476615 23417 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTest/TestClass{ package MyTest::TestClass::Bool; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Class"; our $MITE_SHIM = "MyTest::Mite"; our $MITE_VERSION = "0.010008"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "MyTest::Mite", "MyTest::TestClass::Bool" ); ( *after, *around, *before, *extends, *has, *signature_for, *with ) = do { package MyTest::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "class", @_ ) }, sub {}, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub { $SHIM->HANDLE_signature_for( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; }; # Gather metadata for constructor and destructor sub __META__ { no strict 'refs'; my $class = shift; $class = ref($class) || $class; my $linear_isa = mro::get_linear_isa( $class ); return { BUILD => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::BUILD" } reverse @$linear_isa ], DEMOLISH => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::DEMOLISH" } @$linear_isa ], HAS_BUILDARGS => $class->can('BUILDARGS'), HAS_FOREIGNBUILDARGS => $class->can('FOREIGNBUILDARGS'), }; } # Standard Moose/Moo-style constructor sub new { my $class = ref($_[0]) ? ref(shift) : shift; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $self = bless {}, $class; my $args = $meta->{HAS_BUILDARGS} ? $class->BUILDARGS( @_ ) : { ( @_ == 1 ) ? %{$_[0]} : @_ }; my $no_build = delete $args->{__no_BUILD__}; # Attribute attr (type: Bool) # has declaration, file lib/MyTest/TestClass/Bool.pm, line 42 do { my $value = exists( $args->{"attr"} ) ? $args->{"attr"} : $MyTest::TestClass::Bool::__attr_DEFAULT__->( $self ); (!ref $value and (!defined $value or $value eq q() or $value eq '0' or $value eq '1')) or MyTest::Mite::croak "Type check failed in constructor: %s should be %s", "attr", "Bool"; $self->{"attr"} = $value; }; # Call BUILD methods $self->BUILDALL( $args ) if ( ! $no_build and @{ $meta->{BUILD} || [] } ); # Unrecognized parameters my @unknown = grep not( /\Aattr\z/ ), keys %{$args}; @unknown and MyTest::Mite::croak( "Unexpected keys in constructor: " . join( q[, ], sort @unknown ) ); return $self; } # Used by constructor to call BUILD methods sub BUILDALL { my $class = ref( $_[0] ); my $meta = ( $Mite::META{$class} ||= $class->__META__ ); $_->( @_ ) for @{ $meta->{BUILD} || [] }; } # Destructor should call DEMOLISH methods sub DESTROY { my $self = shift; my $class = ref( $self ) || $self; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $in_global_destruction = defined ${^GLOBAL_PHASE} ? ${^GLOBAL_PHASE} eq 'DESTRUCT' : Devel::GlobalDestruction::in_global_destruction(); for my $demolisher ( @{ $meta->{DEMOLISH} || [] } ) { my $e = do { local ( $?, $@ ); eval { $demolisher->( $self, $in_global_destruction ) }; $@; }; no warnings 'misc'; # avoid (in cleanup) warnings die $e if $e; # rethrow } return; } my $__XS = !$ENV{PERL_ONLY} && eval { require Class::XSAccessor; Class::XSAccessor->VERSION("1.19") }; # Accessors for attr # has declaration, file lib/MyTest/TestClass/Bool.pm, line 42 if ( $__XS ) { Class::XSAccessor->import( chained => 1, "getters" => { "attr" => "attr" }, ); } else { *attr = sub { @_ == 1 or MyTest::Mite::croak( 'Reader "attr" usage: $self->attr()' ); $_[0]{"attr"} }; } sub _set_attr { @_ == 2 or MyTest::Mite::croak( 'Writer "_set_attr" usage: $self->_set_attr( $newvalue )' ); (!ref $_[1] and (!defined $_[1] or $_[1] eq q() or $_[1] eq '0' or $_[1] eq '1')) or MyTest::Mite::croak( "Type check failed in %s: value should be %s", "writer", "Bool" ); $_[0]{"attr"} = $_[1]; $_[0]; } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can( 'does_role' ) and $meta->does_role( $role ) and return 1; } return $self->SUPER::DOES( $role ); } # Alias for Moose/Moo-compatibility sub does { shift->DOES( @_ ); } 1; }Code.pm000664001750001750 110114772476615 21775 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTest/TestClasspackage MyTest::TestClass::Code; use MyTest::Mite; use Sub::HandlesVia; has attr => ( is => 'rwp', isa => 'CodeRef', handles_via => 'Code', handles => { 'my_execute' => 'execute', 'my_execute_list' => 'execute_list', 'my_execute_method' => 'execute_method', 'my_execute_method_list' => 'execute_method_list', 'my_execute_method_scalar' => 'execute_method_scalar', 'my_execute_method_void' => 'execute_method_void', 'my_execute_scalar' => 'execute_scalar', 'my_execute_void' => 'execute_void', }, default => sub { sub {} }, ); 1; Code.pm.mite.pm000664001750001750 1065614772476615 23404 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTest/TestClass{ package MyTest::TestClass::Code; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Class"; our $MITE_SHIM = "MyTest::Mite"; our $MITE_VERSION = "0.010008"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "MyTest::Mite", "MyTest::TestClass::Code" ); ( *after, *around, *before, *extends, *has, *signature_for, *with ) = do { package MyTest::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "class", @_ ) }, sub {}, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub { $SHIM->HANDLE_signature_for( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; }; # Gather metadata for constructor and destructor sub __META__ { no strict 'refs'; my $class = shift; $class = ref($class) || $class; my $linear_isa = mro::get_linear_isa( $class ); return { BUILD => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::BUILD" } reverse @$linear_isa ], DEMOLISH => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::DEMOLISH" } @$linear_isa ], HAS_BUILDARGS => $class->can('BUILDARGS'), HAS_FOREIGNBUILDARGS => $class->can('FOREIGNBUILDARGS'), }; } # Standard Moose/Moo-style constructor sub new { my $class = ref($_[0]) ? ref(shift) : shift; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $self = bless {}, $class; my $args = $meta->{HAS_BUILDARGS} ? $class->BUILDARGS( @_ ) : { ( @_ == 1 ) ? %{$_[0]} : @_ }; my $no_build = delete $args->{__no_BUILD__}; # Attribute attr (type: CodeRef) # has declaration, file lib/MyTest/TestClass/Code.pm, line 42 do { my $value = exists( $args->{"attr"} ) ? $args->{"attr"} : $MyTest::TestClass::Code::__attr_DEFAULT__->( $self ); (ref($value) eq 'CODE') or MyTest::Mite::croak "Type check failed in constructor: %s should be %s", "attr", "CodeRef"; $self->{"attr"} = $value; }; # Call BUILD methods $self->BUILDALL( $args ) if ( ! $no_build and @{ $meta->{BUILD} || [] } ); # Unrecognized parameters my @unknown = grep not( /\Aattr\z/ ), keys %{$args}; @unknown and MyTest::Mite::croak( "Unexpected keys in constructor: " . join( q[, ], sort @unknown ) ); return $self; } # Used by constructor to call BUILD methods sub BUILDALL { my $class = ref( $_[0] ); my $meta = ( $Mite::META{$class} ||= $class->__META__ ); $_->( @_ ) for @{ $meta->{BUILD} || [] }; } # Destructor should call DEMOLISH methods sub DESTROY { my $self = shift; my $class = ref( $self ) || $self; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $in_global_destruction = defined ${^GLOBAL_PHASE} ? ${^GLOBAL_PHASE} eq 'DESTRUCT' : Devel::GlobalDestruction::in_global_destruction(); for my $demolisher ( @{ $meta->{DEMOLISH} || [] } ) { my $e = do { local ( $?, $@ ); eval { $demolisher->( $self, $in_global_destruction ) }; $@; }; no warnings 'misc'; # avoid (in cleanup) warnings die $e if $e; # rethrow } return; } my $__XS = !$ENV{PERL_ONLY} && eval { require Class::XSAccessor; Class::XSAccessor->VERSION("1.19") }; # Accessors for attr # has declaration, file lib/MyTest/TestClass/Code.pm, line 42 if ( $__XS ) { Class::XSAccessor->import( chained => 1, "getters" => { "attr" => "attr" }, ); } else { *attr = sub { @_ == 1 or MyTest::Mite::croak( 'Reader "attr" usage: $self->attr()' ); $_[0]{"attr"} }; } sub _set_attr { @_ == 2 or MyTest::Mite::croak( 'Writer "_set_attr" usage: $self->_set_attr( $newvalue )' ); (ref($_[1]) eq 'CODE') or MyTest::Mite::croak( "Type check failed in %s: value should be %s", "writer", "CodeRef" ); $_[0]{"attr"} = $_[1]; $_[0]; } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can( 'does_role' ) and $meta->does_role( $role ) and return 1; } return $self->SUPER::DOES( $role ); } # Alias for Moose/Moo-compatibility sub does { shift->DOES( @_ ); } 1; }Counter.pm000664001750001750 45214772476615 22532 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTest/TestClasspackage MyTest::TestClass::Counter; use MyTest::Mite; use Sub::HandlesVia; has attr => ( is => 'rwp', isa => 'Int', handles_via => 'Counter', handles => { 'my_dec' => 'dec', 'my_inc' => 'inc', 'my_reset' => 'reset', 'my_set' => 'set', }, default => sub { 0 }, ); 1; Counter.pm.mite.pm000664001750001750 1104714772476615 24144 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTest/TestClass{ package MyTest::TestClass::Counter; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Class"; our $MITE_SHIM = "MyTest::Mite"; our $MITE_VERSION = "0.010008"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "MyTest::Mite", "MyTest::TestClass::Counter" ); ( *after, *around, *before, *extends, *has, *signature_for, *with ) = do { package MyTest::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "class", @_ ) }, sub {}, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub { $SHIM->HANDLE_signature_for( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; }; # Gather metadata for constructor and destructor sub __META__ { no strict 'refs'; my $class = shift; $class = ref($class) || $class; my $linear_isa = mro::get_linear_isa( $class ); return { BUILD => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::BUILD" } reverse @$linear_isa ], DEMOLISH => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::DEMOLISH" } @$linear_isa ], HAS_BUILDARGS => $class->can('BUILDARGS'), HAS_FOREIGNBUILDARGS => $class->can('FOREIGNBUILDARGS'), }; } # Standard Moose/Moo-style constructor sub new { my $class = ref($_[0]) ? ref(shift) : shift; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $self = bless {}, $class; my $args = $meta->{HAS_BUILDARGS} ? $class->BUILDARGS( @_ ) : { ( @_ == 1 ) ? %{$_[0]} : @_ }; my $no_build = delete $args->{__no_BUILD__}; # Attribute attr (type: Int) # has declaration, file lib/MyTest/TestClass/Counter.pm, line 42 do { my $value = exists( $args->{"attr"} ) ? $args->{"attr"} : $MyTest::TestClass::Counter::__attr_DEFAULT__->( $self ); (do { my $tmp = $value; defined($tmp) and !ref($tmp) and $tmp =~ /\A-?[0-9]+\z/ }) or MyTest::Mite::croak "Type check failed in constructor: %s should be %s", "attr", "Int"; $self->{"attr"} = $value; }; # Call BUILD methods $self->BUILDALL( $args ) if ( ! $no_build and @{ $meta->{BUILD} || [] } ); # Unrecognized parameters my @unknown = grep not( /\Aattr\z/ ), keys %{$args}; @unknown and MyTest::Mite::croak( "Unexpected keys in constructor: " . join( q[, ], sort @unknown ) ); return $self; } # Used by constructor to call BUILD methods sub BUILDALL { my $class = ref( $_[0] ); my $meta = ( $Mite::META{$class} ||= $class->__META__ ); $_->( @_ ) for @{ $meta->{BUILD} || [] }; } # Destructor should call DEMOLISH methods sub DESTROY { my $self = shift; my $class = ref( $self ) || $self; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $in_global_destruction = defined ${^GLOBAL_PHASE} ? ${^GLOBAL_PHASE} eq 'DESTRUCT' : Devel::GlobalDestruction::in_global_destruction(); for my $demolisher ( @{ $meta->{DEMOLISH} || [] } ) { my $e = do { local ( $?, $@ ); eval { $demolisher->( $self, $in_global_destruction ) }; $@; }; no warnings 'misc'; # avoid (in cleanup) warnings die $e if $e; # rethrow } return; } my $__XS = !$ENV{PERL_ONLY} && eval { require Class::XSAccessor; Class::XSAccessor->VERSION("1.19") }; # Accessors for attr # has declaration, file lib/MyTest/TestClass/Counter.pm, line 42 if ( $__XS ) { Class::XSAccessor->import( chained => 1, "getters" => { "attr" => "attr" }, ); } else { *attr = sub { @_ == 1 or MyTest::Mite::croak( 'Reader "attr" usage: $self->attr()' ); $_[0]{"attr"} }; } sub _set_attr { @_ == 2 or MyTest::Mite::croak( 'Writer "_set_attr" usage: $self->_set_attr( $newvalue )' ); (do { my $tmp = $_[1]; defined($tmp) and !ref($tmp) and $tmp =~ /\A-?[0-9]+\z/ }) or MyTest::Mite::croak( "Type check failed in %s: value should be %s", "writer", "Int" ); $_[0]{"attr"} = $_[1]; $_[0]; } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can( 'does_role' ) and $meta->does_role( $role ) and return 1; } return $self->SUPER::DOES( $role ); } # Alias for Moose/Moo-compatibility sub does { shift->DOES( @_ ); } 1; }Hash.pm000664001750001750 154214772476615 22017 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTest/TestClasspackage MyTest::TestClass::Hash; use MyTest::Mite; use Sub::HandlesVia; has attr => ( is => 'rwp', isa => 'HashRef', handles_via => 'Hash', handles => { 'my_accessor' => 'accessor', 'my_all' => 'all', 'my_clear' => 'clear', 'my_count' => 'count', 'my_defined' => 'defined', 'my_delete' => 'delete', 'my_delete_where' => 'delete_where', 'my_elements' => 'elements', 'my_exists' => 'exists', 'my_for_each_key' => 'for_each_key', 'my_for_each_pair' => 'for_each_pair', 'my_for_each_value' => 'for_each_value', 'my_get' => 'get', 'my_is_empty' => 'is_empty', 'my_keys' => 'keys', 'my_kv' => 'kv', 'my_reset' => 'reset', 'my_set' => 'set', 'my_shallow_clone' => 'shallow_clone', 'my_sorted_keys' => 'sorted_keys', 'my_values' => 'values', }, default => sub { {} }, ); 1; Hash.pm.mite.pm000664001750001750 1065614772476615 23415 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTest/TestClass{ package MyTest::TestClass::Hash; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Class"; our $MITE_SHIM = "MyTest::Mite"; our $MITE_VERSION = "0.010008"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "MyTest::Mite", "MyTest::TestClass::Hash" ); ( *after, *around, *before, *extends, *has, *signature_for, *with ) = do { package MyTest::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "class", @_ ) }, sub {}, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub { $SHIM->HANDLE_signature_for( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; }; # Gather metadata for constructor and destructor sub __META__ { no strict 'refs'; my $class = shift; $class = ref($class) || $class; my $linear_isa = mro::get_linear_isa( $class ); return { BUILD => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::BUILD" } reverse @$linear_isa ], DEMOLISH => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::DEMOLISH" } @$linear_isa ], HAS_BUILDARGS => $class->can('BUILDARGS'), HAS_FOREIGNBUILDARGS => $class->can('FOREIGNBUILDARGS'), }; } # Standard Moose/Moo-style constructor sub new { my $class = ref($_[0]) ? ref(shift) : shift; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $self = bless {}, $class; my $args = $meta->{HAS_BUILDARGS} ? $class->BUILDARGS( @_ ) : { ( @_ == 1 ) ? %{$_[0]} : @_ }; my $no_build = delete $args->{__no_BUILD__}; # Attribute attr (type: HashRef) # has declaration, file lib/MyTest/TestClass/Hash.pm, line 42 do { my $value = exists( $args->{"attr"} ) ? $args->{"attr"} : $MyTest::TestClass::Hash::__attr_DEFAULT__->( $self ); (ref($value) eq 'HASH') or MyTest::Mite::croak "Type check failed in constructor: %s should be %s", "attr", "HashRef"; $self->{"attr"} = $value; }; # Call BUILD methods $self->BUILDALL( $args ) if ( ! $no_build and @{ $meta->{BUILD} || [] } ); # Unrecognized parameters my @unknown = grep not( /\Aattr\z/ ), keys %{$args}; @unknown and MyTest::Mite::croak( "Unexpected keys in constructor: " . join( q[, ], sort @unknown ) ); return $self; } # Used by constructor to call BUILD methods sub BUILDALL { my $class = ref( $_[0] ); my $meta = ( $Mite::META{$class} ||= $class->__META__ ); $_->( @_ ) for @{ $meta->{BUILD} || [] }; } # Destructor should call DEMOLISH methods sub DESTROY { my $self = shift; my $class = ref( $self ) || $self; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $in_global_destruction = defined ${^GLOBAL_PHASE} ? ${^GLOBAL_PHASE} eq 'DESTRUCT' : Devel::GlobalDestruction::in_global_destruction(); for my $demolisher ( @{ $meta->{DEMOLISH} || [] } ) { my $e = do { local ( $?, $@ ); eval { $demolisher->( $self, $in_global_destruction ) }; $@; }; no warnings 'misc'; # avoid (in cleanup) warnings die $e if $e; # rethrow } return; } my $__XS = !$ENV{PERL_ONLY} && eval { require Class::XSAccessor; Class::XSAccessor->VERSION("1.19") }; # Accessors for attr # has declaration, file lib/MyTest/TestClass/Hash.pm, line 42 if ( $__XS ) { Class::XSAccessor->import( chained => 1, "getters" => { "attr" => "attr" }, ); } else { *attr = sub { @_ == 1 or MyTest::Mite::croak( 'Reader "attr" usage: $self->attr()' ); $_[0]{"attr"} }; } sub _set_attr { @_ == 2 or MyTest::Mite::croak( 'Writer "_set_attr" usage: $self->_set_attr( $newvalue )' ); (ref($_[1]) eq 'HASH') or MyTest::Mite::croak( "Type check failed in %s: value should be %s", "writer", "HashRef" ); $_[0]{"attr"} = $_[1]; $_[0]; } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can( 'does_role' ) and $meta->does_role( $role ) and return 1; } return $self->SUPER::DOES( $role ); } # Alias for Moose/Moo-compatibility sub does { shift->DOES( @_ ); } 1; }Number.pm000664001750001750 102514772476615 22360 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTest/TestClasspackage MyTest::TestClass::Number; use MyTest::Mite; use Sub::HandlesVia; has attr => ( is => 'rwp', isa => 'Num', handles_via => 'Number', handles => { 'my_abs' => 'abs', 'my_add' => 'add', 'my_cmp' => 'cmp', 'my_div' => 'div', 'my_eq' => 'eq', 'my_ge' => 'ge', 'my_get' => 'get', 'my_gt' => 'gt', 'my_le' => 'le', 'my_lt' => 'lt', 'my_mod' => 'mod', 'my_mul' => 'mul', 'my_ne' => 'ne', 'my_set' => 'set', 'my_sub' => 'sub', }, default => sub { 0 }, ); 1; Number.pm.mite.pm000664001750001750 1117014772476615 23752 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTest/TestClass{ package MyTest::TestClass::Number; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Class"; our $MITE_SHIM = "MyTest::Mite"; our $MITE_VERSION = "0.010008"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "MyTest::Mite", "MyTest::TestClass::Number" ); ( *after, *around, *before, *extends, *has, *signature_for, *with ) = do { package MyTest::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "class", @_ ) }, sub {}, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub { $SHIM->HANDLE_signature_for( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; }; # Gather metadata for constructor and destructor sub __META__ { no strict 'refs'; my $class = shift; $class = ref($class) || $class; my $linear_isa = mro::get_linear_isa( $class ); return { BUILD => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::BUILD" } reverse @$linear_isa ], DEMOLISH => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::DEMOLISH" } @$linear_isa ], HAS_BUILDARGS => $class->can('BUILDARGS'), HAS_FOREIGNBUILDARGS => $class->can('FOREIGNBUILDARGS'), }; } # Standard Moose/Moo-style constructor sub new { my $class = ref($_[0]) ? ref(shift) : shift; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $self = bless {}, $class; my $args = $meta->{HAS_BUILDARGS} ? $class->BUILDARGS( @_ ) : { ( @_ == 1 ) ? %{$_[0]} : @_ }; my $no_build = delete $args->{__no_BUILD__}; # Attribute attr (type: Num) # has declaration, file lib/MyTest/TestClass/Number.pm, line 42 do { my $value = exists( $args->{"attr"} ) ? $args->{"attr"} : $MyTest::TestClass::Number::__attr_DEFAULT__->( $self ); (do { package MyTest::Mite; use Scalar::Util (); defined($value) && !ref($value) && Scalar::Util::looks_like_number($value) }) or MyTest::Mite::croak "Type check failed in constructor: %s should be %s", "attr", "Num"; $self->{"attr"} = $value; }; # Call BUILD methods $self->BUILDALL( $args ) if ( ! $no_build and @{ $meta->{BUILD} || [] } ); # Unrecognized parameters my @unknown = grep not( /\Aattr\z/ ), keys %{$args}; @unknown and MyTest::Mite::croak( "Unexpected keys in constructor: " . join( q[, ], sort @unknown ) ); return $self; } # Used by constructor to call BUILD methods sub BUILDALL { my $class = ref( $_[0] ); my $meta = ( $Mite::META{$class} ||= $class->__META__ ); $_->( @_ ) for @{ $meta->{BUILD} || [] }; } # Destructor should call DEMOLISH methods sub DESTROY { my $self = shift; my $class = ref( $self ) || $self; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $in_global_destruction = defined ${^GLOBAL_PHASE} ? ${^GLOBAL_PHASE} eq 'DESTRUCT' : Devel::GlobalDestruction::in_global_destruction(); for my $demolisher ( @{ $meta->{DEMOLISH} || [] } ) { my $e = do { local ( $?, $@ ); eval { $demolisher->( $self, $in_global_destruction ) }; $@; }; no warnings 'misc'; # avoid (in cleanup) warnings die $e if $e; # rethrow } return; } my $__XS = !$ENV{PERL_ONLY} && eval { require Class::XSAccessor; Class::XSAccessor->VERSION("1.19") }; # Accessors for attr # has declaration, file lib/MyTest/TestClass/Number.pm, line 42 if ( $__XS ) { Class::XSAccessor->import( chained => 1, "getters" => { "attr" => "attr" }, ); } else { *attr = sub { @_ == 1 or MyTest::Mite::croak( 'Reader "attr" usage: $self->attr()' ); $_[0]{"attr"} }; } sub _set_attr { @_ == 2 or MyTest::Mite::croak( 'Writer "_set_attr" usage: $self->_set_attr( $newvalue )' ); (do { package MyTest::Mite; use Scalar::Util (); defined($_[1]) && !ref($_[1]) && Scalar::Util::looks_like_number($_[1]) }) or MyTest::Mite::croak( "Type check failed in %s: value should be %s", "writer", "Num" ); $_[0]{"attr"} = $_[1]; $_[0]; } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can( 'does_role' ) and $meta->does_role( $role ) and return 1; } return $self->SUPER::DOES( $role ); } # Alias for Moose/Moo-compatibility sub does { shift->DOES( @_ ); } 1; }Scalar.pm000664001750001750 51114772476615 22314 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTest/TestClasspackage MyTest::TestClass::Scalar; use MyTest::Mite; use Sub::HandlesVia; has attr => ( is => 'rwp', isa => 'Any', handles_via => 'Scalar', handles => { 'my_make_getter' => 'make_getter', 'my_make_setter' => 'make_setter', 'my_scalar_reference' => 'scalar_reference', }, default => sub { q[] }, ); 1; Scalar.pm.mite.pm000664001750001750 1061114772476615 23726 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTest/TestClass{ package MyTest::TestClass::Scalar; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Class"; our $MITE_SHIM = "MyTest::Mite"; our $MITE_VERSION = "0.010008"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "MyTest::Mite", "MyTest::TestClass::Scalar" ); ( *after, *around, *before, *extends, *has, *signature_for, *with ) = do { package MyTest::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "class", @_ ) }, sub {}, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub { $SHIM->HANDLE_signature_for( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; }; # Gather metadata for constructor and destructor sub __META__ { no strict 'refs'; my $class = shift; $class = ref($class) || $class; my $linear_isa = mro::get_linear_isa( $class ); return { BUILD => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::BUILD" } reverse @$linear_isa ], DEMOLISH => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::DEMOLISH" } @$linear_isa ], HAS_BUILDARGS => $class->can('BUILDARGS'), HAS_FOREIGNBUILDARGS => $class->can('FOREIGNBUILDARGS'), }; } # Standard Moose/Moo-style constructor sub new { my $class = ref($_[0]) ? ref(shift) : shift; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $self = bless {}, $class; my $args = $meta->{HAS_BUILDARGS} ? $class->BUILDARGS( @_ ) : { ( @_ == 1 ) ? %{$_[0]} : @_ }; my $no_build = delete $args->{__no_BUILD__}; # Attribute attr (type: Any) # has declaration, file lib/MyTest/TestClass/Scalar.pm, line 42 do { my $value = exists( $args->{"attr"} ) ? $args->{"attr"} : $MyTest::TestClass::Scalar::__attr_DEFAULT__->( $self ); (!!1) or MyTest::Mite::croak "Type check failed in constructor: %s should be %s", "attr", "Any"; $self->{"attr"} = $value; }; # Call BUILD methods $self->BUILDALL( $args ) if ( ! $no_build and @{ $meta->{BUILD} || [] } ); # Unrecognized parameters my @unknown = grep not( /\Aattr\z/ ), keys %{$args}; @unknown and MyTest::Mite::croak( "Unexpected keys in constructor: " . join( q[, ], sort @unknown ) ); return $self; } # Used by constructor to call BUILD methods sub BUILDALL { my $class = ref( $_[0] ); my $meta = ( $Mite::META{$class} ||= $class->__META__ ); $_->( @_ ) for @{ $meta->{BUILD} || [] }; } # Destructor should call DEMOLISH methods sub DESTROY { my $self = shift; my $class = ref( $self ) || $self; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $in_global_destruction = defined ${^GLOBAL_PHASE} ? ${^GLOBAL_PHASE} eq 'DESTRUCT' : Devel::GlobalDestruction::in_global_destruction(); for my $demolisher ( @{ $meta->{DEMOLISH} || [] } ) { my $e = do { local ( $?, $@ ); eval { $demolisher->( $self, $in_global_destruction ) }; $@; }; no warnings 'misc'; # avoid (in cleanup) warnings die $e if $e; # rethrow } return; } my $__XS = !$ENV{PERL_ONLY} && eval { require Class::XSAccessor; Class::XSAccessor->VERSION("1.19") }; # Accessors for attr # has declaration, file lib/MyTest/TestClass/Scalar.pm, line 42 if ( $__XS ) { Class::XSAccessor->import( chained => 1, "getters" => { "attr" => "attr" }, ); } else { *attr = sub { @_ == 1 or MyTest::Mite::croak( 'Reader "attr" usage: $self->attr()' ); $_[0]{"attr"} }; } sub _set_attr { @_ == 2 or MyTest::Mite::croak( 'Writer "_set_attr" usage: $self->_set_attr( $newvalue )' ); (!!1) or MyTest::Mite::croak( "Type check failed in %s: value should be %s", "writer", "Any" ); $_[0]{"attr"} = $_[1]; $_[0]; } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can( 'does_role' ) and $meta->does_role( $role ) and return 1; } return $self->SUPER::DOES( $role ); } # Alias for Moose/Moo-compatibility sub does { shift->DOES( @_ ); } 1; }String.pm000664001750001750 232214772476615 22377 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTest/TestClasspackage MyTest::TestClass::String; use MyTest::Mite; use Sub::HandlesVia; has attr => ( is => 'rwp', isa => 'Str', handles_via => 'String', handles => { 'my_append' => 'append', 'my_chomp' => 'chomp', 'my_chop' => 'chop', 'my_clear' => 'clear', 'my_cmp' => 'cmp', 'my_cmpi' => 'cmpi', 'my_contains' => 'contains', 'my_contains_i' => 'contains_i', 'my_ends_with' => 'ends_with', 'my_ends_with_i' => 'ends_with_i', 'my_eq' => 'eq', 'my_eqi' => 'eqi', 'my_fc' => 'fc', 'my_ge' => 'ge', 'my_gei' => 'gei', 'my_get' => 'get', 'my_gt' => 'gt', 'my_gti' => 'gti', 'my_inc' => 'inc', 'my_lc' => 'lc', 'my_le' => 'le', 'my_lei' => 'lei', 'my_length' => 'length', 'my_lt' => 'lt', 'my_lti' => 'lti', 'my_match' => 'match', 'my_match_i' => 'match_i', 'my_ne' => 'ne', 'my_nei' => 'nei', 'my_prepend' => 'prepend', 'my_replace' => 'replace', 'my_replace_globally' => 'replace_globally', 'my_reset' => 'reset', 'my_set' => 'set', 'my_starts_with' => 'starts_with', 'my_starts_with_i' => 'starts_with_i', 'my_substr' => 'substr', 'my_uc' => 'uc', }, default => sub { q[] }, ); 1; String.pm.mite.pm000664001750001750 1115414772476615 23772 0ustar00taitai000000000000Sub-HandlesVia-0.050002/t/40mite/lib/MyTest/TestClass{ package MyTest::TestClass::String; use strict; use warnings; no warnings qw( once void ); our $USES_MITE = "Mite::Class"; our $MITE_SHIM = "MyTest::Mite"; our $MITE_VERSION = "0.010008"; # Mite keywords BEGIN { my ( $SHIM, $CALLER ) = ( "MyTest::Mite", "MyTest::TestClass::String" ); ( *after, *around, *before, *extends, *has, *signature_for, *with ) = do { package MyTest::Mite; no warnings 'redefine'; ( sub { $SHIM->HANDLE_after( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_around( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_before( $CALLER, "class", @_ ) }, sub {}, sub { $SHIM->HANDLE_has( $CALLER, has => @_ ) }, sub { $SHIM->HANDLE_signature_for( $CALLER, "class", @_ ) }, sub { $SHIM->HANDLE_with( $CALLER, @_ ) }, ); }; }; # Gather metadata for constructor and destructor sub __META__ { no strict 'refs'; my $class = shift; $class = ref($class) || $class; my $linear_isa = mro::get_linear_isa( $class ); return { BUILD => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::BUILD" } reverse @$linear_isa ], DEMOLISH => [ map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } map { "$_\::DEMOLISH" } @$linear_isa ], HAS_BUILDARGS => $class->can('BUILDARGS'), HAS_FOREIGNBUILDARGS => $class->can('FOREIGNBUILDARGS'), }; } # Standard Moose/Moo-style constructor sub new { my $class = ref($_[0]) ? ref(shift) : shift; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $self = bless {}, $class; my $args = $meta->{HAS_BUILDARGS} ? $class->BUILDARGS( @_ ) : { ( @_ == 1 ) ? %{$_[0]} : @_ }; my $no_build = delete $args->{__no_BUILD__}; # Attribute attr (type: Str) # has declaration, file lib/MyTest/TestClass/String.pm, line 42 do { my $value = exists( $args->{"attr"} ) ? $args->{"attr"} : $MyTest::TestClass::String::__attr_DEFAULT__->( $self ); do { package MyTest::Mite; defined($value) and do { ref(\$value) eq 'SCALAR' or ref(\(my $val = $value)) eq 'SCALAR' } } or MyTest::Mite::croak "Type check failed in constructor: %s should be %s", "attr", "Str"; $self->{"attr"} = $value; }; # Call BUILD methods $self->BUILDALL( $args ) if ( ! $no_build and @{ $meta->{BUILD} || [] } ); # Unrecognized parameters my @unknown = grep not( /\Aattr\z/ ), keys %{$args}; @unknown and MyTest::Mite::croak( "Unexpected keys in constructor: " . join( q[, ], sort @unknown ) ); return $self; } # Used by constructor to call BUILD methods sub BUILDALL { my $class = ref( $_[0] ); my $meta = ( $Mite::META{$class} ||= $class->__META__ ); $_->( @_ ) for @{ $meta->{BUILD} || [] }; } # Destructor should call DEMOLISH methods sub DESTROY { my $self = shift; my $class = ref( $self ) || $self; my $meta = ( $Mite::META{$class} ||= $class->__META__ ); my $in_global_destruction = defined ${^GLOBAL_PHASE} ? ${^GLOBAL_PHASE} eq 'DESTRUCT' : Devel::GlobalDestruction::in_global_destruction(); for my $demolisher ( @{ $meta->{DEMOLISH} || [] } ) { my $e = do { local ( $?, $@ ); eval { $demolisher->( $self, $in_global_destruction ) }; $@; }; no warnings 'misc'; # avoid (in cleanup) warnings die $e if $e; # rethrow } return; } my $__XS = !$ENV{PERL_ONLY} && eval { require Class::XSAccessor; Class::XSAccessor->VERSION("1.19") }; # Accessors for attr # has declaration, file lib/MyTest/TestClass/String.pm, line 42 if ( $__XS ) { Class::XSAccessor->import( chained => 1, "getters" => { "attr" => "attr" }, ); } else { *attr = sub { @_ == 1 or MyTest::Mite::croak( 'Reader "attr" usage: $self->attr()' ); $_[0]{"attr"} }; } sub _set_attr { @_ == 2 or MyTest::Mite::croak( 'Writer "_set_attr" usage: $self->_set_attr( $newvalue )' ); do { package MyTest::Mite; defined($_[1]) and do { ref(\$_[1]) eq 'SCALAR' or ref(\(my $val = $_[1])) eq 'SCALAR' } } or MyTest::Mite::croak( "Type check failed in %s: value should be %s", "writer", "Str" ); $_[0]{"attr"} = $_[1]; $_[0]; } # See UNIVERSAL sub DOES { my ( $self, $role ) = @_; our %DOES; return $DOES{$role} if exists $DOES{$role}; return 1 if $role eq __PACKAGE__; if ( $INC{'Moose/Util.pm'} and my $meta = Moose::Util::find_meta( ref $self or $self ) ) { $meta->can( 'does_role' ) and $meta->does_role( $role ) and return 1; } return $self->SUPER::DOES( $role ); } # Alias for Moose/Moo-compatibility sub does { shift->DOES( @_ ); } 1; }