File Coverage

blib/lib/Form/Tiny.pm

Criterion	Covered	Total	%
statement	92	92	100.0
branch	12	16	75.0
condition	10	10	100.0
subroutine	16	16	100.0
pod	0	2	0.0
total	130	136	95.5

package Form::Tiny;
$Form::Tiny::VERSION = '2.21';
use v5.10;
use strict;
use warnings;
use Carp qw(croak);
use Import::Into;

use Form::Tiny::Form;
use Form::Tiny::Utils qw(:meta_handlers);

sub import
{
	my ($package, $caller) = (shift, scalar caller);

	my @wanted = (-base, @_);

	# very special case - do something UNLESS -nomoo was passed
	unless ($package->_get_flag(\@wanted, -nomoo)) {
		require Moo;
		Moo->import::into($caller);
	}

	$package->ft_install($caller, @wanted);
	return;
}

sub ft_install
{
	my ($self, $caller, @import_flags) = @_;

	my $plugins_flag = $self->_get_flag(\@import_flags, 'plugins', 1);
	my @plugins = ($self->_get_plugins(\@import_flags), @{$plugins_flag // []});

	# field context for form building
	my $context;

	my $wanted = $self->ft_run_plugins($caller, \$context, @plugins);

	# create metapackage with roles
	my $meta = create_form_meta($caller, @{$wanted->{meta_roles}});
	$meta->set_form_roles($wanted->{roles});

	# install DSL
	{
		no strict 'refs';
		no warnings 'redefine';

		*{"${caller}::$_"} = $wanted->{subs}{$_}
			foreach keys %{$wanted->{subs}};
	}

	return \$context;
}

sub ft_run_plugins
{
	my ($self, $caller, $context_ref, @plugins) = @_;

	my $wanted = {
		subs => {},
		roles => [],
		meta_roles => [],
	};

	my %seen;
	foreach my $plugin (@plugins) {
		$plugin = "Form::Tiny::Plugin::$plugin";
		$plugin =~ s/^.+\+//;
		next if $seen{$plugin}++;

		my $success = eval "use $plugin; 1";

		croak "could not load plugin $plugin: $@"
			unless $success;
		croak "$plugin is not a Form::Tiny::Plugin"
			unless $plugin->isa('Form::Tiny::Plugin');

		$self->_merge_behaviors($wanted, $plugin->plugin($caller, $context_ref));
	}

	return $wanted;
}

sub _get_plugins
{
	my ($self, $flags) = @_;

	my %known_flags = (
		-base => ['Base'],
		-strict => ['Strict'],
		-filtered => ['Filtered'],

		# legacy no-op flags
		-consistent => [],
	);

	my @plugins;
	foreach my $flag (@$flags) {
		croak "no Form::Tiny import behavior for: $flag"
			unless exists $known_flags{$flag};

		push @plugins, @{$known_flags{$flag}};
	}

	return @plugins;
}

sub _merge_behaviors
{
	my ($self, $wanted, $behaviors) = @_;

	%{$wanted->{subs}} = (%{$wanted->{subs}}, %{$behaviors->{subs} // {}});
	push @{$wanted->{roles}}, @{$behaviors->{roles} // []};
	push @{$wanted->{meta_roles}}, @{$behaviors->{meta_roles} // []};
}

sub _get_flag
{
	my ($self, $flags, $wanted, $with_param) = @_;
	$with_param //= 0;

	for my $n (0 .. $#$flags) {
		if ($flags->[$n] eq $wanted) {
			my $param = 1;
			if ($with_param) {
				croak "Form::Tiny flag $wanted needs a parameter"
					if $n == $#$flags;
				$param = $flags->[$n + 1];
			}

			splice @$flags, $n, 1 + $with_param;
			return $param;
		}
	}

	return;
}

1;

__END__