1#!perl -T 2use strict; 3use warnings FATAL => 'all'; 4use utf8; 5use Test::More; 6use Data::Dumper; 7use DBIx::XHTML_Table; 8 9eval "use HTML::TableExtract"; 10plan skip_all => "HTML::TableExtract required" if $@; 11 12plan tests => 54; 13 14my ( $table, @headers, @data ); 15my $nbsp = chr( 160 ); 16 17{ # headers - no mixed case duplicates 18 @headers = qw(HD_onE HD_twO hd_three ); 19 @data = ( [@headers], ([ (1) x @headers ]) x 3 ); 20 21 $table = DBIx::XHTML_Table->new( [@data] ); 22 is_deeply extract( $table, 0 ), [qw(Hd_one Hd_two Hd_three)], "default header modifications"; 23 24 $table = DBIx::XHTML_Table->new( [@data] ); 25 $table->map_head( sub { lc shift } ); 26 is_deeply extract( $table, 0 ), [qw(hd_one hd_two hd_three)], "all headers changed"; 27 28 $table = DBIx::XHTML_Table->new( [@data] ); 29 $table->map_head( sub { uc shift }, 2 ); 30 is_deeply extract( $table, 0 ), [qw(Hd_one Hd_two HD_THREE)], "header changed by col index"; 31 32 $table = DBIx::XHTML_Table->new( [@data] ); 33 $table->map_head( sub { lc shift }, qw(HD_three) ); 34 is_deeply extract( $table, 0 ), [qw(Hd_one Hd_two hd_three)], "mixed-case query matched by lowercased col key"; 35 36 $table = DBIx::XHTML_Table->new( [@data] ); 37 $table->map_head( sub { uc shift }, qw(hd_TWo) ); 38 is_deeply extract( $table, 0 ), [qw(Hd_one HD_TWO Hd_three)], "mixed-case query match by col key search"; 39 40 $table = DBIx::XHTML_Table->new( [@data] ); 41 $table->map_head( sub { lcfirst( uc( shift ) ) }, qw(HD_twO) ); 42 is_deeply extract( $table, 0 ), [qw(Hd_one hD_TWO Hd_three)], "header changed by exact col key"; 43} 44 45{ # headers - mixed case duplicates 46 @headers = qw(hd_ONE hd_one hd_TWO HD_TWO ); 47 @data = ( [@headers], ([ ('x') x @headers ]) x 3 ); 48 49 $table = DBIx::XHTML_Table->new( [@data] ); 50 is_deeply extract( $table, 0 ), [qw(Hd_one Hd_one Hd_two Hd_two)], "default header modifications"; 51 52 $table = DBIx::XHTML_Table->new( [@data] ); 53 $table->map_head( sub { lc shift } ); 54 is_deeply extract( $table, 0 ), [qw(hd_one hd_one hd_two hd_two)], "all headers changed"; 55 56 $table = DBIx::XHTML_Table->new( [@data] ); 57 $table->map_head( sub { uc shift }, [ 1 ] ); 58 is_deeply extract( $table, 0 ), [qw(Hd_one HD_ONE Hd_two Hd_two)], "header changed by col index"; 59 60 $table = DBIx::XHTML_Table->new( [@data] ); 61 $table->map_head( sub { lc shift }, qw(HD_one) ); 62 is_deeply extract( $table, 0 ), [qw(Hd_one hd_one Hd_two Hd_two)], "mixed-case query matched by lowercased col key"; 63 64 $table = DBIx::XHTML_Table->new( [@data] ); 65 $table->map_head( sub { uc shift }, qw(Hd_Two) ); 66 is_deeply extract( $table, 0 ), [qw(Hd_one Hd_one Hd_two HD_TWO)], "mixed-case query matched by col key search"; 67 68 $table = DBIx::XHTML_Table->new( [@data] ); 69 $table->map_head( sub { lcfirst( uc( shift ) ) }, qw(hd_TWO) ); 70 is_deeply extract( $table, 0 ), [qw(Hd_one Hd_one hD_TWO Hd_two)], "header changed by exact col key"; 71} 72 73{ # rows - no mixed case duplicates 74 @headers = qw(HD_onE HD_twO hd_three ); 75 @data = ( [@headers], ([ (1) x @headers ]) x 3 ); 76 77 $table = DBIx::XHTML_Table->new( [@data] ); 78 is_deeply extract( $table, 1 ), [(1) x @headers], "no mods - row 1 unchanged"; 79 is_deeply extract( $table, 2 ), [(1) x @headers], "no mods - row 2 unchanged"; 80 is_deeply extract( $table, 3 ), [(1) x @headers], "no mods - row 3 unchanged"; 81 82 $table = DBIx::XHTML_Table->new( [@data] ); 83 $table->map_cell( sub { $_[0] + 1 } ); 84 is_deeply extract( $table, 1 ), [(2) x @headers], "all cells - row 1 correct"; 85 is_deeply extract( $table, 2 ), [(2) x @headers], "all cells - row 2 correct"; 86 is_deeply extract( $table, 3 ), [(2) x @headers], "all cells - row 3 correct"; 87 88 $table = DBIx::XHTML_Table->new( [@data] ); 89 $table->map_cell( sub { $_[0] + 1 }, 1 ); 90 is_deeply extract( $table, 1 ), [1,2,1], "col index - row 1 correct"; 91 is_deeply extract( $table, 2 ), [1,2,1], "col index - row 2 correct"; 92 is_deeply extract( $table, 3 ), [1,2,1], "col index - row 3 correct"; 93 94 $table = DBIx::XHTML_Table->new( [@data] ); 95 $table->map_cell( sub { $_[0] + 1 }, qw(HD_three) ); 96 is_deeply extract( $table, 1 ), [1,1,2], "mixed-case query matched by lc col key - row 1"; 97 is_deeply extract( $table, 2 ), [1,1,2], "mixed-case query matched by lc col key - row 2"; 98 is_deeply extract( $table, 3 ), [1,1,2], "mixed-case query matched by lc col key - row 3"; 99 100 $table = DBIx::XHTML_Table->new( [@data] ); 101 $table->map_cell( sub { $_[0] + 1 }, qw(hd_TWo) ); 102 is_deeply extract( $table, 1 ), [1,2,1], "mixed-case query matched by col key search - row 1"; 103 is_deeply extract( $table, 2 ), [1,2,1], "mixed-case query matched by col key search - row 2"; 104 is_deeply extract( $table, 3 ), [1,2,1], "mixed-case query matched by col key search - row 3"; 105 106 $table = DBIx::XHTML_Table->new( [@data] ); 107 $table->map_cell( sub { $_[0] + 2 }, qw(HD_twO) ); 108 is_deeply extract( $table, 1 ), [1,3,1], "cells changed by exact col key - row 1"; 109 is_deeply extract( $table, 2 ), [1,3,1], "cells changed by exact col key - row 2"; 110 is_deeply extract( $table, 3 ), [1,3,1], "cells changed by exact col key - row 3"; 111 112 113 #--------- 114 # calc totals == total will be 2nd row 115 $table = DBIx::XHTML_Table->new( [@data] ); 116 $table->calc_totals( ); 117 is_deeply extract( $table, 1 ), [3,3,3], "calc totals - no mods"; 118 119 $table = DBIx::XHTML_Table->new( [@data] ); 120 $table->calc_totals( [], '%03d' ); 121 is_deeply extract( $table, 1 ), [qw(003 003 003)], "calc totals - with mask"; 122 123 $table = DBIx::XHTML_Table->new( [@data] ); 124 $table->calc_totals( 1 ); 125 is_deeply extract( $table, 1 ), [$nbsp,3,$nbsp], "calc totals - by one col index"; 126 127 $table = DBIx::XHTML_Table->new( [@data] ); 128 $table->calc_totals( [0, 2] ); 129 is_deeply extract( $table, 1 ), [3,$nbsp,3], "calc totals - by one col index"; 130 131 $table = DBIx::XHTML_Table->new( [@data] ); 132 $table->calc_totals( qw(HD_three) ); 133 is_deeply extract( $table, 1 ), [$nbsp,$nbsp,3], "calc totals - by matched lc col key"; 134 135 $table = DBIx::XHTML_Table->new( [@data] ); 136 $table->calc_totals( qw(HD_twO) ); 137 is_deeply extract( $table, 1 ), [$nbsp,3,$nbsp], "calc totals - by exact col key"; 138 139 140 #--------- 141 @data = ( 142 [qw( GRP_1 num1 num2 GRP_2 num3 num4 )], 143 [ a => 5, 5, e => 10, 10 ], 144 [ a => 5, 5, e => 10, 10 ], 145 [ a => 5, 5, e => 10, 10 ], 146 [ b => 5, 5, e => 10, 10 ], 147 [ b => 5, 5, f => 10, 10 ], 148 [ b => 5, 5, f => 10, 10 ], 149 ); 150 151 $table = make_with_subtotals( [@data], group => 0 ); 152 is_deeply extract( $table, 1 ), [$nbsp,30,30,$nbsp,60,60], "1st group subtotals by col index - correct totals"; 153 154 $table = make_with_subtotals( [@data], group => 0 ); 155 is_deeply extract( $table, 5 ), [$nbsp,15,15,$nbsp,30,30], "1st group subtotals by col index - correct subtotals 1"; 156 157 $table = make_with_subtotals( [@data], group => 0 ); 158 is_deeply extract( $table, 9 ), [$nbsp,15,15,$nbsp,30,30], "1st group subtotals by col index - correct subtotals 2"; 159 160 $table = make_with_subtotals( [@data], group => 'GRP_1' ); 161 is_deeply extract( $table, 1 ), [$nbsp,30,30,$nbsp,60,60], "1st group subtotals by col key - correct totals"; 162 163 $table = make_with_subtotals( [@data], group => 'GRP_1' ); 164 is_deeply extract( $table, 5 ), [$nbsp,15,15,$nbsp,30,30], "1st group subtotals by col key - correct subtotals 1"; 165 166 $table = make_with_subtotals( [@data], group => 'GRP_1' ); 167 is_deeply extract( $table, 9 ), [$nbsp,15,15,$nbsp,30,30], "1st group subtotals by col key - correct subtotals 2"; 168 169 $table = make_with_subtotals( [@data], group => 'grp_1' ); 170 is_deeply extract( $table, 1 ), [$nbsp,30,30,$nbsp,60,60], "1st group subtotals by matched lc col key - correct totals"; 171 172 $table = make_with_subtotals( [@data], group => 'grp_1' ); 173 is_deeply extract( $table, 5 ), [$nbsp,15,15,$nbsp,30,30], "1st group subtotals by matched lc col key - correct subtotals 1"; 174 175 $table = make_with_subtotals( [@data], group => 'grp_1' ); 176 is_deeply extract( $table, 9 ), [$nbsp,15,15,$nbsp,30,30], "1st group subtotals by matched lc col key - correct subtotals 2"; 177 178 #--------- 179 $table = make_with_subtotals( [@data], group => 3 ); 180 is_deeply extract( $table, 1 ), [$nbsp,30,30,$nbsp,60,60], "2nd group subtotals by col index - correct totals"; 181 182 $table = make_with_subtotals( [@data], group => 3 ); 183 is_deeply extract( $table, 6 ), [$nbsp,20,20,$nbsp,40,40], "2nd group subtotals by col index - correct subtotals 1"; 184 185 $table = make_with_subtotals( [@data], group => 3 ); 186 is_deeply extract( $table, 9 ), [$nbsp,10,10,$nbsp,20,20], "2nd group subtotals by col index - correct subtotals 2"; 187 188 $table = make_with_subtotals( [@data], group => 'GRP_2' ); 189 is_deeply extract( $table, 1 ), [$nbsp,30,30,$nbsp,60,60], "2nd group subtotals by col key - correct totals"; 190 191 $table = make_with_subtotals( [@data], group => 'GRP_2' ); 192 is_deeply extract( $table, 6 ), [$nbsp,20,20,$nbsp,40,40], "2nd group subtotals by col key - correct subtotals 1"; 193 194 $table = make_with_subtotals( [@data], group => 'GRP_2' ); 195 is_deeply extract( $table, 9 ), [$nbsp,10,10,$nbsp,20,20], "2nd group subtotals by col key - correct subtotals 2"; 196 197 $table = make_with_subtotals( [@data], group => 'grp_2' ); 198 is_deeply extract( $table, 1 ), [$nbsp,30,30,$nbsp,60,60], "2nd group subtotals by matched lc col key - correct totals"; 199 200 $table = make_with_subtotals( [@data], group => 'grp_2' ); 201 is_deeply extract( $table, 6 ), [$nbsp,20,20,$nbsp,40,40], "2nd group subtotals by matched lc col key - correct subtotals 1"; 202 203 $table = make_with_subtotals( [@data], group => 'grp_2' ); 204 is_deeply extract( $table, 9 ), [$nbsp,10,10,$nbsp,20,20], "2nd group subtotals by matched lc col key - correct subtotals 2"; 205} 206 207 208 209exit; 210 211sub make_with_subtotals { 212 my ($data,%args) = @_; 213 my $table = DBIx::XHTML_Table->new( $data ); 214 $table->set_group( $args{group} ); 215 $table->calc_totals( $args{totals} ); 216 $table->calc_subtotals( $args{subtotals} ); 217 return $table; 218} 219 220sub extract { 221 my ($table,$row,$col) = @_; 222 my $extract = HTML::TableExtract->new( keep_headers => 1 ); 223 $extract->parse( $table->output ); 224 if (defined $row) { 225 return @{[ $extract->rows ]}[$row]; 226 } elsif (defined $col) { 227 # TODO: if needed 228 } else { 229 return $extract->rows; 230 } 231} 232 233# 6962 Support for mixed case field names returned by the SQL query 234# promoted to a unit test :D 235