File Coverage

blib/lib/HTML/TableTiler.pm

Criterion	Covered	Total	%
statement	95	104	91.3
branch	32	62	51.6
condition	13	32	40.6
subroutine	10	11	90.9
pod	3	3	100.0
total	153	212	72.1

package HTML::TableTiler ;
$VERSION = 1.21 ;
use strict ;

# This file uses the "Perlish" coding style
# please read http://perl.4pro.net/perlish_coding_style.html

; use 5.005
; use Carp
; use HTML::PullParser 1.0
; use IO::Util 1.2
; require Exporter
; @HTML::TableTiler::ISA = qw| Exporter |
; @HTML::TableTiler::EXPORT_OK = qw| tile_table |

; BEGIN
   { *PULL  = sub () { 'PULL' }
   ; *TILE  = sub () { 'TILE' }
   ; *TRIM  = sub () { 'TRIM' }
   ; *TRUE  = sub () { 1 }
   ; *FALSE = sub () { 0 }
   ; *RESET = sub () { 0 }
   }

; sub new
   { my $c = shift
   ; my $t = shift || \ ''
   ; $t = IO::Util::slurp($t)
          unless ref $t eq 'SCALAR'
   ; $$t or  croak 'The tile content is empty'
   ; my $s = _parse_table($t)
   ; bless $s, $c
   }

; sub _parse_table
   { my ( $content ) = shift
   ; my ( $start
        , $Hrows
        , $end
        )
        = $$content =~ m| ^
                         (.*?)                    # start
                         ( ]*?> .*
                         (.*)                     # end
                         $
                       |xsi
   ; my ( $p
        , $rows
        , $ignore
        )
   ; $Hrows or croak 'The tile does not contain any "
   ; eval
      { local $SIG{__DIE__}
      ; $p = HTML::PullParser->new( doc   => $Hrows
                                  , start => 'tag, text',
                                  , end   => 'tag, text'
                                  )
      }
   ; if ($@)
      { croak "Problem with the HTML parser: $@"
      }
   ; ( my $ri
     = my $di
     = my $td
     = my $in_tr
     = my $in_td
     = RESET
     )
   ; my $err = sub
                { croak "Unespected HTML tag $_[0] found in the tile"
                }
   ; while ( my $tok = $p->get_token )
      { my ( $tag, $text ) = @$tok
      ; if ( $tag eq 'tr' )
         { ( not $in_tr and not $in_td ) or $err->($text)
         ; $$rows[$ri]{Srow} = $text
         ; $in_tr = TRUE
         }
        elsif ( $tag eq '/tr')
         { ( $in_tr and not $in_td) or $err->($text)
         ; $$rows[$ri++]{Erow} = $text
         ; $in_tr = FALSE
         ; $di    = FALSE
         }
        elsif ( $tag eq 'td' )
         { ($in_tr and not $in_td) or $err->($text)
         ; $$rows[$ri]{cells}[$di]{Scell} = $text
         ; $in_td = TRUE
         }
        elsif ( $tag eq '/td' )
         { ($in_tr and $in_td) or $err->($text)
         ; $$rows[$ri]{cells}[$di++]{Ecell} .= $text
         ; $in_td = FALSE
         ; $td++
         }
        elsif ( $tag !~ m|^/| )
         { ($in_tr and $in_td) or $err->($text)
         ; $$rows[$ri]{cells}[$di]{Scell} .= $text if $in_td
         }
        elsif ( $tag =~ m|^/| )
         { ( $in_tr and $in_td ) or $err->($text)
         ; $$rows[$ri]{cells}[$di]{Ecell} .= $text if $in_td
         }
      }
   ; $td or croak 'The tile does not contain any "
   ; return { start => $start
            , rows  => $rows
            , end   => $end
            }
   }

; sub is_matrix
   { my ($data_matrix) = shift
   # bi-dimensional array check
   ; foreach my $dr ( @$data_matrix )
     { if ( ref $dr eq 'ARRAY' )
        { foreach my $d ( @$dr )
           { return 0 if ref $d
           }
        }
       else
        { return 0
        }
     }
   ; return 1
   }

; sub tile_table
   { my ( $s
        , $data_matrix
        , $tile
        , $mode
        , $checked
        )
   ; if (  length(ref $_[0])             # blessed obj
        && eval { $_[0]->isa(ref $_[0]) }
        )
      { ( $s, $data_matrix, $mode, $checked) = @_
      }
     else
      { ( $data_matrix, $tile, $mode, $checked ) = @_
      ; $s = __PACKAGE__->new($tile)
      ; undef $tile
      }

   ; $mode ||= 'H_PULL V_PULL'

   ; $checked
     || is_matrix($data_matrix)
     || croak 'Wrong data matrix content'

   # set Hmode and Vmode
   ; my $m = qr/(PULL|TILE|TRIM)/
   ; my ($Hmode) = $mode =~ /\b H_ $m \b/x ; $Hmode ||= PULL
   ; my ($Vmode) = $mode =~ /\b V_ $m \b/x ; $Vmode ||= PULL

   # spread table
   ; my $out = "\n"

   ; ROW:
     for ( ( my $dmi
           = my $tmi
           = RESET
           )
         ; $dmi <= $#$data_matrix
         ; ( $dmi ++
           , $tmi ++
           )
         )
      { if ( $tmi > $#{$s->{rows}} )
         {
           if    ( $Vmode eq PULL )
            { $tmi = $#{$s->{rows}}
            }
           elsif ( $Vmode eq TILE )
            { $tmi = RESET
            }
           elsif ( $Vmode eq TRIM )
           { last ROW
           }
         }
      ; $out .= $s->{rows}[$tmi]{Srow}
              . "\n"
      ; my $data_cells = $$data_matrix[$dmi]
      ; my $html_cells = $$s{rows}[$tmi]{cells}

      ; CELL:
        for ( ( my $di
              = my $ti
              = RESET
              )
            ; $di <= $#$data_cells
            ; ( $di ++
              , $ti ++
              )
            )
         { if ( $ti > $#$html_cells )
            {
              if    ( $Hmode eq PULL )
               { $ti = $#$html_cells
               }
              elsif ( $Hmode eq TILE )
               { $ti = RESET
               }
              elsif ( $Hmode eq TRIM )
               { last CELL
               }
            }
         ; $out .= "\t"
                 . $$html_cells[$ti]{Scell}
                 . $$data_cells[$di]
                 . $$html_cells[$ti]{Ecell}
                 . "\n"
         }
      ; $out .= $$s{rows}[$tmi]{Erow}
              . "\n"
      }
   ; return $$s{start}
          . $out
          . $$s{end}
   }

; 1

__END__