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 |
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__ |