File Coverage

lib/MooX/Lsub.pm
Criterion Covered Total %
statement 79 79 100.0
branch 1 2 50.0
condition n/a
subroutine 16 16 100.0
pod n/a
total 96 97 98.9


line stmt bran cond sub pod time code
1 5     5   6205 use 5.008; # utf8
  5         18  
  5         203  
2 5     5   30 use strict;
  5         9  
  5         154  
3 5     5   35 use warnings;
  5         10  
  5         131  
4 5     5   4977 use utf8;
  5         69  
  5         36  
5              
6             package MooX::Lsub;
7              
8             our $VERSION = '0.002000';
9              
10             # ABSTRACT: Very shorthand syntax for bulk lazy builders
11              
12             our $AUTHORITY = 'cpan:KENTNL'; # AUTHORITY
13              
14 5     5   4402 use Eval::Closure qw(eval_closure);
  5         18199  
  5         301  
15 5     5   37 use Carp qw(croak);
  5         10  
  5         268  
16             ## no critic (Capitalization,ProhibitConstantPragma,RequireCheckingReturnValueOfEval);
17 5     5   24 use constant can_haz_subname => eval { require Sub::Util };
  5         10  
  5         10  
  5         4243  
18              
19             ## no critic (TestingAndDebugging::ProhibitNoStrict)
20             sub _get_sub {
21 6     6   12 my ( undef, $target, $subname ) = @_;
22 5     5   1701 no strict 'refs';
  5         9  
  5         353  
23 6         8 return \&{ $target . q[::] . $subname };
  6         26  
24             }
25              
26             sub _set_sub {
27 6     6   14 my ( undef, $target, $subname, $code ) = @_;
28 5     5   25 no strict 'refs';
  5         9  
  5         351  
29 6         7 *{ $target . q[::] . $subname } = $code;
  6         33  
30 6         11 return;
31             }
32              
33             sub _set_sub_named {
34 5     5   55147 my ( undef, $target, $subname, $code ) = @_;
35 5     5   25 no strict 'refs';
  5         7  
  5         2749  
36 5         75 *{ $target . q[::] . $subname } = can_haz_subname ? Sub::Util::set_subname( $target . q[::] . $subname, $code ) : $code;
  5         29  
37 5         113 return;
38             }
39             ## use critic
40             #
41             sub import {
42 6     6   2807 my ( $class, @args ) = @_;
43 6         15 my $target = caller;
44 6         20 my $has = $class->_get_sub( $target, 'has' );
45              
46 6 50       24 croak "No 'has' method in $target. Did you forget to import Moo(se)?" if not $has;
47              
48 6         34 my $lsub_code = $class->_make_lsub(
49             {
50             target => $target,
51             has => $has,
52             options => \@args,
53             },
54             );
55              
56 6         25 $class->_set_sub( $target, 'lsub', $lsub_code );
57              
58 6         354 return;
59             }
60              
61             sub _make_lsub_code {
62 8     8   28 my ( $class, $options ) = @_;
63             ## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars)
64 8         11 my $nl = qq[\n];
65 8         17 my $code = 'sub($$) {' . $nl;
66 8         20 $code .= q[ package ] . $class . q[; ] . $nl;
67 8         16 $code .= q[ my ( $subname, $sub , @extras ) = @_; ] . $nl;
68 8         15 $code .= q[ if ( @extras ) { ] . $nl;
69 8         14 $code .= q[ croak "Too many arguments to 'lsub'. Did you misplace a ';'?"; ] . $nl;
70 8         66 $code .= q[ } ] . $nl;
71 8         16 $code .= q[ if ( not defined $subname or not length $subname or ref $subname ) { ] . $nl;
72 8         15 $code .= q[ croak "Subname must be defined + length + not a ref"; ] . $nl;
73 8         14 $code .= q[ } ] . $nl;
74 8         14 $code .= q[ if ( not 'CODE' eq ref $sub ) { ] . $nl;
75 8         16 $code .= q[ croak "Sub must be a CODE ref"; ] . $nl;
76 8         11 $code .= q[ } ] . $nl;
77 8         66 $code .= q[ $class->_set_sub_named($target, "_build_" . $subname , $sub ); ] . $nl;
78 8         19 $code .= q[ package ] . $options->{'target'} . q[; ] . $nl;
79 8         14 $code .= q[ return $has->( ] . $nl;
80 8         14 $code .= q[ $subname, ] . $nl;
81 8         12 $code .= q[ ( ] . $nl;
82 8         14 $code .= q[ is => 'ro', ] . $nl;
83 8         11 $code .= q[ lazy => 1, ] . $nl;
84 8         11 $code .= q[ builder => '_build_' . $subname, ] . $nl;
85 8         13 $code .= q[ ) ] . $nl;
86 8         9 $code .= q[ ); ] . $nl;
87 8         26 $code .= q[}] . $nl;
88             ## use critic
89 8         18 return $code;
90             }
91              
92             sub _make_lsub {
93 7     7   939 my ( $class, $options ) = @_;
94              
95 7         22 my $code = $class->_make_lsub_code($options);
96              
97 7         49 my $sub = eval_closure(
98             source => $code,
99             environment => {
100             ## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars)
101             '$class' => \$class,
102             '$has' => \$options->{'has'},
103             '$target' => \$options->{'target'},
104             ## use critic
105             },
106             );
107 7         2764 return $sub;
108             }
109              
110             1;
111              
112             __END__
113              
114             =pod
115              
116             =encoding UTF-8
117              
118             =head1 NAME
119              
120             MooX::Lsub - Very shorthand syntax for bulk lazy builders
121              
122             =head1 VERSION
123              
124             version 0.002000
125              
126             =head1 SYNOPSIS
127              
128             use MooX::Lsub;
129              
130             # Shorthand for
131             # has foo => ( is => ro =>, lazy => 1, builder => '_build_foo' );
132             # sub _build_foo { "Hello" }
133              
134             lsub foo => sub { "Hello" };
135              
136             =head1 DESCRIPTION
137              
138             I often want to use a lot of lazy build subs to implement some plumbing, with scope to allow
139             it to be overridden by people who know what they're doing with an injection library like Bread::Board.
140              
141             Usually, the syntax of C<Class::Tiny> is what I use for such things.
142              
143             use Class::Tiny {
144             'a' => sub { },
145             'b' => sub { },
146             };
147              
148             Etc.
149              
150             But switching things to Moo means I usually have to get much uglier, and repeat myself a *lot*.
151              
152             So this module exists as a compromise.
153              
154             Additionally, I always forgot to declare C<use Moo 1.000008> which was the first version of C<Moo> where
155             C<< builder => sub >> worked, and I would invariably get silly test failures in smokers as a consequence.
156              
157             This module avoids such problem entirely, and is tested to work with C<Moo 0.009001>.
158              
159             =head1 AUTHOR
160              
161             Kent Fredric <kentnl@cpan.org>
162              
163             =head1 COPYRIGHT AND LICENSE
164              
165             This software is copyright (c) 2014 by Kent Fredric <kentfredric@gmail.com>.
166              
167             This is free software; you can redistribute it and/or modify it under
168             the same terms as the Perl 5 programming language system itself.
169              
170             =cut