File Coverage

blib/lib/Function/Return.pm
Criterion Covered Total %
statement 156 193 80.8
branch 60 114 52.6
condition 4 4 100.0
subroutine 29 30 96.6
pod 3 3 100.0
total 252 344 73.2


line stmt bran cond sub pod time code
1             package Function::Return;
2              
3 14     14   1482591 use v5.14.0;
  14         165  
4 14     14   99 use warnings;
  14         26  
  14         723  
5              
6             our $VERSION = "0.13";
7              
8 14     14   8317 use Attribute::Handlers;
  14         66187  
  14         84  
9 14     14   7754 use B::Hooks::EndOfScope;
  14         124161  
  14         101  
10              
11 14     14   8782 use Scope::Upper ();
  14         12142  
  14         348  
12 14     14   8274 use Sub::Meta;
  14         237038  
  14         609  
13 14     14   7306 use Sub::Meta::Library;
  14         12961  
  14         514  
14 14     14   7001 use Sub::Meta::Finder::FunctionParameters;
  14         65937  
  14         549  
15 14     14   7645 use namespace::autoclean;
  14         95535  
  14         61  
16              
17             my @RETURN_ARGS;
18             my %NO_CHECK;
19              
20             sub import {
21 20     20   1182 my $class = shift;
22 20         56 my %args = @_;
23              
24 20 100       92 my $pkg = $args{pkg} ? $args{pkg} : scalar caller;
25 20 100       96 $NO_CHECK{$pkg} = !!$args{no_check} if exists $args{no_check};
26              
27             {
28             # allow importing package to use attribute
29 14     14   1696 no strict qw(refs);
  14         37  
  14         3983  
  20         38  
30 20         98 my $MODIFY_CODE_ATTRIBUTES = \&Attribute::Handlers::UNIVERSAL::MODIFY_CODE_ATTRIBUTES;
31 20         42 *{"${pkg}::MODIFY_CODE_ATTRIBUTES"} = $MODIFY_CODE_ATTRIBUTES;
  20         130  
32 20         99 *{"${pkg}::_ATTR_CODE_Return"} = $class->can('Return');
  20         86  
33             }
34              
35             #
36             # How to install meta information
37             # 1. At the BEGIN phase, write down the meta information via the `Return` attribute.
38             # 2. At the compile phase, install the meta information in bulk via this `import` subroutine.
39             #
40             # In short,
41             # once Function::Return#import is compiled, the meta-information can be retrieved.
42             #
43             # The Reason Why?
44             #
45             # First NG CASE:
46             # At the **CHECK** phase, write down the meta information via the Return attribute. (Attribute::Handler's default case)
47             # Then, cannot support lazy load.
48             # Ref: case_lazy_load.t
49             #
50             # Second NG CASE:
51             # At the compile phase, install the meta information in **each** via this **Return** attribute.
52             # Then, unable to retrieve meta information for Function::Return from places that are compiled before the Return attribute.
53             # Ref: case_load_and_get_meta.t
54             #
55             on_scope_end {
56 20     20   87503 while (my $args = shift @RETURN_ARGS) {
57 36         116 my ($pkg, $sub, $types) = @$args;
58 36 100 100     286 my $no_check = exists $NO_CHECK{$pkg} ? $NO_CHECK{$pkg} : ($ENV{FUNCTION_RETURN_NO_CHECK}//0);
59              
60 36 100       135 if ($no_check) {
61 9         32 $class->_register_submeta($pkg, $sub, $types);
62             }
63             else {
64 27         109 $class->_register_submeta_and_install($pkg, $sub, $types);
65             }
66             }
67 20         143 };
68              
69 20         1238 return;
70             }
71              
72             sub Return :ATTR(CODE,BEGIN) {
73 36     36 1 643729 my $class = __PACKAGE__;
74 36         128 my ($pkg, undef, $sub, undef, $types) = @_;
75 36   100     180 $types //= [];
76              
77 36         112 push @RETURN_ARGS => [$pkg, $sub, $types];
78 36         95 return;
79 14     14   145 }
  14         64  
  14         139  
80              
81             sub meta {
82 14     14 1 49041 my ($sub) = @_;
83 14         66 Sub::Meta::Library->get($sub);
84             }
85              
86             sub wrap_sub {
87 42     42 1 19207 my ($class, $sub, $types) = @_;
88              
89 42         138 my $meta = Sub::Meta->new(sub => $sub);
90 42         5735 my $shortname = $meta->subname;
91              
92             { # check type
93 42         352 my $file = $meta->file;
  42         109  
94 42         282 my $line = $meta->line;
95 42         215 for my $type (@$types) {
96 44         167 for (qw/check get_message/) {
97 87 100       620 die "Invalid type: $type. require `$_` method at $file line $line.\n"
98             unless $type->can($_)
99             }
100             }
101             }
102              
103 41         271 my @src;
104 41 100       160 push @src => sprintf('_croak "Required list context in fun %s because of multiple return values function" if !wantarray;', $shortname) if @$types > 1;
105              
106             # force LIST context.
107 41         88 push @src => 'my @ret = &Scope::Upper::uplevel($sub, @_, &Scope::Upper::CALLER(0));';
108              
109             # return Empty List
110 41 100       105 push @src => 'return if !@ret;' if @$types == 0;
111              
112             # check count
113 41 100       219 push @src => sprintf(q|_croak "Too few return values for fun %s (expected %s, got @{[map { defined $_ ? $_ : 'undef' } @ret]})" if @ret < %d;|,
114             $shortname, "@$types", scalar @$types) if @$types > 0;
115              
116 41         610 push @src => sprintf(q|_croak "Too many return values for fun %s (expected %s, got @{[map { defined $_ ? $_ : 'undef' } @ret]})" if @ret > %d;|,
117             $shortname, "@$types", scalar @$types);
118              
119             # type check
120 41         399 for my $i (0 .. $#$types) {
121 43         204 push @src => sprintf(q|_croak "Invalid return in fun %s: return %d: @{[$types->[%d]->get_message($ret[%d])]}" unless $types->[%d]->check($ret[%d]);|, $shortname, $i, $i, $i, $i,$i)
122             }
123              
124 41 100       121 push @src => 'return @ret;' if @$types > 1;
125 41 100       121 push @src => 'return $ret[0];' if @$types == 1;
126              
127 41         155 my $src = join "\n", @src;
128 41 100   6   10153 my $code = eval "sub { $src }"; ## no critic
  6 100   5   4787  
  6 50   1   183  
  1 50   1   7  
  1 100   1   3  
  4 0   0   28  
  1 100   3   626  
  1 0   3   26  
  4 50   3   36  
  2 100       62  
  1 50       102  
  4 0       960  
  4 50       121  
  1 0       10  
  0 50       0  
  3 50       15  
  1 0       959  
  1 50       30  
  4 0       36  
  2 50       39  
  3 50       177  
  1 0       826  
  1 0       27  
  0 0       0  
  0 100       0  
  1 0       5  
  0 50       0  
  0 0       0  
  1 50       10  
  0 50       0  
  1 50       86  
  1 100       535  
  1 50       28  
  0 50       0  
  0 0       0  
  1 0       5  
  0 0       0  
  0 0       0  
  1 100       6  
  1 0       47  
  0 50       0  
  0 100       0  
  0 50       0  
  0 0       0  
  0 0       0  
  0         0  
  3         3388  
  1         10  
  1         31  
  0         0  
  0         0  
  1         4  
  0         0  
  0         0  
  1         16  
  0         0  
  1         43  
  0         0  
  1         32  
  3         2496  
  1         10  
  1         26  
  1         3  
  1         11  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  3         2722  
  1         10  
  1         27  
  0         0  
  0         0  
  1         5  
  1         2  
  3         17  
  0            
  0            
  0            
  0            
  0            
129 41         358 return $code;
130             }
131              
132             sub _croak {
133 27     27   9219 my (undef, $file, $line) = caller 1;
134 27         481 die @_, " at $file line $line.\n"
135             }
136              
137             sub _register_submeta {
138 9     9   24 my ($class, $pkg, $sub, $types) = @_;
139              
140 9         34 my $meta = Sub::Meta->new(sub => $sub, stashname => $pkg);
141 9         1469 $meta->set_returns(list => $types);
142              
143 9 100       198 if (my $materials = Sub::Meta::Finder::FunctionParameters::find_materials($sub)) {
144 2         862 $meta->set_is_method($materials->{is_method});
145 2         14 $meta->set_parameters($materials->{parameters});
146             }
147              
148 9         325 Sub::Meta::Library->register($sub, $meta);
149 9         277 return;
150             }
151              
152             sub _register_submeta_and_install {
153 27     27   69 my ($class, $pkg, $sub, $types) = @_;
154              
155 27         209 my $original_meta = Sub::Meta->new(sub => $sub);
156 27         5034 my $wrapped = $class->wrap_sub($sub, $types);
157              
158 27         129 my $meta = Sub::Meta->new(sub => $wrapped, stashname => $pkg);
159 27         4321 $meta->set_returns(list => $types);
160              
161 27 100       746 if (my $materials = Sub::Meta::Finder::FunctionParameters::find_materials($sub)) {
162 4         10432 $meta->set_is_method($materials->{is_method});
163 4         35 $meta->set_parameters($materials->{parameters});
164             }
165              
166 27         1006 $meta->apply_meta($original_meta);
167 27         5437 Sub::Meta::Library->register($wrapped, $meta);
168              
169             {
170 14     14   15090 no strict qw(refs);
  14         65  
  14         672  
  27         758  
171 14     14   117 no warnings qw(redefine);
  14         46  
  14         1747  
172 27         44 *{$meta->fullname} = $wrapped;
  27         70  
173             }
174 27         1059 return;
175             }
176              
177             1;
178             __END__