Skip to content

Commit

Permalink
Sub::HandlesVia::CodeGenerator now has a generator_for_prelude to add…
Browse files Browse the repository at this point in the history 
… extra code into generated methods; fixes #8
  • Loading branch information
@tobyink
tobyink committed Nov 8, 2022
1 parent 84cdf17 commit 5d86669
Show file tree
Hide file tree
Showing 4 changed files with 167 additions and 67 deletions.
128 changes: 77 additions & 51 deletions lib/Sub/HandlesVia/CodeGenerator.pm
View file
Expand Up @@ -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',
Expand Down Expand Up @@ -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 ) {
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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 ) = @_;

Expand Down Expand Up @@ -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 {
Expand Down Expand Up @@ -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<generator_for_prelude> 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<get_is_lvalue> B<Bool>
Indicates wheter the code generated by C<generator_for_get>
Expand Down
62 changes: 50 additions & 12 deletions lib/Sub/HandlesVia/CodeGenerator.pm.mite.pm
View file
Expand Up @@ -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 {

Expand All @@ -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" );

Expand All @@ -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(
Expand Down Expand Up @@ -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,
Expand Down Expand Up @@ -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) {
Expand Down Expand Up @@ -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,
Expand All @@ -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,
Expand Down Expand Up @@ -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 {
Expand Down Expand Up @@ -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,
Expand All @@ -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,
Expand Down
8 changes: 4 additions & 4 deletions lib/Sub/HandlesVia/Handler.pm.mite.pm
View file
Expand Up @@ -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 {

Expand Down Expand Up @@ -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,
Expand Down Expand Up @@ -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 {
Expand Down Expand Up @@ -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,
Expand Down
36 changes: 36 additions & 0 deletions t/15preludes.t
View file
@@ -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;

0 comments on commit 5d86669

Please sign in to comment.