File Coverage

lib/PEF/Front/Model.pm

Criterion	Covered	Total	%
statement	30	53	56.6
branch	10	22	45.4
condition	4	17	23.5
subroutine	5	7	71.4
pod	0	3	0.0
total	49	102	48.0

package PEF::Front::Model;

use PEF::Front::Config;

use strict;
use warnings;

sub normalize_method_name {
	my $name = $_[0];
	if ($name =~ /^\^?PEF::Front/ || $name =~ /^\^/) {
		$name =~ s/^\^//;
	} else {
		$name = cfg_app_namespace . "Local::$name";
	}
	$name;
}

sub make_model_call {
	my ($method, $model) = @_;
	my ($model_sub, $cfg_model_sub);
	if ($model && !ref($model) && $model =~ /^\^?\w+::/) {
		$model = normalize_method_name($model);
		my $class = substr($model, 0, rindex($model, "::"));
		my $can = substr($model, rindex($model, "::") + 2);
		eval "use $class";
		$@ = "$class must contain $can function" if not $@ and not $class->can($can);
		croak {
			result      => 'INTERR',
			answer      => 'Validator $1 loading model error: $2',
			answer_args => [$method, "$@"],
			}
			if $@;
		$model_sub = eval "sub { eval { $model(\@_) } }";
	} else {
		$model ||= 'rpc_site';
		$cfg_model_sub = eval {cfg_model_rpc($model)};
		$@ = "cfg_model_rpc('$model') must return code reference" if ref $cfg_model_sub ne 'CODE';
		croak {
			result      => 'INTERR',
			answer      => 'Validator $1 loading model error: $2',
			answer_args => [$method, "$@"],
			}
			if $@;
		$model_sub = eval "sub { eval { \$cfg_model_sub->(\@_) } }";
	}
	return ($model, $model_sub);
}

sub _chain_links_sub {
	my $links = $_[0];
	$links = [$links] if not ref $links or ref $links ne 'ARRAY';
	my @handlers;
	for my $link (@$links) {
		if (not ref $link) {
			push @handlers, normalize_method_name($link);
		} elsif (ref $link eq 'HASH') {
			push @handlers, map {[normalize_method_name($_), $link->{$_}]} keys %$link;
		}
	}
	my $sub_str = <
sub {
	my (\$req, \$context) = \@_;
	my \$response;
EOS
	for (my $i = 0; $i < @handlers; ++$i) {
		if (ref $handlers[$i]) {
			$sub_str .= "\t\$response = $handlers[$i][0](\$req, \$context, \$response, \$handlers[$i][1]);\n";
		} else {
			$sub_str .= "\t\$response = $handlers[$i](\$req, \$context, \$response);\n";
		}
	}
	$sub_str .= "\t\$response;\n}\n";
	if (wantarray) {
		my $sub = eval $sub_str;
		return ($sub, $sub_str);
	} else {
		return $sub_str;
	}
}

sub chain_links {
	my ($sub, $sub_str) = _chain_links_sub($_[0]);
	return $sub;
}

1;

__END__