Method-Signatures-20131010000755001750000144 012225457201 14734 5ustar00buddyusers000000000000Method-Signatures-20131010/Changes000444001750000144 3066012225457201 16411 0ustar00buddyusers00000000000020131010 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-20131010/MANIFEST.SKIP000444001750000144 210012225457201 16760 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-20131010/.travis.yml000444001750000144 11112225457201 17153 0ustar00buddyusers000000000000language: perl perl: - "5.16" - "5.14" - "5.12" - "5.10" Method-Signatures-20131010/META.yml000444001750000144 251012225457201 16340 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.26 dynamic_config: 1 generated_by: 'Module::Build version 0.4005, CPAN::Meta::Converter version 2.131560' 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: 20131010 Method::Signatures::Modifiers: file: lib/Method/Signatures/Modifiers.pm version: 20131010 Method::Signatures::Parameter: file: lib/Method/Signatures/Parameter.pm Method::Signatures::Parser: file: lib/Method/Signatures/Parser.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 Devel::Pragma: 0.40 Mouse: 0.64 PPI: 1.203 Sub::Name: 0.03 experimental: 0.005 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/schwern/method-signatures version: 20131010 Method-Signatures-20131010/META.json000444001750000144 426212225457201 16516 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.4005, CPAN::Meta::Converter version 2.131560", "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.26" } }, "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", "Devel::Pragma" : "0.40", "Mouse" : "0.64", "PPI" : "1.203", "Sub::Name" : "0.03", "experimental" : "0.005", "perl" : "v5.8.1" } } }, "provides" : { "Method::Signatures" : { "file" : "lib/Method/Signatures.pm", "version" : "20131010" }, "Method::Signatures::Modifiers" : { "file" : "lib/Method/Signatures/Modifiers.pm", "version" : "20131010" }, "Method::Signatures::Parameter" : { "file" : "lib/Method/Signatures/Parameter.pm" }, "Method::Signatures::Parser" : { "file" : "lib/Method/Signatures/Parser.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/schwern/method-signatures" } }, "version" : "20131010" } Method-Signatures-20131010/MANIFEST000444001750000144 404212225457201 16222 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/Parser.pm MANIFEST This list of files MANIFEST.SKIP META.json META.yml 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/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/TrailingGarbage.pm t/lib/UnknownType.pm 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/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/split_proto.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-20131010/Build.PL000444001750000144 270312225457201 16367 0ustar00buddyusers000000000000#!/usr/bin/perl -w use 5.008001; use Module::Build; my $build = Module::Build->new( module_name => 'Method::Signatures', license => 'perl', recursive_test_files => 1, configure_requires => { 'Module::Build' => '0.26', }, 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', 'experimental' => '0.005', 'Devel::Pragma' => '0.40', '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', }, 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/schwern/method-signatures', }, }, ); $build->create_build_script; Method-Signatures-20131010/lib000755001750000144 012225457201 15502 5ustar00buddyusers000000000000Method-Signatures-20131010/lib/Method000755001750000144 012225457201 16722 5ustar00buddyusers000000000000Method-Signatures-20131010/lib/Method/Signatures.pm000444001750000144 14224512225457201 21611 0ustar00buddyusers000000000000package Method::Signatures; use strict; use warnings; use base 'Devel::Declare::MethodInstaller::Simple'; use Method::Signatures::Parser; use Method::Signatures::Parameter; use Devel::Pragma qw(my_hints); our $VERSION = '20131010'; our $DEBUG = $ENV{METHOD_SIGNATURES_DEBUG} || 0; our @CARP_NOT; our $INF = ( 0 + "inf" ) == 0 ? 9e9999 : "inf"; sub DEBUG { return unless $DEBUG; require Data::Dumper; print STDERR "DEBUG: ", map { ref $_ ? Data::Dumper::Dumper($_) : $_ } @_; } =head1 NAME Method::Signatures - method and function declarations with signatures and no source filter =head1 SYNOPSIS package Foo; use Method::Signatures; method new (%args) { return bless {%args}, $self; } method get ($key) { return $self->{$key}; } method set ($key, $val) { return $self->{$key} = $val; } # 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 } func hello($greeting, $place) { print "$greeting, $place!\n"; } =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>. No more C. 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) =head3 Invocant parameter The method invocant (i.e. C<$self>) can be changed as the first parameter. 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:>. C has no invocant. =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. =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 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 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 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}; } elsif ($arg eq ':DEBUG') { $DEBUG = 1; } else { require Carp; Carp::croak("Invalid Module::Signatures argument $arg"); } } $class->install_methodhandler( into => $caller, name => 'method', invocant => '$self' ); $class->install_methodhandler( into => $caller, name => 'func', ); DEBUG("import for $caller done\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}; } sub _strip_ws { $_[0] =~ s/^\s+//; $_[0] =~ s/\s+$//; } # 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; return $self->parse_signature( proto => $proto, invocant => $self->{invocant}, pre_invocant => $self->{pre_invocant} ); } # Parse a signature sub parse_signature { my $self = shift; my %args = @_; my @protos = $self->_split_proto($args{proto} || []); my $signature = $args{signature} || {}; # JIC there's anything we need to pull out before the invocant # (primary example would be the $orig for around modifiers in Moose/Mouse $signature->{pre_invocant} = $args{pre_invocant}; # Special case for methods, they will pass in an invocant to use as the default if( $signature->{invocant} = $args{invocant} ) { if( @protos ) { $signature->{invocant} = $_ for extract_invocant(\$protos[0]); shift @protos unless $protos[0] =~ /\S/; } } return $self->parse_func( proto => \@protos, signature => $signature ); } sub _split_proto { my $self = shift; my $proto = shift; my @protos; if( ref $proto ) { @protos = @$proto; } else { _strip_ws($proto); @protos = split_proto($proto); } return @protos; } # Parse a subroutine signature sub parse_func { my $self = shift; my %args = @_; my @protos = $self->_split_proto($args{proto} || []); my $signature = $args{signature} || {}; $signature->{named} = []; $signature->{positional} = []; $signature->{overall} = { num_optional => 0, num_optional_positional => 0, num_named => 0, num_positional => 0, has_invocant => $signature->{invocant} ? 1 : 0, num_slurpy => 0 }; my $idx = 0; for my $proto (@protos) { DEBUG( "proto: $proto\n" ); my $sig = Method::Signatures::Parameter->new( original_code => $proto, position => $idx, ); $idx++ if $sig->is_positional; # Handle "don't care" specifier if ($sig->is_yadayada) { $signature->{overall}{num_slurpy}++; $signature->{overall}{yadayada}++; next; } $self->_check_sig($sig, $signature); if( $sig->is_named ) { push @{$signature->{named}}, $sig; } else { push @{$signature->{positional}}, $sig; } my $overall = $signature->{overall}; $overall->{num_optional}++ if $sig->is_optional; $overall->{num_named}++ if $sig->is_named; $overall->{num_positional}++ if $sig->is_positional; $overall->{num_optional_positional}++ if $sig->is_optional and $sig->is_positional; $overall->{num_slurpy}++ if $sig->is_slurpy; DEBUG( "sig: ", $sig ); } $self->{signature} = $signature; $self->_calculate_max_args; $self->_check_signature; # Then turn it into Perl code my $inject = $self->inject_from_signature($signature); return $inject; } sub _calculate_max_args { my $self = shift; my $overall = $self->{signature}{overall}; # If there's a slurpy argument, the max is infinity. if( $overall->{num_slurpy} ) { $overall->{max_argv_size} = $INF; $overall->{max_args} = $INF; return; } # How big can @_ be? $overall->{max_argv_size} = ($overall->{num_named} * 2) + $overall->{num_positional}; # The maximum logical arguments (name => value counts as one argument) $overall->{max_args} = $overall->{num_named} + $overall->{num_positional}; return; } # Check the integrity of one piece of the signature sub _check_sig { my($self, $sig, $signature) = @_; if( $sig->is_slurpy ) { sig_parsing_error("Signature can only have one slurpy parameter") if $signature->{overall}{num_slurpy} >= 1; sig_parsing_error("Slurpy parameter '@{[$sig->variable]}' cannot be named; use a reference instead") if $sig->is_named; } if( $sig->is_named ) { if( $signature->{overall}{num_optional_positional} ) { my $pos_var = $signature->{positional}[-1]->variable; my $var = $sig->variable; sig_parsing_error("Named parameter '$var' mixed with optional positional '$pos_var'"); } } else { if( $signature->{overall}{num_named} ) { my $named_var = $signature->{named}[-1]->variable; my $var = $sig->variable; sig_parsing_error("Positional parameter '$var' after named param '$named_var'"); } } } # Check the integrity of the signature as a whole sub _check_signature { my $self = shift; my $signature = $self->{signature}; my $overall = $signature->{overall}; # Check that slurpy arguments come at the end if( $overall->{num_slurpy} && !($overall->{yadayada} || $signature->{positional}[-1]->is_slurpy) ) { my($slurpy_param) = $self->_find_slurpy_params; sig_parsing_error("Slurpy parameter '@{[$slurpy_param->variable]}' must come at the end"); } } sub _find_slurpy_params { my $self = shift; my $signature = $self->{signature}; return grep { $_->is_slurpy } @{ $signature->{named} }, @{ $signature->{positional} }; } # Turn the parsed signature into Perl code sub inject_from_signature { my $self = shift; my $class = ref $self || $self; my $signature = shift; 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}}) { push @code, $self->inject_for_sig($sig); } if( @{$signature->{named}} ) { my $first_named_idx = @{$signature->{positional}}; if (grep { $_->is_ref_alias or $_->traits->{alias} } @{$signature->{named}}) { 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}}) { push @code, $self->inject_for_sig($sig); } push @code, $class . '->named_param_error(\%args) if keys %args;' if $signature->{overall}{num_named} && !$signature->{overall}{yadayada}; } push @code, $class . '->named_param_error(\%args) if keys %args;' if $signature->{overall}{has_named}; my $max_argv = $signature->{overall}{max_argv_size}; my $max_args = $signature->{overall}{max_args}; push @code, qq[$class->too_many_args_error($max_args) if \@_ > $max_argv; ] unless $max_argv == $INF; # 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; 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}" : "(\@_ > $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; ]; } if( $sig->type ) { push @code, $self->inject_for_type_check($sig); } # 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;"; } # 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) if ( $sig->where ) { for my $constraint ( keys %{$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 { use experimental 'smartmatch'; grep { \$_ ~~ $constraint_impl } $var }; "; } } return @code; } # 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 ? $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->passed_in; my $error = sprintf q[%s->type_error('%s', %s, '%s') ], $class, $sig->type, $sig->passed_in, $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 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-20131010/lib/Method/Signatures000755001750000144 012225457201 21046 5ustar00buddyusers000000000000Method-Signatures-20131010/lib/Method/Signatures/Modifiers.pm000444001750000144 2101112225457201 23475 0ustar00buddyusers000000000000package Method::Signatures::Modifiers; use strict; use warnings; use Sub::Name; use base 'Method::Signatures'; our $VERSION = '20131010'; =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-20131010/lib/Method/Signatures/Parser.pm000444001750000144 541412225457201 23001 0ustar00buddyusers000000000000package Method::Signatures::Parser; use strict; use warnings; use Carp; use base qw(Exporter); our @EXPORT = qw(split_proto split_parameter extract_invocant sig_parsing_error carp_location_for); sub split_proto { my $proto = shift; return unless $proto =~ /\S/; local $@ = undef; my $ppi = __PACKAGE__->new_ppi_doc(\$proto); $ppi->prune('PPI::Token::Comment'); my $statement = $ppi->find_first("PPI::Statement"); sig_parsing_error("Could not understand parameter list specification: $proto") unless $statement; my $token = $statement->first_token; my @proto = (''); do { if( $token->class eq "PPI::Token::Operator" and $token->content eq ',' ) { push @proto, ''; } else { $proto[-1] .= $token->content; } $token = $token->class eq 'PPI::Token::Label' ? $token->next_token : $token->next_sibling; } while( $token ); strip_ws($_) for @proto; # Remove blank entries due to trailing comma. @proto = grep { /\S/ } @proto; return @proto; } # Extract an invocant, if one is present... my $IDENTIFIER = qr{ [^\W\d] \w* }x; sub extract_invocant { my ($param_ref) = @_; if ($$param_ref =~ s{ ^ (\$ $IDENTIFIER) \s* : \s* }{}x) { return $1; } return; } sub strip_ws { $_[0] =~ s{^\s+}{}; $_[0] =~ s{\s+$}{}; } # 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 new_ppi_doc { my $class = shift; my $source = shift; require PPI; my $ppi = PPI::Document->new($source) or sig_parsing_error("source '$$source' cannot be parsed by PPI: " . PPI::Document->errstr); return $ppi; } 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-20131010/lib/Method/Signatures/Parameter.pm000444001750000144 1762212225457201 23511 0ustar00buddyusers000000000000package Method::Signatures::Parameter; use Mouse; use Carp; use Method::Signatures::Parser; 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 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 => 'HashRef[Int]', default => sub { {} }; sub has_where { my $self = shift; return keys %{$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', ; 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 = Method::Signatures::Parser->new_ppi_doc(\($self->ppi_clean_code)); 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; $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; $extracted .= shift @$tokens; } 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; } 1; Method-Signatures-20131010/examples000755001750000144 012225457201 16552 5ustar00buddyusers000000000000Method-Signatures-20131010/examples/strip_ws.t000444001750000144 41612225457201 20727 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-20131010/examples/iso_date_example.t000444001750000144 56212225457201 22361 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 ); Method-Signatures-20131010/t000755001750000144 012225457201 15177 5ustar00buddyusers000000000000Method-Signatures-20131010/t/anon.t000444001750000144 47012225457201 16435 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-20131010/t/override_nothing.t000444001750000144 34312225457201 21046 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-20131010/t/mxd-role.t000444001750000144 121112225457201 17243 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-20131010/t/ro.t000444001750000144 64212225457201 16123 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-20131010/t/block_defaults.t000444001750000144 333212225457201 20503 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-20131010/t/defined_or_defaults.t000444001750000144 403412225457201 21507 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-20131010/t/larna.t000444001750000144 67012225457201 16601 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-20131010/t/role_check_moose.t000444001750000144 130512225457201 21020 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-20131010/t/yadayada.t000444001750000144 503012225457201 17274 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-20131010/t/typeload_notypes.t000444001750000144 126412225457201 21126 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-20131010/t/split_proto.t000444001750000144 222612225457201 20101 0ustar00buddyusers000000000000#!/usr/bin/perl -w use strict; use warnings; use Test::More 'no_plan'; use Method::Signatures::Parser; 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) { is_deeply [split_proto($args)], $expect, "split_proto($args)"; } Method-Signatures-20131010/t/begin.t000444001750000144 302012225457201 16600 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-20131010/t/defaults.t000444001750000144 311712225457201 17332 0ustar00buddyusers000000000000#!/usr/bin/perl -w use strict; use warnings; use Test::More 'no_plan'; { 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 ); } Method-Signatures-20131010/t/named.t000444001750000144 256012225457201 16610 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-20131010/t/zero_defaults.t000444001750000144 411712225457201 20372 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-20131010/t/paren_plus_open_block.t000444001750000144 26512225457201 22047 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-20131010/t/before_510.t000444001750000144 217612225457201 17356 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-20131010/t/into.t000444001750000144 36412225457201 16455 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-20131010/t/invocant.t000444001750000144 223612225457201 17345 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); } 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 ); 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-20131010/t/too_many_args.t000444001750000144 305412225457201 20364 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-20131010/t/optional.t000444001750000144 244312225457201 17351 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-20131010/t/override_errors.t000444001750000144 137512225457201 20742 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-20131010/t/method.t000444001750000144 261712225457201 17007 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-20131010/t/role_check_basic.t000444001750000144 316312225457201 20763 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-20131010/t/refs.t000444001750000144 305112225457201 16457 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-20131010/t/caller.t000444001750000144 212612225457201 16764 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-20131010/t/attributes.t000444001750000144 204612225457201 17711 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-20131010/t/required.t000444001750000144 150512225457201 17342 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-20131010/t/typeload_nomoose.t000444001750000144 110612225457201 21077 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-20131010/t/type_req_opt.t000444001750000144 173512225457201 20241 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-20131010/t/undef_defaults.t000444001750000144 417112225457201 20514 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-20131010/t/debugger.t000444001750000144 157312225457201 17313 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-20131010/t/type_check.t000444001750000144 1473412225457201 17670 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-20131010/t/at_underscore.t000444001750000144 54412225457201 20341 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-20131010/t/one_line.t000444001750000144 24112225457201 17266 0ustar00buddyusers000000000000#!/usr/bin/perl -w use Test::More tests => 1; { package Thing; use Method::Signatures; method foo {"wibble"} ::is( Thing->foo, "wibble" ); } Method-Signatures-20131010/t/when.t000444001750000144 163112225457201 16463 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]; }; done_testing; Method-Signatures-20131010/t/named_refs.t000444001750000144 303412225457201 17624 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-20131010/t/named_alias.t000444001750000144 62312225457201 17737 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-20131010/t/typeload_moose.t000444001750000144 177012225457201 20551 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-20131010/t/mxd-sub.t000444001750000144 307512225457201 17105 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-20131010/t/alias.t000444001750000144 61212225457201 16571 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-20131010/t/traits.t000444001750000144 54412225457201 17012 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-20131010/t/paren_on_own_line.t000444001750000144 35712225457201 21201 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-20131010/t/override_modifier_errors.t000444001750000144 165312225457201 22617 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-20131010/t/signature_error_handler.t000444001750000144 66012225457201 22412 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-20131010/t/error_reporting.t000444001750000144 2043212225457201 20764 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', }, ); 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-20131010/t/string_defaults.t000444001750000144 423512225457201 20722 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-20131010/t/types.t000444001750000144 260512225457201 16670 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_func(proto => $proto); my $which = shift @$want; for my $idx (0..$#{$want}) { is $ms->{signature}{$which}[$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_func( proto => 'Foo $this, :$bar, Foo::Bar :$foobar' ); like $code, qr{type_check\('\$this'\)}; like $code, qr{type_check\('\$foobar'\)}; } done_testing; Method-Signatures-20131010/t/role_check_mouse.t000444001750000144 110212225457201 21021 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-20131010/t/override_typecheck.t000444001750000144 32112225457201 21353 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-20131010/t/thread-bug.t000444001750000144 131412225457201 17542 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-20131010/t/syntax_errors.t000444001750000144 57712225457201 20434 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-20131010/t/trailing_comma.t000444001750000144 34612225457201 20471 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-20131010/t/odd_number.t000444001750000144 112412225457201 17635 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-20131010/t/where.t000444001750000144 760112225457201 16637 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 { use 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-20131010/t/simple.plx000444001750000144 17612225457201 17336 0ustar00buddyusers000000000000package Foo; use strict; use warnings; use Method::Signatures; method echo($msg) { return $msg } print Foo->echo(42); Method-Signatures-20131010/t/slurpy.t000444001750000144 332712225457201 17064 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-20131010/t/comments.t000444001750000144 300212225457201 17341 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-20131010/t/array_param.t000555001750000144 125512225457201 20025 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-20131010/t/func.t000444001750000144 24612225457201 16436 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-20131010/t/error_interruption.t000444001750000144 51012225457201 21450 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-20131010/t/mxd-replace.t000444001750000144 174712225457201 17733 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-20131010/t/lib000755001750000144 012225457201 15745 5ustar00buddyusers000000000000Method-Signatures-20131010/t/lib/UnknownType.pm000444001750000144 47112225457201 20723 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-20131010/t/lib/MS_MXD_Role.pm000444001750000144 143612225457201 20454 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-20131010/t/lib/GenErrorRegex.pm000444001750000144 1031612225457201 21177 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 >, # 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 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-20131010/t/lib/OverrideModifierErrors.pm000444001750000144 146012225457201 23074 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-20131010/t/lib/MS_MXD_Replace.pm000444001750000144 174112225457201 21125 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-20131010/t/lib/OverrideErrors.pm000444001750000144 67312225457201 21402 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-20131010/t/lib/BadParameter.pm000444001750000144 55712225457201 20756 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-20131010/t/lib/MS_MXD_Sub.pm000444001750000144 215412225457201 20302 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-20131010/t/lib/InnerNoSuchNamed.pm000444001750000144 22712225457201 21561 0ustar00buddyusers000000000000package InnerNoSuchNamed; use strict; use warnings; use Method::Signatures; sub new { bless {}, __PACKAGE__ } method foo ( :$bar, :$baz ) {} 1; Method-Signatures-20131010/t/lib/BasicRoleTest.pm000444001750000144 40512225457201 21122 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-20131010/t/lib/Bad.pm000444001750000144 26512225457201 17111 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-20131010/t/lib/NoSuchNamed.pm000444001750000144 50712225457201 20566 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-20131010/t/lib/NamedSlurpy.pm000444001750000144 41412225457201 20662 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-20131010/t/lib/MouseRoleTest.pm000444001750000144 32012225457201 21165 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-20131010/t/lib/TrailingGarbage.pm000444001750000144 56112225457201 21444 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-20131010/t/lib/NoOverrides.pm000444001750000144 14112225457201 20653 0ustar00buddyusers000000000000# package for t/override_nothing.t package NoOverrides; use base qw< Method::Signatures >; 1; Method-Signatures-20131010/t/lib/OverrideTypeCheck.pm000444001750000144 24312225457201 21776 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-20131010/t/lib/BarfyDie.pm000444001750000144 112612225457201 20125 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-20131010/t/lib/MooseLoadTest.pm000444001750000144 35712225457201 21147 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-20131010/t/lib/MooseRoleTest.pm000444001750000144 32012225457201 21157 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-20131010/t/lib/BadType.pm000444001750000144 46212225457201 17752 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-20131010/t/lib/ModifierBadType.pm000444001750000144 61712225457201 21433 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-20131010/t/lib/NamedAfterOptPos.pm000444001750000144 43012225457201 21570 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-20131010/t/lib/MultipleSlurpy.pm000444001750000144 42412225457201 21432 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-20131010/t/lib/InnerBadType.pm000444001750000144 21712225457201 20744 0ustar00buddyusers000000000000package InnerBadType; use strict; use warnings; use Method::Signatures; sub new { bless {}, __PACKAGE__ } method foo ( Int $bar ) {} 1; Method-Signatures-20131010/t/lib/MispositionedSlurpy.pm000444001750000144 43112225457201 22463 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-20131010/t/lib/MissingRequired.pm000444001750000144 50312225457201 21530 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-20131010/t/lib/PosAfterNamed.pm000444001750000144 42412225457201 21110 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-20131010/t/lib/InnerUnknownType.pm000444001750000144 23412225457201 21714 0ustar00buddyusers000000000000package InnerUnknownType; use strict; use warnings; use Method::Signatures; sub new { bless {}, __PACKAGE__ } method foo ( Foo::Bmoogle $bar ) {} 1; Method-Signatures-20131010/t/lib/InnerMissingRequired.pm000444001750000144 22512225457201 22525 0ustar00buddyusers000000000000package InnerMissingRequired; use strict; use warnings; use Method::Signatures; sub new { bless {}, __PACKAGE__ } method foo ( :$bar! ) {} 1; Method-Signatures-20131010/t/lib/My000755001750000144 012225457201 16332 5ustar00buddyusers000000000000Method-Signatures-20131010/t/lib/My/Declare.pm000444001750000144 15412225457201 20344 0ustar00buddyusers000000000000use MooseX::Declare; class My::Declare extends MooseX::Declare { use Method::Signatures::Modifiers; } Method-Signatures-20131010/t/lib/My/Method000755001750000144 012225457201 17552 5ustar00buddyusers000000000000Method-Signatures-20131010/t/lib/My/Method/Signatures.pm000444001750000144 27212225457201 22352 0ustar00buddyusers000000000000package My::Method::Signatures; use base 'Method::Signatures'; sub signature_error_handler { my ($class, $msg) = @_; die bless { message => $msg }, 'My::ExceptionClass'; } 1; Method-Signatures-20131010/t/lib/Dev000755001750000144 012225457201 16463 5ustar00buddyusers000000000000Method-Signatures-20131010/t/lib/Dev/Null.pm000444001750000144 25512225457201 20052 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-20131010/t/examples000755001750000144 012225457201 17015 5ustar00buddyusers000000000000Method-Signatures-20131010/t/examples/strip_ws.t000444001750000144 54512225457201 21175 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-20131010/t/examples/iso_date_example.t000444001750000144 103612225457201 22641 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-20131010/t/examples/silly.t000444001750000144 115412225457201 20474 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] };