File Coverage

blib/lib/EB/Report/Reporter/Html.pm
Criterion Covered Total %
statement 18 116 15.5
branch 0 40 0.0
condition 0 6 0.0
subroutine 6 14 42.8
pod 0 6 0.0
total 24 182 13.1


line stmt bran cond sub pod time code
1             #! perl
2              
3             # Html.pm -- HTML backend for Reporters.
4             # Author : Johan Vromans
5             # Created On : Thu Dec 29 15:46:47 2005
6             # Last Modified By: Johan Vromans
7             # Last Modified On: Sat Jun 19 00:39:34 2010
8             # Update Count : 70
9             # Status : Unknown, Use with caution!
10              
11             package main;
12              
13             our $dbh;
14             our $cfg;
15              
16             package EB::Report::Reporter::Html;
17              
18 1     1   4 use strict;
  1         2  
  1         23  
19 1     1   3 use warnings;
  1         1  
  1         18  
20              
21 1     1   3 use EB;
  1         1  
  1         159  
22 1     1   4 use EB::Format qw(datefmt_full);
  1         59  
  1         45  
23              
24 1     1   4 use base qw(EB::Report::Reporter);
  1         1  
  1         975  
25              
26             ################ API ################
27              
28             my $html;
29              
30             sub start {
31 0     0 0   my ($self, @args) = @_;
32 0           eval {
33 0           require HTML::Entities;
34             };
35 0 0         $html = $@ ? \&__html : \&_html;
36 0           $self->SUPER::start(@args);
37             }
38              
39             sub finish {
40 0     0 0   my ($self) = @_;
41 0           $self->SUPER::finish();
42 0           print {$self->{fh}} ("
\n");   0             43               44 0           my $now = $cfg->val(qw(internal now), iso8601date()); 45             # Treat empty value as no value. 46 0   0       $now ||= iso8601date(); 47 0           my $ident = $EB::ident; 48 0 0         $ident = (split(' ', $ident))[0] if $cfg->val(qw(internal now), 0); 49               50 0           $self->{fh}->print("

", 51             __x("Overzicht aangemaakt op {date} door {ident}", 52             ident => $ident, date => datefmt_full($now), url => $EB::url), "

\n"); 53 0           $self->{fh}->print("\n", 54             "\n"); 55 0           close($self->{fh}); 56             } 57               58             sub add { 59 0     0 0   my ($self, $data) = @_; 60               61 0           my $style = delete($data->{_style}); 62               63 0           $self->SUPER::add($data); 64               65 0 0         return unless %$data; 66               67 0           $self->_checkhdr; 68               69 0 0         print {$self->{fh}} ("\n");   0             70               71 0           my $colspan = 0; 72 0           foreach my $col ( @{$self->{_fields}} ) {   0             73               74 0 0         if ( $colspan > 1 ) { 75 0           $colspan--; 76 0           next; 77             } 78               79 0           my $fname = $col->{name}; 80 0 0         my $value = defined($data->{$fname}) ? $data->{$fname} : ""; 81 0           my $class = "c_$fname"; 82               83             # Examine style mods. 84 0 0         if ( $style ) { 85 0 0         if ( my $t = $self->_getstyle($style, $fname) ) { 86 0 0         if ( $t->{class} ) { 87 0           $class = $t->{class}; 88             } 89 0 0         if ( $t->{colspan} ) { 90 0           $colspan = $t->{colspan}; 91             } 92             } 93             } 94 0 0         print {$self->{fh}} ("   0 0           95             $colspan > 1 ? " colspan=\"$colspan\"" : "", 96             ">", 97             $value eq "" ? " " : $html->($value), 98             "\n"); 99             } 100               101 0           print {$self->{fh}} ("\n");   0             102             } 103               104             ################ Pseudo-Internal (used by Base class) ################ 105               106             sub header { 107 0     0 0   my ($self) = @_; 108               109 0           print {$self->{fh}} 110             ("\n", 111             "\n", 112 0   0       "", $html->($self->{_title0} || $self->{_title1}), "\n"); 113               114 0 0         if ( my $style = $self->{_style} ) { 115 0 0         if ( $style =~ /\W/ ) {     0               0           116 0           print {$self->{fh}}   0             117             ('', "\n"); 118             } 119             elsif ( defined $self->{_cssdir} ) { 120 0           print {$self->{fh}} 121             (' 122 0           $style, '.css">', "\n"); 123             } 124             elsif ( my $css = findlib("css/".$style.".css") ) { 125 0           print {$self->{fh}} ('', "\n");   0             128             } 129             else { 130 0           print {$self->{fh}} ("\n"); 133             } 134             } 135               136 0           print {$self->{fh}} 137             ("\n", 138             "\n", 139             "

", $html->($self->{_title1}), "

\n", 140 0           "

", $html->($self->{_title2}), "
\n", $html->($self->{_title3l}), "

\n", 141             "\n"); \n"); \n");
142              
143 0 0         if ( grep { $_->{title} =~ /\S/ } @{$self->{_fields}} ) {
  0            
  0            
144 0           print {$self->{fh}} ("
  0            
145 0           foreach ( @{$self->{_fields}} ) {
  0            
146 0           print {$self->{fh}} ("{name}, "\">",
147 0 0         $_->{title} ? $html->($_->{title}) : " '",
148             "\n");
149             }
150 0           print {$self->{fh}} ("
  0            
151             }
152              
153             }
154              
155             ################ Internal methods ################
156              
157             sub html {
158 0     0 0   my $self = shift;
159 0           _html(@_);
160             }
161              
162             sub _html {
163 0     0     HTML::Entities::encode(shift);
164             }
165              
166             sub __html {
167 0     0     my ($t) = @_;
168 0           $t =~ s/&/&/g;
169 0           $t =~ s/
170 0           $t =~ s/>/>/g;
171 0           $t =~ s/\240/ /g;
172 0           $t =~ s/\x{eb}/ë/g; # for IVP.
173 0           $t;
174             }
175              
176             sub copy_style {
177 0     0 0   my ($out, $css) = @_;
178 0           my $in;
179 0 0         unless ( open($in, "<:encoding(utf-8)", $css) ) {
180 0           print {$out} ("/**** stylesheet $css: $! ****/\n");
  0            
181 0           return;
182             }
183 0           print {$out} ("/** begin stylesheet $css */\n");
  0            
184 0           while ( <$in> ) {
185 0 0         if ( /^\s*\@import\s*(["']?)(.*?)\1\s*;/ ) {
186 1     1   5 use File::Basename;
  1         1  
  1         130  
187 0           my $newcss = join("/", dirname($css), $2);
188 0           copy_style($out, $newcss);
189             }
190             else {
191 0           print {$out} $_;
  0            
192             }
193             }
194 0           close($in);
195 0           print {$out} ("/** end stylesheet $css */\n");
  0            
196             }
197              
198             1;