File Coverage

blib/lib/Test/Smoke/Database/Graph.pm
Criterion Covered Total %
statement 19 236 8.0
branch 0 104 0.0
condition 0 47 0.0
subroutine 7 21 33.3
pod 1 14 7.1
total 27 422 6.4


/, $content)) {
line stmt bran cond sub pod time code
1             package Test::Smoke::Database::Graph;
2              
3             # module Test::Smoke::Database - Create graph about smoke database
4             # Copyright 2003 A.Barbet alian@alianwebserver.com. All rights reserved.
5             # $Date: 2003/11/07 17:34:01 $
6             # $Log: Graph.pm,v $
7             # Revision 1.10 2003/11/07 17:34:01 alian
8             # Return undef if fetch by-config failed
9             #
10             # Revision 1.9 2003/09/16 15:41:50 alian
11             # - Update parsing to parse 5.6.1 report
12             # - Change display for lynx
13             # - Add top smokers
14             #
15             # Revision 1.8 2003/08/19 10:37:24 alian
16             # Release 1.14:
17             # - FORMAT OF DATABASE UPDATED ! (two cols added, one moved).
18             # - Add a 'version' field to filter/parser (Eg: All perl-5.8.1 report)
19             # - Use the field 'date' into filter/parser (Eg: All report after 07/2003)
20             # - Add an author field to parser, and a smoker HTML page about recent
21             # smokers and their available config.
22             # - Change how nbte (number of failed tests) is calculate
23             # - Graph are done by month, no longuer with patchlevel
24             # - Only rewrite cc if gcc. Else we lost solaris info
25             # - Remove ccache info for have less distinct compiler
26             # - Add another report to tests
27             # - Update FAQ.pod for last Test::Smoke version
28             # - Save only wanted headers for each nntp articles (and save From: field).
29             # - Move away last varchar field from builds to data
30             #
31             # Revision 1.7 2003/08/15 15:50:40 alian
32             # Group smoke for graph
33             #
34             # Revision 1.6 2003/08/06 18:50:42 alian
35             # New interfaces with DB.pm & Display.pm
36             #
37             # Revision 1.5 2003/08/02 12:38:27 alian
38             # Minor typo
39             #
40             # Revision 1.4 2003/07/30 15:42:27 alian
41             # -Graph in 1000*300
42             # - Graphs always in png
43             # - Add warn messages
44             # - Add use of GD in a eval
45             #
46             # Revision 1.3 2003/07/19 18:12:16 alian
47             # Use a debug flag and a verbose one. Fix output
48             #
49             # Revision 1.2 2003/02/16 16:14:29 alian
50             # - Add CPAN chart
51             # - All graph are 1000*300
52             # - Change new parameters: use a var for directory where create img
53              
54 3     3   19 use strict;
  3         5  
  3         163  
55 3     3   18 use Data::Dumper;
  3         7  
  3         143  
56 3     3   3552 use LWP::Simple;
  3         960419  
  3         60  
57 3     3   1802 use Carp qw/confess/;
  3         7  
  3         155  
58 3     3   3836 use POSIX;
  3         39820  
  3         26  
59 3     3   1584 eval("
  0            
  0            
60             use GD::Graph::mixed;
61             use GD::Graph::colour;
62             use GD::Graph::Data;
63             ");
64              
65 3     3   14484 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
  3         9  
  3         13298  
66             require Exporter;
67              
68              
69             @ISA = qw(Exporter);
70             @EXPORT = qw(prompt);
71             $VERSION = ('$Revision: 1.10 $ ' =~ /(\d+\.\d+)/)[0];
72              
73             my $debug = 0;
74             my $font = '/usr/X11R6/share/enlightenment/themes/Blue_OS/ttfonts/arial.ttf';
75              
76             #------------------------------------------------------------------------------
77             # new
78             #------------------------------------------------------------------------------
79             sub new {
80 0     0 1   my $class = shift;
81 0           my $self = {};
82 0           bless $self, $class;
83 0           $self->{DBH} = shift;
84 0           $self->{dbsmoke} = shift;
85 0   0       $self->{LIMIT} = shift || 0;
86 0   0       $self->{DIR} = shift || $self->{LIMIT};
87 0 0         if (!-e $self->{DIR}) {
88 0 0         if (!mkdir $self->{DIR},0755) {
89 0           die "Can't create $self->{DIR}:$!\n";
90             }
91             }
92 0           return $self;
93             }
94              
95             #------------------------------------------------------------------------------
96             # percent_configure
97             #------------------------------------------------------------------------------
98             sub percent_configure {
99 0     0 0   my $self = shift;
100 0           my $request = "select DATE_FORMAT(date,'%Y-%c'),
101             os,
102             (sum(nbco)/sum(nbco+nbcf+nbcc+nbcm))*100
103             from builds ";
104 0 0         $request.="where smoke > $self->{LIMIT} " if ($self->{LIMIT});
105 0           $request.="group by 1,os order by 1";
106 0           my (%l,%tt);
107 0           my $st = $self->{DBH}->prepare($request);
108 0 0         $st->execute || print STDERR $request,"
";
109 0 0         while (my @l = $st->fetchrow_array) { $l{lc($l[1])}{$l[0]}=$l[2] if ($l[2]);}
  0            
110 0           $st->finish;
111 0           my @l1;
112 0           foreach my $os (keys %l) {
113 0           $os=~s!/!!g;
114 0           my (@l,@l2,$tt);
115 0           foreach (sort keys %{$l{$os}}) {
  0            
116 0           push(@l,$_);
117 0           push(@l2,$l{$os}{$_});
118 0           $tt+=$l{$os}{$_};
119             }
120 0 0         next if $#l2 < 2;
121 0           $tt{$os}=sprintf("%2d", $tt/($#l2+1));
122 0           my @la=(\@l, \@l2);
123 0           my $my_graph = GD::Graph::area->new(1000,300);
124 0           $my_graph->set_legend("","% of successful make test");
125 0 0         $my_graph->set(
126             title => '% of successful make test for '
127             .$os. ' each month',
128             y_max_value => 100,
129             y_tick_number => 10,
130             x_label_skip => ($#l2)/ 8,
131             legend_spacing => 40,
132             axis_space => 20,
133             t_margin => 40,
134             b_margin => 10,
135             box_axis => 0,
136             dclrs => [ qw/dpurple/ ],
137             transparent => 0,
138             )
139             or warn $my_graph->error;
140 0           go($my_graph, \@la, "$self->{DIR}/9_os_".$os);
141             }
142             }
143             #------------------------------------------------------------------------------
144             # percent_configure_all
145             #------------------------------------------------------------------------------
146             sub percent_configure_all {
147 0     0 0   my $self = shift;
148 0           my $request = "select DATE_FORMAT(date,'%Y-%c'),
149             (sum(nbco)/sum(nbco+nbcf+nbcc+nbcm))*100 from builds ";
150 0 0         $request.="where smoke > $self->{LIMIT} " if ($self->{LIMIT});
151 0           $request.="group by 1 order by 1";
152 0           my $ref = $self->fetch_array($request);
153 0           my $my_graph = GD::Graph::area->new(1000,300);
154 0           $my_graph->set_legend("","% of successful make test");
155 0 0         $my_graph->set(
156             title => '% of successful make test each month',
157             y_max_value => 100,
158             y_tick_number => 10,
159             x_label_skip => 3,
160             legend_spacing => 40,
161             axis_space => 20,
162             t_margin => 40,
163             b_margin => 10,
164             box_axis => 0,
165             dclrs => [ qw/black/ ],
166             transparent => 0,
167             )
168             or warn $my_graph->error;
169 0           go($my_graph, $ref, "$self->{DIR}/90_os");
170             }
171              
172             #------------------------------------------------------------------------------
173             # configure_per_smoke
174             #------------------------------------------------------------------------------
175             sub configure_per_smoke {
176 0     0 0   my $self = shift;
177 0           my $req ="select DATE_FORMAT(date,'%Y-%c'),
178             sum(nbco+nbcf+nbcc+nbcm),
179             sum(nbco) from builds ";
180 0 0         $req.="where smoke > $self->{LIMIT} " if ($self->{LIMIT});
181 0           $req.="group by 1 order by 1";
182 0           my $ref = $self->fetch_array($req);
183 0           my $my_graph = GD::Graph::mixed->new(1000,300);
184 0           $my_graph->set_legend("make test run","make test pass all tests");
185 0 0         $my_graph->set(
186             y_label => 'make test run',
187             title => 'make test run/pass all tests each month',
188             y_max_value => 40000,
189             y_tick_number => 10,
190             x_label_skip => 3,
191             types => [qw(lines area )],
192             shadowclr => 'dred',
193             transparent => 0,
194             legend_spacing => 30,
195             dclrs => [ qw/red dblue/ ],
196             axis_space => 20,
197             t_margin => 50,
198             b_margin => 20,
199             box_axis => 0,
200              
201             )
202             or warn $my_graph->error;
203 0           go($my_graph, $ref, "$self->{DIR}/7_conftested");
204             }
205              
206             #------------------------------------------------------------------------------
207             # configure_per_os
208             #------------------------------------------------------------------------------
209             sub configure_per_os {
210 0     0 0   my $self = shift;
211 0           my $req = "select os,sum(nbc) from builds ";
212 0 0         $req.="where smoke > $self->{LIMIT} " if ($self->{LIMIT});
213 0           $req.="group by os order by 2";
214 0           my $ref = $self->fetch_array($req,2);
215             # no info about this config. Can't create graph
216 0 0 0       if (!ref($$ref[1]) || ref($$ref[1] ne 'ARRAY')) {
217 0           warn __PACKAGE__." not enough data to make graph with \"$req\".";
218 0           return;
219             }
220 0           my @a = @{$$ref[1]};
  0            
221 0           my $my = (floor($a[$#a] / 50)+1)*50;
222 0           my $my_graph = GD::Graph::bars->new(1000,300);
223 0           $my_graph->set_legend("","os tested");
224 0 0         $my_graph->set(
225             title => 'Number of configure run by os',
226             y_max_value => $my,
227             y_tick_number => 5,
228             show_values => 1,
229             x_label_skip => 1,
230             y_label_position => 0,
231             axis_space => 20,
232             shadowclr => 'dred',
233             shadow_depth => 4,
234             transparent => 0,
235             bar_spacing => 10,
236             legend_spacing => 40,
237             t_margin => 35,
238             box_axis => 0,
239             )
240             or warn $my_graph->error;
241 0           return go($my_graph, $ref, "$self->{DIR}/4_nb_configure");
242             }
243              
244             #------------------------------------------------------------------------------
245             # smoke_per_os
246             #------------------------------------------------------------------------------
247             sub smoke_per_os {
248 0     0 0   my $self = shift;
249 0           my $req = "select os,count(id) from builds ";
250 0 0         $req.="where smoke > $self->{LIMIT} " if ($self->{LIMIT});
251 0           $req.="group by os order by 2";
252 0           my $ref = $self->fetch_array($req,2);
253             # no info about this config. Can't create graph
254 0 0 0       if (!ref($$ref[1]) || ref($$ref[1] ne 'ARRAY')) {
255 0           warn __PACKAGE__." not enough data to make smoke per os graph";
256 0           return undef;
257             }
258 0           my @a = @{$$ref[1]};
  0            
259 0           my $my = (floor($a[$#a] / 50)+1)*50;
260 0           my $my_graph = GD::Graph::bars->new(1000,300);
261 0           $my_graph->set_legend("","os tested");
262 0 0         $my_graph->set(
263             title => 'Number of smoke run by os',
264             y_max_value => $my,
265             y_tick_number => 10,
266             show_values => 1,
267             x_label_skip => 1,
268             y_label_position => 0,
269             axis_space => 20,
270             shadowclr => 'dred',
271             shadow_depth => 4,
272             transparent => 0,
273             bar_spacing => 10,
274             legend_spacing => 40,
275             t_margin => 35,
276             box_axis => 0
277             )
278             or warn $my_graph->error;
279 0           return go($my_graph, $ref, "$self->{DIR}/3_nb_smoke");
280             }
281              
282             #------------------------------------------------------------------------------
283             # os_by_smoke
284             #------------------------------------------------------------------------------
285             sub os_by_smoke {
286 0     0 0   my $self = shift;
287 0           my $req = "select DATE_FORMAT(date,'%Y-%c'),count(distinct os,osver,archi,cc) from builds ";
288 0 0         $req.="where smoke > $self->{LIMIT} " if ($self->{LIMIT});
289 0           $req.="group by 1 order by 1";
290 0           my $ref = $self->fetch_array($req);
291 0           my $my_graph = GD::Graph::area->new(1000,300);
292 0           $my_graph->set_legend("","os tested");
293 0 0         $my_graph->set(
294             title => 'Number of distinct smoke machine each month',
295             y_max_value => 50,
296             y_tick_number => 10,
297             x_label_skip => 3,
298             y_label_position => 0,
299             axis_space => 20,
300             # shadows
301             shadowclr => 'dred',
302             shadow_depth => 4,
303             transparent => 0,
304             bar_spacing => 10,
305             legend_spacing => 40,
306             t_margin => 35,
307             box_axis => 0
308             )
309             or warn $my_graph->error;
310 0           go($my_graph, $ref, "$self->{DIR}/6_nb_os_by_smoke");
311             }
312              
313             #------------------------------------------------------------------------------
314             # success_by_os
315             #------------------------------------------------------------------------------
316             sub success_by_os {
317 0     0 0   my $self = shift;
318 0           my $req = "select os,(sum(nbco)/sum(nbco+nbcc+nbcm+nbcf))*100 from builds ";
319 0 0         $req.="where smoke > $self->{LIMIT} " if ($self->{LIMIT});
320 0           $req.="group by os order by 2";
321 0           my $ref = $self->fetch_array($req, 15);
322 0           my $my_graph = GD::Graph::bars->new(1000,300);
323 0           $my_graph->set_legend("","os tested");
324 0 0         $my_graph->set(
325             title => 'Average % of successful make test by os',
326             y_max_value => 100,
327             y_tick_number => 10,
328             show_values => 1,
329             x_label_skip => 1,
330             y_label_position => 0,
331             axis_space => 20,
332             # shadows
333             shadowclr => 'dred',
334             shadow_depth => 4,
335             transparent => 0,
336             bar_spacing => 10,
337             legend_spacing => 40,
338             t_margin => 35,
339             box_axis => 0
340             )
341             or warn $my_graph->error;
342 0           go($my_graph, $ref, "$self->{DIR}/5_configure_by_os");
343             }
344              
345             #------------------------------------------------------------------------------
346             # go
347             #------------------------------------------------------------------------------
348             sub go {
349 0     0 0   my ($my_graph, $data, $filename)=@_;
350 0           my $ok = 0;
351 0 0         print STDERR $filename,"=>\n",Data::Dumper->Dump( $data) if ($debug);
352 0           foreach my $ref ($$data[1]) {
353 0           foreach my $ref2 (@$ref) {
354 0 0         $ok=1 if ($ref2 != 0);
355             }
356             }
357 0 0         return if (!$ok);
358 0 0         $data = GD::Graph::Data->new($data) or die GD::Graph::Data->error;
359 0           $my_graph->set_x_axis_font($font,12 );
360 0           $my_graph->set_y_axis_font($font,9 );
361 0           $my_graph->set_title_font($font,14);
362 0           $my_graph->set_values_font($font,11);
363 0           $my_graph->set_text_clr("black");
364 0 0         $my_graph->plot($data) or die $my_graph->error;
365 0 0         print STDERR "Create $filename.png\n" if ($debug);
366 0           return save_chart($my_graph, $filename);
367             }
368              
369             #------------------------------------------------------------------------------
370             # save_chart
371             #------------------------------------------------------------------------------
372             sub save_chart {
373 0 0   0 0   my $chart = shift or warn "Need a chart!";
374 0 0         my $name = shift or warn "Need a name!";
375 0 0 0       return if (!$name or !$chart);
376 0           local(*OUT);
377 0 0         open(OUT, ">$name.png") or
378             confess "Cannot open $name.png for write: $!";
379 0           binmode OUT;
380 0           print OUT $chart->gd->png();
381 0           close OUT;
382 0           return 1;
383             }
384              
385             #------------------------------------------------------------------------------
386             # fetch_array
387             #------------------------------------------------------------------------------
388             sub fetch_array {
389 0     0 0   my ($self,$request, $limit)=@_;
390 0           my (@tab,@tab2);
391 0 0         print STDERR "SQL request =>$request\n" if ($debug);
392 0           my $ref = $self->{DBH}->selectall_arrayref($request);
393 0 0         print STDERR "1:",Data::Dumper->Dump($ref) if ($debug);
394 0           foreach (@$ref) {
395 0 0 0       next if (($limit && $_->[1] < $limit) or (!$_->[1] and !$_->[0]));
      0        
      0        
396 0           my $i = 0;
397 0           foreach my $v (@$_) { push( @{$tab[$i++]}, $v); }
  0            
  0            
398             }
399              
400 0 0         print STDERR "2:",Data::Dumper->Dump([ \@tab ]) if ($debug);
401 0           return \@tab;
402             }
403              
404             #------------------------------------------------------------------------------
405             # create_html
406             #------------------------------------------------------------------------------
407             sub create_html {
408 0     0 0   my ($self, $mt, $ref, $c)=@_;
409 0           my $i=0;
410 0 0         print STDERR "Create $mt.html\n" if ($self->{opts}->{debug});
411 0 0         open(STATS,">$mt.html") or die "Can't create $mt.html:$!\n";
412 0           print STATS $self->{dbsmoke}->HTML->header_html.
413             $c->h2($$ref{$mt})."Current result - ";
414 0           foreach my $mt2 (keys %$ref) {
415 0           print STATS $c->a({-href=>"$mt2.html"},$$ref{$mt2})." - ";
416             }
417 0           print STATS "
\n";
418 0           foreach (glob("$mt/*.png")) {
419 0           print STATS $c->img({-src => $_,-align=>'center',-width=>1000,
420             -height=>300}),"
\n";
421             }
422 0           print STATS "Build with DBD::Mysql / GD::Graph / Test::Smoke::Database on ",
423             scalar localtime,$c->end_html;
424 0           close(STATS);
425             }
426              
427             #------------------------------------------------------------------------------
428             # stats_cpan
429             #------------------------------------------------------------------------------
430             sub stats_cpan {
431 0     0 0   my $self = shift;
432 0 0         my $content = get("http://testers.cpan.org/search?request=by-config")
433             or return undef;
434 0           my @liste;
435 0           my ($perl, $os, $osver, $archi);
436 0           foreach (split(/
437 0           my @content2 = split(/
438 0           my ($val, $num);
439 0           my $i=$#content2+1;
440 0 0         next if ($i==0);
441 0           foreach (@content2) {
442 0 0         next if (--$i==$#content2);
443             # print $_,"\n";
444 0 0         if (m!]*>(.*).*(\d*)!) {
445 0           ($val, $num) = ($1, $2);
446             }
447             # print $i," ",$val,"\n";
448 0 0 0       if ($i==4 && $val){ $perl = $val; }
  0 0 0        
    0 0        
    0 0        
449 0           elsif ($i==3 && $val) { $os = $val; }
450 0           elsif ($i==2 && $val) { $osver = $val; }
451 0           elsif ($i==1 && $val) { $archi = $val; }
452             # $i--;
453 0 0         last if ($i==1);
454             }
455 0 0 0       next if (!$perl or !$os or !$osver or !$archi or !$num);
      0        
      0        
      0        
456             # print "$perl / $os / $osver / $archi / $num\n";
457 0           push(@liste, [ $perl, $os, $osver, $archi, $num]);
458             }
459              
460 0           my (%perl,%os,%os58,%os56,%os55);
461 0           my ($tt,$tt58,$tt56,$tt55);
462 0           foreach my $ref (@liste) {
463 0           $perl{$$ref[0]}+=$$ref[4];
464 0 0         if ($$ref[0] eq '5.008') { $os58{$$ref[1]}+=$$ref[4]; $tt58+=$$ref[4]; }
  0 0          
  0 0          
465 0           elsif ($$ref[0] eq '5.006_01') { $os56{$$ref[1]}+=$$ref[4]; $tt56+=$$ref[4]; }
  0            
466 0           elsif ($$ref[0] eq '5.005_03') { $os55{$$ref[1]}+=$$ref[4]; $tt55+=$$ref[4]; }
  0            
467 0           $os{$$ref[1]}+=$$ref[4];
468 0           $tt+=$$ref[4];
469             }
470 0           foreach my $ref (\%perl,\%os ) {
471 0           foreach my $n (keys %$ref) { $$ref{$n}=$$ref{$n}*100/$tt; }
  0            
472             }
473 0           foreach my $n (keys %os58) { $os58{$n}=$os58{$n}*100/$tt58; }
  0            
474 0           foreach my $n (keys %os56) { $os56{$n}=$os56{$n}*100/$tt56; }
  0            
475 0           foreach my $n (keys %os55) { $os55{$n}=$os55{$n}*100/$tt55; }
  0            
476              
477 0           graph_cpan("1_perl_version","% CPAN reports by Perl version",%perl);
478 0           graph_cpan("2_os","% CPAN reports by OS",%os);
479 0           graph_cpan("3_os58","% CPAN reports by OS for Perl 5.008 ($tt58 reports)",%os58);
480 0           graph_cpan("4_os56","% CPAN reports by OS for Perl 5.006_01 ($tt56 reports)",
481             %os56);
482 0           graph_cpan("5_os55","% CPAN reports by OS for Perl 5.005_03 ($tt55 reports)",
483             %os55);
484             }
485              
486             #------------------------------------------------------------------------------
487             # graph
488             #------------------------------------------------------------------------------
489             sub graph_cpan {
490 0     0 0   my ($name, $title, %perl)=@_;
491 0           foreach my $r (keys %perl) {
492 0 0         if ($perl{$r} <2) {
493 0           $perl{"others"}+=$perl{$r};
494 0           delete $perl{$r};
495             # print $perl{$r},"\n";
496             }
497             }
498 0           my @l = sort { $perl{$a} <=> $perl{$b} } keys %perl;
  0            
499 0           my @l2;
500 0           foreach (@l) { push(@l2, $perl{$_}); }
  0            
501 0           my $ref = [ \@l, \@l2];
502 0           my $my_graph = GD::Graph::bars->new(1000,300);
503             #$my_graph->set_legend("","% of successful make test");
504 0 0         $my_graph->set(
505             title => $title,
506             # y_max_value => 25000,
507             #y_tick_number => 10,
508             # x_label_skip => 0,
509             show_values => 1,
510             axis_space => 20,
511             t_margin => 40,
512             b_margin => 20,
513             box_axis => 0,
514             # dclrs => [ qw/black/ ],
515             transparent => 0,
516             shadowclr => 'dred',
517             legend_spacing => 40,
518             shadow_depth => 4,
519             transparent => 0,
520             bar_spacing => 20,
521             values_format => "%2.1f %%"
522             )
523             or warn $my_graph->error;
524 0           go($my_graph, $ref, "cpan/$name");
525             }
526              
527             __END__