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     "xenwatch" => 1,
  86 );
  87
  88 # List of packages.
  89 my %packages;
  90
  91 # Count of packages by branch.
  92 my %count;
  93
  94 # Collect the package names & status from the specfiles.
  95 sub collect {
  96     my $specfile;
  97
  98     # Fedora and EPEL packages.
  99     foreach $specfile (<$fedora/*/*/*.spec>) {
 100         if ($specfile =~ m{/([^/]+)/([^/]+)\.spec$}) {
 101             my $specfile_name = $2;
 102             my $branch = $1;
 103             if (exists $branches{$branch} &&
 104                 !exists $ignore_fedora{$specfile_name}) {
 105                 collect_specfile ($specfile, $branch);
 106             }
 107         }
 108     }
 109
 110     # Pending packages in review.
 111     foreach $specfile (<$pending/*/*.spec>) {
 112         collect_specfile ($specfile, "pending");
 113     }
 114 }
 115
 116 sub collect_specfile {
 117     my $specfile = shift;
 118     my $branch = shift;
 119
 120     # Read the specfile and parse the bits we understand.
 121     my ($name, $version, $summary, $description, $url, $is_mingw,
 122         @rpmdefines);
 123     @rpmdefines = (["nil", ""]);
 124
 125     open SPEC, "$specfile" or die "$specfile: $!";
 126     while (<SPEC>) {
 127         if (/^Name:\s*(\S+)/) {
 128             $name = $1;
 129             $name = rpmsubst ($name, 1, @rpmdefines) if $name =~ /%{/;
 130             $is_mingw = 1 if $name =~ /mingw32/;
 131         } elsif (/^Version:\s*(\S+)/) {
 132             $version = $1;
 133             $version = rpmsubst ($version, 1, @rpmdefines) if $version =~ /%{/;
 134         } elsif (!$url && /^URL:\s*(\S+)/) {
 135             $url = $1;
 136             $url = rpmsubst ($url, 1, @rpmdefines) if $url =~ /%{/;
 137         } elsif (!$summary && /^Summary:\s*(.*)/) {
 138             $summary = $1;
 139             #$is_mingw = 1 if $summary =~ /mingw32/i;
 140         } elsif (/^(Build)?Requires:.*mingw32/) {
 141             $is_mingw = 1
 142         } elsif (!$description && /^%description/) {
 143             $description = "";
 144             while (<SPEC>) {
 145                 last if /^%/;
 146                 $description .= $_;
 147             }
 148             $description = rpmsubst ($description, 1, @rpmdefines)
 149                 if $description =~ /%{/;
 150             #$is_mingw = 1 if $description =~ /mingw/i;
 151         }
 152
 153         # Handle simple RPM defines.
 154         elsif (/^%define\s+([A-Za-z_]+)\s+(.*)/) {
 155             my $name = $1;
 156             my $val = $2;
 157             if (only_simple_substs ($val)) {
 158                 $val = rpmsubst ($val, 0, @rpmdefines);
 159                 push @rpmdefines, [ $name, $val ];
 160             }
 161         }
 162     }
 163
 164     # Check it's a MinGW package.  If name/summary/description contains
 165     # 'mingw' or it Requires/BuildRequires some mingw32-* package then we
 166     # assume it's related.
 167     if (!$is_mingw) {
 168         warn "warning: $name ($branch) ignored, not a MinGW package\n";
 169         return;
 170     }
 171
 172     # Ignore certain packages appearing in pending branch.
 173     if ($branch eq "pending") {
 174         if (exists $ignore_pending{$name}) {
 175             return;
 176         }
 177
 178         # Also ignore packages marked NOT-FOR-FEDORA in pending.
 179         my $dirname = $specfile;
 180         $dirname =~ s{/[^/]+$}{};
 181         if (-f "$dirname/NOT-FOR-FEDORA") {
 182             return;
 183         }
 184     }
 185
 186     #print "$name $version $url\n";
 187
 188     # If the package is in "pending" then there shouldn't be a
 189     # Fedora package also.
 190     if ($branch eq "pending" && exists $packages{$name}) {
 191         die "error: pending $name is also in Fedora repo\n"
 192     }
 193
 194     # Add the package.
 195     $packages{$name} = {} unless exists $packages{$name};
 196     if (exists $packages{$name}{$branch}) {
 197         die "$name ($branch) package already seen\n";
 198     }
 199     $packages{$name}{$branch} = {
 200         name => $name,
 201         branch => $branch,
 202         version => $version,
 203         url => $url,
 204         summary => $summary,
 205         description => $description,
 206     }
 207 }
 208
 209 sub only_simple_substs {
 210     local $_ = shift;
 211
 212     s/%{[A-Za-z_]+}//g;
 213     s/%\([A-Za-z_]+\)//g;
 214     ! (m/%{/ || m/%\(/)
 215 }
 216
 217 # Simple RPM '%define' substitutions.
 218 sub rpmsubst {
 219     local $_ = shift;
 220     my $fail = shift;
 221
 222     my $pair;
 223     foreach $pair (@_) {
 224         my $var = $pair->[0];
 225         my $val = $pair->[1];
 226
 227         s/%{$var}/$val/ge;
 228         s/%\($var\)/$val/ge;
 229     }
 230
 231     if ($fail && (m/%{/ || m/%\(/)) {
 232         die "rpmsubst: string contains undefined substitutions: $_\n";
 233     }
 234
 235     $_;
 236 }
 237
 238 sub branchsortorder {
 239     $branches{$a}{sortorder} <=> $branches{$b}{sortorder}
 240 }
 241
 242 sub nbsp {
 243     local $_ = shift;
 244     s/\s+/&nbsp;/g;
 245     $_
 246 }
 247
 248 sub output_header {
 249     print "Status of packages in Fedora, EPEL and RHEL, last updated on ";
 250     print strftime("%Y-%m-%d",gmtime);
 251     print ".\n\n";
 252     print "<html>\n";
 253     print "<table class=\"top_table fedoratbl\">\n";
 254     print "<tr><th>Name</th>\n";
 255     foreach (sort branchsortorder (keys %branches)) {
 256         my $name = $branches{$_}{name};
 257         my $url = $branches{$_}{url};
 258         my $class = $branches{$_}{class};
 259
 260         print "<th class=\"$class\">";
 261         if (exists $branches{$_}{title}) {
 262             my $title = escapeHTML ($branches{$_}{title});
 263             print "<a title=\"$title\" href=\"$url\">",
 264               nbsp(escapeHTML($name)),
 265               "</a>";
 266         } else {
 267             print "<a href=\"$url\">",
 268               nbsp(escapeHTML($name)),
 269               "</a>";
 270         }
 271         print "</th>\n";
 272     }
 273     print "</tr>\n";
 274
 275     # Count the packages in each branch.
 276     %count = ();
 277     foreach (keys %branches) {
 278         $count{$_} = 0
 279     }
 280 }
 281
 282 sub output_package {
 283     my $name = shift;
 284
 285     # Get the URL, summary and description from devel
 286     # or pending (if possible).
 287     my ($url, $summary, $description);
 288     if (exists $packages{$name}{devel}) {
 289         $url = $packages{$name}{devel}{url};
 290         $summary = $packages{$name}{devel}{summary};
 291         $description = $packages{$name}{devel}{description};
 292     } elsif (exists $packages{$name}{pending}) {
 293         $url = $packages{$name}{pending}{url};
 294         $summary = $packages{$name}{pending}{summary};
 295         $description = $packages{$name}{pending}{description};
 296     }
 297
 298     print "<tr><td>";
 299     if (defined $url) {
 300         if (defined $summary && defined $description) {
 301             print "<a title=\"",
 302               escapeHTML($description),
 303               "\" href=\"$url\">",
 304               escapeHTML($name),
 305               "</a><br/><small>",
 306               escapeHTML($summary),
 307               "</small>";
 308         } else {
 309             print "<a href=\"$url\">", escapeHTML($name), "</a>";
 310         }
 311     } else {
 312         print (escapeHTML($name));
 313     }
 314     print "</td>\n";
 315
 316     my $branch;
 317     foreach $branch (sort branchsortorder (keys %branches)) {
 318         my $brclass = $branches{$branch}{class};
 319
 320         if (exists $packages{$name}{$branch}) {
 321             $count{$branch}++;
 322
 323             my %r = %{$packages{$name}{$branch}};
 324
 325             my $class = "released";
 326             $class = "pending" if $branch eq "pending";
 327             $class = "devel" if $branch eq "devel";
 328             $class = "filesystem" if $name eq "mingw32-filesystem";
 329
 330             print "<td class=\"$brclass $class\">$r{version}</td>\n";
 331         } else {
 332             # No package in this branch.
 333             print "<td class=\"$brclass\">&nbsp;</td>\n"
 334         }
 335     }
 336
 337     print "</tr>\n";
 338 }
 339
 340 sub output_trailer {
 341     # Summary of packages in each branch.
 342     print "<tr><td>Totals</td>";
 343     my $branch;
 344     foreach $branch (sort branchsortorder (keys %branches)) {
 345         print "<td>$count{$branch}</td>";
 346     }
 347     print "</tr>\n";
 348
 349     print "</table>\n";
 350     print "</html>\n";
 351 }
 352
 353 # Define a standard package name order.
 354 sub pkgnameorder {
 355     # "mingw32-*" packages always sort first.
 356     return -1 if $a =~ /^mingw32/ && $b !~ /^mingw32/;
 357     return 1 if $a !~ /^mingw32/ && $b =~ /^mingw32/;
 358
 359     return (lc($a) cmp lc($b))
 360 }
 361
 362 sub main {
 363     # Collect all the specfiles, into %packages hash.
 364     collect ();
 365
 366     # Get the package names.
 367     my @names = sort pkgnameorder (keys %packages);
 368
 369     # Generate the output.
 370     output_header ();
 371     foreach (@names) {
 372         output_package ($_);
 373     }
 374     output_trailer ();
 375 }
 376
 377 main ()