From 5d86669cd3277e2c5426f20166ac4de014c289f9 Mon Sep 17 00:00:00 2001 From: Toby Inkster Date: Tue, 8 Nov 2022 18:24:58 +0000 Subject: [PATCH] Sub::HandlesVia::CodeGenerator now has a generator_for_prelude to add extra code into generated methods; fixes #8 --- lib/Sub/HandlesVia/CodeGenerator.pm | 128 ++++++++++++-------- lib/Sub/HandlesVia/CodeGenerator.pm.mite.pm | 62 ++++++++-- lib/Sub/HandlesVia/Handler.pm.mite.pm | 8 +- t/15preludes.t | 36 ++++++ 4 files changed, 167 insertions(+), 67 deletions(-) create mode 100644 t/15preludes.t diff --git a/lib/Sub/HandlesVia/CodeGenerator.pm b/lib/Sub/HandlesVia/CodeGenerator.pm index 254b51e..1907474 100644 --- a/lib/Sub/HandlesVia/CodeGenerator.pm +++ b/lib/Sub/HandlesVia/CodeGenerator.pm @@ -167,6 +167,15 @@ has generator_for_error => ( default_is_trusted => true, ); +has generator_for_prelude => ( + is => ro, + isa => 'CodeRef', + builder => sub { + return sub { '' }; + }, + default_is_trusted => true, +); + has method_installer => ( is => rw, isa => 'CodeRef', @@ -212,7 +221,7 @@ my $REASONABLE_SCALAR = qr/^ my @generatable_things = qw( slot get set default arg args argc currying usage_string self - type_assertion error + type_assertion error prelude ); for my $thing ( @generatable_things ) { @@ -372,6 +381,7 @@ sub _generate_ec_args_for_handler { ); $self ->_handle_sigcheck( @args ) # check method sigs + ->_handle_prelude( @args ) # insert any prelude ->_handle_shiftself( @args ) # $self = shift ->_handle_currying( @args ) # push curried values to @_ ->_handle_additional_validation( @args ) # additional type checks @@ -401,56 +411,6 @@ sub _generate_ec_args_for_handler { }; } -sub _handle_shiftself { - my ( $self, $method_name, $handler, $env, $code, $state ) = @_; - - # Handlers which use @ARG will benefit from shifting $self - # off @_, but for other handlers, this will just slow compilation - # down (but not much). - # - return $self - unless $handler->curried || $handler->prefer_shift_self; - - # Shift off the invocant. - # - push @$code, 'my $shv_self=shift;'; - - $self->_add_generator_override( - - # Override $ARG[$n] because the array has been reindexed. - # - arg => sub { my ($gen, $n) = @_; $gen->generate_arg( $n - 1 ) }, - - # Overrride @ARG to point to the whole array. This is the - # real speed-up! - # - args => sub { '@_' }, - - # Override #ARG to no longer subtract 1. - # - argc => sub { 'scalar(@_)' }, - - # $SELF is now '$shv_self'. - # - self => sub { '$shv_self' }, - - # The default currying callback will splice the list into - # @_ at index 1. Instead unshift the list at the start of @_. - # - currying => sub { - my ($gen, $list) = @_; - "CORE::unshift(\@_, $list);"; - }, - ); - - # Getter was cached in $state and needs update. - # - $state->{getter} = $self->generate_get; - $state->{shifted_self} = true; - - return $self; -} - sub _handle_sigcheck { my ( $self, $method_name, $handler, $env, $code, $state ) = @_; @@ -519,6 +479,64 @@ sub _handle_sigcheck { return $self; } +sub _handle_prelude { + my ( $self, $method_name, $handler, $env, $code, $state ) = @_; + + push @$code, $self->generate_prelude(); + + return $self; +} + +sub _handle_shiftself { + my ( $self, $method_name, $handler, $env, $code, $state ) = @_; + + # Handlers which use @ARG will benefit from shifting $self + # off @_, but for other handlers, this will just slow compilation + # down (but not much). + # + return $self + unless $handler->curried || $handler->prefer_shift_self; + + # Shift off the invocant. + # + push @$code, 'my $shv_self=shift;'; + + $self->_add_generator_override( + + # Override $ARG[$n] because the array has been reindexed. + # + arg => sub { my ($gen, $n) = @_; $gen->generate_arg( $n - 1 ) }, + + # Overrride @ARG to point to the whole array. This is the + # real speed-up! + # + args => sub { '@_' }, + + # Override #ARG to no longer subtract 1. + # + argc => sub { 'scalar(@_)' }, + + # $SELF is now '$shv_self'. + # + self => sub { '$shv_self' }, + + # The default currying callback will splice the list into + # @_ at index 1. Instead unshift the list at the start of @_. + # + currying => sub { + my ($gen, $list) = @_; + "CORE::unshift(\@_, $list);"; + }, + ); + + # Getter was cached in $state and needs update. + # + $state->{getter} = $self->generate_get; + $state->{shifted_self} = true; + + return $self; +} + # Insert code into method for currying. # sub _handle_currying { @@ -905,6 +923,14 @@ value meets the type constraint, with coercion if appropriate. Called as a method and passed a Perl string which is an expression evaluating to an error message. Generates code to throw the error. +=head2 C B<< CodeRef >> + +By default is a coderef returning the empty string. Can be used to generate +some additional statements which will be inserted near the top of the +method being generated. (Typically after parameter checks but before +doing anything serious.) This can be used to unlock a read-only attribute, +for example. + =head2 C B Indicates wheter the code generated by C diff --git a/lib/Sub/HandlesVia/CodeGenerator.pm.mite.pm b/lib/Sub/HandlesVia/CodeGenerator.pm.mite.pm index c1c3622..558d30b 100644 --- a/lib/Sub/HandlesVia/CodeGenerator.pm.mite.pm +++ b/lib/Sub/HandlesVia/CodeGenerator.pm.mite.pm @@ -410,8 +410,28 @@ $self->{"generator_for_error"} = $value; }; + # Attribute generator_for_prelude (type: CodeRef) + # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 176 + do { + my $value = exists( $args->{"generator_for_prelude"} ) + ? ( + ( + do { + + package Sub::HandlesVia::Mite; + ref( $args->{"generator_for_prelude"} ) eq 'CODE'; + } + ) ? $args->{"generator_for_prelude"} : croak( + "Type check failed in constructor: %s should be %s", + "generator_for_prelude", "CodeRef" + ) + ) + : $self->_build_generator_for_prelude; + $self->{"generator_for_prelude"} = $value; + }; + # Attribute method_installer (type: CodeRef) - # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 170 + # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 179 if ( exists $args->{"method_installer"} ) { do { @@ -424,26 +444,26 @@ } # Attribute is_method - # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 180 + # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 189 $self->{"is_method"} = ( exists( $args->{"is_method"} ) ? $args->{"is_method"} : "1" ); # Attribute get_is_lvalue - # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 185 + # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 194 $self->{"get_is_lvalue"} = ( exists( $args->{"get_is_lvalue"} ) ? $args->{"get_is_lvalue"} : "" ); # Attribute set_checks_isa - # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 190 + # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 199 $self->{"set_checks_isa"} = ( exists( $args->{"set_checks_isa"} ) ? $args->{"set_checks_isa"} : "" ); # Attribute set_strictly - # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 195 + # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 204 $self->{"set_strictly"} = ( exists( $args->{"set_strictly"} ) ? $args->{"set_strictly"} : "1" ); @@ -452,7 +472,7 @@ # Unrecognized parameters my @unknown = grep not( -/\A(?:attribute(?:_spec)?|coerce|env|ge(?:nerator_for_(?:arg[cs]?|currying|default|error|get|s(?:e(?:lf|t)|lot)|type_assertion|usage_string)|t_is_lvalue)|is(?:_method|a)|method_installer|s(?:andboxing_package|et_(?:checks_isa|strictly))|t(?:arget|oolkit))\z/ +/\A(?:attribute(?:_spec)?|coerce|env|ge(?:nerator_for_(?:arg[cs]?|currying|default|error|get|prelude|s(?:e(?:lf|t)|lot)|type_assertion|usage_string)|t_is_lvalue)|is(?:_method|a)|method_installer|s(?:andboxing_package|et_(?:checks_isa|strictly))|t(?:arget|oolkit))\z/ ), keys %{$args}; @unknown and croak( @@ -493,7 +513,7 @@ && eval { require Class::XSAccessor; Class::XSAccessor->VERSION("1.19") }; # Accessors for _override - # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 175 + # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 184 if ($__XS) { Class::XSAccessor->import( chained => 1, @@ -695,6 +715,24 @@ }; } + # Accessors for generator_for_prelude + # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 176 + if ($__XS) { + Class::XSAccessor->import( + chained => 1, + "getters" => { "generator_for_prelude" => "generator_for_prelude" }, + ); + } + else { + *generator_for_prelude = sub { + @_ == 1 + or croak( +'Reader "generator_for_prelude" usage: $self->generator_for_prelude()' + ); + $_[0]{"generator_for_prelude"}; + }; + } + # Accessors for generator_for_self # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 128 if ($__XS) { @@ -788,7 +826,7 @@ } # Accessors for get_is_lvalue - # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 185 + # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 194 if ($__XS) { Class::XSAccessor->import( chained => 1, @@ -804,7 +842,7 @@ } # Accessors for is_method - # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 180 + # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 189 if ($__XS) { Class::XSAccessor->import( chained => 1, @@ -834,7 +872,7 @@ } # Accessors for method_installer - # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 170 + # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 179 sub method_installer { @_ > 1 ? do { @@ -866,7 +904,7 @@ } # Accessors for set_checks_isa - # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 190 + # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 199 if ($__XS) { Class::XSAccessor->import( chained => 1, @@ -883,7 +921,7 @@ } # Accessors for set_strictly - # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 195 + # has declaration, file lib/Sub/HandlesVia/CodeGenerator.pm, line 204 if ($__XS) { Class::XSAccessor->import( chained => 1, diff --git a/lib/Sub/HandlesVia/Handler.pm.mite.pm b/lib/Sub/HandlesVia/Handler.pm.mite.pm index 48c4f73..08146e9 100644 --- a/lib/Sub/HandlesVia/Handler.pm.mite.pm +++ b/lib/Sub/HandlesVia/Handler.pm.mite.pm @@ -1412,7 +1412,7 @@ } # Attribute name (type: Str) - # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 281 + # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 282 croak "Missing key in constructor: name" unless exists $args->{"name"}; do { @@ -1444,7 +1444,7 @@ && eval { require Class::XSAccessor; Class::XSAccessor->VERSION("1.19") }; # Accessors for name - # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 281 + # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 282 if ($__XS) { Class::XSAccessor->import( chained => 1, @@ -1978,7 +1978,7 @@ } # Attribute delegated_coderef (type: CodeRef) - # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 302 + # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 303 croak "Missing key in constructor: delegated_coderef" unless exists $args->{"delegated_coderef"}; do { @@ -2008,7 +2008,7 @@ && eval { require Class::XSAccessor; Class::XSAccessor->VERSION("1.19") }; # Accessors for delegated_coderef - # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 302 + # has declaration, file lib/Sub/HandlesVia/Handler.pm, line 303 if ($__XS) { Class::XSAccessor->import( chained => 1, diff --git a/t/15preludes.t b/t/15preludes.t new file mode 100644 index 0000000..5a477c2 --- /dev/null +++ b/t/15preludes.t @@ -0,0 +1,36 @@ +use strict; +use warnings; +use Test::More; + +use Sub::HandlesVia::CodeGenerator; +use Sub::HandlesVia::HandlerLibrary::Array; + +my $gen = 'Sub::HandlesVia::CodeGenerator'->new( + toolkit => __PACKAGE__, + target => 'My::Class', + attribute => 'attr', + env => {}, + coerce => !!0, + generator_for_slot => sub { my $self = shift->generate_self; "$self\->{attr}" }, + generator_for_get => sub { my $self = shift->generate_self; "$self\->{attr}" }, + generator_for_set => sub { my $self = shift->generate_self; "( $self\->{attr} = @_ )" }, + get_is_lvalue => !!0, + set_checks_isa => !!1, + set_strictly => !!1, + generator_for_default => sub { 'undef' }, + generator_for_prelude => sub { 'my $GUARD = undef;' }, +); + +my $push = 'Sub::HandlesVia::HandlerLibrary::Array'->get_handler( 'push' ); +my $ec_args = $gen->_generate_ec_args_for_handler( 'my_push', $push ); +my $coderef = $gen->generate_coderef_for_handler( 'my_push', $push ); + +my ( $found ) = grep /GUARD/, @{ $ec_args->{source} }; +is( $found, 'my $GUARD = undef;' ); + +my $foo = bless { attr => [] }, 'My::Class'; +$foo->$coderef( 1, 2, 3 ); +$foo->$coderef( 4 ); +is_deeply( $foo->{attr}, [1..4] ); + +done_testing; \ No newline at end of file