view release on metacpan or  search on metacpan

lib/Kavorka/Sub.pm  view on Meta::CPAN

use Text::Balanced qw( extract_bracketed );
use Parse::Keyword {};
use Parse::KeywordX;
use Carp;

our @CARP_NOT = qw(Kavorka);

use Moo::Role;
use namespace::sweep;

use overload (
	q[&{}]   => sub { shift->body },
	q[bool]  => sub { 1 },
	q[""]    => sub { shift->qualified_name // '__ANON__' },
	q[0+]    => sub { 1 },
	fallback => 1,
);

has keyword         => (is => 'ro');
has signature_class => (is => 'lazy', default => sub { 'Kavorka::Signature' });
has package         => (is => 'ro');
has declared_name   => (is => 'rwp');
has signature       => (is => 'rwp');
has traits          => (is => 'lazy', default => sub { +{} });
has prototype       => (is => 'rwp');
has attributes      => (is => 'lazy', default => sub { [] });
has body            => (is => 'rwp');
has qualified_name  => (is => 'rwp');

has _unwrapped_body => (is => 'rwp');
has _pads_to_poke   => (is => 'lazy');
has _tmp_name       => (is => 'lazy');

sub allow_anonymous      { 1 }
sub allow_lexical        { 1 }
sub is_anonymous         { !defined( shift->declared_name ) }
sub is_lexical           { (shift->declared_name || '') =~ /\A\$/ }
sub invocation_style     { +undef }
sub default_attributes   { return; }
sub default_invocant     { return; }
sub forward_declare_sub  { return; }

sub bypass_custom_parsing
{
	my $class = shift;
	my ($keyword, $caller, $args) = @_;
	croak("Attempt to call keyword '$keyword' bypassing prototype not supported");
}

sub install_sub
{
	my $self = shift;
	my $code = $self->body;
	
	if ($self->is_anonymous)
	{
		# no installation
	}
	elsif ($self->is_lexical)
	{
		require PadWalker;
		PadWalker::peek_my(2)->{ $self->declared_name } = \$code;
	}
	else
	{
		my $name = $self->qualified_name;
		no strict 'refs';
		*{$name} = $code;
	}
	
	$code;
}

sub inject_attributes
{
	my $self = shift;
	no warnings; # Perl 5.21+ sprintf emits warnings for redundant arguments
	join(' ', map sprintf($_->[1] ? ':%s(%s)' : ':%s', @$_), @{ $self->attributes }),
}

sub inject_prelude
{
	my $self = shift;
	$self->signature->injection;
}

sub parse
{
	my $class = shift;
	my $self  = $class->new(@_, package => compiling_package);
	
	lex_read_space;
	
	# sub name
	$self->parse_subname;
	unless ($self->is_anonymous or $self->is_lexical)
	{
		my $qualified = Kavorka::_fqname($self->declared_name);
		$self->_set_qualified_name($qualified);
		$self->forward_declare_sub;
	}
	
	# Thanks to Perl 5.20 subs, we have to allow attributes before
	# the signature too.
	lex_read_space;
	$self->parse_attributes
		if lex_peek    eq ':'
		&& lex_peek(2) ne ':(';
	
	# signature
	$self->parse_signature;
	my $sig = $self->signature;
	unless ($sig->has_invocants)
	{
		my @defaults = $self->default_invocant;
		unshift @{$sig->params}, @defaults;
		$sig->_set_has_invocants(scalar @defaults);
	}
	
	# traits
	$self->parse_traits;
	my $traits = $self->traits;

lib/Kavorka/Sub.pm  view on Meta::CPAN

sub _apply_return_types
{
	my $self = shift;
	
	my @rt = @{ $self->signature ? $self->signature->return_types : [] };
	
	if (@rt)
	{
		my @scalar = grep !$_->list, @rt;
		my @list   = grep  $_->list, @rt;
		
		my $scalar =
			(@scalar == 0) ? undef :
			(@scalar == 1) ? $scalar[0] :
			croak("Multiple scalar context return types specified for function");
		
		my $list =
			(@list == 0) ? undef :
			(@list == 1) ? $list[0] :
			croak("Multiple list context return types specified for function");
		
		return if (!$scalar || $scalar->assumed) && (!$list || $list->assumed);
		
		require Return::Type;
		my $wrapped = Return::Type->wrap_sub(
			$self->body,
			scalar        => ($scalar ? $scalar->_effective_type   : undef),
			list          => ($list   ? $list->_effective_type     : undef),
			coerce_scalar => ($scalar ? $scalar->coerce            : 0),
			coerce_list   => ($list   ? $list->coerce              : $scalar ? $scalar->coerce : 0),
		);
		$self->_set__unwrapped_body($self->body);
		$self->_set_body($wrapped);
	}
	
	();
}

sub _build__pads_to_poke
{
	my $self = shift;
	
	my @pads = $self->_unwrapped_body // $self->body;
	
	for my $param (@{ $self->signature ? $self->signature->params : [] })
	{
		push @pads, $param->default if $param->default;
		push @pads, @{ $param->constraints };
	}
	
	\@pads;
}

sub _poke_pads
{
	my $self = shift;
	my ($vars) = @_;
	
	for my $code (@{$self->_pads_to_poke})
	{
		my $closed_over = PadWalker::closed_over($code);
		ref($vars->{$_}) && ($closed_over->{$_} = $vars->{$_})
			for keys %$closed_over;
		PadWalker::set_closed_over($code, $closed_over);
	}
	
	();
}

1;

__END__

=pod

=encoding utf-8

=for stopwords invocant invocants lexicals unintuitive

=head1 NAME

Kavorka::Sub - a function that has been declared

=head1 DESCRIPTION

Kavorka::Sub is a role which represents a function declared using
L<Kavorka>. Classes implementing this role are used to parse functions,
and also to inject Perl code into them.

Instances of classes implementing this role are also returned by
Kavorka's function introspection API.

=head2 Introspection API

A function instance has the following methods.

=over

=item C<keyword>

The keyword (e.g. C<method>) used to declare the function.

=item C<package>

Returns the package name the parameter was declared in. Not necessarily
the package it will be installed into...

   package Foo;
   fun UNIVERSAL::quux { ... }  # will be installed into UNIVERSAL

=item C<is_anonymous>

Returns a boolean indicating whether this is an anonymous coderef.

=item C<declared_name>

The declared name of the function (if any).

=item C<qualified_name>

The name the function will be installed as, based on the package and
declared name.

=item C<signature>