File Coverage

blib/lib/Mojolicious/Plugin/DomIdHelper.pm

Criterion	Covered	Total	%
statement	59	60	98.3
branch	9	14	64.2
condition	13	23	56.5
subroutine	9	9	100.0
pod	1	1	100.0
total	91	107	85.0

package Mojolicious::Plugin::DomIdHelper;

use Mojo::Base 'Mojolicious::Plugin';
use Mojo::Util qw{xml_escape};
use Scalar::Util qw{blessed};

our $VERSION = '0.04';

# Method used to retrieve the object's PK
my $METHOD = 'id';

# Character used to delimitthe package name from object's PK
my $DELIMITER = '_';

# Keep the full package name when generating the DOM ID, false = strip.
my $KEEP_NAMESPACE = 0;

# If available we'll pluralize the package name when an array is used
my $HAVE_INFLECT = eval "require Lingua::EN::Inflect; 1";

sub register
{
    my ($self, $app, $defaults) = @_;

    $defaults ||= {};
    $defaults->{method} ||= $METHOD;
    $defaults->{delimiter} ||= $DELIMITER;
    $defaults->{keep_namespace} ||= $KEEP_NAMESPACE;

    $app->helper(
	dom_id => sub {
	    my $c      = shift;
	    my $obj    = shift;
	    my %config = (%$defaults, @_);
	    my $dom_id = $self->_generate_dom_id($obj, %config);

	    xml_escape($dom_id);
    });

    $app->helper(
	dom_class => sub {
	    my $c      = shift;
	    my $obj    = shift;
	    my %config = (%$defaults, @_);
	    my $dom_class = $self->_generate_dom_class($obj, %config);

	    xml_escape($dom_class);
    });
}

sub _generate_dom_id
{
    my ($self, $obj, %config) = @_;
    my $methods   = $config{method};
    my $delimiter = $config{delimiter};

    my $dom_id = $self->_generate_dom_class($obj, %config);
    return unless $dom_id;

    # Append the ID suffix to blessed() refs only, others can't receive methods calls.
    if(blessed($obj)) {
	if(ref($methods) ne 'ARRAY') {
	    $methods = [$methods];
	}

	my @suffix;
	for my $method (@$methods) {
	    push @suffix, $obj->$method;
	}

	@suffix = grep defined, @suffix;

	if(@suffix) {
	    $dom_id .= $delimiter;
	    $dom_id .= join '', @suffix;
            $dom_id =~ s/\s+/$delimiter/g;
	}
    }

    $dom_id;
}

sub _generate_dom_class
{
    my ($self, $obj, %config) = @_;
    my $type = $self->_instance_name($obj);
    return unless $type;

    my @namespace = split /\b::\b/, $type;
    my $delimiter = $config{delimiter};

    # Do we want to strip the prefix from the package name
    if(!$config{keep_namespace} && @namespace > 1) {
	@namespace = pop @namespace;
    }

    # Split the package name on camelcase bounderies
    my $dom_class = join $delimiter, map {
	s/([^A-Z])([A-Z])/$1$delimiter$2/g;
	s/([A-Z])([A-Z][^A-Z])/$1$delimiter$2/g;
	lc;
    } @namespace;

    $dom_class;
}

sub _instance_name
{
    my ($self, $obj) = @_;
    my $type = ref $obj;

    if($type && $HAVE_INFLECT && $type eq 'ARRAY' && blessed($obj->[0])) {
	$type = Lingua::EN::Inflect::PL(ref $obj->[0])
    }

    $type;
}

1;

__END__