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 ()