File Coverage

blib/lib/HTML/TableContent/Template.pm

Criterion	Covered	Total	%
statement	137	139	98.5
branch	12	14	85.7
condition	3	3	100.0
subroutine	44	45	97.7
pod			n/a
total	196	201	97.5

package HTML::TableContent::Template;

use strict;
use warnings;
use Carp qw/croak/;
use MooX::ReturnModifiers;
use HTML::TableContent::Table;
use HTML::TableContent::Table::Caption;
use HTML::TableContent::Table::Header;

our $VERSION = '1.00';

my %TABLE = (
    caption => 'HTML::TableContent::Table::Caption',
    header => 'HTML::TableContent::Table::Header',
    row => 'HTML::TableContent::Table::Row',
    cell => 'HTML::TableContent::Table::Row::Cell',
);

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

    my $target = caller;

    my %modifiers = return_modifiers($target);

    my @target_isa;

    return if $target->can('_table');

    { no strict 'refs'; @target_isa = @{"${target}::ISA"} };

    if (@target_isa) {
        eval '{
        package ' . $target . ';

            sub _caption_spec {
                my ($class, @meta) = @_;
                return $class->maybe::next::method(@meta);
            }

            sub _header_spec {
                my ($class, @meta) = @_;
                return $class->maybe::next::method(@meta);
            }

            sub _row_spec {
                my ($class, @meta) = @_;
                return $class->maybe::next::method(@meta);
            }

            sub _cell_spec {
                my ($class, @meta) = @_;
                return $class->maybe::next::method(@meta);
            }

        1;
        }';
    }

    $modifiers{has}->( 'package' => ( is => 'ro', lazy => 1, default => sub { return $target; } ) );

    my $apply_modifiers = sub {
       $modifiers{with}->('HTML::TableContent::Template::Base');
    };

    for my $element (keys %TABLE) {
        my @element = ();
        my $option = sub {
            my ( $name, %attributes ) = @_;

            my $element_data = { };
            my %filtered_attributes = _filter_attributes($name, $element, %attributes);

            if ( $element =~ m{caption|header}ixms ){
                $modifiers{has}->( $name => %filtered_attributes );
            }

            delete $filtered_attributes{default};

            $element_data->{$name} = \%filtered_attributes;

            my $spec = sprintf('_%s_spec', $element);
            if ( $element =~ m{row|cell}ixms ) {
                $modifiers{around}->(
                    $spec => sub {
                        my ( $orig, $self ) = ( shift, shift );
                        return $self->$orig(@_), %$element_data;
                    }
                );
            } else {
                push @element, $element_data;
                $modifiers{around}->(
                    $spec => sub {
                        my ( $orig, $self ) = ( shift, shift );
                        return $self->$orig(@_), \@element;
                    }
                );
            }
            return;
        };

        { no strict 'refs'; *{"${target}::$element"} = $option; }
    }

    $apply_modifiers->();

    return;
}

sub _filter_attributes {
    my ($name, $element,  %attributes) = @_;

    $attributes{template_attr} = $name;

    if ( ! exists $attributes{text} ) {
        $attributes{text} = $name;
    }

    if ( $element eq 'cell' && exists $attributes{alternate_classes} ) {
         my @classes = @{ $attributes{alternate_classes} };
         $attributes{oac} = \@classes;
    }

    my %tattr = %attributes;
    $attributes{is} = 'ro';
    $attributes{lazy} = 1;
    if ( $element =~ m{row|cell}ixms ) {
        $attributes{default} = sub { return \%tattr; };
    } else {
        my $class = $TABLE{$element};
        $attributes{default} = sub { my %aah = %tattr; return $class->new(\%aah); };
    }

    return %attributes;
}

1;

__END__