File Coverage

blib/lib/Text/Table/HTML.pm

Criterion	Covered	Total	%
statement	124	127	97.6
branch	64	74	86.4
condition	23	24	95.8
subroutine	5	5	100.0
pod	1	1	100.0
total	217	231	93.9

package Text::Table::HTML;

use 5.010001;
use strict;
use warnings;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2025-05-15'; # DATE
our $DIST = 'Text-Table-HTML'; # DIST
our $VERSION = '0.012'; # VERSION

sub _encode {
    state $load = do { require HTML::Entities };
    my $val = shift;
    # encode_entities change 0 (false) to empty string so we need to filter the
    # value first
    if (!defined $val) {
        "";
    } elsif (!$val) {
        "$val";
    } else {
        HTML::Entities::encode_entities($val);
    }
}

sub table {
    my %params = @_;
    my $rows   = delete $params{rows} or die "Must provide rows!";

    # here we go...
    my @table;

    my %attr = %{ delete( $params{html_attr} ) // {} };
    {
        my @direct_attr = grep exists $params{"html_$_"}, qw( id class style );
        $attr{@direct_attr} = delete @params{ map "html_$_", @direct_attr };
    }

    my $attr =
      keys %attr
      ? join q{ }, '', map { qq{$_="$attr{$_}"} } grep defined( $attr{$_} ),
      keys %attr
      : '';

    # set all rows bottom_border if requested.
    my $bottom_border_rows = delete($params{separate_rows});

    push @table, "\n";

    if ( defined( my $caption = delete $params{caption} ) ) {
        push @table, "
    }

    if ( defined( my $colgroup = delete $params{html_colgroup} ) ) {

        if (@$colgroup) {
            push @table, "

            for my $col ( @{$colgroup} ) {

                my @element = '
                if ( defined $col ) {
                    if ( 'HASH' eq ref $col ) {
                        push @element, qq{$_="$col->{$_}"} for keys %{$col};
                    }
                    else {
                        push @element, $col;
                    }
                }
                push @element, '/>';
                push @table, join( q{ }, @element ), "\n";
            }

            push @table, "\n";
        }
    }

    # then the header & footer
    my $header_row = delete $params{header_row} // 0;
    my $footer_row = delete $params{footer_row} // 0;

    # check for unrecognized options
    die( "unrecognized options: ", join q{, }, sort keys %params )
      if keys %params;

    my $footer_row_start;
    my $footer_row_end;

    # footer is directly after the header
    if ( $footer_row > 0 ) {
        $footer_row_start = $header_row;
        $footer_row_end   = $footer_row_start + $footer_row;
        $footer_row       = !!1;
    }

    # footer is at end
    elsif ( $footer_row < 0 ) {
        $footer_row_start = @{$rows} + $footer_row;
        $footer_row_end   = $footer_row_start - $footer_row;
        $footer_row       = !!1;
    }

    my $needs_thead_open  = !!$header_row;
    my $needs_thead_close = !!0;

    my $needs_tbody_open  = !!1;
    my $add_tbody_open    = !!1;
    my $needs_tbody_close = !!0;

    my $needs_tfoot_close = !!0;
    my $idx               = -1;

    # then the data
    foreach my $row ( @{$rows} ) {
        ++$idx;

        my $col_tag = 'td';

        if ($header_row) {

            $col_tag = 'th';

            if ($needs_thead_open) {
                push @table, "
                $needs_thead_open  = !!0;
                $needs_thead_close = !!1;
                $add_tbody_open    = !!0;
            }

            elsif ( --$header_row == 0 ) {
                push @table, "
                $needs_thead_close = !!0;
                $add_tbody_open    = $needs_tbody_open;
                $col_tag           = 'td';
            }
        }

        if ($footer_row) {

            if ( $idx == $footer_row_start ) {

                if ($needs_thead_close) {
                    push @table, "\n";
                    $needs_thead_close = !!0;
                }

                elsif ($needs_tbody_close) {
                    push @table, "
                    $needs_tbody_close = !!0;
                }

                push @table, "
                $add_tbody_open    = !!0;
                $needs_tfoot_close = !!1;
            }

            elsif ( $idx == $footer_row_end ) {
                push @table, "
                $footer_row     = $needs_tfoot_close = !!0;
                $add_tbody_open = $needs_tbody_open;
            }

        }

        if ($add_tbody_open) {
            push @table, "
            $add_tbody_open    = $needs_tbody_open = !!0;
            $needs_tbody_close = !!1;
        }

        my $bottom_border;

        my @row;

        for my $cell (@$row) {

            my $cell_tag = $col_tag;
            my $text;
            my $tag  = $col_tag;
            my $attr = '';

            if ( ref $cell eq 'HASH' ) {

                # add a class attribute for bottom_border if
                # any cell in the row has it set. once the attribute is set,
                # no need to do the check again.
                $bottom_border //=
                  ($bottom_border_rows // $cell->{bottom_border})
                  && " class=has_bottom_border";

                if ( defined $cell->{raw_html} ) {
                    $text = $cell->{raw_html};
                }
                else {
                    $text = _encode( $cell->{text} // '' );
                }

                my $rowspan = int( $cell->{rowspan} // 1 );
                $attr .= " rowspan=$rowspan" if $rowspan > 1;

                my $colspan = int( $cell->{colspan} // 1 );
                $attr .= " colspan=$colspan" if $colspan > 1;

                $attr .= ' align="' . $cell->{align} . '"'
                  if defined $cell->{align};

                $cell_tag = $cell->{html_element}
                  if defined $cell->{html_element};

                if ( defined $cell->{html_scope} ) {
                    die("'html_scope' attribute is only valid in header cells")
                      unless $col_tag eq 'th';
                    $attr .= ' scope="' . $cell->{html_scope} . '"';
                }

                # cleaner if in a loop, but that might slow things down
                $attr .= ' class="' . $cell->{html_class} . '"'
                  if defined $cell->{html_class};
                $attr .= ' headers="' . $cell->{html_headers} . '"'
                  if defined $cell->{html_headers};
                $attr .= ' id="' . $cell->{html_id} . '"'
                  if defined $cell->{html_id};
                $attr .= ' style="' . $cell->{html_style} . '"'
                  if defined $cell->{html_style};
            }
            else {
                $text = _encode( $cell // '' );
            }

            push @row,
              '<' . $cell_tag . $attr . '>', $text, '';
        }

        push @table, "", @row, "
    }

    push @table, "\n" if $needs_thead_close;
    push @table, "\n" if $needs_tfoot_close;

    push @table, "
    push @table, "
    push @table, "