File Coverage

blib/lib/EB/Report/Reporter/Text.pm
Criterion Covered Total %
statement 12 168 7.1
branch 0 62 0.0
condition 0 13 0.0
subroutine 4 15 26.6
pod 0 4 0.0
total 16 262 6.1


line stmt bran cond sub pod time code
1             #! perl
2              
3             # Text.pm -- Reporter backend for text reports.
4             # Author : Johan Vromans
5             # Created On : Wed Dec 28 13:21:11 2005
6             # Last Modified By: Johan Vromans
7             # Last Modified On: Sat Jun 19 00:39:44 2010
8             # Update Count : 119
9             # Status : Unknown, Use with caution!
10              
11             package main;
12              
13             our $cfg;
14             our $dbh;
15              
16             package EB::Report::Reporter::Text;
17              
18 1     1   5 use strict;
  1         1  
  1         22  
19 1     1   4 use warnings;
  1         1  
  1         20  
20              
21 1     1   3 use EB;
  1         0  
  1         155  
22              
23 1     1   4 use base qw(EB::Report::Reporter);
  1         1  
  1         377  
24              
25             ################ API ################
26              
27             sub start {
28 0     0 0   my ($self, @args) = @_;
29 0           $self->SUPER::start(@args);
30 0           $self->_make_format;
31 0           $self->{_lines} = 0;
32 0           $self->{_page} = 0;
33 0 0         $self->{_colsep} = " " unless defined $self->{_colsep};
34             }
35              
36             sub finish {
37 0     0 0   my ($self) = @_;
38 0           $self->_checkskip(1); # cancel skips.
39 0           $self->SUPER::finish();
40 0           close($self->{fh});
41             }
42              
43             sub add {
44 0     0 0   my ($self, $data) = @_;
45              
46 0           my $style = delete($data->{_style});
47              
48 0           $self->SUPER::add($data);
49              
50 0           $self->_checkhdr;
51              
52 0           my $skip_after = 0;
53 0           my $line_after = 0;
54 0           my $cancel_skip = 0;
55 0 0 0       if ( $style and my $t = $self->_getstyle($style) ) {
56 0 0         $self->_skip if $t->{skip_before};
57 0           $skip_after = $t->{skip_after};
58 0 0         $self->_line if $t->{line_before};
59 0           $line_after = $t->{line_after};
60 0           $cancel_skip = $t->{cancel_skip};
61             }
62              
63 0           $self->_checkskip($cancel_skip);
64              
65 0           my @values;
66             my @widths;
67 0           my @indents;
68 0           my $linebefore;
69 0           my $lineafter;
70 0           my $colspan = 0;
71 0           my $lw;
72             #push(@values, $style||"") if $cfg->val(__PACKAGE__, "layout", 0);
73 0           foreach my $col ( @{$self->{_fields}} ) {
  0            
74              
75 0 0         if ( $colspan > 1 ) {
76 0           $colspan--;
77 0           $$lw += $col->{width} + length($self->{_colsep});
78 0           push(@values, "");
79 0           push(@widths, 0);
80 0           push(@indents, 0);
81 0           next;
82             }
83              
84 0           my $fname = $col->{name};
85 0 0         push(@values, defined($data->{$fname}) ? $data->{$fname} : "");
86 0           push(@widths, $col->{width});
87              
88             # Examine style mods.
89 0           my $indent = 0;
90 0           my $excess = 0;
91 0 0         if ( $style ) {
92 0 0         if ( my $t = $self->_getstyle($style, $fname) ) {
93 0   0       $indent = $t->{indent} || 0;
94 0 0         if ( $t->{line_before} ) {
95             $linebefore->{$fname} =
96 0 0         ($t->{line_before} eq "1" ? "-" : $t->{line_before}) x $col->{width};
97             }
98 0 0         if ( $t->{line_after} ) {
99             $lineafter->{$fname} =
100 0 0         ($t->{line_after} eq "1" ? "-" : $t->{line_after}) x $col->{width};
101             }
102 0 0         if ( $t->{excess} ) {
103             #### TODO $widths[-1] += $t->{excess};
104             }
105 0 0         if ( $t->{truncate} ) {
106 0           $values[-1] = substr($values[-1], 0, $widths[-1] - $indent);
107             }
108 0 0         if ( $t->{colspan} ) {
109 0           $colspan = $t->{colspan};
110 0           $lw = \$widths[-1];
111             }
112             }
113             }
114 0           push(@indents, $indent);
115              
116             }
117              
118             # use Data::Dumper;
119             # warn(Dumper \@values);
120             # warn(Dumper \@widths);
121 0 0         if ( $linebefore ) {
122 0           $self->add($linebefore);
123             }
124              
125 0           my @lines;
126 0           while ( 1 ) {
127 0           my $more = 0;
128 0           my @v;
129 0           foreach my $i ( 0..$#widths ) {
130 0           my $ind = $indents[$i];
131 0           my $maxw = $widths[$i] - $ind;
132 0           $ind = " " x $ind;
133 0 0         if ( length($values[$i]) <= $maxw ) {
134 0           push(@v, $ind.$values[$i]);
135 0           $values[$i] = "";
136             }
137             else {
138 0           my $t = substr($values[$i], 0, $maxw);
139 0 0         if ( substr($values[$i], $maxw, 1) eq " " ) {
    0          
140 0           push(@v, $ind.$t);
141 0           substr($values[$i], 0, length($t) + 1, "");
142             }
143             elsif ( $t =~ /^(.*)([ ]+)/ ) {
144 0           my $pre = $1;
145 0           push(@v, $ind.$pre);
146 0           substr($values[$i], 0, length($pre) + length($2), "");
147             }
148             else {
149 0           push(@v, $ind.$t);
150 0           substr($values[$i], 0, $maxw, "");
151             }
152 0           $more++;
153             }
154             }
155 0           my $t = $self->_format_line(\@v, \@widths);
156 0           $t =~ s/ +$//;
157 0 0         push(@lines, $t) if $t =~ /\S/;
158 0 0         last unless $more;
159             }
160              
161 0 0         if ( $self->{_lines} < @lines ) {
162 0           $self->{_needhdr} = 1;
163 0           $self->_checkhdr;
164             }
165 0           print {$self->{fh}} @lines;
  0            
166 0           $self->{_lines} -= @lines;
167              
168             # Post: Lines for cells.
169 0 0         if ( $lineafter ) {
170 0           $self->add($lineafter);
171             }
172             # Post: Line for row.
173 0 0         if ( $line_after ) {
    0          
174 0           $self->_line;
175             }
176             # Post: Skip after this row.
177             elsif ( $skip_after ) {
178 0           $self->_skip;
179             }
180             }
181              
182             ################ Pseudo-Internal (used by Base class) ################
183              
184             sub header {
185 0     0 0   my ($self) = @_;
186             my $t = sprintf("%s\n" .
187             "%-" . ($self->{_width}-10) . "s%10s\n" .
188             "%-" . ($self->{_width}-31) . "s%31s\n" .
189             "\n",
190             $self->_center($self->{_title1}, $self->{_width}),
191             $self->{_title2},
192             1 ? "" : ("Blad: " . (++$self->{_page})),
193 0           $self->{_title3l}, $self->{_title3r});
194              
195 0 0         if ( grep { $_->{title} =~ /\S/ } @{$self->{_fields}} ) {
  0            
  0            
196 0           $t .= $self->_format_line([map { $_->{title} } @{$self->{_fields}}],
  0            
197 0           [map { $_->{width} } @{$self->{_fields}}]),
  0            
  0            
198             }
199              
200 0           $t =~ s/ +$//gm;
201 0           print {$self->{fh}} ($t);
  0            
202 0           $self->_line;
203 0           $self->_checkskip(1); # cancel skips.
204 0           $self->{_lines} = $self->{page} - 6;
205             }
206              
207             ################ Internal methods ################
208              
209             sub _make_format {
210 0     0     my ($self) = @_;
211              
212 0           my $width = 0; # new width
213 0   0       my $cs = $self->{_colsep} || " ";
214 0           my $cw = length($cs);
215              
216 0           foreach my $a ( @{$self->{_fields}} ) {
  0            
217              
218 0           $width += $a->{width} + $cw;
219             }
220 0           $self->{_width} = $width - $cw;
221              
222             # PBP: Return nothing sensible.
223 0           return;
224             }
225              
226             sub _format_line {
227 0     0     my ($self, $values, $widths) = @_;
228              
229 0           my $t = "";
230 0           my $i = 0;
231 0           for ( my $i = 0; $i <= $#{$self->{_fields}}; $i++ ) {
  0            
232 0 0 0       $t .= $self->{_colsep} if $t ne '' && $widths->[$i];
233 0           my $a = $self->{_fields}->[$i];
234 0           my $v = shift(@$values);
235 0 0         if ( $a->{align} eq '<' ) {
236 0           $t .= $v;
237 0           $t .= ' ' x ($widths->[$i] - length($v));
238             }
239             #elsif ( $a->{align} eq '<' ) {
240             else {
241 0           $t .= ' ' x ($widths->[$i] - length($v));
242 0           $t .= $v;
243             }
244 0 0         $i += $a->{colspan} if $a->{colspan};
245             }
246 0           $t . "\n";
247             }
248              
249             sub _checkskip {
250 0     0     my ($self, $cancel) = @_;
251 0 0 0       return if !$self->{_needskip} || $self->{_lines} <= 0;
252 0 0         $self->{_lines}--, print {$self->{fh}} ("\n") unless $cancel;
  0            
253 0           $self->{_needskip} = 0;
254             }
255              
256             sub _line {
257 0     0     my ($self) = @_;
258              
259 0           $self->_checkhdr;
260 0           $self->_checkskip(1); # cancel skips.
261              
262 0           print {$self->{fh}} ("-" x ($self->{_width}), "\n");
  0            
263 0           $self->{_lines}--;
264             }
265              
266             sub _skip {
267 0     0     my ($self) = @_;
268              
269 0           $self->_checkhdr;
270 0           $self->{_needskip} = 1;
271             }
272              
273             sub _center {
274 0     0     my ($self, $text, $width) = @_;
275 0           (" " x (($width - length($text))/2)) . $text;
276             }
277              
278             sub _expand {
279 0     0     my ($self, $text) = @_;
280 0           $text =~ s/(.)/$1 /g;
281 0           $text =~ s/ +$//;
282 0           $text;
283             }
284              
285             1;