File Coverage

blib/lib/MooseX/Meta/Method/Signature.pm
Criterion Covered Total %
statement 1 3 33.3
branch n/a
condition n/a
subroutine 1 1 100.0
pod n/a
total 2 4 50.0


line stmt bran cond sub pod time code
1             package MooseX::Meta::Method::Signature;
2              
3 1     1   1969 use Moose;
  0            
  0            
4              
5             use Carp;
6             use Moose::Util qw/does_role/;
7             use MooseX::Method::Exception;
8              
9             extends qw/Moose::Meta::Method/;
10              
11             our $VERSION = '0.01';
12              
13             our $AUTHORITY = 'cpan:BERLE';
14              
15             sub wrap_with_signature {
16             my ($class,$signature,$coderef,$classname,$subname) = @_;
17              
18             MooseX::Method::Exception->throw ('No valid signature provided')
19             unless does_role ($signature,'MooseX::Meta::Signature');
20              
21             MooseX::Method::Exception->throw ('No valid coderef provided')
22             unless ref $coderef;
23              
24             my $self = $class->wrap (
25             $class->_make_validating_coderef ($signature,$coderef),
26             package_name => $classname, name => $subname
27             );
28              
29             $self->{'$!signature'} = $signature;
30              
31             return $self;
32             }
33              
34             sub _make_validating_coderef {
35             my ($class,$signature,$coderef) = @_;
36              
37             return sub {
38             my $self = shift;
39              
40             eval {
41             @_ = ($self,$signature->validate (@_));
42             };
43              
44             Carp::croak ("$@")
45             if $@;
46              
47             goto $coderef;
48             };
49             }
50              
51             sub signature {
52             my ($self) = @_;
53              
54             return $self->{'$!signature'};
55             }
56              
57             sub has_signature {
58             my ($self) = @_;
59              
60             return (defined $self->{'$!signature'} ? 1 : 0);
61             }
62              
63             __PACKAGE__->meta->make_immutable;
64              
65             1;
66              
67             __END__
68              
69             =pod
70              
71             =head1 NAME
72              
73             MooseX::Meta::Method::Signature - Signature supporting method metaclass
74              
75             =head1 WARNING
76              
77             This API is unstable, it may change at any time. This should not
78             affect ordinary L<MooseX::Method> usage.
79              
80             =head1 SYNOPSIS
81              
82             use MooseX::Meta::Method::Signature;
83             use MooseX::Meta::Signature::Named;
84              
85             my $method = MooseX::Meta::Method::Signature->wrap_with_signature (
86             MooseX::Meta::Signature::Named->new,
87             sub { print "Hello world!\n" },
88             );
89              
90             Someclass->meta->add_method (foo => $method);
91              
92             =head1 DESCRIPTION
93              
94             A subclass of L<Moose::Meta::Method> that has some added attributes
95             and methods to support signatures.
96              
97             =head1 METHODS
98              
99             =over 4
100              
101             =item B<wrap_with_signature>
102              
103             Similar to the wrap method from L<Moose::Meta::Method> but lets you
104             specify a signature for your coderef.
105              
106             =item B<signature>
107              
108             Returns the signature if any.
109              
110             =item B<has_signature>
111              
112             Returns true or false depending on if a signature is present.
113              
114             =back
115              
116             =head1 SEE ALSO
117              
118             =over 4
119              
120             =item L<Moose::Meta::Method>
121              
122             =back
123              
124             =head1 BUGS
125              
126             Most software has bugs. This module probably isn't an exception.
127             If you find a bug please either email me, or add the bug to cpan-RT.
128              
129             =head1 AUTHOR
130              
131             Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
132              
133             =head1 COPYRIGHT AND LICENSE
134              
135             Copyright 2007 by Anders Nor Berle.
136              
137             This library is free software; you can redistribute it and/or modify
138             it under the same terms as Perl itself.
139              
140             =cut
141