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