File Coverage

blib/lib/Test/Smoke/Database/Display.pm
Criterion Covered Total %
statement 52 214 24.3
branch 5 90 5.5
condition 1 55 1.8
subroutine 11 16 68.7
pod 4 9 44.4
total 73 384 19.0


line stmt bran cond sub pod time code
1             package Test::Smoke::Database::Display;
2              
3             # Test::Smoke::Database::Display -
4             # Copyright 2003 A.Barbet alian@alianwebserver.com. All rights reserved.
5             # $Date: 2004/04/19 17:50:09 $
6             # $Log: Display.pm,v $
7             # Revision 1.9 2004/04/19 17:50:09 alian
8             # fix on warnings
9             #
10             # Revision 1.8 2003/11/07 17:34:25 alian
11             # Change display at import
12             #
13             # Revision 1.7 2003/09/16 15:41:50 alian
14             # - Update parsing to parse 5.6.1 report
15             # - Change display for lynx
16             # - Add top smokers
17             #
18             # Revision 1.6 2003/08/19 10:37:24 alian
19             # Release 1.14:
20             # - FORMAT OF DATABASE UPDATED ! (two cols added, one moved).
21             # - Add a 'version' field to filter/parser (Eg: All perl-5.8.1 report)
22             # - Use the field 'date' into filter/parser (Eg: All report after 07/2003)
23             # - Add an author field to parser, and a smoker HTML page about recent
24             # smokers and their available config.
25             # - Change how nbte (number of failed tests) is calculate
26             # - Graph are done by month, no longuer with patchlevel
27             # - Only rewrite cc if gcc. Else we lost solaris info
28             # - Remove ccache info for have less distinct compiler
29             # - Add another report to tests
30             # - Update FAQ.pod for last Test::Smoke version
31             # - Save only wanted headers for each nntp articles (and save From: field).
32             # - Move away last varchar field from builds to data
33             #
34             # Revision 1.5 2003/08/15 16:08:16 alian
35             # Display link for X status
36             #
37             # Revision 1.4 2003/08/15 15:10:03 alian
38             # Update html for be able to browse database with lynx
39             #
40             # Revision 1.3 2003/08/08 13:58:09 alian
41             # Update display limit
42             #
43             # Revision 1.2 2003/08/06 19:20:51 alian
44             # Add proto to methods
45             #
46             # Revision 1.1 2003/08/06 18:50:42 alian
47             # New interfaces with DB.pm & Display.pm
48             #
49              
50 3     3   17 use Carp;
  3         7  
  3         199  
51 3     3   14 use strict;
  3         5  
  3         179  
52 3     3   16 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
  3         7  
  3         226  
53 3     3   118113 use CGI qw/:standard -no_xhtml/;
  3         56640  
  3         25  
54 3     3   19143 use Data::Dumper;
  3         8  
  3         301  
55 3     3   19 use Carp qw(cluck);
  3         6  
  3         385  
56             require Exporter;
57              
58             @ISA = qw(Exporter);
59             @EXPORT = qw();
60             $VERSION = ('$Revision: 1.9 $ ' =~ /(\d+\.\d+)/)[0];
61              
62 3     3   19 use vars qw/$debug $verbose/;
  3         9  
  3         14290  
63              
64             my $limite = 18600;
65             #$limite = 0;
66              
67              
68             #------------------------------------------------------------------------------
69             # new
70             #------------------------------------------------------------------------------
71             sub new {
72 1     1 0 4 my $class = shift;
73 1         3 my $self = {};
74 1         2 my $indexer = shift;
75 1         3 bless $self, $class;
76 1 50       6 $debug = ($indexer->{opts}->{debug} ? 1 : 0);
77 1 50       5 $verbose = ($indexer->{opts}->{verbose} ? 1 : 0);
78 1         9 $self->{CGI} = $indexer->{opts}->{cgi};
79 1         2 $self->{DB} = $indexer->{DB};
80 1         5 $limite = $indexer->{opts}->{limit};
81 1 50       13 $ENV{SCRIPT_NAME}='localhost' if !$ENV{SCRIPT_NAME};
82 1         5 return $self;
83             }
84              
85             #------------------------------------------------------------------------------
86             # db
87             #------------------------------------------------------------------------------
88 2     2 0 249 sub db(\%) { return $_[0]->{DB}; }
89              
90             #------------------------------------------------------------------------------
91             # header
92             #------------------------------------------------------------------------------
93             sub header_html(\%) {
94 1     1 1 2 my $self = shift;
95 1   50     13 my $u = $self->{opts}->{url_base} || $ENV{BASE} || '/perl/smoke';
96 1 50       6 if (!$ENV{SCRIPT_NAME}) {
97 0   0     0 $ENV{SCRIPT_NAME} = $ENV{CGI_BASE} || '/cgi-bin';
98 0         0 $ENV{SCRIPT_NAME}.='/smoke_db.cgi';
99             }
100 1         72 my $buf = start_html
101             (-style=>{'src'=>"$u/smokedb.css"}, -title=>"perl-current smoke results");
102 1         8671 $buf.= <
103            
 
104             Home | 
105             Filter | 
106             Last report | 
107             Last smoke | 
108            
109             Last failures | 
110            
111             Smokers | 
112             FAQ | 
113             Stats | 
114             About | 
115             Author | 
116            
117            
118            

Perl-current smoke results
119             EOF
120 1         6 return $buf;
121              
122             }
123              
124             #------------------------------------------------------------------------------
125             # filter
126             #------------------------------------------------------------------------------
127             sub filter(\%) {
128 0     0 1 0 my $d = shift;
129 0         0 my $cgi = $d->{CGI};
130 0         0 my %t =
131             (
132             'os' => '1 - Os',
133             'osver' => '2 - Version OS',
134             'archi' => '3 - Architecture',
135             'cc' => '4 - Compiler',
136             'ccver' => '5 - Compiler version',
137             'smoke' => '6 - Only this smoke',
138             'last_smoke' => '7 - Nothing before patchlevel',
139             'version' => '8 - Perl version',
140             );
141 0         0 my $bi = h2("Filter").start_form({-method=>'GET'}).""; "; ";
142 0 0       0 $bi.= hidden({-name=>'last',-value=>1}) if ($cgi->param('last'));
143 0 0       0 $bi.= hidden({-name=>'failure',-value=>1}) if ($cgi->param('failure'));
144 0         0 foreach my $o (sort { $t{$a} cmp $t{$b} } keys %t) {
  0         0  
145 0         0 $bi.='
'.$t{$o}.''.
146             "
147 0         0 my $r = $o;
148             # print STDERR $r,"\n";
149 0 0       0 $r = 'smoke' if ($o eq 'last_smoke');
150 0         0 my @l = @{$d->db->distinct($r)};
  0         0  
151 0 0 0     0 push(@l,"Last") if ($o eq 'smoke' or $o eq 'last_smoke');
152 0 0       0 @l = reverse @l if ($o eq 'smoke');
153 0   0     0 my $v = param($o) || param($o.'_fil') || cookie($o) || undef;
154 0 0 0     0 $v = $limite if (!$v and $o eq 'last_smoke');
155 0         0 foreach my $name (@l) {
156 0 0       0 my $sname = (($o eq 'ccver') ? substr($name,0,15) : $name);
157 0 0 0     0 if (($v and $v eq $name) or (!$v and $name eq 'Last') or
      0        
      0        
      0        
      0        
158             ($o eq 'last_smoke' and $name eq $limite)) {
159 0         0 $bi.="\n";
160             } else {
161 0         0 $bi.="\n";
162             }
163             }
164 0         0 $bi.="
165             }
166 0         0 $bi.="
167             9 - Results after date:
168            
169 0         0 foreach my $i (2001..2003) {
170 0         0 foreach my $j (1..12) {
171 0         0 my $d = $i.'-'.sprintf("%02d",$j) ;
172 0         0 $bi.='";
173             }
174             }
175 0         0 $bi.= "
176 0         0 $bi.= Tr(td(),td(submit))."
".end_form;
177 0         0 return $bi;
178             }
179              
180             #------------------------------------------------------------------------------
181             # display
182             #------------------------------------------------------------------------------
183             sub display(\%$$$$$$) {
184 1     1 1 4 my ($self,$os,$osver,$ar,$cc,$ccver,$smoke)=@_;
185 1         4 my ($i,$summary,$details,$failure,$class,$resume)=(0);
186 1         3 my ($lastsmoke, $lastsuccessful)=(0,0,0);
187             # Walk on each smoke
188 1         9 $summary = "
189            
190             ". ".td($config);
191             Tr(th("Os".(' ' x 5)), th("Os version".(' ' x 5)),
192             th("Archi" .(' ' x 3)), th("Compiler"),
193             th("Version compiler"), th("Patchlevel"), th(a({-href=>'#legend'},"(1)")),
194             th({-width=>"15"},a({-href=>'#legend'},"(2)")),
195             th({-width=>"15"},a({-href=>'#legend'},"(3)")),
196             th({-width=>"15"},a({-href=>'#legend'},"(4)")),
197             th({-width=>"15"},a({-href=>'#legend'},"(5)")),
198             th({-width=>"15"},a({-href=>'#legend'},"(6)")),
199             th("(7)"))."\n";
200 1         2910 my $ref = $self->db->read_all;
201 1         5 my ($lasta,$lastosv,$lastcc,$lastccv,$lastar,$oss,$osvv,$ccc,$ccvv,$arr)=
202             (" "," "," "," "," ");
203 1         2 my @ls;
204             # By os
205 1         5 foreach my $os (sort keys %$ref) {
206             # By os version
207 0         0 $lastosv = " ";
208 0         0 foreach my $osver (sort keys %{$$ref{$os}}) {
  0         0  
209             # By arch
210 0         0 $lastar= " ";
211 0         0 foreach my $ar (sort keys %{$$ref{$os}{$osver}}) {
  0         0  
212             # By cc
213 0         0 $lastcc=" ";
214 0         0 foreach my $cc (sort keys %{$$ref{$os}{$osver}{$ar}}) {
  0         0  
215             # By ccver
216 0         0 $lastccv=" ";
217 0         0 foreach my $ccver (sort keys %{$$ref{$os}{$osver}{$ar}{$cc}}) {
  0         0  
218             # By smoke
219 0         0 undef @ls;
220 0 0 0     0 if ($smoke && $smoke eq 'All') {
    0 0        
221 0         0 @ls = reverse sort keys %{$$ref{$os}{$osver}{$ar}{$cc}{$ccver}};
  0         0  
222             }
223             elsif (!$smoke or $smoke eq 'Last') {
224             # On prend le dernier smoke
225 0         0 @ls = reverse sort keys %{$$ref{$os}{$osver}{$ar}{$cc}{$ccver}};
  0         0  
226 0         0 @ls = shift @ls;
227             }
228 0         0 else { @ls =($smoke); }
229              
230 0         0 foreach my $smoke (sort @ls) {
231 0 0       0 next if (!$$ref{$os}{$osver}{$ar}{$cc}{$ccver}{$smoke});
232 0 0       0 $lastsmoke = $smoke if ($smoke >$lastsmoke);
233 0         0 my ($nbt,$nbc,$nbto,$nbcf,$nbcm,$nbcc,$nbtt,$matrix)=
234             ($$ref{$os}{$osver}{$ar}{$cc}{$ccver}{$smoke}{nbte},
235             $$ref{$os}{$osver}{$ar}{$cc}{$ccver}{$smoke}{nbc},
236             $$ref{$os}{$osver}{$ar}{$cc}{$ccver}{$smoke}{nbco},
237             $$ref{$os}{$osver}{$ar}{$cc}{$ccver}{$smoke}{nbcf},
238             $$ref{$os}{$osver}{$ar}{$cc}{$ccver}{$smoke}{nbcm},
239             $$ref{$os}{$osver}{$ar}{$cc}{$ccver}{$smoke}{nbcc},
240             $$ref{$os}{$osver}{$ar}{$cc}{$ccver}{$smoke}{nbtt},
241             $$ref{$os}{$osver}{$ar}{$cc}{$ccver}{$smoke}{matrix}
242             );
243 0         0 my $id = $$ref{$os}{$osver}{$ar}{$cc}{$ccver}{$smoke}{id};
244             # Matrice
245 0         0 my $matrixe;
246 0         0 my $y=0;
247 0   0     0 my @ltmp = split(/\|/, $matrix || " ");
248              
249             # debut des tableaux erreurs et details
250 0         0 my $de = "\n ". ".(""x$y++). "x($#ltmp-$y+2))."";
251             Tr(th({-colspan=> (2 + $#ltmp) },
252             "$os $osver $ar $cc $ccver smoke patch $smoke")).
253             Tr(th({-colspan=> (2 + $#ltmp) },
254             'Original report'));
255 0         0 foreach (@ltmp) {
256 0         0 $matrixe.="
$__
257             ("|
258             }
259             # Liste des tests echoues
260 0 0 0     0 if (param('failure') && $nbt && $$ref{$os}{$osver}{$ar}{$cc}{$ccver}{$smoke}{failure}) {
      0        
261 0         0 $failure.=$de.Tr(td(pre($$ref{$os}{$osver}{$ar}{$cc}{$ccver}{$smoke}{failure})))."

";
262             }
263             # Liste des configs testees
264 0 0       0 if (ref($$ref{$os}{$osver}{$ar}{$cc}{$ccver}{$smoke}{build})) {
265 0         0 my $r2 = 1;
266 0         0 my ($dets);
267 0         0 foreach my $config (sort keys %{$$ref{$os}{$osver}{$ar}{$cc}{$ccver}{$smoke}{build}}) {
  0         0  
268 0         0 $dets.= "
269 0         0 my $co=""; ";
270 0         0 my $r = 1; my $classe=" ";
  0         0  
271 0         0 foreach my $v (split(/ /,$$ref{$os}{$osver}{$ar}{$cc}{$ccver}{$smoke}{build}{$config})) {
272 0         0 my $u = $ENV{SCRIPT_NAME}."?failure=1&smoke=$smoke";
273 0 0       0 $u.=$self->compl_url if ($self->compl_url);
274 0 0       0 $u.="#$id" if ($id);
275 0 0 0     0 if ( ($v eq 'F') or ($v eq 'X')) {
    0 0        
276 0         0 $v= a({-href=>$u},$v); $r=0; $r2=0;
  0         0  
  0         0  
277             } elsif ($v eq 'm' or $v eq 'c') {
278 0         0 $classe="red";
279             }
280 0         0 $dets.=td({-class=>$classe,-width=>3},$v);
281             }
282 0         0 $dets.="
283 0         0 $nbto+=$r;
284 0         0 $nbc++;
285             }
286 0 0 0     0 $details.=$de.$dets.$matrixe."

"
287             if (!param('want_smoke') or !$r2);
288             }
289             # Sommaire
290 0 0       0 if ($lasta ne $os) {
291 0         0 $oss = cw($os,7); $lasta = $os; $class=($i++)%2;
  0         0  
  0         0  
292 0         0 } else { $oss=cw(undef,7); }
293 0 0       0 if ($lastcc ne $cc) {
294 0         0 $ccc = cw($cc,8); $lastcc = $cc; }
  0         0  
295 0         0 else { $ccc=cw(undef,8); }
296 0 0       0 if ($lastccv ne $ccver) {
297 0         0 $ccvv = cw($ccver,18); $lastccv = $ccvv;
  0         0  
298 0         0 } else { $ccvv=cw(undef,18); }
299 0 0       0 if ($lastosv ne $osver) {
300 0         0 $osvv = cw($osver,15); $lastosv = $osver;
  0         0  
301 0         0 } else { $osvv=cw(undef, 15); }
302 0 0       0 if ($lastar ne $ar) { $arr = cw($ar,7); $lastar = $ar; }
  0         0  
  0         0  
303 0         0 else { $arr=cw(undef,7); }
304 0 0       0 if ($nbt) {
305 0         0 my $u = $ENV{SCRIPT_NAME}."?failure=1&smoke=$smoke";
306 0 0       0 $u.=$self->compl_url if ($self->compl_url);
307 0 0       0 $u.="#$id" if ($id);
308 0         0 $nbt=a({-href=>$u,-class=>'red'},cn($nbt));
309 0         0 $nbt = td({-align=>"center", -class=>'red'},$nbt);
310             }
311 0         0 else { $nbt=td({-align=>"center"},cn(0)); }
312 0         0 my $u = $ENV{SCRIPT_NAME}."?last=1&smoke=$smoke";
313 0 0       0 $u.= $self->compl_url if ($self->compl_url);
314 0 0       0 $u.="#$id" if ($id);
315 0         0 my $ss="makeOk";
316 0 0       0 if ($nbcc) { $ss='confFail';}
  0 0       0  
    0          
317 0         0 elsif ($nbcm) { $ss='makeFail';}
318 0         0 elsif ($nbcf) { $ss='makeTestFail';}
319 0         0 $summary.=Tr({-class=>"mod".$class},
320             td({-class=>"os"},$oss),
321             td({-class=>"osver"},$osvv),
322             td({-class=>"archi"},$arr." "),
323             td({-class=>"cc"},$ccc),
324             td({-class=>"ccver"},$ccvv),
325             td({-class=>"smoke"},a({-href=>$u}, $smoke)),
326             td({-class=>"configure"},cn($nbc)),
327             td({-class=>$ss,-width=>"15"},cn($nbtt)),
328             td({-class=>$ss,-width=>"15"},cn($nbto)),
329             td({-class=>$ss,-width=>"15"},cn($nbcc)),
330             td({-class=>$ss,-width=>"15"},cn($nbcm)),
331             td({-class=>$ss,-width=>"15"},cn($nbcf)),
332             $nbt)."\n";
333 0 0 0     0 $lastsuccessful = $smoke if ($nbto == $nbtt && ($smoke>$lastsuccessful));
334             }
335             }
336             }
337             }
338             }
339             }
340 1         3 $summary.=<
341            
342            
343            
344            

Legend
345            
346            
  • Number of configure run
    		•
    347            
  • Number of make test run
    		•
    348            
  • Number of make test ok
    		•
    349            
  • Number of failed configure
    		•
    350            
  • Number of failed make
    		•
    351            
  • Number of failed make test
    		•
    352            
  • Number of failed test
    		•
    353            
    354            
    355             EOF
    356 1 50       6 $lastsuccessful = "Never" if ! $lastsuccessful;
    357 1         29 $resume = table({ border=>1, class=>"box2" },
    358             Tr(th("Smoke available"),
    359             th("Since smoke"),
    360             th("Last, "),
    361             th("Last successfull")),
    362             Tr(td($self->db->nb), td($limite),
    363             td($lastsmoke),td($lastsuccessful)));
    364 1         1083 $summary = $resume.$summary;
    365 1         7 return (\$summary,\$details,\$failure);
    366             }
    367              
    368              
    369             #------------------------------------------------------------------------------
    370             # smokers
    371             #------------------------------------------------------------------------------
    372             sub smokers {
    373 0     0 0   my $self = shift;
    374 0           my $ref = $self->db->read_smokers;
    375             # print STDERR Data::Dumper->Dump([$ref]);
    376 0           my $buf=Tr(th(cw("Author", 28)), th(cw("Os",7)), th(cw("Os version",16)),
    377             th(cw("Architecture",10)), th(cw("Cc",15)),
    378             th(cw("Cc version",15)), th(cw("Nb smoke",3)));
    379 0           my $i=0;
    380              
    381             # List of config in last 6 month
    382             # Tab author
    383 0           foreach my $author (keys %$ref) {
    384 0           my ($bu);
    385 0           my $aa = $author;
    386 0           $aa=~s/\@/ at /g;
    387 0           my ($os, $osver);
    388             # Tab config
    389 0           foreach (@{$ref->{$author}}) {
      0            
    390 0 0         $bu = $bu ? td(cw(undef, 28)) : td(cw($aa, 28));
    391             # tab specs
    392 0 0         $bu.=td(cw(($_->[0] eq $os ? " " : $_->[0]), 7)).
        0          
    393             td(cw(($_->[1] eq $osver ? " " : $_->[1]), 16)).
    394             td(cw($_->[2], 10)).td(cw($_->[3], 15)).
    395             td(cw($_->[4], 15)). td(cw($_->[5], 3));
    396 0           ($os, $osver) = ($_->[0], $_->[1]);
    397 0           $buf.=Tr({-class=>'mod'.$i%2},$bu)."\n";
    398             }
    399 0           $i++;
    400             }
    401 0           $buf = h2("Smokers in last 6 month").
    402             table({-class => 'box', -border=>1}, $buf);
    403              
    404             # top 20 smokers
    405 0           $ref = $self->db->read_top_smokers(20);
    406 0           my $bu;
    407 0           $buf.=h2("Top 20 smokers since beginning");
    408 0           foreach (@$ref) {
    409 0           my $author = shift @$_;
    410 0           $author=~s/\@/ at /g;
    411 0           $bu.=Tr({-class=>'mod'.$i++%2}, td($author), td($_->[0]));
    412             }
    413 0           $buf.=table({-class => 'box', -border=> 1},
    414             Tr(th(cw("Author")), th(cw("Nb smoke"))), $bu);
    415 0           return $buf
    416             }
    417              
    418             #------------------------------------------------------------------------------
    419             # cw
    420             #------------------------------------------------------------------------------
    421             sub cw($$) {
    422 0     0 0   my ($word, $size)= @_;
    423 0 0         $size = 10 if !$size;
    424 0 0 0       return ($word || "").(" " x ($size - ($word ? length($word) :0 )));
    425             }
    426              
    427             #------------------------------------------------------------------------------
    428             # cn
    429             #------------------------------------------------------------------------------
    430             sub cn($) {
    431 0 0   0 0   return ( ($_[0] <10) ? ' '.$_[0] : $_[0]);
    432             }
    433              
    434             #------------------------------------------------------------------------------
    435             # compl_url
    436             #------------------------------------------------------------------------------
    437             sub compl_url(\%) {
    438 0     0 1   my $self = shift;
    439 0           my $buf;
    440 0           foreach ('os','osver','archi','cc','ccver','smoke') {
    441 0 0         $buf.="&$_=".param($_) if (param($_));
    442             }
    443 0           return $buf;
    444             }
    445              
    446             __END__