/
Signatures.pm
1301 lines (903 loc) · 37.1 KB
/
Signatures.pm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
package Method::Signatures;
use strict;
use warnings;
use base 'Devel::Declare::MethodInstaller::Simple';
use Method::Signatures::Parser;
use Data::Alias;
use Devel::Pragma qw(:all);
our $VERSION = '20111017.2055_002';
our $DEBUG = $ENV{METHOD_SIGNATURES_DEBUG} || 0;
our @CARP_NOT;
# set up some regexen using for parsing types
my $TYPENAME = qr{ [a-z] \w* (?: \:\: \w+)* }ix;
my $PARAMETERIZED = qr{ \w+ \[ $TYPENAME \] }x;
my $DISJUNCTION = qr{ (?: $TYPENAME | $PARAMETERIZED ) \| (?: $TYPENAME | $PARAMETERIZED ) }x;
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<func> and C<method>, so that you can write subroutines with signatures instead of having to spell out C<my $self = shift; my($thing) = @_>
C<func> is like C<sub> but takes a signature where the prototype would
normally go. This takes the place of C<my($foo, $bar) = @_> and does
a whole lot more.
C<method> is like C<func> but specifically for making methods. It will
automatically provide the invocant as C<$self>. No more C<my $self =
shift>.
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<no source filters>.
=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.
=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<method> has an implied default of C<$self:>. C<func> 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),
)
{
...
}
Defaults will only be used if the argument is not passed in at all.
Passing in C<undef> 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
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<Any::Moose> which will load L<Mouse> if
L<Moose> 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<Mouse::Util::TypeConstraints> (or L<Moose::Util::TypeConstraints>;
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<Mouse> and L<Moose> 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<sum>;
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 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<is rw is copy>.
=over 4
=item B<ro>
Read-only. Assigning or modifying the parameter is an error.
=item B<rw>
Read-write. It's ok to read or write the parameter.
This is a default trait.
=item B<copy>
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.
=item B<alias>
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.
=back
=head3 Traits and defaults
To have a parameter which has both a trait and a default, set the
trait first and the default second.
method echo($message is ro = "what?") {
return $message
}
Think of it as C<$message is ro> being the left-hand side of the 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 Required and optional parameters
Parameters declared using C<$arg!> are explicitly I<required>.
Parameters declared using C<$arg?> are explicitly I<optional>. These
declarations override all other considerations.
A parameter is implictly I<optional> if it is a named parameter, has a
default, or is slurpy. All other parameters are implicitly
I<required>.
# $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.
=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<Earlier Perl versions>.
=head3 debug
When true, turns on debugging messages about compiling methods and
funcs. See L<DEBUGGING>. 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");
}
sub code_for {
my($self, $name) = @_;
my $code = $self->SUPER::code_for($name);
# Make method and func act at compile time, if they're named and if we're
# configured to do that.
if( defined $name && $self->_do_compile_at_BEGIN ) {
require Devel::BeginLift;
Devel::BeginLift->setup_for_cv($code);
}
return $code;
}
# 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;
}
# 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} = $1 if $protos[0] =~ s{^ ([^:\s]+) : (?! :) \s* }{}x;
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 = {};
$sig->{proto} = $proto;
# $TYPENAME, $PARAMETERIZED, and $DISJUNCTION defined up at top, for performance reasons
$sig->{type} = $1 if $proto =~ s{^ ($TYPENAME | $PARAMETERIZED | $DISJUNCTION) \s+ }{}iox;
$sig->{named} = $proto =~ s{^:}{};
if( !$sig->{named} ) {
$sig->{idx} = $idx;
$idx++;
}
$sig->{is_at_underscore} = $proto eq '@_';
$sig->{is_ref_alias} = $proto =~ s{^\\}{};
while ($proto =~ s{ \s+ is \s+ (\S+) }{}x) {
$sig->{traits}{$1}++;
}
$sig->{default} = $1 if $proto =~ s{ \s* = \s* (.*) }{}x;
my ($sigil, $name) = $proto =~ m{^ (.)(.*) }x;
$sig->{is_slurpy} = ($sigil =~ /^[%@]$/ and !$sig->{is_ref_alias});
$sig->{is_optional} = ($name =~ s{\?$}{} or exists $sig->{default} or $sig->{named} or $sig->{is_slurpy});
$sig->{is_optional} = 0 if $name =~ s{\!$}{};
$sig->{sigil} = $sigil;
$sig->{name} = $name;
$sig->{var} = $sigil . $name;
$self->_check_sig($sig, $signature);
if( $sig->{named} ) {
push @{$signature->{named}}, $sig;
}
else {
push @{$signature->{positional}}, $sig;
$sig->{position} = @{$signature->{positional}};
}
my $overall = $signature->{overall};
$overall->{num_optional}++ if $sig->{is_optional};
$overall->{num_named}++ if $sig->{named};
$overall->{num_positional}++ if !$sig->{named};
$overall->{num_optional_positional}++ if $sig->{is_optional} and !$sig->{named};
$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);
DEBUG( "inject: $inject\n" );
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 maxmimum 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} ) {
$self->signature_error("signature can only have one slurpy parameter") if
$signature->{overall}{num_slurpy} >= 1;
$self->signature_error("slurpy parameter $sig->{var} cannot be named, use a reference instead") if
$sig->{named};
}
if( $sig->{named} ) {
if( $signature->{overall}{num_optional_positional} ) {
my $pos_var = $signature->{positional}[-1]{var};
die("named parameter $sig->{var} mixed with optional positional $pos_var\n");
}
}
else {
if( $signature->{overall}{num_named} ) {
my $named_var = $signature->{named}[-1]{var};
die("positional parameter $sig->{var} after named param $named_var\n");
}
}
}
# 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} &&
!$signature->{positional}[-1]{is_slurpy}
)
{
my($slurpy_param) = $self->_find_slurpy_params;
$self->signature_error("slurpy parameter $slurpy_param->{var} 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}};
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 %args;' if $signature->{overall}{num_named};
}
push @code, $class . '->named_param_error(\%args) if %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)");
}
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->{name};
my $idx = $sig->{idx};
# These are the defaults.
my $lhs = "my $sig->{var}";
my $rhs;
if( $sig->{named} ) {
$sig->{passed_in} = "\$args{$sig->{name}}";
$rhs = "delete $sig->{passed_in}";
}
else {
$rhs = $sig->{is_ref_alias} ? "${sigil}{\$_[$idx]}" :
$sig->{sigil} =~ /^[@%]$/ ? "\@_[$idx..\$#_]" :
"\$_[$idx]" ;
$sig->{passed_in} = $rhs;
}
my $check_exists = $sig->{check_exists} = $sig->{named} ? "exists \$args{$sig->{name}}" : "(\@_ > $idx)";
# Handle a default value
if( defined $sig->{default} ) {
$rhs = "$check_exists ? ($rhs) : ($sig->{default})";
}
if( !$sig->{is_optional} ) {
push @code, qq[${class}->required_arg('$sig->{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} ) {
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;";
}
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} ? "if $sig->{check_exists}" : '';
return "${class}->type_check('$sig->{type}', $sig->{passed_in}, '$sig->{name}') $check_exists;";
}
# 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;
# 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
local @CARP_NOT;
push @CARP_NOT, __PACKAGE__;
push @CARP_NOT, $class unless $class =~ /^${\__PACKAGE__}(::|$)/;
push @CARP_NOT, qw< Class::MOP Moose Mouse Devel::Declare >;
my $skip = qr/^(?:${\(join('|', @CARP_NOT))})::/;
my $level = 0;
my ($pack, $file, $line, $method);
do {
($pack, $file, $line, $method) = caller(++$level);
} while $method =~ /$skip/ or $pack =~ /$skip/;
die "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.
my %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))
{
$value = defined $value ? qq{"$value"} : 'undef';
$class->type_error($type, $value, $name);
}