File Coverage

blib/lib/Sub/HandlesVia/CodeGenerator.pm
Criterion Covered Total %
statement 206 219 94.0
branch 62 76 81.5
condition 45 53 84.9
subroutine 46 48 95.8
pod 3 4 75.0
total 362 400 90.5


line stmt bran cond sub pod time code
1 94     30525   109965 use 5.008;
  94         440  
2 94     94   624 use strict;
  94         277  
  94         2442  
3 94     94   601 use warnings;
  94         268  
  94         7738  
4              
5             package Sub::HandlesVia::CodeGenerator;
6              
7             our $AUTHORITY = 'cpan:TOBYINK';
8             our $VERSION = '0.046';
9              
10 94     94   1316 use Sub::HandlesVia::Mite -all;
  94         308  
  94         1497  
11              
12             has toolkit => (
13             is => ro,
14             );
15              
16             has target => (
17             is => ro,
18             );
19              
20             has attribute => (
21             is => ro,
22             );
23              
24             has attribute_spec => (
25             is => ro,
26             isa => 'HashRef',
27             );
28              
29             has isa => (
30             is => ro,
31             );
32              
33             has coerce => (
34             is => ro,
35             isa => 'Bool',
36             );
37              
38             has env => (
39             is => ro,
40             isa => 'HashRef',
41             default => \ '{}',
42             default_is_trusted => true,
43             );
44              
45             has sandboxing_package => (
46             is => ro,
47             isa => 'Str|Undef',
48             default => sprintf( '%s::__SANDBOX__', __PACKAGE__ ),
49             default_is_trusted => true,
50             );
51              
52             has [ 'generator_for_slot', 'generator_for_get', 'generator_for_set', 'generator_for_default' ] => (
53             is => ro,
54             isa => 'CodeRef',
55             );
56              
57             has generator_for_args => (
58             is => ro,
59             isa => 'CodeRef',
60             builder => sub {
61             return sub {
62 134     134   724 '@_[1..$#_]';
63 346     346   2138 };
64             },
65             default_is_trusted => true,
66             );
67              
68             has generator_for_arg => (
69             is => ro,
70             isa => 'CodeRef',
71             builder => sub {
72             return sub {
73 4587 50   4587   10553 @_==2 or die;
74 4587         7977 my $n = pop;
75 4587         20306 "\$_[$n]";
76 346     346   1945 };
77             },
78             default_is_trusted => true,
79             );
80              
81             has generator_for_argc => (
82             is => ro,
83             isa => 'CodeRef',
84             builder => sub {
85             return sub {
86 472     472   2278 '(@_-1)';
87 346     346   1650 };
88             },
89             default_is_trusted => true,
90             );
91              
92             has generator_for_currying => (
93             is => ro,
94             isa => 'CodeRef',
95             builder => sub {
96             return sub {
97 0 0   0   0 @_==2 or die;
98 0         0 my $arr = pop;
99 0         0 "splice(\@_,1,0,$arr);";
100 346     346   1929 };
101             },
102             default_is_trusted => true,
103             );
104              
105             has generator_for_usage_string => (
106             is => ro,
107             isa => 'CodeRef',
108             builder => sub {
109             return sub {
110 2661 50   2661   6459 @_==3 or die;
111 2661         4041 shift;
112 2661         4323 my $method_name = shift;
113 2661         4236 my $guts = shift;
114 2661         21876 "\$instance->$method_name($guts)";
115 346     346   1997 };
116             },
117             default_is_trusted => true,
118             );
119              
120             has generator_for_self => (
121             is => ro,
122             isa => 'CodeRef',
123             builder => sub {
124             return sub {
125 5398     5398   18527 '$_[0]';
126 346     346   1662 };
127             },
128             default_is_trusted => true,
129             );
130              
131             has generator_for_type_assertion => (
132             is => ro,
133             isa => 'CodeRef',
134             builder => sub {
135             return sub {
136 790     790   2013 my ( $gen, $env, $type, $varname ) = @_;
137 790         1337 my $i = 0;
138 790         3166 my $type_varname = sprintf '$shv_type_constraint_%d', $type->{uniq};
139 790         2165 $env->{$type_varname} = \$type;
140 790 100 100     2654 if ( $gen->coerce and $type->has_coercion ) {
141 8 50       106 if ( $type->coercion->can_be_inlined ) {
142 8         758 return sprintf '%s=%s;%s;',
143             $varname,
144             $type->coercion->inline_coercion($varname),
145             $type->inline_assert( $varname, $type_varname );
146             }
147             else {
148 0         0 return sprintf '%s=%s->assert_coerce(%s);',
149             $varname, $type_varname, $varname;
150             }
151             }
152 782         3711 return $type->inline_assert( $varname, $type_varname );
153 346     346   2397 };
154             },
155             default_is_trusted => true,
156             );
157              
158             has generator_for_error => (
159             is => ro,
160             isa => 'CodeRef',
161             builder => sub {
162             return sub {
163 2746     2746   6272 my ( $gen, $error ) = @_;
164 2746         9631 sprintf 'do { require Carp; Carp::croak(%s) }', $error;
165 346     346   1948 };
166             },
167             default_is_trusted => true,
168             );
169              
170             has generator_for_prelude => (
171             is => ro,
172             isa => 'CodeRef',
173             builder => sub {
174 2988     2988   9960 return sub { '' };
  1601         5325  
175             },
176             default_is_trusted => true,
177             );
178              
179             has method_installer => (
180             is => rw,
181             isa => 'CodeRef',
182             );
183              
184             has _override => (
185             is => rw,
186             init_arg => undef,
187             );
188              
189             has is_method => (
190             is => ro,
191             default => true,
192             );
193              
194             has get_is_lvalue => (
195             is => ro,
196             default => false,
197             );
198              
199             has set_checks_isa => (
200             is => ro,
201             default => false,
202             );
203              
204             has set_strictly => (
205             is => ro,
206             default => true,
207             );
208              
209             my $REASONABLE_SCALAR = qr/^
210             \$ # scalar access
211             [^\W0-9]\w* # normal-looking variable name (including $_)
212             (?: # then...
213             (?:\-\>)? # dereference maybe
214             [\[\{] # opening [ or {
215             [\'\"]? # quote maybe
216             \w+ # word characters (includes digits)
217             [\'\"]? # quote maybe
218             [\]\}] # closing ] or }
219             ){0,3} # ... up to thrice
220             $/x;
221              
222             my @generatable_things = qw(
223             slot get set default arg args argc currying usage_string self
224             type_assertion error prelude
225             );
226              
227             for my $thing ( @generatable_things ) {
228             my $generator = "generator_for_$thing";
229             my $method_name = "generate_$thing";
230             my $method = sub {
231 37611     37611   96746 my $gen = shift;
232 37611         55196 local ${^GENERATOR} = $gen;
233            
234 37611 100       49333 if ( @{ $gen->_override->{$thing} || [] } ) {
  37611 100       139292  
235 8577         12609 my $coderef = pop @{ $gen->_override->{$thing} };
  8577         18425  
236             my $guard = guard {
237 8577   50 8577   12407 push @{ $gen->_override->{$thing} ||= [] }, $coderef;
  8577         59677  
238 8577         41362 };
239 8577         21459 return $gen->$coderef( @_ );
240             }
241            
242 29034         101968 return $gen->$generator->( $gen, @_ );
243             };
244 94     94   115014 no strict 'refs';
  94         294  
  94         51390  
245             *$method_name = $method;
246             }
247              
248             sub attribute_name {
249 3     3 0 5 my $self = shift;
250 3         19 my $attr = $self->attribute;
251            
252 3 50       17 return $attr
253             if !ref $attr;
254            
255 0 0       0 return sprintf '$instance->%s', $attr->[0]
256             if ref($attr) eq 'ARRAY';
257            
258 0         0 return '$attribute_value';
259             }
260              
261             sub _start_overriding_generators {
262 4246     4246   7066 my $self = shift;
263 4246         14166 $self->_override( {} );
264             return guard {
265 4246     4246   32533 $self->_override( {} );
266 4246         23486 };
267             }
268              
269             {
270             my %generatable_thing = map +( $_ => 1 ), @generatable_things;
271            
272             sub _add_generator_override {
273 3089     3089   11437 my ( $self, %overrides ) = @_;
274 3089         11622 while ( my ( $key, $value ) = each %overrides ) {
275 11200 100       22763 next if !defined $value;
276 10928 100       24375 next if !$generatable_thing{$key};
277 8916   100     12013 push @{ $self->_override->{$key} ||= [] }, $value;
  8916         47773  
278             }
279 3089         7374 return $self;
280             }
281             }
282              
283             sub generate_and_install_method {
284 4244     4244 1 8926 my ( $self, $method_name, $handler ) = @_;
285            
286 4244         11449 $self->install_method(
287             $method_name,
288             $self->generate_coderef_for_handler( $method_name, $handler ),
289             );
290             }
291              
292             {
293             my $sub_rename;
294             if ( eval { require Sub::Util } ) {
295             $sub_rename = Sub::Util->can('set_subname');
296             }
297             elsif ( eval { require Sub::Name } ) {
298             $sub_rename = Sub::Name->can('subname');
299             }
300            
301             sub install_method {
302 4244     4244 1 1862237 my ( $self, $method_name, $coderef ) = @_;
303 4244         14129 my $target = $self->target;
304            
305 4244 50       14272 eval {
306 4244         34981 $coderef = $sub_rename->( "$target\::$method_name", $coderef )
307             } if ref $sub_rename;
308            
309 4244 100       16964 if ( $self->method_installer ) {
310 2593         6748 $self->method_installer->( $method_name, $coderef );
311             }
312             else {
313 94     94   1017 no strict 'refs';
  94         356  
  94         231350  
314 1651         2886 *{"$target\::$method_name"} = $coderef;
  1651         12110  
315             }
316             }
317             }
318              
319             sub generate_coderef_for_handler {
320 4245     4245 1 7791 my ( $self, $method_name, $handler ) = @_;
321            
322 4245         9538 my $ec_args = $self->_generate_ec_args_for_handler( $method_name, $handler );
323            
324             # warn "#### $method_name";
325             # warn join("\n", @{$ec_args->{source}});
326             # for my $key (sort keys %{$ec_args->{environment}}) {
327             # warn ">> $key : ".ref($ec_args->{environment}{$key});
328             # if ( ref($ec_args->{environment}{$key}) eq 'REF' and ref(${$ec_args->{environment}{$key}}) eq 'CODE' ) {
329             # require B::Deparse;
330             # warn B::Deparse->new->coderef2text(${$ec_args->{environment}{$key}});
331             # }
332             # }
333            
334 4245         24241 require Eval::TypeTiny;
335 4245         19513 Eval::TypeTiny::eval_closure( %$ec_args );
336             }
337              
338             sub _generate_ec_args_for_handler {
339 4246     4246   7562 my ( $self, $method_name, $handler ) = @_;
340            
341             # Later on, we might need to override the generators for
342             # arg, argc, args, set, etc.
343             #
344 4246         9028 my $guard = $self->_start_overriding_generators;
345            
346             # Make a COPY of $self->env!
347             #
348 4246         7574 my $env = { %{$self->env} };
  4246         14557  
349            
350             # Preamble code.
351             #
352 4246         9874 my $code = [
353             'sub {',
354             ];
355            
356 4246 50       24673 push @$code, sprintf( 'package %s;', $self->sandboxing_package )
357             if $self->sandboxing_package;
358              
359             # Need to maintain state between following method calls. A proper
360             # object might be nice, but a hashref will do for now.
361             #
362 4246         14531 my $state = {
363             signature_check_needed => true, # hasn't been done yet
364             final_type_check_needed => $handler->is_mutator,
365             getter => scalar($self->generate_get),
366             getter_is_lvalue => $self->get_is_lvalue,
367             template_wrapper => undef, # nothing yet
368             add_later => undef, # nothing yet
369             shifted_self => false,
370             };
371              
372             # use Hash::Util qw( lock_ref_keys );
373             # lock_ref_keys( $state );
374            
375 4246         25963 my @args = (
376             $method_name, # Intended name for the coderef being generated
377             $handler, # Info about the functionality being delegated
378             $env, # Variables which need to be closed over
379             $code, # Lines of code in the method
380             $state, # Shared state while building method. (Minimal!)
381             );
382 4246         10855 $self
383             ->_handle_sigcheck( @args ) # check method sigs
384             ->_handle_prelude( @args ) # insert any prelude
385             ->_handle_shiftself( @args ) # $self = shift
386             ->_handle_currying( @args ) # push curried values to @_
387             ->_handle_additional_validation( @args ) # additional type checks
388             ->_handle_getter_code( @args ) # optimize calling getter
389             ->_handle_setter_code( @args ) # make calling setter safer
390             ->_handle_template( @args ) # perform code substitutes
391             ->_handle_chaining( @args ); # return $self if requested
392            
393             # Postamble code. Can't really do much here because the template
394             # might want to be able to return something.
395             #
396 4246         9790 push @$code, "}";
397            
398             # Allow the handler to inject variables into the environment.
399             # Rarely needed.
400             #
401 4246         14894 $handler->_tweak_env( $env );
402            
403             return {
404 4246   50     44991 source => $code,
405             environment => $env,
406             description => sprintf(
407             "%s=%s",
408             $method_name || '__ANON__',
409             $handler->name,
410             ),
411             };
412             }
413              
414             sub _handle_sigcheck {
415 4246     4246   9153 my ( $self, $method_name, $handler, $env, $code, $state ) = @_;
416              
417             # If there's a proper signature for the method...
418             #
419 4246 100       6307 if ( @{ $handler->signature || [] } ) {
  4246 100       18135  
420            
421             # Generate code using Type::Params to check the signature.
422             # We also need to close over the signature.
423             #
424 1585         9320 require Type::Params;
425 1585         4816 unshift @$code, 'my $__sigcheck;';
426 1585         3885 $env->{'@__sig'} = $handler->signature;
427 1585 50       3359 if ( $state->{shifted_self} ) {
428 0         0 push @$code, '$__sigcheck||=Type::Params::compile(@__sig);@_=&$__sigcheck;';
429             }
430             else {
431 1585         3752 push @$code, '$__sigcheck||=Type::Params::compile(1, @__sig);@_=&$__sigcheck;';
432             }
433            
434             # As we've now inserted a signature check, we can stop worrying
435             # about signature checks.
436             #
437 1585         2929 $state->{signature_check_needed} = 0;
438             }
439             # There is no proper signature, but there's still check the
440             # arity of the method.
441             #
442             else {
443             # What is the arity?
444             #
445 2661   100     7906 my $min_args = $handler->min_args || 0;
446 2661         7451 my $max_args = $handler->max_args;
447            
448 2661         4731 my $plus = 1;
449 2661 50       6486 if ( $state->{shifted_self} ) {
450 0         0 $plus = 0;
451             }
452            
453             # What usage message do we want to print if wrong arity?
454             #
455 2661         8708 my $usg = $self->generate_error( sprintf(
456             ' "Wrong number of parameters; usage: " . %s ',
457             B::perlstring( $self->generate_usage_string( $method_name, $handler->usage ) ),
458             ) );
459            
460             # Insert the check into the code.
461             #
462 2661 100 66     17871 if (defined $min_args and defined $max_args and $min_args==$max_args) {
    100 100        
    100 66        
      66        
463 1810         6846 push @$code, sprintf('@_==%d or %s;', $min_args + $plus, $usg);
464             }
465             elsif (defined $min_args and defined $max_args) {
466 264         1284 push @$code, sprintf('(@_ >= %d and @_ <= %d) or %s;', $min_args + $plus, $max_args + $plus, $usg);
467             }
468             elsif (defined $min_args and $min_args > 0) {
469 187         866 push @$code, sprintf('@_ >= %d or %s;', $min_args + $plus, $usg);
470             }
471            
472             # We are still lacking a proper signature check though, so note
473             # that in the state. The information can be used by
474             # additional_validation coderefs.
475             #
476 2661         6975 $state->{signature_check_needed} = true;
477             }
478            
479 4246         12083 return $self;
480             }
481              
482             sub _handle_prelude {
483 4246     4246   9356 my ( $self, $method_name, $handler, $env, $code, $state ) = @_;
484 4246         9336 push @$code, grep !!$_, $self->generate_prelude();
485 4246         11962 return $self;
486             }
487              
488             sub _handle_shiftself {
489 4246     4246   9121 my ( $self, $method_name, $handler, $env, $code, $state ) = @_;
490              
491             # Handlers which use @ARG will benefit from shifting $self
492             # off @_, but for other handlers, this will just slow compilation
493             # down (but not much).
494             #
495 4246 100 100     20713 return $self
496             unless $handler->curried || $handler->prefer_shift_self;
497              
498             # Shift off the invocant.
499             #
500 1708         4056 push @$code, 'my $shv_self=shift;';
501            
502             $self->_add_generator_override(
503            
504             # Override $ARG[$n] because the array has been reindexed.
505             #
506 2472     2472   6804 arg => sub { my ($gen, $n) = @_; $gen->generate_arg( $n - 1 ) },
  2472         6901  
507            
508             # Overrride @ARG to point to the whole array. This is the
509             # real speed-up!
510             #
511 683     683   2804 args => sub { '@_' },
512            
513             # Override #ARG to no longer subtract 1.
514             #
515 875     875   2817 argc => sub { 'scalar(@_)' },
516            
517             # $SELF is now '$shv_self'.
518             #
519 2636     2636   9623 self => sub { '$shv_self' },
520            
521             # The default currying callback will splice the list into
522             # @_ at index 1. Instead unshift the list at the start of @_.
523             #
524             currying => sub {
525 1403     1403   3452 my ($gen, $list) = @_;
526 1403         6231 "CORE::unshift(\@_, $list);";
527             },
528 1708         20393 );
529            
530             # Getter was cached in $state and needs update.
531             #
532 1708         4232 $state->{getter} = $self->generate_get;
533 1708         7241 $state->{shifted_self} = true;
534            
535 1708         5317 return $self;
536             }
537              
538             # Insert code into method for currying.
539             #
540             sub _handle_currying {
541 4246     4246   9365 my ( $self, $method_name, $handler, $env, $code, $state ) = @_;
542            
543 4246 100       11556 if ( my $curried = $handler->curried ) {
544            
545             # If the curried values are non-simple, we close over an array
546             # called @curry.
547             #
548 1403 100       5322 if ( grep ref, @$curried ) {
549            
550             # Note that generate_currying will generate code that unshifts whatever
551             # parameters it is given onto @_.
552 360         1196 push @$code, $self->generate_currying('@curry');
553 360         1241 $env->{'@curry'} = $curried;
554             }
555             # If it's just strings, numbers, and undef, it should be pretty
556             # trivial to hard-code the values into the generated Perl string.
557             #
558             else {
559 1043         5852 require B;
560             my $values = join(
561             ',',
562 1043 50       2503 map { defined($_) ? B::perlstring($_) : 'undef' } @$curried,
  1559         7148  
563             );
564 1043         4133 push @$code, $self->generate_currying( "($values)" );
565             }
566             }
567            
568 4246         11416 return $self;
569             }
570              
571             sub _handle_additional_validation {
572 4246     4246   8469 my ( $self, $method_name, $handler, $env, $code, $state ) = @_;
573            
574             # If the handler specifies no validation needed, or the attribute
575             # simply has no type check, we don't need to check the type of the
576             # final attribute value.
577             #
578 4246 100 66     34781 if ( $handler->no_validation_needed or not $self->isa ) {
579 177         354 $state->{final_type_check_needed} = false;
580             }
581            
582             # The handler can define some additional validation to be performed
583             # on arguments either now or later, such that if this additional
584             # validation is performed, the type check we were planning later
585             # will be known to be unnecessary.
586             #
587             # An example for this is that is the attribute value is already an
588             # arrayref of numbers, and we're pushing a new value onto it, by checking
589             # up front that the INCOMING value is a number, it becomes unnecessary
590             # to check the whole arrayref contains numbers after the push.
591             #
592             # Not all handlers define an additional_validation coderef to do
593             # this, because in many cases it doesn't make sense to.
594             #
595             # Also if we've already decided a final type check isn't needed, we
596             # can skip this step.
597             #
598 4246 100 100     31991 if ( $state->{final_type_check_needed}
599             and defined $handler->additional_validation ) {
600            
601 1381         4642 my $real_av_method = $handler->_real_additional_validation;
602            
603             # The additional_validation coderef is called as a method and takes
604             # two additional parameters:
605             #
606             my $opt = $handler->$real_av_method(
607             !$state->{signature_check_needed}, # $sig_was_checked
608 1381         5843 $self, # $gen
609             );
610 1381   100     7000 $opt ||= {}; # can return undef
611            
612             # The additional_validation coderef will often generate code which
613             # coerces incoming data, thus moving it from @_ to some other array.
614             # This means that the generators for @ARG, $ARG, etc will need to
615             # need to be overridden to point to the new array.
616             #
617 1381         6139 $self->_add_generator_override( %$opt );
618            
619             # The additional_validation coderef may supply extra variables
620             # to close over.
621             #
622             $env->{$_} = $opt->{env}{$_}
623 1381 100       2475 for keys %{ $opt->{env} || {} };
  1381         6646  
624            
625             # The additional_validation coderef will normally generate
626             # new code.
627             #
628 1381 100       5335 if ( defined $opt->{code} ) {
629            
630             # Code can be inserted into the generated method straight away,
631             # or may need to be inserted in a special placeholder position
632             # later.
633             #
634             $opt->{add_later}
635             ? ( $state->{add_later} = $opt->{code} )
636 889 100       2705 : push( @$code, $opt->{code} );
637            
638             # Final type check is often no longer needed.
639             #
640 889   100     5893 $state->{final_type_check_needed} = $opt->{final_type_check_needed} || false;
641             }
642             }
643            
644 4246         11822 return $self;
645             }
646              
647             sub _handle_getter_code {
648 4246     4246   9439 my ( $self, $method_name, $handler, $env, $code, $state ) = @_;
649            
650             # If there's a complicated way to fetch the attribute value (perhaps
651             # involving a lazy builder)...
652             #
653 4246 100       39270 if ( $state->{getter} !~ $REASONABLE_SCALAR ) {
654            
655             # And if it's definitely a reference anyway, then get it straight away,
656             # and store it in $shv_ref_invocant so we don't have to keep doing the
657             # complicated thing.
658             #
659 847 100 100     6659 if ( $handler->name =~ /^(Array|Hash):/ ) {
    100 66        
660 501         1831 push @$code, "my \$shv_ref_invocant = do { $state->{getter} };";
661 501         981 $state->{getter} = '$shv_ref_invocant';
662 501         981 $state->{getter_is_lvalue} = true;
663             }
664            
665             # Alternatively, unless the handler doesn't want us to, or the template
666             # doesn't want to get the attribute value anyway, then we'll do something
667             # similar. Here it can't be used as an lvalue though.
668             #
669             elsif ( $handler->allow_getter_shortcuts
670             and $handler->template.($handler->lvalue_template||'') =~ /\$GET/ ) {
671 343         1308 ( my $g = $state->{getter} ) =~ s/%/%%/g;
672 343         1007 $state->{template_wrapper} = "do { my \$shv_real_invocant = $g; %s }";
673 343         704 $state->{getter} = '$shv_real_invocant';
674             }
675             }
676            
677 4246         12357 return $self;
678             }
679              
680             sub _handle_setter_code {
681 4246     4246   9309 my ( $self, $method_name, $handler, $env, $code, $state ) = @_;
682            
683             # If a type check is needed, but the setter doesn't do type checks,
684             # then override the setter. Now the setter does the type check, so
685             # we no longer need to worry about it.
686             #
687             # XXX: I don't think any of the tests currently exercise this.
688             #
689 4246 50 66     14341 if ( $state->{final_type_check_needed} and not $self->set_checks_isa ) {
690             $self->_add_generator_override( set => sub {
691 0     0   0 my ( $me, $value_code ) = @_;
692 0         0 $me->generate_set( sprintf(
693             'do { my $shv_final_unchecked = %s; %s }',
694             $value_code,
695             $me->generate_type_assertion( $env, $me->isa, '$shv_final_unchecked' ),
696             ) );
697 0         0 } );
698            
699             # In this case we can no longer use the getter as an lvalue, if we
700             # ever could.
701             #
702 0         0 $state->{getter_is_lvalue} = false;
703            
704             # Stop worrying about the final type check. The setter does that now.
705             #
706 0         0 $state->{final_type_check_needed} = false;
707             }
708            
709 4246         10431 return $self;
710             }
711              
712             sub _handle_template {
713 4246     4246   8359 my ( $self, $method_name, $handler, $env, $code, $state ) = @_;
714            
715 4246         6382 my $template;
716            
717             # If the getter is an lvalue, the handler has a special template
718             # for lvalues, we haven't been told to set strictly, and we have taken
719             # care of any type checks, then use the special lvalue template.
720             #
721 4246 100 100     26258 if ( $state->{getter_is_lvalue}
      100        
      100        
722             and $handler->lvalue_template
723             and !$self->set_strictly
724             and !$state->{final_type_check_needed} ) {
725 465         1081 $template = $handler->lvalue_template;
726             }
727             else {
728 3781         8921 $template = $handler->template;
729             }
730            
731             # Perform substitutions of special codes in the template string.
732             #
733 4246         9619 $template =~ s/\$SLOT/$self->generate_slot()/eg;
  2         6  
734 4246         25409 $template =~ s/\$GET/$state->{getter}/g;
735 4246         9889 $template =~ s/\$ATTRNAME/$self->attribute_name()/eg;
  3         16  
736 4246         9657 $template =~ s/\$ARG\[([0-9]+)\]/$self->generate_arg($1)/eg;
  2586         6189  
737 4246         10154 $template =~ s/\$ARG/$self->generate_arg(1)/eg;
  2067         5231  
738 4246         9159 $template =~ s/\#ARG/$self->generate_argc()/eg;
  865         2343  
739 4246         8262 $template =~ s/\@ARG/$self->generate_args()/eg;
  587         1679  
740 4246         7782 $template =~ s/⸨(.+?)⸩/$self->generate_error($1)/eg;
  85         308  
741 4246         14390 $template =~ s/«(.+?)»/$self->generate_set($1)/eg;
  1989         5341  
742 4246         9304 $template =~ s/\$DEFAULT/$self->generate_default($handler)/eg;
  55         220  
743 4246         7241 $template =~ s/\$SELF/$self->generate_self()/eg;
  47         131  
744            
745             # Apply wrapper (if any). This wrapper is given
746             # by _handle_getter_code (sometimes).
747             #
748             $template = sprintf( $state->{template_wrapper}, $template )
749 4246 100       11631 if $state->{template_wrapper};
750            
751             # If validation needs to be added late...
752             #
753             $template =~ s/\"?____VALIDATION_HERE____\"?/$state->{add_later}/
754 4246 100       9928 if defined $state->{add_later};
755            
756 4246         9751 push @$code, $template;
757            
758 4246         15690 return $self;
759             }
760              
761             sub _handle_chaining {
762 4246     4246   9089 my ( $self, $method_name, $handler, $env, $code, $state ) = @_;
763            
764             # Will just insert a string like ';$_[0]' at the end
765             #
766 4246 100       11856 push @$code, ';' . $self->generate_self,
767             if $handler->is_chainable;
768            
769 4246         7266 return $self;
770             }
771              
772             1;
773              
774             __END__
775              
776             =pod
777              
778             =encoding utf-8
779              
780             =head1 NAME
781              
782             Sub::HandlesVia::CodeGenerator - looks at a Handler and generates a string of Perl code for it
783              
784             =head1 DESCRIPTION
785              
786             B<< This module is part of Sub::HandlesVia's internal API. >>
787             It is mostly of interest to people extending Sub::HandlesVia.
788              
789             Sub::HandlesVia toolkits create a code generator for each attribute they're
790             dealing with, and use the code generator to generate Perl code for one or
791             more delegated methods.
792              
793             =head1 CONSTRUCTORS
794              
795             =head2 C<< new( %attributes ) >>
796              
797             Standard Moose-like constructor.
798              
799             =head1 ATTRIBUTES
800              
801             =head2 C<toolkit> B<Object>
802              
803             The toolkit which made this code generator.
804              
805             =head2 C<target> B<< ClassName|RoleName >>
806              
807             The target package for generated methods.
808              
809             =head2 C<sandboxing_package> B<< ClassName|RoleName|Undef >>
810              
811             Package name to use as a sandbox; the default is usually fine.
812              
813             =head2 C<attribute> B<< Str|ArrayRef >>
814              
815             The attribute delegated to.
816              
817             =head2 C<attribute_spec> B<< HashRef >>
818              
819             Informational only.
820              
821             =head2 C<is_method> B<< Bool >>
822              
823             Indicates whether the generated code should be methods rather than functions.
824             This defaults to true, and false isn't really tested or well-defined.
825              
826             =head2 C<env> B<< HashRef >>
827              
828             Variables which need to be closed over when compiling coderefs.
829              
830             =head2 C<isa> B<< Maybe[TypeTiny] >>
831              
832             The type constraint for the attribute.
833              
834             =head2 C<coerce> B<< Bool >>
835              
836             Should the attribute coerce?
837              
838             =head2 C<method_installer> B<CodeRef>
839              
840             A coderef which can be called with C<< $method_name >> and C<< $coderef >>,
841             will install the method. Note that it isn't passed the package to install
842             into (which can be found in C<target>), so that would need to be closed
843             over.
844              
845             =head2 C<generator_for_self> B<< CodeRef >>
846              
847             A coderef which if called, generates a string like C<< '$_[0]' >>.
848              
849             Has a sensible default.
850              
851             All the C<generator_for_XXX> methods are called as methods, so have
852             the code generator object as an invocant.
853              
854             =head2 C<generator_for_slot> B<< CodeRef >>
855              
856             A coderef which if called, generates a string like C<< '$_[0]{attrname}' >>.
857              
858             =head2 C<generator_for_get> B<< CodeRef >>
859              
860             A coderef which if called, generates a string like C<< '$_[0]->attrname' >>.
861              
862             =head2 C<generator_for_set> B<< CodeRef >>
863              
864             A coderef which if called with a parameter, generates a string like
865             C<< "\$_[0]->_set_attrname( $parameter )" >>.
866              
867             =head2 C<generator_for_simple_default> B<< CodeRef >>
868              
869             A coderef which if called with a parameter, generates a string like
870             C<< 'undef' >> or C<< 'q[]' >> or C<< '{}' >>.
871              
872             The parameter is a handler object, which offers a C<default_for_reset>
873             attribute which might be able to provide a useful fallback.
874              
875             =head2 C<generator_for_args> B<< CodeRef >>
876              
877             A coderef which if called, generates a string like C<< '@_[1..$#_]' >>.
878              
879             Has a sensible default.
880              
881             =head2 C<generator_for_argc> B<< CodeRef >>
882              
883             A coderef which if called, generates a string like C<< '$#_' >>.
884              
885             Has a sensible default.
886              
887             =head2 C<generator_for_argc> B<< CodeRef >>
888              
889             A coderef which if called with a parameter, generates a string like
890             C<< "\$_[$parameter + 1]" >>.
891              
892             Has a sensible default.
893              
894             =head2 C<generator_for_currying> B<< CodeRef >>
895              
896             A coderef which if called with a parameter, generates a string like
897             C<< "splice(\@_,1,0,$parameter);" >>.
898              
899             Has a sensible default.
900              
901             =head2 C<generator_for_usage_string> B<< CodeRef >>
902              
903             The default is this coderef:
904              
905             sub {
906             @_==3 or die;
907             shift;
908             my $method_name = shift;
909             my $guts = shift;
910             return "\$instance->$method_name($guts)";
911             }
912              
913             =head2 C<generator_for_type_assertion> B<< CodeRef >>
914              
915             Called as a method and passed a hashref compilation environment, a type
916             constraint, and a variable name. Generates code to assert that the variable
917             value meets the type constraint, with coercion if appropriate.
918              
919             =head2 C<generator_for_error> B<< CodeRef >>
920              
921             Called as a method and passed a Perl string which is an expression evaluating
922             to an error message. Generates code to throw the error.
923              
924             =head2 C<generator_for_prelude> B<< CodeRef >>
925              
926             By default is a coderef returning the empty string. Can be used to generate
927             some additional statements which will be inserted near the top of the
928             method being generated. (Typically after parameter checks but before
929             doing anything serious.) This can be used to unlock a read-only attribute,
930             for example.
931              
932             =head2 C<get_is_lvalue> B<Bool>
933              
934             Indicates wheter the code generated by C<generator_for_get>
935             will be suitable for used as an lvalue.
936              
937             =head2 C<set_checks_isa> B<Bool>
938              
939             Indicates wheter the code generated by C<generator_for_set>
940             will do type checks.
941              
942             =head2 C<set_strictly> B<Bool>
943              
944             Indicates wheter we want to ensure that the setter is always called,
945             and we should not try to bypass it, even if we have an lvalue getter.
946              
947             =head1 METHODS
948              
949             For each C<generator_for_XXX> attribute, there's a corresponding
950             C<generate_XXX> method to actually call the coderef, possibly including
951             additional processing.
952              
953             =head2 C<< generate_and_install_method( $method_name, $handler ) >>
954              
955             Given a handler and a method name, will generate a coderef for the handler
956             and install it into the target package.
957              
958             =head2 C<< generate_coderef_for_handler( $method_name, $handler ) >>
959              
960             As above, but just returns the coderef rather than installs it.
961              
962             =head2 C<< install_method( $method_name, $coderef ) >>
963              
964             Installs a coderef into the target package with the given name.
965              
966             =head1 BUGS
967              
968             Please report any bugs to
969             L<https://github.com/tobyink/p5-sub-handlesvia/issues>.
970              
971             =head1 SEE ALSO
972              
973             L<Sub::HandlesVia>.
974              
975             =head1 AUTHOR
976              
977             Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
978              
979             =head1 COPYRIGHT AND LICENCE
980              
981             This software is copyright (c) 2020, 2022 by Toby Inkster.
982              
983             This is free software; you can redistribute it and/or modify it under
984             the same terms as the Perl 5 programming language system itself.
985              
986             =head1 DISCLAIMER OF WARRANTIES
987              
988             THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
989             WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
990             MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.