File Coverage

blib/lib/DBIx/HTMLTable.pm
Criterion Covered Total %
statement 0 66 0.0
branch 0 10 0.0
condition 0 6 0.0
subroutine 0 4 0.0
pod 0 4 0.0
total 0 90 0.0


\n|; \n|; \n|; \n|;
line stmt bran cond sub pod time code
1             package DBIx::HTMLTable;
2             $VERSION=0.24;
3              
4             @EXPORT_OK=qw(&HTMLTable &HTMLTableByRef);
5              
6             # Table Options
7             my @options = qw(caption nullfield rs fs);
8              
9             # HTML 4.0 attributes for table tag.
10             my @tableattribs = qw(align width cols id class dir title
11             style onclick ondbclick onmousedown
12             onmouseup onmouseover onmousemove
13             onmouseout onkeypress onkeydown
14             onkeyup bgcolor frame rules border
15             cellspacing cellpadding);
16              
17             my $nullfield = ' ';
18             my $rs = "\n";
19             my $fs = ",";
20              
21             sub HTMLTable {
22 0     0 0   my ($data, @args) = @_;
23 0           my ($i, $j, @cols, @theads, @trows, $thead,$topdatarow);
24 0           &table_opts (@args);
25 0           my @rows = split /$options->{rs}/, $data;
26 0           @cols = split /$options->{fs}/, $rows[0];
27 0           $thead = $rows[0];
28              
29 0           my $cols = $#cols;
30              
31 0           my $table = &table_tag;
32 0           print $table."\n";
33 0           print qq|
34 0           foreach my $row (@rows) {
35 0           print qq|
36 0           my @trow = split /\,/, $row;
37 0           foreach my $col (@trow) {
38 0           print qq||;
39 0 0 0       if ($col and length $col) {
40 0           print $col;
41             } else {
42 0           print $options->{nullfield};
43             }
44 0           print qq|
45             }
46 0           print qq|
47             }
48 0           print qq|\n|;
49 0           print qq|
\n|; 50             } 51               52             sub HTMLTableByRef { 53 0     0 0   my $dataref = $_[0]; 54 0           my $opts = $_[1]; 55 0           my ($newopts,$newattribs) = &table_opts ($opts); 56 0           my ($i, $j, $nrows, $ncols, @rows); 57               58 0           foreach (@$dataref) { push @rows, $_ }   0             59               60 0           $nrows = $#rows; 61 0           $ncols = scalar @{$rows[0]};   0             62               63 0           my $table = &table_tag ($newattribs); 64 0           print $table."\n"; 65               66 0 0         if (length $newopts->{caption}) { 67 0           print qq|$newopts->{caption}\n|; 68             } 69               70 0           print qq|\n|; 71               72 0           for ( $i = 0; $i <= $nrows; $i++ ) { 73 0           print qq|\n|; 74 0           for ( $j = 0; $j < $ncols; $j++ ) { 75 0 0 0       if ( not ${$rows[$i]}[$j] or (${$rows[$i]}[$j] eq '') ) {   0               0             76 0           ${$rows[$i]}[$j] = ' ';   0             77             } 78 0           print "".${rows[$i]}[$j]."\n"; 79             } 80 0           print qq|\n|; 81             } 82               83 0           print qq|\n|; 84 0           print qq|\n|; 85             } 86               87             sub table_tag { 88 0     0 0   my ($attribs) = @_; 89 0           my $tag = '
90 0           foreach my $attrib (keys %$attribs) {
91 0           $tag .= ' '.$attrib."\=\"".$attribs->{$attrib}."\"";
92             }
93 0           $tag .= '>';
94             }
95              
96             # All this does is check that options and attrbutes are valid.
97             sub table_opts {
98 0     0 0   my ($args) = @_;
99 0           my (%newopts,%newattribs);
100 0           foreach my $key (keys %$args) {
101 0           foreach my $opt (@options) {
102 0 0         if ($key =~ /$opt/) {
103 0           $newopts{$key} = $args->{$key};
104 0           last;
105             }
106             }
107             }
108 0           foreach my $key (keys %$args) {
109 0           foreach my $attrib (@tableattribs) {
110 0 0         if ($key =~ /$attrib/) {
111 0           $newattribs{$key} = $args->{$key};
112 0           last;
113             }
114             }
115             }
116 0           return \%newopts, \%newattribs;
117             }
118              
119             1;
120             __END__;