Re-enable bandwidth throttling.
[fedora-mingw.git] / status.pl
1 #!/usr/bin/perl -wT
2
3 # Produce a status page for all current and pending Fedora MinGW packages.
4 # By Richard W.M. Jones <rjones@redhat.com>
5 #
6 # Requires:
7 # . All Fedora MinGW packages have to be checked out
8 #   under $HOME/d/fedora.
9 # . All pending packages to be available in
10 #   $HOME/d/fedora-mingw--devel.
11 #
12 # The output is normally placed here:
13 # http://annexia.org/fedora_mingw
14 #
15 # Checks that the package build-requires mingw32-* in order to know if
16 # it's an MinGW-related package.
17 #
18 # Only recognizes the Fedora/EPEL branches listed below and ignores
19 # anything else.  There are no MinGW packages in RHEL at this time.
20 #
21 # XXX This script is a bit crap.  Instead of using lame specfile
22 # parsing, this should be generated from the SRPMs.
23
24 use strict;
25
26 use POSIX qw(strftime);
27 use CGI qw/:standard/;
28
29 my $home = $ENV{HOME};
30 if ($home =~ m/(.*)/) { $home = $1; }
31
32 my $fedora = $home . "/d/fedora";
33 my $pending = $home . "/d/fedora-mingw--devel";
34
35 chdir $pending or die "$pending: $!\n";
36
37 my %branches = (
38     "EL-5" => {
39         name => "EPEL 5",
40         url => "http://fedoraproject.org/wiki/EPEL",
41         title => "Packages for Red Hat Enterprise Linux 5",
42         sortorder => 2,
43         class => "epelbg",
44     },
45     "F-10" => {
46         name => "Fedora 10",
47         url => "http://fedoraproject.org/",
48         sortorder => 10,
49         class => "fedorabg",
50     },
51     "devel" => {
52         name => "Devel",
53         url => "http://fedoraproject.org/wiki/Releases/Rawhide",
54         title => "Fedora 11 in development a.k.a. Rawhide",
55         sortorder => 99,
56         class => "develbg",
57     },
58     "pending" => {
59         name => "Pending",
60         url => "https://bugzilla.redhat.com/buglist.cgi?version=rawhide&component=Package+Review&target_milestone=&bug_status=NEW&bug_status=ASSIGNED&bug_status=NEEDINFO&bug_status=MODIFIED&short_desc_type=allwordssubstr&short_desc=mingw32&long_desc_type=allwordssubstr&long_desc=",
61         sortorder => 100,
62         class => "pendingbg",
63     },
64 );
65
66 # List of packages to ignore in pending.
67 my %ignore_pending = ();
68 open IGNORE, "IGNORE" or die "IGNORE: $!\n";
69 while (<IGNORE>) {
70     next if /^\#/ || /^$/;
71     m/(.*)/; # untaint
72     $ignore_pending{"mingw32-$1"} = 1;
73 }
74 close IGNORE;
75
76 # List of packages to ignore in Fedora checkout,
77 # because they confuse this script.
78 my %ignore_fedora = (
79     "cyrus-sasl" => 1,
80     "kernel" => 1,
81     "msmtp" => 1,
82     "openldap" => 1,
83     "pixman" => 1,
84     "python" => 1,
85     "qt" => 1,
86     "xenwatch" => 1,
87 );
88
89 # List of packages.
90 my %packages;
91
92 # Count of packages by branch.
93 my %count;
94
95 # Collect the package names & status from the specfiles.
96 sub collect {
97     my $specfile;
98
99     # Fedora and EPEL packages.
100     foreach $specfile (<$fedora/*/*/*.spec>) {
101         if ($specfile =~ m{/([^/]+)/([^/]+)\.spec$}) {
102             my $specfile_name = $2;
103             my $branch = $1;
104             if (exists $branches{$branch} &&
105                 !exists $ignore_fedora{$specfile_name}) {
106                 collect_specfile ($specfile, $branch);
107             }
108         }
109     }
110
111     # Pending packages in review.
112     foreach $specfile (<$pending/*/*.spec>) {
113         collect_specfile ($specfile, "pending");
114     }
115 }
116
117 sub collect_specfile {
118     my $specfile = shift;
119     my $branch = shift;
120
121     # Read the specfile and parse the bits we understand.
122     my ($name, $version, $summary, $description, $url, $is_mingw,
123         @rpmdefines);
124     @rpmdefines = (["nil", ""]);
125
126     open SPEC, "$specfile" or die "$specfile: $!";
127     while (<SPEC>) {
128         if (/^Name:\s*(\S+)/) {
129             $name = $1;
130             $name = rpmsubst ($name, 1, @rpmdefines) if $name =~ /%{/;
131             $is_mingw = 1 if $name =~ /mingw32/;
132         } elsif (/^Version:\s*(\S+)/) {
133             $version = $1;
134             $version = rpmsubst ($version, 1, @rpmdefines) if $version =~ /%{/;
135         } elsif (!$url && /^URL:\s*(\S+)/) {
136             $url = $1;
137             $url = rpmsubst ($url, 1, @rpmdefines) if $url =~ /%{/;
138         } elsif (!$summary && /^Summary:\s*(.*)/) {
139             $summary = $1;
140             #$is_mingw = 1 if $summary =~ /mingw32/i;
141         } elsif (/^(Build)?Requires:.*mingw32/) {
142             $is_mingw = 1
143         } elsif (!$description && /^%description/) {
144             $description = "";
145             while (<SPEC>) {
146                 last if /^%/;
147                 $description .= $_;
148             }
149             $description = rpmsubst ($description, 1, @rpmdefines)
150                 if $description =~ /%{/;
151             #$is_mingw = 1 if $description =~ /mingw/i;
152         }
153
154         # Handle simple RPM defines.
155         elsif (/^%define\s+([A-Za-z_]+)\s+(.*)/) {
156             my $name = $1;
157             my $val = $2;
158             if (only_simple_substs ($val)) {
159                 $val = rpmsubst ($val, 0, @rpmdefines);
160                 push @rpmdefines, [ $name, $val ];
161             }
162         }
163     }
164
165     # Check it's a MinGW package.  If name/summary/description contains
166     # 'mingw' or it Requires/BuildRequires some mingw32-* package then we
167     # assume it's related.
168     if (!$is_mingw) {
169         warn "warning: $name ($branch) ignored, not a MinGW package\n";
170         return;
171     }
172
173     # Ignore certain packages appearing in pending branch.
174     if ($branch eq "pending") {
175         if (exists $ignore_pending{$name}) {
176             return;
177         }
178
179         # Also ignore packages marked NOT-FOR-FEDORA in pending.
180         my $dirname = $specfile;
181         $dirname =~ s{/[^/]+$}{};
182         if (-f "$dirname/NOT-FOR-FEDORA") {
183             return;
184         }
185     }
186
187     #print "$name $version $url\n";
188
189     # If the package is in "pending" then there shouldn't be a
190     # Fedora package also.
191     if ($branch eq "pending" && exists $packages{$name}) {
192         die "error: pending $name is also in Fedora repo\n"
193     }
194
195     # Add the package.
196     $packages{$name} = {} unless exists $packages{$name};
197     if (exists $packages{$name}{$branch}) {
198         die "$name ($branch) package already seen\n";
199     }
200     $packages{$name}{$branch} = {
201         name => $name,
202         branch => $branch,
203         version => $version,
204         url => $url,
205         summary => $summary,
206         description => $description,
207     }
208 }
209
210 sub only_simple_substs {
211     local $_ = shift;
212
213     s/%{[A-Za-z_]+}//g;
214     s/%\([A-Za-z_]+\)//g;
215     ! (m/%{/ || m/%\(/)
216 }
217
218 # Simple RPM '%define' substitutions.
219 sub rpmsubst {
220     local $_ = shift;
221     my $fail = shift;
222
223     my $pair;
224     foreach $pair (@_) {
225         my $var = $pair->[0];
226         my $val = $pair->[1];
227
228         s/%{$var}/$val/ge;
229         s/%\($var\)/$val/ge;
230     }
231
232     if ($fail && (m/%{/ || m/%\(/)) {
233         die "rpmsubst: string contains undefined substitutions: $_\n";
234     }
235
236     $_;
237 }
238
239 sub branchsortorder {
240     $branches{$a}{sortorder} <=> $branches{$b}{sortorder}
241 }
242
243 sub nbsp {
244     local $_ = shift;
245     s/\s+/&nbsp;/g;
246     $_
247 }
248
249 sub output_header {
250     print "Status of packages in Fedora, EPEL and RHEL, last updated on ";
251     print strftime("%Y-%m-%d",gmtime);
252     print ".\n\n";
253     print "<html>\n";
254     print "<table class=\"top_table fedoratbl\">\n";
255     print "<tr><th>Name</th>\n";
256     foreach (sort branchsortorder (keys %branches)) {
257         my $name = $branches{$_}{name};
258         my $url = $branches{$_}{url};
259         my $class = $branches{$_}{class};
260
261         print "<th class=\"$class\">";
262         if (exists $branches{$_}{title}) {
263             my $title = escapeHTML ($branches{$_}{title});
264             print "<a title=\"$title\" href=\"$url\">",
265               nbsp(escapeHTML($name)),
266               "</a>";
267         } else {
268             print "<a href=\"$url\">",
269               nbsp(escapeHTML($name)),
270               "</a>";
271         }
272         print "</th>\n";
273     }
274     print "</tr>\n";
275
276     # Count the packages in each branch.
277     %count = ();
278     foreach (keys %branches) {
279         $count{$_} = 0
280     }
281 }
282
283 sub output_package {
284     my $name = shift;
285
286     # Get the URL, summary and description from devel
287     # or pending (if possible).
288     my ($url, $summary, $description);
289     if (exists $packages{$name}{devel}) {
290         $url = $packages{$name}{devel}{url};
291         $summary = $packages{$name}{devel}{summary};
292         $description = $packages{$name}{devel}{description};
293     } elsif (exists $packages{$name}{pending}) {
294         $url = $packages{$name}{pending}{url};
295         $summary = $packages{$name}{pending}{summary};
296         $description = $packages{$name}{pending}{description};
297     }
298
299     print "<tr><td>";
300     if (defined $url) {
301         if (defined $summary && defined $description) {
302             print "<a title=\"",
303               escapeHTML($description),
304               "\" href=\"$url\">",
305               escapeHTML($name),
306               "</a><br/><small>",
307               escapeHTML($summary),
308               "</small>";
309         } else {
310             print "<a href=\"$url\">", escapeHTML($name), "</a>";
311         }
312     } else {
313         print (escapeHTML($name));
314     }
315     print "</td>\n";
316
317     my $branch;
318     foreach $branch (sort branchsortorder (keys %branches)) {
319         my $brclass = $branches{$branch}{class};
320
321         if (exists $packages{$name}{$branch}) {
322             $count{$branch}++;
323
324             my %r = %{$packages{$name}{$branch}};
325
326             my $class = "released";
327             $class = "pending" if $branch eq "pending";
328             $class = "devel" if $branch eq "devel";
329             $class = "filesystem" if $name eq "mingw32-filesystem";
330
331             print "<td class=\"$brclass $class\">$r{version}</td>\n";
332         } else {
333             # No package in this branch.
334             print "<td class=\"$brclass\">&nbsp;</td>\n"
335         }
336     }
337
338     print "</tr>\n";
339 }
340
341 sub output_trailer {
342     # Summary of packages in each branch.
343     print "<tr><td>Totals</td>";
344     my $branch;
345     foreach $branch (sort branchsortorder (keys %branches)) {
346         print "<td>$count{$branch}</td>";
347     }
348     print "</tr>\n";
349
350     print "</table>\n";
351     print "</html>\n";
352 }
353
354 # Define a standard package name order.
355 sub pkgnameorder {
356     # "mingw32-*" packages always sort first.
357     return -1 if $a =~ /^mingw32/ && $b !~ /^mingw32/;
358     return 1 if $a !~ /^mingw32/ && $b =~ /^mingw32/;
359
360     return (lc($a) cmp lc($b))
361 }
362
363 sub main {
364     # Collect all the specfiles, into %packages hash.
365     collect ();
366
367     # Get the package names.
368     my @names = sort pkgnameorder (keys %packages);
369
370     # Generate the output.
371     output_header ();
372     foreach (@names) {
373         output_package ($_);
374     }
375     output_trailer ();
376 }
377
378 main ()