#!/usr/bin/perl # # Extracts info from update_excuses.html[1] and update_output.txt[2] and # attempts to answer the question "why is package X not in testing yet?" # # This script is published under the GNU General Public License version 2.0. # See http://bjorn.haxx.se/debian/COPYING for full license details. # # Also see 'cronjob.txt' in this directory for the data fetching. # # Björn Stenberg # # References: # [1] http://ftp-master.debian.org/testing/update_excuses.html # [2] http://ftp-master.debian.org/testing/update_output.txt # [3] http://incoming.debian.org/ # [4] http://popcon.debian.org/by_inst # use CGI 'param'; use URI::Escape; use POSIX 'strftime'; use HTTP::Date; # initialise libapt-pkg-perl for use in vercmp use AptPkg::Config '$_config'; use AptPkg::System '$_system'; use AptPkg::Version; $_config->init; $_system = $_config->system; my $BASE_DIR = '/srv/release.debian.org/tools/migration'; my $OUT_DIR = '/srv/release.debian.org/www/migration'; my $green = "#006000"; my $startgreen = ""; my $stopgreen = ""; $printalldeps = 0; $cginame = "testing.pl"; $excuses = "http://release.debian.org/britney/update_excuses.html"; # calculate Last-Modified header to allow caching @files = ( "$OUT_DIR/packages-main", "$OUT_DIR/sources-main", "$OUT_DIR/sources-contrib", "$OUT_DIR/sources-non-free"); $toptime = 0; for (@files) { $mtime = (stat($_))[9]; $toptime = $mtime if ($mtime > $toptime); } $cgitime = (stat($cginame))[9]; @times = gmtime $toptime; $lastmodified = strftime "%a, %d %b %Y %T GMT", @times; if (defined $ENV{HTTP_IF_MODIFIED_SINCE}) { my $ims = $ENV{HTTP_IF_MODIFIED_SINCE}; my $imstime = HTTP::Date::str2time($ims); if ($imstime >= $toptime and $imstime >= $cgitime) { print "Status: 304 Not Modified\n\n"; exit; } } if (1 and scalar @ARGV) { &readfiles(1); &handle_argv(); exit; } $printalldeps = param("printalldeps") + 0; $expand = param("expand") + 0; $only_testing = param("nonew") + 0; $only_ready = param("ready") + 0; chdir($OUT_DIR); print "Last-Modified: $lastmodified\n"; print "Content-type: text/html; charset=iso-8859-1\n\n"; my $n = param("package"); $n =~ /(^[a-zA-Z0-9\-\.\+]+)/; # ignore silly characters my $name = $1; if ($ENV{QUERY_STRING} eq "") { $name = "_index"; } if (0 and scalar @ARGV) { $name = shift @ARGV; } if (!$printalldeps and !param(waiting) and !param(staller) and !param(nocache)) { $name =~ /^(.)/; my $dir = $1; my $filename = sprintf("cache/$dir/$name%s", $expand ? ".$expand" : ""); if ($name eq "_index") { $filename = "cache/_index"; } if (open CACHED, "<$filename") { print ; close CACHED; exit; } } &readfiles(); print &mkpage($name); exit; sub mkpage { my $name = shift @_; my $out; $depth = $bdepth = $broken = $recursed = 0; %explained = %bexplained = (); %reportedbreak = (); %done = (); $topname = $newtopname = ""; my $title = "Why is package X not in testing yet?"; if ($name ne "") { $title = "$name - $title"; } $out .= '' . "\n"; $out .= "$title\n"; $out .= "\n"; $out .= "\n"; $out .= "

Why is package X not in testing yet?

\n"; if ($name ne "") { $out .= "

Checking $name

\n"; if (0) { if (defined $testingversion{$name}) { $out .= "

Testing version: $testingversion{$name}\n"; } else { $out .= "

Not available in testing.\n"; } if (defined $unstableversion{$name}) { $out .= "
Unstable version: $unstableversion{$name}\n"; } else { $out .= "
Not available in unstable.\n"; } } $debug = 0; $depth = 0; $broken = 0; $firstdep = 1; $topname = $name; $out .= &reason($topname); $topnameset = 1; if (not defined $removing{$name}) { if ($newtopname ne "") { $out .= &checkbuilddeps($newtopname); $out .= &checkolddeps($topname); $out .= &checkolddeps($newtopname); $out .= &checkconflicts($topname); $out .= &checkconflicts($newtopname); } else { $out .= &checkbuilddeps($topname); $out .= &checkolddeps($topname); $out .= &checkconflicts($topname); } } exit if ($debug); $topname = $newtopname if ($newtopname ne ""); $etopname = uri_escape($topname, "+"); $out .= "

["; if (!$printalldeps) { $out .= "Show all dependencies ·\n"; } if ($expand) { $out .= "Show top level only ·\n"; } if ($broken) { $out .= sprintf "expand uninstallable packages ·\n", $expand + 1; } $out .= sprintf "pkgs waiting for $topname ·\n"; $out .= sprintf "pkgs stalled by $topname ·\n"; $out .= "$topname on packages.qa.d.o ·\n"; $out .= "$topname's buildd status ·\n"; $out .= "bugs in $topname"; $out .= "]\n

"; } $n = param("waiting"); if ($n =~ /(^[a-zA-Z0-9\-\.]+)/) { # ignore silly characters my $name = $1; if (scalar @{$waits{$name}}) { $out .= "

Packages waiting for $name:

\n"; $out .= "
    \n"; for (@{$waits{$name}}) { $out .= sprintf("
  1. %s (%d days old) is waiting for %s:\n", makelink($_), $age{$_}, makelink($name)); } $out .= "
\n"; } else { $out .= "

No packages are waiting for $name\n"; } } $n = param("staller"); if ($n =~ /(^[a-zA-Z0-9\-\.]+)/) { # ignore silly characters my $name = $1; $count = 0; my $stalls = &recur($name,1); if ($stalls ne "\n

\n") { $out .= "

Packages stalled by $name:

\n"; $out .= "

(Showing only packages which are \"ready\", i.e. past their waiting period.)\n" if ($only_ready); $out .= "

(Showing only packages which already have a version in testing -- no new packages.)\n" if ($only_testing); $out .= $stalls; %done = (); } else { $out .= "

No packages are stalled by $name\n"; } } $n = param("waitingonly"); if ($n =~ /(^[a-zA-Z0-9\-\.]+)/) { # ignore silly characters my $name = $1; if (scalar @{$waits{$name}}) { $out .= "

Packages only waiting for $name (no other reasons):

\n"; $out .= "
    \n"; for (sort @{$waits{$name}}) { if ($depends{$_} == 1 && not defined $minage{$_} && not defined $bugs{$_} && not defined $outofdate{$_} && not defined $unsatis{$_} && not defined $breaks{$_} ) { $out .= sprintf("
  1. %s is only waiting for %s\n", makelink($_), makelink($name)); } } $out .= "
\n"; } else { $out .= "

No packages are only waiting for $name\n"; } } #$out .= "

Note: Testing (Sarge) is currently frozen and thus no packages go in without hand-approval.\n"; $out .= "

\n"; $out .= "

Package name: \n"; $out .= "

"; if (scalar keys %version) { $out .= sprintf "

%d packages are trying to enter testing.\n", (scalar (keys %version)) - (scalar (keys %removing)); $out .= sprintf "%d packages are trying to be removed.\n", scalar (keys %removal) if scalar (keys %removal); my $inout = scalar @inoutpkgs; $out .= "$inout packages are going in/out today.\n"; } $out .= "
dependency toplist ·\n"; $out .= "oldest candidates ·\n"; $out .= "highscore ·\n"; $out .= "top stalls \n"; $out .= "(no new, \n"; $out .= "only ready) ·\n"; $out .= "versioned conflicts ·\n"; $out .= "old dependencies\n"; $out .= "· obsolete binaries\n"; if ($broken) { $out .= "

Explanations:

\n"; $out .= "

1. Sometimes packages have seemingly recursive dependencies (adding X makes Y uninstallable, Y is waiting for X). This means the new version of X will break the old version of Y, but there's also a new version of Y that needs the new version of X. As soon as all other dependencies are solved, the two packages can be hinted to go in together.\n"; $out .= "

2. Platforms are tested in alphabetical order, but only the first that breaks is displayed. That's why many packages are reported as uninstallable on alpha. Actually they are most likely uninstallable on many other platforms too, but only the result for alpha is displayed.\n"; } $out .= "

written by Björn Stenberg · script source code\n"; # $out .= "

Info: The non-US section of Debian is being phased out and is not being updated.\n"; $out .= "

Data is updated hourly.
Latest update: $lastmodified\n"; $out .= "\n"; return $out; } sub debug { my $string = shift @_; print "",$string if ($debug); } sub reason { my $binary_name = shift @_; my $output; my $name = &getprovider($binary_name); return if (length $name < 2); if (!$depth and !$bdepth and ($name ne $binary_name) and !$topnameset) { $newtopname = $name; } return if ($depth and $binary_name eq $topname); my $ename = uri_escape($name, "+"); my $link = makelink($name); $rpkg[$depth] = $name; if ($filename{$binary_name} ne "" and not defined $issourcepackage{$binary_name} and not defined $srcforbinary{$binary_name}) { $output .= sprintf("

\n", makelink($binary_name), makelink($name)); return $output; } if ($name ne $binary_name) { $output .= sprintf("\n"; return $output; } } $output .= "\n\n"; $output .= "\n\n" if ($name ne $binary_name); $depth--; # if (!$depth and $status{$name} eq "Not considered") { # print "

Note: $link was not test-installed due to the above problems. Test-installing may reveal problems not yet shown here.\n"; # } return $output; } sub getprovider { my $pkg = shift @_; if (defined $issourcepackage{$pkg}) { $spkg = $pkg; } elsif (defined $srcpackage{$pkg}) { $spkg = $srcpackage{$pkg}; } elsif (defined $provider{$pkg}) { $spkg = $provider{$pkg}; if (defined $srcpackage{$spkg}) { $spkg = $srcpackage{$spkg}; } } elsif (defined $testingprovider{$pkg}) { $spkg = $testingprovider{$pkg}; if (defined $srcpackage{$spkg}) { $spkg = $srcpackage{$spkg}; } } else { $spkg = $pkg; } return $spkg; } sub vercmp { my ($ver1, $ver2) = @_; return 1 if ($ver1 eq "" or $ver2 eq ""); return $_system->versioning->compare($ver1, $ver2); # # strip out debian version "-n" # $ver1 =~ /(\d+:|)([\w\.+-:~]+?)(-[\w+.]+|)$/; # my $epoch1 = $1; # $ver1 = $2; # my $debver1 = $3; # # $ver2 =~ /(\d+:|)([\w\.+-:~]+?)(-[\w+.]+|)$/; # my $epoch2 = $1; # $ver2 = $2; # my $debver2 = $3; # # return 1 if ($epoch1 > $epoch2); # return -1 if ($epoch2 > $epoch1); # # my @v1 = split /\b/, $ver1; # my @v2 = split /\b/, $ver2; # # my $num = scalar @v1; # $num = scalar @v2 if (scalar @v2 > $num); # # for (0 .. $num) { # $a = $v1[$_]; # $b = $v2[$_]; # if ($a =~ /^\d/ or $b =~ /^\d/) { # # numerical comparison # return 1 if ($a > $b); # return -1 if ($a < $b); # } # else { # # lexical comparison # while (ord $a == ord $b) { # $a = substr($a, 1); # $b = substr($b, 1); # last if (!length $a or !length $b); # # if (($a > 0) or ($b > 0)) { # # number in string: use numerical comparison # return 1 if ($a > $b); # return -1 if ($a < $b); # last; # } # } # # return 1 if (ord $a > ord $b); # return -1 if (ord $a < ord $b); # } # } # # return 0 if ($debver1 eq $debver2); # return vercmp($debver1, $debver2); } sub cmpverstring { my ($ver,$tver) = @_; my $yes = 0; if ($ver =~ />> *(.+)/) { $yes = 1 if (&vercmp($tver,$1) > 0); } elsif ($ver =~ /<< *(.+)/) { $yes = 1 if (&vercmp($tver,$1) < 0); } elsif ($ver =~ />=? *(.+)/) { $yes = 1 if (&vercmp($tver,$1) >= 0); } elsif ($ver =~ /<=? *(.+)/) { $yes = 1 if (&vercmp($tver,$1) <= 0); } elsif ($ver =~ /= *(.+)/) { $yes = 1 if (&vercmp($tver,$1) == 0); } elsif ($ver =~ /0$/) { $yes = 1 if ($tver ne ""); } else { $output .= "

Failed parsing version string: $ver / $tver\n"; } return $yes; } sub checkbuilddeps { my $binary_name = shift @_; my $name = $binary_name; my $output; my $print = 0; if (defined($srcpackage{$binary_name})) { $name = $srcpackage{$binary_name}; } $bdepth++; if ($bdepth > 20) { warn "Too recursive in pkg $topname"; return; } $stack[$bdepth] = $name; debug "entering checkbuilddeps($name)\n"; return if (defined $bexplained{$name}); $bexplained{$name} = 1; if (!$depsaid) { $output .= "

Dependency analysis (including build-depends; i386 only):

\n"; $depsaid = 1; } $output .= "\n" if (!$depth); $bdepth--; return $output if ($print); return ""; } sub _checkbuilddeps { my ($name, $pkg, $ver) = @_; my $print = 0; my $output; $bdepth = 0; &debug("_checkbuilddeps($name, $pkg, $ver)\n") if ($debug); # remove surrounding spaces if ($pkg =~ /^\s*(.+?)\s*$/) { $pkg = $1; } my $spkg = &getprovider($pkg); return "" if ($spkg eq $name); my $link = makelink($name); my $str = "
  • $alt$link depends on " . makelink($pkg); $str .= " $ver" if ($ver ne "0"); my $tver = $testingversion{$pkg}; if (0==&cmpverstring("$pkg $ver", $tver)) { $output .= "$str"; if ($tver) { $print = 1; $output .= " but testing has $tver (unstable has $unstableversion{$pkg})\n"; $output .= &reason($pkg); $output .= &checkbuilddeps($pkg); } else { if (defined $providerlist{$pkg}) { $output .= ", provided by: " . &printlinkarray(@{$providerlist{$pkg}}); my $options = scalar @{$providerlist{$pkg}}; my $count = 0; $output .= "
      \n"; foreach (@{$providerlist{$pkg}}) { my $link = makelink($_); if (defined $testingversion{$_}) { $count++; $output .= "
      • info: $link has version $testingversion{$_} in testing
      \n"; } else { $output .= "
    • $link is not available in testing:\n\n"; $output .= &reason($_); $output .= &checkbuilddeps($_); #$output .= "
    \n"; } } $output .= "\n"; $print = 1 if ($count == 0 or $printalldeps); } else { $print = 1; $output .= " which is not available in testing\n"; $output .= &reason($pkg); $output .= &checkbuilddeps($pkg); } } } elsif (not defined $testingversion{$pkg} and not defined $testingprovider{$pkg}) { $output .= "$str, which is not available in testing"; $output .= &reason($pkg); $output .= &checkbuilddeps($pkg); $print = 1; } if ($printalldeps and !$print) { my $ver = $builddeps{$name}{$pkg}; my $tver = $testingversion{$pkg}; if (!$testingversion{$pkg} and defined $testingprovider{$pkg}) { $tver = $testingversion{$testingprovider{$pkg}}; } $str =~ s/
  • /
  • info: /; $output .= sprintf "$str %s (ok, testing has version $tver)\n", $ver ? $ver : ""; $print = 1; } return $output if ($print); return ""; } sub checkconflicts { my $pkg = shift @_; my $str; my $output; &debug("checkconflicts($pkg)\n") if ($debug); for my $conf (sort keys %{$conflicts{$pkg}}) { my $s = &tryalternatives($pkg, $conf, \&_checkconflicts); if ($s ne "" or $printalldeps) { $output .= $s; } } if (1 and $output ne "") { $output = "

    Package version conflicts:

    \n
      \n$output
    \n"; } return $output; } sub _checkconflicts { my ($name, $pkg, $ver) = @_; debug "_checkconflicts($name, $pkg, $ver)\n"; return "" if ($ver eq "0" or not defined $testingversion{$pkg}); my $spkg = &getprovider($pkg); return "" if ($spkg eq $name); if (&cmpverstring("$pkg $ver", $testingversion{$pkg})) { return "" unless (defined $deplist{$name}{$pkg}); return sprintf("
  • %s conflicts with %s $ver but testing has $testingversion{$pkg}\n", makelink($name), makelink($pkg)); } return ""; } sub checkolddeps { my $pkg = shift @_; my $output; debug "checkolddeps($pkg): " . (scalar keys %{$revdeps{$pkg}}) . " revdeps\n"; for my $dep (sort keys %{$revdeps{$pkg}}) { debug "$pkg => $dep\n"; for my $dep2 (sort keys %{$builddeps{$dep}}) { debug "$pkg => $dep => $dep2\n"; next unless (index($dep2, $pkg) == 0); my $str = &tryalternatives($dep, $dep2, \&_checkolddeps); if ($str ne "" or $printalldeps) { $output .= $str; } } } if ($output ne "") { $output = "

    Dependencies on old versions of $pkg:

    \n
      \n$output
    \n"; } return $output; } sub _checkolddeps { my ($name, $pkg, $ver) = @_; debug "_checkolddeps($name, $pkg, $ver)\n"; return "" if ($ver =~ />/); return "" if ($ver eq "0" or not defined $unstableversion{$pkg}); my $spkg = &getprovider($name); return "" if ($spkg eq $pkg); if (not &cmpverstring("$pkg $ver", $unstableversion{$pkg})) { return sprintf("
  • %s depends on %s $ver, but $unstableversion{$pkg} is going in\n", makelink($name), makelink($pkg)); } return ""; } # split a conditional depend/conflict and check each one sub tryalternatives { my ($name, $arg, $function) = @_; my $print = 0; my $count = 0; my $loop = 0; my $output; debug "tryalternatives($name, $arg)\n"; my @alternatives = split / *\| */, $arg; my $options = scalar @alternatives; for my $p (@alternatives) { my $v = 0; my $s; $loop++; # split package and version if ($p =~ /(.+?)\s*\((.+?)\)/) { $p = $1; $v = $2; } # remove arch if ($p =~ /(.+?)\s*\[(.+?)\]/) { # next; # don't try to parse arch-specific dependencies $p = $1; } if (scalar @alternatives > 1) { $alt = sprintf "alternative %d/%d: ", $loop, scalar @alternatives; } else { $alt = ""; } $s = &$function($name, $p, $v); if ($s ne "") { $count++; $output .= $s; #debug "alternative $count/$options failed: $s\n"; } } if ($count == $options) { if ($options > 1) { if ($printalldeps) { $output = sprintf "

  • %d alternatives: $arg\n
      $output
    ", scalar @alternatives; } else { $output = sprintf "

  • All %d alternatives failed: $arg\n
      $output
    ", scalar @alternatives; } } return $output; } return ""; } sub makelink { my $name = shift @_; return sprintf("$name", uri_escape $name, "+"); } sub printbreaklist { my ($list,$name) = @_; my @a; for ( split ", ", $list ) { next if (defined $deplist{$_}{$name}); next if (defined $deplist{$srcpackage{$_}}{$name}); #next if ($srcpackage{$_} ne $_); push @a, &makelink($_); #push @a, "($srcpackage{$_})" if (defined $srcpackage{$_}); } return join ",\n", @a; } sub printlinkarray { my @list = @_; my @a; for ( @list ) { push @a, &makelink($_); } return join ",\n", @a; } sub recur { my ($name,$print) = @_; $done{$name} = 1; my $output; $output .= "\n
      \n" if ( $print ); for ( @{$waits{$name}} ) { next if (defined $done{$_}); next if ($only_testing and not defined $testingversion{$_}); next if ($only_ready and $age{$_} < $minage{$_}); if (defined $installations{$_}) { $score += $installations{$_}; $l .= "$_:$installations{$_},"; } $count ++; if ( $print ) { my $days; if ($minage{$_}) { $days = sprintf("(%d day%s of %s)", $age{$_}, $age{$_} > 1 ? "s" : "", $minage{$_}); } else { $days = sprintf "(%d days old)", $age{$_}; } $output .= sprintf("
    • $count: %s $days waits for $name\n", &makelink($_)); } $output .= &recur($_,$print) unless (defined $done{$_}); } $output .= "
    \n" if ( $print ); return $output; } sub readfiles { my $readvotes = shift @_; # # Reading the Packages files must happen before the update output # is read. # if (0) { # read rene output first (for obsolete binary detection) open RENE, "; close RENE; my $melanie = (grep /melanie.+ -b /, @lines)[0]; } # read data about packages in unstable distribution for (("srcs", "pkgs")) { my $srcs = 0; $srcs = 1 if ($_ eq "srcs"); open PACKAGES, "<$_" or die("Cannot open $_: $!"); for () { if (/^Package: (.*)$/) { $source = $1; $issourcepackage{$1} = 1 if ($srcs); } # skip repeated package entries # (this happens while non-US is not updated. and since "nonus" is # alphabetically sorted last, they will appear last in the list...) next if (defined $filename{$source}); if (/^Filename: (.*)$/) { $nonus{$source} = 1 if ($1 =~ /non-US/); $filename{$source} = $1; } elsif (/^Binary: (.*)$/) { my @pkgs = split(/[ ,]+/, $1); foreach $pkg (@pkgs) { $srcpackage{$pkg} = $source; $srcforbinary{$pkg} = $source; } } elsif (/^Version: (.*)$/) { $unstableversion{$source} = $1; } elsif (/^Directory: (.*)$/) { $directory{$source} = $1; } elsif (/^Source: (.+)$/) { my $tmp = $1; if ($tmp =~ /^(.+?) \(.+\)/) { $tmp = $1; } $srcpackage{$source} = $1; } elsif (/^Provides: (.*)$/) { for $pkg (split(/[ ,]+/, $1)) { $provider{$pkg} = $source; push @{$providerlist{$pkg}}, $source; } } elsif (/^Conflicts: (.*)$/) { for $pkg (split(/ *, */, $1)) { $conflicts{$source}{$pkg} = 1; } } elsif (/^Maintainer: (.*?) <(.+?)>$/) { $maintainer{$source} = $1; $email{$source} = $2; } # elsif (/^.*Depends.*: (.*)$/) { elsif (/^.*Depends: (.*)$/) { # elsif (/^Depends: (.*)$/) { foreach my $dep (split(/ *, */, $1)) { # save entire dependecy, versions alternatives and all $builddeps{$source}{$dep} = 0; # remember dependencies on older packages if ($dep =~ /([^ ]+?) *\( *([<=].+?)\)/) { $olddeps{$1}{$source} = $2; } # remember reverse dependencies for my $s (split / *\| */, $dep) { if ($s =~ /^([^ ]+?) *\([<>=]+.+?\)/) { $revdeps{$1}{$source} = 1; } else { $revdeps{$s}{$source} = 1; } } } } } close PACKAGES; } # read incoming.debian.org open INCOMING, ") { if (//i) { $incoming{$1}{$2}{$3} = 1; } } close INCOMING; # read data about packages in testing distribution for (("testing.pkgs", "testing.srcs")) { open PACKAGES, "<$_" or die("Cannot open $_: $!"); for () { if (/^Package: (.*)$/) { $source = $1; } elsif (/^Version: (.*)$/) { $testingversion{$source} = $1; } elsif (/^Provides: (.*)$/) { for $pkg (split(/[ ,]+/, $1)) { $testingprovider{$pkg} = $source; } } } close PACKAGES; } # read data about packages in experimental distribution for (("experimental.pkgs", "experimental.srcs")) { open PACKAGES, "<$_" or die("Cannot open $_: $!"); for () { if (/^Package: (.*)$/) { $source = $1; } elsif (/^Version: (.*)$/) { $experimentalversion{$source} = $1; } elsif (/^Provides: (.*)$/) { for $pkg (split(/[ ,]+/, $1)) { $experimentalprovider{$pkg} = $source; } } } close PACKAGES; } my $name; open EXCUSES, "<$BASE_DIR/update_excuses.html" or die("Cannot open update_excuses.html: $!"); for ( ) { if ( /(\d+) days old/ ) { $age{$name} = $1; } elsif ( /^
  • Too young, only (\d+) of (\d+)/ ) { $age{$name} = $1; $minage{$name} = $2; } elsif ( /^
  • (Not considered)/ ) { $status{$name} = $1; } elsif ( /^
  • (Valid candidate)/ ) { $status{$name} = $1; } elsif ( /^
  • New binary:/ ) { $newbin{$name} = "$arch"; } elsif ( /^
  • Trying to remove package/ ) { $removing{$name} = 1; } elsif ( /^
  • Should ignore, (.*)/ ) { $anyway{$name} = $1; } elsif ( /^
  • out of date on (.+?)<\/a>: (.+?) \(.+?>(.+?) 1 ? "ies" : "y"); if (scalar @pkgs < 8 and scalar @pkgs) { $links .= ": " . &printlinkarray(@pkgs); } if (defined $incoming{$name}{$version{$name}}{$port}) { push @{$outofdate{$name}}, "build for $port is uploaded to incoming"; } else { push @{$outofdate{$name}}, "is not yet built on $port: $ver vs $version{$name} (missing $links) $comment"; } # Check if the offending binary packages does not exist in the new # version and has to be removed by the ftp master using "rene" # to make "britney" happy again. foreach $pkg (@pkgs) { if (not defined $srcforbinary{$pkg} and not defined $notsource{$pkg.$arch}) { my $mel; if (0) { my $renelink = "by rene"; if (index($melanie, $pkg) > 0) { $mel = "also suggested $renelink"; } else { $mel = "not seen $renelink"; } } push (@{$outofdate{$name}}, sprintf("no longer provides binary %s. ftpmaster needs to remove it.", &makelink($pkg))); $notsource{$pkg.$arch} = 1; } } } elsif ( /^
  • .+?buggy.+?\((\d+) .+? (\d+)/) { if ( $1 > $2 ) { $bugs{$name} = 1; } } elsif ( /^
  • Updating (.+?) introduces new bugs/) { $binbugs{$name}{$1} = 1; } elsif ( /^
  • Not touching package, as requested by freeze/) { $frozen{$name} = 1; } # # Unsatisfied dependencies don't affects a packages Valid Candidate status # # elsif ( /^
  • (.+?)\/(.+?) unsatisfiable Depends: ([^ ]+)/) { # $a = ""; # $a = "$1 needs "; # $unsatis{$name}{$1}{$3}{$2} = 1; # } elsif ( /^
  • Depends: (.+?) .+?>(.+?)Maintainer/) { } elsif ( /^
  • (.*)/ ) { push @{$comments{$name}}, $1; } } close EXCUSES; open OUTPUT, "<$BASE_DIR/update_output.txt" or die("Cannot open update_output.txt: $!"); for ( ) { if ( /^skipped: (-?)([^ \/]+)(\/([^\"]+))? / ) { $name = $2; $removal{$name} = 1 if ($1 eq "-"); $status{$name} = "skipped" if (not defined $status{$name}); } elsif ( /^endloop:/ ) { $name = ""; } elsif ( /^accepted: (-?)([^ \/]+)(\/([^\"]+))? / ) { $name = $2; next if ($name =~ /\//); # ignore arch-specific binary updates $removal{$name} = 1 if ($1 eq "-"); $accepted{$name} = 1; if ( $recur ne "" ) { push @recurred, $2; } } elsif ( /^final: (.+)/ ) { for ( split ',', $1 ) { my $name = $_; if (/^-(.*)/) { $name = $1; $removal{$name} = 1; } next if ($name =~ /\//); # ignore arch-specific binary updates $final{$name} = 1; $accepted{$name} = 1; if ($lasthinted ne "") { $finalhint{$name} = $lasthinted; } } $lasthinted = ""; $recur = 0; } elsif ( /(?:[hH]int|[eE]asy) from (.+?): (.+)/ ) { $lasthinted = $1; for ( split ' ', $2 ) { /(.+?)\//; $hintby{$1} = $lasthinted; # print ">>$lasthinted hinted $1\n"; } } elsif ( /^recur: \[.*?\] (.+) \d+\/\d+/ ) { $recur = $1; $triedrecur{$1} = 1; } elsif ( /^FAILED/ ) { #print "\n"; for ( @recurred ) { delete $accepted{$_}; } $recur = ""; @recurred = (); $lasthinted = ""; } # elsif ( /^ all: (.+)/ ) { # for ( split ' ', $1 ) { # /(-|)(.*)/; # $accepted{$2} = 1; # } # } elsif (/^ \* (.*)/) { $count = scalar split ",", $1; if (defined $breaks{$name}) { # only save the lowest break count if ($count < $breaks{$name}) { $breaks{$name} = $count; $broken{$name} = $1; } } else { $breaks{$name} = $count; $broken{$name} = $1; } # print STDERR "$name breaks $count packages\n"; } } close OUTPUT; my @tmplist = (keys %accepted, keys %final); my %pcount; @inoutpkgs = grep { ++$pcount{$_} < 2 } @tmplist; %eek = (); for (@inoutpkgs) { # non-US packages aren't going anywhere next if ($nonus{$_}); next if (!&vercmp($unstableversion{$_},$testingversion{$_})); $eek{$_} = 1; } @inoutpkgs = keys %eek; # read popcon data? (for package scoring) open POPCON, ") { if (/^\d+\s+([^\s]+)\s+(\d+)/) { $installations{$1} = $2; } } close POPCON; open REMOVALS, " ) { if ( /Bug#(\d+): ?RM: ?([a-z,0-9,\-,\.]+) --/ ) { my $bugnr = $1; my $package = $2; $removals{$package} = $bugnr; } } close REMOVALS; } sub handle_argv { if ($ARGV[0] eq "mkcache") { # printf "Making %d cache files\n", scalar keys %unstableversion; for (('a'..'z', 0..9)) { mkdir("cache/$_"); #print "Making cache dir $_\n"; } my $i = 0; for (keys %unstableversion) { /-?((.).+)\/?/; my $name = $1; my $dir = $2; if (1) { $expand = 0; if (1) { $depsaid = 0; open OUT, ">cache/$dir/$name" or die "Failed creating cache/$name: $!"; print OUT &mkpage($name); close OUT; } else { &mkpage($name); } # $expand = 1; # open OUT, ">cache/$dir/$name.1" or die "Failed creating cache/$name: $!"; # print OUT &mkpage($name); # close OUT; } else { #print "pkg/$1\n"; } #$i++; #print "$i\n" if (($i % 1000) == 0); } open OUT, ">cache/_index" or die "Failed creating cache/_index: $!"; print OUT &mkpage(""); close OUT; exit; } elsif ($ARGV[0] eq "conflicts") { for my $pkg (sort keys %version) { for my $conf (sort keys %{$conflicts{$pkg}}) { print &tryalternatives($pkg, $conf, \&_checkconflicts); } } exit; } elsif ($ARGV[0] eq "olddeps") { for my $pkg (sort keys %version) { for my $dep (sort keys %{$revdeps{$pkg}}) { print "$pkg => $dep\n" if ($debug); for my $dep2 (sort keys %{$builddeps{$dep}}) { print "$pkg => $dep => $dep2\n" if ($debug); next unless index($dep2, $pkg)==0; print &tryalternatives($dep, $dep2, \&_checkolddeps); } } } exit; } elsif ($ARGV[0] eq "obsolete") { for my $pkg (sort keys %outofdate) { my @ood = grep /no longer provides/, @{$outofdate{$pkg}}; for (@ood) { my $days; if ($minage{$pkg}) { $days = sprintf("(%d day%s of %s)", $age{$pkg}, $age{$pkg} > 1 ? "s" : "", $minage{$pkg}); } else { $days = sprintf "(%d days old)", $age{$pkg}; } printf("%s $days $_
    \n", &makelink($pkg)); } } exit; } elsif ($ARGV[0] eq "accepted") { my ($in,$out) = (0,0); for (@inoutpkgs) { if (defined $removal{$_}) { $out++; } else { $in++; } } printf "

    Packages entering or leaving testing today

    \n"; printf "

    $in packages are going in:

    \n"; printf "

    $out packages are being removed:

    \n"; for (sort @inoutpkgs) { s|(/(.+))||; my $arch = $2; if (defined $removal{$_}) { printf("
  • %s is being removed%s
    \n", # 99999-$elements{$_}, 99999, makelink($_), defined $hintby{$_} ? " (hinted by $hintby{$_})" : ""); } elsif ($arch ne "") { printf("
  • %s is getting updated $arch binaries
    \n", 99999, makelink($_)); } else { if (defined $age{$_}) { printf("
  • %s is going in after $age{$_} days%s%s
    \n", # 99999-$elements{$_}, 99999, makelink($_), $elements{$_} ? sprintf " ($elements{$_} packages waiting)", uri_escape($_, "+") : "", defined $hintby{$_} ? " (hinted by $hintby{$_})" : ""); } else { printf("
  • %s is going in
    \n", 99999, makelink($_)); } } } exit; } # print toplist for ( keys %version ) { $ename = uri_escape $_, "+"; $whynot = ""; @why = (); $bad = 0; my $accept = 0; if (defined $frozen{$_}) { push @why, "frozen"; } if (defined $accepted{$_} or defined $final{$_}) { if (defined $removing{$_}) { push @why, "REMOVED"; } elsif (defined $nonus{$_}) { push @why, "non-us"; } else { push @why, "ACCEPTED"; } $accept = 1; } if (defined $bugs{$_}) { push @why, "has RC bugs"; $bad++; } if (defined $binbugs{$_}) { my $bin = uri_escape( (keys %{$binbugs{$_}})[0]); push @why, "has RC bugs"; $bad++; } if (defined $outofdate{$_}) { push @why, "not yet built"; } if (defined $unsatis{$_}) { push @why, "unsatisfiable"; $bad++; } if (defined $breaks{$_}) { push @why, "breaks $breaks{$_} pkgs"; $bad++; } if (defined $minage{$_}) { next if ($ARGV[0] eq "points" and scalar @why == 0); push @why, "too young"; } else { $bad++; } if (defined $depends{$_}) { next if ($ARGV[0] eq "points" and scalar @why == 0); push @why, "waiting for ". join ', ', sort keys %{$deplist{$_}}; #push @why,"waiting for ". printlinkarray(keys %{$deplist{$_}}); } if (defined $removals{$_}) { push @why, "remove requested"; } my $state; if (defined $testingversion{$_}) { $state = "update"; } else { $state = "new pkg"; } $whynot = join ", ", @why; #my $maint = "[$maintainer{$_}]" if (defined $maintainer{$_}); my $maint = "[$maintainer{$_}]" if (defined $maintainer{$_}); if ($ARGV[0] eq "age") { next if ($age{$_} == 0); printf( "%d days: %s (%d waiting, $state, $whynot) $maint
    \n", $age{$_}, makelink($_), $elements{$_}); } elsif ($ARGV[0] eq "points") { $score = 1; $l = ""; %done = (); &recur($_,0); $score += $installations{$_}; #$score *= (1 + $age{$_}/100); $l .= "$_:$score, "; if (defined $bugs{$_}) { $score *= 1.5; $l .= "RC = *1.5, "; } elsif (defined $frozen{$_}) { next; } next if (!$bad or (defined $accepted{$_} or defined $final{$_})); if ($score) { printf( "%d points: %s (%d stalled, %d days old, $whynot) $maint
    \n", # printf( "%d points: %s (%d stalled, %d days old, $whynot) $maint
    \n", $score, makelink($_), $elements{$_}, $age{$_}); } } elsif ($ARGV[0] eq "stalls") { $count = 0; %done = (); &recur($_,0); printf( "%d packages are stalled by $_%s (%d days old, $whynot) $maint%s
    \n", $count, $accept ? $startgreen : "", $age{$_}, $accept ? $stopgreen : "") if ($count); } elsif ($ARGV[0] eq "stalls-nonew") { $count = 0; %done = (); next if (not defined $testingversion{$_}); $only_testing = 1; &recur($_,0); printf( "%d in-testing packages are stalled by $_%s (%d days old, $whynot) $maint%s
    \n", $count, $accept ? $startgreen : "", $age{$_}, $accept ? $stopgreen : "") if ($count); } elsif ($ARGV[0] eq "stalls-ready") { $count = 0; %done = (); next if ($age{$_} < $minage{$_}); $only_ready = 1; &recur($_,0); printf( "%d otherwise ready packages are stalled by $_%s (%d days old, $whynot) $maint%s
    \n", $count, $accept ? $startgreen : "", $age{$_}, $accept ? $stopgreen : "") if ($count); } else { printf( "%d packages wait for $_%s (%d days old, $whynot) $maint%s
    \n", $elements{$_}, $accept ? $startgreen : "", $age{$_}, $accept ? $stopgreen : "") if ($elements{$_}); } } }