Method-Signatures-20160315000755001751000144 012672114746 14761 5ustar00buddyusers000000000000Method-Signatures-20160315/Build.PL000444001751000144 410212672114746 16407 0ustar00buddyusers000000000000#!/usr/bin/perl -w use 5.008001; use Module::Build; my $class = Module::Build->subclass( class => 'Module::Build::Custom', code => <<'SUBCLASS'); sub ACTION_distmeta{ my ($self) = @_; if (eval {require Pod::Readme; Pod::Readme->can('new') } ){ $self->delete_filetree('README'); my $prf = Pod::Readme->new( target => 'readme', base_dir => '.', input_file => $self->_main_docfile, output_file => 'README.pod', ); $prf->run(); $self->_add_to_manifest('MANIFEST', 'README.pod'); } $self->SUPER::ACTION_distmeta; }; SUBCLASS my $build = $class->new( module_name => 'Method::Signatures', license => 'perl', recursive_test_files => 1, configure_requires => { 'Module::Build' => '0.31', }, build_requires => { 'Module::Build' => '0.26', 'Test::More' => '0.82', 'Test::Builder' => '0.82', 'Test::Warn' => '0.10', 'Test::Exception' => '0.29', }, requires => { 'perl' => '5.8.1', 'Devel::Declare' => '0.006002', 'Devel::Declare::MethodInstaller::Simple' => '0.006002', 'Const::Fast' => '0.006', PPI => '1.203', 'Any::Moose' => '0.11', Mouse => '0.64', 'Sub::Name' => '0.03', 'Lexical::SealRequireHints' => '0.008', #0.008 is for perl 5.10.x, RT#93759 }, recommends => { 'Moose' => '0.96', 'Data::Alias' => '1.08', }, dist_author => 'Michael G Schwern ', meta_merge => { resources => { license => 'http://dev.perl.org/licenses/', bugtracker => 'http://rt.cpan.org/NoAuth/Bugs.html?Dist=Method-Signatures', repository => 'https://github.com/evalEmpire/method-signatures', }, }, create_readme => 1, create_license => 1, ); $build->create_build_script; Method-Signatures-20160315/META.yml000444001751000144 277412672114746 16401 0ustar00buddyusers000000000000--- abstract: 'method and function declarations with signatures and no source filter' author: - 'Michael G Schwern ' build_requires: Module::Build: '0.26' Test::Builder: '0.82' Test::Exception: '0.29' Test::More: '0.82' Test::Warn: '0.10' configure_requires: Module::Build: '0.31' dynamic_config: 1 generated_by: 'Module::Build version 0.4211, CPAN::Meta::Converter version 2.143240' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Method-Signatures provides: Method::Signatures: file: lib/Method/Signatures.pm version: '20160315' Method::Signatures::Modifiers: file: lib/Method/Signatures/Modifiers.pm version: '20160315' Method::Signatures::Parameter: file: lib/Method/Signatures/Parameter.pm Method::Signatures::Signature: file: lib/Method/Signatures/Signature.pm Method::Signatures::Types: file: lib/Method/Signatures/Types.pm Method::Signatures::Utils: file: lib/Method/Signatures/Utils.pm recommends: Data::Alias: '1.08' Moose: '0.96' requires: Any::Moose: '0.11' Const::Fast: '0.006' Devel::Declare: '0.006002' Devel::Declare::MethodInstaller::Simple: '0.006002' Lexical::SealRequireHints: '0.008' Mouse: '0.64' PPI: '1.203' Sub::Name: '0.03' perl: v5.8.1 resources: bugtracker: http://rt.cpan.org/NoAuth/Bugs.html?Dist=Method-Signatures license: http://dev.perl.org/licenses/ repository: https://github.com/evalEmpire/method-signatures version: '20160315' Method-Signatures-20160315/README.pod000444001751000144 425512672114746 16565 0ustar00buddyusers000000000000=head1 NAME Method::Signatures - method and function declarations with signatures and no source filter =head1 VERSION 20160315 =head1 SYNOPSIS package Foo; use Method::Signatures; method new (%args) { return bless {%args}, $self; } # Can also get type checking if you like: method set (Str $key, Int $val) { return $self->{$key} = $val; # now you know $val is always an integer } =head1 DESCRIPTION Provides two new keywords, C and C, so that you can write subroutines with signatures instead of having to spell out C C is like C but takes a signature where the prototype would normally go. This takes the place of C and does a whole lot more. C is like C but specifically for making methods. It will automatically provide the invocant as C<$self> (L). No more C. =head1 INSTALLATION This module sources are hosted on github https://github.com/evalEmpire/method-signatures.git and uses C to generate the distribution. It can be istalled: =over =item directly cpanm git://github.com/evalEmpire/method-signatures.git =item from CPAN cpan Method::Signatures cpanm Method::Signatures =item maualy cloninig the repository: git clone https://github.com/evalEmpire/method-signatures.git cd method-signatures perl Build.PL ./Build install =back =head1 REQUIREMENTS This distribution requires Perl v5.8.1. This distribution requires the following modules: =over 4 =item * L (version 0.11) =item * L (version 0.006) =item * L (version 0.006002) =item * L (version 0.006002) =item * L (version 0.008) =item * L (version 0.26) =item * L (version 0.64) =item * L (version 1.203) =item * L (version 0.03) =item * L (version 0.29) =item * L (version 0.10) =back This distribution recommends the following modules: =over 4 =item * L (version 1.08) =item * L (version 0.96) =back Method-Signatures-20160315/MANIFEST000444001751000144 427412672114746 16256 0ustar00buddyusers000000000000.travis.yml Build.PL Changes examples/iso_date_example.t examples/strip_ws.t lib/Method/Signatures.pm lib/Method/Signatures/Modifiers.pm lib/Method/Signatures/Parameter.pm lib/Method/Signatures/Signature.pm lib/Method/Signatures/Types.pm lib/Method/Signatures/Utils.pm LICENSE MANIFEST This list of files MANIFEST.SKIP META.json META.yml README README.pod t/alias.t t/anon.t t/array_param.t t/at_underscore.t t/attributes.t t/before_510.t t/begin.t t/block_defaults.t t/caller.t t/comments.t t/debugger.t t/default_invocant.t t/defaults.t t/defined_or_defaults.t t/error_interruption.t t/error_reporting.t t/examples/iso_date_example.t t/examples/silly.t t/examples/strip_ws.t t/func.t t/into.t t/invocant.t t/larna.t t/lib/Bad.pm t/lib/BadParameter.pm t/lib/BadType.pm t/lib/BarfyDie.pm t/lib/BasicRoleTest.pm t/lib/Dev/Null.pm t/lib/GenErrorRegex.pm t/lib/InnerBadType.pm t/lib/InnerMissingRequired.pm t/lib/InnerNoSuchNamed.pm t/lib/InnerUnknownType.pm t/lib/MispositionedSlurpy.pm t/lib/MissingRequired.pm t/lib/ModifierBadType.pm t/lib/MooseLoadTest.pm t/lib/MooseRoleTest.pm t/lib/MouseRoleTest.pm t/lib/MS_MXD_Replace.pm t/lib/MS_MXD_Role.pm t/lib/MS_MXD_Sub.pm t/lib/MultipleSlurpy.pm t/lib/My/Declare.pm t/lib/My/Method/Signatures.pm t/lib/NamedAfterOptPos.pm t/lib/NamedSlurpy.pm t/lib/NoOverrides.pm t/lib/NoSuchNamed.pm t/lib/OverrideErrors.pm t/lib/OverrideModifierErrors.pm t/lib/OverrideTypeCheck.pm t/lib/PosAfterNamed.pm t/lib/RequiredAfterOpt.pm t/lib/TrailingGarbage.pm t/lib/UnknownType.pm t/line_numbers.t t/method.t t/mxd-replace.t t/mxd-role.t t/mxd-sub.t t/named.t t/named_alias.t t/named_refs.t t/odd_number.t t/one_line.t t/optional.t t/override_errors.t t/override_modifier_errors.t t/override_nothing.t t/override_typecheck.t t/parameters.t t/paren_on_own_line.t t/paren_plus_open_block.t t/refs.t t/required.t t/ro.t t/role_check_basic.t t/role_check_moose.t t/role_check_mouse.t t/signature_error_handler.t t/simple.plx t/slurpy.t t/string_defaults.t t/syntax_errors.t t/thread-bug.t t/too_many_args.t t/trailing_comma.t t/traits.t t/type_check.t t/type_req_opt.t t/typeload_moose.t t/typeload_nomoose.t t/typeload_notypes.t t/types.t t/undef_defaults.t t/when.t t/where.t t/yadayada.t t/zero_defaults.t Method-Signatures-20160315/MANIFEST.SKIP000444001751000144 210012672114746 17005 0ustar00buddyusers000000000000 #!start included /Users/schwern/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/ExtUtils/MANIFEST.SKIP # Avoid version control files. \bRCS\b \bCVS\b \bSCCS\b ,v$ \B\.svn\b \B\.git\b \B\.gitignore\b \b_darcs\b \B\.cvsignore$ # Avoid VMS specific MakeMaker generated files \bDescrip.MMS$ \bDESCRIP.MMS$ \bdescrip.mms$ # Avoid Makemaker generated and utility files. \bMANIFEST\.bak \bMakefile$ \bblib/ \bMakeMaker-\d \bpm_to_blib\.ts$ \bpm_to_blib$ \bblibdirs\.ts$ # 6.18 through 6.25 generated this # Avoid Module::Build generated and utility files. \bBuild$ \b_build/ \bBuild.bat$ \bBuild.COM$ \bBUILD.COM$ \bbuild.com$ # Avoid temp and backup files. ~$ \.old$ \#$ \b\.# \.bak$ \.tmp$ \.# \.rej$ \.*\.swp # Avoid OS-specific files/dirs # Mac OSX metadata \B\.DS_Store # Mac OSX SMB mount metadata files \B\._ # Avoid Devel::Cover and Devel::CoverX::Covered files. \bcover_db\b \bcovered\b # Avoid MYMETA files ^MYMETA\. #!end included /Users/schwern/perl5/perlbrew/perls/perl-5.14.1/lib/5.14.1/ExtUtils/MANIFEST.SKIP ^\.git ^\.# ^MYMETA.yml$ ^MYMETA\.json$ talks/ ^extlib Method-Signatures-20160315/LICENSE000444001751000144 4377012672114746 16156 0ustar00buddyusers000000000000This software is copyright (c) 2016 by Michael G Schwern . 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) 2016 by Michael G Schwern . This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2016 by Michael G Schwern . 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 Method-Signatures-20160315/README000444001751000144 423012672114746 15775 0ustar00buddyusers000000000000NAME Method::Signatures - method and function declarations with signatures and no source filter VERSION 20160315 SYNOPSIS package Foo; use Method::Signatures; method new (%args) { return bless {%args}, $self; } # Can also get type checking if you like: method set (Str $key, Int $val) { return $self->{$key} = $val; # now you know $val is always an integer } DESCRIPTION Provides two new keywords, func and method, so that you can write subroutines with signatures instead of having to spell out my $self = shift; my($thing) = @_ func is like sub but takes a signature where the prototype would normally go. This takes the place of my($foo, $bar) = @_ and does a whole lot more. method is like func but specifically for making methods. It will automatically provide the invocant as $self (by default). No more my $self = shift. INSTALLATION This module sources are hosted on github https://github.com/evalEmpire/method-signatures.git and uses Module::Build to generate the distribution. It can be istalled: directly cpanm git://github.com/evalEmpire/method-signatures.git from CPAN cpan Method::Signatures cpanm Method::Signatures maualy cloninig the repository: git clone https://github.com/evalEmpire/method-signatures.git cd method-signatures perl Build.PL ./Build install REQUIREMENTS This distribution requires Perl v5.8.1. This distribution requires the following modules: * Any::Moose (version 0.11) * Const::Fast (version 0.006) * Devel::Declare (version 0.006002) * Devel::Declare::MethodInstaller::Simple (version 0.006002) * Lexical::SealRequireHints (version 0.008) * Module::Build (version 0.26) * Mouse (version 0.64) * PPI (version 1.203) * Sub::Name (version 0.03) * Test::Exception (version 0.29) * Test::Warn (version 0.10) This distribution recommends the following modules: * Data::Alias (version 1.08) * Moose (version 0.96) Method-Signatures-20160315/Changes000444001751000144 3424712672114746 16443 0ustar00buddyusers00000000000020160315 Tue Mar 15 16:21:33 PDT 2016 Promoted to full release 20160310.2049_001 Thu Mar 10 20:49:00 PST 2016 Docs * Fix broken link in POD [github #120] (thanks Manwar) Distribution Fixes * Generate README from POD [github #122/#123/#124] (thanks jluis) * Silence bogus Kwalitee failure [github #121] (thanks jluis) 20151120.1519_001 Fri Nov 20 15:19:44 PST 2015 Bug Fixes * Fix missing semi-colon [github #118] (thanks joenio) Distribution Fixes * Bump required version of Lexical::SealRequireHints to fix RT #93759 [github #119] (thanks chorny) 20141021 Tue Oct 21 02:11:29 PDT 2014 Promoted to full release 20140920.1910_001 Sat Sep 20 19:10:06 PDT 2014 New Features * Can now specify an alternate name for invocant (besides `$self`) [github #82] (thanks Hercynium) Bug Fixes * Correct parse error on multi-line default values [github #106] * Using a required param after an optional one now a compile error [github #108] 20140806.0226_001 Wed Aug 6 02:26:36 PDT 2014 Bug Fixes * Correct parse error when invocant is preceded by a space * Fix bug where undef which should trigger default fails typecheck [github #102] Distribution Fixes * Remove dependency on experimental (breaks 5.8 compat) [github #97] Misc * Refactor signature parsing into its own class [github #96] 20140224 Mon Feb 24 14:25:43 PST 2014 Promoted to full release 20140220.0106_001 Thu Feb 20 01:14:54 PST 2014 Distribution Fixes * Remove dependency on Devel::Pragma [github #91], and fixes [github #41] Docs * Document which features require Data::Alias and Const::Fast [github #90] 20131010 Thu Oct 10 00:57:41 PDT 2013 Promoted to full release 20131007.0002_002 Mon Oct 7 00:02:30 PDT 2013 Distribution Fixes * Fixed failing test in 5.10.0 (uncovered by CPAN Testers) 20131004.0159_001 Fri Oct 4 01:59:55 PDT 2013 Bug Fixes * Removed experimental smartmatch warnings * Don't require Data::Alias for named params unless you have to [github #71] Docs * Updated close parend problem to include quotes and a workaround [rt.cpan.org 85925] * Fixed some typos (thanks dsteinbrunner) [github #88] Distribution Fixes * Fixed repo link in metadata (thanks dsteinbrunner) [github #87] 20130505 May 5 21:17:45 PDT 2013 Promoted to full release 20130427.0031_001 Sat Apr 27 00:31:04 PDT 2013 Distribution Fixes * Add M::S::Parameter to MANIFEST [github #76] * Change representation of Infinity to work on Win32 [github #75] Bug Fixes * Fixed obscure bug where an eval in Method::Signatures wouldn't be skipped when carp'ing (i.e. in carp_location_for()) [github #72] Misc * Rearranged so signature is now an object [github #30] * Add hook for Travis CI [github #78] Docs * Found and fixed missing parend 20130222 Feb 22 21:10:10 PST 2013 Promoted to full release 20130218.1447_001 Mon Feb 18 14:47:28 PST 2013 Distribution Fixes * Fixed stray detritus in MANIFEST. * Somehow my last-minute fix to the new error handler test didn't make it in; this will fix "Can't locate Moose.pm" errors. 20130216.1729_001 Sat Feb 16 17:29:45 PST 2013 New Features * Handling of run-time errors (default: die) is now overridable by subclasses via signature_error_handler(). [github #54] Bug Fixes * Data::Alias is only loaded when needed avoiding a threads + eval bug in most cases and improving compile time performance. [rt.cpan.org 82922, github #62] 20121219.0033_001 Wed Dec 19 00:33:58 PST 2012 New Features * Can now have aliased named parameters. [github #57] Bug Fixes * Compile-time errors now reporting proper line numbers. [github #61] Docs * Minor clarifications here and there. * Clarified what doesn't work in Perl 5.8. * Added Function::Parameters to See Also section. * Updated copyright. 20121201 Sat Dec 1 01:59:44 PST 2012 Promoted to full release 20121128.2139_001 Wed Nov 28 21:39:16 PST 2012 Bug Fixes * Trailing commas on parameter lists are now ok. [rt.cpan.org 81364] Misc * Failure to parse parameters will now produce a more useful error. Distribution Fixes * Fixed test failing on 5.10.0 as per github #59. * Fixed subtests failing on Test::More's prior to 0.96. 20121108.0047_001 Thu Nov 8 00:47:15 PST 2012 New Features * remove dependency on Devel::BeginLift [github #39] Bug Fixes * Default condition of `when {}' now interpreted as `when { $_ ~~ {} }' (avoids parse error). [github #60] 20121025.2315_001 Thu Oct 25 23:15:20 PDT 2012 New Features * can now use `when' to specify default conditions [github #48] * can use `//=' as a shortcut for `when undef' [github #45] * can now provide `where' constraints in addition to (or instead of) a type [github #7] * can now use `...' to disable further argument checking [github #49] * can now specify more than one alternative in type unions [github #55] * can now nest parameterized types Incompatible Changes * can no longer use both `\' and `:' (didn't work anyway) Optimizations * better signature parsing using PPI [github #11] Docs * documented all new features * new ASCI-art breakdown of signature syntax * minor tweaks and corrections 20120523 May 23 16:36:04 PDT 2012 Distribution Fixes * Fixed META.json 20120517 Thu May 17 20:14:34 PDT 2012 Promoted to full release 20120514.0117_001 Mon May 14 01:17:38 PDT 2012 Distribution Fixes * Added version number to Method::Signatures::Modifiers. 20111125 Fri Nov 25 01:15:50 PST 2011 Optimizations * Type checks significantly faster. 40% faster with Mouse. 20% faster with Moose. [github #42] Distribution Fixes * Added Test::Exception as a build requirement [github #43] * Added Moose as a recommended module (with version number) 20111020 Thu Oct 20 17:00:29 PDT 2011 Promoted to full release 20111017.2055_002 Mon Oct 17 20:55:09 PDT 2011 Bug Fix * Move inject_if_block code back to MSM [github #40] 20110927.2305_001 Tue Sep 27 23:05:02 PDT 2011 Bug Fix * Remove spurious error for modifiers in roles [github #36] 20110923.1726 Fri Sep 23 17:27:47 PDT 2011 Distribution Fixes * 20110923 had a bad signature file because gpg is broken on my laptop. Releasing without a signature. 1 aM n0t A hax0r!!!1!1! 20110923 Fri Sep 23 16:13:46 PDT 2011 [It Takes All Types] Incompatible Changes * Slurpy parameters (@foo and %bar) now must come at the end. * Slurpy parameters cannot be named, they must be positional. * Slurpy parameters are now optional by default. [github #21] * The empty signature takes no arguments. [github #26] * No signature implies the empty signature and takes no arguments. [github #26] New Features * Now checking if there are too many arguments. [github #23] * Run-time errors are now class methods, so subclasses can override them. * Method::Signatures::Modifiers allows you to use Method::Signatures with MooseX::Declare and apply method modifiers like before, after and around. [Buddy Burden] [github #14] * compile_at_BEGIN option controls if "method" and "func" are compiled like normal statements or early like "sub". [github #8] Bug Fixes * Now depending on a version of Devel::Declare that works with 5.13 and up. [github #10] * Now depending on a known good version of Mouse. [github #17] * Improved error messages reporting from the right position in the user's code. [Buddy Burden] * Comments in the signature fixed. [Buddy Burden] [github #13] * Passing in too many positional parameters now generates an error. [github #23] * Fixed a case where we'd eat compilation errors. [github #16] * Optional parameters will no longer fail type checks if they're not passed in. [github #12] * Depending on a new version of Devel::Declare that works with perl 5.13 and up. [github #10] * Fix some cases where a compile time error will show up as an error inside PPI. Docs * Many grammar fixes and prose improvements [Noirin Plunkett] [github #25] * Slurpy parameters are clearly documented * The rules if a parameter is required or optional are more clear * Clarify that func() has no invocant [github #32] * Mention METHOD_SIGNATURES_DEBUG environment variable for debugging. [github #32] * Documented the "debug" option. * Documented issues with 5.8 and compile_at_BEGIN. [github #8] [github #22] Test Fixes * Tests will no longer fail because 5.10.0 and down report different errors on compilation failure. [github #18] * Tests will no longer fail on 5.8. [github #22] 20110324.1600_001 Thu, 24 Mar 2011 16:00:38 +1100 Bug Fix * Declare dependency on Any::Moose [github #9] 20110322.0027_001 Tue, 22 Mar 2011 00:27:00 +1100 New Features * Added support for Perl 6 style type syntax backed by Any::Moose (barefootcoder) [github #3] Test Fixes * t/syntax_errors.t would fail on some versions of Perl because we wouldn't get the expected error message out of eval. [github #4] 20110216.1153_001 Wed, 16 Feb 2011 11:35:05 +1100 New Features * Data::Alias is no longer optional. It's been fixed and is now maintained. Aliasing will now always work. Misc * Use Const::Fast to implement read only arguments. This avoids the optional Readonly::XS to make it fast. 20100730 Fri Jul 30 12:54:20 PDT 2010 New Features * Added func() to handle functions. Incompatible Changes * Data::Alias is now optional. This is because it does not work in 5.12 and there's no fix in sight. If you want to use aliasing in your distribution it will have to depend on Data::Alias itself. Docs * Updated the SEE ALSO * Removed the assertion that no checks are done on the signature 20090620 Sat Jun 20 01:26:59 PDT 2009 Performance * Load PPI on demand to reduce load time (needed by perl5i) Other * Separated signature translation between methods and subroutines (needed by perl5i) 20081028 Tue Oct 28 00:45:48 PDT 2008 New Features * Two or more slurpy parameters (ie. @foo or %bar) in a signature is an error. Bug Fixes * The debugger now works, thanks to an upgrade in Devel::Declare. * methods are now declared at compile time, like regular subs. Other * Added some simple example files. 20081021.1911 Tue Oct 21 19:11:47 PDT 2008 Test Fixes * Used a new feature of Test::Builder, upgrade dependency. 20081021 Tue Oct 21 01:43:24 PDT 2008 New Features * Checks for unspecified arguments * Almost anything can be used as a default. Bug Fixes * A default value with a comma in it is properly parsed. * Default values can now be any literal, even wacky things like q,Hi!, * The closing paren of a signature can now be on its own line. * The closing paren and the opening block can be on the same line. New Docs * Documented differences from Perl 6 20081008 Wed Oct 8 09:48:33 EDT 2008 New Features * Named parameters have some basic compile-time error checks for illegal signatures. New Docs * Document restritions on named parameters. 20081007 Tue Oct 7 23:27:19 EDT 2008 New Features * Added named parameters. Docs * Some documentation on what is not allowed, even if we don't yet check for it. * More thanks! * Add an example and comparision with regular Perl * Add some debugging tips 20081006 Mon Oct 6 02:24:36 EDT 2008 New Features * Implemented "is alias", "is ro", "is rw" and "is copy". * Multiple traits supported "is copy is rw" * Implemented ! and ? (required and optional arguments) Bug Fixes * Stole some code from MooseX::Method::Signatures to make attributes parse better. (thanks to Florian Ragwitz) Other - Repository moved to github. - Changing to ISO date versions. 0.11 Sat Sep 27 16:47:51 EDT 2008 New Features * Added the "$arg!" required syntax (currently does nothing) * Attributes now work (thanks to mst) New Docs - Documented how to set a trait and a default * Document that earlier params may be used in defaults. * Document that @_ is left intact * Clarify aliased ref behavior * Document anonymous methods Bug Fixes * Protect against complicated default expressions 0.10 Sun Sep 21 20:04:41 PDT 2008 New Features * Added "$class:" change the invocant a la Perl 6. * Added "$arg = EXPR" to set defaults. * Added "$arg?" optional param syntax (currently does nothing) * Added "$arg is foo" param traits (currently does nothing) * Expose a way to play with the prototype handler. Doc Fixes - Change "prototype" to "signature" to avoid confusion with Perl's built in prototypes. 0.05 Sun Sep 21 15:17:16 PDT 2008 Bug Fixes * methods now get the right name in caller(), not "Class::__ANON__". * The \@foo prototype no longer has a performance hit * Closures now work with \@foo (All the above thanks to Matthijs van Duin and his Sub::Name and Data::Alias) Test Fixes * Not rigorously checking the bitmask and hints flags from caller() as their behavior is undefined. This fixes the 5.10 test failures. 0.04 Sun Sep 21 13:52:29 PDT 2008 New Features * A \@foo protototype allows you to use a reference as a regular var New Docs * Documented the @_ prototype 0.03 Sun Sep 21 00:57:32 PDT 2008 New Features * Eliminate the need of the trailing semicolon New Bugs * The debugger and one-liners are broken New Docs * Better prototype docs 0.02 Wed Dec 26 02:07:26 PST 2007 Doc Fix * Forgot the "use Method::Signatures" in the SYNOPSIS 0.01 Wed Dec 26 01:55:33 PST 2007 It works! Method-Signatures-20160315/META.json000444001751000144 447612672114746 16552 0ustar00buddyusers000000000000{ "abstract" : "method and function declarations with signatures and no source filter", "author" : [ "Michael G Schwern " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4211", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Method-Signatures", "prereqs" : { "build" : { "requires" : { "Module::Build" : "0.26", "Test::Builder" : "0.82", "Test::Exception" : "0.29", "Test::More" : "0.82", "Test::Warn" : "0.10" } }, "configure" : { "requires" : { "Module::Build" : "0.31" } }, "runtime" : { "recommends" : { "Data::Alias" : "1.08", "Moose" : "0.96" }, "requires" : { "Any::Moose" : "0.11", "Const::Fast" : "0.006", "Devel::Declare" : "0.006002", "Devel::Declare::MethodInstaller::Simple" : "0.006002", "Lexical::SealRequireHints" : "0.008", "Mouse" : "0.64", "PPI" : "1.203", "Sub::Name" : "0.03", "perl" : "v5.8.1" } } }, "provides" : { "Method::Signatures" : { "file" : "lib/Method/Signatures.pm", "version" : "20160315" }, "Method::Signatures::Modifiers" : { "file" : "lib/Method/Signatures/Modifiers.pm", "version" : "20160315" }, "Method::Signatures::Parameter" : { "file" : "lib/Method/Signatures/Parameter.pm" }, "Method::Signatures::Signature" : { "file" : "lib/Method/Signatures/Signature.pm" }, "Method::Signatures::Types" : { "file" : "lib/Method/Signatures/Types.pm" }, "Method::Signatures::Utils" : { "file" : "lib/Method/Signatures/Utils.pm" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://rt.cpan.org/NoAuth/Bugs.html?Dist=Method-Signatures" }, "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "url" : "https://github.com/evalEmpire/method-signatures" } }, "version" : "20160315" } Method-Signatures-20160315/.travis.yml000444001751000144 15712672114746 17212 0ustar00buddyusers000000000000language: perl perl: - "5.20" - "5.18" - "5.16" - "5.14" - "5.12" - "5.10" - "5.8" Method-Signatures-20160315/lib000755001751000144 012672114746 15527 5ustar00buddyusers000000000000Method-Signatures-20160315/lib/Method000755001751000144 012672114746 16747 5ustar00buddyusers000000000000Method-Signatures-20160315/lib/Method/Signatures.pm000444001751000144 13654312672114746 21642 0ustar00buddyusers000000000000package Method::Signatures; use strict; use warnings; use Lexical::SealRequireHints; use base 'Devel::Declare::MethodInstaller::Simple'; use Method::Signatures::Utils; use Method::Signatures::Parameter; use Method::Signatures::Signature; our $VERSION = '20160315'; our $DEBUG = $ENV{METHOD_SIGNATURES_DEBUG} || 0; our $INF = ( 0 + "inf" ) == 0 ? 9e9999 : "inf"; # copied from Devel::Pragma sub my_hints() { $^H |= 0x20000; return \%^H; } =head1 NAME Method::Signatures - method and function declarations with signatures and no source filter =for readme plugin version =head1 SYNOPSIS package Foo; use Method::Signatures; method new (%args) { return bless {%args}, $self; } =for readme stop method get ($key) { return $self->{$key}; } method set ($key, $val) { return $self->{$key} = $val; } =for readme start # Can also get type checking if you like: method set (Str $key, Int $val) { return $self->{$key} = $val; # now you know $val is always an integer } =for readme stop func hello($greeting, $place) { print "$greeting, $place!\n"; } =for readme start =head1 DESCRIPTION Provides two new keywords, C and C, so that you can write subroutines with signatures instead of having to spell out C C is like C but takes a signature where the prototype would normally go. This takes the place of C and does a whole lot more. C is like C but specifically for making methods. It will automatically provide the invocant as C<$self> (L). No more C. =begin :readme =head1 INSTALLATION This module sources are hosted on github https://github.com/evalEmpire/method-signatures.git and uses C to generate the distribution. It can be istalled: =over =item directly cpanm git://github.com/evalEmpire/method-signatures.git =item from CPAN cpan Method::Signatures cpanm Method::Signatures =item maualy cloninig the repository: git clone https://github.com/evalEmpire/method-signatures.git cd method-signatures perl Build.PL ./Build install =back =for readme plugin requires =end :readme =for readme stop Also allows signatures, very similar to Perl 6 signatures. Also does type checking, understanding all the types that Moose (or Mouse) would understand. And it does all this with B. =head2 Signature syntax func echo($message) { print "$message\n"; } is equivalent to: sub echo { my($message) = @_; print "$message\n"; } except the original line numbering is preserved and the arguments are checked to make sure they match the signature. Similarly method foo($bar, $baz) { $self->wibble($bar, $baz); } is equivalent to: sub foo { my $self = shift; my($bar, $baz) = @_; $self->wibble($bar, $baz); } again with checks to make sure the arguments passed in match the signature. The full signature syntax for each parameter is: Int|Str \:$param! where $SM_EXPR is ro = $AS_EXPR when $SM_EXPR \_____/ ^^\____/^ \____________/ \___/ \________/ \___________/ | || | | | | | | Type_/ || | | | | | | Aliased?___/ | | | | | | | Named?______/ | | | | | | Parameter var___/ | | | | | Required?__________/ | | | | Parameter constraint(s)_____/ | | | Parameter trait(s)______________________/ | | Default value____________________________________/ | When default value should be applied_________________________/ Every component except the parameter name (with sigil) is optional. C<$SM_EXPR> is any expression that is valid as the RHS of a smartmatch, or else a raw block of code. See L<"Value constraints">. C<$AS_EXPR> is any expression that is valid as the RHS of an assignment operator. See L<"Defaults">. =head3 C<@_> Other than removing C<$self>, C<@_> is left intact. You are free to use C<@_> alongside the arguments provided by Method::Signatures. =head3 Named parameters Parameters can be passed in named, as a hash, using the C<:$arg> syntax. method foo(:$arg) { ... } $object->foo( arg => 42 ); Named parameters are optional by default. Required positional parameters and named parameters can be mixed, but the named params must come last. method foo( $a, $b, :$c ) # legal Named parameters are passed in as a hash after all positional arguments. method display( $text, :$justify = 'left', :$enchef = 0 ) { ... } # $text = "Some stuff", $justify = "right", $enchef = 0 $obj->display( "Some stuff", justify => "right" ); You cannot mix optional positional params with named params, as that leads to ambiguities. method foo( $a, $b?, :$c ) # illegal # Is this $a = 'c', $b = 42 or $c = 42? $obj->foo( c => 42 ); =head3 Aliased references A signature of C<\@arg> will take an array reference but allow it to be used as C<@arg> inside the method. C<@arg> is an alias to the original reference. Any changes to C<@arg> will affect the original reference. package Stuff; method add_one(\@foo) { $_++ for @foo; } my @bar = (1,2,3); Stuff->add_one(\@bar); # @bar is now (2,3,4) This feature requires L to be installed. =head3 Invocant parameter The method invocant (i.e. C<$self>) can be changed as the first parameter on a per-method basis. Put a colon after it instead of a comma: method foo($class:) { $class->bar; } method stuff($class: $arg, $another) { $class->things($arg, $another); } C has an implied default invocant of C<$self:>, though that is configurable by setting the L on the C line. C has no invocant, as it is intended for creating subs that will not be invoked on an object. =head3 Defaults Each parameter can be given a default with the C<$arg = EXPR> syntax. For example, method add($this = 23, $that = 42) { return $this + $that; } Almost any expression can be used as a default. method silly( $num = 42, $string = q[Hello, world!], $hash = { this => 42, that => 23 }, $code = sub { $num + 4 }, @nums = (1,2,3), ) { ... } Normally, defaults will only be used if the argument is not passed in at all. Passing in C will override the default. That means ... Class->add(); # $this = 23, $that = 42 Class->add(99); # $this = 99, $that = 42 Class->add(99, undef); # $this = 99, $that = undef However, you can specify additional conditions under which a default is also to be used, using a trailing C. For example: # Use default if no argument passed method get_results($how_many = 1) {...} # Use default if no argument passed OR argument is undef method get_results($how_many = 1 when undef) {...} # Use default if no argument passed OR argument is empty string method get_results($how_many = 1 when "") {...} # Use default if no argument passed OR argument is zero method get_results($how_many = 1 when 0) {...} # Use default if no argument passed OR argument is zero or less method get_results($how_many = 1 when sub{ $_[0] <= 0 }) {...} # Use default if no argument passed OR argument is invalid method get_results($how_many = 1 when sub{ !valid($_[0]) }) {...} In other words, if you include a C> after the default, the default is still used if the argument is missing, but is also used if the argument is provided but smart-matches the specified I. Note that the final two examples above use anonymous subroutines to conform their complex tests to the requirements of the smartmatch operator. Because this is useful, but syntactically clumsy, there is also a short-cut for this behaviour. If the test after C consists of a block, the block is executed as the defaulting test, with the actual argument value aliased to C<$_> (just like in a C block). So the final two examples above could also be written: # Use default if no argument passed OR argument is zero or less method get_results($how_many = 1 when {$_ <= 0}) {...} # Use default if no argument passed OR argument is invalid method get_results($how_many = 1 when {!valid($_)}) } {...} The most commonly used form of C modifier is almost certainly C: # Use default if no argument passed OR argument is undef method get_results($how_many = 1 when undef) {...} which covers the common case where an uninitialized variable is passed as an argument, or where supplying an explicit undefined value is intended to indicate: "use the default instead." This usage is sufficiently common that a short-cut is provided: using the C operator (instead of the regular assignment operator) to specify the default. Like so: # Use default if no argument passed OR argument is undef method get_results($how_many //= 1) {...} Earlier parameters may be used in later defaults. method copy_cat($this, $that = $this) { return $that; } Any variable that has a default is considered optional. =head3 Type Constraints Parameters can also be given type constraints. If they are, the value passed in will be validated against the type constraint provided. Types are provided by L which will load L if L is not already loaded. Type constraints can be a type, a role or a class. Each will be checked in turn until one of them passes. * First, is the $value of that type declared in Moose (or Mouse)? * Then, does the $value have that role? $value->DOES($type); * Finally, is the $value an object of that class? $value->isa($type); The set of default types that are understood can be found in L (or L; they are generally the same, but there may be small differences). # avoid "argument isn't numeric" warnings method add(Int $this = 23, Int $that = 42) { return $this + $that; } L and L also understand some parameterized types; see their documentation for more details. method add(Int $this = 23, Maybe[Int] $that) { # $this will definitely be defined # but $that might be undef return defined $that ? $this + $that : $this; } You may also use disjunctions, which means that you are willing to accept a value of either type. method add(Int $this = 23, Int|ArrayRef[Int] $that) { # $that could be a single number, # or a reference to an array of numbers use List::Util qw; my @ints = ($this); push @ints, ref $that ? @$that : $that; return sum(@ints); } If the value does not validate against the type, a run-time exception is thrown. # Error will be: # In call to Class::add : the 'this' parameter ("cow") is not of type Int Class->add('cow', 'boy'); # make a cowboy! You cannot declare the type of the invocant. # this generates a compile-time error method new(ClassName $class:) { ... } =head3 Value Constraints In addition to a type, each parameter can also be specified with one or more additional constraints, using the C<$arg where CONSTRAINT> syntax. method set_name($name where qr{\S+ \s+ \S+}x) { ... } method set_rank($rank where \%STD_RANKS) { ... } method set_age(Int $age where [17..75] ) { ... } method set_rating($rating where { $_ >= 0 } where { $_ <= 100 } ) { ... } method set_serial_num(Int $snum where {valid_checksum($snum)} ) { ... } The C keyword must appear immediately after the parameter name and before any L or L. Each C constraint is smartmatched against the value of the corresponding parameter, and an exception is thrown if the value does not satisfy the constraint. Any of the normal smartmatch arguments (numbers, strings, regexes, undefs, hashrefs, arrayrefs, coderefs) can be used as a constraint. In addition, the constraint can be specified as a raw block. This block can then refer to the parameter variable directly by name (as in the definition of C above), or else as C<$_> (as in the definition of C. Unlike type constraints, value constraints are tested I any default values have been resolved, and in the same order as they were specified within the signature. =head3 Parameter traits Each parameter can be assigned a trait with the C<$arg is TRAIT> syntax. method stuff($this is ro) { ... } Any unknown trait is ignored. Most parameters have a default traits of C. =over 4 =item B Read-only. Assigning or modifying the parameter is an error. This trait requires L to be installed. =item B Read-write. It's ok to read or write the parameter. This is a default trait. =item B The parameter will be a copy of the argument (just like C<< my $arg = shift >>). This is a default trait except for the C<\@foo> parameter (see L). =item B The parameter will be an alias of the argument. Any changes to the parameter will be reflected in the caller. This trait requires L to be installed. This is a default trait for the C<\@foo> parameter (see L). =back =head3 Mixing value constraints, traits, and defaults As explained in L, there is a defined order when including multiple trailing aspects of a parameter: =over 4 =item * Any value constraint must immediately follow the parameter name. =item * Any trait must follow that. =item * Any default must come last. =back For instance, to have a parameter which has all three aspects: method echo($message where { length <= 80 } is ro = "what?") { return $message } Think of C<$message where { length <= 80 }> as being the left-hand side of the trait, and C<$message where { length <= 80 } is ro> as being the left-hand side of the default assignment. =head3 Slurpy parameters A "slurpy" parameter is a list or hash parameter that "slurps up" all remaining arguments. Since any following parameters can't receive values, there can be only one slurpy parameter. Slurpy parameters must come at the end of the signature and they must be positional. Slurpy parameters are optional by default. =head3 The "yada yada" marker The restriction that slurpy parameters must be positional, and must appear at the end of the signature, means that they cannot be used in conjunction with named parameters. This is frustrating, because there are many situations (in particular: during object initialization, or when creating a callback) where it is extremely handy to be able to ignore extra named arguments that don't correspond to any named parameter. While it would be theoretically possible to allow a slurpy parameter to come after named parameters, the current implementation does not support this (see L<"Slurpy parameter restrictions">). Instead, there is a special syntax (colloquially known as the "yada yada") that tells a method or function to simply ignore any extra arguments that are passed to it: # Expect name, age, gender, and simply ignore anything else method BUILD (:$name, :$age, :$gender, ...) { $self->{name} = uc $name; $self->{age} = min($age, 18); $self->{gender} = $gender // 'unspecified'; } # Traverse tree with node-printing callback # (Callback only interested in nodes, ignores any other args passed to it) $tree->traverse( func($node, ...) { $node->print } ); The C<...> may appear as a separate "pseudo-parameter" anywhere in the signature, but is normally placed at the very end. It has no other effect except to disable the usual "die if extra arguments" test that the module sets up within each method or function. This means that a "yada yada" can also be used to ignore positional arguments (as the second example above indicates). So, instead of: method verify ($min, $max, @etc) { return $min <= $self->{val} && $self->{val} <= $max; } you can just write: method verify ($min, $max, ...) { return $min <= $self->{val} && $self->{val} <= $max; } This is also marginally more efficient, as it does not have to allocate, initialize, or deallocate the unused slurpy parameter C<@etc>. =head3 Required and optional parameters Parameters declared using C<$arg!> are explicitly I. Parameters declared using C<$arg?> are explicitly I. These declarations override all other considerations. A parameter is implicitly I if it is a named parameter, has a default, or is slurpy. All other parameters are implicitly I. # $greeting is optional because it is named method hello(:$greeting) { ... } # $greeting is required because it is positional method hello($greeting) { ... } # $greeting is optional because it has a default method hello($greeting = "Gruezi") { ... } # $greeting is required because it is explicitly declared using ! method hello(:$greeting!) { ... } # $greeting is required, even with the default, because it is # explicitly declared using ! method hello(:$greeting! = "Gruezi") { ... } =head3 The C<@_> signature The @_ signature is a special case which only shifts C<$self>. It leaves the rest of C<@_> alone. This way you can get $self but do the rest of the argument handling manually. Note that a signature of C<(@_)> is exactly equivalent to a signature of C<(...)>. See L<"The yada yada marker">. =head3 The empty signature If a method is given the signature of C<< () >> or no signature at all, it takes no arguments. =head2 Anonymous Methods An anonymous method can be declared just like an anonymous sub. my $method = method ($arg) { return $self->foo($arg); }; $obj->$method(42); =head2 Options Method::Signatures takes some options at `use` time of the form use Method::Signatures { option => "value", ... }; =head3 invocant In some cases it is desirable for the invocant to be named something other than C<$self>, and specifying it in the signature of every method is tedious and prone to human-error. When this option is set, methods that do not specify the invocant variable in their signatures will use the given variable name. use Method::Signatures { invocant => '$app' }; method main { $app->config; $app->run; $app->cleanup; } Note that the leading sigil I be provided, and the value must be a single token that would be valid as a perl variable. Currently only scalar invocant variables are supported (eg, the sigil must be a C<$>). This option only affects the packages in which it is used. All others will continue to use C<$self> as the default invocant variable. =head3 compile_at_BEGIN By default, named methods and funcs are evaluated at compile time, as if they were in a BEGIN block, just like normal Perl named subs. That means this will work: echo("something"); # This function is compiled first func echo($msg) { print $msg } You can turn this off lexically by setting compile_at_BEGIN to a false value. use Method::Signatures { compile_at_BEGIN => 0 }; compile_at_BEGIN currently causes some issues when used with Perl 5.8. See L. =head3 debug When true, turns on debugging messages about compiling methods and funcs. See L. The flag is currently global, but this may change. =head2 Differences from Perl 6 Method::Signatures is mostly a straight subset of Perl 6 signatures. The important differences... =head3 Restrictions on named parameters As noted above, there are more restrictions on named parameters than in Perl 6. =head3 Named parameters are just hashes Perl 5 lacks all the fancy named parameter syntax for the caller. =head3 Parameters are copies. In Perl 6, parameters are aliases. This makes sense in Perl 6 because Perl 6 is an "everything is an object" language. Perl 5 is not, so parameters are much more naturally passed as copies. You can alias using the "alias" trait. =head3 Can't use positional params as named params Perl 6 allows you to use any parameter as a named parameter. Perl 5 lacks the named parameter disambiguating syntax so it is not allowed. =head3 Addition of the C<\@foo> reference alias prototype In Perl 6, arrays and hashes don't get flattened, and their referencing syntax is much improved. Perl 5 has no such luxury, so Method::Signatures added a way to alias references to normal variables to make them easier to work with. =head3 Addition of the C<@_> prototype Method::Signatures lets you punt and use @_ like in regular Perl 5. =cut sub import { my $class = shift; my $caller = caller; # default values # default invocant var - end-user can change with 'invocant' option. my $inv_var = '$self'; my $hints = my_hints; $hints->{METHOD_SIGNATURES_compile_at_BEGIN} = 1; # default to on my $arg = shift; if (defined $arg) { if (ref $arg) { $DEBUG = $arg->{debug} if exists $arg->{debug}; $caller = $arg->{into} if exists $arg->{into}; $hints->{METHOD_SIGNATURES_compile_at_BEGIN} = $arg->{compile_at_BEGIN} if exists $arg->{compile_at_BEGIN}; if (exists $arg->{invocant}) { $inv_var = $arg->{invocant}; # ensure (for now) the specified value is a valid variable # name (with '$' sigil) and nothing more. if ($inv_var !~ m{ \A \$ [^\W\d]\w* \z }x) { require Carp; Carp::croak("Invalid invocant name: '$inv_var'"); } } } elsif ($arg eq ':DEBUG') { $DEBUG = 1; } else { require Carp; Carp::croak("Invalid Module::Signatures argument $arg"); } } $class->install_methodhandler( into => $caller, name => 'method', invocant => $inv_var, ); $class->install_methodhandler( into => $caller, name => 'func', ); DEBUG("import for $caller done\n"); DEBUG("method invocant is '$inv_var'\n"); } # Inject special code to make named functions compile at BEGIN time. # Otherwise we leave injection to Devel::Declare. sub inject_if_block { my ($self, $inject, $before) = @_; my $name = $self->{function_name}; my $attrs = $self->{attributes} || ''; DEBUG( "attributes: $attrs\n" ); # Named function compiled at BEGIN time if( defined $name && $self->_do_compile_at_BEGIN ) { # Devel::Declare needs the code ref which has been generated. # Fortunately, "sub foo {...}" happens at compile time, so we # can use \&foo at runtime even if it comes before the sub # declaration in the code! $before = qq[\\&$name; sub $name $attrs ]; } DEBUG( "inject: $inject\n" ); DEBUG( "before: $before\n" ); DEBUG( "linestr before: ".$self->get_linestr."\n" ) if $DEBUG; my $ret = $self->SUPER::inject_if_block($inject, $before); DEBUG( "linestr after: ". $self->get_linestr."\n" ) if $DEBUG; return $ret; } # Check if compile_at_BEGIN is set in this scope. sub _do_compile_at_BEGIN { my $hints = my_hints; # Default to on. return 1 if !exists $hints->{METHOD_SIGNATURES_compile_at_BEGIN}; return $hints->{METHOD_SIGNATURES_compile_at_BEGIN}; } # Sometimes a compilation error will happen but not throw an error causing the # code to continue compiling and producing an unrelated error down the road. # # A symptom of this is that eval STRING no longer works. So we detect if the # parser is a dead man walking. sub _parser_is_fucked { local $@; return eval 42 ? 0 : 1; } # Capture the function name sub strip_name { my $self = shift; my $name = $self->SUPER::strip_name(@_); $self->{function_name} = $name; return $name; } # Capture the attributes sub strip_attrs { my $self = shift; my $attrs = $self->SUPER::strip_attrs(@_); $self->{attributes} = $attrs; return $attrs; } # Overriden method from D::D::MS sub parse_proto { my $self = shift; my $proto = shift; # Before we try to compile signatures, make sure there isn't a hidden compilation error. die $@ if _parser_is_fucked; $self->{signature} = Method::Signatures::Signature->new( signature_string => defined $proto ? $proto : "", invocant => $self->{invocant}, pre_invocant => $self->{pre_invocant} ); # Then turn it into Perl code my $inject = $self->inject_from_signature(); return $inject; } # Turn the parsed signature into Perl code sub inject_from_signature { my $self = shift; my $class = ref $self || $self; my $signature = $self->{signature}; $self->{line_number} = 1; my @code; push @code, "my @{[$signature->pre_invocant]} = shift;" if $signature->pre_invocant; push @code, "my @{[$signature->invocant]} = shift;" if $signature->invocant; for my $sig (@{$signature->positional_parameters}) { push @code, $self->inject_for_sig($sig); } if( @{$signature->named_parameters} ) { my $first_named_idx = @{$signature->positional_parameters}; if (grep { $_->is_ref_alias or $_->traits->{alias} } @{$signature->named_parameters}) { require Data::Alias; push @code, "Data::Alias::alias( my (\%args) = \@_[$first_named_idx..\$#_] );"; } else { push @code, "my (\%args) = \@_[$first_named_idx..\$#_];"; } for my $sig (@{$signature->named_parameters}) { push @code, $self->inject_for_sig($sig); } push @code, $class . '->named_param_error(\%args) if keys %args;' if $signature->num_named && !$signature->num_yadayada; } my $max_argv = $signature->max_argv_size; my $max_args = $signature->max_args; push @code, qq[$class->too_many_args_error($max_args) if scalar(\@_) > $max_argv; ] unless $max_argv == $INF; # Add any additional trailing newlines so the body is on the right line. push @code, $self->inject_newlines( $signature->num_lines - $self->{line_number} ); # All on one line. return join ' ', @code; } sub too_many_args_error { my($class, $max_args) = @_; $class->signature_error("was given too many arguments; it expects $max_args"); } sub named_param_error { my ($class, $args) = @_; my @keys = keys %$args; $class->signature_error("does not take @keys as named argument(s)"); } # Regex to determine if a where clause is a block. my $when_block_re = qr{ ^ \s* \{ (?: .* ; .* | # statements separated by semicolons (?:(?! => ). )+ # doesn't look like a hash with fat commas ) \} \s* $ }xs; sub inject_for_sig { my $self = shift; my $class = ref $self || $self; my $sig = shift; return if $sig->is_at_underscore; my @code; # Add any necessary leading newlines so line numbers are preserved. push @code, $self->inject_newlines($sig->first_line_number - $self->{line_number}); my $sigil = $sig->sigil; my $name = $sig->variable_name; my $idx = $sig->position; my $var = $sig->variable; # These are the defaults. my $lhs = "my $var"; my ($rhs, $deletion_target); if( $sig->is_named ) { $sig->passed_in("\$args{$name}"); $rhs = $deletion_target = $sig->passed_in; $rhs = "${sigil}{$rhs}" if $sig->is_ref_alias; } else { $rhs = $sig->is_ref_alias ? "${sigil}{\$_[$idx]}" : $sig->sigil =~ /^[@%]$/ ? "\@_[$idx..\$#_]" : "\$_[$idx]" ; $sig->passed_in($rhs); } my $check_exists = $sig->is_named ? "exists \$args{$name}" : "( scalar(\@_) > $idx)"; $sig->check_exists($check_exists); my $default = $sig->default; my $when = $sig->default_when; # Handle a default value if( defined $when ) { # Handle default with 'when { block using $_ }' if ($when =~ $when_block_re) { $rhs = "!$check_exists ? ($default) : do{ no warnings; my \$arg = $rhs; (grep $when \$arg) ? ($default) : \$arg}"; } # Handle default with 'when anything_else' else { $rhs = "!$check_exists ? ($default) : do{ no warnings; my \$arg = $rhs; \$arg ~~ ($when) ? ($default) : \$arg }"; } } # Handle simple defaults elsif( defined $default ) { $rhs = "$check_exists ? ($rhs) : ($default)"; } if( $sig->is_required ) { push @code, qq[${class}->required_arg('$var') unless $check_exists; ]; } # Handle \@foo if ( $sig->is_ref_alias or $sig->traits->{alias} ) { require Data::Alias; push @code, sprintf 'Data::Alias::alias(%s = %s);', $lhs, $rhs; } # Handle "is ro" elsif ( $sig->traits->{ro} ) { require Const::Fast; push @code, "Const::Fast::const( $lhs => $rhs );"; } else { push @code, "$lhs = $rhs;"; } if( $sig->type ) { push @code, $self->inject_for_type_check($sig); } # Named arg has been handled, so don't pass to error handler push @code, "delete( $deletion_target );" if $deletion_target; # Handle 'where' constraints (after defaults are resolved) for my $constraint ( @{$sig->where} ) { # Handle 'where { block using $_ }' my $constraint_impl = $constraint =~ m{^ \s* \{ (?: .* ; .* | (?:(?! => ). )* ) \} \s* $}xs ? "sub $constraint" : $constraint; my $error = sprintf q{ %s->where_error(%s, '%s', '%s') }, $class, $var, $var, $constraint; push @code, "$error unless do { no if \$] >= 5.017011, warnings => 'experimental::smartmatch'; grep { \$_ ~~ $constraint_impl } $var }; "; } # Record the current line number for the next injection. $self->{line_number} = $sig->first_line_number; return @code; } sub __magic_newline() { die "newline() should never be called"; } # Devel::Declare cannot normally inject multiple lines. # This is a way to trick it, the parser will continue through # a function call with a newline in the argument list. sub inject_newlines { my $self = shift; my $num_newlines = shift; return if $num_newlines == 0; return sprintf q[ Method::Signatures::__magic_newline(%s) if 0; ], "\n" x $num_newlines; } # A hook for extension authors # (see also type_check below) sub inject_for_type_check { my $self = shift; my $class = ref $self || $self; my ($sig) = @_; my $check_exists = $sig->is_optional && !defined $sig->default ? $sig->check_exists : ''; # This is an optimization to unroll typecheck which makes Mouse types about 40% faster. # It only happens when type_check() has not been overridden. if( $class->can("type_check") eq __PACKAGE__->can("type_check") ) { my $check = sprintf q[($%s::mutc{cache}{'%s'} ||= %s->_make_constraint('%s'))->check(%s)], __PACKAGE__, $sig->type, $class, $sig->type, $sig->variable; my $error = sprintf q[%s->type_error('%s', %s, '%s') ], $class, $sig->type, $sig->variable, $sig->variable_name; my $code = "$error if "; $code .= "$check_exists && " if $check_exists; $code .= "!$check"; return "$code;"; } # If a subclass has overridden type_check(), we must use that. else { my $name = $sig->variable_name; my $code = "${class}->type_check('@{[$sig->type]}', @{[$sig->passed_in]}, '$name')"; $code .= "if $check_exists" if $check_exists; return "$code;"; } } # This class method just dies with the message generated by signature_error. # If necessary it can be overridden by a subclass to do something fancier. # sub signature_error_handler { my ($class, $msg) = @_; die $msg; } # This is a common function to throw errors so that they appear to be from the point of the calling # sub, not any of the Method::Signatures subs. sub signature_error { my ($proto, $msg) = @_; my $class = ref $proto || $proto; my ($file, $line, $method) = carp_location_for($class); $class->signature_error_handler("In call to $method(), $msg at $file line $line.\n"); } sub required_arg { my ($class, $var) = @_; $class->signature_error("missing required argument $var"); } # STUFF FOR TYPE CHECKING # This variable will hold all the bits we need. MUTC could stand for Moose::Util::TypeConstraint, # or it could stand for Mouse::Util::TypeConstraint ... depends on which one you've got loaded (or # Mouse if you have neither loaded). Because we use Any::Moose to allow the user to choose # whichever they like, we'll need to figure out the exact method names to call. We'll also need a # type constraint cache, where we stick our constraints once we find or create them. This insures # that we only have to run down any given constraint once, the first time it's seen, and then after # that it's simple enough to pluck back out. This is very similar to how MooseX::Params::Validate # does it. our %mutc; # This is a helper function to initialize our %mutc variable. sub _init_mutc { require Any::Moose; Any::Moose->import('::Util::TypeConstraints'); no strict 'refs'; my $class = any_moose('::Util::TypeConstraints'); $mutc{class} = $class; $mutc{findit} = \&{ $class . '::find_or_parse_type_constraint' }; $mutc{pull} = \&{ $class . '::find_type_constraint' }; $mutc{make_class} = \&{ $class . '::class_type' }; $mutc{make_role} = \&{ $class . '::role_type' }; $mutc{isa_class} = $mutc{pull}->("ClassName"); $mutc{isa_role} = $mutc{pull}->("RoleName"); } # This is a helper function to find (or create) the constraint we need for a given type. It would # be called when the type is not found in our cache. sub _make_constraint { my ($class, $type) = @_; _init_mutc() unless $mutc{class}; # Look for basic types (Int, Str, Bool, etc). This will also create a new constraint for any # parameterized types (e.g. ArrayRef[Int]) or any disjunctions (e.g. Int|ScalarRef[Int]). my $constr = eval { $mutc{findit}->($type) }; if ($@) { $class->signature_error("the type $type is unrecognized (looks like it doesn't parse correctly)"); } return $constr if $constr; # Check for roles. Note that you *must* check for roles before you check for classes, because a # role ISA class. return $mutc{make_role}->($type) if $mutc{isa_role}->check($type); # Now check for classes. return $mutc{make_class}->($type) if $mutc{isa_class}->check($type); $class->signature_error("the type $type is unrecognized (perhaps you forgot to load it?)"); } # This method does the actual type checking. It's what we inject into our user's method, to be # called directly by them. # # Note that you can override this instead of inject_for_type_check if you'd rather. If you do, # remember that this is a class method, not an object method. That's because it's called at # runtime, when there is no Method::Signatures object still around. sub type_check { my ($class, $type, $value, $name) = @_; # find it if isn't cached $mutc{cache}->{$type} ||= $class->_make_constraint($type); # throw an error if the type check fails unless ($mutc{cache}->{$type}->check($value)) { $class->type_error($type, $value, $name); } # $mutc{cache} = {}; } # If you just want to change what the type failure errors look like, just override this. # Note that you can call signature_error yourself to handle the croak-like aspects. sub type_error { my ($class, $type, $value, $name) = @_; $value = defined $value ? qq{"$value"} : 'undef'; $class->signature_error(qq{the '$name' parameter ($value) is not of type $type}); } # Errors from `where' constraints are handled here. sub where_error { my ($class, $value, $name, $constraint) = @_; $value = defined $value ? qq{"$value"} : 'undef'; $class->signature_error(qq{$name value ($value) does not satisfy constraint: $constraint}); } =head1 PERFORMANCE There is no run-time performance penalty for using this module above what it normally costs to do argument handling. There is also no run-time penalty for type-checking if you do not declare types. The run-time penalty if you do declare types should be very similar to using L (or L) directly, and should be faster than using a module such as L. The magic of L is used to give you the lightweight L if you have not yet loaded L, or the full-bodied L if you have. Type-checking modules are not loaded until run-time, so this is fine: use Method::Signatures; use Moose; # you will still get Moose type checking # (assuming you declare one or more methods with types) =head1 DEBUGGING One of the best ways to figure out what Method::Signatures is doing is to run your code through B::Deparse (run the code with -MO=Deparse). Setting the C environment variable will cause Method::Signatures to display debugging information when it is compiling signatures. =head1 EXAMPLE Here's an example of a method which displays some text and takes some extra options. use Method::Signatures; method display($text is ro, :$justify = "left", :$fh = \*STDOUT) { ... } # $text = $stuff, $justify = "left" and $fh = \*STDOUT $obj->display($stuff); # $text = $stuff, $justify = "left" and $fh = \*STDERR $obj->display($stuff, fh => \*STDERR); # error, missing required $text argument $obj->display(); The display() method is equivalent to all this code. sub display { my $self = shift; croak('display() missing required argument $text') unless @_ > 0; const my $text = $_[0]; my(%args) = @_[1 .. $#_]; my $justify = exists $args{justify} ? $args{justify} : 'left'; my $fh = exists $args{fh} ? $args{'fh'} : \*STDOUT; ... } =head1 EXPERIMENTING If you want to experiment with the prototype syntax, start with C. It takes a method prototype and returns a string of Perl 5 code which will be placed at the beginning of that method. If you would like to try to provide your own type checking, subclass L and either override C or C. See L, below. This interface is experimental, unstable and will change between versions. =head1 EXTENDING If you wish to subclass Method::Signatures, the following methods are good places to start. =head2 too_many_args_error, named_param_error, required_arg, type_error, where_error These are class methods which report the various run-time errors (extra parameters, unknown named parameter, required parameter missing, parameter fails type check, and parameter fails where constraint respectively). Note that each one calls C, which your versions should do as well. =head2 signature_error This is a class method which calls C (see below) and reports the error as being from the caller's perspective. Most likely you will not need to override this. If you'd like to have Method::Signatures errors give full stack traces (similar to C<$Carp::Verbose>), have a look at L. =head2 signature_error_handler By default, C generates an error message and Cs with that message. If you need to do something fancier with the generated error message, your subclass can define its own C. For example: package My::Method::Signatures; use Moose; extends 'Method::Signatures'; sub signature_error_handler { my ($class, $msg) = @_; die bless { message => $msg }, 'My::ExceptionClass'; }; =head2 type_check This is a class method which is called to verify that parameters have the proper type. If you want to change the way that Method::Signatures does its type checking, this is most likely what you want to override. It calls C (see above). =head2 inject_for_type_check This is the object method that actually inserts the call to L into your Perl code. Most likely you will not need to override this, but if you wanted different parameters passed into C, this would be the place to do it. =head1 BUGS, CAVEATS and NOTES Please report bugs and leave feedback at Ebug-Method-SignaturesE at Ert.cpan.orgE. Or use the web interface at L. Report early, report often. =head2 One liners If you want to write "use Method::Signatures" in a one-liner, do a C<-MMethod::Signatures> first. This is due to a bug/limitation in Devel::Declare. =head2 Close parends in quotes or comments Because of the way L parses things, an unbalanced close parend inside a quote or comment could throw off the signature parsing. For instance: func foo ( $foo, # $foo might contain ) $bar ) is going to produce a syntax error, because the parend inside the comment is perceived as the end of the signature. On the other hand, this: func foo ( $foo, # (this is the $foo parend) $bar ) is fine, because the parends in the comments are balanced. If you absolutely can't avoid an unbalanced close parend, such as in the following signature: func foo ( $foo, $bar = ")" ) # this won't parse correctly you can always use a backslash to tell the parser that that close parend doesn't indicate the end of the signature: func foo ( $foo, $bar = "\)" ) # this is fine This even works in single quotes: func foo ( $foo, $bar = '\)' ) # default is ')', *not* '\)'! although we don't recomment that form, as it may be surprising to readers of your code. =head2 No source filter While this module does rely on the black magic of L to access Perl's own parser, it does not depend on a source filter. As such, it doesn't try to parse and rewrite your source code and there should be no weird side effects. Devel::Declare only affects compilation. After that, it's a normal subroutine. As such, for all that hairy magic, this module is surprisingly stable. =head2 Earlier Perl versions The most noticeable is if an error occurs at compile time, such as a strict error, perl might not notice until it tries to compile something else via an C or C at which point perl will appear to fail where there is no reason to fail. We recommend you use the L<"compile_at_BEGIN"> flag to turn off compile-time parsing. You can't use any feature that requires a smartmatch expression (i.e. conditional L<"Defaults"> and L<"Value Constraints">) in Perl 5.8. Method::Signatures cannot be used with Perl versions prior to 5.8 because L does not work with those earlier versions. =head2 What about class methods? Right now there's nothing special about class methods. Just use C<$class> as your invocant like the normal Perl 5 convention. There may be special syntax to separate class from object methods in the future. =head2 What about the return value? Currently there is no support for declaring the type of the return value. =head2 How does this relate to Perl's built-in prototypes? It doesn't. Perl prototypes are a rather different beastie from subroutine signatures. They don't work on methods anyway. A syntax for function prototypes is being considered. func($foo, $bar?) is proto($;$) =head2 Error checking Here's some additional checks I would like to add, mostly to avoid ambiguous or non-sense situations. * If one positional param is optional, everything to the right must be optional method foo($a, $b?, $c?) # legal method bar($a, $b?, $c) # illegal, ambiguous Does C<< ->bar(1,2) >> mean $a = 1 and $b = 2 or $a = 1, $c = 3? * Positionals are resolved before named params. They have precedence. =head2 Slurpy parameter restrictions Slurpy parameters are currently more restricted than they need to be. It is possible to work out a slurpy parameter in the middle, or a named slurpy parameter. However, there's lots of edge cases and possible nonsense configurations. Until that's worked out, we've left it restricted. =head2 What about... Method traits are in the pondering stage. An API to query a method's signature is in the pondering stage. Now that we have method signatures, multi-methods are a distinct possibility. Applying traits to all parameters as a short-hand? # Equivalent? method foo($a is ro, $b is ro, $c is ro) method foo($a, $b, $c) is ro L roles are currently not recognized by the type system. A "go really fast" switch. Turn off all runtime checks that might bite into performance. Method traits. method add($left, $right) is predictable # declarative method add($left, $right) is cached # procedural # (and Perl 6 compatible) =head1 THANKS Most of this module is based on or copied from hard work done by many other people. All the really scary parts are copied from or rely on Matt Trout's, Florian Ragwitz's and Rhesa Rozendaal's L work. The prototype syntax is a slight adaptation of all the excellent work the Perl 6 folks have already done. The type checking and method modifier work was supplied by Buddy Burden (barefootcoder). Thanks to this, you can now use Method::Signatures (or, more properly, L) instead of L, which fixes many of the problems commonly attributed to L. Value constraints and default conditions (i.e. "where" and "when") were added by Damian Conway, who also rewrote some of the signature parsing to make it more robust and more extensible. Also thanks to Matthijs van Duin for his awesome L which makes the C<\@foo> signature work perfectly and L which makes the subroutine names come out right in caller(). And thanks to Florian Ragwitz for his parallel L module from which I borrow ideas and code. =head1 LICENSE The original code was taken from Matt S. Trout's tests for L. Copyright 2007-2012 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =head1 SEE ALSO L for an alternative implementation. L for a more complete implementation of Perl 6 signatures. L for a more basic version of what Method::Signatures provides. L for a subset of Method::Signature's features without using L. L for C with signatures. Perl 6 subroutine parameters and arguments - L L or L for further details on how the type-checking works. =cut 1; Method-Signatures-20160315/lib/Method/Signatures000755001751000144 012672114746 21073 5ustar00buddyusers000000000000Method-Signatures-20160315/lib/Method/Signatures/Modifiers.pm000444001751000144 2101112672114746 23522 0ustar00buddyusers000000000000package Method::Signatures::Modifiers; use strict; use warnings; use Sub::Name; use base 'Method::Signatures'; our $VERSION = '20160315'; =head1 NAME Method::Signatures::Modifiers - use Method::Signatures from within MooseX::Declare =head1 SYNOPSIS use MooseX::Declare; use Method::Signatures::Modifiers; class Foo { method bar (Int $thing) { # this method is declared with Method::Signatures instead of MooseX::Method::Signatures } } # -- OR -- use MooseX::Declare; class My::Declare extends MooseX::Declare { use Method::Signatures::Modifiers; } # ... later ... use My::Declare; class Fizz { method baz (Int $thing) { # this method also declared with Method::Signatures instead of MooseX::Method::Signatures } } =head1 DESCRIPTION Allows you to use L from within L, both for the C keyword and also for any method modifiers (C, C, C, C, and C). Typically method signatures within L are provided by L. Using L instead provides several advantages: =over 4 =item * L has a known bug with Perl 5.12.x which does not plague L. =item * L may provide substantially better performance when calling methods, depending on your circumstances. =item * L error messages are somewhat easier to read (and can be overridden more easily). =back However, L cannot be considered a drop-in replacement for L. Specifically, the following features of L are not available to you (or work differently) if you substitute L: =head3 Types for Invocants L allows code such as this: method foo (ClassName $class: Int $bar) { } L does not allow you to specify a type for the invocant, so your code would change to: method foo ($class: Int $bar) { } =head3 Parameter Aliasing (Labels) L allows code like this: # call this as $obj->foo(bar => $baz) method foo (Int :bar($baz)) { } This feature is not currently planned for L. =head3 Placeholders L allows code like this: method foo (Int $bar, $, Int $baz) { # second parameter not available as a variable here } This feature is not currently planned for L. Note that, if the parameter you want to ignore is at the end: method foo (Int $bar, Int $baz, $) { # third parameter not available as a variable here } then you could write that in L using the "yada yada" pseudo-parameter: method foo (Int $bar, Int $baz, ...) { # third (or greater) parameter(s) not available here } =head3 Traits In L, C is a synonym for C. L does not honor this. L supports several traits that L does not. L supports the C trait. L does not currently support this, although it is a planned feature for a future release, potentially using the C syntax. =cut sub import { my ($class) = @_; # intercept the parse() method that handles the 'method' keyword require MooseX::Declare::Syntax::Keyword::Method; my $meta = MooseX::Declare::Syntax::Keyword::Method->meta; $meta->make_mutable(); $meta->add_around_method_modifier ( parse => sub { my ($orig, $self, $ctx) = @_; # have to rebless the MooseX::Declare::Context's Devel::Declare::Context::Simple object into our class # since we're ultimately descended from DDCS, this should work my $ms = bless $ctx->_dd_context, $class; # have to sneak the default invocant in there $ms->{invocant} = '$self'; # this sets some things in $ms that were already set, but that's pretty much unavoidable $ms->parser($ms->declarator, $ms->offset); } ); $meta->make_immutable(); # intercept the parse() method that handles method modifiers require MooseX::Declare::Syntax::Keyword::MethodModifier; $meta = MooseX::Declare::Syntax::Keyword::MethodModifier->meta; $meta->make_mutable(); $meta->add_around_method_modifier ( parse => sub { my ($orig, $self, $ctx) = @_; # have to rebless the MooseX::Declare::Context's Devel::Declare::Context::Simple object into our class # since we're ultimately descended from DDCS, this should work my $ms = bless $ctx->_dd_context, $class; # have to sneak the default invocant in there $ms->{invocant} = '$self'; # and have to let code_for() know this is a modifier $ms->{is_modifier} = 1; # and have to get the $orig in there if it's an around $ms->{pre_invocant} = '$orig' if $ms->declarator eq 'around'; # this sets some things in $ms that were already set, but that's pretty much unavoidable $ms->parser($ms->declarator, $ms->offset); } ); $meta->make_immutable(); } # Method::Signatures doesn't have a code_for routine; it just passes through directly to # Devel::Declare::MethodInstaller::Simple. But DDMIS::code_for creates a sub, which is entirely # different from creating a method modifier. We need all different code. # # Our code_for will need to return a sub which does the following things: # # * Figures out the metaclass of the class we're processing. # # * Figures out which modifier we're adding (e.g., before, after, around, etc) and then figures # out which method to call to add that modifier. # # * Checks for basic errors (such as unknown type of modifier). # # * Adds the modifier. # # * If it's _not_ for a modifier, just fall through to code_for() in Method::Signatures. # # And that's all this code does. sub code_for { my($self, $name) = @_; if ($self->{is_modifier}) { die("can't create an anonymous method modifier") unless $name; my $class = $self->{outer_package}; my $modtype = $self->declarator; my $add = "add_${modtype}_method_modifier"; my $code = sub { my $meta = $class->meta; require Carp; Carp::confess("cannot create method modifier for $modtype") unless $meta->can($add); no strict 'refs'; my $code = subname "${class}::$name" => shift; $meta->$add($name => $code); }; return $code; } else { return $self->SUPER::code_for($name); } } # Generally, the code that calls inject_if_block decides what to put in front of the actual # subroutine body. For instance, if it's an anonymous sub, the $before parameter would contain # "sub ". In our case, we need the "sub " all the time. sub inject_if_block { my ($self, $inject, $before) = @_; $before = 'sub ' unless $before; $self->SUPER::inject_if_block($inject, $before); } # Always compile at runtime sub _do_compile_at_BEGIN { 0 } =head1 BUGS, CAVEATS and NOTES Note that although this module causes all calls to L from within L to be completely I by calls to L (or calls to Method::Signatures::Modifiers), L is still I by L. It's just never used. The C flag to L is ignored by Method::Signatures::Modifiers. This is because parsing at compile-time can cause method modifiers to be added before the methods they are modifying are composed into the Moose classes. Parsing of methods at run-time is compatible with L. =head1 THANKS This code was written by Buddy Burden (barefootcoder). The import code for replacing L is based on a suggestion from Nick Perez. =head1 LICENSE Copyright 2011 by Michael G Schwern Eschwern@pobox.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =head1 SEE ALSO L, L, L. =cut 1; Method-Signatures-20160315/lib/Method/Signatures/Signature.pm000444001751000144 1646012672114746 23556 0ustar00buddyusers000000000000package Method::Signatures::Signature; use Carp; use Mouse; use Method::Signatures::Types; use Method::Signatures::Parameter; use Method::Signatures::Utils qw(new_ppi_doc sig_parsing_error DEBUG); my $INF = ( 0 + "inf" ) == 0 ? 9e9999 : "inf"; has num_lines => is => 'rw', isa => 'Int', lazy => 1, default => sub { my $self = shift; my $num =()= $self->signature_string =~ /\n/g; return $num + 1; }; # The unmodified, uncleaned up original signature for reference has signature_string => is => 'ro', isa => 'Str', required => 1; # Just the parameter part of the signature, no invocant has parameter_string => is => 'ro', isa => 'Str', lazy => 1, builder => '_build_parameter_string'; # The parsed Method::Signature::Parameter objects has parameters => is => 'ro', isa => 'ArrayRef[Method::Signatures::Parameter]', lazy => 1, builder => '_build_parameters'; has named_parameters => is => 'ro', isa => 'ArrayRef[Method::Signatures::Parameter]', default => sub { [] }; has positional_parameters => is => 'ro', isa => 'ArrayRef[Method::Signatures::Parameter]', default => sub { [] }; has optional_parameters => is => 'ro', isa => 'ArrayRef[Method::Signatures::Parameter]', default => sub { [] }; has optional_positional_parameters => is => 'ro', isa => 'ArrayRef[Method::Signatures::Parameter]', default => sub { [] }; has slurpy_parameters => is => 'ro', isa => 'ArrayRef[Method::Signatures::Parameter]', default => sub { [] }; has yadayada_parameters => is => 'ro', isa => 'ArrayRef[Method::Signatures::Parameter]', default => sub { [] }; sub num_named { return scalar @{$_[0]->named_parameters}; } sub num_positional { return scalar @{$_[0]->positional_parameters}; } sub num_optional { return scalar @{$_[0]->optional_parameters}; } sub num_optional_positional { return scalar @{$_[0]->optional_positional_parameters}; } sub num_slurpy { return scalar @{$_[0]->slurpy_parameters}; } sub num_yadayada { return scalar @{$_[0]->yadayada_parameters}; } # Anything we need to pull out before the invocant. # Primary example would be the $orig for around modifiers in Moose/Mouse has pre_invocant => is => 'rw', isa => 'Maybe[Str]', default => ''; has invocant => is => 'rw', isa => 'Maybe[Str]', default => ''; sub has_invocant { return $_[0]->invocant ? 1 : 0; } # How big can @_ be? has max_argv_size => is => 'rw', isa => 'Int|Inf'; # The maximum logical arguments (name => value counts as one argument) has max_args => is => 'rw', isa => 'Int|Inf'; # A PPI::Document representing the list of parameters has ppi_doc => is => 'ro', isa => 'PPI::Document', lazy => 1, default => sub { my $code = $_[0]->parameter_string; return new_ppi_doc(\$code); }; # If set, no checks will be done on the signature or parameters has no_checks => is => 'rw', isa => 'Bool', default => 0; sub BUILD { my $self = shift; for my $sig (@{$self->parameters}) { # Handle "don't care" specifier if ($sig->is_yadayada) { push @{$self->slurpy_parameters}, $sig; push @{$self->yadayada_parameters}, $sig; next; } $sig->check($self) unless $self->no_checks; push @{$self->named_parameters}, $sig if $sig->is_named; push @{$self->positional_parameters}, $sig if $sig->is_positional; push @{$self->optional_parameters}, $sig if $sig->is_optional; push @{$self->optional_positional_parameters}, $sig if $sig->is_optional and $sig->is_positional; push @{$self->slurpy_parameters}, $sig if $sig->is_slurpy; DEBUG( "sig: ", $sig ); } $self->_calculate_max_args; $self->check unless $self->no_checks; return; } sub _calculate_max_args { my $self = shift; # If there's a slurpy argument, the max is infinity. if( $self->num_slurpy ) { $self->max_argv_size($INF); $self->max_args($INF); return; } $self->max_argv_size( ($self->num_named * 2) + $self->num_positional ); $self->max_args( $self->num_named + $self->num_positional ); return; } # Check the integrity of the signature as a whole sub check { my $self = shift; # Check that slurpy arguments come at the end if( $self->num_slurpy && !($self->num_yadayada || $self->positional_parameters->[-1]->is_slurpy) ) { my $slurpy_param = $self->slurpy_parameters->[0]; sig_parsing_error("Slurpy parameter '@{[$slurpy_param->variable]}' must come at the end"); } return 1; } sub _strip_ws { $_[1] =~ s/^\s+//; $_[1] =~ s/\s+$//; } my $IDENTIFIER = qr{ [^\W\d] \w* }x; sub _build_parameter_string { my $self = shift; my $sig_string = $self->signature_string; my $invocant; # Extract an invocant, if one is present. if ($sig_string =~ s{ ^ \s* (\$ $IDENTIFIER) \s* : \s* }{}x) { $self->invocant($1); } # The siganture, minus the invocant, is just the list of parameters return $sig_string; } sub _build_parameters { my $self = shift; my $param_string = $self->parameter_string; return [] unless $param_string =~ /\S/; my $ppi = $self->ppi_doc; $ppi->prune('PPI::Token::Comment'); my $statement = $ppi->find_first("PPI::Statement"); sig_parsing_error("Could not understand parameter list specification: $param_string") unless $statement; my $token = $statement->first_token; # Split the signature into parameters as tokens. my @tokens_by_param = ([]); do { if( $token->class eq "PPI::Token::Operator" and $token->content eq ',' ) { push @tokens_by_param, []; } else { push @{$tokens_by_param[-1]}, $token; } # "Type: $arg" is interpreted by PPI as a label, which is lucky for us. $token = $token->class eq 'PPI::Token::Label' ? $token->next_token : $token->next_sibling; } while( $token ); # Turn those token sets into Parameter objects. my $idx = 0; my @params; for my $tokens (@tokens_by_param) { my $code = join '', map { $_->content } @$tokens; next unless $code =~ /\S/; DEBUG( "raw_parameter: $code\n" ); $self->_strip_ws($_) for ($code); my $first_significant_token = _first_significant_token($tokens); my $param = Method::Signatures::Parameter->new( original_code => $code, position => $idx, first_line_number => $first_significant_token->line_number, ); $idx++ if $param->is_positional; push @params, $param; } return \@params; } sub _first_significant_token { my $tokens = shift; for my $token (@$tokens) { return $token if $token->significant; } croak "No significant token found"; } 1; Method-Signatures-20160315/lib/Method/Signatures/Parameter.pm000444001751000144 2364412672114746 23537 0ustar00buddyusers000000000000package Method::Signatures::Parameter; use Mouse; use Carp; use Method::Signatures::Utils; my $IDENTIFIER = qr{ [^\W\d] \w* }x; my $VARIABLE = qr{ [\$\@%] $IDENTIFIER }x; my $TYPENAME = qr{ $IDENTIFIER (?: \:\: $IDENTIFIER )* }x; our $PARAMETERIZED; $PARAMETERIZED = do{ use re 'eval'; qr{ $TYPENAME (?: \[ (??{$PARAMETERIZED}) \] )? }x; }; my $TYPESPEC = qr{ ^ \s* $PARAMETERIZED (?: \s* \| \s* $PARAMETERIZED )* \s* }x; has original_code => is => 'ro', isa => 'Str', required => 1; # Note: Have to preparse with regexes up to traits # because :, ! and ? in sigs confuse PPI has ppi_clean_code => is => 'rw', isa => 'Str', ; has is_yadayada => is => 'ro', isa => 'Bool', lazy => 1, default => sub { my $self = shift; return $self->original_code =~ m{^ \s* \Q...\E \s* $}x; }; has type => is => 'rw', isa => 'Str', default => ''; ; has is_ref_alias => is => 'rw', isa => 'Bool', default => 0; has is_named => is => 'rw', isa => 'Bool', ; sub is_positional { my $self = shift; return !$self->is_named; } has variable => is => 'rw', isa => 'Str', default => ''; has first_line_number => is => 'rw', isa => 'Int'; has position => is => 'rw', isa => 'Maybe[Int]', # XXX 0 or positive int trigger => sub { my($self, $new_position, $old_position) = @_; if( $self->is_named ) { croak("A named parameter cannot have a position") if defined $new_position and length $new_position; } else { # positional parameter croak("A positional parameter must have a position") if !(defined $new_position and length $new_position); } }; has sigil => is => 'rw', isa => 'Str', # XXX [%$@*] ; has variable_name => is => 'rw', isa => 'Str', ; has where => is => 'rw', isa => 'ArrayRef', default => sub { [] }; sub has_where { my $self = shift; return @{$self->where} ? 1 : 0; } has traits => is => 'rw', isa => 'HashRef[Int]', default => sub { {} }; sub has_traits { my $self = shift; return keys %{$self->traits} ? 1 : 0; } has default => is => 'rw', isa => 'Maybe[Str]' ; has default_when => is => 'rw', isa => 'Str', ; has passed_in => is => 'rw', isa => 'Str', ; has check_exists => is => 'rw', isa => 'Str' ; has is_slurpy => is => 'ro', isa => 'Bool', lazy => 1, default => sub { my $self = shift; return 0 if $self->is_ref_alias; return 0 if !$self->sigil; return $self->sigil =~ m{ ^ [%\@] $ }x; }; has is_at_underscore => is => 'ro', isa => 'Bool', lazy => 1, default => sub { my $self = shift; return $self->variable eq '@_'; }; has required_flag => is => 'rw', isa => 'Str', default => ''; has is_required => is => 'rw', isa => 'Bool', ; # A PPI::Document representing the parameter has ppi_doc => is => 'ro', isa => 'PPI::Document', lazy => 1, default => sub { my $code = $_[0]->ppi_clean_code; return new_ppi_doc(\$code); }; sub is_optional { my $self = shift; return !$self->is_required; } sub BUILD { my $self = shift; return if $self->is_yadayada; $self->_preparse_original_code_for_ppi; $self->_parse_with_ppi; $self->_init_split_variable; $self->_init_is_required; return; } sub _init_is_required { my $self = shift; $self->is_required( $self->_determine_is_required ); } sub _determine_is_required { my $self = shift; return 1 if $self->required_flag eq '!'; return 0 if $self->required_flag eq '?'; return 0 if $self->has_default; return 0 if $self->is_named; return 0 if $self->is_slurpy; return 1; } sub has_default { my $self = shift; return defined $self->default; } sub _parse_with_ppi { my $self = shift; # Nothing to parse. return if $self->ppi_clean_code !~ /\S/; # Replace parameter var so as not to confuse PPI... $self->ppi_clean_code($self->variable. " " .$self->ppi_clean_code); # Tokenize... my $components = $self->ppi_doc; my $statement = $components->find_first("PPI::Statement") or sig_parsing_error("Could not understand parameter specification: @{[$self->ppi_clean_code]}"); my $tokens = [ $statement->children ]; # Re-remove parameter var shift @$tokens; # Extract any 'where' constraints... while ($self->_extract_leading(qr{^ where $}x, $tokens)) { sig_parsing_error("'where' constraint only available under Perl 5.10 or later. Error") if $] < 5.010; push @{$self->where}, $self->_extract_until(qr{^ (?: where | is | = | //= ) $}x, $tokens); } # Extract parameter traits... while ($self->_extract_leading(qr{^ is $}x, $tokens)) { $self->traits->{ $self->_extract_leading(qr{^ \S+ $}x, $tokens) }++; } # Extract normal default specifier (if any)... if ($self->_extract_leading(qr{^ = $}x, $tokens)) { $self->default( $self->_extract_until(qr{^ when $}x, $tokens) ); # Extract 'when' modifier (if any)... if ($self->_extract_leading(qr{^ when $}x, $tokens)) { sig_parsing_error("'when' modifier on default only available under Perl 5.10 or later. Error") if $] < 5.010; $self->default_when( join(q{}, @$tokens) ); $tokens = []; } } # Otherwise, extract undef-default specifier (if any)... elsif ($self->_extract_leading(qr{^ //= $}x, $tokens)) { sig_parsing_error("'//=' defaults only available under Perl 5.10 or later. Error") if $] < 5.010; $self->default_when('undef'); $self->default( join(q{}, @$tokens) ); $tokens = []; } # Anything left over is an error... elsif (my $trailing = $self->_extract_leading(qr{ \S }x, $tokens)) { sig_parsing_error("Unexpected extra code after parameter specification: '", $trailing . join(q{}, @$tokens), "'" ); } return; } # Remove leading whitespace + token, if token matches the specified pattern... sub _extract_leading { my ($self, $selector_pat, $tokens) = @_; while (@$tokens && $tokens->[0]->class eq 'PPI::Token::Whitespace') { shift @$tokens; } return @$tokens && $tokens->[0] =~ $selector_pat ? "" . shift @$tokens : undef; } # Remove tokens up to (but excluding) the first that matches the delimiter... sub _extract_until { my ($self, $delimiter_pat, $tokens) = @_; my $extracted = q{}; while (@$tokens) { last if $tokens->[0] =~ $delimiter_pat; my $token = shift @$tokens; # Flatten multi-line data structures into a single line which # Devel::Declare can inject. $token->prune(sub { !$_[1]->significant }) if $token->isa("PPI::Node"); $extracted .= $token; } return $extracted; } sub _preparse_original_code_for_ppi { my $self = shift; my $original_code = $self->original_code; $self->type($1) if $original_code =~ s{^ ($TYPESPEC) \s+ }{}ox; # Extract ref-alias & named-arg markers, param var, and required/optional marker... $original_code =~ s{ ^ \s* ([\\:]*) \s* ($VARIABLE) \s* ([!?]?) }{}ox or sig_parsing_error("Could not understand parameter specification: $original_code"); my ($premod, $var, $postmod) = ($1, $2, $3); $self->is_ref_alias ($premod =~ m{ \\ }x); $self->is_named ($premod =~ m{ : }x); $self->required_flag($postmod) if $postmod; $self->variable($var) if $var; $self->ppi_clean_code($original_code); return; } sub _init_split_variable { my $self = shift; $self->variable =~ /^(.) (.*)/x; $self->sigil ($1); $self->variable_name($2); return; } # Check the integrity of one piece of the signature sub check { my($self, $signature) = @_; if( $self->is_slurpy ) { sig_parsing_error("Signature can only have one slurpy parameter") if $signature->num_slurpy >= 1; sig_parsing_error("Slurpy parameter '@{[$self->variable]}' cannot be named; use a reference instead") if $self->is_named; } if( $self->is_named ) { if( $signature->num_optional_positional ) { my $pos_var = $signature->positional_parameters->[-1]->variable; my $var = $self->variable; sig_parsing_error("Named parameter '$var' mixed with optional positional '$pos_var'"); } } else { # is_positional if( $signature->num_named ) { my $named_var = $signature->named_parameters->[-1]->variable; my $var = $self->variable; sig_parsing_error("Positional parameter '$var' after named param '$named_var'"); } # Required positional after an optional. # Required positional after a slurpy will be handled elsewhere. if( $self->is_required && $signature->num_optional_positional && !$signature->num_slurpy ) { my $var = $self->variable; my $opt_pos_var = $signature->optional_positional_parameters->[-1] ->variable; sig_parsing_error("Required positional parameter '$var' cannot follow an optional positional parameter '$opt_pos_var'"); } } return 1; } 1; Method-Signatures-20160315/lib/Method/Signatures/Utils.pm000444001751000144 342312672114746 22670 0ustar00buddyusers000000000000package Method::Signatures::Utils; use strict; use warnings; use Carp; use base qw(Exporter); our @EXPORT = qw(new_ppi_doc sig_parsing_error carp_location_for DEBUG); sub DEBUG { return unless $Method::Signatures::DEBUG; require Data::Dumper; local $Data::Dumper::Sortkeys = 1; print STDERR "DEBUG: ", map { ref $_ ? Data::Dumper::Dumper($_) : $_ } @_; } sub new_ppi_doc { my $code = shift; require PPI; my $ppi = PPI::Document->new($code) or sig_parsing_error( "source '$$code' cannot be parsed by PPI: " . PPI::Document->errstr ); return $ppi; }; # Generate cleaner error messages... sub carp_location_for { my ($class, $target) = @_; $target = qr{(?!)} if !$target; # using @CARP_NOT here even though we're not using Carp # who knows? maybe someday Carp will be capable of doing what we want # until then, we're rolling our own, but @CARP_NOT is still serving roughly the same purpose our @CARP_NOT; local @CARP_NOT; push @CARP_NOT, 'Method::Signatures'; push @CARP_NOT, $class unless $class =~ /^${\__PACKAGE__}(::|$)/; push @CARP_NOT, qw< Class::MOP Moose Mouse Devel::Declare >; # Skip any package in the @CARP_NOT list or their sub packages. my $carp_not_list_re = join '|', @CARP_NOT; my $skip = qr/^ $carp_not_list_re (?: :: | $ ) /x; my $level = 0; my ($pack, $file, $line, $method); do { ($pack, $file, $line, $method) = caller(++$level); } while $method !~ $target and $method =~ /$skip/ or $pack =~ /$skip/; return ($file, $line, $method); } sub sig_parsing_error { my ($file, $line) = carp_location_for(__PACKAGE__, 'Devel::Declare::linestr_callback'); my $msg = join('', @_, " in declaration at $file line $line.\n"); die($msg); } 1; Method-Signatures-20160315/lib/Method/Signatures/Types.pm000444001751000144 23212672114746 22647 0ustar00buddyusers000000000000package Method::Signatures::Types; use strict; use warnings; use Mouse::Util::TypeConstraints; subtype 'Inf', as 'Str', where { $_ eq 'inf' }; 1; Method-Signatures-20160315/t000755001751000144 012672114746 15224 5ustar00buddyusers000000000000Method-Signatures-20160315/t/paren_on_own_line.t000444001751000144 35712672114746 21226 0ustar00buddyusers000000000000#!/usr/bin/perl -w package Foo; use strict; use warnings; use Method::Signatures; use Test::More 'no_plan'; # The problem goes away inside an eval STRING. method foo( $arg ) { return $arg; } is $@, ''; is( Foo->foo(42), 42 ); Method-Signatures-20160315/t/traits.t000444001751000144 54412672114746 17037 0ustar00buddyusers000000000000#!/usr/bin/perl -w use strict; use warnings; use Test::More 'no_plan'; { package Stuff; use Test::More; use Method::Signatures; method whatever($this is foo) { return $this; } method andever($this is foo is bar) { return $this; } is( Stuff->whatever(23), 23 ); is( Stuff->andever(42), 42 ); } Method-Signatures-20160315/t/block_defaults.t000444001751000144 333212672114746 20530 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; BEGIN { plan skip_all => "Perl 5.10 or higher required to test block defaults", 1 if $] < 5.010; } # if we don't load it up here, we get the "Devel::Declare not loaded soon enough" error use Method::Signatures; { package Stuff; use Test::More; use Method::Signatures; method add($this = 23 when {$_ < 23}, $that = 42 when {42 < $_}) { return $this + $that; } # Check that it recognizes hashes method add_block($this = 23 when { 2 => 'bad' }, $that = 42 when { 42 < $_ } ) { return $this + $that; } # Check that it disambiguates blocks method add_dis($this = 23 when {; 2 => 'bad' }, $that = 42 when { 42 < $_ } ) { return $this + $that; } method minus($this is ro = 23 when undef, $that is ro = 42 when {($_ % 2)}) { return $this - $that; } is( Stuff->add(), 23 + 42 ); is( Stuff->add(undef), 23 + 42 ); is( Stuff->add(99), 99 + 42 ); is( Stuff->add(2,3), 23 + 3 ); is( Stuff->add(24,3), 24 + 3 ); is( Stuff->add_block(), 23 + 42 ); is( Stuff->add_block(99), 99 + 42 ); is( Stuff->add_block(2,3), 23 + 3 ); is( Stuff->add_block(4,3), 4 + 3 ); is( Stuff->add_block(24,3), 24 + 3 ); is( Stuff->add_dis(), 23 + 42 ); is( Stuff->add_dis(99), 23 + 42 ); is( Stuff->add_dis(2,3), 23 + 3 ); is( Stuff->add_dis(4,3), 23 + 3 ); is( Stuff->add_dis(24,3), 23 + 3 ); is( Stuff->minus(), 23 - 42 ); is( Stuff->minus(undef), 23 - 42 ); is( Stuff->minus(99), 99 - 42 ); is( Stuff->minus(2, 3), 2 - 42 ); is( Stuff->minus(2, 4), 2 - 4 ); } done_testing; Method-Signatures-20160315/t/defined_or_defaults.t000444001751000144 403412672114746 21534 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; # Skip the test before Method::Signatures can try to compile it and blow up. BEGIN { plan skip_all => "Perl 5.10 or higher required to test where constraints" if $] < 5.010; } { package Stuff; use Test::More; use Method::Signatures; method add($this //= 23, $that //= 42) { return $this + $that; } method minus($this is ro //= 23, $that is ro //= 42) { return $this - $that; } is( Stuff->add(), 23 + 42 ); is( Stuff->add(undef), 23 + 42 ); is( Stuff->add(99), 99 + 42 ); is( Stuff->add(2,3), 5 ); is( Stuff->minus(), 23 - 42 ); is( Stuff->minus(undef), 23 - 42 ); is( Stuff->minus(99), 99 - 42 ); is( Stuff->minus(2, 3), 2 - 3 ); # Test again that undef doesn't override defaults method echo($message //= "what?") { return $message } is( Stuff->echo(), "what?" ); is( Stuff->echo(undef), "what?" ); is( Stuff->echo("who?"), 'who?' ); # Test that you can reference earlier args in a default method copy_cat($this, $that //= $this) { return $that; } is( Stuff->copy_cat("wibble"), "wibble" ); is( Stuff->copy_cat("wibble", undef), "wibble" ); is( Stuff->copy_cat(23, 42), 42 ); } { package Bar; use Test::More; use Method::Signatures; method hello($msg //= "Hello, world!") { return $msg; } is( Bar->hello, "Hello, world!" ); is( Bar->hello(undef), "Hello, world!" ); is( Bar->hello("Greetings!"), "Greetings!" ); method hi($msg //= q,Hi,) { return $msg; } is( Bar->hi, "Hi" ); is( Bar->hi(undef), "Hi" ); is( Bar->hi("Yo"), "Yo" ); method list(@args = (1,2,3) when ()) { return @args; } is_deeply [Bar->list()], [1,2,3]; method code($num, $code //= sub { $num + 2 }) { return $code->(); } is( Bar->code(42), 44 ); } done_testing; Method-Signatures-20160315/t/role_check_basic.t000444001751000144 316312672114746 21010 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use lib 't/lib'; use GenErrorRegex qw< badval_error >; use Test::More; use Test::Exception; # This may not be possible. I'm not sure that Role::Basic and Mouse are going to play nice # together, and I'm not even sure it's a viable use case. That is, if you're using # Method::Signatures, you're already getting Mouse, and, if you're already getting Mouse, why use # Role::Basic? Role::Basic's doco itself says that it's designed for people who don't want Mouse # (or Moose), and, if you don't want Mouse, you might not want to use Method::Signatures, since that # brings in Mouse whether you like it or not (assuming you're doing type checking, but then, if # you're not doing type checking, you wouldn't be caring about Role::Basic interaction). # # So if we decide we want to pursue this, it may be possible by working with Ovid and creating a # Mouse subtype to check Role::Basic roles, but in the meantime, I'm just marking this all TODO. TODO: { local $TODO = "Compatibility with Role::Basic unimplemented"; { package Foo::Bar; sub new { bless {}, __PACKAGE__; } } SKIP: { eval "use Role::Basic ()" or skip "Role::Basic required for testing basic roles", 2; require BasicRoleTest; use Method::Signatures; my $basic = WithBasicRole->new; my $foobar = Foo::Bar->new; func basicy (BasicRole $foo) {} # positive test lives_ok { basicy($basic) } 'Basic role passes okay'; # negative test throws_ok { basicy($foobar) } badval_error(undef, foo => BasicRole => $foobar, 'basicy'), 'Basic role fails when appropriate'; } } done_testing; Method-Signatures-20160315/t/error_interruption.t000444001751000144 51012672114746 21475 0ustar00buddyusers000000000000 use strict; use warnings; use lib 't/lib'; use Test::More; use Test::Exception; TODO: { local $TODO; $TODO = 'Older Perls have trouble with this' if $] < 5.010001; throws_ok { require BarfyDie } qr/requires explicit package name/, "MS doesn't interrupt real compilation error"; } done_testing(); Method-Signatures-20160315/t/anon.t000444001751000144 47012672114746 16462 0ustar00buddyusers000000000000#!/usr/bin/perl -w use strict; use warnings; use Test::More 'no_plan'; { package Stuff; use Test::More; use Method::Signatures; method echo($arg) { return $arg } my $method = method ($arg) { return $self->echo($arg) }; is( Stuff->$method("foo"), "foo" ); } Method-Signatures-20160315/t/signature_error_handler.t000444001751000144 66012672114746 22437 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use lib 't/lib'; use My::Method::Signatures { compile_at_BEGIN => 0 }; func no_sig { return @_ } note "signature_error_handler"; { ok !eval { no_sig(42); 1 }, "no args"; my $exception = $@; isa_ok($exception, 'My::ExceptionClass'); my $msg = $exception->{message}; like $msg, qr{no_sig\(\).*given too many arguments.*it expects 0}; } done_testing; Method-Signatures-20160315/t/when.t000444001751000144 227112672114746 16511 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; # Skip the test before Method::Signatures can try to compile it and blow up. BEGIN { plan skip_all => "Perl 5.10 or higher required to test where constraints" if $] < 5.010; } use Method::Signatures; subtest "when {}" => sub { func empty_hash( HashRef[Int] $ref = { foo => 23, bar => 42 } when {} ) { return $ref; } is_deeply empty_hash(), { foo => 23, bar => 42 }; is_deeply empty_hash({}), { foo => 23, bar => 42 }; is_deeply empty_hash({ this => 23 }), { this => 23 }; }; subtest "when []" => sub { func empty_array( ArrayRef[Int] $ref = [1,2,3] when [] ) { return $ref; } is_deeply empty_array(), [1,2,3]; is_deeply empty_array([]), [1,2,3]; is_deeply empty_array([4,5,6]), [4,5,6]; }; subtest "Defaults are applied before type check" => sub { package Baz; use Test::More; use Method::Signatures; func hi( Str $place //= "World" ) { return "Hi, $place!\n"; } is hi(), "Hi, World!\n"; is hi(undef), "Hi, World!\n"; }; done_testing; Method-Signatures-20160315/t/mxd-role.t000444001751000144 121112672114746 17270 0ustar00buddyusers000000000000 use Test::More; use Test::Exception; use lib 't/lib'; use GenErrorRegex qw< badval_error badtype_error >; # Final test: make sure we can load up our role file which adds method modifiers for methods that # don't exist. That's okay for roles, so we need to make sure we're allowing it. # # In this case, as long as the module loads okay, we're good. SKIP: { eval { require MooseX::Declare } or skip "MooseX::Declare required for this test", 1; # have to require here or else we try to load MXD before we check for it not being there (above) lives_ok { require MS_MXD_Role } "role method modifiers load okay"; } done_testing(); Method-Signatures-20160315/t/role_check_mouse.t000444001751000144 110212672114746 21046 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use lib 't/lib'; use GenErrorRegex qw< badval_error >; use Test::More; use Test::Exception; { package Foo::Bar; sub new { bless {}, __PACKAGE__; } } require MouseRoleTest; use Method::Signatures; my $mouse = WithMouseRole->new; my $foobar = Foo::Bar->new; func mousey (MouseRole $foo) {} # positive test lives_ok { mousey($mouse) } 'Mouse role passes okay'; # negative test throws_ok { mousey($foobar) } badval_error(undef, foo => MouseRole => $foobar, 'mousey'), 'Mouse role fails when appropriate'; done_testing; Method-Signatures-20160315/t/named_refs.t000444001751000144 303412672114746 17651 0ustar00buddyusers000000000000#!/usr/bin/perl -w use strict; use warnings; use lib 't/lib'; use Dev::Null; use Test::More; BEGIN { plan skip_all => "Data::Alias not available" unless eval { require Data::Alias }; plan 'no_plan'; } # Test a basic alias. { package Foo; use Test::More; use Method::Signatures; method add_one_to_each(\:@args) { $_++ for @args; return @args; } my @input = (1,2,3); is_deeply [Foo->add_one_to_each(args=>\@input)], [2,3,4]; is_deeply \@input, [2,3,4]; tie *STDERR, "Dev::Null"; ok !eval q[@args; 1;], '\@args does not leak out of subroutine'; untie *STDERR; } # Try to break the aliasing prototype { package Bar; use Test::More; use Method::Signatures; method break_args($foo, \:@bar, \:%baz, :$num, \:$biff, ...) { return { foo => $foo, bar => \@bar, baz => \%baz, num => $num, biff => $biff, } } is_deeply( Bar->break_args(1, bar=>[2,3], baz=>{4 => 5}, num=>6, biff=>\7, (8,9)), { foo => 1, bar => [2,3], baz => {4 => 5}, num => 6, biff => 7 } ); } # What about closures? { package Stuff; use Method::Signatures; method make_closure(\:@nums) { return sub { return @nums; }; } my $closure1 = Stuff->make_closure(nums=>[1,2,3]); my $closure2 = Stuff->make_closure(nums=>[4,5,6]); ::is_deeply [$closure1->()], [1,2,3]; ::is_deeply [$closure2->()], [4,5,6]; } Method-Signatures-20160315/t/attributes.t000444001751000144 204612672114746 17736 0ustar00buddyusers000000000000#!/usr/bin/perl -w use strict; use warnings; use Test::More 'no_plan'; use attributes; { package Stuff; use Test::More; use Method::Signatures; method echo($arg) : method { return $arg; } is( Stuff->echo(42), 42 ); is_deeply( [attributes::get \&echo], ['method'] ); } { package Foo; use Test::More; use Method::Signatures; my $code = func () : method {}; is_deeply( [attributes::get $code], ['method'] ); } { package Things; use attributes; use Method::Signatures; my $attrs; my $cb_called; sub MODIFY_CODE_ATTRIBUTES { my ($pkg, $code, @attrs) = @_; $cb_called = 1; $attrs = \@attrs; return (); } method moo($foo, $bar) : Bar Baz(fubar) { } # Torture test for the attribute handling. method foo : Bar :Moo(:Ko{oh) : Baz(fu{bar:): { return {} } ::ok($cb_called, 'attribute handler got called'); ::is_deeply($attrs, [qw/Bar Moo(:Ko{oh) Baz(fu{bar:)/], '... with the right attributes'); } Method-Signatures-20160315/t/line_numbers.t000444001751000144 373312672114746 20236 0ustar00buddyusers000000000000#!/usr/bin/perl -w # Test that Method::Signatures does not change the line numbers # in caller and error messages. use strict; use Test::More; use Method::Signatures; my $DEFAULT_LINES_NOT_WORKING = $] < 5.012; my $DEFAULT_LINES_NOT_WORKING_REASON = 'Earlier versions of Perl get the line numbers wrong'; note "Basic multi-line signature"; { #line 13 func basic_multi_line ( $arg = "test" ) { return __LINE__; } is basic_multi_line(), 16; is __LINE__, 21, "line numbers ok after function"; } note "Computed default"; { # Using 'sub' to avoid further Method::Signatures interference sub return_caller_line { return (caller)[2]; } #line 30 func computed_default ( $static_default = "test", $computed_default = return_caller_line() ) { return [__LINE__, $computed_default]; } my $have = computed_default(); is $have->[0], 34, "body line number"; SKIP: { skip $DEFAULT_LINES_NOT_WORKING_REASON, 1 if $DEFAULT_LINES_NOT_WORKING; is $have->[1], 32, "computed default line number"; }; is __LINE__, 44, "line numbers ok after function"; } note "single line signature"; { #line 45 func single_line($a?, $b?, $c?) { return __LINE__ } is single_line, 45; is __LINE__, 47, "line numbers ok after function"; } # Multi-line defaults are collapsed into one line, so __LINE__ # will be off after the first line of each default. note "multi-line default"; { #line 52 func multi_line_defaults( $a = { line => __LINE__ }, $b = { line => __LINE__ } ) { return [$a->{line}, $b->{line}, __LINE__]; } my $have = multi_line_defaults; SKIP: { skip $DEFAULT_LINES_NOT_WORKING_REASON, 1 if $DEFAULT_LINES_NOT_WORKING; is $have->[0], 53, 'default $a'; is $have->[1], 55, 'default $b'; } is $have->[2], 58, 'body'; is __LINE__, 69, "line numbers ok after function"; } done_testing; Method-Signatures-20160315/t/thread-bug.t000444001751000144 131412672114746 17567 0ustar00buddyusers000000000000#! /usr/bin/env perl # eval + Data::Alias + threads == segfault # See rt.cpan.org 82922 # This tests that we at least don't blow up on load of MS. use strict; use warnings; use Config; # threads.pm must be loaded before Test::More in order for Test::More # to operate properly with threaded tests. my $has_threads; BEGIN { $has_threads = eval { require threads }; } use Test::More; plan skip_all => 'This test only relevant under threaded Perls' if !$has_threads; use Method::Signatures; sub worker { pass("Before eval"); eval "1 + 1"; pass("After eval"); return 1; } pass("Creating thread"); my $thr = threads->create(\&worker); $thr->join(); pass("Threads joined"); done_testing(4); Method-Signatures-20160315/t/slurpy.t000444001751000144 332712672114746 17111 0ustar00buddyusers000000000000#!/usr/bin/perl -w # Test slurpy parameters use strict; use warnings; use Test::More; use Test::Exception; { package Stuff; use Method::Signatures; use Test::More; method slurpy(@that) { return \@that } method slurpy_required(@that!) { return \@that } method slurpy_last($this, @that) { return $this, \@that; } ok !eval q[func slurpy_first(@that, $this) { return $this, \@that; }]; like $@, qr{Slurpy parameter '\@that' must come at the end}; TODO: { local $TODO = "error message incorrect inside an eval"; like $@, qr{Stuff::}; like $@, qr{slurpy_first\(\)}; } ok !eval q[func slurpy_middle($this, @that, $other) { return $this, \@that, $other }]; like $@, qr{slurpy parameter .* must come at the end}i; TODO: { local $TODO = "error message incorrect inside an eval"; like $@, qr{Stuff::}; like $@, qr{slurpy_middle\(\)}; } ok !eval q[func slurpy_positional(:@that) { return \@that; }]; like $@, qr{slurpy parameter .* cannot be named. use a reference instead}i; TODO: { local $TODO = "error message incorrect inside an eval"; like $@, qr{Stuff::}; like $@, qr{slurpy_positional\(\)}; } ok !eval q[func slurpy_two($this, @that, @other) { return $this, \@that, \@other }]; like $@, qr{can only have one slurpy parameter}; } note "Optional slurpy params accept 0 length list"; { is_deeply [Stuff->slurpy()], [[]]; is_deeply [Stuff->slurpy_last(23)], [23, []]; } note "Required slurpy params require an argument"; { throws_ok { Stuff->slurpy_required() } qr{slurpy_required\Q()\E, missing required argument \@that at \Q$0\E line @{[__LINE__ - 1]}}; } done_testing; Method-Signatures-20160315/t/too_many_args.t000444001751000144 305412672114746 20411 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Method::Signatures { compile_at_BEGIN => 0 }; func no_sig { return @_ } func no_args() { return @_ } func one_arg($foo) { return $foo } func two_args($foo, $bar) { return ($foo, $bar) } func array_at_end($foo, @stuff) { return ($foo, @stuff) } func one_named(:$foo) { return $foo; } func one_named_one_positional($bar, :$foo) { return($foo, $bar) } note "too many arguments"; { ok !eval { no_sig(42); 1 }, "no args"; like $@, qr{no_sig\(\), was given too many arguments; it expects 0}; ok !eval { no_args(42); 1 }, "no args"; like $@, qr{no_args\(\), was given too many arguments; it expects 0}; ok !eval { one_arg(23, 42); 1 }, "one arg"; like $@, qr{one_arg\(\), was given too many arguments; it expects 1}; ok !eval { two_args(23, 42, 99); 1 }, "two args"; like $@, qr{two_args\(\), was given too many arguments; it expects 2}; is_deeply [array_at_end(23, 42, 99)], [23, 42, 99], "array at end"; } note "with positionals"; { is one_named(foo => 42), 42; ok !eval { one_named(foo => 23, foo => 42); 1 }; like $@, qr{one_named\(\), was given too many arguments; it expects 1}; is_deeply [one_named_one_positional(23, foo => 42)], [42, 23]; ok !eval { one_named_one_positional(23, foo => 42, foo => 23); 1 }; like $@, qr{one_named_one_positional\(\), was given too many arguments; it expects 2}; } done_testing; Method-Signatures-20160315/t/default_invocant.t000444001751000144 740112672114746 21075 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; # in each class/package constructed in this test script, we want to essentially # perform the same set of tests, just with slightly different parameters. sub do_common_subtests { my %opt = @_; my $class = $opt{class} || scalar caller; subtest $opt{desc} => sub { is $class->name, $class, 'works in class method call'; my $obj = new_ok $class, [], 'works in constructor'; isa_ok $obj->self, $class, 'works in object method call'; isa_ok $obj->specified, $class, 'invocant specified in signature still works'; done_testing; }; } # Below are a series of packages that use MS with various, um, variations # on setting the import parameter. Not only do we want to make sure that using # the parameter works properly, we also want to ensure it doesn't change # existing functionality when it's not being used. We also want to be sure that # invalid values cause an exception, but when that happens it still does not # break anything for other classes using MS. (hey, it happens) # TODO: Should I generate these test classes? They're so very repetitive. # Can't think of a simple way without string-eval, though... { package Foo; use Test::More; use Method::Signatures { invocant => '$foo' }; method name { return $foo } # call this as a class method. method new { return bless {}, $foo } method self { return $foo } method specified( $fnord: ) { return $fnord } main::do_common_subtests( desc => 'use option to specify different default invocant var', ); } { package Bar; use Test::More; use Method::Signatures { invocant => '$bar' }; method name { return $bar } method new { return bless {}, $bar } method self { return $bar } method specified( $fnord: ) { return $fnord } main::do_common_subtests( desc => 'diff invocant option in diff class in same program', ); } { package Self; use Test::More; use Method::Signatures; method name { return $self } method new { return bless {}, $self } method self { return $self } method specified( $fnord: ) { return $fnord } main::do_common_subtests( desc => 'no invocant option in diff class in same program still defaults to "$self"', ); } { package Bad; use Test::More; # this seems exhaustive enough for now... my @bad_invocants = ( q{bad}, q{$also bad}, q{$real $bad}, q{thriller was a great album}, q{%worse}, q{"$worser"}, q{'$wurst'}, q{weiner $chnitzel}, q{""}, q{''}, q{[]}, q[{}], q{}, q{undef}, q{0foo}, q{$0foo}, q{$}, q{$$}, q{$-}, q{$-foo}, q{$fo-o}, q{$foo-}, q{$foo-bar}, q{$$foo}, # and for the hell of it... q{q[$urprise]}, ); # say *that* ten times fast: my $desc = 'invalid invocant options incur exceptions'; subtest $desc => sub { my $use_statement = q{ use Method::Signatures { invocant => q{%HERE} }; }; # make sure MS always throws an exception when use'd with invocant # set to any of the bad values above. for my $inv ( @bad_invocants ) { (my $use = $use_statement) =~ s/%HERE/$inv/; eval $use; like $@, qr/Invalid invocant name/, "die when invocant option set to '$inv'"; } }; } # make sure previously tested classes still work after testing the # invalid invocants do_common_subtests( class => 'Bar', desc => 'Bar class still works even after testing invalid invocants', ); do_common_subtests( class => 'Self', desc => 'Self class still works even after testing invalid invocants', ); done_testing; Method-Signatures-20160315/t/type_check.t000444001751000144 1473412672114746 17715 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use Method::Signatures; { package Foo::Bar; sub new { bless {}, __PACKAGE__; } } { package Foo::Baz; sub new { bless {}, __PACKAGE__; } } our $foobar = Foo::Bar->new; our $foobaz = Foo::Baz->new; # types to check below # the test name needs to be interpolated into a method name, so it must be a valid identifier # either good value or bad value can be an array reference: # * if it is, it is taken to be multiple values to try # * if you want to pass an array reference, you have to put it inside another array reference # * so, [ 42, undef ] makes two calls: one with 42, and one with undef # * but [[ 42, undef ]] makes one call, passing [ 42, undef ] our @TYPES = ( ## Test Name => Type => Good Value => Bad Value int => 'Int' => 42 => 'foo' , bool => 'Bool' => 0 => 'fool' , aref => 'ArrayRef', => [[ 42, undef ]] => 42 , class => 'Foo::Bar' => $foobar => $foobaz , maybe_int => 'Maybe[Int]' => [ 42, undef ] => 'foo' , paramized_aref => 'ArrayRef[Num]' => [[ 6.5, 42, 1e23 ]] => [[ 6.5, 42, 'thing' ]] , paramized_href => 'HashRef[Num]' => { a => 6.5, b => 2, c => 1e23 } => { a => 6.5, b => 42, c => 'thing' } , paramized_nested=> 'HashRef[ArrayRef[Int]]' => { foo=>[1..3], bar=>[1] } => { foo=>['a'] } , ## ScalarRef[X] not implemented in Mouse, so this test is moved to typeload_moose.t ## if Mouse starts supporting it, the test could be restored here # paramized_sref => 'ScalarRef[Num]' => \42 => \'thing' , int_or_aref => 'Int|ArrayRef[Int]' => [ 42 , [42 ] ] => 'foo' , int_or_aref_or_undef => 'Int|ArrayRef[Int]|Undef' => [ 42 , [42 ], undef ] => 'foo' , ); our $tester; { package TypeCheck::Class; use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use lib 't/lib'; use GenErrorRegex qw< badval_error badtype_error >; use Method::Signatures; method new ($class:) { bless {}, $class; } sub _list { return ref $_[0] eq 'ARRAY' ? @{$_[0]} : ( $_[0] ); } $tester = __PACKAGE__->new; while (@TYPES) { my ($name, $type, $goodval, $badval) = splice @TYPES, 0, 4; note "name/type/goodval/badval $name/$type/$goodval/$badval"; my $method = "check_$name"; no strict 'refs'; # make sure the declaration of the method doesn't throw a warning warning_is { eval qq{ method $method ($type \$bar) {} } } undef, "no warnings from declaring $name param"; # positive test--can we call it with a good value? my @vals = _list($goodval); my $count = 1; foreach (@vals) { my $tag = @vals ? ' (alternative ' . $count++ . ')' : ''; lives_ok { $tester->$method($_) } "call with good value for $name passes" . $tag; } # negative test--does calling it with a bad value throw an exception? @vals = _list($badval); $count = 1; foreach (@vals) { my $tag = @vals ? ' (#' . $count++ . ')' : ''; throws_ok { $tester->$method($_) } badval_error($tester, bar => $type, $_, $method), "call with bad value for $name dies"; } } # try some mixed (i.e. some with a type, some without) and multiples my $method = 'check_mixed_type_first'; warning_is { eval qq{ method $method (Int \$bar, \$baz) {} } } undef, 'no warnings (type, notype)'; lives_ok { $tester->$method(0, 'thing') } 'call with good values (type, notype) passes'; throws_ok { $tester->$method('thing1', 'thing2') } badval_error($tester, bar => Int => thing1 => $method), 'call with bad values (type, notype) dies'; $method = 'check_mixed_type_second'; warning_is { eval qq{ method $method (\$bar, Int \$baz) {} } } undef, 'no warnings (notype, type)'; lives_ok { $tester->$method('thing', 1) } 'call with good values (notype, type) passes'; throws_ok { $tester->$method('thing1', 'thing2') } badval_error($tester, baz => Int => thing2 => $method), 'call with bad values (notype, type) dies'; $method = 'check_multiple_types'; warning_is { eval qq{ method $method (Int \$bar, Int \$baz) {} } } undef, 'no warnings when type loaded'; lives_ok { $tester->$method(1, 1) } 'call with good values (type, type) passes'; # with two types, and bad values for both, they should fail in order of declaration throws_ok { $tester->$method('thing1', 'thing2') } badval_error($tester, bar => Int => thing1 => $method), 'call with bad values (type, type) dies'; # want to try one with undef as well to make sure we don't get an uninitialized warning warning_is { eval { $tester->check_int(undef) } } undef, 'no warning for undef value in type checking'; like $@, badval_error($tester, bar => Int => undef, 'check_int'), 'call with undefined Int arg is okay'; # finally, some types that shouldn't be recognized my $type; $method = 'unknown_type'; $type = 'Bmoogle'; warning_is { eval qq{ method $method ($type \$bar) {} } } undef, 'no warnings when weird type loaded'; throws_ok { $tester->$method(42) } badtype_error($tester, $type, "perhaps you forgot to load it?", $method), 'call with unrecognized type dies'; # this one is a bit specialer in that it involved an unrecognized parameterization $method = 'unknown_paramized_type'; $type = 'Bmoogle[Int]'; warning_is { eval qq{ method $method ($type \$bar) {} } } undef, 'no warnings when weird paramized type loaded'; throws_ok { $tester->$method(42) } badtype_error($tester, $type, "looks like it doesn't parse correctly", $method), 'call with unrecognized paramized type dies'; } done_testing; Method-Signatures-20160315/t/string_defaults.t000444001751000144 423512672114746 20747 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; # Skip the test before Method::Signatures can try to compile it and blow up. BEGIN { plan skip_all => "Perl 5.10 or higher required to test where constraints" if $] < 5.010; } { package Stuff; use Test::More; use Method::Signatures; method add($this = 23 when '', $that = 42 when '') { no warnings 'uninitialized'; return $this + $that; } method minus($this is ro = 23 when '', $that is ro = 42 when "") { return $this - $that; } is( Stuff->add(), 23 + 42 ); is( Stuff->add(''), 23 + 42 ); is( Stuff->add(undef), 42 ); is( Stuff->add(99), 99 + 42 ); is( Stuff->add(2,3), 5 ); is( Stuff->minus(), 23 - 42 ); is( Stuff->minus(''), 23 - 42 ); is( Stuff->minus(99), 99 - 42 ); is( Stuff->minus(2, 3), 2 - 3 ); # Test again that empty string doesn't override defaults method echo($message = "what?" when q{}) { return $message } is( Stuff->echo(), "what?" ); is( Stuff->echo(''), "what?" ); is( Stuff->echo("who?"), 'who?' ); # Test that you can reference earlier args in a default method copy_cat($this, $that = $this when '') { return $that; } is( Stuff->copy_cat("wibble"), "wibble" ); is( Stuff->copy_cat("wibble", ""), "wibble" ); is( Stuff->copy_cat(23, 42), 42 ); } { package Bar; use Test::More; use Method::Signatures; method hello($msg = "Hello, world!" when '') { return $msg; } is( Bar->hello, "Hello, world!" ); is( Bar->hello(q{}), "Hello, world!" ); is( Bar->hello("Greetings!"), "Greetings!" ); method hi($msg = q,Hi, when '') { return $msg; } is( Bar->hi, "Hi" ); is( Bar->hi(q{}), "Hi" ); is( Bar->hi("Yo"), "Yo" ); method list(@args = (1,2,3) when ()) { return @args; } is_deeply [Bar->list()], [1,2,3]; method code($num, $code = sub { $num + 2 } when '') { return $code->(); } is( Bar->code(42), 44 ); } done_testing; Method-Signatures-20160315/t/where.t000444001751000144 764012672114746 16667 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; # Skip the test before Method::Signatures can try to compile it and blow up. BEGIN { plan skip_all => "Perl 5.10.1 or higher required to test where constraints" if $] < 5.01001; } use Method::Signatures; my $where_func = q{ func silly_test ($x where { $_ == 3 }) {} }; warning_is { eval $where_func } undef, 'no warnings for using smartmatch'; subtest 'where { block() }' => sub { plan tests => 3; func small_int (Maybe[Int] $x where { $_ < 10 } is copy = 0 when undef) { ok defined $x, "small_int($x) has defined value"; ok $x < 10, "small_int($x) has value in range"; return 1; } subtest "small_int()" => sub { ok eval{ small_int(); }, "small_int() called as expected" or note $@; }; subtest "small_int(9)" => sub { ok eval{ small_int(9); }, "small_int(9) called as expected" or note $@; }; subtest "small_int(10)" => sub { ok !eval{ small_int(10);}, "small_int(10) not called (as expected)"; note $@; }; }; subtest 'where [0..10]' => sub { plan tests => 4; func range_int (Maybe[Int] $x where [0..9] is copy = 0 when undef) { ok defined $x, "range_int($x) has defined value"; ok 0 <= $x && $x <= 9, "range_int($x) has value in range"; return 1; } subtest "range_int()" => sub { ok eval{ range_int(); }, "range_int() called as expected" or note $@; }; subtest "range_int(9)" => sub { ok eval{ range_int(9); }, "range_int(9) called as expected" or note $@; }; subtest "range_int(10)" => sub { ok !eval{ range_int(10);}, "range_int(10) not called (as expected)"; note $@; }; subtest "range_int(-1)" => sub { ok !eval{ range_int(-1);}, "range_int(10) not called (as expected)"; note $@; }; }; subtest 'where { cat => 1, dog => 2}' => sub { plan tests => 4; func hash_member (Maybe[Str] $x where { cat => 1, dog => 2 } is copy = 'cat' when undef) { ok defined $x, "hash_member($x) has defined value"; like $x, qr{^(cat|dog)$} , "hash_member($x) has value in range"; return 1; } subtest "hash_member()" => sub { ok eval{ hash_member(); }, "hash_member() called as expected" or note $@; }; subtest "hash_member('cat')" => sub { ok eval{ hash_member('cat'); }, "hash_member('cat') called as expected" or note $@; }; subtest "hash_member('dog')" => sub { ok eval{ hash_member('dog'); }, "hash_member('dog') called as expected" or note $@; }; subtest "hash_member('fish')" => sub { ok !eval{ hash_member('fish');}, "hash_member('fish') not called (as expected)"; note $@; }; }; subtest 'where where where' => sub { no if $] >= 5.017011, warnings => 'experimental::smartmatch'; plan tests => 14; func is_prime ($x) { return $x ~~ [2,3,5,7,11]; } func neg_and_odd_and_prime ($x where [0..10] where { $x % 2 } where \&is_prime ) { ok $x ~~ [3,5,7], '$x had acceptable value'; return 1; } for my $n (-1..11) { subtest "neg_and_odd_and_prime($n)" => sub { local $@; my $result = eval{ neg_and_odd_and_prime($n); }; my $error = $@; if (defined $result) { pass "neg_and_odd_and_prime($n) as expected"; } else { like $error, qr{\$x value \("$n"\) does not satisfy constraint:} => "neg_and_odd_and_prime($n) as expected"; note $@; } }; } # try an undef value my $result = eval{ neg_and_odd_and_prime(undef); }; like $@, qr{\$x value \(undef\) does not satisfy constraint:}, "neg_and_odd_and_prime(undef) as expected"; }; done_testing; Method-Signatures-20160315/t/trailing_comma.t000444001751000144 34612672114746 20516 0ustar00buddyusers000000000000#!/usr/bin/env perl # Make sure we allow a trailing comma. use strict; use warnings; use Test::More; use Method::Signatures; func foo($foo, $bar,) { return [$foo, $bar]; } is_deeply foo(23, 42), [23, 42]; done_testing; Method-Signatures-20160315/t/simple.plx000444001751000144 17612672114746 17363 0ustar00buddyusers000000000000package Foo; use strict; use warnings; use Method::Signatures; method echo($msg) { return $msg } print Foo->echo(42); Method-Signatures-20160315/t/comments.t000444001751000144 300212672114746 17366 0ustar00buddyusers000000000000 use strict; use warnings; use Test::More; use Test::Exception; use Method::Signatures; lives_ok { eval q{ func foo ( Int :$foo, # this is foo Int :$bar # this is bar ) { } 1; } or die; } 'survives comments within the signature itself'; lives_ok { eval q{ func bar ( Int :$foo, Int :$bar ) # this is a signature { } 1; } or die; } 'survives comments between signature and open brace'; SKIP: { eval { require MooseX::Declare } or skip "MooseX::Declare required for this test", 1; lives_ok { eval q{ use MooseX::Declare; use Method::Signatures::Modifiers; class Foo { method bar ( Int :$foo, Int :$bar ) # this is a signature { } } 1; } or die; } 'survives comments between signature and open brace'; } TODO: { local $TODO = "closing paren in comment: rt.cpan.org 81364"; lives_ok { # When this fails, it produces 'Variable "$bar" is not imported' # This is expected to fail, don't bother the user. no warnings; eval q{ func special_comment ( $foo, # ) $bar ) { 42 } 1; } or die; } 'closing paren in comment'; is eval q[special_comment("this", "that")], 42; } done_testing(); Method-Signatures-20160315/t/parameters.t000444001751000144 353212672114746 17714 0ustar00buddyusers000000000000#!/usr/bin/perl -w use strict; use warnings; use Test::More 'no_plan'; use Method::Signatures::Signature; my %tests = ( '$foo' => ['$foo'], '$foo, $bar' => ['$foo', '$bar'], ':$foo, $bar?' => [':$foo', '$bar?'], '' => [], '$sum = 2+2, $div = 2/2' => ['$sum = 2+2', '$div = 2/2'], '$foo = "Hello, world!"' => ['$foo = "Hello, world!"'], '@args = (1,2,3)' => ['@args = (1,2,3)'], '$foo = [1,2,3], $bar = { this => 23, that => 42 }' => [ '$foo = [1,2,3]', '$bar = { this => 23, that => 42 }' ], '$code = sub { my $bar = 2+2; }, :$this' => ['$code = sub { my $bar = 2+2; }', ':$this'], q[ $num = 42, $string = q[Hello, world!], $hash = { this => 42, that => 23 }, $code = sub { $num + 4 }, @nums = (1,2,3) ] => [ '$num = 42', '$string = q[Hello, world!]', '$hash = { this => 42, that => 23 }', '$code = sub { $num + 4 }', '@nums = (1,2,3)' ], ); while(my($args, $expect) = each %tests) { my $sig = Method::Signatures::Signature->new( signature_string => $args, # we just want to test the tokenizing no_checks => 1, ); is_deeply [map { $_->original_code } @{$sig->parameters}], $expect, "parameters - $args"; } note "line numbers"; { my $code = q[ $num = 42, $hash = { this => 42, that => 23 }, $code = sub { $num + 4 }, ]; my $sig = Method::Signatures::Signature->new( signature_string => $code, no_checks => 1, ); my $parameters = $sig->parameters; is $parameters->[0]->first_line_number, 2; is $parameters->[1]->first_line_number, 3; is $parameters->[2]->first_line_number, 5; } Method-Signatures-20160315/t/zero_defaults.t000444001751000144 411712672114746 20417 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; BEGIN { plan skip_all => "Perl 5.10 or higher required to test default conditions", 1 if $] < 5.010; } { package Stuff; use Test::More; use Method::Signatures; method add($this = 23 when 0, $that = 42 when 0) { no warnings 'uninitialized'; return $this + $that; } method minus($this is ro = 23 when 0, $that is ro = 42 when 0x0) { return $this - $that; } is( Stuff->add(), 23 + 42 ); is( Stuff->add(0), 23 + 42 ); is( Stuff->add(undef), 42 ); is( Stuff->add(99), 99 + 42 ); is( Stuff->add(2,3), 5 ); is( Stuff->minus(), 23 - 42 ); is( Stuff->minus(0), 23 - 42 ); is( Stuff->minus(99), 99 - 42 ); is( Stuff->minus(2, 3), 2 - 3 ); # Test again that empty string doesn't override defaults method echo($message = "what?" when 0.0) { return $message } is( Stuff->echo(), "what?" ); is( Stuff->echo(0), "what?" ); is( Stuff->echo(1), 1 ); # Test that you can reference earlier args in a default method copy_cat($this, $that = $this when 0) { return $that; } is( Stuff->copy_cat("wibble"), "wibble" ); is( Stuff->copy_cat("wibble", 0), "wibble" ); is( Stuff->copy_cat(23, 42), 42 ); } { package Bar; use Test::More; use Method::Signatures; method hello($msg = "Hello, world!" when 0) { return $msg; } is( Bar->hello, "Hello, world!" ); is( Bar->hello(0x0), "Hello, world!" ); is( Bar->hello(42), 42 ); method hi($msg = q,Hi, when 0) { return $msg; } is( Bar->hi, "Hi" ); is( Bar->hi(0.0), "Hi" ); is( Bar->hi(1), 1 ); method list(@args = (1,2,3) when ()) { return @args; } is_deeply [Bar->list()], [1,2,3]; method code($num, $code = sub { $num + 2 } when 0) { return $code->(); } is( Bar->code(42), 44 ); } done_testing; Method-Signatures-20160315/t/at_underscore.t000444001751000144 54412672114746 20366 0ustar00buddyusers000000000000#!/usr/bin/env perl # Test the @_ signature use strict; use warnings; use Test::More; { package Foo; use Method::Signatures; func foo(@_) { return @_ } method bar(@_) { return @_ } } is_deeply [Foo::foo()], []; is_deeply [Foo::foo(23, 42)], [23, 42]; is_deeply [Foo->bar()], []; is_deeply [Foo->bar(23, 42)], [23, 42]; done_testing; Method-Signatures-20160315/t/begin.t000444001751000144 302012672114746 16625 0ustar00buddyusers000000000000#!/usr/bin/perl package Foo; use strict; use warnings; use Test::More; use Test::Exception; use Method::Signatures; our $phase; BEGIN { $phase = 'compile-time' } INIT { $phase = 'run-time' } sub method_defined { my ($method) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; lives_ok { Foo->$method } "method $method is defined at $phase"; } sub method_undefined { my ($method) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; throws_ok { Foo->$method } qr/Can't locate object method/, "method $method is undefined at $phase"; } # The default configuration with compile at BEGIN on. method top_level_default() {} # Turn it off. use Method::Signatures { compile_at_BEGIN => 0 }; method top_level_off() {} # And on again. use Method::Signatures { compile_at_BEGIN => 1 }; method top_level_on() {} # Now turn it off inside a lexical scope { use Method::Signatures { compile_at_BEGIN => 0 }; method inner_scope_off() {} } # And it's restored. method outer_scope_on() {} # at compile-time, some should be defined and others shouldn't be BEGIN { method_defined('top_level_default'); method_undefined('top_level_off'); method_defined('top_level_on'); method_undefined('inner_scope_off'); method_defined('outer_scope_on'); } # by run-time, they should _all_ be defined method_defined('top_level_default'); method_defined('top_level_off'); method_defined('top_level_on'); method_defined('inner_scope_off'); method_defined('outer_scope_on'); done_testing; Method-Signatures-20160315/t/debugger.t000444001751000144 157312672114746 17340 0ustar00buddyusers000000000000#!/usr/bin/perl -w use Test::More 'no_plan'; TODO: { todo_skip "This is still totally hosed", 2; is eval { local $SIG{ALRM} = sub { die "Alarm!\n"; }; alarm 5; my $ret = qx{$^X "-Ilib" -le "package Foo; use Method::Signatures; method foo() { 42 } print Foo->foo()"}; alarm 0; $ret; }, "42\n", 'one-liner'; is $@, ''; } is eval { local $SIG{ALRM} = sub { die "Alarm!\n"; }; alarm 5; my $ret = qx{$^X "-Ilib" -MMethod::Signatures -le "package Foo; use Method::Signatures; method foo() { 42 } print Foo->foo()"}; alarm 0; $ret; }, "42\n", 'one liner with -MMethod::Signatures'; is $@, ''; is eval { local $SIG{ALRM} = sub { die "Alarm!\n"; }; local $ENV{PERLDB_OPTS} = 'NonStop'; alarm 5; my $ret = qx{$^X "-Ilib" -dw t/simple.plx}; alarm 0; $ret; }, "42", 'debugger'; is $@, ''; Method-Signatures-20160315/t/invocant.t000444001751000144 252112672114746 17367 0ustar00buddyusers000000000000#!/usr/bin/perl # Test that you can change the invocant. use strict; use warnings; use Test::More 'no_plan'; our $skip_no_invocants; { package Stuff; use Test::More; use Method::Signatures; sub new { bless {}, __PACKAGE__ } method bar($arg) { return ref $arg || $arg; } method invocant($class:) { $class->bar(0); } method with_arg($class: $arg) { $class->bar($arg); } method without_space($class:$arg) { $class->bar($arg); } method with_space_before_invocant( $class: $arg) { $class->bar($arg); } eval q{ method no_invocant_class_type(Foo::Bar $arg) { $self->bar($arg); } method no_invocant_named_param(Foo :$arg) { $self->bar($arg); } }; is $@, '', 'compiles without invocant'; } { package Foo; sub new { bless {}, __PACKAGE__ } } { package Foo::Bar; sub new { bless {}, __PACKAGE__ } } is( Stuff->invocant, 0 ); is( Stuff->with_arg(42), 42 ); is( Stuff->without_space(42), 42 ); is( Stuff->with_space_before_invocant(42), 42 ); my $stuff = Stuff->new; is( $stuff->no_invocant_class_type(Foo::Bar->new), 'Foo::Bar' ); is( $stuff->no_invocant_named_param(arg => Foo->new), 'Foo' ); Method-Signatures-20160315/t/override_nothing.t000444001751000144 34312672114746 21073 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use lib 't/lib'; use Test::More; use Test::Exception; use NoOverrides; func foo (Int $bar) {} lives_ok { foo(42) } 'calls succeed for subclass with no overrides'; done_testing; Method-Signatures-20160315/t/override_modifier_errors.t000444001751000144 165312672114746 22644 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use lib 't/lib'; use Test::More; use Test::Exception; SKIP: { eval { require MooseX::Declare } or skip "MooseX::Declare required for this test", 1; use_ok("OverrideModifierErrors"); my $obj = NewErrorSubclass->new; throws_ok { $obj->biff( ) } qr/override missing/, 'error okay: modifier / missing / method'; throws_ok { $obj->bamm( snork => 1 ) } qr/override extra/, 'error okay: modifier / extra / method'; throws_ok { $obj->boom( .5 ) } qr/override badtype/, 'error okay: modifier / bad type / method'; throws_ok { $obj->fee( ) } qr/override missing/, 'error okay: modifier / missing / around'; throws_ok { $obj->fie( snork => 1 ) } qr/override extra/, 'error okay: modifier / extra / around'; throws_ok { $obj->foe( .5 ) } qr/override badtype/, 'error okay: modifier / bad type / around'; } done_testing; Method-Signatures-20160315/t/caller.t000444001751000144 212612672114746 17011 0ustar00buddyusers000000000000#!/usr/bin/perl -w # Test that caller() works { package Foo; use Test::More 'no_plan'; use Method::Signatures; sub sub_caller { my($self, $level) = @_; #line 13 return caller($level); } sub sub_caller2 { my($self, $level) = @_; #line 20 return $self->sub_caller($level); } method method_caller($level) { #line 13 return caller($level); } method method_caller2($level) { #line 20 return $self->method_caller($level); } #line 36 my @expected = Foo->sub_caller2(0); my @expected2 = Foo->sub_caller2(1); #line 36 my @have = Foo->method_caller2(0); my @have2 = Foo->method_caller2(1); $expected[3] = 'Foo::method_caller'; $expected2[3] = 'Foo::method_caller2'; is_deeply([@have[0..7]], [@expected[0..7]]); is_deeply([@have2[0..7]], [@expected2[0..7]]); # hints and bitmask change and are twitchy so I'm just going to # check that they're there. isnt $have[8], undef; isnt $have2[8], undef; isnt $have[9], undef; isnt $have2[9], undef; } Method-Signatures-20160315/t/named.t000444001751000144 256012672114746 16635 0ustar00buddyusers000000000000#!/usr/bin/perl -w use strict; use Test::More; { package Foo; use lib 't/lib'; use GenErrorRegex qw< required_error named_param_error >; use Test::More; use Test::Exception; use Method::Signatures; method formalize($text! is ro, :$justify is ro = "left", :$case) { my %params; $params{text} = $text; $params{justify} = $justify; $params{case} = $case if defined $case; return \%params; } ::is_deeply( Foo->formalize( "stuff" ), { text => "stuff", justify => "left" } ); #line 24 throws_ok { Foo->formalize( "stuff", wibble => 23 ) } named_param_error('Foo', wibble => 'formalize', LINE => 24), 'simple named parameter error okay'; method foo( :$arg! ) { return $arg; } is( Foo->foo( arg => 42 ), 42 ); #line 30 throws_ok { foo() } required_error('Foo', '$arg', 'foo', LINE => 30), 'simple named parameter error okay'; eval q{ method wrong( :$named, $pos ) {} }; like $@, qr/positional parameter .* after named param/i; eval q{ method wrong( $foo, :$named, $bar ) {} }; like $@, qr/positional parameter .* after named param/i; eval q{ method wrong( $foo, $bar?, :$named ) {} }; like $@, qr/named parameter .* mixed with optional positional/i; } done_testing(); Method-Signatures-20160315/t/larna.t000444001751000144 67012672114746 16626 0ustar00buddyusers000000000000 use strict; use warnings; use Test::More; use Method::Signatures; { my $a; ok eval q{ $a = [ func () {}, 1 ]; 1 }, 'anonymous function in list is okay' or diag "eval error: $@"; is ref $a->[0], "CODE"; is $a->[1], 1; } { my $a; ok eval q{ $a = [ method () {}, 1 ]; 1 }, 'anonymous method in list is okay' or diag "eval error: $@"; is ref $a->[0], "CODE"; is $a->[1], 1; } done_testing; Method-Signatures-20160315/t/typeload_notypes.t000444001751000144 126412672114746 21153 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; { package Foo::Bar; use strict; use warnings; use Method::Signatures; method new ($class:) { bless {}, $class; } # not using a type here, so we won't expect Moose to get loaded method foo1 ($bar) {}; } my $foobar = Foo::Bar->new; # at this point, Moose should not be loaded is $INC{'Moose/Util/TypeConstraints.pm'}, undef, 'no type checking module loaded before method call'; $foobar->foo1(42); # _still_ should have no Moose because we haven't requested any type checking is $INC{'Moose/Util/TypeConstraints.pm'}, undef, 'no type checking module loaded before method call'; done_testing; Method-Signatures-20160315/t/func.t000444001751000144 24612672114746 16463 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use Test::More tests => 1; use Method::Signatures; func echo($arg) { return $arg; } is echo(42), 42, "basic func"; Method-Signatures-20160315/t/method.t000444001751000144 261712672114746 17034 0ustar00buddyusers000000000000#!/usr/bin/perl -w use strict; use Test::More 'no_plan'; { package Foo; use Method::Signatures; method new (%args) { return bless {%args}, $self; } method set ($key, $val) { return $self->{$key} = $val; } method get ($key) { return $self->{$key}; } method no_proto { return($self, @_); } method empty_proto() { return($self, @_); } method echo(@_) { return($self, @_); } method caller($height = 0) { return (CORE::caller($height))[0..2]; } #line 39 method warn($foo?) { my $warning = ''; local $SIG{__WARN__} = sub { $warning = join '', @_; }; CORE::warn "Testing warn"; return $warning; } # Method with the same name as a loaded class. method strict () { 42 } } my $obj = Foo->new( foo => 42, bar => 23 ); isa_ok $obj, "Foo"; is $obj->get("foo"), 42; is $obj->get("bar"), 23; $obj->set(foo => 99); is $obj->get("foo"), 99; for my $method (qw(no_proto empty_proto)) { is_deeply [$obj->$method], [$obj]; ok !eval { $obj->$method(23); 1 }; like $@, qr{\Q$method(), was given too many arguments; it expects 0}; } is_deeply [$obj->echo(1,2,3)], [$obj,1,2,3], "echo"; is_deeply [$obj->caller], [__PACKAGE__, $0, __LINE__], 'caller works'; is $obj->warn, "Testing warn at $0 line 42.\n"; is eval { $obj->strict }, 42; Method-Signatures-20160315/t/yadayada.t000444001751000144 503012672114746 17321 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Warn; use Test::Exception; use Method::Signatures; plan tests => 4; subtest 'yada after positional' => sub { plan tests => 2; func yada_after_positional ($pos1, $pos2, ...) { subtest @_ . ' args' => sub { is $pos1, 'pos1' => '$pos1 okay'; is $pos2, 'pos2' => '$pos2 okay'; done_testing; # for Test::More's before 0.96 }; return 1; } yada_after_positional('pos1', 'pos2', 'pos3', named => 'named'); yada_after_positional('pos1', 'pos2', 'pos3', named => 'named', other => 'other'); }; subtest 'yada after named' => sub { plan tests => 2; func yada_after_named (:$named1, :$named2, ...) { subtest @_ . ' args' => sub { is $named1, 'named1' => '$named1 okay'; is $named2, 'named2' => '$named2 okay'; done_testing; # for Test::More's before 0.96 }; return 1; } yada_after_named(named2 => 'named2', named1 => 'named1'); yada_after_named(named2 => 'named2', named1 => 'named1', other => 'other'); }; subtest 'yada after both' => sub { plan tests => 2; func yada_after_both ($pos1, $pos2, :$named1, :$named2, ...) { subtest @_ . ' args' => sub { is $pos1, 'pos1' => '$pos1 okay'; is $pos2, 'pos2' => '$pos2 okay'; is $named1, 'named1' => '$named1 okay'; is $named2, 'named2' => '$named2 okay'; done_testing; # for Test::More's before 0.96 }; return 1; } yada_after_named('pos1', 'pos2', named2 => 'named2', named1 => 'named1'); yada_after_named('pos1', 'pos2', named2 => 'named2', named1 => 'named1', other => 'other'); }; subtest 'non-yada' => sub { plan tests => 2; func non_yada ($pos1, $pos2, :$named1, :$named2) { subtest @_ . ' args' => sub { is $pos1, 'pos1' => '$pos1 okay'; is $pos2, 'pos2' => '$pos2 okay'; is $named1, 'named1' => '$named1 okay'; is $named2, 'named2' => '$named2 okay'; done_testing; # for Test::More's before 0.96 }; return 1; } non_yada('pos1', 'pos2', named2 => 'named2', named1 => 'named1'); ok !eval{ non_yada('pos1', 'pos2', named2 => 'named2', named1 => 'named1', other => 'other') } => 'Extra args rejected'; }; Method-Signatures-20160315/t/undef_defaults.t000444001751000144 417112672114746 20541 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; # Skip the test before Method::Signatures can try to compile it and blow up. BEGIN { plan skip_all => "Perl 5.10 or higher required to test where constraints" if $] < 5.010; } { package Stuff; use Test::More; use Method::Signatures; method add($this = 23 when undef, $that = 42 when undef) { return $this + $that; } method minus(Int|Str|Any $this is ro = 23 when undef, $that is ro = 42 when undef) { return $this - $that; } is( Stuff->add(), 23 + 42 ); is( Stuff->add(undef), 23 + 42 ); is( Stuff->add(99), 99 + 42 ); is( Stuff->add(2,3), 5 ); is( Stuff->minus(), 23 - 42 ); is( Stuff->minus(undef), 23 - 42 ); is( Stuff->minus(99), 99 - 42 ); is( Stuff->minus(2, 3), 2 - 3 ); # Test again that undef doesn't override defaults method echo($message = "what?" when undef) { return $message } is( Stuff->echo(), "what?" ); is( Stuff->echo(undef), "what?" ); is( Stuff->echo("who?"), 'who?' ); # Test that you can reference earlier args in a default method copy_cat($this, $that = $this when undef) { return $that; } is( Stuff->copy_cat("wibble"), "wibble" ); is( Stuff->copy_cat("wibble", undef), "wibble" ); is( Stuff->copy_cat(23, 42), 42 ); } { package Bar; use Test::More; use Method::Signatures; method hello($msg = "Hello, world!" when undef) { return $msg; } is( Bar->hello, "Hello, world!" ); is( Bar->hello(undef), "Hello, world!" ); is( Bar->hello("Greetings!"), "Greetings!" ); method hi($msg = q,Hi, when undef) { return $msg; } is( Bar->hi, "Hi" ); is( Bar->hi(undef), "Hi" ); is( Bar->hi("Yo"), "Yo" ); method list(@args = (1,2,3) when ()) { return @args; } is_deeply [Bar->list()], [1,2,3]; method code($num, $code = sub { $num + 2 } when undef) { return $code->(); } is( Bar->code(42), 44 ); } done_testing; Method-Signatures-20160315/t/role_check_moose.t000444001751000144 130512672114746 21045 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use lib 't/lib'; use GenErrorRegex qw< badval_error >; use Test::More; use Test::Exception; { package Foo::Bar; sub new { bless {}, __PACKAGE__; } } SKIP: { eval { require Moose } or skip "Moose required for testing Moose roles", 2; require MooseRoleTest; use Method::Signatures; my $moose = WithMooseRole->new; my $foobar = Foo::Bar->new; func moosey (MooseRole $foo) {} # positive test lives_ok { moosey($moose) } 'Moose role passes okay'; # negative test throws_ok { moosey($foobar) } badval_error(undef, foo => MooseRole => $foobar, 'moosey'), 'Moose role fails when appropriate'; } done_testing; Method-Signatures-20160315/t/defaults.t000444001751000144 436612672114746 17366 0ustar00buddyusers000000000000#!/usr/bin/perl -w use strict; use warnings; use Test::More; { package Stuff; use Test::More; use Method::Signatures; method add($this = 23, $that = 42) { return $this + $that; } method minus($this is ro = 23, $that is ro = 42) { return $this - $that; } is( Stuff->add(), 23 + 42 ); is( Stuff->add(99), 99 + 42 ); is( Stuff->add(2,3), 5 ); is( Stuff->minus(), 23 - 42 ); is( Stuff->minus(99), 99 - 42 ); is( Stuff->minus(2, 3), 2 - 3 ); # Test that undef overrides defaults method echo($message = "what?") { return $message } is( Stuff->echo(), "what?" ); is( Stuff->echo(undef), undef ); is( Stuff->echo("who?"), 'who?' ); # Test that you can reference earlier args in a default method copy_cat($this, $that = $this) { return $that; } is( Stuff->copy_cat("wibble"), "wibble" ); is( Stuff->copy_cat(23, 42), 42 ); } { package Bar; use Test::More; use Method::Signatures; method hello($msg = "Hello, world!") { return $msg; } is( Bar->hello, "Hello, world!" ); is( Bar->hello("Greetings!"), "Greetings!" ); method hi($msg = q,Hi,) { return $msg; } is( Bar->hi, "Hi" ); is( Bar->hi("Yo"), "Yo" ); method list(@args = (1,2,3)) { return @args; } is_deeply [Bar->list()], [1,2,3]; method code($num, $code = sub { $num + 2 }) { return $code->(); } is( Bar->code(42), 44 ); } note "Defaults are type checked"; { package Biff; use Test::More; use Method::Signatures; func hi( Object $place = "World" ) { return "Hi, $place!\n"; } ok !eval { hi() }; like $@, qr/the 'place' parameter \("World"\) is not of type Object/; } note "Multi-line defaults"; { package Whatever; use Method::Signatures; use Test::More; func stuff( $arg = { foo => 23, bar => 42 } ) { return $arg->{foo}; } is( stuff(), 23 ); func things( $arg = "Hello There" ) { return $arg; } is( things(), "Hello\nThere" ); } done_testing; Method-Signatures-20160315/t/named_alias.t000444001751000144 62312672114746 17764 0ustar00buddyusers000000000000#!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { plan skip_all => "Data::Alias not available" unless eval { require Data::Alias }; plan 'no_plan'; } { package Stuff; use Test::More; use Method::Signatures; method add_meaning(:$arg is alias) { $arg += 42; } my $life = 23; Stuff->add_meaning(arg => $life); is $life, 23 + 42; } Method-Signatures-20160315/t/refs.t000444001751000144 305112672114746 16504 0ustar00buddyusers000000000000#!/usr/bin/perl -w use strict; use warnings; use lib 't/lib'; use Dev::Null; use Test::More; BEGIN { plan skip_all => "Data::Alias not available" unless eval { require Data::Alias }; plan 'no_plan'; } # Test a basic alias. { package Foo; use Test::More; use Method::Signatures; method add_one_to_each(\@args) { $_++ for @args; return @args; } my @input = (1,2,3); is_deeply [Foo->add_one_to_each(\@input)], [2,3,4]; is_deeply \@input, [2,3,4]; tie *STDERR, "Dev::Null"; ok !eval q[@args; 1;], '\@args does not leak out of subroutine'; untie *STDERR; } # Try to break the aliasing prototype { package Bar; use Test::More; use Method::Signatures; method break_args($foo, \@bar, \%baz, $num, \$biff, @rest) { return { foo => $foo, bar => \@bar, baz => \%baz, num => $num, biff => $biff, rest => \@rest } } is_deeply( Bar->break_args(1, [2,3], {4 => 5}, 6, \7, (8,9)), { foo => 1, bar => [2,3], baz => {4 => 5}, num => 6, biff => 7, rest => [8,9] } ); } # What about closures? { package Stuff; use Method::Signatures; method make_closure(\@nums) { return sub { return @nums; }; } my $closure1 = Stuff->make_closure([1,2,3]); my $closure2 = Stuff->make_closure([4,5,6]); ::is_deeply [$closure1->()], [1,2,3]; ::is_deeply [$closure2->()], [4,5,6]; } Method-Signatures-20160315/t/optional.t000444001751000144 244312672114746 17376 0ustar00buddyusers000000000000#!/usr/bin/perl -w # Test the $arg? optional syntax. use strict; use warnings; use Test::More; { package Stuff; use Test::More; use Test::Exception; use Method::Signatures; method whatever($this?) { return $this; } is( Stuff->whatever(23), 23 ); method things($this? = 99) { return $this; } is( Stuff->things(), 99 ); method some_optional($that, $this?) { return $that + ($this || 0); } is( Stuff->some_optional(18, 22), 18 + 22 ); is( Stuff->some_optional(18), 18 ); # are named parameters optional by default? method named_params(:$this, :$that) {} lives_ok { Stuff->named_params(this => 0) } 'can leave out some named params'; lives_ok { Stuff->named_params( ) } 'can leave out all named params'; # are slurpy parameters optional by default? # (throwing in a default just for a little feature interaction test) method slurpy_param($this, $that = 0, @other) {} my @a = (); lives_ok { Stuff->slurpy_param(0, 0, @a) } 'can pass empty array to slurpy param'; lives_ok { Stuff->slurpy_param(0, 0 ) } 'can omit slurpy param altogether'; lives_ok { Stuff->slurpy_param(0 ) } 'can omit other optional params as well as slurpy param'; } done_testing; Method-Signatures-20160315/t/error_reporting.t000444001751000144 2133412672114746 21013 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use lib 't/lib'; use GenErrorRegex; # error-generating subs imported below use Test::More; use Test::Exception; # This test file is all about making sure that errors are reported at the right places. That is, # when you make a compile-time mistake, we should report the error at the place where you declare # the method, and when you make a run-time mistake, we should report it at the place where you # _call_ the method, not in the method itself, or (even worse) somewhere deep inside # Method::Signatures. # # The errors we're concerned about are: # # *) The error thrown when you fail to pass a required argument. # *) The error thrown when you pass a named argument that was not declared. # *) The error thrown when you try to pass a type that is unrecognized. # *) The error thrown when you try to pass an argument of the wrong type. # # This is mildly tricky, since trapping the error to check it means the error could end up reported # as being in "eval 27" or somesuch. So we're going to use a few different layers of files that # include each other to work around that for the run-time errors. For the compile-time errors, # we'll just call require instead of use. # # Ready? Here we go. my %compile_time_errors = ( BadParameter => { error_gen => 'bad_param_error', error_args => [ '&$bar', ], test_name => 'illegal param spec reports correctly', }, TrailingGarbage => { error_gen => 'unexpected_after_error', error_args => [ '&', ], test_name => 'trailing code after param reports correctly', }, NamedAfterOptPos => { error_gen => 'named_after_optpos_error', error_args => [ '$baz', '$bar', ], test_name => 'named param following optional positional reports correctly', }, PosAfterNamed => { error_gen => 'pos_after_named_error', error_args => [ '$baz', '$bar', ], test_name => 'positional param following named reports correctly', }, MispositionedSlurpy => { error_gen => 'mispositioned_slurpy_error', error_args => [ '@bar', ], test_name => 'mispositioned slurpy param reports correctly', }, MultipleSlurpy => { error_gen => 'multiple_slurpy_error', error_args => [ ], test_name => 'multiple slurpy params reports correctly', }, NamedSlurpy => { error_gen => 'named_slurpy_error', error_args => [ '@bar', ], test_name => 'named slurpy param reports correctly', }, RequiredAfterOpt => { error_gen => 'required_after_optional_error', error_args => [ '$baz', '$bar', ], test_name => 'required param after an optional param', }, ); my %run_time_errors = ( MissingRequired => { method => 'bar', error_gen => 'required_error', error_args => [ 'InnerMissingRequired', '$bar', 'foo', ], test_name => 'missing required param reports correctly', }, NoSuchNamed => { method => 'bar', error_gen => 'named_param_error', error_args => [ 'InnerNoSuchNamed', 'bmoogle', 'foo', ], test_name => 'no such named param reports correctly', }, UnknownType => { method => 'bar', error_gen => 'badtype_error', error_args => [ 'InnerUnknownType', 'Foo::Bmoogle', 'perhaps you forgot to load it?', 'foo', ], test_name => 'unrecognized type reports correctly', }, BadType => { method => 'bar', error_gen => 'badval_error', error_args => [ 'InnerBadType', 'bar', 'Int', 'thing', 'foo', ], test_name => 'incorrect type reports correctly', }, ); # this is *much* easier (and less error-prone) than having to update the import list manually up top GenErrorRegex->import( map { $_->{error_gen} } values %compile_time_errors, values %run_time_errors ); while (my ($testclass, $test) = each %compile_time_errors) { (my $testmod = "$testclass.pm") =~ s{::}{/}g; no strict 'refs'; throws_ok { require $testmod } $test->{error_gen}->(@{$test->{error_args}}, FILE => "t/lib/$testmod", LINE => 1133), $test->{test_name}; } while (my ($testclass, $test) = each %run_time_errors) { (my $testmod = "$testclass.pm") =~ s{::}{/}g; no strict 'refs'; lives_ok { require $testmod } "$testclass loads correctly"; throws_ok { &{ $testclass . '::' . $test->{method} }->() } $test->{error_gen}->(@{$test->{error_args}}, FILE => "t/lib/$testmod", LINE => 1133), $test->{test_name}; } # modifiers bad type value checks (handled a bit differently than those above) SKIP: { eval { require MooseX::Declare } or skip "MooseX::Declare required for this test", 1; # different modifiers will throw different types in their errors my %bad_types = ( before => 'Int', around => 'Int', after => 'Num', override => 'Int', augment => 'Num', ); lives_ok { require ModifierBadType } 'incorrect type loads correctly'; foreach ( qw< before around after override augment > ) { my $test_meth = "test_$_"; my $error_args = [ 'Foo::Bar', num => $bad_types{$_} => 'thing', $test_meth, ]; throws_ok{ ModifierBadType::bar($test_meth) } badval_error(@$error_args, FILE => 't/lib/ModifierBadType.pm', LINE => 1133), "incorrect type for $_ modifier reports correctly"; } } done_testing; Method-Signatures-20160315/t/syntax_errors.t000444001751000144 57712672114746 20461 0ustar00buddyusers000000000000#!perl use strict; use warnings; use lib 't/lib'; use Test::More; use Carp (); ok !eval { require Bad }; TODO: { local $TODO = "The user should see the actual syntax error"; like $@, qr{^Global symbol "\$info" requires explicit package name}ms; like($@, qr{^PPI failed to find statement for '\$bar'}ms, 'Bad syntax generates stack trace'); } done_testing(); Method-Signatures-20160315/t/odd_number.t000444001751000144 112412672114746 17662 0ustar00buddyusers000000000000#!/usr/bin/perl -w package Foo; use strict; use Test::Warn; use Test::More 'no_plan'; use Method::Signatures; method foo(:$name, :$value) { return $name, $value; } TODO: { # Test::Warn is having issues with $TODO. Test::More->builder->todo_start("Odd number of elements should happen at the caller"); #line 20 my @result; warning_like { @result = Foo->foo(name => 42, value =>); } qr/^Odd number of elements in hash assignment at \Q$0\E line 22.$/; Test::More->builder->todo_end; # Or should it be an error? is_deeply \@result, [42, undef]; } Method-Signatures-20160315/t/alias.t000444001751000144 61212672114746 16616 0ustar00buddyusers000000000000#!/usr/bin/perl -w use strict; use warnings; use Test::More; BEGIN { plan skip_all => "Data::Alias not available" unless eval { require Data::Alias }; plan 'no_plan'; } { package Stuff; use Test::More; use Method::Signatures; method add_meaning($arg is alias) { $arg += 42; } my $life = 23; Stuff->add_meaning($life); is $life, 23 + 42; } Method-Signatures-20160315/t/types.t000444001751000144 264712672114746 16723 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Method::Signatures; note "types"; { my %tests = ( q[Foo $bar] => [positional => "Foo"], q[$bar] => [positional => undef], q[type $bar, Some::Type @this] => [positional => "type", "Some::Type"], q[RFC1234::Foo::bar32 $var] => [positional => "RFC1234::Foo::bar32"], q[Foo :$var] => [named => "Foo"], q[Foo::Bar $var] => [positional => "Foo::Bar"], ); for my $proto (keys %tests) { my $want = $tests{$proto}; my $ms = Method::Signatures->new; $ms->parse_proto($proto); my $which = shift @$want; for my $idx (0..$#{$want}) { my $method = $which.'_parameters'; is $ms->{signature}->$method->[$idx]->type, $want->[$idx] || ''; } } } note "inject_for_type_check"; { { package My::MS; use base "Method::Signatures"; sub inject_for_type_check { my $self = shift; my $sig = shift; my $var = $sig->variable; return "type_check('$var');"; } } my $ms = My::MS->new; my $code = $ms->parse_proto( 'Foo $this, :$bar, Foo::Bar :$foobar' ); like $code, qr{type_check\('\$this'\)}; like $code, qr{type_check\('\$foobar'\)}; } done_testing; Method-Signatures-20160315/t/before_510.t000444001751000144 217612672114746 17403 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; plan skip_all => "This only applies to Perls before 5.10" if $] >= 5.010; use Method::Signatures; { eval q{ func neg_and_odd_and_prime ($x where [0..10]) { return 1; } }; like $@, qr{\Q'where' constraint only available under Perl 5.10 or later.\E}, "Perls <5.10 properly error out on where constraints"; } { eval q{ package Stuff; use Method::Signatures; method add($this //= 23, $that //= 42) { return $this + $that; } }; like $@, qr{\Q'//=' defaults only available under Perl 5.10 or later.\E}, "Perls <5.10 properly error out on //= declaration"; } { eval q{ package Stuff; use Method::Signatures; method add($this = 23 when '', $that = 42 when '') { no warnings 'uninitialized'; return $this + $that; } }; like $@, qr{\Q'when' modifier on default only available under Perl 5.10 or later.\E}, "Perls <5.10 properly error out on 'when' conditions"; } done_testing; Method-Signatures-20160315/t/paren_plus_open_block.t000444001751000144 26512672114746 22074 0ustar00buddyusers000000000000#!/usr/bin/perl -w use strict; use warnings; package Foo; use Test::More "no_plan"; use Method::Signatures; method foo( $arg ) { return $arg } is( Foo->foo(23), 23 ); Method-Signatures-20160315/t/typeload_moose.t000444001751000144 177012672114746 20576 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use lib 't/lib'; use GenErrorRegex qw< badval_error >; use Test::More; use Test::Exception; SKIP: { eval { require Moose } or skip "Moose required for testing Moose types", 1; require MooseLoadTest; my $foobar = Foo::Bar->new; # can't check for type module not being loaded here, because Moose will drag it in $foobar->check_int(42); # now we should have loaded Moose to do our type checking like $INC{'Moose/Util/TypeConstraints.pm'}, qr{Moose/Util/TypeConstraints\.pm$}, 'loaded Moose'; # tests for ScalarRef[X] have to live here, because they only work with Moose my $method = 'check_paramized_sref'; my $bad_ref = \'thing'; lives_ok { $foobar->$method(\42) } 'call with good value for paramized_sref passes'; throws_ok { $foobar->$method($bad_ref) } badval_error($foobar, bar => 'ScalarRef[Num]' => $bad_ref, $method), 'call with bad value for paramized_sref dies'; } done_testing; Method-Signatures-20160315/t/override_errors.t000444001751000144 137512672114746 20767 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use lib 't/lib'; use Test::More; use Test::Exception; use OverrideErrors { compile_at_BEGIN => 0 }; func biff ( $bar) {} func bamm ( :$bar) {} func boom (Int $bar) {} throws_ok { biff( ) } qr/you suck!/, 'required param missing from overridden errors'; throws_ok { bamm( snork => 1 ) } qr/and yo mama's ugly, too/, 'no such named param from overridden errors'; throws_ok { boom( .5 ) } qr/she got a wooden leg with a kickstand/, 'value of wrong type from overridden errors'; # make sure our subclass is getting skipped properly throws_ok { biff() } qr/^In call to main::biff.*$0 line/, 'subclassing reports errors from proper place'; done_testing; Method-Signatures-20160315/t/one_line.t000444001751000144 24112672114746 17313 0ustar00buddyusers000000000000#!/usr/bin/perl -w use Test::More tests => 1; { package Thing; use Method::Signatures; method foo {"wibble"} ::is( Thing->foo, "wibble" ); } Method-Signatures-20160315/t/type_req_opt.t000444001751000144 173512672114746 20266 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Exception; { package TypeCheck::RequiredOptional; use strict; use warnings; use Method::Signatures; method new ($class:) { bless {}, $class; } method required_named ( Int :$foo! ) {} method optional_named ( Int :$foo ) {} method required_positional ( Int $foo ) {} method optional_positional ( Int $foo? ) {} } our $tester = TypeCheck::RequiredOptional->new; lives_ok { $tester->optional_named() } 'no type error when failing to pass optional named arg'; lives_ok { $tester->optional_positional() } 'no type error when failing to pass optional positional arg'; throws_ok { $tester->required_named() } qr/missing required argument/, 'proper error when failing to pass required named arg'; throws_ok { $tester->required_positional() } qr/missing required argument/, 'proper error when failing to pass required positional arg'; done_testing; Method-Signatures-20160315/t/ro.t000444001751000144 64212672114746 16150 0ustar00buddyusers000000000000#!/usr/bin/perl -w use strict; use warnings; use Test::More 'no_plan'; { package Stuff; use Test::More; use Method::Signatures; method echo($arg is ro) { return $arg; } #line 19 method naughty($arg is ro) { $arg++ } is( Stuff->echo(42), 42 ); ok !eval { Stuff->naughty(23) }; like $@, qr/^Modification of a read-only value attempted at \Q$0\E line 20/; } Method-Signatures-20160315/t/typeload_nomoose.t000444001751000144 110612672114746 21124 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; { package Foo::Bar; use strict; use warnings; use Method::Signatures; method new ($class:) { bless {}, $class; } method foo1 (Int $bar) {}; } my $foobar = Foo::Bar->new; # at this point, Moose should not be loaded (yet) is $INC{'Moose/Util/TypeConstraints.pm'}, undef, 'no type checking module loaded before method call'; $foobar->foo1(42); # now we should have loaded Mouse to do our type checking is $INC{'Moose/Util/TypeConstraints.pm'}, undef, "didn't load Moose"; done_testing; Method-Signatures-20160315/t/array_param.t000555001751000144 125512672114746 20052 0ustar00buddyusers000000000000#!/usr/bin/perl -w use strict; use warnings; use Test::More tests => 3; { package Bla; use Test::More; use Method::Signatures; method new ($class:) { bless {}, $class; } method array_param_at_end ($a, $b, @c) { return "$a|$b|@c"; } eval q{ method two_array_params ($a, @b, @c) {} }; like($@, qr{signature can only have one slurpy parameter}i, "Two array params"); eval q{ method two_slurpy_params ($a, %b, $c, @d, $e) {} }; like($@, qr{signature can only have one slurpy parameter}i, "Two slurpy params"); } is(Bla->new->array_param_at_end(1, 2, 3, 4), "1|2|3 4", "Array parameter at end"); Method-Signatures-20160315/t/into.t000444001751000144 36412672114746 16502 0ustar00buddyusers000000000000#!/usr/bin/perl -w # It should be possible to import into another package. package Foo; use Test::More 'no_plan'; { package Bar; use Method::Signatures { into => 'Foo' }; } is( Foo->foo(42), 42 ); method foo ($arg) { return $arg; } Method-Signatures-20160315/t/override_typecheck.t000444001751000144 32112672114746 21400 0ustar00buddyusers000000000000#!/usr/bin/perl use strict; use warnings; use lib 't/lib'; use Test::More; use Test::Warn; use OverrideTypeCheck; func foo (Int $bar) {} warning_is{ foo(42) } 'in overridden type_check'; done_testing; Method-Signatures-20160315/t/required.t000444001751000144 150512672114746 17367 0ustar00buddyusers000000000000#!/usr/bin/perl -w # Test the $arg! required syntax use strict; use warnings; use Test::More; { package Stuff; use lib 't/lib'; use GenErrorRegex qw< required_error >; use Test::More; use Test::Exception; use Method::Signatures; method whatever($this!) { return $this; } is( Stuff->whatever(23), 23 ); #line 23 throws_ok { Stuff->whatever() } required_error('Stuff', '$this', 'whatever', LINE => 23), 'simple required param error okay'; method some_optional($that!, $this = 22) { return $that + $this } is( Stuff->some_optional(18), 18 + 22 ); #line 33 throws_ok { Stuff->some_optional() } required_error('Stuff', '$that', 'some_optional', LINE => 33), 'some required/some not required param error okay'; } done_testing(); Method-Signatures-20160315/t/mxd-replace.t000444001751000144 174712672114746 17760 0ustar00buddyusers000000000000 use Test::More; use Test::Exception; use lib 't/lib'; use GenErrorRegex qw< badval_error badtype_error >; # First test: try the method where you load MXD, then load MSM, which inserts itself into MXD # and replaces MXMS. SKIP: { eval { require MooseX::Declare } or skip "MooseX::Declare required for this test", 1; # have to require here or else we try to load MXD before we check for it not being there (above) require MS_MXD_Replace or die("can't load test module: $@"); MS_MXD_Replace->import; my $foo = Foo->new; my $foobar = Foo::Bar->new; foreach ( qw< before after around override augment > ) { my $method = "test_$_"; throws_ok { $foo->$method('bmoogle') } badval_error($foo, num => Num => 'bmoogle' => $method), "MXD using MS for method ($_)"; throws_ok { $foobar->$method(.5) } badval_error($foobar, num => Int => .5 => $method), "MXD using MSM for modifier ($_)"; } } done_testing(); Method-Signatures-20160315/t/mxd-sub.t000444001751000144 307512672114746 17132 0ustar00buddyusers000000000000 use Test::More; use Test::Exception; use lib 't/lib'; use GenErrorRegex qw< badval_error badtype_error >; # This time we'll try the method where you subclass MXD and then use MSM inside your subclass. # Then you can just your subclass instead of MXD. # Note that this code is nearly identical to t/mxd-replace.t. However, you can't put them in the # same file, or else whichever one runs first will replace MXMS for the whole program, which # invalidates the testing of the second one. Possibly they could be combined if we shelled out to # separate Perl instances (Test::Command is good for that sort of thing). But I'm not sure it's # worth dragging in the extra testing dependency (and possibly obscuring the test code) at this # point. If we add a third method for using MSM, that would probably make it worthwhile to do. SKIP: { eval { require MooseX::Declare } or skip "MooseX::Declare required for this test", 1; # have to require here or else we try to load MXD before we check for it not being there (above) require MS_MXD_Sub or die("can't load test module: $@"); MS_MXD_Sub->import; $foo = Foo2->new; $foobar = Foo2::Bar->new; foreach ( qw< before after around override augment > ) { my $method = "test_$_"; throws_ok { $foo->$method('bmoogle') } badval_error($foo, num => Num => 'bmoogle' => $method), "MXD using MS for method ($_)"; throws_ok { $foobar->$method(.5) } badval_error($foobar, num => Int => .5 => $method), "MXD using MSM for modifier ($_)"; } } done_testing(); Method-Signatures-20160315/t/lib000755001751000144 012672114746 15772 5ustar00buddyusers000000000000Method-Signatures-20160315/t/lib/BarfyDie.pm000444001751000144 112612672114746 20152 0ustar00buddyusers000000000000# For use with t/error_interruption.t package BarfyDie; use strict; use warnings; use Method::Signatures; # This _should_ produce a simple error like the following: # Global symbol "$foo" requires explicit package name at t/lib/BarfyDie.pm line 13. $foo = 'hi!'; # And, without the signature below, it would. # For that matter, if you compile this by itself, it still does. # However, when you require this file from inside an eval, Method::Signature's parser() method will # eat the error unless we localize $@ there. So this verifies that we're doing that. method foo (Str $bar) { } 1; Method-Signatures-20160315/t/lib/RequiredAfterOpt.pm000444001751000144 43512672114746 21674 0ustar00buddyusers000000000000package RequiredAfterOpt; use strict; use warnings; use Method::Signatures; # the #line directive helps us guarantee that we'll always know what line number to expect the error # on, regardless of how much this test module changes #line 1133 func foo ( $foo, $bar?, $baz ) {} 1; Method-Signatures-20160315/t/lib/ModifierBadType.pm000444001751000144 61712672114746 21460 0ustar00buddyusers000000000000package ModifierBadType; use strict; use warnings; # reusing this from t/mxd-replace.t use MS_MXD_Replace; sub bar { my ($meth) = @_; my $foobar = Foo::Bar->new; no strict 'refs'; # the #line directive helps us guarantee that we'll always know what line number to expect the error # on, regardless of how much this test module changes #line 1133 $foobar->$meth('thing'); } 1; Method-Signatures-20160315/t/lib/NamedSlurpy.pm000444001751000144 41412672114746 20707 0ustar00buddyusers000000000000package NamedSlurpy; use strict; use warnings; use Method::Signatures; # the #line directive helps us guarantee that we'll always know what line number to expect the error # on, regardless of how much this test module changes #line 1133 func foo ( :@bar ) {} 1; Method-Signatures-20160315/t/lib/OverrideErrors.pm000444001751000144 67312672114746 21427 0ustar00buddyusers000000000000# package for t/override_errors.t package OverrideErrors; use base qw< Method::Signatures >; sub required_arg { my ($class, $var) = @_; $class->signature_error("you suck!"); } sub named_param_error { my ($class, $args) = @_; $class->signature_error("and yo mama's ugly, too"); } sub type_error { my ($class, $type, $value, $name) = @_; $class->signature_error("she got a wooden leg with a kickstand"); } 1; Method-Signatures-20160315/t/lib/MS_MXD_Replace.pm000444001751000144 174112672114746 21152 0ustar00buddyusers000000000000# used by t/mxd-replace.t # also used by t/error_reporting.t use MooseX::Declare; use Method::Signatures::Modifiers; class Foo { method test_before (Num $num) {} method test_around (Num $num) {} method test_after (Num $num) {} method test_override (Num $num) {} method test_augment (Num $num) { inner($num); } } # Obviously, it's not a very good idea to change the parameter types for before, after, or augment # modifiers. (Changing the parameter type for around is okay, and changing it for override is more # of an academic/philosophical point.) However, doing this allows us to test that MXMS is being # replaced by MSM by looking at the error messages. class Foo::Bar extends Foo { before test_before (Int $num) {} around test_around (Int $num) { $self->$orig($num / 2); } after test_after (Int $num) {} override test_override (Int $num) { return super; } augment test_augment (Int $num) {} } 1; Method-Signatures-20160315/t/lib/BasicRoleTest.pm000444001751000144 40512672114746 21147 0ustar00buddyusers000000000000# package for t/role_check_basic.t # the role { package BasicRole; use Role::Basic; } # a class that composes the role { package WithBasicRole; use Role::Basic 'with'; with 'BasicRole'; sub new { bless {}, __PACKAGE__; } } 1; Method-Signatures-20160315/t/lib/MooseLoadTest.pm000444001751000144 35712672114746 21174 0ustar00buddyusers000000000000# package for t/typeload_moose.t # (see comments there for why check_paramized_sref is here) package Foo::Bar; use Moose; use Method::Signatures; method check_int (Int $bar) {}; method check_paramized_sref (ScalarRef[Num] $bar) {}; 1; Method-Signatures-20160315/t/lib/Bad.pm000444001751000144 26512672114746 17136 0ustar00buddyusers000000000000package Bad; use strict; use warnings; use Method::Signatures; ## $info->{} should be $info{} method meth1 ($foo) { my %info; $info->{xpto} = 1; } method meth2 ($bar) {} 1; Method-Signatures-20160315/t/lib/NamedAfterOptPos.pm000444001751000144 43012672114746 21615 0ustar00buddyusers000000000000package NamedAfterOptPos; use strict; use warnings; use Method::Signatures; # the #line directive helps us guarantee that we'll always know what line number to expect the error # on, regardless of how much this test module changes #line 1133 func foo ( $bar?, :$baz ) {} 1; Method-Signatures-20160315/t/lib/BadParameter.pm000444001751000144 55712672114746 21003 0ustar00buddyusers000000000000package BadParameter; use strict; use warnings; use Method::Signatures; # the #line directive helps us guarantee that we'll always know what line number to expect the error # on, regardless of how much this test module changes #line 1133 func foo ( &$bar ) {} # & is not a valid character to precede a param 1; Method-Signatures-20160315/t/lib/OverrideModifierErrors.pm000444001751000144 146012672114746 23121 0ustar00buddyusers000000000000# package for t/override_modifier_errors.t package OverrideModifierErrors; use base qw< Method::Signatures::Modifiers >; sub required_arg { my ($class, $var) = @_; $class->signature_error("override missing"); } sub named_param_error { my ($class, $args) = @_; $class->signature_error("override extra"); } sub type_error { my ($class, $type, $value, $name) = @_; $class->signature_error("override badtype"); } 1; use MooseX::Declare; use OverrideModifierErrors; class NewErrorClass { method fee () {} method fie () {} method foe () {} method biff ( $bar) {} method bamm ( :$bar) {} method boom (Int $bar) {} } class NewErrorSubclass extends NewErrorClass { around fee ( $bar) {} around fie ( :$bar) {} around foe (Int $bar) {} } Method-Signatures-20160315/t/lib/MouseRoleTest.pm000444001751000144 32012672114746 21212 0ustar00buddyusers000000000000# package for t/role_check_mouse.t # the role { package MouseRole; use Mouse::Role; } # a class that composes the role { package WithMouseRole; use Mouse; with 'MouseRole'; } 1; Method-Signatures-20160315/t/lib/GenErrorRegex.pm000444001751000144 1072712672114746 21232 0ustar00buddyusers000000000000package GenErrorRegex; use strict; use warnings; use base qw< Exporter >; our @EXPORT_OK = ( qw< bad_param_error unexpected_after_error named_after_optpos_error pos_after_named_error required_after_optional_error >, # compile-time qw< mispositioned_slurpy_error multiple_slurpy_error named_slurpy_error >, # compile-time qw< required_error named_param_error badval_error badtype_error >, # run-time ); sub _regexify { my ($compile_time, $class, $obj, $method, $msg, %extra); $compile_time = ($_[0] || '') eq 'COMPILE_TIME'; # really should be // there, but this works if ($compile_time) { (undef, $msg, %extra) = @_; } else { ($obj, $method, $msg, %extra) = @_; $class = ref $obj || $obj || 'main'; } my $error = $compile_time ? "$msg in declaration at " : "In call to ${class}::$method(), $msg at "; if ($extra{LINE}) { $extra{FILE} ||= $0; $error .= "$extra{FILE} line $extra{LINE}.\n"; } if ($compile_time) { $error .= "Compilation failed"; } $error = quotemeta $error; return $extra{LINE} && !$compile_time ? qr/\A$error\Z/ : qr/\A$error/; } #################################################################################################### # COMPILE-TIME ERRORS # These don't know what package or method they're dealing with, so they require fewer parameters, # and they'll call _regexify() with an initial argument of 'COMPILE_TIME'. #################################################################################################### sub bad_param_error { my ($param, %extra) = @_; return _regexify(COMPILE_TIME => "Could not understand parameter specification: $param", %extra); } sub unexpected_after_error { my ($trailing, %extra) = @_; return _regexify(COMPILE_TIME => "Unexpected extra code after parameter specification: '$trailing'", %extra); } sub named_after_optpos_error { my ($named, $optpos, %extra) = @_; return _regexify(COMPILE_TIME => "Named parameter '$named' mixed with optional positional '$optpos'", %extra); } sub required_after_optional_error { my ($required, $optional, %extra) = @_; return _regexify(COMPILE_TIME => "Required positional parameter '$required' cannot follow an optional positional parameter '$optional'", %extra); } sub pos_after_named_error { my ($pos, $named, %extra) = @_; return _regexify(COMPILE_TIME => "Positional parameter '$pos' after named param '$named'", %extra); } sub mispositioned_slurpy_error { my ($param, %extra) = @_; return _regexify(COMPILE_TIME => "Slurpy parameter '$param' must come at the end", %extra); } sub multiple_slurpy_error { my (%extra) = @_; return _regexify(COMPILE_TIME => "Signature can only have one slurpy parameter", %extra); } sub named_slurpy_error { my ($param, %extra) = @_; return _regexify(COMPILE_TIME => "Slurpy parameter '$param' cannot be named; use a reference instead", %extra); } #################################################################################################### # RUN-TIME ERRORS # These should know what package and method they're dealing with, so they will all take an $obj # parameter and a $method parameter, with possibly some other parameters in between. The $obj # parameter can either be an instance of the package in question, or the name of it, or undef (which # will indicate the 'main' package. _regexify() handles all of that for you. Of course, because of # the way the compile-time errors are identified, it wouldn't work if you had a package named # COMPILE_TIME. That seems pretty unlikely though. #################################################################################################### sub required_error { my ($obj, $varname, $method, %extra) = @_; return _regexify($obj, $method, "missing required argument $varname", %extra); } sub named_param_error { my ($obj, $varname, $method, %extra) = @_; return _regexify($obj, $method, "does not take $varname as named argument(s)", %extra); } sub badval_error { my ($obj, $varname, $type, $val, $method, %extra) = @_; $val = defined $val ? qq{"$val"} : 'undef'; return _regexify($obj, $method, "the '$varname' parameter ($val) is not of type $type", %extra); } sub badtype_error { my ($obj, $type, $submsg, $method, %extra) = @_; return _regexify($obj, $method, "the type $type is unrecognized ($submsg)", %extra); } 1; Method-Signatures-20160315/t/lib/MissingRequired.pm000444001751000144 50312672114746 21555 0ustar00buddyusers000000000000package MissingRequired; use strict; use warnings; use InnerMissingRequired; sub bar { my $imr = InnerMissingRequired->new; # the #line directive helps us guarantee that we'll always know what line number to expect the error # on, regardless of how much this test module changes #line 1133 $imr->foo(); } 1; Method-Signatures-20160315/t/lib/PosAfterNamed.pm000444001751000144 42412672114746 21135 0ustar00buddyusers000000000000package PosAfterNamed; use strict; use warnings; use Method::Signatures; # the #line directive helps us guarantee that we'll always know what line number to expect the error # on, regardless of how much this test module changes #line 1133 func foo ( :$bar, $baz ) {} 1; Method-Signatures-20160315/t/lib/NoOverrides.pm000444001751000144 14112672114746 20700 0ustar00buddyusers000000000000# package for t/override_nothing.t package NoOverrides; use base qw< Method::Signatures >; 1; Method-Signatures-20160315/t/lib/BadType.pm000444001751000144 46212672114746 17777 0ustar00buddyusers000000000000package BadType; use strict; use warnings; use InnerBadType; sub bar { my $iut = InnerBadType->new; # the #line directive helps us guarantee that we'll always know what line number to expect the error # on, regardless of how much this test module changes #line 1133 $iut->foo('thing'); } 1; Method-Signatures-20160315/t/lib/InnerMissingRequired.pm000444001751000144 22512672114746 22552 0ustar00buddyusers000000000000package InnerMissingRequired; use strict; use warnings; use Method::Signatures; sub new { bless {}, __PACKAGE__ } method foo ( :$bar! ) {} 1; Method-Signatures-20160315/t/lib/OverrideTypeCheck.pm000444001751000144 24312672114746 22023 0ustar00buddyusers000000000000# package for t/override_typecheck.t package OverrideTypeCheck; use base qw< Method::Signatures >; sub type_check { warn "in overridden type_check"; } 1; Method-Signatures-20160315/t/lib/UnknownType.pm000444001751000144 47112672114746 20750 0ustar00buddyusers000000000000package UnknownType; use strict; use warnings; use InnerUnknownType; sub bar { my $iut = InnerUnknownType->new; # the #line directive helps us guarantee that we'll always know what line number to expect the error # on, regardless of how much this test module changes #line 1133 $iut->foo(42); } 1; Method-Signatures-20160315/t/lib/InnerUnknownType.pm000444001751000144 23412672114746 21741 0ustar00buddyusers000000000000package InnerUnknownType; use strict; use warnings; use Method::Signatures; sub new { bless {}, __PACKAGE__ } method foo ( Foo::Bmoogle $bar ) {} 1; Method-Signatures-20160315/t/lib/NoSuchNamed.pm000444001751000144 50712672114746 20613 0ustar00buddyusers000000000000package NoSuchNamed; use strict; use warnings; use InnerNoSuchNamed; sub bar { my $insn = InnerNoSuchNamed->new; # the #line directive helps us guarantee that we'll always know what line number to expect the error # on, regardless of how much this test module changes #line 1133 $insn->foo( bmoogle => 1 ); } 1; Method-Signatures-20160315/t/lib/MS_MXD_Role.pm000444001751000144 143612672114746 20501 0ustar00buddyusers000000000000# used by t/mxd-role.t use MooseX::Declare; use Method::Signatures::Modifiers; # Unlike classes, roles don't need to actually _have_ to have the methods they're modifying. This # particular test file is less about making sure we're properly substituting and more about making # sure we're not blowing up. Our original version of MSM::code_for was a bit too agressive in its # error checking and disallowed some role method modifiers that it shouldn't have. # # No need to test 'augment' because that isn't allowed in roles. role Foo { # attribute with modifiers has foo => ( is => 'ro' ); before foo () {} after foo () {} # "naked" modifiers before test_before () {} around test_around () {} after test_after () {} override test_override () {} } 1; Method-Signatures-20160315/t/lib/MooseRoleTest.pm000444001751000144 32012672114746 21204 0ustar00buddyusers000000000000# package for t/role_check_moose.t # the role { package MooseRole; use Moose::Role; } # a class that composes the role { package WithMooseRole; use Moose; with 'MooseRole'; } 1; Method-Signatures-20160315/t/lib/InnerNoSuchNamed.pm000444001751000144 22712672114746 21606 0ustar00buddyusers000000000000package InnerNoSuchNamed; use strict; use warnings; use Method::Signatures; sub new { bless {}, __PACKAGE__ } method foo ( :$bar, :$baz ) {} 1; Method-Signatures-20160315/t/lib/MS_MXD_Sub.pm000444001751000144 215412672114746 20327 0ustar00buddyusers000000000000use My::Declare; # Using Foo2 here just so we can insure we don't get our subclassing test crossed with our # replacement test (which uses Foo). Other than that, and the use statement above, note that this # code is exactly the same as MS_MXD_Replace.pm. class Foo2 { method test_before (Num $num) {} method test_around (Num $num) {} method test_after (Num $num) {} method test_override (Num $num) {} method test_augment (Num $num) { inner($num); } } # Obviously, it's not a very good idea to change the parameter types for before, after, or augment # modifiers. (Changing the parameter type for around is okay, and changing it for override is more # of an academic/philosophical point.) However, doing this allows us to test that MXMS is being # replaced by MSM by looking at the error messages. class Foo2::Bar extends Foo2 { before test_before (Int $num) {} around test_around (Int $num) { $self->$orig($num / 2); } after test_after (Int $num) {} after test_override (Int $num) { return super; } augment test_augment (Int $num) {} } 1; Method-Signatures-20160315/t/lib/MispositionedSlurpy.pm000444001751000144 43112672114746 22510 0ustar00buddyusers000000000000package MispositionedSlurpy; use strict; use warnings; use Method::Signatures; # the #line directive helps us guarantee that we'll always know what line number to expect the error # on, regardless of how much this test module changes #line 1133 func foo ( @bar, $baz ) {} 1; Method-Signatures-20160315/t/lib/TrailingGarbage.pm000444001751000144 56112672114746 21471 0ustar00buddyusers000000000000package TrailingGarbage; use strict; use warnings; use Method::Signatures; # the #line directive helps us guarantee that we'll always know what line number to expect the error # on, regardless of how much this test module changes #line 1133 func foo ( $bar& ) {} # & is not a valid character to follow a param 1; Method-Signatures-20160315/t/lib/InnerBadType.pm000444001751000144 21712672114746 20771 0ustar00buddyusers000000000000package InnerBadType; use strict; use warnings; use Method::Signatures; sub new { bless {}, __PACKAGE__ } method foo ( Int $bar ) {} 1; Method-Signatures-20160315/t/lib/MultipleSlurpy.pm000444001751000144 42412672114746 21457 0ustar00buddyusers000000000000package MultipleSlurpy; use strict; use warnings; use Method::Signatures; # the #line directive helps us guarantee that we'll always know what line number to expect the error # on, regardless of how much this test module changes #line 1133 func foo ( @bar, @baz ) {} 1; Method-Signatures-20160315/t/lib/Dev000755001751000144 012672114746 16510 5ustar00buddyusers000000000000Method-Signatures-20160315/t/lib/Dev/Null.pm000444001751000144 25512672114746 20077 0ustar00buddyusers000000000000package Dev::Null; # $Id: /mirror/googlecode/test-more/t/lib/Dev/Null.pm 57943 2008-08-18T02:09:22.275428Z brooklyn.kid51 $ sub TIEHANDLE { bless {} } sub PRINT { 1 } 1; Method-Signatures-20160315/t/lib/My000755001751000144 012672114746 16357 5ustar00buddyusers000000000000Method-Signatures-20160315/t/lib/My/Declare.pm000444001751000144 15412672114746 20371 0ustar00buddyusers000000000000use MooseX::Declare; class My::Declare extends MooseX::Declare { use Method::Signatures::Modifiers; } Method-Signatures-20160315/t/lib/My/Method000755001751000144 012672114746 17577 5ustar00buddyusers000000000000Method-Signatures-20160315/t/lib/My/Method/Signatures.pm000444001751000144 27212672114746 22377 0ustar00buddyusers000000000000package My::Method::Signatures; use base 'Method::Signatures'; sub signature_error_handler { my ($class, $msg) = @_; die bless { message => $msg }, 'My::ExceptionClass'; } 1; Method-Signatures-20160315/t/examples000755001751000144 012672114746 17042 5ustar00buddyusers000000000000Method-Signatures-20160315/t/examples/strip_ws.t000444001751000144 54512672114746 21222 0ustar00buddyusers000000000000#!/usr/bin/perl -w package Foo; use Test::More; BEGIN { plan skip_all => "Data::Alias not available" unless eval { require Data::Alias }; plan 'no_plan'; } use Method::Signatures; method strip_ws($str is alias) { $str =~ s{^\s+}{}; $str =~ s{\s+$}{}; return; } my $string = " stuff "; Foo->strip_ws($string); is $string, "stuff"; Method-Signatures-20160315/t/examples/iso_date_example.t000444001751000144 103612672114746 22666 0ustar00buddyusers000000000000#!/usr/bin/perl -w package Foo; use Test::More; use Test::Exception; use lib 't/lib'; use GenErrorRegex qw< required_error >; use Method::Signatures; method new($class:@_) { bless {@_}, $class; } method iso_date( :$year!, :$month = 1, :$day = 1, :$hour = 0, :$min = 0, :$sec = 0 ) { return "$year-$month-$day $hour:$min:$sec"; } $obj = Foo->new; is( $obj->iso_date(year => 2008), "2008-1-1 0:0:0" ); #line 25 throws_ok { $obj->iso_date() } required_error($obj, '$year', 'iso_date', LINE => 25); done_testing(); Method-Signatures-20160315/t/examples/silly.t000444001751000144 115412672114746 20521 0ustar00buddyusers000000000000#!/usr/bin/perl -w use strict; use warnings; package Foo; use Method::Signatures; use Test::More 'no_plan'; method silly( $num = 42, $string = q[Hello, world!], $hash = { this => 42, that => 23 }, $code = sub { $num + 4 }, @nums = (1,2,3) ) { return( num => $num, string => $string, hash => $hash, code => $code->(), nums => \@nums ); } is_deeply {Foo->silly()}, { num => 42, string => 'Hello, world!', hash => { this => 42, that => 23 }, code => 46, nums => [1,2,3] }; Method-Signatures-20160315/examples000755001751000144 012672114746 16577 5ustar00buddyusers000000000000Method-Signatures-20160315/examples/strip_ws.t000444001751000144 41612672114746 20754 0ustar00buddyusers000000000000#!/usr/bin/perl -lw package String; use Method::Signatures; method strip_ws($str is alias) { $str =~ s{^\s+}{}; $str =~ s{\s+$}{}; return; } my $string = " stuff "; print "String was: '$string'"; String->strip_ws($string); print "String is: '$string'"; Method-Signatures-20160315/examples/iso_date_example.t000444001751000144 56212672114746 22406 0ustar00buddyusers000000000000#!/usr/bin/perl -lw package Date; use Method::Signatures; method new($class:@_) { bless {@_}, $class; } method iso_date( :$year!, :$month = 1, :$day = 1, :$hour = 0, :$min = 0, :$sec = 0 ) { return sprintf "%04d-%02d-%02d %02d:%02d:%02d", $year, $month, $day, $hour, $min, $sec; } my $date = Date->new(); print $date->iso_date( year => 2008 );