File Coverage

blib/lib/Spreadsheet/HTML.pm

Criterion	Covered	Total	%
statement	145	225	64.4
branch	82	148	55.4
condition	34	70	48.5
subroutine	20	40	50.0
pod	24	24	100.0
total	305	507	60.1

package Spreadsheet::HTML;
use strict;
use warnings FATAL => 'all';
our $VERSION = '1.20';

use Exporter 'import';
our @EXPORT_OK = qw(
    generate portrait landscape
    north east south west handson
    layout checkerboard scroll
    chess checkers conway sudoku
    calculator calendar banner maze
    beadwork list
);

use HTML::AutoTag;
use Spreadsheet::HTML::Engine;
use Spreadsheet::HTML::Presets;
use Spreadsheet::HTML::File::Loader;

sub portrait    { generate( @_, theta =>   0 ) }
sub landscape   { generate( @_, theta => -270, tgroups => 0 ) }

sub north   { generate( @_, theta =>    0 ) }
sub east    { generate( @_, theta =>   90, tgroups => 0, pinhead => 1 ) }
sub south   { generate( @_, theta => -180, tgroups => 0, pinhead => 1 ) }
sub west    { generate( @_, theta => -270, tgroups => 0 ) }

sub layout          { Spreadsheet::HTML::Presets::layout(           @_ ) }
sub list            { Spreadsheet::HTML::Presets::List::list(       @_ ) }
sub select          { Spreadsheet::HTML::Presets::List::select(     @_ ) }
sub handson         { Spreadsheet::HTML::Presets::Handson::handson( @_ ) }
sub conway          { Spreadsheet::HTML::Presets::Conway::conway(   @_ ) }
sub calculator      { Spreadsheet::HTML::Presets::Calculator::calculator( @_ ) }
sub chess           { Spreadsheet::HTML::Presets::Chess::chess(     @_ ) }
sub checkers        { Spreadsheet::HTML::Presets::checkers(         @_ ) }
sub tictactoe       { Spreadsheet::HTML::Presets::TicTacToe::tictactoe( @_ ) }
sub sudoku          { Spreadsheet::HTML::Presets::Sudoku::sudoku(   @_ ) }
sub checkerboard    { Spreadsheet::HTML::Presets::checkerboard(     @_ ) }
sub calendar        { Spreadsheet::HTML::Presets::calendar(         @_ ) }
sub scroll          { Spreadsheet::HTML::Presets::Scroll::scroll(   @_ ) }
sub maze            { Spreadsheet::HTML::Presets::maze(             @_ ) }
sub banner          { Spreadsheet::HTML::Presets::banner(           @_ ) }
sub beadwork        { Spreadsheet::HTML::Presets::Beadwork::beadwork( @_ ) }

sub generate {
    my %args = _process( @_ );

    $args{theta} *= -1 if $args{theta} and $args{flip};

    if (!$args{theta}) { # north

        $args{data} = $args{flip} ? [ map [ CORE::reverse @$_ ], @{ $args{data} } ] : $args{data};

    } elsif ($args{theta} == -90) {

        $args{data} = [ CORE::reverse @{ _transpose( $args{data} ) }];
        $args{data} = ($args{pinhead} and !$args{headless})
            ? [ map [ @$_[1 .. $#$_], $_->[0] ], @{ $args{data} } ]
            : [ map [ CORE::reverse @$_ ], @{ $args{data} } ];

    } elsif ($args{theta} == 90) { # east

        $args{data} = _transpose( $args{data} );
        $args{data} = ($args{pinhead} and !$args{headless})
            ? [ map [ @$_[1 .. $#$_], $_->[0] ], @{ $args{data} } ]
            : [ map [ CORE::reverse @$_ ], @{ $args{data} } ];

    } elsif ($args{theta} == -180) { # south

        $args{data} = ($args{pinhead} and !$args{headless})
            ? [ @{ $args{data} }[1 .. $#{ $args{data} }], $args{data}[0] ]
            : [ CORE::reverse @{ $args{data} } ];

    } elsif ($args{theta} == 180) {

        $args{data} = ($args{pinhead} and !$args{headless})
            ? [ map [ CORE::reverse @$_ ], @{ $args{data} }[1 .. $#{ $args{data} }], $args{data}[0] ]
            : [ map [ CORE::reverse @$_ ], CORE::reverse @{ $args{data} } ];

    } elsif ($args{theta} == -270) { # west

        $args{data} = [@{ _transpose( $args{data} ) }];

    } elsif ($args{theta} == 270) {

        $args{data} = [ CORE::reverse @{ _transpose( $args{data} ) }];
    }

    if ($args{scroll}) {
        my ($js, %new_args) = Spreadsheet::HTML::Presets::Scroll::scroll(
            %args,
            data => [ map [ map $_->{cdata}, @$_ ], @{ $args{data} } ],
        );
        for (keys %args) {
            if (ref $args{$_} eq 'HASH') {
                $new_args{$_} = { %{ $new_args{$_} || {} }, %{ $args{$_} || {} } };
            }
        }
        my $table = _make_table( _process( %new_args ) );
        return $js . $table;
    }

    return _make_table( %args );
}

sub new {
    my $class = shift;
    my %attrs = ref($_[0]) eq 'HASH' ? %{+shift} : @_;
    return bless { %attrs }, $class;
}

sub _process {
    my ($self,$data,$args) = _args( @_ );

    if ($self and $self->{is_cached}) {
        return wantarray ? ( data => $self->{data}, %{ $args || {} } ) : $data;
    }

    # headings is an alias for -r0
    $args->{-r0} = $args->{headings} if exists $args->{headings};

    # headings to index mapping (alias for some -cX)
    my %index = ();
    if ($#{ $data->[0] }) {
        %index = map { '-' . ($data->[0][$_] || '') => $_ } 0 .. $#{ $data->[0] };
        for (grep /^-/, keys %$args) {
            $args->{"-c$index{$_}" } = $args->{$_} if exists $index{$_};
        }
    }

    my $empty = exists $args->{empty} ? $args->{empty} : ' ';
    my $tag   = ($args->{headless} or $args->{matrix}) ? 'td' : 'th';
    for my $row (0 .. $args->{_max_rows} - 1) {

        unless ($args->{_layout}) {
            push @{ $data->[$row] }, undef for 1 .. $args->{_max_cols} - $#{ $data->[$row] } + 1;  # pad
            pop  @{ $data->[$row] } for $args->{_max_cols} .. $#{ $data->[$row] };                 # truncate
        }

        for my $col (0 .. $#{ $data->[$row] }) {

            my ( $cdata, $attr ) = ( $data->[$row][$col], undef );
            for ($tag, "-c$col", "-r$row", "-r${row}c${col}") {
                next unless exists $args->{$_};
                ( $cdata, $attr ) = _extrapolate( $cdata, $attr, $args->{$_} );
            }

            do{ no warnings;
                $cdata = HTML::Entities::encode_entities( $cdata, $args->{encodes} ) if $args->{encode} || exists $args->{encodes};
                $cdata =~ s/^\s*$/$empty/g;
            };

            $data->[$row][$col] = {
                tag => $tag,
                (defined( $cdata ) ? (cdata => $cdata) : ()),
                (keys( %$attr )    ? (attr => $attr)   : ()),
            };
        }
        $tag = 'td';
    }

    if ($args->{cache} and $self and !$self->{is_cached}) {
        $self->{data} = $data;
        $self->{is_cached} = 1;
    }

    shift @$data if $args->{headless};

    return wantarray ? ( data => $data, %$args ) : $data;
}

sub _make_table {
    my %args = @_;

    my @cdata = ( _tag( %args, tag => 'caption' ) || (), _colgroup( %args ) );

    if ($args{tgroups}) {

        my @body = @{ $args{data} };
        my $head = shift @body unless $args{matrix} and scalar @{ $args{data} } > 2;
        my $foot = pop @body if !$args{matrix} and $args{tgroups} > 1 and scalar @{ $args{data} } > 2;

        my $head_row  = { tag => 'tr', attr => $args{'thead.tr'}, cdata => $head };
        my $foot_row  = { tag => 'tr', attr => $args{'tfoot.tr'}, cdata => $foot };
        my $body_rows = [ map { tag => 'tr', attr => $args{tr}, cdata => $_ }, @body ];

        if (int($args{group} || 0) > 1) {
            $body_rows = [
                map [ @$body_rows[$_ .. $_ + $args{group} - 1] ],
                _range( 0, $#$body_rows, $args{group} )
            ];
            pop @{ $body_rows->[-1] } while !defined $body_rows->[-1][-1];
        } else {
            $body_rows = [ $body_rows ];
        }

        push @cdata, (
            ( $head ? { tag => 'thead', attr => $args{thead}, cdata => $head_row } : () ),
            ( $foot ? { tag => 'tfoot', attr => $args{tfoot}, cdata => $foot_row } : () ),
            ( map     { tag => 'tbody', attr => $args{tbody}, cdata => $_ }, @$body_rows ),
        );


    } else {
        push @cdata, map { tag => 'tr', attr => $args{tr}, cdata => $_ }, @{ $args{data} };
    }

    return $args{_auto}->tag( tag => 'table', attr => $args{table}, cdata => \@cdata );
}

sub _args {
    my ($self,@data,$data,@args,$args);
    $self = shift if UNIVERSAL::isa( $_[0], __PACKAGE__ );
    $data = shift if (@_ == 1);

    while (@_) {
        if (ref( $_[0] )) {
            push @data, shift;
            if (ref( $_[0] )) {
                push @data, shift;
            } elsif (defined $_[0]) {
                push @args, shift, shift;
            }
        } else {
            push @args, shift, shift;
        }
    }

    $data ||= (@data == 1) ? $data[0] : (@data) ? [ @data ] : undef;
    $args = scalar @args ? { @args } : {};
    $args = { %{ $self || {} }, %{ $args || {} } };
    $data = delete $args->{data} if exists $args->{data};

    $args->{_auto} ||= HTML::AutoTag->new(
        indent  => $args->{indent},
        level   => $args->{level},
        sorted  => $args->{sorted_attrs},
    );

    return ( $self, $self->{data}, $args ) if $self and $self->{is_cached};

    $args->{worksheet} ||= 1;
    $args->{worksheet} = 1 if $args->{worksheet} < 1;
    if ($args->{file}) {
        $data = Spreadsheet::HTML::File::Loader::_parse( $args, $data );
        unlink $args->{file} if $args->{_unlink};
    }

    $data = [ $data ] unless ref($data) eq 'ARRAY';
    $data = [ $data ] unless ref($data->[0]) eq 'ARRAY';

    if ($args->{wrap} and defined $data->[0][0]) {
        my @flat = map @$_, @$data;
        $data = [
            map [ @flat[$_ .. $_ + $args->{wrap} - 1] ],
            _range( 0, $#flat, $args->{wrap} )
        ];
    }

    $data = Spreadsheet::HTML::Engine::_apply( $data, $args->{apply} ) if $args->{apply};

    $args->{_max_rows} = scalar @{ $data }      || 1;
    $args->{_max_cols} = scalar @{ $data->[0] } || 1;

    if ($args->{fill}) {
        my ($row,$col) = split /\D/, $args->{fill};
        $args->{_max_rows} = $row if (int($row || 0)) > ($args->{_max_rows});
        $args->{_max_cols} = $col if (int($col || 0)) > ($args->{_max_cols});
    }

    return ( $self, [ map [@$_], @$data], $args );
}

sub _extrapolate {
    my ( $cdata, $attr, $thingy ) = @_;
    my $new_attr;
    $thingy = [ $thingy ] unless ref( $thingy ) eq 'ARRAY';
    for (@{ $thingy }) {
        if (ref($_) eq 'CODE') {
            $cdata = $_->($cdata);
        } elsif (ref($_) eq 'HASH') {
            $new_attr = $_;
        }
    }
    $attr = { %{ $attr || {} }, %{ $new_attr || {} } };
    return ( $cdata, $attr );
}

sub _colgroup {
    my %args = @_;

    my @colgroup;
    $args{col} = [ $args{col} ] if ref($args{col}) eq 'HASH';

    if (ref($args{col}) eq 'ARRAY') {

        if (ref $args{colgroup} eq 'ARRAY') {
            @colgroup = map {
                tag   => 'colgroup',
                attr  => $_,
                cdata => [ map { tag => 'col', attr => $_ }, @{ $args{col} } ]
            }, @{ $args{colgroup} };
        } else {
            @colgroup = {
                tag   => 'colgroup',
                attr  => $args{colgroup},
                cdata => [ map { tag => 'col', attr => $_ }, @{ $args{col} } ]
            };
        }

    } else {

        $args{colgroup} = [ $args{colgroup} ] if ref($args{colgroup}) eq 'HASH';
        if (ref $args{colgroup} eq 'ARRAY') {
            @colgroup = map { tag => 'colgroup', attr => $_ }, @{ $args{colgroup} };
        }
    }

    return @colgroup;
}

sub _tag {
    my %args = @_;
    my $thingy = $args{ $args{tag} };
    return unless defined $thingy;
    my $tag = { tag => $args{tag}, cdata => $thingy };
    if (ref $thingy eq 'HASH') {
        $tag->{cdata} = ( keys   %$thingy )[0];
        $tag->{attr}  = ( values %$thingy )[0];
    }
    return $tag;
}

# credit: Math::Matrix
sub _transpose {
    my $data = shift;
    my @trans;
    for my $i (0 .. $#{ $data->[0] }) {
        push @trans, [ map $_->[$i], @$data ]
    }
    return \@trans;
}

sub _range {grep!(($_-$_[0])%($_[2]||1)),$_[0]..$_[1]}


1;

__END__