COPYRIGHT000664001750001750 640013731701653 14365 0ustar00taitai000000000000Sub-HandlesVia-0.016Format: 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: Changes META.json META.yml dist.ini doap.ttl lib/Sub/HandlesVia/Handler.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/Toolkit/Moo.pm lib/Sub/HandlesVia/Toolkit/Moose.pm lib/Sub/HandlesVia/Toolkit/Mouse.pm lib/Sub/HandlesVia/Toolkit/Plain.pm t/00begin.t t/02moo.t 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.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/role.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/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_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/95any.t t/96foreach.t t/97pickrandom.t t/98apply.t t/99headtail.t Copyright: Copyright 2020 Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: README lib/Sub/HandlesVia.pm lib/Sub/HandlesVia/Toolkit.pm t/01basic.t Copyright: This software is copyright (c) 2020 by Toby Inkster. License: GPL-1.0+ or Artistic-1.0 Files: COPYRIGHT CREDITS SIGNATURE Copyright: None License: public-domain Files: INSTALL LICENSE Copyright: Unknown License: Unknown Files: Makefile.PL Copyright: Copyright 2013 Toby Inkster. License: GPL-1.0+ or Artistic-1.0 License: Artistic-1.0 This software is Copyright (c) 2020 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) 2020 by the copyright holder(s). This is free software, licensed under: The GNU General Public License, Version 1, February 1989 CREDITS000664001750001750 7113731701652 14047 0ustar00taitai000000000000Sub-HandlesVia-0.016Maintainer: - Toby Inkster (TOBYINK) Changes000664001750001750 603513731701652 14370 0ustar00taitai000000000000Sub-HandlesVia-0.016Sub-HandlesVia ============== Created: 2020-01-18 Home page: Bug tracker: Maintainer: Toby Inkster (TOBYINK) 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 170413731701652 14124 0ustar00taitai000000000000Sub-HandlesVia-0.016 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 4365513731701652 14133 0ustar00taitai000000000000Sub-HandlesVia-0.016This 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. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2020 by 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 Artistic License 1.0 --- This software is Copyright (c) 2020 by Toby Inkster. This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End MANIFEST000664001750001750 442413731701653 14227 0ustar00taitai000000000000Sub-HandlesVia-0.016COPYRIGHT CREDITS Changes INSTALL LICENSE MANIFEST META.json META.yml Makefile.PL README SIGNATURE dist.ini doap.ttl lib/Sub/HandlesVia.pm lib/Sub/HandlesVia/Handler.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/Toolkit.pm lib/Sub/HandlesVia/Toolkit/Moo.pm lib/Sub/HandlesVia/Toolkit/Moose.pm lib/Sub/HandlesVia/Toolkit/Mouse.pm lib/Sub/HandlesVia/Toolkit/Plain.pm t/00begin.t t/01basic.t t/02moo.t 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.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/role.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/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_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/95any.t t/96foreach.t t/97pickrandom.t t/98apply.t t/99headtail.t META.json000664001750001750 1263713731701653 14544 0ustar00taitai000000000000Sub-HandlesVia-0.016{ "abstract" : "alternative handles_via implementation", "author" : [ "Toby Inkster (TOBYINK) " ], "dynamic_config" : 0, "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" } }, "runtime" : { "recommends" : { "Sub::Util" : "0" }, "requires" : { "Class::Method::Modifiers" : "0", "Class::Tiny" : "0", "Eval::TypeTiny" : "0", "Exporter::Shiny" : "0", "List::Util" : "1.54", "Role::Tiny" : "0", "Type::Params" : "1.004000", "Types::Standard" : "0", "perl" : "5.008" } }, "test" : { "recommends" : { "Class::Tiny" : "0", "Moo" : "0", "MooX::TypeTiny" : "0", "Moose" : "0", "Mouse" : "0" }, "requires" : { "Test::Fatal" : "0", "Test::More" : "0.96", "Test::Requires" : "0" } } }, "provides" : { "Sub::HandlesVia" : { "file" : "lib/Sub/HandlesVia.pm", "version" : "0.016" }, "Sub::HandlesVia::Handler" : { "file" : "lib/Sub/HandlesVia/Handler.pm", "version" : "0.016" }, "Sub::HandlesVia::Handler::CodeRef" : { "file" : "lib/Sub/HandlesVia/Handler.pm", "version" : "0.016" }, "Sub::HandlesVia::Handler::Traditional" : { "file" : "lib/Sub/HandlesVia/Handler.pm", "version" : "0.016" }, "Sub::HandlesVia::HandlerLibrary" : { "file" : "lib/Sub/HandlesVia/HandlerLibrary.pm", "version" : "0.016" }, "Sub::HandlesVia::HandlerLibrary::Array" : { "file" : "lib/Sub/HandlesVia/HandlerLibrary/Array.pm", "version" : "0.016" }, "Sub::HandlesVia::HandlerLibrary::Bool" : { "file" : "lib/Sub/HandlesVia/HandlerLibrary/Bool.pm", "version" : "0.016" }, "Sub::HandlesVia::HandlerLibrary::Code" : { "file" : "lib/Sub/HandlesVia/HandlerLibrary/Code.pm", "version" : "0.016" }, "Sub::HandlesVia::HandlerLibrary::Counter" : { "file" : "lib/Sub/HandlesVia/HandlerLibrary/Counter.pm", "version" : "0.016" }, "Sub::HandlesVia::HandlerLibrary::Hash" : { "file" : "lib/Sub/HandlesVia/HandlerLibrary/Hash.pm", "version" : "0.016" }, "Sub::HandlesVia::HandlerLibrary::Number" : { "file" : "lib/Sub/HandlesVia/HandlerLibrary/Number.pm", "version" : "0.016" }, "Sub::HandlesVia::HandlerLibrary::Scalar" : { "file" : "lib/Sub/HandlesVia/HandlerLibrary/Scalar.pm", "version" : "0.016" }, "Sub::HandlesVia::HandlerLibrary::String" : { "file" : "lib/Sub/HandlesVia/HandlerLibrary/String.pm", "version" : "0.016" }, "Sub::HandlesVia::Toolkit" : { "file" : "lib/Sub/HandlesVia/Toolkit.pm", "version" : "0.016" }, "Sub::HandlesVia::Toolkit::Moo" : { "file" : "lib/Sub/HandlesVia/Toolkit/Moo.pm", "version" : "0.016" }, "Sub::HandlesVia::Toolkit::Moose" : { "file" : "lib/Sub/HandlesVia/Toolkit/Moose.pm", "version" : "0.016" }, "Sub::HandlesVia::Toolkit::Moose::PackageTrait" : { "file" : "lib/Sub/HandlesVia/Toolkit/Moose.pm", "version" : "0.016" }, "Sub::HandlesVia::Toolkit::Moose::RoleTrait" : { "file" : "lib/Sub/HandlesVia/Toolkit/Moose.pm", "version" : "0.016" }, "Sub::HandlesVia::Toolkit::Mouse" : { "file" : "lib/Sub/HandlesVia/Toolkit/Mouse.pm", "version" : "0.016" }, "Sub::HandlesVia::Toolkit::Mouse::PackageTrait" : { "file" : "lib/Sub/HandlesVia/Toolkit/Mouse.pm", "version" : "0.016" }, "Sub::HandlesVia::Toolkit::Mouse::RoleTrait" : { "file" : "lib/Sub/HandlesVia/Toolkit/Mouse.pm", "version" : "0.016" }, "Sub::HandlesVia::Toolkit::Plain" : { "file" : "lib/Sub/HandlesVia/Toolkit/Plain.pm", "version" : "0.016" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://rt.cpan.org/Dist/Display.html?Queue=Sub-HandlesVia" }, "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.016", "x_serialization_backend" : "JSON::PP version 2.27400_02", "x_static_install" : 1 } META.yml000664001750001750 701313731701653 14344 0ustar00taitai000000000000Sub-HandlesVia-0.016--- abstract: 'alternative handles_via implementation' author: - 'Toby Inkster (TOBYINK) ' build_requires: Test::Fatal: '0' Test::More: '0.96' Test::Requires: '0' configure_requires: ExtUtils::MakeMaker: '6.17' dynamic_config: 0 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.016' Sub::HandlesVia::Handler: file: lib/Sub/HandlesVia/Handler.pm version: '0.016' Sub::HandlesVia::Handler::CodeRef: file: lib/Sub/HandlesVia/Handler.pm version: '0.016' Sub::HandlesVia::Handler::Traditional: file: lib/Sub/HandlesVia/Handler.pm version: '0.016' Sub::HandlesVia::HandlerLibrary: file: lib/Sub/HandlesVia/HandlerLibrary.pm version: '0.016' Sub::HandlesVia::HandlerLibrary::Array: file: lib/Sub/HandlesVia/HandlerLibrary/Array.pm version: '0.016' Sub::HandlesVia::HandlerLibrary::Bool: file: lib/Sub/HandlesVia/HandlerLibrary/Bool.pm version: '0.016' Sub::HandlesVia::HandlerLibrary::Code: file: lib/Sub/HandlesVia/HandlerLibrary/Code.pm version: '0.016' Sub::HandlesVia::HandlerLibrary::Counter: file: lib/Sub/HandlesVia/HandlerLibrary/Counter.pm version: '0.016' Sub::HandlesVia::HandlerLibrary::Hash: file: lib/Sub/HandlesVia/HandlerLibrary/Hash.pm version: '0.016' Sub::HandlesVia::HandlerLibrary::Number: file: lib/Sub/HandlesVia/HandlerLibrary/Number.pm version: '0.016' Sub::HandlesVia::HandlerLibrary::Scalar: file: lib/Sub/HandlesVia/HandlerLibrary/Scalar.pm version: '0.016' Sub::HandlesVia::HandlerLibrary::String: file: lib/Sub/HandlesVia/HandlerLibrary/String.pm version: '0.016' Sub::HandlesVia::Toolkit: file: lib/Sub/HandlesVia/Toolkit.pm version: '0.016' Sub::HandlesVia::Toolkit::Moo: file: lib/Sub/HandlesVia/Toolkit/Moo.pm version: '0.016' Sub::HandlesVia::Toolkit::Moose: file: lib/Sub/HandlesVia/Toolkit/Moose.pm version: '0.016' Sub::HandlesVia::Toolkit::Moose::PackageTrait: file: lib/Sub/HandlesVia/Toolkit/Moose.pm version: '0.016' Sub::HandlesVia::Toolkit::Moose::RoleTrait: file: lib/Sub/HandlesVia/Toolkit/Moose.pm version: '0.016' Sub::HandlesVia::Toolkit::Mouse: file: lib/Sub/HandlesVia/Toolkit/Mouse.pm version: '0.016' Sub::HandlesVia::Toolkit::Mouse::PackageTrait: file: lib/Sub/HandlesVia/Toolkit/Mouse.pm version: '0.016' Sub::HandlesVia::Toolkit::Mouse::RoleTrait: file: lib/Sub/HandlesVia/Toolkit/Mouse.pm version: '0.016' Sub::HandlesVia::Toolkit::Plain: file: lib/Sub/HandlesVia/Toolkit/Plain.pm version: '0.016' recommends: Sub::Util: '0' requires: Class::Method::Modifiers: '0' Class::Tiny: '0' Eval::TypeTiny: '0' Exporter::Shiny: '0' List::Util: '1.54' Role::Tiny: '0' Type::Params: '1.004000' Types::Standard: '0' perl: '5.008' resources: Identifier: http://purl.org/NET/cpan-uri/dist/Sub-HandlesVia/project bugtracker: http://rt.cpan.org/Dist/Display.html?Queue=Sub-HandlesVia homepage: https://metacpan.org/release/Sub-HandlesVia license: http://dev.perl.org/licenses/ repository: git://github.com/tobyink/p5-sub-handlesvia.git version: '0.016' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' x_static_install: 1 Makefile.PL000664001750001750 2670413731701653 15075 0ustar00taitai000000000000Sub-HandlesVia-0.016use 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" => 0, "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 } }, runtime => { recommends => { "Sub::Util" => 0 }, requires => { "Class::Method::Modifiers" => 0, "Class::Tiny" => 0, "Eval::TypeTiny" => 0, "Exporter::Shiny" => 0, "List::Util" => 1.54, "perl" => 5.008, "Role::Tiny" => 0, "Type::Params" => "1.004000", "Types::Standard" => 0, }, }, test => { recommends => { "Class::Tiny" => 0, "Moo" => 0, "Moose" => 0, "MooX::TypeTiny" => 0, "Mouse" => 0, }, requires => { "Test::Fatal" => 0, "Test::More" => 0.96, "Test::Requires" => 0 }, }, }, "provides" => { "Sub::HandlesVia" => { file => "lib/Sub/HandlesVia.pm", version => 0.016 }, "Sub::HandlesVia::Handler" => { file => "lib/Sub/HandlesVia/Handler.pm", version => 0.016 }, "Sub::HandlesVia::Handler::CodeRef" => { file => "lib/Sub/HandlesVia/Handler.pm", version => 0.016 }, "Sub::HandlesVia::Handler::Traditional" => { file => "lib/Sub/HandlesVia/Handler.pm", version => 0.016 }, "Sub::HandlesVia::HandlerLibrary" => { file => "lib/Sub/HandlesVia/HandlerLibrary.pm", version => 0.016 }, "Sub::HandlesVia::HandlerLibrary::Array" => { file => "lib/Sub/HandlesVia/HandlerLibrary/Array.pm", version => 0.016, }, "Sub::HandlesVia::HandlerLibrary::Bool" => { file => "lib/Sub/HandlesVia/HandlerLibrary/Bool.pm", version => 0.016, }, "Sub::HandlesVia::HandlerLibrary::Code" => { file => "lib/Sub/HandlesVia/HandlerLibrary/Code.pm", version => 0.016, }, "Sub::HandlesVia::HandlerLibrary::Counter" => { file => "lib/Sub/HandlesVia/HandlerLibrary/Counter.pm", version => 0.016, }, "Sub::HandlesVia::HandlerLibrary::Hash" => { file => "lib/Sub/HandlesVia/HandlerLibrary/Hash.pm", version => 0.016, }, "Sub::HandlesVia::HandlerLibrary::Number" => { file => "lib/Sub/HandlesVia/HandlerLibrary/Number.pm", version => 0.016, }, "Sub::HandlesVia::HandlerLibrary::Scalar" => { file => "lib/Sub/HandlesVia/HandlerLibrary/Scalar.pm", version => 0.016, }, "Sub::HandlesVia::HandlerLibrary::String" => { file => "lib/Sub/HandlesVia/HandlerLibrary/String.pm", version => 0.016, }, "Sub::HandlesVia::Toolkit" => { file => "lib/Sub/HandlesVia/Toolkit.pm", version => 0.016 }, "Sub::HandlesVia::Toolkit::Moo" => { file => "lib/Sub/HandlesVia/Toolkit/Moo.pm", version => 0.016 }, "Sub::HandlesVia::Toolkit::Moose" => { file => "lib/Sub/HandlesVia/Toolkit/Moose.pm", version => 0.016 }, "Sub::HandlesVia::Toolkit::Moose::PackageTrait" => { file => "lib/Sub/HandlesVia/Toolkit/Moose.pm", version => 0.016 }, "Sub::HandlesVia::Toolkit::Moose::RoleTrait" => { file => "lib/Sub/HandlesVia/Toolkit/Moose.pm", version => 0.016 }, "Sub::HandlesVia::Toolkit::Mouse" => { file => "lib/Sub/HandlesVia/Toolkit/Mouse.pm", version => 0.016 }, "Sub::HandlesVia::Toolkit::Mouse::PackageTrait" => { file => "lib/Sub/HandlesVia/Toolkit/Mouse.pm", version => 0.016 }, "Sub::HandlesVia::Toolkit::Mouse::RoleTrait" => { file => "lib/Sub/HandlesVia/Toolkit/Mouse.pm", version => 0.016 }, "Sub::HandlesVia::Toolkit::Plain" => { file => "lib/Sub/HandlesVia/Toolkit/Plain.pm", version => 0.016 }, }, "release_status" => "stable", "resources" => { bugtracker => { web => "http://rt.cpan.org/Dist/Display.html?Queue=Sub-HandlesVia", }, 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.016, "x_static_install" => 1, }; my %dynamic_config; 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" }, %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; } } sub FixMakefile { return unless -d 'inc'; my $file = shift; local *MAKEFILE; open MAKEFILE, "< $file" or die "FixMakefile: Couldn't open $file: $!; bailing out"; my $makefile = do { local $/; }; close MAKEFILE or die $!; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; open MAKEFILE, "> $file" or die "FixMakefile: Couldn't open $file: $!; bailing out"; print MAKEFILE $makefile or die $!; close MAKEFILE or die $!; } my $mm = WriteMakefile(%WriteMakefileArgs); FixMakefile($mm->{FIRST_MAKEFILE} || 'Makefile'); exit(0); README000664001750001750 4507713731701652 14006 0ustar00taitai000000000000Sub-HandlesVia-0.016NAME 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. Also, unlike MooX::HandlesVia, it honours type constraints, plus it doesn't have the limitation that it can't mutate non-reference values. Using with Moo You should be able to use it as a drop-in replacement for MooX::HandlesVia. 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', }, ); } Using with Mouse It works the same as Moo basically. 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', }, ); } You are not forced to use Types::Standard. Mouse native types should 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', }, ); } Sub::HandlesVia will also recognize MooseX::NativeTraits-style traits. It will jump in and handle them before MooseX::NativeTraits 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', }, ); } (If you have a mouse in your kitchen though, that might not be very hygienic.) Using with Moose It works the same as Mouse basically. 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', }, ); } You are not forced to use Types::Standard. Moose native types should 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', }, ); } 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', }, ); } (If you have a moose in your kitchen, that might be even worse than the mouse.) Using with Anything 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 `has` 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 { use Class::Tiny { food => sub { [] }, }; use Sub::HandlesVia qw( delegations ); delegations( attribute => 'food' handles_via => 'Array', handles => { 'add_food' => 'push', 'find_food' => 'grep', }, ); } Setting `attribute` to "food" means that when Sub::HandlesVia needs to get the food list, it will call `$kitchen->food` and when it needs to set the food list, it will call `$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 `delegations` function can be imported into Moo/Mouse/Moose classes too, in which case the `attribute` needs to be the same attribute name you passed to `has`. You cannot use a arrayref, coderef, hash key, or array index.) What methods can be delegated to? The following table compares Sub::HandlesVia with Data::Perl, Moose native traits, and MouseX::NativeTraits. 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 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_method : SubHV Moose Mouse Counter ========================================= dec : SubHV DataP Moose Mouse inc : SubHV DataP Moose Mouse reset : SubHV DataP Moose Mouse set : SubHV Moose Mouse 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 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 div : SubHV DataP Moose Mouse get : SubHV mod : SubHV DataP Moose Mouse mul : SubHV DataP Moose Mouse set : SubHV Moose sub : SubHV DataP Moose Mouse String ========================================== append : SubHV DataP Moose Mouse chomp : SubHV DataP Moose Mouse chop : SubHV DataP Moose Mouse clear : SubHV DataP Moose Mouse get : SubHV inc : SubHV DataP Moose Mouse length : SubHV DataP Moose Mouse match : SubHV DataP Moose Mouse prepend : SubHV DataP Moose Mouse replace : SubHV DataP Moose Mouse replace_globally : SubHV Mouse reset : SubHV set : SubHV substr : SubHV DataP Moose Mouse Method Chaining Say you have the following handles_via => 'Array', handles => { 'add_food' => 'push', 'find_food' => 'grep', 'remove_food' => 'pop', }, Now `$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 `remove_food` 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; Hand Waving Sub::HandlesVia tries to be strict by default, but you can tell it to be less rigourous checking method arguments, etc using the `~` prefix: handles_via => 'Array', handles => { 'find_food' => '~grep', }, CodeRefs You can delegate to coderefs: handles_via => 'Array', handles => { 'find_healthiest' => sub { my $foods = shift; ... }, } Named Methods Let's say "FoodList" is a class where instances are blessed arrayrefs of strings. isa => InstanceOf['FoodList'], handles_via => 'Array', handles => { 'find_food' => 'grep', 'find_healthiest_food' => 'find_healthiest', }, Now `$kitchen->find_food($coderef)` does this (which breaks encapsulation of course): my @result = grep $coderef->(), @{ $kitchen->food }; And `$kitchen->find_healthiest_food` does this: $kitchen->food->find_healthiest Basically, because `find_healthiest` isn't one of the methods offered by Sub::HandlesVia::HandlerList::Array, it assumes you want to call it on the arrayref like a proper method. Currying Favour 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', }, `$kitchen->get_food(0)` will return the first item on the list. `$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 ], }, Pick and Mix 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, `$object->ship_shape` will work nicely, but `$object->the_keys` will fail badly. Still, this sort of thing can kind of make sense if you have an object that overloads both `@{}` and `%{}`. Sometime a method will be ambiguous. For example, there's a `get` method for both hashes and arrays. In this case, the array one will win because you listed it first in `handles_via`. But you can be specific: isa => ArrayRef|HashRef, handles_via => [ 'Array', 'Hash' ], handles => { get_foo => 'Array->get', get_bar => 'Hash->get', } BUGS Please report any bugs to . (There are known bugs for Moose native types that do coercion.) SEE ALSO Moose, MouseX::NativeTraits, Data::Perl, MooX::HandlesVia. AUTHOR Toby Inkster . 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. 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 2312313731701653 14377 0ustar00taitai000000000000Sub-HandlesVia-0.016This file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.83. 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: SHA1 SHA256 1aab16ed874bb72bd4a5cd336c2a4815a14ff8b9169d6bee7b16397852c17113 COPYRIGHT SHA256 7977c02e031153dc91d6db9d2e803671d586e59bca2c5c3dc6211f29c04d92d6 CREDITS SHA256 b596d655c19cc71277a3d8a914d91d697d6c004ec5231e872ef96999d2f7d13c Changes SHA256 35bc6e48ae9f06aba42a170044f623d625a4825b6c1d960959ee0e286d5e8732 INSTALL SHA256 1fb7395e76eabf94c421912d7d0a4f7fa745d49e1acb76b222c21d605b66bd25 LICENSE SHA256 60a6e7d2dc914e3b813943a2d8ed3cecdc2c3f22a16f61c10687ba41df4416f5 MANIFEST SHA256 7b5e367e05c82be89276750f2afc2327dec633614b14ee26201591a8a3eefcdd META.json SHA256 137c3848d6b7552764fe91720b0071906c425b91186c54395dd3c91e01ab0276 META.yml SHA256 a0555fa55737c723030b8a6d2a2bd55b3c4dd43982a09b450015b2b3715f0b48 Makefile.PL SHA256 06d1ab82fb75a84bef5afab740a08cd1b20437dd6b01bc581de93519e3c5f344 README SHA256 19f3f459b9cfea0def44f03009e61bb836505472ebf33ff33082885276d4681c dist.ini SHA256 57305cfaeebb100fe03f42bfeb7d5ac71cf8448e01f61a49aa590da709786fbe doap.ttl SHA256 db9b0beb0d0eb5ee546940116846dc0af944b31f914e7b038b58345181d94aad lib/Sub/HandlesVia.pm SHA256 ebe1b1f2514b93ec750ad0a82a472b36cb2d2ae7d7a867b73581432fe0213467 lib/Sub/HandlesVia/Handler.pm SHA256 26113aefb80cd1dd082b782135fb06f190602b07449c219f89828f05324d630a lib/Sub/HandlesVia/HandlerLibrary.pm SHA256 9fbd65af7546c77d7d2b4229c1b0a997acd5ed4b30c27cd00679adc82b951e77 lib/Sub/HandlesVia/HandlerLibrary/Array.pm SHA256 79e7271609f6b350a07eea834464d862a47e8e62c51ad9338cc35b88a348bee6 lib/Sub/HandlesVia/HandlerLibrary/Bool.pm SHA256 9568206d648f6f7eeaa455cddf96e266aafd655c4d5e4c81f8f2c6be64fd9bbf lib/Sub/HandlesVia/HandlerLibrary/Code.pm SHA256 38164845019ffca83895e45c19cd457a9ddfb93e6a4a1bee4dc43e8af169dee0 lib/Sub/HandlesVia/HandlerLibrary/Counter.pm SHA256 5e9dcb7ae3887d291263a5bc0f60f830a880a78a61f9b687f3bdcea1b78a8c41 lib/Sub/HandlesVia/HandlerLibrary/Hash.pm SHA256 f8551ffc67f23568adb5beabe8214dde1fc10ac84ff052be337a2042f4a1b1a1 lib/Sub/HandlesVia/HandlerLibrary/Number.pm SHA256 831d4f78c822a4d47be021baad5f5d4e47d345e7654382985e3ad88db37c4f40 lib/Sub/HandlesVia/HandlerLibrary/Scalar.pm SHA256 c4f61f9be510ec960dbecb9f607dd2acc2284527b14c415ee91a09485e1c554f lib/Sub/HandlesVia/HandlerLibrary/String.pm SHA256 f6644208595fb3895cfb965e3c2d13e349bc2fe8c6b5384c31a12c9d5e192400 lib/Sub/HandlesVia/Toolkit.pm SHA256 7137c9dff539abe691d0fc60e2951583d4dd4854d9a6938dbb31538ac25634fc lib/Sub/HandlesVia/Toolkit/Moo.pm SHA256 23b76f965ad6ca777ebd61e57d95d8b51be18be50cc075a8d67fa538b896055c lib/Sub/HandlesVia/Toolkit/Moose.pm SHA256 3f718453241113e9c220bda35713bb216da9e53a15d1c5bb7f55e763e7d93ab4 lib/Sub/HandlesVia/Toolkit/Mouse.pm SHA256 ecd73a2fb64e8617a002311ff32e110ae28a818f7a5330f6c438acdf1eea295a lib/Sub/HandlesVia/Toolkit/Plain.pm SHA256 2078046dd5726576304630c6f0ff72da1b938007a1cb49429327b569e689f81c t/00begin.t SHA256 5be3d6935e48a88ff74c38cd8a03e911b2f3d4f49ac639246e40b1e88e8fcb32 t/01basic.t SHA256 345d5ded3095f416270828ff24316643c1358172a49c6984694085e91eadd611 t/02moo.t SHA256 02a8dc13c7451b68163d1701b4e8ca520a463c4adea8166189d15852aeaab5b5 t/02moo/role.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 052088c0351edcbae45d46dbfe53274f4add46dcc28a8341174d9a96535dcdec 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 66b562d5320f176d8421bcf186f87d47c14053ea9cf9e3f5b2ddadfcc418782e t/04moose.t SHA256 5307fae95a9f4da426d32c874586da8317b9fe64f55d16d4c14f6a0c204c6387 t/04moose/role.t SHA256 f7c20da3d91e0fe191b63bb7f799e0171ad65c0fd182ccd2cb17c6cc0ebb0847 t/04moose/trait_array.t SHA256 7e12487be6b52cf3ec69cbad9e36e3d1154aeb78a0da4e657f7f8b5d393a3890 t/04moose/trait_bool.t SHA256 5217b6191882a3c3d309d0881f9e625caac628c13b60366768ac15b0709aea73 t/04moose/trait_code.t SHA256 548146f77322d735b468f619888bfd9efff56460341908ba4d3fe1c832b4890b t/04moose/trait_counter.t SHA256 c1cc4fd637e72a4b04ef81dfac84b0e04019eb7c03f56ecaf2689f495c068087 t/04moose/trait_hash.t SHA256 7751eaa29d58e68cf4211cfb0304fa405b8dfabe5806e51194223e4d084aa62a t/04moose/trait_number.t SHA256 64f5d5251746a767c6af942c60ebed6a2f3cf17317c1f420740a65c57680c0d2 t/04moose/trait_string.t SHA256 cbc1e78776b7abe41c903b5483eb3874316ce8950e2284ebf33a8053c521690a t/05moose_nativetypes.t SHA256 c0c5b5c9d933cdf2441672e4d34e95164c2b65221a2bb5d42db282972911f578 t/05moose_nativetypes/role.t SHA256 c1d10f77feb15cec3b861c0c9fcfe55f08be7014dfb0a6e6692f133d4fd2935c 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 26363dfbed646d07fabf40ab19bdec4bd47fc65a9e706fde18664f63fc3705ed t/06mouse.t SHA256 5d0c0e1fec6078628126d633b71f5071761d01c40cd1865fed386f98d320a441 t/06mouse/role.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 ce2e761b37116ddddbe21c9c920eeb40b471b249c10cc8a517b097008b62062a t/10barebones_eagerbuilder.t SHA256 8955063fd2bef08f522a25ca9f76507010d7b7590e660b96ed85ece611614f21 t/11delegation.t SHA256 ae5ec80935fce3ac9631c5de490b183b030e3605fddd092e4679a0af86110dc9 t/12slotaccess.t SHA256 c2b7cf16e9eab452e875e0303e5f4e7722d69ba4d5ada363caff9e807cfaa67c t/95any.t SHA256 f393205104cde3e714e7a078b801fed222fd941a366c2d9acde59e6ca93e282e t/96foreach.t SHA256 a21db55eaa70dd2775f35eb2537459446f4fbe9dd42910bdeda002b7de5eaf54 t/97pickrandom.t SHA256 18db1b856bacf0eff67b372a3802a85707d38e75a80d179cfcf85dcb1e63cfa2 t/98apply.t SHA256 d1effc82e9f28d40ae4ecedf5bea289029e3a29b714c4a5cf17892b44a0a86ca t/99headtail.t -----BEGIN PGP SIGNATURE----- iF0EARECAB0WIQRVJKj/4+s6z4WzNujOv4Eoaip9OQUCX2eDqwAKCRDOv4Eoaip9 OXOqAJ9lPTE9N6ncTUUxJBwBfMDHti7L7QCglqg/TZMeAUfX66wDX45Z3/yL5u4= =orX0 -----END PGP SIGNATURE----- dist.ini000664001750001750 10013731701652 14504 0ustar00taitai000000000000Sub-HandlesVia-0.016;;class='Dist::Inkt::Profile::TOBYINK' ;;name='Sub-HandlesVia' doap.ttl000664001750001750 4132313731701653 14565 0ustar00taitai000000000000Sub-HandlesVia-0.016@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:runtime-recommendation [ doap-deps:on "Sub::Util"^^doap-deps:CpanId ]; doap-deps:runtime-requirement [ doap-deps:on "perl 5.008"^^doap-deps:CpanId ], [ doap-deps:on "Types::Standard"^^doap-deps:CpanId ], [ doap-deps:on "Eval::TypeTiny"^^doap-deps:CpanId ], [ doap-deps:on "Exporter::Shiny"^^doap-deps:CpanId ], [ doap-deps:on "Type::Params 1.004000"^^doap-deps:CpanId; ], [ doap-deps:on "Types::Standard"^^doap-deps:CpanId ], [ doap-deps:on "Role::Tiny"^^doap-deps:CpanId ], [ doap-deps:on "Class::Tiny"^^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 "Moose"^^doap-deps:CpanId ], [ doap-deps:on "Mouse"^^doap-deps:CpanId ], [ 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:test-requirement [ doap-deps:on "Test::More 0.96"^^doap-deps:CpanId ], [ doap-deps:on "Test::Fatal"^^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 foaf:Person; foaf:mbox ; foaf:name "Toby Inkster"; foaf:nick "TOBYINK"; foaf:page . 00begin.t000664001750001750 326613731701652 14754 0ustar00taitai000000000000Sub-HandlesVia-0.016/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; require Devel::TypeTiny::Perl56Compat; 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 70313731701652 14723 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 516513731701652 14464 0ustar00taitai000000000000Sub-HandlesVia-0.016/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::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; 03moo_mxtt.t000664001750001750 526613731701652 15543 0ustar00taitai000000000000Sub-HandlesVia-0.016/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::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; 04moose.t000664001750001750 551313731701652 15013 0ustar00taitai000000000000Sub-HandlesVia-0.016/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::Bleh::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 331313731701652 17443 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 522213731701652 15020 0ustar00taitai000000000000Sub-HandlesVia-0.016/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::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; 07mouse_nativetypes.t000664001750001750 321513731701652 17454 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 166313731701652 15710 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 220513731701652 15631 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 223013731701652 20331 0ustar00taitai000000000000Sub-HandlesVia-0.016/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'); done_testing; 11delegation.t000664001750001750 221713731701652 16000 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 }; #require B::Deparse; #for my $method (qw/ spin wheel_ref wheel_colour /) { # diag("sub $method"); # diag(B::Deparse->new->coderef2text($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', ); done_testing; 12slotaccess.t000664001750001750 354613731701652 16037 0ustar00taitai000000000000Sub-HandlesVia-0.016/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;95any.t000664001750001750 67513731701652 14456 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 256013731701652 15312 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 140013731701652 16023 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 74413731701652 15014 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 202713731701652 15457 0ustar00taitai000000000000Sub-HandlesVia-0.016/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/ head tail /], ); } my $collection = Local::Class->new( collection => [qw/ a b c d e f /], ); # head is_deeply [$collection->head(0)], [], 'head(0)'; is_deeply [$collection->head(3)], [qw{a b c}], 'head(3)'; is_deeply [$collection->head(30)], [qw{a b c d e f}], 'head(30)'; is_deeply [$collection->head(-2)], [qw{a b c d}], 'head(-2)' or diag explain[ $collection->head(-2) ]; is_deeply [$collection->head(-30)], [], 'head(-30)' or diag explain[ $collection->head(-30) ]; # tail is_deeply [$collection->tail(0)], [], 'tail(0)'; is_deeply [$collection->tail(3)], [qw{d e f}], 'tail(3)'; is_deeply [$collection->tail(30)], [qw{a b c d e f}], 'tail(30)'; is_deeply [$collection->tail(-2)], [qw{c d e f}], 'tail(-2)'; is_deeply [$collection->tail(-30)], [], 'tail(-30)'; done_testing; HandlesVia.pm000664001750001750 4547713731701652 17005 0ustar00taitai000000000000Sub-HandlesVia-0.016/lib/Subuse 5.008; use strict; use warnings; package Sub::HandlesVia; use Exporter::Shiny qw( delegations ); our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.016'; 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, @_); if ($INC{'Moo/Role.pm'} 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'; } 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. Also, unlike L, it honours type constraints, plus it doesn't have the limitation that it can't mutate non-reference values. =head2 Using with Moo You should be able to use it as a drop-in replacement for L. 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', }, ); } =head2 Using with Mouse It works the same as Moo basically. 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', }, ); } You are not forced to use Types::Standard. Mouse native types should 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', }, ); } Sub::HandlesVia will also recognize L-style traits. 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', }, ); } (If you have a mouse in your kitchen though, that might not be very hygienic.) =head2 Using with Moose It works the same as Mouse basically. 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', }, ); } You are not forced to use Types::Standard. Moose native types should 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', }, ); } 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', }, ); } (If you have a moose in your kitchen, that might be even worse than the mouse.) =head2 Using with Anything 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 { use Class::Tiny { food => sub { [] }, }; 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.) =head2 What methods can be delegated to? 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 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_method : SubHV Moose Mouse Counter ========================================= dec : SubHV DataP Moose Mouse inc : SubHV DataP Moose Mouse reset : SubHV DataP Moose Mouse set : SubHV Moose Mouse 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 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 div : SubHV DataP Moose Mouse get : SubHV mod : SubHV DataP Moose Mouse mul : SubHV DataP Moose Mouse set : SubHV Moose sub : SubHV DataP Moose Mouse String ========================================== append : SubHV DataP Moose Mouse chomp : SubHV DataP Moose Mouse chop : SubHV DataP Moose Mouse clear : SubHV DataP Moose Mouse get : SubHV inc : SubHV DataP Moose Mouse length : SubHV DataP Moose Mouse match : SubHV DataP Moose Mouse prepend : SubHV DataP Moose Mouse replace : SubHV DataP Moose Mouse replace_globally : SubHV Mouse reset : SubHV set : SubHV substr : SubHV DataP Moose Mouse =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 Hand Waving Sub::HandlesVia tries to be strict by default, but you can tell it to be less rigourous checking method arguments, etc using the C<< ~ >> prefix: handles_via => 'Array', handles => { 'find_food' => '~grep', }, =head2 CodeRefs You can delegate to coderefs: handles_via => 'Array', handles => { 'find_healthiest' => sub { my $foods = shift; ... }, } =head2 Named Methods Let's say "FoodList" is a class where instances are blessed arrayrefs of strings. isa => InstanceOf['FoodList'], handles_via => 'Array', handles => { 'find_food' => 'grep', 'find_healthiest_food' => 'find_healthiest', }, Now C<< $kitchen->find_food($coderef) >> does this (which breaks encapsulation of course): my @result = grep $coderef->(), @{ $kitchen->food }; And C<< $kitchen->find_healthiest_food >> does this: $kitchen->food->find_healthiest Basically, because C isn't one of the methods offered by Sub::HandlesVia::HandlerList::Array, it assumes you want to call it on the arrayref like a proper method. =head2 Currying Favour 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 Pick and Mix 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 can kind of make sense if you have an object that overloads both C<< @{} >> and C<< %{} >>. Sometime a method 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_foo => 'Array->get', get_bar => 'Hash->get', } =head1 BUGS Please report any bugs to L. (There are known bugs for Moose native types that do coercion.) =head1 SEE ALSO L, L, L, L. =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. =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. role.t000664001750001750 156413731701652 15424 0ustar00taitai000000000000Sub-HandlesVia-0.016/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; trait_array.t000664001750001750 6333213731701652 17025 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 552113731701652 16616 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 562713731701652 16604 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 1123413731701652 17360 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 2205113731701652 16623 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 1025213731701652 17170 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 2301113731701652 17203 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 163713731701652 16502 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 6340513731701652 20103 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 557413731701652 17703 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 570213731701652 17653 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 1130713731701652 20436 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 2227313731701652 17706 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 1032513731701652 20246 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 2306413731701652 20270 0ustar00taitai000000000000Sub-HandlesVia-0.016/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; role.t000664001750001750 160613731701652 15753 0ustar00taitai000000000000Sub-HandlesVia-0.016/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; trait_array.t000664001750001750 6335113731701652 17360 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 550613731701652 17153 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 561413731701652 17132 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 1122313731701652 17710 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 2203613731701652 17160 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 1023713731701652 17525 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 2277613731701652 17556 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 153713731701652 20412 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 6336013731701652 22014 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 567513731701652 21616 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 555113731701652 21566 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 1132513731701652 22347 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 2217313731701652 21616 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 1042313731701652 22156 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 2300413731701652 22173 0ustar00taitai000000000000Sub-HandlesVia-0.016/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; role.t000664001750001750 160613731701652 15763 0ustar00taitai000000000000Sub-HandlesVia-0.016/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; trait_array.t000664001750001750 6355313731701652 17374 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 550613731701652 17163 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 561413731701652 17142 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 1122313731701652 17720 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 2203613731701652 17170 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 1023713731701652 17535 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 2277613731701652 17566 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 153713731701652 20422 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 6356613731701652 22034 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 570113731701652 21614 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 555513731701652 21602 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 1133113731701652 22354 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 2220213731701652 21617 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 1042713731701652 22172 0ustar00taitai000000000000Sub-HandlesVia-0.016/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 2301013731701652 22200 0ustar00taitai000000000000Sub-HandlesVia-0.016/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; Handler.pm000664001750001750 3077513731701652 20355 0ustar00taitai000000000000Sub-HandlesVia-0.016/lib/Sub/HandlesViause 5.008; use strict; use warnings; package Sub::HandlesVia::Handler; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.016'; use Class::Tiny ( qw( template lvalue_template args name signature curried is_chainable no_validation_needed additional_validation default_for_reset ), { is_mutator => sub { defined $_[0]{lvalue_template} or $_[0]{template} =~ /«/ }, min_args => sub { shift->args }, max_args => sub { shift->args }, usage => sub { shift->_build_usage }, }, ); sub has_min_args { defined shift->min_args } sub has_max_args { defined shift->max_args } 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 ('1;', {}); } if ($ti and $ti->{trust_mutated} eq 'maybe') { return ('1;', {}); } 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"; eval "require $class" unless $class eq $trait; if ($class->isa('Sub::HandlesVia::HandlerLibrary') and $class->can($method_name)) { $handler = $class->$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 _process_template { my ($self, $template, %callbacks) = @_; my $wrapper; my $getter = $callbacks{get}->(); if ($getter !~ /^ \$ # 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 and $template =~ /\$GET/) { # Getter is kind of complex (maybe includes function calls, etc # So only do it once. $getter =~ s/%/%%/g; $wrapper = "do { my \$shv_real_invocant = $getter; %s }"; $getter = '$shv_real_invocant'; } $template =~ s/\$GET/$getter/g; $template =~ s/\$ARG\[([0-9]+)\]/$callbacks{arg}->($1)/eg; $template =~ s/\$ARG/$callbacks{arg}->(1)/eg; $template =~ s/\$SELF/$callbacks{self}->()/eg; $template =~ s/\$SLOT/$callbacks{slot}->()/eg; $template =~ s/\#ARG/$callbacks{argc}->()/eg; $template =~ s/\@ARG/$callbacks{args}->()/eg; $template =~ s/«(.+?)»/$callbacks{set}->($1)/eg; $template =~ s/\$DEFAULT/$callbacks{default_for_reset}->($self, \%callbacks)/eg; $wrapper ? sprintf($wrapper, $template) : $template; } sub _coderef { my ($self, %callbacks) = @_; my $env = { %{$callbacks{env}||{}} }; my $min_args = $self->has_min_args ? $self->min_args : 0; my $max_args = $self->max_args; my @code = ('sub {'); push @code, sprintf('package %s::__SANDBOX__;', __PACKAGE__); my $sig_was_checked = 0; if (@{ $self->signature || [] }) { require Type::Params; unshift @code, 'my $__sigcheck;'; $env->{'@__sig'} = $self->signature; push @code, '$__sigcheck||=Type::Params::compile(1, @__sig);@_=&$__sigcheck;'; ++$sig_was_checked; } else { my $usg = sprintf( 'do { require Carp; Carp::croak("Wrong number of parameters; usage: ".%s) }', B::perlstring( $callbacks{usage_string}->($callbacks{method_name}, $self->usage) ), ); if (defined $min_args and defined $max_args and $min_args==$max_args) { push @code, sprintf('@_==%d or %s;', $min_args + 1, $usg); } elsif (defined $min_args and defined $max_args) { push @code, sprintf('(@_ >= %d and @_ <= %d) or %s;', $min_args + 1, $max_args + 1, $usg); } elsif (defined $min_args) { push @code, sprintf('@_ >= %d or %s;', $min_args + 1, $usg); } } if (my $curried = $self->curried) { if (grep ref, @$curried) { $env->{'@curry'} = $curried; push @code, $callbacks{curry}->('@curry'); } else { require B; push @code, $callbacks{curry}->(sprintf('(%s)', join ',', map { defined($_) ? B::perlstring($_) : 'undef' } @$curried)); } } my $something_can_go_wrong = $self->is_mutator && !!ref($callbacks{isa}); if ($self->no_validation_needed) { $something_can_go_wrong = 0; } if ($self->name =~ /^(Array|Hash):/) { my $getter = $callbacks{get}->(); if ($getter !~ /^ \$ # 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) { push @code, "my \$shv_ref_invocant = do { $getter };"; $callbacks{get} = sub { '$shv_ref_invocant' }; $callbacks{get_is_lvalue} = 1; } } my $add_later; if ($something_can_go_wrong and defined $self->additional_validation) { my ($add_code, $add_env, $later) = $self->_real_additional_validation->($self, $sig_was_checked, \%callbacks); if ($later) { $add_later = $add_code; $env->{$_} = $add_env->{$_} for keys %$add_env; $something_can_go_wrong = 0; } elsif ($add_code) { push @code, $add_code; $env->{$_} = $add_env->{$_} for keys %$add_env; $something_can_go_wrong = 0; } } if (!$something_can_go_wrong and !$callbacks{be_strict} and $callbacks{set_checks_isa} and defined $callbacks{simple_set}) { $callbacks{set} = $callbacks{simple_set}; } if ($something_can_go_wrong and not $callbacks{set_checks_isa}) { my $orig_set = delete $callbacks{set}; $callbacks{get_is_lvalue} = 0; $callbacks{set} = sub { my $value = shift; $orig_set->(sprintf( 'do { my $unchecked = %s; %s }', $value, $callbacks{isa}->inline_assert('$unchecked', '$finaltype'), )); }; $env->{'$finaltype'} = \$callbacks{isa}; $something_can_go_wrong = 0; } my $template = $self->template; if ($callbacks{get_is_lvalue} and !$callbacks{be_strict} and !$something_can_go_wrong) { $template = $self->lvalue_template if $self->lvalue_template; } my $body = $self->_process_template($template, %callbacks); $body =~ s/\"?____VALIDATION_HERE____\"?/$add_later/ if defined $add_later; push @code, $body; push @code, ';'.$callbacks{self}->() if $self->is_chainable; push @code, "}"; return ( source => \@code, environment => $env, description => sprintf("%s=%s", $callbacks{method_name}||'__ANON__', $self->name), ); } sub coderef { my ($self, %callbacks) = @_; my %eval = $self->_coderef(%callbacks); # warn join("\n", @{$eval{source}}); # for my $key (sort keys %{$eval{environment}}) { # warn ">> $key : ".ref($eval{environment}{$key}); # if ( ref($eval{environment}{$key}) eq 'REF' and ref(${$eval{environment}{$key}}) eq 'CODE' ) { # require B::Deparse; # warn B::Deparse->new->coderef2text(${$eval{environment}{$key}}); # } # } require Eval::TypeTiny; Eval::TypeTiny::eval_closure(%eval); } sub install_method { my ($self, %callbacks) = @_; my $target = $callbacks{target} or die; my $name = $callbacks{method_name} or die; my $coderef = $self->coderef(is_method => 1, %callbacks); if ( eval { require Sub::Util }) { $coderef = Sub::Util::set_subname("$target\::$name", $coderef); } elsif ( eval { require Sub::Name }) { $coderef = Sub::Name::subname("$target\::$name", $coderef); } if ($callbacks{install_method}) { $callbacks{install_method}->($name, $coderef); } elsif ($callbacks{install_method_fq}) { $callbacks{install_method}->("$target\::$name", $coderef); } else { no strict 'refs'; *{"$target\::$name"} = $coderef; } } sub code_as_string { my ($self, %callbacks) = @_; my %eval = $self->_coderef(%callbacks); my $code = join "\n", @{$eval{source}}; if ($callbacks{method_name}) { $code =~ s/sub/sub $callbacks{method_name}/xs; } if (eval { require Perl::Tidy }) { my $tidy = ''; Perl::Tidy::perltidy( source => \$code, destination => \$tidy, ); $code = $tidy; } $code; } 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; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.016'; BEGIN { our @ISA = 'Sub::HandlesVia::Handler' }; sub BUILD { $_[1]{name} or die 'name required'; } sub _coderef { my ($self, %callbacks) = @_; my @code = 'sub {'; push @code, sprintf('package %s::__SANDBOX__;', __PACKAGE__); my $env = {}; if (my $curried = $self->curried) { if (grep ref, @$curried) { $env->{'@curry'} = $curried; push @code, $callbacks{curry}->('@curry'); } else { require B; push @code, $callbacks{curry}->(sprintf('(%s)', join ',', map { defined($_) ? B::perlstring($_) : 'undef' } @$curried)); } } require B; my $q_name = B::perlstring($self->name); push @code, $self->_process_template('($GET)->${\\ '.$q_name.'}(@ARG)', %callbacks); push @code, ';'.$callbacks{self}->() if $self->is_chainable; push @code, '}'; return ( source => \@code, environment => $env, description => sprintf("%s=%s", $callbacks{method_name}||'__ANON__', $self->name), ); } package Sub::HandlesVia::Handler::CodeRef; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.016'; BEGIN { our @ISA = 'Sub::HandlesVia::Handler' }; use Class::Tiny qw( delegated_coderef ); sub BUILD { $_[1]{delegated_coderef} or die 'delegated_coderef required'; } sub _coderef { my ($self, %callbacks) = @_; my @code = 'sub {'; push @code, sprintf('package %s::__SANDBOX__;', __PACKAGE__); my $env = { '$shv_callback' => \($self->delegated_coderef) }; if (my $curried = $self->curried) { if (grep ref, @$curried) { $env->{'@curry'} = $curried; push @code, $callbacks{curry}->('@curry'); } else { require B; push @code, $callbacks{curry}->(sprintf('(%s)', join ',', map { defined($_) ? B::perlstring($_) : 'undef' } @$curried)); } } push @code, $self->_process_template('$shv_callback->($GET, @ARG)', %callbacks); push @code, ';'.$callbacks{self}->() if $self->is_chainable; push @code, '}'; return ( source => \@code, environment => $env, description => sprintf("%s=%s", $callbacks{method_name}||'__ANON__', '__ANON__'), ); } 1; HandlerLibrary.pm000664001750001750 55513731701652 21633 0ustar00taitai000000000000Sub-HandlesVia-0.016/lib/Sub/HandlesViause 5.008; use strict; use warnings; package Sub::HandlesVia::HandlerLibrary; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.016'; 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' }; } 1; Toolkit.pm000664001750001750 765313731701652 20404 0ustar00taitai000000000000Sub-HandlesVia-0.016/lib/Sub/HandlesViause 5.008; use strict; use warnings; package Sub::HandlesVia::Toolkit; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.016'; use Type::Params qw(compile_named_oo); use Types::Standard qw( ArrayRef HashRef Str Num Int CodeRef Bool ); use Types::Standard qw( assert_HashRef is_ArrayRef ); 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 $callbacks = $me->make_callbacks($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); # warn $handler->code_as_string( # %$callbacks, # target => $arg->target, # method_name => $h, # ); $handler->install_method( %$callbacks, target => $arg->target, method_name => $h, ); } } my %native = qw( Array 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, ); 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); if ($default_type{$joined} and not exists $spec->{isa}) { $spec->{isa} = $default_type{$joined}; $spec->{coerce} = 1 if $default_type{$joined}->has_coercion; } $spec->{handles} = { map +($_ => $_), @{ $spec->{handles} } } if is_ArrayRef $spec->{handles}; assert_HashRef $spec->{handles}; return { target => $target, attribute => $attr, handles_via => delete($spec->{handles_via}), handles => delete($spec->{handles}), }; } sub make_callbacks { my ($me, $target, $attr) = (shift, @_); die "must be implemented by child classes"; } 1; __END__ =pod =encoding utf-8 =head1 NAME Sub::HandlesVia::Toolkit - integration with OO frameworks for Sub::HandlesVia =head1 DESCRIPTION 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 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. Array.pm000664001750001750 5111313731701652 22745 0ustar00taitai000000000000Sub-HandlesVia-0.016/lib/Sub/HandlesVia/HandlerLibraryuse 5.008; use strict; use warnings; package Sub::HandlesVia::HandlerLibrary::Array; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.016'; use Sub::HandlesVia::HandlerLibrary; our @ISA = 'Sub::HandlesVia::HandlerLibrary'; use Sub::HandlesVia::Handler qw( handler ); use Types::Standard qw( ArrayRef Optional Str CodeRef Int Item Any Ref Defined FileHandle ); 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, $callbacks) = @_; my $ti = __PACKAGE__->_type_inspector($callbacks->{isa}); if ($ti and $ti->{trust_mutated} eq 'always') { return ('1;', {}); } if ($ti and $ti->{trust_mutated} eq 'maybe') { my $coercion = ($callbacks->{coerce} && $ti->{value_type}->has_coercion); my @rv = $coercion ? ( $self->_process_template( 'my @shv_values = map $shv_type_for_values->assert_coerce($_), @ARG;', %$callbacks, ), { '$shv_type_for_values' => \$ti->{value_type} }, ) : ( $self->_process_template( sprintf( 'my @shv_values = @ARG; for my $shv_value (@shv_values) { %s }', $ti->{value_type}->inline_assert('$shv_value', '$shv_type_for_values'), ), %$callbacks, ), { '$shv_type_for_values' => \$ti->{value_type} }, ); $callbacks->{'arg'} = sub { "\$shv_values[($_[0])-1]" }; $callbacks->{'args'} = sub { '@shv_values' }; return @rv; } return; }; my $additional_validation_for_set_and_insert = sub { my $self = CORE::shift; my ($sig_was_checked, $callbacks) = @_; my $ti = __PACKAGE__->_type_inspector($callbacks->{isa}); if ($ti and $ti->{trust_mutated} eq 'always') { return ('1;', {}); } if ($ti and $ti->{trust_mutated} eq 'maybe') { my $coercion = ($callbacks->{coerce} && $ti->{value_type}->has_coercion); my $orig = $callbacks->{'arg'}; $callbacks->{'arg'} = sub { return '$shv_index' if $_[0]=='1'; return '$shv_value' if $_[0]=='2'; goto &$orig; }; return ( $self->_process_template(sprintf( 'my($shv_index,$shv_value)=@ARG; %s;', $coercion ? '$shv_value=$shv_type_for_values->assert_coerce($shv_value)' : $ti->{value_type}->inline_assert('$shv_value', '$shv_type_for_values'), ), %$callbacks), { '$shv_type_for_values' => \$ti->{value_type} }, ) if $sig_was_checked; return ( $self->_process_template(sprintf( 'my($shv_index,$shv_value)=@ARG; %s; %s;', Int->inline_assert('$shv_index', '$Types_Standard_Int'), $coercion ? '$shv_value=$shv_type_for_values->assert_coerce($shv_value)' : $ti->{value_type}->inline_assert('$shv_value', '$shv_type_for_values'), ), %$callbacks), { '$Types_Standard_Int' => \(Int), '$shv_type_for_values' => \$ti->{value_type} }, ); } return; }; sub count { handler name => 'Array:count', args => 0, template => 'scalar(@{$GET})', } sub is_empty { handler name => 'Array:is_empty', args => 0, template => '!scalar(@{$GET})', } sub all { handler name => 'Array:all', args => 0, template => '@{$GET}', } sub elements { handler name => 'Array:elements', args => 0, template => '@{$GET}', } sub flatten { handler name => 'Array:flatten', args => 0, template => '@{$GET}', } sub get { handler name => 'Array:get', args => 1, signature => [Int], usage => '$index', template => '($GET)->[$ARG]', } 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', } 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)', additional_validation => $additional_validation_for_push_and_unshift, } 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', } 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)', additional_validation => $additional_validation_for_push_and_unshift, } sub clear { my $me = CORE::shift; handler name => 'Array:clear', args => 0, template => '«[]»', lvalue_template => '@{$GET} = ()', additional_validation => 'no incoming values', } sub first { require List::Util; handler name => 'Array:first', args => 1, signature => [CodeRef], usage => '$coderef', template => '&List::Util::first($ARG, @{$GET})', } sub any { require List::Util; handler name => 'Array:any', args => 1, signature => [CodeRef], usage => '$coderef', template => '&List::Util::any($ARG, @{$GET})', } sub first_index { my $me = __PACKAGE__; handler name => 'Array:first_index', args => 1, signature => [CodeRef], usage => '$coderef', template => $me.'::_firstidx($ARG, @{$GET})', } # Implementation from List::MoreUtils::PP. # Removed original prototype. sub _firstidx { my $f = CORE::shift; foreach my $i (0 .. $#_) { local *_ = \$_[$i]; return $i if $f->(); } return -1; } 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}', } 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, } 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, $callbacks) = @_; my $ti = __PACKAGE__->_type_inspector($callbacks->{isa}); if ($ti and $ti->{trust_mutated} eq 'always') { return ('1;', {}); } if ($ti and $ti->{trust_mutated} eq 'maybe') { my $coercion = ($callbacks->{coerce} && $ti->{value_type}->has_coercion); my $orig = $callbacks->{'arg'}; $callbacks->{'arg'} = sub { return '$shv_index' if $_[0]=='1'; return '$shv_value' if $_[0]=='2'; goto &$orig; }; return ( $self->_process_template(sprintf( 'my($shv_index,$shv_value)=@ARG; if (#ARG>1) { %s };', $coercion ? '$shv_value=$shv_type_for_values->assert_coerce($shv_value)' : $ti->{value_type}->inline_assert('$shv_value', '$shv_type_for_values'), ), %$callbacks), { '$shv_type_for_values' => \$ti->{value_type} }, ) if $sig_was_checked; return ( $self->_process_template(sprintf( 'my($shv_index,$shv_value)=@ARG; %s; if (#ARG>1) { %s };', Int->inline_assert('$shv_index', '$Types_Standard_Int'), $coercion ? '$shv_value=$shv_type_for_values->assert_coerce($shv_value)' : $ti->{value_type}->inline_assert('$shv_value', '$shv_type_for_values'), ), %$callbacks), { '$Types_Standard_Int' => \(Int), '$shv_type_for_values' => \$ti->{value_type} }, ); } return; }, } 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_iterator = '.$me.'::_natatime($ARG[1], @{$GET}); if ($ARG[2]) { while (my @shv_values = $shv_iterator->()) { $ARG[2]->(@shv_values) } } else { $shv_iterator }', } # Implementation from List::MoreUtils::PP. # Removed original prototype. sub _natatime { my $n = CORE::shift; my @list = @_; return sub { CORE::splice @list, 0, $n } } sub shallow_clone { handler name => 'Array:shallow_clone', args => 0, template => '[@{$GET}]', } sub map { handler name => 'Array:map', args => 1, signature => [CodeRef], usage => '$coderef', template => 'map($ARG->($_), @{$GET})', } sub grep { handler name => 'Array:grep', args => 1, signature => [CodeRef], usage => '$coderef', template => 'grep($ARG->($_), @{$GET})', } 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})', } sub reverse { handler name => 'Array:reverse', args => 0, template => 'reverse @{$GET}', } 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', } sub shuffle { require List::Util; handler name => 'Array:shuffle', args => 0, template => 'my @shv_return = List::Util::shuffle(@{$GET}); wantarray ? @shv_return : \@shv_return', } 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', } sub uniq { require List::Util; handler name => 'Array:uniq', args => 0, template => 'my @shv_return = List::Util::uniq(@{$GET}); wantarray ? @shv_return : \@shv_return', } 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', } sub uniqnum { require List::Util; handler name => 'Array:uniqnum', args => 0, template => 'my @shv_return = List::Util::uniqnum(@{$GET}); wantarray ? @shv_return : \@shv_return', } 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', } sub uniqstr { require List::Util; handler name => 'Array:uniqstr', args => 0, template => 'my @shv_return = List::Util::uniqstr(@{$GET}); wantarray ? @shv_return : \@shv_return', } 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', } sub splice { # luckily Int is fully inlinable because there's no way to # add to %environment from here!!! my $checks = sprintf( 'if (#ARG > 0) { %s }; if (#ARG > 1) { %s };', Int->inline_assert('$shv_index'), Int->inline_assert('$shv_length'), ); handler name => 'Array:splice', min_args => 1, usage => '$index, $length, @values', template => 'my @shv_tmp = @{$GET}; my ($shv_index, $shv_length, @shv_values) = @ARG;'.$checks.'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;'.$checks.';splice(@{$GET}, $shv_index, $shv_length, @shv_values)', additional_validation => sub { my $self = CORE::shift; my ($sig_was_checked, $callbacks) = @_; my $ti = __PACKAGE__->_type_inspector($callbacks->{isa}); if ($ti and $ti->{trust_mutated} eq 'always') { return ('1;', {}); } if ($ti and $ti->{trust_mutated} eq 'maybe') { my $coercion = ($callbacks->{coerce} && $ti->{value_type}->has_coercion); my @rv = $coercion ? ( $self->_process_template( 'my @shv_unprocessed=@ARG;my @shv_processed=splice(@shv_unprocessed,0,2); push @shv_processed, map $shv_type_for_values->assert_coerce($_), @shv_unprocessed;', %$callbacks, ), { '$shv_type_for_values' => \$ti->{value_type} }, ) : ( $self->_process_template( sprintf( 'my @shv_unprocessed=@ARG;my @shv_processed=splice(@shv_unprocessed,0,2);for my $shv_value (@shv_unprocessed) { %s };push @shv_processed, @shv_unprocessed;', $ti->{value_type}->inline_assert('$shv_value', '$shv_type_for_values'), ), %$callbacks, ), { '$shv_type_for_values' => \$ti->{value_type} }, ); $callbacks->{'arg'} = sub { "\$shv_processed[($_[0])-1]" }; $callbacks->{'args'} = sub { '@shv_processed' }; return @rv; } }, } 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', } 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, } sub flatten_deep { my $me = __PACKAGE__; handler name => 'Array:flatten_deep', min_args => 0, max_args => 1, signature => [Optional[Int]], usage => '$depth?', template => "$me\::_flatten_deep(\@{\$GET}, \$ARG)", } # callback! sub _flatten_deep { my @array = @_; my $depth = CORE::pop @array; --$depth if defined($depth); my @elements = CORE::map { (ref eq 'ARRAY') ? (defined($depth) && $depth == -1) ? $_ : _flatten_deep(@$_, $depth) : $_ } @array; } 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})', } 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})', } 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)]', } 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]', } 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]', } sub pick_random { require List::Util; handler name => 'Array:pick_random', min_args => 0, max_args => 1, signature => [Optional[Int]], usage => '$coderef', 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] }', } 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', } 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', } sub all_true { require List::Util; handler name => 'Array:all_true', args => 1, signature => [CodeRef], usage => '$coderef', template => '&List::Util::all($ARG, @{$GET})', } 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})', } sub min { require List::Util; handler name => 'Array:min', args => 0, template => '&List::Util::min(@{$GET})', } sub max { require List::Util; handler name => 'Array:max', args => 0, template => '&List::Util::max(@{$GET})', } sub minstr { require List::Util; handler name => 'Array:minstr', args => 0, template => '&List::Util::minstr(@{$GET})', } sub maxstr { require List::Util; handler name => 'Array:maxstr', args => 0, template => '&List::Util::maxstr(@{$GET})', } sub sum { require List::Util; handler name => 'Array:sum', args => 0, template => '&List::Util::sum(0, @{$GET})', } sub product { require List::Util; handler name => 'Array:product', args => 0, template => '&List::Util::product(1, @{$GET})', } sub sample { require List::Util; handler name => 'Array:sample', args => 1, signature => [Int], usage => '$count', template => '&List::Util::sample($ARG, @{$GET})', } 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}', } sub pairs { require List::Util; handler name => 'Array:pairs', args => 0, template => '&List::Util::pairs(@{$GET})', } sub pairkeys { require List::Util; handler name => 'Array:pairkeys', args => 0, template => '&List::Util::pairkeys(@{$GET})', } sub pairvalues { require List::Util; handler name => 'Array:pairkeys', args => 0, template => '&List::Util::pairkeys(@{$GET})', } sub pairgrep { require List::Util; handler name => 'Array:pairgrep', args => 1, signature => [CodeRef], usage => '$coderef', template => 'List::Util::pairgrep { $ARG->($_) } @{$GET}', } sub pairfirst { require List::Util; handler name => 'Array:pairfirst', args => 1, signature => [CodeRef], usage => '$coderef', template => 'List::Util::pairfirst { $ARG->($_) } @{$GET}', } sub pairmap { require List::Util; handler name => 'Array:pairmap', args => 1, signature => [CodeRef], usage => '$coderef', template => 'List::Util::pairmap { $ARG->($_) } @{$GET}', } sub reset { handler name => 'Array:reset', args => 0, template => '« $DEFAULT »', default_for_reset => sub { '[]' }, } 1; Bool.pm000664001750001750 152613731701652 22545 0ustar00taitai000000000000Sub-HandlesVia-0.016/lib/Sub/HandlesVia/HandlerLibraryuse 5.008; use strict; use warnings; package Sub::HandlesVia::HandlerLibrary::Bool; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.016'; 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 »', } sub unset { handler name => 'Bool:unset', args => 0, template => '« !!0 »', } sub toggle { handler name => 'Bool:toggle', args => 0, template => '« !$GET »', } sub not { handler name => 'Bool:not', args => 0, template => '!$GET', } sub reset { handler name => 'Bool:reset', args => 0, template => '« $DEFAULT »', default_for_reset => sub { 0 }, } 1; Code.pm000664001750001750 101013731701652 22510 0ustar00taitai000000000000Sub-HandlesVia-0.016/lib/Sub/HandlesVia/HandlerLibraryuse 5.008; use strict; use warnings; package Sub::HandlesVia::HandlerLibrary::Code; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.016'; use Sub::HandlesVia::HandlerLibrary; our @ISA = 'Sub::HandlesVia::HandlerLibrary'; use Sub::HandlesVia::Handler qw( handler ); our @METHODS = qw( execute execute_method ); sub execute { handler name => 'Code:execute', template => '$GET->(@ARG)', } sub execute_method { handler name => 'Code:execute_method', template => '$GET->($SELF, @ARG)', } 1; Counter.pm000664001750001750 251413731701652 23267 0ustar00taitai000000000000Sub-HandlesVia-0.016/lib/Sub/HandlesVia/HandlerLibraryuse 5.008; use strict; use warnings; package Sub::HandlesVia::HandlerLibrary::Counter; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.016'; 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 »', } 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)', } 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)', } sub reset { handler name => 'Counter:reset', args => 0, template => '« $DEFAULT »', default_for_reset => sub { 0 }, } 1;Hash.pm000664001750001750 2136713731701652 22562 0ustar00taitai000000000000Sub-HandlesVia-0.016/lib/Sub/HandlesVia/HandlerLibraryuse 5.008; use strict; use warnings; package Sub::HandlesVia::HandlerLibrary::Hash; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.016'; 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 ); our @METHODS = qw( all accessor clear count defined delete elements exists get is_empty keys kv set shallow_clone values sorted_keys for_each_pair for_each_key for_each_value reset ); 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, $callbacks) = @_; my $ti = __PACKAGE__->_type_inspector($callbacks->{isa}); if ($ti and $ti->{trust_mutated} eq 'always') { return ('1;', {}); } if ($ti and $ti->{trust_mutated} eq 'maybe') { my $key_coercion = ($callbacks->{coerce} && $ti->{key_type}->has_coercion); my $value_coercion = ($callbacks->{coerce} && $ti->{value_type}->has_coercion); my $orig = $callbacks->{'arg'}; $callbacks->{'arg'} = sub { return '$shv_key' if $_[0]=='1'; return '$shv_value' if $_[0]=='2'; goto &$orig; }; return ( $self->_process_template(sprintf( 'my($shv_key,$shv_value)=@ARG; if (#ARG>0) { %s }; if (#ARG>1) { %s };', $key_coercion ? '$shv_key=$shv_key_tc->assert_coerce($shv_key)' : $ti->{key_type}->inline_assert('$shv_key', '$shv_key_tc'), $value_coercion ? '$shv_value=$shv_value_tc->assert_coerce($shv_value)' : $ti->{value_type}->inline_assert('$shv_value', '$shv_value_tc'), ), %$callbacks), { '$shv_key_tc' => \($ti->{key_type} || Str), '$shv_value_tc' => \$ti->{value_type} }, ); } return; }; sub count { handler name => 'Hash:count', args => 0, template => 'scalar keys %{$GET}', } sub is_empty { handler name => 'Hash:is_empty', args => 0, template => '!scalar keys %{$GET}', } sub keys { handler name => 'Hash:keys', args => 0, template => 'keys %{$GET}', } sub sorted_keys { handler name => 'Hash:sorted_keys', args => 0, template => 'sort(keys %{$GET})', } sub values { handler name => 'Hash:values', args => 0, template => 'values %{$GET}', } sub all { handler name => 'Hash:all', args => 0, template => 'map { $_ => ($GET)->{$_} } keys %{$GET}', } sub elements { handler name => 'Hash:elements', args => 0, template => 'map { $_ => ($GET)->{$_} } keys %{$GET}', } sub kv { handler name => 'Hash:kv', args => 0, template => 'map [ $_ => ($GET)->{$_} ], keys %{$GET}', } sub get { handler name => 'Hash:get', min_args => 1, usage => '$key', template => '#ARG>1 ? @{$GET}{@ARG} : ($GET)->{$ARG}', } sub defined { handler name => 'Hash:defined', args => 1, signature => [Str], usage => '$key', template => 'defined(($GET)->{$ARG})', } sub exists { handler name => 'Hash:exists', args => 1, signature => [Str], usage => '$key', template => 'defined(($GET)->{$ARG})', } 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})', additional_validation => 'no incoming values', } sub clear { handler name => 'Hash:clear', args => 0, template => '«{}»', lvalue_template => '%{$GET} = ()', additional_validation => 'no incoming values', } sub shallow_clone { handler name => 'Hash:shallow_clone', args => 0, template => '+{%{$GET}}', } sub _old_set { my $me = CORE::shift; handler name => 'Hash:set', args => 2, signature => [Str, Any], usage => '$key, $value', template => 'my %shv_tmp = %{$GET}; $shv_tmp{$ARG[1]} = $ARG[2]; «\\%shv_tmp»', lvalue_template => '($GET)->{ $ARG[1] } = $ARG[2]', additional_validation => $additional_validation_for_set_and_insert, } sub set { my $me = CORE::shift; handler name => 'Hash:set', min_args => 2, usage => '$key, $value, ...', template => ( 'my (@shv_params) = @ARG; ' . 'scalar(@shv_params) % 2 and do { require Carp; Carp::croak("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 do { require Carp; Carp::croak("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 do { require Carp; Carp::croak("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 do { require Carp; Carp::croak("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, $callbacks) = @_; my $ti = __PACKAGE__->_type_inspector($callbacks->{isa}); if ($ti and $ti->{trust_mutated} eq 'always') { # still need to check keys are strings return ( sprintf( 'for my $shv_tmp (@shv_keys_idx) { %s };', Str->inline_assert('$shv_params[$shv_tmp]', '$Types_Standard_Str'), ), { '$Types_Standard_Str' => \(Str) }, 'LATER!', ); } if ($ti and $ti->{trust_mutated} eq 'maybe') { my $key_coercion = ($callbacks->{coerce} && $ti->{key_type}->has_coercion); my $value_coercion = ($callbacks->{coerce} && $ti->{value_type}->has_coercion); return ( sprintf( 'for my $shv_tmp (@shv_keys_idx) { %s }; for my $shv_tmp (@shv_values_idx) { %s };', $key_coercion ? '$shv_params[$shv_tmp] = $shv_key_tc->assert_coerce($shv_params[$shv_tmp])' : $ti->{key_type}->inline_assert('$shv_params[$shv_tmp]', '$shv_key_tc'), $value_coercion ? '$shv_params[$shv_tmp] = $shv_value_tc->assert_coerce($shv_params[$shv_tmp])' : $ti->{value_type}->inline_assert('$shv_params[$shv_tmp]', '$shv_value_tc'), ), { '$shv_key_tc' => \($ti->{key_type}), '$shv_value_tc' => \($ti->{value_type}) }, 'LATER!', ); } return; } } 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, } 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', } 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', } 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', } sub reset { handler name => 'Hash:reset', args => 0, template => '« $DEFAULT »', default_for_reset => sub { '{}' }, } 1; Number.pm000664001750001750 312613731701652 23100 0ustar00taitai000000000000Sub-HandlesVia-0.016/lib/Sub/HandlesVia/HandlerLibraryuse 5.008; use strict; use warnings; package Sub::HandlesVia::HandlerLibrary::Number; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.016'; 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 ); 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', } sub get { handler name => 'Number:get', args => 0, template => '$GET', } sub add { handler name => 'Number:add', args => 1, signature => [Num], template => '« $GET + $ARG »', } sub sub { handler name => 'Number:sub', args => 1, signature => [Num], template => '« $GET - $ARG »', } sub mul { handler name => 'Number:mul', args => 1, signature => [Num], template => '« $GET * $ARG »', } sub div { handler name => 'Number:div', args => 1, signature => [Num], template => '« $GET / $ARG »', } sub mod { handler name => 'Number:mod', args => 1, signature => [Num], template => '« $GET % $ARG »', } sub abs { handler name => 'Number:abs', args => 0, template => '« abs($GET) »', additional_validation => 'no incoming values', } 1; Scalar.pm000664001750001750 67713731701652 23045 0ustar00taitai000000000000Sub-HandlesVia-0.016/lib/Sub/HandlesVia/HandlerLibraryuse 5.008; use strict; use warnings; package Sub::HandlesVia::HandlerLibrary::Scalar; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.016'; use Sub::HandlesVia::HandlerLibrary; our @ISA = 'Sub::HandlesVia::HandlerLibrary'; use Sub::HandlesVia::Handler qw( handler ); our @METHODS = qw( scalar_reference ); sub scalar_reference { handler name => 'Scalar:scalar_reference', args => 0, template => '$GET;\\($SLOT)', } 1; String.pm000664001750001750 1027113731701652 23135 0ustar00taitai000000000000Sub-HandlesVia-0.016/lib/Sub/HandlesVia/HandlerLibraryuse 5.008; use strict; use warnings; package Sub::HandlesVia::HandlerLibrary::String; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.016'; 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 replace match chop chomp clear reset length substr replace_globally ); 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', } sub get { handler name => 'String:get', args => 0, template => '$GET', } sub inc { handler name => 'String:inc', args => 0, template => '« do { my $shv_tmp = $GET; ++$shv_tmp } »', lvalue_template => '++$GET', additional_validation => 'no incoming values', } sub append { handler name => 'String:append', args => 1, signature => [Str], template => '« $GET . $ARG »', lvalue_template => '$GET .= $ARG', } sub prepend { handler args => 1, name => 'String:prepend', signature => [Str], template => '« $ARG . $GET »', } 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]'), ), } 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]'), ), } sub match { handler name => 'String:match', args => 1, signature => [ Str|RegexpRef ], usage => '$regexp', template => '$GET =~ /$ARG/', } 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', } 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', } sub clear { handler name => 'String:clear', args => 0, template => '«q()»', additional_validation => 'no incoming values', } sub reset { handler name => 'String:reset', args => 0, template => '« $DEFAULT »', default_for_reset => sub { 'q()' }, } sub length { handler name => 'String:length', args => 0, template => 'length($GET)', } 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]) } ', } 1; Moo.pm000664001750001750 2172213731701652 21147 0ustar00taitai000000000000Sub-HandlesVia-0.016/lib/Sub/HandlesVia/Toolkituse 5.008; use strict; use warnings; package Sub::HandlesVia::Toolkit::Moo; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.016'; use Sub::HandlesVia::Toolkit; our @ISA = 'Sub::HandlesVia::Toolkit'; use Data::Dumper; 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 $attrs = [$attrs] unless ref $attrs; for my $attr (@$attrs) { my $shv = $me->clean_spec($target, $attr, \%spec); $orig->($attr, %spec); $me->install_delegations($shv) if $shv; } return; }); } my %standard_callbacks = ( args => sub { '@_[1..$#_]'; }, arg => sub { @_==1 or die; my $n = shift; "\$_[$n]"; }, argc => sub { '(@_-1)'; }, curry => sub { @_==1 or die; my $arr = shift; "splice(\@_,1,0,$arr);"; }, usage_string => sub { @_==2 or die; my $method_name = shift; my $guts = shift; "\$instance->$method_name($guts)"; }, self => sub { '$_[0]'; }, ); sub make_callbacks { 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->_make_callbacks_role($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) = $maker->generate_simple_get('$_[0]', $attrname, $spec); my ($is_simple_get, $get, $captures) = $maker->is_simple_get($attrname, $spec) ? (1, $maker->generate_simple_get('$_[0]', $attrname, $spec)) : (0, $maker->_generate_get($attrname, $spec), delete($maker->{captures})||{}); my ($is_simple_set, $set) = $maker->is_simple_set($attrname, $spec) ? (1, sub { my ($var) = @_; $maker->_generate_simple_set('$_[0]', $attrname, $spec, $var); }) : (0, sub { # that allows us to avoid going down this yucky code path my ($var) = @_; my $code = $maker->_generate_set($attrname, $spec); $captures = { %$captures, %{ delete($maker->{captures}) or {} } }; # merge environments $code = "do { local \@_ = (\$_[0], $var); $code }"; $code; }); # force $captures to be updated $set->('$dummy') if !$is_simple_set; 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]; } return { %standard_callbacks, is_method => !!1, slot => sub { $slot }, get => sub { $get }, get_is_lvalue => $is_simple_get, set => $set, set_checks_isa => !$is_simple_set, isa => $type, coerce => !!$coerce, env => $captures, be_strict => $spec->{weak_ref}||$spec->{trigger}, default_for_reset => sub { my ($handler, $callbacks) = @_ or die; if (!$default) { return $handler->default_for_reset->(); } elsif ($default->[0] eq 'builder') { return sprintf('(%s)->%s', $callbacks->{self}->(), $default->[1]); } elsif ($default->[0] eq 'default' and is_CodeRef $default->[1]) { return sprintf('(%s)->$shv_default_for_reset', $callbacks->{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]); } else { die 'lolwut?'; } }, }; } sub _make_callbacks_role { 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 { sprintf "\$_[0]->%s", $reader_name } : sub { sprintf "\$_[0]->\${\\ %s }", 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 { '$_[0]->$shv_reader()' }; } if (defined $writer_name) { $set = $writer_name =~ /^[\W0-9]\w*$/s ? sub { my $val = shift; sprintf "\$_[0]->%s(%s)", $writer_name, $val } : sub { my $val = shift; sprintf "\$_[0]->\${\\ %s }(%s)", 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 $val = shift; "\$_[0]->\$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]; } return { %standard_callbacks, is_method => !!1, slot => sub { '$_[0]{'.B::perlstring($attrname).'}' }, # icky get => $get, get_is_lvalue => !!0, set => $set, set_checks_isa => !!1, isa => $type, coerce => !!$coerce, env => $captures, be_strict => !!0, default_for_reset => sub { my ($handler, $callbacks) = @_ or die; if (!$default) { return $handler->default_for_reset->(); } elsif ($default->[0] eq 'builder') { return sprintf('(%s)->%s', $callbacks->{self}->(), $default->[1]); } elsif ($default->[0] eq 'default' and is_CodeRef $default->[1]) { return sprintf('(%s)->$shv_default_for_reset', $callbacks->{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]); } else { die 'lolwut?'; } }, }; } 1; Moose.pm000664001750001750 1233213731701652 21474 0ustar00taitai000000000000Sub-HandlesVia-0.016/lib/Sub/HandlesVia/Toolkituse 5.008; use strict; use warnings; package Sub::HandlesVia::Toolkit::Moose; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.016'; use Sub::HandlesVia::Toolkit; our @ISA = 'Sub::HandlesVia::Toolkit'; sub setup_for { my $me = shift; my ($target) = @_; require Moose::Util; my $meta = Moose::Util::find_meta($target); Role::Tiny->apply_roles_to_object($meta, $me->package_trait); Role::Tiny->apply_roles_to_object($meta, $me->role_trait) if $meta->isa('Moose::Meta::Role'); } sub package_trait { __PACKAGE__ . "::PackageTrait"; } sub role_trait { __PACKAGE__ . "::RoleTrait"; } my %standard_callbacks = ( args => sub { '@_[1..$#_]'; }, arg => sub { @_==1 or die; my $n = shift; "\$_[$n]"; }, argc => sub { '(@_-1)'; }, curry => sub { @_==1 or die; my $arr = shift; "splice(\@_,1,0,$arr);"; }, usage_string => sub { @_==2 or die; my $method_name = shift; my $guts = shift; "\$instance->$method_name($guts)"; }, self => sub { '$_[0]'; }, ); sub make_callbacks { 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 = $meta->get_meta_instance->inline_slot_access('$_[0]', $attrname); my ($get, $set, $get_is_lvalue, $set_checks_isa); if (!$spec->{lazy} and !$spec->{traits} and !$spec->{auto_deref}) { $get = sub { $slot }; ++$get_is_lvalue; } elsif ($attr->has_read_method) { my $read_method = $attr->get_read_method; $get = sub { "scalar(\$_[0]->$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 { 'scalar($_[0]->$shv_read_method)' }; } if ($attr->has_write_method) { my $write_method = $attr->get_write_method; $set = sub { my $val = shift; "\$_[0]->$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 $val = shift; '$_[0]->$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]; } return { %standard_callbacks, is_method => !!1, slot => sub { $slot }, get => $get, get_is_lvalue => $get_is_lvalue, set => $set, set_checks_isa => $set_checks_isa, isa => Types::TypeTiny::to_TypeTiny($attr->type_constraint), coerce => !!$spec->{coerce}, env => $captures, be_strict => !!1, install_method => sub { $meta->add_method(@_) }, default_for_reset => sub { my ($handler, $callbacks) = @_ or die; if (!$default) { return $handler->default_for_reset->(); } elsif ($default->[0] eq 'builder') { return sprintf('(%s)->%s', $callbacks->{self}->(), $default->[1]); } elsif ($default->[0] eq 'default' and ref $default->[1] eq 'CODE') { return sprintf('(%s)->$shv_default_for_reset', $callbacks->{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]); } else { die 'lolwut?'; } }, }; } package Sub::HandlesVia::Toolkit::Moose::PackageTrait; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.016'; use Role::Tiny; 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; } $spec->{definition_context}{shv} = $self->_shv_toolkit->clean_spec($self->name, $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.016'; use Role::Tiny; around apply => sub { my ($next, $self, $other, %args) = (shift, shift, @_); if ($other->isa('Moose::Meta::Role')) { Role::Tiny->apply_roles_to_object( $other, $self->_shv_toolkit->package_trait, $self->_shv_toolkit->role_trait, ); } else { Role::Tiny->apply_roles_to_object( $other, $self->_shv_toolkit->package_trait, ); } $self->$next(@_); }; 1; Mouse.pm000664001750001750 1203713731701652 21504 0ustar00taitai000000000000Sub-HandlesVia-0.016/lib/Sub/HandlesVia/Toolkituse 5.008; use strict; use warnings; package Sub::HandlesVia::Toolkit::Mouse; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.016'; use Sub::HandlesVia::Toolkit; our @ISA = 'Sub::HandlesVia::Toolkit'; sub setup_for { my $me = shift; my ($target) = @_; require Mouse::Util; my $meta = Mouse::Util::find_meta($target); Role::Tiny->apply_roles_to_object($meta, $me->package_trait); Role::Tiny->apply_roles_to_object($meta, $me->role_trait) if $meta->isa('Mouse::Meta::Role'); } sub package_trait { __PACKAGE__ . "::PackageTrait"; } sub role_trait { __PACKAGE__ . "::RoleTrait"; } my %standard_callbacks = ( args => sub { '@_[1..$#_]'; }, arg => sub { @_==1 or die; my $n = shift; "\$_[$n]"; }, argc => sub { '(@_-1)'; }, curry => sub { @_==1 or die; my $arr = shift; "splice(\@_,1,0,$arr);"; }, usage_string => sub { @_==2 or die; my $method_name = shift; my $guts = shift; "\$instance->$method_name($guts)"; }, self => sub { '$_[0]'; }, ); sub make_callbacks { 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 { "\$_[0]{$slot}" }; ++$get_is_lvalue; } elsif ($attr->has_read_method) { my $read_method = $attr->reader || $attr->accessor; $get = sub { "scalar(\$_[0]->$read_method)" }; } else { my $read_method = $attr->get_read_method_ref; $captures->{'$shv_read_method'} = \$read_method; $get = sub { 'scalar($_[0]->$shv_read_method)' }; } if ($attr->has_write_method) { my $write_method = $attr->writer || $attr->accessor; $set = sub { my $val = shift; "\$_[0]->$write_method\($val)" }; ++$set_checks_isa; } else { my $write_method = $attr->get_write_method_ref; $captures->{'$shv_write_method'} = \$write_method; $set = sub { my $val = shift; '$_[0]->$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]; } return { %standard_callbacks, is_method => !!1, slot => sub { '$_[0]{'.B::perlstring($attrname).'}' }, # icky get => $get, get_is_lvalue => $get_is_lvalue, set => $set, set_checks_isa => $set_checks_isa, isa => Types::TypeTiny::to_TypeTiny($attr->type_constraint), coerce => !!$spec->{coerce}, env => $captures, be_strict => !!0, install_method => sub { $meta->add_method(@_) }, default_for_reset => sub { my ($handler, $callbacks) = @_ or die; if (!$default) { return $handler->default_for_reset->(); } elsif ($default->[0] eq 'builder') { return sprintf('(%s)->%s', $callbacks->{self}->(), $default->[1]); } elsif ($default->[0] eq 'default' and ref $default->[1] eq 'CODE') { return sprintf('(%s)->$shv_default_for_reset', $callbacks->{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]); } else { die 'lolwut?'; } }, }; } package Sub::HandlesVia::Toolkit::Mouse::PackageTrait; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.016'; use Role::Tiny; 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; } $spec->{provides}{shv} = $self->_shv_toolkit->clean_spec($self->name, $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.016'; use Role::Tiny; around apply => sub { my ($next, $self, $other, %args) = (shift, shift, @_); if ($other->isa('Mouse::Meta::Role')) { Role::Tiny->apply_roles_to_object( $other, $self->_shv_toolkit->package_trait, $self->_shv_toolkit->role_trait, ); } else { Role::Tiny->apply_roles_to_object( $other, $self->_shv_toolkit->package_trait, ); } $self->$next(@_); }; 1; Plain.pm000664001750001750 517013731701652 21437 0ustar00taitai000000000000Sub-HandlesVia-0.016/lib/Sub/HandlesVia/Toolkituse 5.008; use strict; use warnings; package Sub::HandlesVia::Toolkit::Plain; our $AUTHORITY = 'cpan:TOBYINK'; our $VERSION = '0.016'; use Sub::HandlesVia::Toolkit; our @ISA = 'Sub::HandlesVia::Toolkit'; use Types::Standard qw( is_CodeRef is_Str ); sub make_callbacks { my ($me, $target, $attr) = (shift, @_); my ($get_slot, $set_slot, $default) = @$attr; $set_slot = $get_slot if @$attr < 2; my $captures = {}; my ($get, $set, $get_is_lvalue) = (undef, undef, 0); require B; if (ref $get_slot) { $get = sub { '$_[0]->$shv_reader' }; $captures->{'$shv_reader'} = \$get_slot; } elsif ($get_slot =~ /\A \[ ([0-9]+) \] \z/sx) { my $index = $1; $get = sub { "\$_[0][$index]" }; ++$get_is_lvalue; } elsif ($get_slot =~ /\A \{ (.+) \} \z/sx) { my $key = B::perlstring($1); $get = sub { "\$_[0]{$key}" }; ++$get_is_lvalue; } else { my $method = B::perlstring($get_slot); $get = sub { "\$_[0]->\${\\ $method}" }; } if (ref $set_slot) { $set = sub { my $val = shift or die; "\$_[0]->\$shv_writer($val)" }; $captures->{'$shv_writer'} = \$set_slot; } elsif ($set_slot =~ /\A \[ ([0-9]+) \] \z/sx) { my $index = $1; $set = sub { my $val = shift or die; "(\$_[0][$index] = $val)" }; } elsif ($set_slot =~ /\A \{ (.+) \} \z/sx) { my $key = B::perlstring($1); $set = sub { my $val = shift or die; "(\$_[0]{$key} = $val)" }; } else { my $method = B::perlstring($set_slot); $set = sub { my $val = shift or die; "\$_[0]->\${\\ $method}($val)" }; } if (is_CodeRef $default) { $captures->{'$shv_default_for_reset'} = \$default; } my %callbacks = ( args => sub { '@_[1..$#_]'; }, arg => sub { @_==1 or die; my $n = shift; "\$_[$n]"; }, argc => sub { '(@_-1)'; }, curry => sub { @_==1 or die; my $arr = shift; "splice(\@_,1,0,$arr);"; }, usage_string => sub { @_==2 or die; my $method_name = shift; my $guts = shift; "\$instance->$method_name($guts)"; }, self => sub { '$_[0]'; }, is_method => !!1, get => $get, get_is_lvalue => $get_is_lvalue, set => $set, set_checks_isa => !!1, coerce => !!0, env => $captures, be_strict => !!1, default_for_reset => sub { my ($handler, $callbacks) = @_ or die; if (!$default) { return $handler->default_for_reset->(); } elsif (is_CodeRef $default) { return sprintf('(%s)->$shv_default_for_reset', $callbacks->{self}->()); } elsif (is_Str $default) { require B; return sprintf('(%s)->${\ %s }', $callbacks->{self}->(), B::perlstring($default)); } else { die 'lolwut?'; } }, ); \%callbacks; } 1;