MooX-HandlesVia-0.001005/000755 012504 012504 00000000000 12255076473 016712 5ustar00mphillipsmphillips000000 000000 MooX-HandlesVia-0.001005/TODO000644 012504 012504 00000000362 12255076473 017403 0ustar00mphillipsmphillips000000 000000 -currently Data::Perl does not return certain wantarray contextual return vals that Moose native traits return (ie hash get/set/delete, array splice). for full backwards compatibility a ::Mooselike subclass should be provided by HandlesVia. MooX-HandlesVia-0.001005/README000644 012504 012504 00000006237 12255076473 017602 0ustar00mphillipsmphillips000000 000000 NAME MooX::HandlesVia - NativeTrait-like behavior for Moo. VERSION version 0.001005 SYNOPSIS { package Hashy; use Moo; use MooX::HandlesVia; has hash => ( is => 'rw', handles_via => 'Hash', handles => { get_val => 'get', set_val => 'set', all_keys => 'keys' } ); } my $h = Hashy->new(hash => { a => 1, b => 2}); $h->get_val('b'); # 2 $h->set_val('a', 'BAR'); # sets a to BAR my @keys = $h->all_keys; # returns a, b DESCRIPTION MooX::HandlesVia is an extension of Moo's 'handles' attribute functionality. It provides a means of proxying functionality from an external class to the given atttribute. This is most commonly used as a way to emulate 'Native Trait' behavior that has become commonplace in Moose code, for which there was no Moo alternative. SHORTCOMINGS Due to current Moo implementation details there are some deficiencies in how MooX::HandlesVia in comparison to what you would expect from Moose native traits. * methods delegated via the Moo 'handles' interface are passed the attribue value directly. and there is no way to access the parent class. This means if an attribute is updated any triggers or type coercions WILL NOT fire. * Moo attribute method delegations are passed the attribute value. This is fine for references (objects, arrays, hashrefs..) it means simple scalar types are READ ONLY. This unfortunately means Number, String, Counter, Bool cannot modify the attributes value, rendering them largely useless. PROVIDED INTERFACE/FUNCTIONS process_has(@_) MooX::HandlesVia preprocesses arguments passed to has() attribute declarations via the process_has function. In a given Moo class, If 'handles_via' is set to a ClassName string, and 'handles' is set with a hashref mapping of desired moo class methods that should map to ClassName methods, process_has() will create the appropriate binding to create the mapping IF ClassName provides that named method. has options => ( is => 'rw', handles_via => 'Array', handles => { mixup => 'shuffle', unique_options => 'uniq', all_options => 'elements' } ); The following handles_via keywords are reserved as shorthand for mapping to Data::Perl: * Hash maps to Data::Perl::Collection::Hash::MooseLike * Array maps to Data::Perl::Collection::Array::MooseLike * String maps to Data::Perl::String::MooseLike * Number maps to Data::Perl::Number::MooseLike * Bool maps to Data::Perl::Bool::MooseLike * Code maps to Data::Perl::Code SEE ALSO * Moo * MooX::late AUTHOR Matthew Phillips COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Matthew Phillips . This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. MooX-HandlesVia-0.001005/Changes000644 012504 012504 00000001274 12255076473 020211 0ustar00mphillipsmphillips000000 000000 0.001005 2013-12-20 12:24:09 America/Toronto - bugfix to support proper unimporting with 'no Moo' (@lukas-t) - typofix (@djgoku) 0.001004 2013-07-16 10:12:02 EST5EDT - bump Moo minver to 1.00300, as it contains crucial Role composition fixes when interacting with Moose. thanks @haarg 0.001003 2013-05-15 10:19:06 EST5EDT - handles_via can now accept arrayref as an arg, to more closely mirror Moose 0.001002 2013-05-15 10:02:56 EST5EDT - fix buggy flattening mechanism in MooseLike array/hashes 0.001001 2013-05-14 17:05:24 EST5EDT - adds support for moosify attribute spec, for proper Moo inflation. 0.001000 2013-03-16 20:00:00 America/Toronto - Initial drop to cpan. MooX-HandlesVia-0.001005/LICENSE000644 012504 012504 00000043752 12255076473 017732 0ustar00mphillipsmphillips000000 000000 This software is copyright (c) 2013 by Matthew Phillips . 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) 2013 by Matthew Phillips . 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, Suite 500, Boston, MA 02110-1335 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) 2013 by Matthew Phillips . 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 MooX-HandlesVia-0.001005/dist.ini000644 012504 012504 00000001613 12255076473 020357 0ustar00mphillipsmphillips000000 000000 name = MooX-HandlesVia author = Matthew Phillips license = Perl_5 copyright_holder = Matthew Phillips version = 0.001005 [@Basic] [MetaJSON] [NextRelease] [@Git] allow_dirty = Changes allow_dirty = dist.ini allow_dirty = README.mkdn add_files_in = Changes add_files_in = dist.ini add_files_in = README.mkdn [PodWeaver] [MetaResources] repository.url = git://github.com/mattp-/MooX-HandlesVia.git repository.web = https://github.com/mattp-/MooX-HandlesVia repository.type = git [CheckChangeLog] [PkgVersion] [ReadmeFromPod] [ReadmeMarkdownFromPod] [PodCoverageTests] [PodSyntaxTests] [Prereqs / RuntimeRequires] Moo = 1.003000 Data::Perl = 0.002006 Module::Runtime = 0 Role::Tiny = 0 Class::Method::Modifiers = 0 [Prereqs / TestRequires] Test::More = 0 Test::Exception = 0 MooX::Types::MooseLike::Base = 0.23 [Prereqs] [Run::BeforeRelease] run = cp %d%pREADME.mkdn . MooX-HandlesVia-0.001005/t/000755 012504 012504 00000000000 12255076473 017155 5ustar00mphillipsmphillips000000 000000 MooX-HandlesVia-0.001005/META.yml000644 012504 012504 00000001231 12255076473 020160 0ustar00mphillipsmphillips000000 000000 --- abstract: 'NativeTrait-like behavior for Moo.' author: - 'Matthew Phillips ' build_requires: MooX::Types::MooseLike::Base: 0.23 Test::Exception: 0 Test::More: 0 configure_requires: ExtUtils::MakeMaker: 6.30 dynamic_config: 0 generated_by: 'Dist::Zilla version 5.006, CPAN::Meta::Converter version 2.133380' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: MooX-HandlesVia requires: Class::Method::Modifiers: 0 Data::Perl: 0.002006 Module::Runtime: 0 Moo: 1.003000 Role::Tiny: 0 resources: repository: git://github.com/mattp-/MooX-HandlesVia.git version: 0.001005 MooX-HandlesVia-0.001005/MANIFEST000644 012504 012504 00000001264 12255076473 020046 0ustar00mphillipsmphillips000000 000000 Changes LICENSE MANIFEST META.json META.yml Makefile.PL README README.mkdn TODO dist.ini lib/Data/Perl/Bool/MooseLike.pm lib/Data/Perl/Collection/Array/MooseLike.pm lib/Data/Perl/Collection/Hash/MooseLike.pm lib/Data/Perl/Number/MooseLike.pm lib/Data/Perl/String/MooseLike.pm lib/MooX/HandlesVia.pm t/arbitrary.t t/from-moose/trait_array.t t/from-moose/trait_bool.t t/from-moose/trait_code.t t/from-moose/trait_hash.t t/from-moose/trait_number.t t/from-moose/trait_string.t t/handlesvia_in_role.t t/hash.t t/invalid.t t/proof_of_concept.t t/release-pod-coverage.t t/release-pod-syntax.t t/unimport/namespace_autoclean.t t/unimport/namespace_clean.t t/unimport/no_moo.t t/unimport/pollution.t MooX-HandlesVia-0.001005/META.json000644 012504 012504 00000002626 12255076473 020341 0ustar00mphillipsmphillips000000 000000 { "abstract" : "NativeTrait-like behavior for Moo.", "author" : [ "Matthew Phillips " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 5.006, CPAN::Meta::Converter version 2.133380", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "MooX-HandlesVia", "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.30" } }, "develop" : { "requires" : { "Pod::Coverage::TrustPod" : "0", "Test::Pod" : "1.41", "Test::Pod::Coverage" : "1.08" } }, "runtime" : { "requires" : { "Class::Method::Modifiers" : "0", "Data::Perl" : "0.002006", "Module::Runtime" : "0", "Moo" : "1.003000", "Role::Tiny" : "0" } }, "test" : { "requires" : { "MooX::Types::MooseLike::Base" : "0.23", "Test::Exception" : "0", "Test::More" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "git://github.com/mattp-/MooX-HandlesVia.git", "web" : "https://github.com/mattp-/MooX-HandlesVia" } }, "version" : "0.001005" } MooX-HandlesVia-0.001005/README.mkdn000644 012504 012504 00000006635 12255076473 020534 0ustar00mphillipsmphillips000000 000000 # NAME MooX::HandlesVia - NativeTrait-like behavior for Moo. # VERSION version 0.001005 # SYNOPSIS { package Hashy; use Moo; use MooX::HandlesVia; has hash => ( is => 'rw', handles_via => 'Hash', handles => { get_val => 'get', set_val => 'set', all_keys => 'keys' } ); } my $h = Hashy->new(hash => { a => 1, b => 2}); $h->get_val('b'); # 2 $h->set_val('a', 'BAR'); # sets a to BAR my @keys = $h->all_keys; # returns a, b # DESCRIPTION MooX::HandlesVia is an extension of Moo's 'handles' attribute functionality. It provides a means of proxying functionality from an external class to the given atttribute. This is most commonly used as a way to emulate 'Native Trait' behavior that has become commonplace in Moose code, for which there was no Moo alternative. # SHORTCOMINGS Due to current Moo implementation details there are some deficiencies in how MooX::HandlesVia in comparison to what you would expect from Moose native traits. - methods delegated via the Moo 'handles' interface are passed the attribue value directly. and there is no way to access the parent class. This means if an attribute is updated any triggers or type coercions __WILL NOT__ fire. - Moo attribute method delegations are passed the attribute value. This is fine for references (objects, arrays, hashrefs..) it means simple scalar types are __READ ONLY__. This unfortunately means Number, String, Counter, Bool cannot modify the attributes value, rendering them largely useless. # PROVIDED INTERFACE/FUNCTIONS - __process\_has(@\_)__ MooX::HandlesVia preprocesses arguments passed to has() attribute declarations via the process\_has function. In a given Moo class, If 'handles\_via' is set to a ClassName string, and 'handles' is set with a hashref mapping of desired moo class methods that should map to ClassName methods, process\_has() will create the appropriate binding to create the mapping IF ClassName provides that named method. has options => ( is => 'rw', handles_via => 'Array', handles => { mixup => 'shuffle', unique_options => 'uniq', all_options => 'elements' } ); The following handles\_via keywords are reserved as shorthand for mapping to [Data::Perl](https://metacpan.org/pod/Data::Perl): - __Hash__ maps to [Data::Perl::Collection::Hash::MooseLike](https://metacpan.org/pod/Data::Perl::Collection::Hash::MooseLike) - __Array__ maps to [Data::Perl::Collection::Array::MooseLike](https://metacpan.org/pod/Data::Perl::Collection::Array::MooseLike) - __String__ maps to [Data::Perl::String::MooseLike](https://metacpan.org/pod/Data::Perl::String::MooseLike) - __Number__ maps to [Data::Perl::Number::MooseLike](https://metacpan.org/pod/Data::Perl::Number::MooseLike) - __Bool__ maps to [Data::Perl::Bool::MooseLike](https://metacpan.org/pod/Data::Perl::Bool::MooseLike) - __Code__ maps to [Data::Perl::Code](https://metacpan.org/pod/Data::Perl::Code) # SEE ALSO - [Moo](https://metacpan.org/pod/Moo) - [MooX::late](https://metacpan.org/pod/MooX::late) # AUTHOR Matthew Phillips # COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Matthew Phillips . This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. MooX-HandlesVia-0.001005/Makefile.PL000644 012504 012504 00000002564 12255076473 020673 0ustar00mphillipsmphillips000000 000000 use strict; use warnings; use ExtUtils::MakeMaker 6.30; my %WriteMakefileArgs = ( "ABSTRACT" => "NativeTrait-like behavior for Moo.", "AUTHOR" => "Matthew Phillips ", "BUILD_REQUIRES" => {}, "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => "6.30" }, "DISTNAME" => "MooX-HandlesVia", "EXE_FILES" => [], "LICENSE" => "perl", "NAME" => "MooX::HandlesVia", "PREREQ_PM" => { "Class::Method::Modifiers" => 0, "Data::Perl" => "0.002006", "Module::Runtime" => 0, "Moo" => "1.003000", "Role::Tiny" => 0 }, "TEST_REQUIRES" => { "MooX::Types::MooseLike::Base" => "0.23", "Test::Exception" => 0, "Test::More" => 0 }, "VERSION" => "0.001005", "test" => { "TESTS" => "t/*.t t/from-moose/*.t t/unimport/*.t" } ); my %FallbackPrereqs = ( "Class::Method::Modifiers" => 0, "Data::Perl" => "0.002006", "Module::Runtime" => 0, "Moo" => "1.003000", "MooX::Types::MooseLike::Base" => "0.23", "Role::Tiny" => 0, "Test::Exception" => 0, "Test::More" => 0 ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { delete $WriteMakefileArgs{TEST_REQUIRES}; delete $WriteMakefileArgs{BUILD_REQUIRES}; $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs); MooX-HandlesVia-0.001005/lib/000755 012504 012504 00000000000 12255076473 017460 5ustar00mphillipsmphillips000000 000000 MooX-HandlesVia-0.001005/lib/MooX/000755 012504 012504 00000000000 12255076473 020342 5ustar00mphillipsmphillips000000 000000 MooX-HandlesVia-0.001005/lib/Data/000755 012504 012504 00000000000 12255076473 020331 5ustar00mphillipsmphillips000000 000000 MooX-HandlesVia-0.001005/lib/Data/Perl/000755 012504 012504 00000000000 12255076473 021233 5ustar00mphillipsmphillips000000 000000 MooX-HandlesVia-0.001005/lib/Data/Perl/Bool/000755 012504 012504 00000000000 12255076473 022126 5ustar00mphillipsmphillips000000 000000 MooX-HandlesVia-0.001005/lib/Data/Perl/Number/000755 012504 012504 00000000000 12255076473 022463 5ustar00mphillipsmphillips000000 000000 MooX-HandlesVia-0.001005/lib/Data/Perl/String/000755 012504 012504 00000000000 12255076473 022501 5ustar00mphillipsmphillips000000 000000 MooX-HandlesVia-0.001005/lib/Data/Perl/Collection/000755 012504 012504 00000000000 12255076473 023326 5ustar00mphillipsmphillips000000 000000 MooX-HandlesVia-0.001005/lib/Data/Perl/Collection/Hash/000755 012504 012504 00000000000 12255076473 024211 5ustar00mphillipsmphillips000000 000000 MooX-HandlesVia-0.001005/lib/Data/Perl/Collection/Array/000755 012504 012504 00000000000 12255076473 024404 5ustar00mphillipsmphillips000000 000000 MooX-HandlesVia-0.001005/lib/Data/Perl/Collection/Array/MooseLike.pm000644 012504 012504 00000003714 12255076473 026636 0ustar00mphillipsmphillips000000 000000 package Data::Perl::Collection::Array::MooseLike; { $Data::Perl::Collection::Array::MooseLike::VERSION = '0.001005'; } # ABSTRACT: Collection::Array subclass that simulates Moose's native traits. use strictures 1; use Role::Tiny::With; use Class::Method::Modifiers; with 'Data::Perl::Role::Collection::Array'; around 'splice' => sub { my $orig = shift; my @res = $orig->(@_); # support both class instance method invocation style @res = blessed($res[0]) && $res[0]->isa('Data::Perl::Collection::Array') ? $res[0]->flatten : @res; wantarray ? @res : $res[-1]; }; 1; =pod =encoding UTF-8 =head1 NAME Data::Perl::Collection::Array::MooseLike - Collection::Array subclass that simulates Moose's native traits. =head1 VERSION version 0.001005 =head1 SYNOPSIS use Data::Perl::Collection::Array::MooseLike; my $array = Data::Perl::Collection::Array::MooseLike->new(qw/a b c d/); my $scalar_context = $array->splice(0, 2); # removes and returns b my @list_context = $array->splice(0, 2); # returns and removes (b, c) =head1 DESCRIPTION This class provides a wrapper and methods for interacting with an array. All methods are written to emulate/match existing behavior that exists with Moose's native traits. =head1 DIFFERENCES IN FUNCTIONALITY =over 4 =item B Just like Perl's builtin splice. In scalar context, this returns the last element removed, or undef if no elements were removed. In list context, this returns all the elements removed from the array. This method requires at least one argument. =back =head1 SEE ALSO =over 4 =item * L =item * L =back =head1 AUTHOR Matthew Phillips =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Matthew Phillips . 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 __END__ ==pod MooX-HandlesVia-0.001005/lib/Data/Perl/Collection/Hash/MooseLike.pm000644 012504 012504 00000004614 12255076473 026443 0ustar00mphillipsmphillips000000 000000 package Data::Perl::Collection::Hash::MooseLike; { $Data::Perl::Collection::Hash::MooseLike::VERSION = '0.001005'; } # ABSTRACT: Collection::Hash subclass that simulates Moose's native traits. use strictures 1; use Role::Tiny::With; use Class::Method::Modifiers; with 'Data::Perl::Role::Collection::Hash'; around 'set', 'get', 'delete' => sub { my $orig = shift; my @res = $orig->(@_); # support both class instance method invocation style @res = blessed($res[0]) && ($res[0]->isa('Data::Perl::Collection::Hash') || $res[0]->isa('Data::Perl::Collection::Array')) ? $res[0]->flatten : @res; wantarray ? @res : $res[-1]; }; 1; =pod =encoding UTF-8 =head1 NAME Data::Perl::Collection::Hash::MooseLike - Collection::Hash subclass that simulates Moose's native traits. =head1 VERSION version 0.001005 =head1 SYNOPSIS use Data::Perl::Collection::Hash::MooseLike; my $hash = Data::Perl::Collection::Hash::MooseLike->new(a => 1, b => 2); $hash->values; # (1, 2) $hash->set('foo', 'bar'); # (a => 1, b => 2, foo => 'bar') =head1 DESCRIPTION This class provides a wrapper and methods for interacting with a hash. All methods are written to emulate/match existing behavior that exists with Moose's native traits. =head1 DIFFERENCES IN FUNCTIONALITY =over 4 =item B Returns values from the hash. In list context it returns a list of values in the hash for the given keys. In scalar context it returns the value for the last key specified. =item B Sets the elements in the hash to the given values. It returns the new values set for each key, in the same order as the keys passed to the method. This method requires at least two arguments, and expects an even number of arguments. =item B Removes the elements with the given keys. In list context it returns a list of values in the hash for the deleted keys. In scalar context it returns the value for the last key specified. =back =head1 SEE ALSO =over 4 =item * L =item * L =back =head1 AUTHOR Matthew Phillips =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Matthew Phillips . 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 __END__ ==pod MooX-HandlesVia-0.001005/lib/Data/Perl/String/MooseLike.pm000644 012504 012504 00000004265 12255076473 024735 0ustar00mphillipsmphillips000000 000000 package Data::Perl::String::MooseLike; { $Data::Perl::String::MooseLike::VERSION = '0.001005'; } # ABSTRACT: data::Perl::String subclass that simulates Moose's native traits. use strictures 1; use Role::Tiny::With; use Class::Method::Modifiers; with 'Data::Perl::Role::String'; my @methods = grep { $_ ne 'new' } Role::Tiny->methods_provided_by('Data::Perl::Role::String'); around @methods => sub { my $orig = shift; $orig->(\$_[0], @_[1..$#_]); }; 1; =pod =encoding UTF-8 =head1 NAME Data::Perl::String::MooseLike - data::Perl::String subclass that simulates Moose's native traits. =head1 VERSION version 0.001005 =head1 SYNOPSIS use Data::Perl::Collection::Hash::MooseLike; my $hash = Data::Perl::Collection::Hash::MooseLike->new(a => 1, b => 2); $hash->values; # (1, 2) $hash->set('foo', 'bar'); # (a => 1, b => 2, foo => 'bar') =head1 DESCRIPTION This class provides a wrapper and methods for interacting with a hash. All methods are written to emulate/match existing behavior that exists with Moose's native traits. =head1 DIFFERENCES IN FUNCTIONALITY =over 4 =item B Returns values from the hash. In list context it returns a list of values in the hash for the given keys. In scalar context it returns the value for the last key specified. =item B Sets the elements in the hash to the given values. It returns the new values set for each key, in the same order as the keys passed to the method. This method requires at least two arguments, and expects an even number of arguments. =item B Removes the elements with the given keys. In list context it returns a list of values in the hash for the deleted keys. In scalar context it returns the value for the last key specified. =back =head1 SEE ALSO =over 4 =item * L =item * L =back =head1 AUTHOR Matthew Phillips =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Matthew Phillips . 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 __END__ ==pod MooX-HandlesVia-0.001005/lib/Data/Perl/Number/MooseLike.pm000644 012504 012504 00000002454 12255076473 024715 0ustar00mphillipsmphillips000000 000000 package Data::Perl::Number::MooseLike; { $Data::Perl::Number::MooseLike::VERSION = '0.001005'; } # ABSTRACT: data::Perl::Number subclass that simulates Moose's native traits. use strictures 1; use Role::Tiny::With; use Class::Method::Modifiers; with 'Data::Perl::Role::Number'; my @methods = grep { $_ ne 'new' } Role::Tiny->methods_provided_by('Data::Perl::Role::Number'); around @methods => sub { my $orig = shift; $orig->(\$_[0], @_[1..$#_]); }; 1; =pod =encoding UTF-8 =head1 NAME Data::Perl::Number::MooseLike - data::Perl::Number subclass that simulates Moose's native traits. =head1 VERSION version 0.001005 =head1 SYNOPSIS # you should not be consuming this class directly. =head1 DESCRIPTION This class provides a wrapper and methods for interacting with a boolean. All methods are written to emulate/match existing behavior that exists with Moose's native traits. =head1 SEE ALSO =over 4 =item * L =item * L =back =head1 AUTHOR Matthew Phillips =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Matthew Phillips . 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 __END__ ==pod MooX-HandlesVia-0.001005/lib/Data/Perl/Bool/MooseLike.pm000644 012504 012504 00000002434 12255076473 024356 0ustar00mphillipsmphillips000000 000000 package Data::Perl::Bool::MooseLike; { $Data::Perl::Bool::MooseLike::VERSION = '0.001005'; } # ABSTRACT: data::Perl::Bool subclass that simulates Moose's native traits. use strictures 1; use Role::Tiny::With; use Class::Method::Modifiers; with 'Data::Perl::Role::Bool'; my @methods = grep { $_ ne 'new' } Role::Tiny->methods_provided_by('Data::Perl::Role::Bool'); around @methods => sub { my $orig = shift; $orig->(\$_[0], @_[1..$#_]); }; 1; =pod =encoding UTF-8 =head1 NAME Data::Perl::Bool::MooseLike - data::Perl::Bool subclass that simulates Moose's native traits. =head1 VERSION version 0.001005 =head1 SYNOPSIS # you should not be consuming this class directly. =head1 DESCRIPTION This class provides a wrapper and methods for interacting with a boolean. All methods are written to emulate/match existing behavior that exists with Moose's native traits. =head1 SEE ALSO =over 4 =item * L =item * L =back =head1 AUTHOR Matthew Phillips =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Matthew Phillips . 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 __END__ ==pod MooX-HandlesVia-0.001005/lib/MooX/HandlesVia.pm000644 012504 012504 00000012605 12255076473 022722 0ustar00mphillipsmphillips000000 000000 package MooX::HandlesVia; { $MooX::HandlesVia::VERSION = '0.001005'; } # ABSTRACT: NativeTrait-like behavior for Moo. use strictures 1; use Module::Runtime qw/require_module/; # reserved hardcoded mappings for classname shortcuts. my %RESERVED = ( 'Array' => 'Data::Perl::Collection::Array::MooseLike', 'Hash' => 'Data::Perl::Collection::Hash::MooseLike', 'String' => 'Data::Perl::String::MooseLike', 'Bool' => 'Data::Perl::Bool::MooseLike', 'Number' => 'Data::Perl::Number::MooseLike', 'Code' => 'Data::Perl::Code', ); my %REVERSED = reverse %RESERVED; sub import { my ($class) = @_; no strict 'refs'; no warnings 'redefine'; my $target = caller; if(my $has = $target->can('has')) { my $newsub = sub { $has->(process_has(@_)); }; if($target->isa("Moo::Object")){ Moo::_install_tracked($target, "has", $newsub); } else{ Moo::Role::_install_tracked($target, "has", $newsub); } } } sub process_has { my ($name, %opts) = @_; my $handles = $opts{handles}; return ($name, %opts) if not $handles or ref $handles ne 'HASH'; if (my $via = delete $opts{handles_via}) { $via = ref $via eq 'ARRAY' ? $via->[0] : $via; # try to load the reserved mapping, if it exists, else the full name $via = $RESERVED{$via} || $via; require_module($via); # clone handles for HandlesMoose support my %handles_clone = %$handles; while (my ($target, $delegation) = each %$handles) { # if passed an array, handle the curry if (ref $delegation eq 'ARRAY') { my ($method, @curry) = @$delegation; if ($via->can($method)) { $handles->{$target} = ['${\\'.$via.'->can("'.$method.'")}', @curry]; } } elsif (ref $delegation eq '') { if ($via->can($delegation)) { $handles->{$target} = '${\\'.$via.'->can("'.$delegation.'")}'; } } } # install our support for moose upgrading of class/role # we deleted the handles_via key above, but install it as a native trait my $inflator = $opts{moosify}; $opts{moosify} = sub { my ($spec) = @_; $spec->{handles} = \%handles_clone; $spec->{traits} = [$REVERSED{$via} || $via]; # pass through if needed $inflator->($spec) if ref($spec) eq 'CODE'; }; } ($name, %opts); } 1; =pod =encoding UTF-8 =head1 NAME MooX::HandlesVia - NativeTrait-like behavior for Moo. =head1 VERSION version 0.001005 =head1 SYNOPSIS { package Hashy; use Moo; use MooX::HandlesVia; has hash => ( is => 'rw', handles_via => 'Hash', handles => { get_val => 'get', set_val => 'set', all_keys => 'keys' } ); } my $h = Hashy->new(hash => { a => 1, b => 2}); $h->get_val('b'); # 2 $h->set_val('a', 'BAR'); # sets a to BAR my @keys = $h->all_keys; # returns a, b =head1 DESCRIPTION MooX::HandlesVia is an extension of Moo's 'handles' attribute functionality. It provides a means of proxying functionality from an external class to the given atttribute. This is most commonly used as a way to emulate 'Native Trait' behavior that has become commonplace in Moose code, for which there was no Moo alternative. =head1 SHORTCOMINGS Due to current Moo implementation details there are some deficiencies in how MooX::HandlesVia in comparison to what you would expect from Moose native traits. =over 4 =item * methods delegated via the Moo 'handles' interface are passed the attribue value directly. and there is no way to access the parent class. This means if an attribute is updated any triggers or type coercions B fire. =item * Moo attribute method delegations are passed the attribute value. This is fine for references (objects, arrays, hashrefs..) it means simple scalar types are B. This unfortunately means Number, String, Counter, Bool cannot modify the attributes value, rendering them largely useless. =back =head1 PROVIDED INTERFACE/FUNCTIONS =over 4 =item B MooX::HandlesVia preprocesses arguments passed to has() attribute declarations via the process_has function. In a given Moo class, If 'handles_via' is set to a ClassName string, and 'handles' is set with a hashref mapping of desired moo class methods that should map to ClassName methods, process_has() will create the appropriate binding to create the mapping IF ClassName provides that named method. has options => ( is => 'rw', handles_via => 'Array', handles => { mixup => 'shuffle', unique_options => 'uniq', all_options => 'elements' } ); =back The following handles_via keywords are reserved as shorthand for mapping to L: =over 4 =item * B maps to L =item * B maps to L =item * B maps to L =item * B maps to L =item * B maps to L =item * B maps to L =back =head1 SEE ALSO =over 4 =item * L =item * L =back =head1 AUTHOR Matthew Phillips =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 by Matthew Phillips . 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 __END__ ==pod MooX-HandlesVia-0.001005/t/hash.t000644 012504 012504 00000002226 12255076473 020267 0ustar00mphillipsmphillips000000 000000 use strict; use warnings; use Data::Perl::Collection::Hash::MooseLike; { package Ex1; use Moo; use MooX::HandlesVia; has foos => ( is => 'ro', handles => { 'get_foo' => 'get', 'set_foo' => 'set', }, ); has bars => ( is => 'ro', handles => { 'get_bar' => '${\Data::Perl::Collection::Hash::MooseLike->can("get")}', 'set_bar' => '${\Data::Perl::Collection::Hash::MooseLike->can("set")}', }, ); has bazes => ( is => 'rw', handles_via => 'Hash', handles => { get_baz => 'get', bazkeys => 'keys' } ); } my $ex = Ex1->new( foos => Data::Perl::Collection::Hash::MooseLike->new(one => 1), bars => { one => 1 }, bazes => { ate => 'nine', two => 'five' }, ); use Test::More; use Test::Exception; is ($ex->get_foo('one'), 1, 'get_foo worked'); is ($ex->get_bar('one'), 1, 'get_bar worked'); is ($ex->set_foo('two', 2), 2, 'set_foo worked'); is ($ex->set_bar('two', 2), 2, 'set_bar worked'); is ($ex->foos->{'two'}, 2, 'foos accessor worked'); is ($ex->get_baz('ate'), 'nine', 'get_baz worked'); is_deeply([sort $ex->bazkeys], [qw/ate two/] , 'bazkeys worked'); done_testing; MooX-HandlesVia-0.001005/t/invalid.t000644 012504 012504 00000001404 12255076473 020767 0ustar00mphillipsmphillips000000 000000 use strict; use warnings; use Test::More; use Test::Exception; # test invalid input lives_ok { package foo; use Moo; use MooX::HandlesVia; has asdf => ( is => 'rw', handles => [qw/a b/], ); } 'invalid handles ref passed along cleanly'; lives_ok { package boo; use MooX::HandlesVia; } 'noop if has() is not found in the samespace'; lives_ok { package bop; use Moo; use MooX::HandlesVia; has foo => (is => 'rw'); } 'noop on runs with no handles_via'; lives_ok { package baz; use Moo; use MooX::HandlesVia; has asdf => ( is => 'rw', handles_via => 'Hash', handles => { 'existing' => 'get', 'fake' => 'this_shouldnt_do_anything', } ); } 'Missing target methods just get ignored'; done_testing; MooX-HandlesVia-0.001005/t/arbitrary.t000644 012504 012504 00000001301 12255076473 021334 0ustar00mphillipsmphillips000000 000000 { # arbitrary class, not leveraging Data::Perl package Data::Hash; sub new { my $cl = shift; bless({ @_ }, $cl) } sub get { $_[0]->{$_[1]} } sub set { $_[0]->{$_[1]} = $_[2] } } { package Ex1; use Moo; has foos => ( is => 'ro', handles_via => ['Data::Hash'], # test for array deref handles => { 'get_foo' => 'get', 'set_foo' => 'set', }, ); } my $ex = Ex1->new( foos => Data::Hash->new(one => 1), ); use Test::More; is $ex->foos->get('one'), 1, 'getter works with arbitrary class'; is $ex->foos->set('one', 'two'), 'two', 'setter works with arbitrary class'; is $ex->foos->get('one'), 'two', 'getter still works after modification'; done_testing; MooX-HandlesVia-0.001005/t/unimport/000755 012504 012504 00000000000 12255076473 021032 5ustar00mphillipsmphillips000000 000000 MooX-HandlesVia-0.001005/t/proof_of_concept.t000644 012504 012504 00000001320 12255076473 022662 0ustar00mphillipsmphillips000000 000000 { package Data::Hash; sub new { my $cl = shift; bless({ @_ }, $cl) } sub get { $_[0]->{$_[1]} } sub set { $_[0]->{$_[1]} = $_[2] } } { package Ex1; use Moo; has foos => ( is => 'ro', handles => { 'get_foo' => 'get', 'set_foo' => 'set', }, ); has bars => ( is => 'ro', handles => { 'get_bar' => '${\Data::Hash->can("get")}', 'set_bar' => '${\Data::Hash->can("set")}', }, ); } my $ex = Ex1->new( foos => Data::Hash->new(one => 1), bars => { one => 1 }, ); use Test::More; foreach my $name (qw(foo bar)) { is($ex->${\"get_${name}"}('one'), 1); $ex->${\"set_${name}"}('two', 2); is($ex->${\"${name}s"}->{'two'}, 2); } done_testing; MooX-HandlesVia-0.001005/t/handlesvia_in_role.t000644 012504 012504 00000002356 12255076473 023175 0ustar00mphillipsmphillips000000 000000 use strict; use warnings; use Data::Perl::Collection::Hash::MooseLike; { package Ex1::Role; use Moo::Role; use MooX::HandlesVia; has foos => ( is => 'ro', handles => { 'get_foo' => 'get', 'set_foo' => 'set', }, ); has bars => ( is => 'ro', handles => { 'get_bar' => '${\Data::Perl::Collection::Hash::MooseLike->can("get")}', 'set_bar' => '${\Data::Perl::Collection::Hash::MooseLike->can("set")}', }, ); has bazes => ( is => 'rw', handles_via => 'Hash', handles => { get_baz => 'get', bazkeys => 'keys' } ); no Moo::Role; } { package Ex1; use Moo; with qw/Ex1::Role/; } my $ex = Ex1->new( foos => Data::Perl::Collection::Hash::MooseLike->new(one => 1), bars => { one => 1 }, bazes => { ate => 'nine', two => 'five' }, ); use Test::More; use Test::Exception; is ($ex->get_foo('one'), 1, 'get_foo worked'); is ($ex->get_bar('one'), 1, 'get_bar worked'); is ($ex->set_foo('two', 2), 2, 'set_foo worked'); is ($ex->set_bar('two', 2), 2, 'set_bar worked'); is ($ex->foos->{'two'}, 2, 'foos accessor worked'); is ($ex->get_baz('ate'), 'nine', 'get_baz worked'); is_deeply([sort $ex->bazkeys], [qw/ate two/] , 'bazkeys worked'); done_testing; MooX-HandlesVia-0.001005/t/release-pod-syntax.t000644 012504 012504 00000000450 12255076473 023065 0ustar00mphillipsmphillips000000 000000 #!perl BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use Test::More; eval "use Test::Pod 1.41"; plan skip_all => "Test::Pod 1.41 required for testing POD" if $@; all_pod_files_ok(); MooX-HandlesVia-0.001005/t/release-pod-coverage.t000644 012504 012504 00000000765 12255076473 023343 0ustar00mphillipsmphillips000000 000000 #!perl BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use Test::More; eval "use Test::Pod::Coverage 1.08"; plan skip_all => "Test::Pod::Coverage 1.08 required for testing POD coverage" if $@; eval "use Pod::Coverage::TrustPod"; plan skip_all => "Pod::Coverage::TrustPod required for testing POD coverage" if $@; all_pod_coverage_ok({ coverage_class => 'Pod::Coverage::TrustPod' }); MooX-HandlesVia-0.001005/t/from-moose/000755 012504 012504 00000000000 12255076473 021240 5ustar00mphillipsmphillips000000 000000 MooX-HandlesVia-0.001005/t/from-moose/trait_bool.t000644 012504 012504 00000005423 12255076473 023567 0ustar00mphillipsmphillips000000 000000 #!/usr/bin/perl use strict; use warnings; #use lib 't/lib'; #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 = @_; eval qq| package $name; use Moo; use MooX::HandlesVia; use MooX::Types::MooseLike::Base qw/Bool/; has is_lit => ( handles_via => 'Bool', handles => \\%handles, isa => Bool, is => 'rw', default => sub { 0 }, clearer => '_clear_is_list', \%attr, ); 1; |; return ( $name++, \%handles ); } } { run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); run_tests( build_class( no_inline => 1 ) ); # Will force the inlining code to check the entire hashref when it is modified. #subtype '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 ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; my $obj = $class->new(is_lit => 1); #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/Cannot call set with any arguments/, 'set throws an error when an argument is passed' ); $obj = $class->new(is_lit => 0); #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/Cannot call unset with any arguments/, 'unset throws an error when an argument is passed' ); $obj = $class->new(is_lit => 1); #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/Cannot call toggle with any arguments/, 'toggle throws an error when an argument is passed' ); #$obj->flip_switch; $obj = $class->new(is_lit => 0); 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' ); } done_testing; MooX-HandlesVia-0.001005/t/from-moose/trait_code.t000644 012504 012504 00000004667 12255076473 023557 0ustar00mphillipsmphillips000000 000000 use strict; use warnings; #use lib 't/lib'; #use Moose (); #use NoInlineAttribute; use Test::More; use Test::Exception; #use Test::Moose; { my $name = 'Foo1'; sub build_class { my ( $attr1, $attr2, $attr3 ) = @_; eval qq? package $name; use Moo; use MooX::HandlesVia; use MooX::Types::MooseLike::Base qw/CodeRef/; has callback => ( is => 'rw', isa => CodeRef, handles_via => 'Code', handles => { 'invoke_callback' => 'execute' }, required => 1, %{ \$attr1 || {} }, ); has callback_method => ( is => 'rw', isa => CodeRef, handles_via => 'Code', handles => { 'invoke_method_callback' => 'execute_method' }, required => 1, %{ \$attr2 || {} }, ); has multiplier => ( is => 'rw', isa => CodeRef, handles_via => 'Code', handles => { 'multiply' => 'execute' }, required => 1, %{ \$attr3 || {} }, ); 1; ?; return $name++; } } { 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 ) = @_; #ok( #!$class->can($_), #"Code trait didn't create reader method for $_" #) for qw(callback callback_method multiplier); ${$iref} = 0; my $obj = $class->new(@args); $obj->invoke_callback; is( ${$iref}, 1, '$i is 1 after invoke_callback' ); throws_ok { $obj->invoke_method_callback } qr/unimplemented/, 'Call as method remains unimplemented'; #'invoke_method_callback calls multiply with @_' is( $obj->multiply(3), 6, 'multiple double value' ); } done_testing; MooX-HandlesVia-0.001005/t/from-moose/trait_hash.t000644 012504 012504 00000020553 12255076473 023560 0ustar00mphillipsmphillips000000 000000 #!/usr/bin/perl use strict; use warnings; #use lib 't/lib'; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::Fatal; use Test::More; #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 $class = $name++; eval qq| package $class; use Moo; use MooX::HandlesVia; use MooX::Types::MooseLike::Base qw/HashRef Str/; has options => ( is => 'rw', isa => HashRef[Str], handles_via => 'Hash', handles => \\%handles, default => sub { {} }, clearer => '_clear_options', %attr, ); 1; |; return ( $class, \%handles, \%attr ); } } { 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 ) ); # Will force the inlining code to check the entire hashref when it is modified. #subtype 'MyHashRef', as 'HashRef[Str]', where { 1 }; #run_tests( build_class( isa => 'MyHashRef' ) ); #coerce 'MyHashRef', from 'HashRef', via { $_ }; #run_tests( build_class( isa => 'MyHashRef', coerce => 1 ) ); } sub run_tests { my ( $class, $handles, $obj_attr) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; 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/You must pass an even number of arguments to set/, #'exception with odd number of arguments' #); #like( #exception { $obj->set_option( undef, 'bar' ) }, #qr/Hash keys passed to set must be defined/, #'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/Cannot call accessor without at least 1 argument/, #'error when calling accessor with no arguments' #); #like( #exception { $obj->option_accessor( undef, 'bar' ) }, #qr/Hash keys passed to accessor must be defined/, #'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' ); TODO: { local $TODO = 'this is currently difficult to implement due to Moo details.'; 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 ($obj_attr->{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' ); } } { use MooX::Types::MooseLike::Base qw/HashRef/; my ( $class, $handles ) = build_class( isa => HashRef ); my $obj = $class->new; 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' ); } done_testing; MooX-HandlesVia-0.001005/t/from-moose/trait_array.t000644 012504 012504 00000055411 12255076473 023754 0ustar00mphillipsmphillips000000 000000 #!/usr/bin/perl use strict; use warnings; #use Moose::Util::TypeConstraints; #use NoInlineAttribute; #use Test::Moose; use Test::More; use Test::Fatal; { 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 $class = $name++; eval qq| package $class; use Moo; use MooX::HandlesVia; use MooX::Types::MooseLike::Base qw/ArrayRef Int/; has _values => ( is => 'rw', isa => ArrayRef[Int], handles_via => 'Array', handles => \\%handles, default => sub { [] }, clearer => '_clear_values', %attr, ); 1; |; 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; } } { run_tests(build_class); run_tests( build_class( lazy => 1, default => sub { [ 42, 84 ] } ) ); run_tests( build_class( trigger => sub { } ) ); #run_tests( build_class( no_inline => 1 ) ); # Will force the inlining code to check the entire arrayref when it is modified. #subtype 'MyArrayRef', as 'ArrayRef', where { 1 }; #run_tests( build_class( isa => 'MyArrayRef' ) ); #coerce 'MyArrayRef', from 'ArrayRef', via { $_ }; #run_tests( build_class( isa => 'MyArrayRef', coerce => 1 ) ); } sub run_tests { my ( $class, $handles ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; 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/Cannot call count with any arguments/, '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/Cannot call pop with any arguments/, 'call to pop with arguments dies' ); is( $obj->shift, 101, 'shift returns the first value' ); #like( exception { $obj->shift(42) }, qr/Cannot call shift with any arguments/, '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' ); #like( exception { $obj->elements(22) }, qr/Cannot call elements with any arguments/, '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/Cannot call get without at least 1 argument/, 'throws an error when get is called without any arguments' ); #like( exception { $obj->get( {} ) }, qr/The index passed to get must be an integer/, 'throws an error when get is called with an invalid argument' ); #like( exception { $obj->get(2.2) }, qr/The index passed to get must be an integer/, 'throws an error when get is called with an invalid argument' ); #like( exception { $obj->get('foo') }, qr/The index passed to get must be an integer/, 'throws an error when get is called with an invalid argument' ); #like( exception { $obj->get_curried(2) }, qr/Cannot call get with more than 1 argument/, '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/Cannot call set with more than 2 arguments/, '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/Cannot call set with more than 2 arguments/, '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/Cannot call set with more than 2 arguments/, 'throws an error when set_curried_2 is called with one argument' ); 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/Cannot call accessor without at least 1 argument/, # '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/Cannot call accessor with more than 2 arguments/, '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/Cannot call accessor with more than 2 arguments/, '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/Cannot call accessor with more than 2 arguments/, '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/Cannot call clear with any arguments/, '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/Cannot call is_empty with any arguments/, '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/Cannot call delete with more than 1 argument/, '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/Cannot call delete with more than 1 argument/, '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/Cannot call insert with more than 2 arguments/, '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/Cannot call splice without at least 1 argument/, 'throws an error when splice is called with no arguments' ); #like( exception { $obj->splice( 1, 'foo', ) }, qr/The length argument passed to splice must be an integer/, '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_deeply( [ $obj->sort( sub { $_[0] <=> $_[1] } ) ], [ 3, 5, 9, 11, 22 ], 'sort returns values sorted by provided function' ); #like( exception { $obj->sort(1) }, qr/The argument passed to sort must be a code reference/, 'throws an error when passing a non coderef to sort' ); #like( exception { # $obj->sort( sub { }, 27 ); #}, qr/Cannot call sort with more than 1 argument/, '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/The argument passed to sort_in_place must be a code reference/, 'throws an error when passing a non coderef to sort_in_place' ); #like( exception { # $obj->sort_in_place( sub { }, 27 ); #}, qr/Cannot call sort_in_place with more than 1 argument/, '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/Cannot call sort_in_place with more than 1 argument/, '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/Cannot call map without at least 1 argument/, 'throws an error when passing no arguments to map' ); #like( exception { # $obj->map( sub { }, 2 ); #}, qr/Cannot call map with more than 1 argument/, 'throws an error when passing two arguments to map' ); #like( exception { $obj->map( {} ) }, qr/The argument passed to map must be a code reference/, '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/Cannot call map with more than 1 argument/, '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/Cannot call grep without at least 1 argument/, 'throws an error when passing no arguments to grep' ); #like( exception { # $obj->grep( sub { }, 2 ); #}, qr/Cannot call grep with more than 1 argument/, 'throws an error when passing two arguments to grep' ); #like( exception { $obj->grep( {} ) }, qr/The argument passed to grep must be a code reference/, '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/Cannot call grep with more than 1 argument/, '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/Cannot call first without at least 1 argument/, 'throws an error when passing no arguments to first' ); #like( exception { # $obj->first( sub { }, 2 ); #}, qr/Cannot call first with more than 1 argument/, 'throws an error when passing two arguments to first' ); #like( exception { $obj->first( {} ) }, qr/The argument passed to first must be a code reference/, '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/Cannot call first with more than 1 argument/, '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/Cannot call first_index without at least 1 argument/, 'throws an error when passing no arguments to first_index' ); #like( exception { # $obj->first_index( sub { }, 2 ); #}, qr/Cannot call first_index with more than 1 argument/, 'throws an error when passing two arguments to first_index' ); #like( exception { $obj->first_index( {} ) }, qr/The argument passed to first_index must be a code reference/, '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/Cannot call first_index with more than 1 argument/, '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( OverloadStr->new(q{}) ), '1234', 'join returns expected result when joining with empty string' ); #like( exception { $obj->join }, qr/Cannot call join without at least 1 argument/, 'throws an error when passing no arguments to join' ); #like( exception { $obj->join( '-', 2 ) }, qr/Cannot call join with more than 1 argument/, 'throws an error when passing two arguments to join' ); #like( exception { $obj->join( {} ) }, qr/The argument passed to join must be a string/, '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/Cannot call shuffle with any arguments/, '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/Cannot call uniq with any arguments/, '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/Cannot call reduce without at least 1 argument/, 'throws an error when passing no arguments to reduce' ); #like( exception { #$obj->reduce( sub { }, 2 ); #}, qr/Cannot call reduce with more than 1 argument/, 'throws an error when passing two arguments to reduce' ); #like( exception { $obj->reduce( {} ) }, qr/The argument passed to reduce must be a code reference/, '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/Cannot call reduce with more than 1 argument/, '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' ); @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/The n value passed to natatime must be an integer/, 'throws an error when passing a non integer to natatime' ); #like( exception { $obj->natatime( 2, {} ) }, qr/The second argument passed to natatime must be a code reference/, '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/The second argument passed to natatime must be a code reference/, 'throws an error when passing a non code ref to natatime_curried' ); } { use MooX::Types::MooseLike::Base qw/ArrayRef/; my ( $class, $handles ) = build_class( isa => ArrayRef ); my $obj = $class->new; 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' ); } done_testing; MooX-HandlesVia-0.001005/t/from-moose/trait_number.t000644 012504 012504 00000010466 12255076473 024127 0ustar00mphillipsmphillips000000 000000 #!/usr/bin/perl use strict; use warnings; #use lib 't/lib'; #use Moose (); #use Moose::Util::TypeConstraints; #use NoInlineAttribute; use Test::Fatal; use Test::More; #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 $class = $name++; my @traits = 'String'; eval qq| package $class; use Moo; use MooX::HandlesVia; use MooX::Types::MooseLike::Base qw/Int/; has integer => ( handles_via => 'Number', handles => \\%handles, is => 'rw', isa => Int, default => sub { 5 }, clearer => '_clear_integer', %attr, ); 1; |; return ( $class, \%handles, \%attr ); } } { run_tests(build_class); run_tests( build_class( lazy => 1 ) ); run_tests( build_class( trigger => sub { } ) ); #run_tests( build_class( no_inline => 1 ) ); # Will force the inlining code to check the entire hashref when it is modified. #subtype 'MyInt', as 'Int', where { 1 }; #run_tests( build_class( isa => 'MyInt' ) ); #coerce 'MyInt', from 'Int', via { $_ }; #run_tests( build_class( isa => 'MyInt', coerce => 1 ) ); } sub run_tests { my ( $class, $handles, $attr) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; 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' ); $obj->integer(15); #like( exception { $obj->add( 10, 2 ) }, qr/Cannot call add with more than 1 argument/, 'add throws an error when 2 arguments are passed' ); is( $obj->sub(3), 12, 'sub returns new value' ); $obj->integer(12); is( $obj->integer, 12, 'Subtract three for 12' ); #like( exception { $obj->sub( 10, 2 ) }, qr/Cannot call sub with more than 1 argument/, 'sub throws an error when 2 arguments are passed' ); #is( $obj->set(10), 10, 'set returns new value' ); $obj->integer(10); is( $obj->integer, 10, 'Set to ten' ); #like( exception { $obj->set( 10, 2 ) }, qr/Cannot call set with more than 1 argument/, 'set throws an error when 2 arguments are passed' ); is( $obj->div(2), 5, 'div returns new value' ); $obj->integer(5); is( $obj->integer, 5, 'divide by 2' ); #like( exception { $obj->div( 10, 2 ) }, qr/Cannot call div with more than 1 argument/, 'div throws an error when 2 arguments are passed' ); is( $obj->mul(2), 10, 'mul returns new value' ); $obj->integer(10); is( $obj->integer, 10, 'multiplied by 2' ); #like( exception { $obj->mul( 10, 2 ) }, qr/Cannot call mul with more than 1 argument/, 'mul throws an error when 2 arguments are passed' ); is( $obj->mod(2), 0, 'mod returns new value' ); $obj->integer(0); is( $obj->integer, 0, 'Mod by 2' ); #like( exception { $obj->mod( 10, 2 ) }, qr/Cannot call mod with more than 1 argument/, 'mod throws an error when 2 arguments are passed' ); #$obj->set(7); $obj->mod(5); $obj->integer(2); is( $obj->integer, 2, 'Mod by 5' ); #$obj->set(-1); $obj->integer(-1); is( $obj->abs, 1, 'abs returns new value' ); #like( exception { $obj->abs(10) }, qr/Cannot call abs with any arguments/, 'abs throws an error when an argument is passed' ); $obj->integer(1); is( $obj->integer, 1, 'abs 1' ); $obj->integer(12); #$obj->set(12); $obj->inc; is( $obj->inc, 13, 'inc 12' ); $obj->dec; is( $obj->dec, 11, 'dec 13' ); #if ( $attr->{lazy} ) { #my $obj = $class->new; #$obj->add(2); #is( $obj->add, 7, 'add with lazy default' ); #this probably should work. need some interface to moo internals.. #$obj->_clear_integer; #$obj->mod(2); #is( $obj->mod, 1, 'mod with lazy default' ); #} } done_testing; MooX-HandlesVia-0.001005/t/from-moose/trait_string.t000644 012504 012504 00000022001 12255076473 024131 0ustar00mphillipsmphillips000000 000000 #!/usr/bin/perl use strict; use warnings; #use lib 't/lib'; #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 $class = $name++; eval qq| package $class; use Moo; use MooX::HandlesVia; use MooX::Types::MooseLike::Base qw/Str/; has _string => ( handles_via => 'String', handles => \\%handles, is => 'rw', isa => Str, default => sub { q{} }, clearer => '_clear_string', %attr, ); 1; |; 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 ) ); # Will force the inlining code to check the entire hashref when it is modified. #subtype '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 ) = @_; can_ok( $class, $_ ) for sort keys %{$handles}; my $obj = $class->new(); $obj->length; 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/Cannot call length with any arguments/, '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/Cannot call inc with any arguments/, 'inc throws an error when an argument is passed' ); $obj->_string('b'); is( $obj->append('foo'), 'bfoo', 'append returns new value' ); #is( $obj->_string, 'bfoo', 'appended to the string' ); #like( exception { $obj->append( 'foo', 2 ) }, qr/Cannot call append with more than 1 argument/, '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/Cannot call append with more than 1 argument/, '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/Cannot call chomp with any arguments/, 'chomp throws an error when an argument is passed' ); $obj->_string("has nl"); is( $obj->chop, 'l', 'chop returns character removed' ); #is( $obj->_string, 'has n', 'chopped string' ); #like( exception { $obj->chop(42) }, qr/Cannot call chop with any arguments/, '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->_string('-barx'); $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/The first argument passed to replace must be a string or regexp reference/, 'replace throws an error when the first argument is not a string or regexp' ); #like( exception { $obj->replace( qr/x/, {} ) }, qr/The second argument passed to replace must be a string or code reference/, '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/Cannot call match without at least 1 argument/, 'match throws an error when no arguments are passed' ); #like( exception { $obj->match( {} ) }, qr/The argument passed to match must be a string or regexp reference/, '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/Cannot call clear with any arguments/, '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/Cannot call substr without at least 1 argument/, 'substr throws an error when no argumemts are passed' ); #like( exception { $obj->substr( 1, 2, 3, 4 ) }, qr/Cannot call substr with more than 3 arguments/, 'substr throws an error when four argumemts are passed' ); #like( exception { $obj->substr( {} ) }, qr/The first argument passed to substr must be an integer/, 'substr throws an error when first argument is not an integer' ); #like( exception { $obj->substr( 1, {} ) }, qr/The second argument passed to substr must be an integer/, 'substr throws an error when second argument is not an integer' ); #like( exception { $obj->substr( 1, 2, {} ) }, qr/The third argument passed to substr must be a string/, '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' #); } done_testing; MooX-HandlesVia-0.001005/t/unimport/no_moo.t000644 012504 012504 00000001407 12255076473 022507 0ustar00mphillipsmphillips000000 000000 # cleaning the namespace using "no Moo" use strict; use warnings; use Test::More; { package NoMoo::Moo; use Moo; no Moo; } { package NoMoo::HandlesVia; use Moo; use MooX::HandlesVia; no Moo; } { package NoMoo::HandlesVia::Role; use Moo::Role; use MooX::HandlesVia; no Moo::Role; } { package NoMoo::WithRole; use Moo; with qw/NoMoo::HandlesVia::Role/; no Moo; } my $moo_obj = new_ok "NoMoo::Moo"; my $handlesvia_obj = new_ok "NoMoo::HandlesVia"; my $role_obj = new_ok "NoMoo::WithRole"; ok ! $moo_obj->can("has"), 'plain Moo: namespace is cleaned'; ok ! $handlesvia_obj->can("has"), 'HandlesVia: namespace is cleaned'; ok ! $role_obj->can("has"), 'HandlesVia in a Role: namespace is cleaned'; done_testing; MooX-HandlesVia-0.001005/t/unimport/pollution.t000644 012504 012504 00000002355 12255076473 023251 0ustar00mphillipsmphillips000000 000000 # using Moo and MooX::HandlesVia without cleaning the namespace use strict; use warnings; use Test::More; { package Polluted::Moo; use Moo; } { package Polluted::HandlesVia; use Moo; use MooX::HandlesVia; } my $moo_obj = new_ok "Polluted::Moo"; my $handlesvia_obj = new_ok "Polluted::HandlesVia"; my $moo_has = $moo_obj->can("has"); my $handlesvia_has = $handlesvia_obj->can("has"); ok defined $moo_has, "Plain Moo-Object can 'has'"; ok defined $handlesvia_has, "HandlesVia-Object can 'has'"; ok ! $moo_obj->can("foo"), "Moo-Object can't 'foo'"; $moo_has->(foo => ( is => "lazy", default => sub{{}} ) ); can_ok $moo_obj, "foo"; ok defined $moo_obj->foo, "foo-attribute was set"; ok ! $handlesvia_obj->can("foo"), "HandlesVia-Object can't 'foo'"; $handlesvia_has->(foo => ( is => "lazy", default => sub{{}}, handles_via => "Hash", handles => { set_foo => "set", get_foo => "get"}, ) ); can_ok $handlesvia_obj, qw/foo set_foo get_foo/; ok defined $handlesvia_obj->foo, "foo-attribute was set"; ok ! $handlesvia_obj->get_foo("bar"), "bar is not defined in foo attribute"; $handlesvia_obj->set_foo("bar", "baz"); is $handlesvia_obj->get_foo("bar"), "baz", "delegation works as expected"; done_testing; MooX-HandlesVia-0.001005/t/unimport/namespace_clean.t000644 012504 012504 00000001771 12255076473 024323 0ustar00mphillipsmphillips000000 000000 # cleaning the namespace using 'namespace::clean' use strict; use warnings; use Test::More; eval { require namespace::clean }; plan skip_all => "namespace::clean is required for this test" if $@; eval <can("has"), 'plain Moo: namespace is cleaned'; ok ! $handlesvia_obj->can("has"), 'HandlesVia: namespace is cleaned'; ok ! $role_obj->can("has"), 'HandlesVia in a role: namespace is cleaned'; done_testing; MooX-HandlesVia-0.001005/t/unimport/namespace_autoclean.t000644 012504 012504 00000002054 12255076473 025207 0ustar00mphillipsmphillips000000 000000 # cleaning the namespace using 'namespace::clean' use strict; use warnings; use Test::More; eval { require namespace::autoclean }; plan skip_all => "namespace::autoclean is required for this test" if $@; eval <can("has"), 'plain Moo: namespace is cleaned'; ok ! $handlesvia_obj->can("has"), 'HandlesVia: namespace is cleaned'; ok ! $role_obj->can("has"), 'HandlesVia in a role: namespace is cleaned'; done_testing;