File Coverage

blib/lib/HTML/FormHandler/Widget/ApplyRole.pm

Criterion	Covered	Total	%
statement	44	44	100.0
branch	9	12	75.0
condition			n/a
subroutine	10	10	100.0
pod	0	3	0.0
total	63	69	91.3

package HTML::FormHandler::Widget::ApplyRole;
# ABSTRACT: role to apply widgets
$HTML::FormHandler::Widget::ApplyRole::VERSION = '0.40068';
use Moose::Role;
use File::Spec;
use Class::MOP;
use Try::Tiny;
use Class::Load qw/ load_optional_class /;
use namespace::autoclean;

our $ERROR;

sub apply_widget_role {
    my ( $self, $target, $widget_name, $dir ) = @_;

    my $render_role = $self->get_widget_role( $widget_name, $dir );
    $render_role->meta->apply($target) if $render_role;
}

sub get_widget_role {
    my ( $self, $widget_name, $dir ) = @_;
    my $widget_class      = $self->widget_class($widget_name);
    my $ldir              = $dir ? '::' . $dir . '::' : '::';

    my $widget_ns = $self->widget_name_space;
    my @name_spaces = @$widget_ns;
    push @name_spaces, ('HTML::FormHandler::Widget', 'HTML::FormHandlerX::Widget');
    my @classes;
    if ( $widget_class =~ s/^\+// )
    {
        push @classes, $widget_class;
    }
    foreach my $ns (@name_spaces) {
        push @classes,  $ns . $ldir . $widget_class;
    }
    foreach my $try (@classes) {
        return $try if load_optional_class($try);
    }
    die "Can't find $dir widget $widget_class from " . join(", ", @name_spaces);
}

# this is for compatibility with widget names like 'radio_group'
# RadioGroup, Textarea, etc. also work
sub widget_class {
    my ( $self, $widget ) = @_;
    return unless $widget;
    if($widget eq lc $widget) {
        $widget =~ s/^(\w{1})/\u$1/g;
        $widget =~ s/_(\w{1})/\u$1/g;
    }
    return $widget;
}

use namespace::autoclean;
1;

__END__

=pod

=encoding UTF-8

=head1 NAME

HTML::FormHandler::Widget::ApplyRole - role to apply widgets

=head1 VERSION

version 0.40068

=head1 AUTHOR

FormHandler Contributors - see HTML::FormHandler

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2017 by Gerda Shank.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut