3 # wanna-build-statistics: print statistics for wanna-build databases
4 # Copyright (C) 1998 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de>
6 # This program is free software; you can redistribute it and/or
7 # modify it under the terms of the GNU General Public License as
8 # published by the Free Software Foundation; either version 2 of the
9 # License, or (at your option) any later version.
11 # This program is distributed in the hope that it will be useful, but
12 # WITHOUT ANY WARRANTY; without even the implied warranty of
13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 # General Public License for more details.
16 # You should have received a copy of the GNU General Public License
17 # along with this program; if not, write to the Free Software
18 # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20 # $Id: wanna-build-statistics 43 2005-06-01 09:28:43Z rmurray $
22 # $Log: wanna-build-statistics,v $
23 # Revision 1.4 2000/10/19 09:15:37 rnhodek
24 # percent: handle $total == 0 case.
26 # Revision 1.3 1999/01/13 09:57:17 rnhodek
27 # If wanna-build returns error status, also print last message from it.
29 # Revision 1.2 1998/12/16 10:51:34 rnhodek
30 # Print nothing at all if wanna-build says that the db doesn't exist.
31 # Remove debugging stuff.
33 # Revision 1.1 1998/12/16 10:29:09 rnhodek
38 use vars qw($verbose $dist $database);
42 $database = "build-db";
44 while( @ARGV && $ARGV[0] =~ /^-/ ) {
46 if (/^-v$/ || /^--verbose$/) {
49 elsif (/^-d/ || /^--dist/) {
50 if (/^-d(.)/ || /^--dist=(.)/) {
54 die "$_ option missing argument\n";
59 $dist = "oldstable" if $dist eq "o";
60 $dist = "stable" if $dist eq "s";
61 $dist = "testing" if $dist eq "t";
62 $dist = "unstable" if $dist eq "u";
63 die "Bad distribution\n" if !isin($dist, qw(stable testing unstable stable-security testing-security oldstable oldstable-security));
68 elsif (/^--database=(.*)$/) {
72 die "Unknown option: $_\n";
76 my($lastmsg, %n_state, $total, %n_builder);
77 open( PIPE, "wanna-build --database=$database --dist=$dist --list=all 2>&1 |" )
78 or die "Cannot spawn wanna-build: $!\n";
80 if (/^Database for $dist doesn't exist$/) {
83 elsif (/^Total (\d+) package\(s\) in state (\S+)\.$/) {
86 elsif (/^Total (\d+) package\(s\)$/) {
89 elsif (/^\S+: (\S+) by (\S+)/) {
90 $n_builder{$1}->{$2}++;
97 die "Bad exit status $? from wanna-build\n";
100 print "Distribution $dist:\n";
101 print "--------------", "-" x length($dist), "\n";
103 my $total_width = 78;
104 my @state_list = qw(Installed Needs-Build Building Built Build-Attempted Uploaded Failed Dep-Wait
105 Failed-Removed Dep-Wait-Removed
108 grep { $statewidth = length($_) if length($_) > $statewidth } @state_list;
109 my $startcol = $statewidth + 9;
111 my($state, $builder);
112 foreach $state (@state_list) {
113 printf "%-${statewidth}s: %5d", $state, $n_state{$state};
114 if (!keys %{$n_builder{$state}}) {
119 foreach $builder (keys %{$n_builder{$state}}) {
120 $sum += $n_builder{$state}->{$builder};
122 $n_builder{$state}->{"unknown"} = $n_state{$state} - $sum;
126 foreach $builder (sort keys %{$n_builder{$state}}) {
127 next if !$n_builder{$state}->{$builder};
128 my $str = "$builder: $n_builder{$state}->{$builder}";
129 $str = ", $str" if !$is_first;
131 if ($pos + length($str) > $total_width) {
132 print ",\n", " " x $startcol;
137 $pos += length($str);
141 printf "%-${statewidth}s: %5d\n", "total", $total;
144 $total -= $n_state{"Not-For-Us"};
145 print percent(qw(Installed)), " up-to-date, ";
146 print percent(qw(Installed Uploaded)), " if also counting uploaded pkgs\n";
147 print percent(qw(Built Installed Uploaded)), " if also counting built pkgs\n";
148 print percent(qw(Needs-Build)), " uncompiled\n";
149 print percent(qw(Building)), " currently building (short-term delay)\n";
150 print percent(qw(Build-Attempted)), " currently failed building (short-term delay)\n";
151 print percent(qw(Failed Dep-Wait)), " failed or waiting (long-term delay)\n";
161 return sprintf "%6.2f%%", $n*100/$total if $total;
162 return sprintf "%6.2f%%", 0;
167 return grep( $_ eq $val, @_ );