bin/wanna-build

   1 #!/usr/bin/perl
   2 #
   3 # wanna-build: coordination script for Debian buildds
   4 # Copyright (C) 1998 Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de>
   5 # Copyright (C) 2005-2008 Ryan Murray <rmurray@debian.org>
   6 #
   7 # This program is free software; you can redistribute it and/or
   8 # modify it under the terms of the GNU General Public License as
   9 # published by the Free Software Foundation; either version 2 of the
  10 # License, or (at your option) any later version.
  11 #
  12 # This program is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 # General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program; if not, write to the Free Software
  19 # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
  20 #
  21
  22 package conf;
  23 # defaults
  24 $basedir ||= "/var/lib/debbuild";
  25 $dbbase ||= "build-db";
  26 $transactlog ||= "transactions.log";
  27 $mailprog ||= "/usr/sbin/sendmail";
  28 require "/org/wanna-build/etc/wanna-build.conf";
  29 die "$conf::basedir is not a directory\n" if ! -d $conf::basedir;
  30 die "dbbase is empty\n" if ! $dbbase;
  31 die "transactlog is empty\n" if ! $transactlog;
  32 die "mailprog binary $conf::mailprog does not exist or isn't executable\n"
  33         if !-x $conf::mailprog;
  34 die "no distributions defined\n" if ! %distributions;
  35 package main;
  36
  37 use strict;
  38 use POSIX;
  39 use FileHandle;
  40 use File::Copy;
  41 use DBI;
  42 use lib '/org/wanna-build/bin';
  43 use WannaBuild;
  44 use YAML::Tiny;
  45 use Data::Dumper;
  46 use Hash::Merge qw ( merge );
  47 use String::Format;
  48 use Date::Parse;
  49
  50 our ($verbose, $mail_logs, $list_order, $list_state,
  51     $curr_date, $op_mode, $user, $real_user, $distribution,
  52     $fail_reason, $opt_override, $import_from, $export_to, $opt_create_db,
  53     %prioval, %sectval,
  54     $info_all_dists, $arch,
  55     $category, %catval, %short_category,
  56     $short_date, $list_min_age, $dbbase, @curr_time,
  57     $build_priority, %new_vers, $binNMUver, %merge_srcvers, %merge_binsrc,
  58     $printformat
  59     );
  60
  61 # global vars
  62 $ENV{'PATH'} = "/bin:/usr/bin:/usr/local/bin:/org/wanna-build/bin/";
  63 $ENV{'LC_ALL'} = 'C';
  64 $verbose = 0;
  65 $mail_logs = "";
  66 @curr_time = gmtime;
  67 $curr_date = strftime("%Y %b %d %H:%M:%S",@curr_time);
  68 $short_date = strftime("%m/%d/%y",@curr_time);
  69 $| = 1;
  70
  71 # map program invocation names to operation modes
  72 my %prognames = ( "uploaded-build"  => "set-uploaded",
  73                                   "failed-build"    => "set-failed",
  74                                   "no-build"            => "set-not-for-us",
  75                                   "give-back-build" => "set-needs-build",
  76                                   "dep-wait-build"  => "set-dep-wait",
  77                                   "forget-build"        => "forget",
  78                                   "merge-quinn"         => "merge-quinn",
  79                                   "merge-packages"  => "merge-packages",
  80                                   "merge-sources"   => "merge-sources",
  81                                   "build-info"          => "info" );
  82
  83 %short_category = ( u => "uploaded-fixed-pkg",
  84                                     f => "fix-expected",
  85                                         r => "reminder-sent",
  86                                         n => "nmu-offered",
  87                                         e => "easy",
  88                                         m => "medium",
  89                                         h => "hard",
  90                                         c => "compiler-error",
  91                                         "" => "none" );
  92
  93 my $progname;
  94 ($progname = $0) =~ s,.*/,,;
  95 if ($prognames{$progname}) {
  96         $op_mode = $prognames{$progname};
  97 }
  98 elsif ($progname =~ /^list-(.*)$/) {
  99         $op_mode = "list";
 100         $list_state = ($1 eq "all") ? "" : $1;
 101 }
 102
 103 my %options =
 104         (# flags
 105          verbose        => { short => "v", flag => \$verbose },
 106          override               => { short => "o", flag => \$opt_override },
 107          "create-db"    => { flag => \$opt_create_db },
 108          "correct-compare" => { flag => \$WannaBuild::opt_correct_version_cmp },
 109          # TODO: remove after buildds no longer pass to wanna-build
 110          "no-propagation" => { short => "N" },
 111          "no-down-propagation" => { short => "D" },
 112          # normal actions
 113          take                   => { mode => "set-building" },
 114          failed                 => { short => "f", mode => "set-failed" },
 115          uploaded               => { short => "u", mode => "set-uploaded" },
 116          "no-build"             => { short => "n", mode => "set-not-for-us" },
 117          built                  => { mode => "set-built" },
 118          attempted              => { mode => "set-attempted" },
 119          "give-back"            => { mode => "set-needs-build" },
 120          "dep-wait"             => { mode => "set-dep-wait" },
 121          forget                 => { mode => "forget" },
 122          'forget-user' => { mode => 'forget-user' },
 123          "merge-quinn"  => { mode => "merge-quinn" },
 124          "merge-partial-quinn" => { mode => "merge-partial-quinn" },
 125          "merge-packages" => { mode => "merge-packages" },
 126          "merge-sources" => { mode => "merge-sources" },
 127          "pretend-avail" => { short => "p", mode => "pretend-avail" },
 128          "merge-all"     => { mode => "merge-all" },
 129          "merge-all-secondary" => { mode => "merge-all-secondary" },
 130          info                   => { short => "i", mode => "info" },
 131          'binNMU' => { mode => 'set-binary-nmu', arg => \$binNMUver,
 132                              code => sub { die "Invalid binNMU version: $binNMUver\n"
 133                                 if $binNMUver !~ /^([\d]*)$/ and $1 >= 0; } },
 134          'perm-build-priority'    => { mode => "set-permanent-build-priority", arg => \$build_priority,
 135                               code => sub { die "Invalid build priority: $build_priority\n"
 136                                 if $build_priority !~ /^-?[\d]+$/; } },
 137          'build-priority'    => { mode => "set-build-priority", arg => \$build_priority,
 138                               code => sub { die "Invalid build priority: $build_priority\n"
 139                                 if $build_priority !~ /^-?[\d]+$/; } },
 140          list                   =>
 141          { short => "l", mode => "list", arg => \$list_state,
 142            code => sub {
 143                    die "Unknown state to list: $list_state\n"
 144                            if !isin( $list_state, qw(needs-build building uploaded
 145                                                  built build-attempted failed installed dep-wait
 146                                                  not-for-us all failed-removed
 147                                                  install-wait reupload-wait bd-uninstallable));} },
 148          # options with args
 149          dist           =>
 150          { short => "d", arg => \$distribution,
 151            code => sub {
 152                    if ($distribution eq "a" || $distribution eq "all") {
 153                            $info_all_dists = 1;
 154                            $distribution = "";
 155                    }
 156                    else {
 157                            $distribution = "oldstable"   if $distribution eq "o";
 158                            $distribution = "stable"   if $distribution eq "s";
 159                            $distribution = "testing"  if $distribution eq "t";
 160                            $distribution = "unstable" if $distribution eq "u";
 161                    }
 162            } },
 163          order          =>
 164          { short => "O", arg => \$list_order,
 165            code => sub {
 166                    die "Bad ordering character\n"
 167                            if $list_order !~ /^[PSpsncbCW]+$/;
 168            } },
 169          message        => { short => "m", arg => \$fail_reason },
 170          # database is deprecated, use arch instead.
 171          database       => { short => "b", arg => \$conf::dbbase },
 172          arch           => { short => "A", arg => \$arch },
 173          user           => { short => "U", arg => \$user },
 174          category               => { short => "c", arg => \$category,
 175                                                  code => sub {
 176                                                          $category = $short_category{$category}
 177                                                                  if exists $short_category{$category};
 178                                                          die "Unknown category: $category\n"
 179                                                                  if !isin( $category, values %short_category );
 180                                                  } },
 181          "min-age"      => { short => "a", arg => \$list_min_age,
 182                                                  code => sub {
 183                                                          die "Argument of --min-age must be a non-zero number\n"
 184                                                                  if $list_min_age == 0;
 185                                                  } },
 186          "max-age"      => { arg => \$list_min_age,
 187                                                  code => sub {
 188                                                          die "Argument of --max-age must be a non-zero number\n"
 189                                                                  if $list_min_age == 0;
 190                                                          $list_min_age *= -1;
 191                                                  } },
 192          "format"       => { arg => \$printformat },
 193          # special actions
 194          export         => { arg => \$export_to, mode => "export" },
 195          import         => { arg => \$import_from, mode => "import" },
 196          "manual-edit"  => { mode => "manual-edit" },
 197          );
 198
 199 while( @ARGV && $ARGV[0] =~ /^-/ ) {
 200         $_ = shift @ARGV;
 201         last if $_ eq "--";
 202         my($opt, $optname, $arg);
 203         if (/^--([^=]+)(=|$)/) {
 204                 $optname = $1;
 205                 $opt = $options{$optname};
 206                 $arg = $1 if /^--\Q$optname\E=((.|\n)*)$/;
 207         }
 208         else {
 209                 $optname = substr( $_, 1, 1 );
 210                 $opt = (grep { defined($_->{short}) ? $_->{short} eq $optname : 0} values %options)[0];
 211                 $arg = $1 if /^-$optname(.+)$/;
 212         }
 213         if (!$opt) {
 214                 warn "Unknown option: --$1\n";
 215                 usage();
 216         }
 217         if ($opt->{arg}) {
 218                 if (!defined $arg) {
 219                         die "$optname option missing argument\n" if !@ARGV;
 220                         $arg = shift @ARGV;
 221                 }
 222                 ${$opt->{arg}} = $arg;
 223         }
 224         elsif (defined $arg) {
 225                 die "Option $optname takes no argument\n";
 226         }
 227
 228         if ($opt->{mode}) {
 229                 die "Conflicting operation modes\n" if $op_mode;
 230                 $op_mode = $opt->{mode};
 231         }
 232         if ($opt->{flag}) {
 233                 ${$opt->{flag}}++;
 234         }
 235         if ($opt->{code}) {
 236                 &{$opt->{code}};
 237         }
 238 }
 239
 240 $op_mode = $category ? "set-failed" : "set-building"
 241         if !$op_mode; # default operation
 242 $distribution ||= "unstable";
 243 die "Bad distribution '$distribution'\n"
 244         if !isin($distribution, keys %conf::distributions);
 245
 246 # If they didn't specify an arch, try to get it from database name which
 247 # is in the form of $arch/build-db
 248 # This is for backwards compatibity with older versions that didn't
 249 # specify the arch yet.
 250 $conf::dbbase =~ m#^([^/]+)#;
 251 $arch ||= $1;
 252
 253 # TODO: Check that it's an known arch (for that dist), and give
 254 # a proper error.
 255
 256 if ($verbose) {
 257         my $version = '$Revision: db181a534e9d $ $Date: 2008/03/26 06:20:22 $ $Author: rmurray $';
 258         $version =~ s/(^\$| \$ .*$)//g;
 259         print "wanna-build $version for $distribution on $arch\n";
 260 }
 261
 262 if (!@ARGV && !isin( $op_mode, qw(list merge-quinn merge-partial-quinn import export
 263                                   merge-packages manual-edit
 264                                   merge-sources))) {
 265         warn "No packages given.\n";
 266         usage();
 267 }
 268
 269 $real_user = (getpwuid($<))[0];
 270 die "Can't determine your user name\n"
 271         if $op_mode ne "list" && !$user &&
 272            !($user = $real_user);
 273
 274 if (!$fail_reason) {
 275         if ($op_mode eq "set-failed" && !$category) {
 276                 print "Enter reason for failing (end with '.' alone on ".
 277                       "its line):\n";
 278                 my $line;
 279                 while(!eof(STDIN)) {
 280                         $line = <STDIN>;
 281                         last if $line eq ".\n";
 282                         $fail_reason .= $line;
 283                 }
 284                 chomp( $fail_reason );
 285         } elsif ($op_mode eq "set-dep-wait") {
 286                 print "Enter dependencies (one line):\n";
 287                 my $line;
 288                 while( !$line && !eof(STDIN) ) {
 289                         chomp( $line = <STDIN> );
 290                 }
 291                 die "No dependencies given\n" if !$line;
 292                 $fail_reason = $line;
 293         } elsif ($op_mode eq "set-binary-nmu" and $binNMUver > 0) {
 294                 print "Enter changelog entry (one line):\n";
 295                 my $line;
 296                 while( !$line && !eof(STDIN) ) {
 297                         chomp( $line = <STDIN> );
 298                 }
 299                 die "No changelog entry given\n" if !$line;
 300                 $fail_reason = $line;
 301         }
 302 }
 303
 304 my $yamlmap = ();
 305 my $yamldir = "/org/wanna-build/etc/yaml";
 306 my @files = ('wanna-build.yaml');
 307 if ($user =~ /(buildd.*)-/) { push (@files, "$1.yaml") };
 308 push ( @files, "$user.yaml");
 309 foreach my $file (@files) {
 310         if ($verbose >= 2) { print "Trying to read $file ...\n"; }
 311         next unless -f $yamldir."/".$file;
 312         if ($verbose >= 2) { print "Read $file ...\n"; }
 313         my $m = YAML::Tiny->read( $yamldir."/".$file )->[0];
 314         $yamlmap = merge($m, $yamlmap);
 315 }
 316 if (not $yamlmap) {
 317         die "FATAL: no configuration found\n";
 318 }
 319 $list_order = $yamlmap->{"list-order"}{$list_state} if !$list_order and $list_state;
 320 $list_order ||= $yamlmap->{"list-order"}{'default'};
 321
 322 my $dbh;
 323
 324 END {
 325         if (defined $dbh)
 326         {
 327                 $dbh->disconnect or warn $dbh->errstr;
 328         }
 329 }
 330
 331 my $schema_suffix = '';
 332 if (isin( $op_mode, qw(list info)) && $distribution !~ /security/ && !(not -t and $user =~ /-/)) {
 333         $dbh = DBI->connect("DBI:Pg:service=wanna-build") ||
 334                 die "FATAL: Cannot open database: $DBI::errstr\n";
 335         $schema_suffix = '_public';
 336 }
 337 else
 338 {
 339         $dbh = DBI->connect("DBI:Pg:service=wanna-build-privileged") ||
 340                 die "FATAL: Cannot open database: $DBI::errstr\n";
 341 }
 342
 343 # TODO: This shouldn't be needed, file a bug.
 344 $dbh->{pg_server_prepare} = 0;
 345
 346 $dbh->begin_work or die $dbh->errstr;
 347
 348 process();
 349
 350 $dbh->commit;
 351 $dbh->disconnect;
 352
 353 if ($mail_logs && $conf::log_mail) {
 354         send_mail( $conf::log_mail,
 355                            "wanna-build $distribution state changes $curr_date",
 356                            "State changes at $curr_date for distribution ".
 357                            "$distribution:\n\n$mail_logs\n" );
 358 }
 359
 360 exit 0;
 361
 362
 363 sub process {
 364
 365         SWITCH: foreach ($op_mode) {
 366                 /^set-(.+)/ && do {
 367                         add_packages( $1, @ARGV );
 368                         last SWITCH;
 369                 };
 370                 /^list/ && do {
 371                         list_packages( $list_state );
 372                         last SWITCH;
 373                 };
 374                 /^info/ && do {
 375                         info_packages( @ARGV );
 376                         last SWITCH;
 377                 };
 378                 /^forget-user/ && do {
 379                         die "This operation is restricted to admin users\n"
 380                                 if (defined @conf::admin_users and
 381                                     !isin( $real_user, @conf::admin_users));
 382                         forget_users( @ARGV );
 383                         last SWITCH;
 384                 };
 385                 /^forget/ && do {
 386                         forget_packages( @ARGV );
 387                         last SWITCH;
 388                 };
 389                 /^merge-partial-quinn/ && do {
 390                         die "This operation is restricted to admin users\n"
 391                                 if (defined @conf::admin_users and
 392                                     !isin( $real_user, @conf::admin_users));
 393                         lock_table();
 394                         parse_quinn_diff(1);
 395                         last SWITCH;
 396                 };
 397                 /^merge-quinn/ && do {
 398                         die "This operation is restricted to admin users\n"
 399                                 if (defined @conf::admin_users and
 400                                     !isin( $real_user, @conf::admin_users));
 401                         lock_table();
 402                         parse_quinn_diff(0);
 403                         last SWITCH;
 404                 };
 405                 /^merge-packages/ && do {
 406                         die "This operation is restricted to admin users\n"
 407                                 if (defined @conf::admin_users and
 408                                     !isin( $real_user, @conf::admin_users));
 409                         lock_table();
 410                         parse_packages(0);
 411                         last SWITCH;
 412                 };
 413                 /^merge-sources/ && do {
 414                         die "This operation is restricted to admin users\n"
 415                                 if (defined @conf::admin_users and
 416                                     !isin( $real_user, @conf::admin_users));
 417                         lock_table();
 418                         parse_sources(0);
 419                         last SWITCH;
 420                 };
 421                 /^pretend-avail/ && do {
 422                         pretend_avail( @ARGV );
 423                         last SWITCH;
 424                 };
 425                 /^merge-all$/ && do {
 426                         die "This operation is restricted to admin users\n"
 427                                 if (defined @conf::admin_users and
 428                                     !isin( $real_user, @conf::admin_users));
 429                         lock_table();
 430                         my @ARGS = @ARGV;
 431                         @ARGV = ( $ARGS[0] );
 432                         my $pkgs = parse_packages(0);
 433                         @ARGV = ( $ARGS[1] );
 434                         parse_quinn_diff(0);
 435                         @ARGV = ( $ARGS[2] );
 436                         my $srcs = parse_sources(1);
 437                         call_edos_depcheck( $ARGS[0], $srcs );
 438                         last SWITCH;
 439                 };
 440                 /^merge-all-secondary/ && do {
 441                         die "This operation is restricted to admin users\n"
 442                                 if (defined @conf::admin_users and
 443                                     !isin( $real_user, @conf::admin_users));
 444                         # This is in case the chroot has multiple unrelated
 445                         # dist, for instance unstable and experimental.
 446                         # This is not for stable and proposed-updates.
 447                         # The second packages file contains a combination
 448                         # of all Packages files known to the buildd, the
 449                         # first only for the current dist.
 450                         lock_table();
 451                         my @ARGS = @ARGV;
 452                         @ARGV = ( $ARGS[0] );
 453                         my $pkgs = parse_packages(0);
 454                         @ARGV = ( $ARGS[3] );
 455                         my $pkgs = parse_packages(1);
 456                         @ARGV = ( $ARGS[1] );
 457                         parse_quinn_diff(0);
 458                         @ARGV = ( $ARGS[2] );
 459                         my $srcs = parse_sources(1);
 460                         call_edos_depcheck( $ARGS[3], $srcs );
 461                         last SWITCH;
 462                 };
 463                 /^import/ && do {
 464                         die "This operation is restricted to admin users\n"
 465                                 if (defined @conf::admin_users and
 466                                     !isin( $real_user, @conf::admin_users));
 467                         $dbh->do("DELETE from " . table_name() .
 468                                 " WHERE distribution = ?", undef,
 469                                 $distribution)
 470                                 or die $dbh->errstr;
 471                         forget_users();
 472                         read_db( $import_from );
 473                         last SWITCH;
 474                 };
 475                 /^export/ && do {
 476                         export_db( $export_to );
 477                         last SWITCH;
 478                 };
 479
 480                 die "Unexpected operation mode $op_mode\n";
 481         }
 482         if (not -t and $user =~ /-/) {
 483                 my $userinfo = get_user_info($user);
 484                 if (!defined $userinfo)
 485                 {
 486                         add_user_info($user);
 487                 }
 488                 else
 489                 {
 490                         update_user_info($user);
 491                 }
 492         }
 493 }
 494
 495 sub add_packages {
 496         my $newstate = shift;
 497         my( $package, $name, $version, $ok, $reason );
 498
 499         foreach $package (@_) {
 500                 $package =~ s,^.*/,,; # strip path
 501                 $package =~ s/\.(dsc|diff\.gz|tar\.gz|deb)$//; # strip extension
 502                 $package =~ s/_[a-zA-Z\d-]+\.changes$//; # strip extension
 503                 if ($package =~ /^([\w\d.+-]+)_([\w\d:.+~-]+)/) {
 504                         ($name,$version) = ($1,$2);
 505                 }
 506                 else {
 507                         warn "$package: can't extract package name and version ".
 508                                  "(bad format)\n";
 509                         next;
 510                 }
 511
 512                 if ($op_mode eq "set-building") {
 513                         add_one_building( $name, $version );
 514                 }
 515                 elsif ($op_mode eq "set-built") {
 516                         add_one_built( $name, $version );
 517                 }
 518                 elsif ($op_mode eq "set-attempted") {
 519                         add_one_attempted( $name, $version );
 520                 }
 521                 elsif ($op_mode eq "set-uploaded") {
 522                         add_one_uploaded( $name, $version );
 523                 }
 524                 elsif ($op_mode eq "set-failed") {
 525                         add_one_failed( $name, $version );
 526                 }
 527                 elsif ($op_mode eq "set-not-for-us") {
 528                         add_one_notforus( $name, $version );
 529                 }
 530                 elsif ($op_mode eq "set-needs-build") {
 531                         add_one_needsbuild( $name, $version );
 532                 }
 533                 elsif ($op_mode eq "set-dep-wait") {
 534                         add_one_depwait( $name, $version );
 535                 }
 536                 elsif ($op_mode eq "set-build-priority") {
 537                         set_one_buildpri( $name, $version, 'buildpri' );
 538                 }
 539                 elsif ($op_mode eq "set-permanent-build-priority") {
 540                         set_one_buildpri( $name, $version, 'permbuildpri' );
 541                 }
 542                 elsif ($op_mode eq "set-binary-nmu") {
 543                         set_one_binnmu( $name, $version );
 544                 }
 545         }
 546 }
 547
 548 sub add_one_building {
 549         my $name = shift;
 550         my $version = shift;
 551         my( $ok, $reason );
 552
 553         $ok = 1;
 554         my $pkg = get_source_info($name);
 555         if (defined($pkg)) {
 556                 if ($pkg->{'state'} eq "Not-For-Us") {
 557                         $ok = 0;
 558                         $reason = "not suitable for this architecture";
 559                 }
 560                 elsif ($pkg->{'state'} =~ /^Dep-Wait/) {
 561                         $ok = 0;
 562                         $reason = "not all source dependencies available yet";
 563                 }
 564                 elsif ($pkg->{'state'} =~ /^BD-Uninstallable/) {
 565                         $ok = 0;
 566                         $reason = "source dependencies are not installable";
 567                 }
 568                 elsif ($pkg->{'state'} eq "Uploaded" &&
 569                            (version_lesseq($version, $pkg->{'version'}))) {
 570                         $ok = 0;
 571                         $reason = "already uploaded by $pkg->{'builder'}";
 572                         $reason .= " (in newer version $pkg->{'version'})"
 573                                 if !version_eq($pkg, $version);
 574                 }
 575                 elsif ($pkg->{'state'} eq "Installed" &&
 576                            version_less($version,$pkg->{'version'})) {
 577                         if ($opt_override) {
 578                                 print "$name: Warning: newer version $pkg->{'version'} ".
 579                                           "already installed, but overridden.\n";
 580                         }
 581                         else {
 582                                 $ok = 0;
 583                                 $reason = "newer version $pkg->{'version'} already in ".
 584                                                   "archive; doesn't need rebuilding";
 585                                 print "$name: Note: If the following is due to an epoch ",
 586                                           " change, use --override\n";
 587                         }
 588                 }
 589                 elsif ($pkg->{'state'} eq "Installed" &&
 590                            pkg_version_eq($pkg,$version)) {
 591                         $ok = 0;
 592                         $reason = "is up-to-date in the archive; doesn't need rebuilding";
 593                 }
 594                 elsif ($pkg->{'state'} eq "Needs-Build" &&
 595                            version_less($version,$pkg->{'version'})) {
 596                         if ($opt_override) {
 597                                 print "$name: Warning: newer version $pkg->{'version'} ".
 598                                           "needs building, but overridden.";
 599                         }
 600                         else {
 601                                 $ok = 0;
 602                                 $reason = "newer version $pkg->{'version'} needs building, ".
 603                                                   "not $version";
 604                         }
 605                 }
 606                 elsif (isin($pkg->{'state'},qw(Building Built Build-Attempted))) {
 607                         if (version_less($pkg->{'version'},$version)) {
 608                                 print "$name: Warning: Older version $pkg->{'version'} ",
 609                                       "is being built by $pkg->{'builder'}\n";
 610                                 if ($pkg->{'builder'} ne $user) {
 611                                         send_mail( $pkg->{'builder'},
 612                                                            "package takeover in newer version",
 613                                                            "You are building package '$name' in ".
 614                                                            "version $version\n".
 615                                                            "(as far as I'm informed).\n".
 616                                                            "$user now has taken the newer ".
 617                                                            "version $version for building.".
 618                                                            "You can abort the build if you like.\n" );
 619                                 }
 620                         }
 621                         else {
 622                                 if ($opt_override) {
 623                                         print "User $pkg->{'builder'} had already ",
 624                                               "taken the following package,\n",
 625                                                   "but overriding this as you request:\n";
 626                                         send_mail( $pkg->{'builder'}, "package takeover",
 627                                                            "The package '$name' (version $version) that ".
 628                                                            "was taken by you\n".
 629                                                            "has been taken over by $user\n" );
 630                                 }
 631                                 elsif ($pkg->{'builder'} eq $user) {
 632                                         print "$name: Note: already taken by you.\n";
 633                                         print "$name: ok\n" if $verbose;
 634                                         return;
 635                                 }
 636                                 else {
 637                                         $ok = 0;
 638                                         $reason = "already taken by $pkg->{'builder'}";
 639                                         $reason .= " (in newer version $pkg->{'version'})"
 640                                                 if !version_eq($pkg->{'version'}, $version);
 641                                 }
 642                         }
 643                 }
 644                 elsif ($pkg->{'state'} =~ /^Failed/ &&
 645                            pkg_version_eq($pkg, $version)) {
 646                         if ($opt_override) {
 647                                 print "The following package previously failed ",
 648                                           "(by $pkg->{'builder'})\n",
 649                                           "but overriding this as you request:\n";
 650                                 send_mail( $pkg->{'builder'}, "failed package takeover",
 651                                                    "The package '$name' (version $version) that ".
 652                                                    "is taken by you\n".
 653                                                    "and has failed previously has been taken over ".
 654                                                    "by $user\n" )
 655                                         if $pkg->{'builder'} ne $user;
 656                         }
 657                         else {
 658                                 $ok = 0;
 659                                 $reason = "build of $version failed previously:\n    ";
 660                                 $reason .= join( "\n    ", split( "\n", $pkg->{'failed'} ));
 661                                 $reason .= "\nalso the package doesn't need builing"
 662                                         if $pkg->{'state'} eq 'Failed-Removed';
 663                         }
 664                 }
 665         }
 666         if ($ok) {
 667                 my $ok = 'ok';
 668                 if ($pkg->{'binary_nmu_version'}) {
 669                         print "$name: Warning: needs binary NMU $pkg->{'binary_nmu_version'}\n" .
 670                               "$pkg->{'binary_nmu_changelog'}\n";
 671                         $ok = 'aok';
 672                 } else {
 673                         print "$name: Warning: Previous version failed!\n"
 674                                 if $pkg->{'previous_state'} =~ /^Failed/ ||
 675                                    $pkg->{'state'} =~ /^Failed/;
 676                 }
 677                 change_state( \$pkg, 'Building' );
 678                 $pkg->{'package'} = $name;
 679                 $pkg->{'version'} = $version;
 680                 $pkg->{'builder'} = $user;
 681                 log_ta( $pkg, "--take" );
 682                 update_source_info($pkg);
 683                 print "$name: $ok\n" if $verbose;
 684         }
 685         else {
 686                 print "$name: NOT OK!\n  $reason\n";
 687         }
 688 }
 689
 690 sub add_one_attempted {
 691         my $name = shift;
 692         my $version = shift;
 693         my $pkg = get_source_info($name);
 694
 695         if (!defined($pkg)) {
 696                 print "$name: not registered yet.\n";
 697                 return;
 698         }
 699
 700         if (($pkg->{'state'} ne "Building") && ($pkg->{'state'} ne "Build-Attempted")) {
 701                 print "$name: not taken for building (state is $pkg->{'state'}). ",
 702                           "Skipping.\n";
 703                 return;
 704         }
 705         if ($pkg->{'builder'} ne $user) {
 706                 print "$name: not taken by you, but by $pkg->{'builder'}. Skipping.\n";
 707                 return;
 708         }
 709         elsif ( !pkg_version_eq($pkg, $version) ) {
 710                 print "$name: version mismatch ".
 711                           "$(pkg->{'version'} ".
 712                           "by $pkg->{'builder'})\n";
 713                 return;
 714         }
 715
 716         change_state( \$pkg, 'Build-Attempted' );
 717         log_ta( $pkg, "--attempted" );
 718         update_source_info($pkg);
 719         print "$name: registered as uploaded\n" if $verbose;
 720 }
 721
 722 sub add_one_built {
 723         my $name = shift;
 724         my $version = shift;
 725         my $pkg = get_source_info($name);
 726
 727         if (!defined($pkg)) {
 728                 print "$name: not registered yet.\n";
 729                 return;
 730         }
 731
 732         if (($pkg->{'state'} ne "Building") && ($pkg->{'state'} ne "Build-Attempted")) {
 733                 print "$name: not taken for building (state is $pkg->{'state'}). ",
 734                           "Skipping.\n";
 735                 return;
 736         }
 737         if ($pkg->{'builder'} ne $user) {
 738                 print "$name: not taken by you, but by $pkg->{'builder'}. Skipping.\n";
 739                 return;
 740         }
 741         elsif ( !pkg_version_eq($pkg, $version) ) {
 742                 print "$name: version mismatch ".
 743                           "$(pkg->{'version'} ".
 744                           "by $pkg->{'builder'})\n";
 745                 return;
 746         }
 747         change_state( \$pkg, 'Built' );
 748         log_ta( $pkg, "--built" );
 749         update_source_info($pkg);
 750         print "$name: registered as built\n" if $verbose;
 751 }
 752
 753 sub add_one_uploaded {
 754         my $name = shift;
 755         my $version = shift;
 756         my $pkg = get_source_info($name);
 757
 758         if (!defined($pkg)) {
 759                 print "$name: not registered yet.\n";
 760                 return;
 761         }
 762
 763         if ($pkg->{'state'} eq "Uploaded" &&
 764                 pkg_version_eq($pkg,$version)) {
 765                 print "$name: already uploaded\n";
 766                 return;
 767         }
 768         if (!isin( $pkg->{'state'}, qw(Building Built Build-Attempted))) {
 769                 print "$name: not taken for building (state is $pkg->{'state'}). ",
 770                           "Skipping.\n";
 771                 return;
 772         }
 773         if ($pkg->{'builder'} ne $user) {
 774                 print "$name: not taken by you, but by $pkg->{'builder'}. Skipping.\n";
 775                 return;
 776         }
 777         # strip epoch -- buildd-uploader used to go based on the filename.
 778         # (to remove at some point)
 779         my $pkgver;
 780         ($pkgver = $pkg->{'version'}) =~ s/^\d+://;
 781         $version =~ s/^\d+://; # for command line use
 782         if ($pkg->{'binary_nmu_version'} ) {
 783                 my $nmuver = binNMU_version($pkgver, $pkg->{'binary_nmu_version'});
 784                 if (!version_eq( $nmuver, $version )) {
 785                         print "$name: version mismatch ($nmuver registered). ",
 786                                   "Skipping.\n";
 787                         return;
 788                 }
 789         } elsif (!version_eq($pkgver, $version)) {
 790                 print "$name: version mismatch ($pkg->{'version'} registered). ",
 791                           "Skipping.\n";
 792                 return;
 793         }
 794
 795         change_state( \$pkg, 'Uploaded' );
 796         log_ta( $pkg, "--uploaded" );
 797         update_source_info($pkg);
 798         print "$name: registered as uploaded\n" if $verbose;
 799 }
 800
 801 sub add_one_failed {
 802         my $name = shift;
 803         my $version = shift;
 804         my ($state, $cat);
 805         my $pkg = get_source_info($name);
 806
 807         if (!defined($pkg)) {
 808                 print "$name: not registered yet.\n";
 809                 return;
 810         }
 811         $state = $pkg->{'state'};
 812
 813         if ($state eq "Not-For-Us") {
 814                 print "$name: not suitable for this architecture anyway. Skipping.\n";
 815                 return;
 816         }
 817         elsif ($state eq "Failed-Removed") {
 818                 print "$name: failed previously and doesn't need building. Skipping.\n";
 819                 return;
 820         }
 821         elsif ($state eq "Installed") {
 822                 print "$name: Is already installed in archive. Skipping.\n";
 823                 return;
 824         }
 825         elsif ($pkg->{'builder'} &&
 826                    (($user ne $pkg->{'builder'}) &&
 827                     !($pkg->{'builder'} =~ /^(\w+)-\w+/ && $1 eq $user))) {
 828                 print "$name: not taken by you, but by ".
 829                           "$pkg->{'builder'}. Skipping.\n";
 830                 return;
 831         }
 832         elsif ( !pkg_version_eq($pkg, $version) ) {
 833                 print "$name: version mismatch ".
 834                           "$(pkg->{'version'} ".
 835                           "by $pkg->{'builder'})\n";
 836                 return;
 837         }
 838
 839         $cat = $category;
 840         if (!$cat && $fail_reason =~ /^\[([^\]]+)\]/) {
 841                 $cat = $1;
 842                 $cat = $short_category{$cat} if exists $short_category{$cat};
 843                 if (!isin( $cat, values %short_category )) {
 844                         print "$name: Warning: unknown category $cat; discarded\n";
 845                         $cat = "";
 846                 }
 847                 $fail_reason =~ s/^\[[^\]]+\][ \t]*\n*//;
 848         }
 849
 850         if ($state eq "Needs-Build") {
 851                 print "$name: Warning: not registered for building previously, ".
 852                           "but processing anyway.\n";
 853         }
 854         elsif ($state eq "Uploaded") {
 855                 print "$name: Warning: marked as uploaded previously, ".
 856                           "but processing anyway.\n";
 857         }
 858         elsif ($state eq "Dep-Wait") {
 859                 print "$name: Warning: marked as waiting for dependencies, ".
 860                           "but processing anyway.\n";
 861         }
 862         elsif ($state eq "BD-Uninstallable") {
 863                 print "$name: Warning: marked as having uninstallable build-dependencies, ".
 864                           "but processing anyway.\n";
 865         }
 866         elsif ($state eq "Failed") {
 867                 print "$name: already registered as failed; will append new message\n"
 868                         if $fail_reason;
 869                 print "$name: already registered as failed; changing category\n"
 870                         if $cat;
 871         }
 872
 873         if (($cat eq "reminder-sent" || $cat eq "nmu-offered") &&
 874                 defined $pkg->{'failed_category'} &&
 875                 $pkg->{'failed_category'} ne $cat) {
 876                 (my $action = $cat) =~ s/-/ /;
 877                 $fail_reason .= "\n$short_date: $action";
 878         }
 879
 880         change_state( \$pkg, 'Failed' );
 881         $pkg->{'builder'} = $user;
 882         $pkg->{'failed'} .= "\n" if $pkg->{'failed'};
 883         $pkg->{'failed'} .= $fail_reason;
 884         $pkg->{'failed_category'} = $cat if $cat;
 885         if (defined $pkg->{'permbuildpri'}) {
 886                 $pkg->{'buildpri'} = $pkg->{'permbuildpri'};
 887         } else {
 888                 delete $pkg->{'buildpri'};
 889         }
 890         log_ta( $pkg, "--failed" );
 891         update_source_info($pkg);
 892         print "$name: registered as failed\n" if $verbose;
 893 }
 894
 895 sub add_one_notforus {
 896         my $name = shift;
 897         my $version = shift;
 898         my $pkg = get_source_info($name);
 899
 900         if ($pkg->{'state'} eq 'Not-For-Us') {
 901                 # reset Not-For-Us state in case it's called twice; this is
 902                 # the only way to get a package out of this state...
 903                 # There is no really good state in which such packages should
 904                 # be put :-( So use Failed for now.
 905                 change_state( \$pkg, 'Failed' );
 906                 $pkg->{'package'} = $name;
 907                 $pkg->{'failed'} = "Was Not-For-Us previously";
 908                 delete $pkg->{'builder'};
 909                 delete $pkg->{'depends'};
 910                 log_ta( $pkg, "--no-build(rev)" );
 911                 print "$name: now not unsuitable anymore\n";
 912
 913                 send_mail( $conf::notforus_maint,
 914                                    "$name moved out of Not-For-Us state",
 915                                    "The package '$name' has been moved out of the Not-For-Us ".
 916                                    "state by $user.\n".
 917                                    "It should probably also be removed from ".
 918                                    "Packages-arch-specific or\n".
 919                                    "the action was wrong.\n" )
 920                         if $conf::notforus_maint;
 921         }
 922         else {
 923                 change_state( \$pkg, 'Not-For-Us' );
 924                 $pkg->{'package'} = $name;
 925                 delete $pkg->{'builder'};
 926                 delete $pkg->{'depends'};
 927                 delete $pkg->{'buildpri'};
 928                 delete $pkg->{'binary_nmu_version'};
 929                 delete $pkg->{'binary_nmu_changelog'};
 930                 log_ta( $pkg, "--no-build" );
 931                 print "$name: registered as unsuitable\n" if $verbose;
 932
 933                 send_mail( $conf::notforus_maint,
 934                                    "$name set to Not-For-Us",
 935                                    "The package '$name' has been set to state Not-For-Us ".
 936                                    "by $user.\n".
 937                                    "It should probably also be added to ".
 938                                    "Packages-arch-specific or\n".
 939                                    "the Not-For-Us state is wrong.\n" )
 940                         if $conf::notforus_maint;
 941         }
 942         update_source_info($pkg);
 943 }
 944
 945 sub add_one_needsbuild {
 946         my $name = shift;
 947         my $version = shift;
 948         my $state;
 949         my $pkg = get_source_info($name);
 950
 951         if (!defined($pkg)) {
 952                 print "$name: not registered; can't give back.\n";
 953                 return;
 954         }
 955         $state = $pkg->{'state'};
 956
 957         if ($state eq "BD-Uninstallable") {
 958                 if ($opt_override) {
 959                         print "$name: Forcing uninstallability mark to be removed. This is not permanent and might be reset with the next trigger run\n";
 960
 961                         change_state( \$pkg, 'Needs-Build' );
 962                         delete $pkg->{'builder'};
 963                         delete $pkg->{'depends'};
 964                         log_ta( $pkg, "--give-back" );
 965                         update_source_info($pkg);
 966                         print "$name: given back\n" if $verbose;
 967                         return;
 968                 }
 969                 else {
 970                         print "$name: has uninstallable build-dependencies. Skipping\n",
 971                                   "  (use --override to clear dependency list and ",
 972                                   "give back anyway)\n";
 973                         return;
 974                 }
 975         }
 976         elsif ($state eq "Dep-Wait") {
 977                 if ($opt_override) {
 978                         print "$name: Forcing source dependency list to be cleared\n";
 979                 }
 980                 else {
 981                         print "$name: waiting for source dependencies. Skipping\n",
 982                                   "  (use --override to clear dependency list and ",
 983                                   "give back anyway)\n";
 984                         return;
 985                 }
 986         }
 987         elsif (!isin( $state, qw(Building Built Build-Attempted))) {
 988                 print "$name: not taken for building (state is $state).";
 989                 if ($opt_override) {
 990                         print "\n$name: Forcing give-back\n";
 991                 }
 992                 else {
 993                         print " Skipping.\n";
 994                         return;
 995                 }
 996         }
 997         if (defined ($pkg->{'builder'}) && $user ne $pkg->{'builder'} &&
 998                 !($pkg->{'builder'} =~ /^(\w+)-\w+/ && $1 eq $user) &&
 999                 !$opt_override) {
1000                 print "$name: not taken by you, but by ".
1001                           "$pkg->{'builder'}. Skipping.\n";
1002                 return;
1003         }
1004         if (!pkg_version_eq($pkg, $version)) {
1005                 print "$name: version mismatch ($pkg->{'version'} registered). ",
1006                           "Skipping.\n";
1007                 return;
1008         }
1009         if ($distribution eq "unstable") {
1010                 change_state( \$pkg, 'BD-Uninstallable' );
1011                 $pkg->{'bd_problem'} = "Installability of build dependencies not tested yet";
1012         } else {
1013                 change_state( \$pkg, 'Needs-Build' );
1014         }
1015         $pkg->{'builder'} = undef;
1016         $pkg->{'depends'} = undef;
1017         log_ta( $pkg, "--give-back" );
1018         update_source_info($pkg);
1019         print "$name: given back\n" if $verbose;
1020 }
1021
1022 sub set_one_binnmu {
1023         my $name = shift;
1024         my $version = shift;
1025         my $pkg = get_source_info($name);
1026         my $state;
1027
1028         if (!defined($pkg)) {
1029                 print "$name: not registered; can't register for binNMU.\n";
1030                 return;
1031         }
1032         my $db_ver = $pkg->{'version'};
1033
1034         if (!version_eq($db_ver, $version)) {
1035                 print "$name: version mismatch ($db_ver registered). ",
1036                           "Skipping.\n";
1037                 return;
1038         }
1039         $state = $pkg->{'state'};
1040
1041         if (defined $pkg->{'binary_nmu_version'}) {
1042                 if ($binNMUver == 0) {
1043                         change_state( \$pkg, 'Installed' );
1044                         delete $pkg->{'builder'};
1045                         delete $pkg->{'depends'};
1046                         delete $pkg->{'binary_nmu_version'};
1047                         delete $pkg->{'binary_nmu_changelog'};
1048                 } elsif ($binNMUver <= $pkg->{'binary_nmu_version'}) {
1049                         print "$name: already building binNMU $pkg->{'binary_nmu_version'}\n";
1050                         return;
1051                 } else {
1052                         $pkg->{'binary_nmu_version'} = $binNMUver;
1053                         $pkg->{'binary_nmu_changelog'} = $fail_reason;
1054                         $pkg->{'notes'} = 'out-of-date';
1055                         $pkg->{'buildpri'} = $pkg->{'permbuildpri'}
1056                                 if (defined $pkg->{'permbuildpri'});
1057                 }
1058                 log_ta( $pkg, "--binNMU" );
1059                 update_source_info($pkg);
1060                 return;
1061         } elsif ($binNMUver == 0) {
1062                 print "${name}_$version: no scheduled binNMU to cancel.\n";
1063                 return;
1064         }
1065
1066         if ($state ne 'Installed') {
1067                 print "${name}_$version: not installed; can't register for binNMU.\n";
1068                 return;
1069         }
1070
1071         my $fullver = binNMU_version($version,$binNMUver);
1072         if ( version_lesseq( $fullver, $pkg->{'installed_version'} ) )
1073         {
1074                 print "$name: binNMU $fullver is not newer than current version $pkg->{'installed_version'}\n";
1075                 return;
1076         }
1077
1078         if ($distribution eq "unstable") {
1079                 change_state( \$pkg, 'BD-Uninstallable' );
1080                 $pkg->{'bd_problem'} = "Installability of build dependencies not tested yet";
1081         }
1082         else
1083         {
1084                 change_state( \$pkg, 'Needs-Build' );
1085         }
1086         delete $pkg->{'builder'};
1087         delete $pkg->{'depends'};
1088         $pkg->{'binary_nmu_version'} = $binNMUver;
1089         $pkg->{'binary_nmu_changelog'} = $fail_reason;
1090         $pkg->{'notes'} = 'out-of-date';
1091         log_ta( $pkg, "--binNMU" );
1092         update_source_info($pkg);
1093         print "${name}: registered for binNMU $fullver\n" if $verbose;
1094 }
1095
1096 sub set_one_buildpri {
1097         my $name = shift;
1098         my $version = shift;
1099         my $key = shift;
1100         my $pkg = get_source_info($name);
1101         my $state;
1102
1103         if (!defined($pkg)) {
1104                 print "$name: not registered; can't set priority.\n";
1105                 return;
1106         }
1107         $state = $pkg->{'state'};
1108
1109         if ($state eq "Not-For-Us") {
1110                 print "$name: not suitable for this architecture. Skipping.\n";
1111                 return;
1112         } elsif ($state eq "Failed-Removed") {
1113                 print "$name: failed previously and doesn't need building. Skipping.\n";
1114                 return;
1115         }
1116         if (!pkg_version_eq($pkg, $version)) {
1117                 print "$name: version mismatch ($pkg->{'version'} registered). ",
1118                           "Skipping.\n";
1119                 return;
1120         }
1121         if ( $build_priority == 0 ) {
1122                 delete $pkg->{'buildpri'}
1123                         if $key eq 'permbuildpri' and defined $pkg->{'buildpri'}
1124                         and $pkg->{'buildpri'} == $pkg->{$key};
1125                 delete $pkg->{$key};
1126         } else {
1127                 $pkg->{'buildpri'} = $build_priority
1128                         if $key eq 'permbuildpri';
1129                 $pkg->{$key} = $build_priority;
1130         }
1131         update_source_info($pkg);
1132         print "$name: set to build priority $build_priority\n" if $verbose;
1133 }
1134
1135 sub add_one_depwait {
1136         my $name = shift;
1137         my $version = shift;
1138         my $state;
1139         my $pkg = get_source_info($name);
1140
1141         if (!defined($pkg)) {
1142                 print "$name: not registered yet.\n";
1143                 return;
1144         }
1145         $state = $pkg->{'state'};
1146
1147         if ($state eq "Dep-Wait") {
1148                 print "$name: merging with previously registered dependencies\n";
1149         }
1150
1151         if (isin( $state, qw(Needs-Build Failed BD-Uninstallable))) {
1152                 print "$name: Warning: not registered for building previously, ".
1153                           "but processing anyway.\n";
1154         }
1155         elsif ($state eq "Not-For-Us") {
1156                 print "$name: not suitable for this architecture anyway. Skipping.\n";
1157                 return;
1158         }
1159         elsif ($state eq "Failed-Removed") {
1160                 print "$name: failed previously and doesn't need building. Skipping.\n";
1161                 return;
1162         }
1163         elsif ($state eq "Installed") {
1164                 print "$name: Is already installed in archive. Skipping.\n";
1165                 return;
1166         }
1167         elsif ($state eq "Uploaded") {
1168                 print "$name: Is already uploaded. Skipping.\n";
1169                 return;
1170         }
1171         elsif ($pkg->{'builder'} &&
1172                    $user ne $pkg->{'builder'}) {
1173                 print "$name: not taken by you, but by ".
1174                           "$pkg->{'builder'}. Skipping.\n";
1175                 return;
1176         }
1177         elsif ( !pkg_version_eq($pkg,$version)) {
1178                 print "$name: version mismatch ".
1179                           "($pkg->{'version'} ".
1180                           "by $pkg->{'builder'})\n";
1181                 return;
1182         }
1183         elsif ($fail_reason =~ /^\s*$/ ||
1184                    !parse_deplist( $fail_reason, 1 )) {
1185                 print "$name: Bad dependency list\n";
1186                 return;
1187         }
1188         change_state( \$pkg, 'Dep-Wait' );
1189         $pkg->{'builder'} = $user;
1190         if (defined $pkg->{'permbuildpri'}) {
1191                 $pkg->{'buildpri'} = $pkg->{'permbuildpri'};
1192         } else {
1193                 delete $pkg->{'buildpri'};
1194         }
1195         my $deplist = parse_deplist( $pkg->{'depends'} );
1196         my $new_deplist = parse_deplist( $fail_reason );
1197         # add new dependencies, maybe overwriting old entries
1198         foreach (keys %$new_deplist) {
1199                 $deplist->{$_} = $new_deplist->{$_};
1200         }
1201         $pkg->{'depends'} = build_deplist($deplist);
1202         log_ta( $pkg, "--dep-wait" );
1203         update_source_info($pkg);
1204         print "$name: registered as waiting for dependencies\n" if $verbose;
1205 }
1206
1207
1208 sub parse_sources {
1209         my %pkgs;
1210         my %srcver;
1211         my $name;
1212         my $full = shift;
1213
1214         my $db = get_all_source_info();
1215
1216         local($/) = ""; # read in paragraph mode
1217         while( <> ) {
1218                 my( $version, $arch, $section, $priority, $builddep, $buildconf, $binaries );
1219                 s/\s*$//m;
1220                 /^Package:\s*(\S+)$/mi and $name = $1;
1221                 /^Version:\s*(\S+)$/mi and $version = $1;
1222                 /^Architecture:\s*(\S+)$/mi and $arch = $1;
1223                 /^Section:\s*(\S+)$/mi and $section = $1;
1224                 /^Priority:\s*(\S+)$/mi and $priority = $1;
1225                 /^Build-Depends:\s*(.*)$/mi and $builddep = $1;
1226                 /^Build-Conflicts:\s*(.*)$/mi and $buildconf = $1;
1227                 /^Binary:\s*(.*)$/mi and $binaries = $1;
1228
1229                 next if (defined $srcver{$name} and version_less( $version, $srcver{$name} ));
1230                 $srcver{$name} = $version;
1231
1232                 $pkgs{$name}{'ver'} = $version;
1233                 $pkgs{$name}{'bin'} = $binaries;
1234                 $pkgs{$name}{'dep'} = $builddep;
1235                 $pkgs{$name}{'conf'} = $buildconf;
1236                 my $pkg = $db->{$name};
1237
1238                 if (defined $pkg) {
1239                         my $change = 0;
1240
1241                         if ($arch eq "all" && !version_less( $version, $pkg->{'version'} )) {
1242                                 # package is now Arch: all, delete it from db
1243                                 change_state( \$pkg, 'deleted' );
1244                                 log_ta( $pkg, "--merge-sources" );
1245                                 print "$name ($pkg->{'version'}): deleted ".
1246                                           "from database, because now Arch: all\n"
1247                                                   if $verbose;
1248                                 del_source_info($name);
1249                                 delete $db->{$name};
1250                                 next;
1251                         }
1252
1253                         # The "Version" should always be the source version --
1254                         # not a possible binNMU version number.
1255                         $pkg->{'version'} = $version, $change++
1256                                 if ($pkg->{'state'} eq 'Installed' and
1257                                 !version_eq( $pkg->{'version'}, $version));
1258                         # Always update priority and section, if available
1259                         $pkg->{'priority'} = $priority, $change++
1260                                 if defined $priority and (not defined($pkg->{'priority'}) or $pkg->{'priority'} ne $priority);
1261
1262                         $pkg->{'section'} = $section, $change++
1263                                 if defined $section and (not defined($pkg->{'section'}) or $pkg->{'section'} ne $section);
1264
1265                         update_source_info($pkg) if $change;
1266                 }
1267         }
1268         # Now that we only have the latest source version, build the list
1269         # of binary packages from the Sources point of view
1270         foreach $name (keys %pkgs) {
1271             foreach my $bin (split( /\s*,\s*/, $pkgs{$name}{'bin'} ) ) {
1272                 $merge_binsrc{$bin} = $name;
1273             }
1274         }
1275         # remove installed packages that no longer have source available
1276         # or binaries installed
1277         foreach $name (keys %$db) {
1278                 next if $name =~ /^_/;
1279                 my $pkg = $db->{$name};
1280                 if (not defined($pkgs{$name})) {
1281                         change_state( \$pkg, 'deleted' );
1282                         log_ta( $pkg, "--merge-sources" );
1283                         print "$name ($pkg->{'version'}): ".
1284                                   "deleted from database, because ".
1285                                   "not in Sources anymore\n"
1286                                           if $verbose;
1287                         del_source_info($name);
1288                         delete $db->{$name};
1289                 } else {
1290                         next if !isin( $pkg->{'state'}, qw(Installed) );
1291                         if ($full && not defined $merge_srcvers{$name}) {
1292                             change_state( \$pkg, 'deleted' );
1293                             log_ta( $pkg, "--merge-sources" );
1294                             print "$name ($pkg->{'version'}): ".
1295                                       "deleted from database, because ".
1296                                       "binaries don't exist anymore\n"
1297                                               if $verbose;
1298                             del_source_info($name);
1299                             delete $db->{$name};
1300                         } elsif ($full && version_less( $merge_srcvers{$name}, $pkg->{'version'})) {
1301                             print "$name ($pkg->{'version'}): ".
1302                                       "package is Installed but binaries are from ".
1303                                       $merge_srcvers{$name}. "\n"
1304                                               if $verbose;
1305                         }
1306                 }
1307         }
1308         return \%pkgs;
1309 }
1310
1311 # This function looks through a Packages file and sets the state of
1312 # packages to 'Installed'
1313 sub parse_packages {
1314         my $depwait_only = shift;
1315         my $installed;
1316
1317         my $pkgs = get_all_source_info();
1318         local($/) = ""; # read in paragraph mode
1319         while( <> ) {
1320                 my( $name, $version, $depends, $source, $sourcev, $architecture, $provides, $binaryv, $binnmu );
1321                 s/\s*$//m;
1322                 /^Package:\s*(\S+)$/mi and $name = $1;
1323                 /^Version:\s*(\S+)$/mi and $version = $1;
1324                 /^Depends:\s*(.*)$/mi and $depends = $1;
1325                 /^Source:\s*(\S+)(\s*\((\S+)\))?$/mi and ($source,$sourcev) = ($1, $3);
1326                 /^Architecture:\s*(\S+)$/mi and $architecture = $1;
1327                 /^Provides:\s*(.*)$/mi and $provides = $1;
1328                 next if !$name || !$version;
1329                 next if ($arch ne $architecture and $architecture ne "all");
1330                 next if (defined ($installed->{$name}) and $installed->{$name}{'version'} ne "" and
1331                         version_lesseq( $version, $installed->{$name}{'version'} ));
1332                 $installed->{$name}{'version'} = $version;
1333                 next if $depwait_only;
1334                 $installed->{$name}{'depends'} = $depends;
1335                 $installed->{$name}{'all'} = 1 if $architecture eq "all";
1336                 undef $installed->{$name}{'Provider'};
1337                 $installed->{$name}{'Source'} = $source ? $source : $name;
1338                 if ($provides) {
1339                     foreach (split( /\s*,\s*/, $provides )) {
1340                         if (not defined ($installed->{$_})) {
1341                             $installed->{$_}{'version'} = "";
1342                             $installed->{$_}{'Provider'} = $name;
1343                         }
1344                     }
1345                 }
1346                 if ( $version =~ /\+b(\d+)$/ ) {
1347                     $binnmu = $1;
1348                 }
1349                 $version = $sourcev if $sourcev;
1350                 $binaryv = $version;
1351                 $binaryv =~ s/\+b\d+$//;
1352                 $installed->{$name}{'Sourcev'} = $sourcev ? $sourcev : $binaryv;
1353                 $binaryv .= "+b$binnmu" if defined($binnmu);
1354
1355                 next if $architecture ne $arch;
1356                 $name = $source if $source;
1357                 next if defined($merge_srcvers{$name}) and $merge_srcvers{$name} eq $version;
1358                 $merge_srcvers{$name} = $version;
1359
1360                 my $pkg = $pkgs->{$name};
1361
1362                 if (defined $pkg) {
1363                         if (isin( $pkg->{'state'}, qw(Not-For-Us)) ||
1364                                 (isin($pkg->{'state'}, qw(Installed)) &&
1365                                  version_lesseq($binaryv, $pkg->{'installed_version'}))) {
1366                                 print "Skipping $name because State == $pkg->{'state'}\n"
1367                                         if $verbose >= 2;
1368                                 next;
1369                         }
1370                         if ($pkg->{'binary_nmu_version'} ) {
1371                                 my $nmuver = binNMU_version($pkg->{'version'}, $pkg->{'binary_nmu_version'});
1372                                 if (version_less( $binaryv, $nmuver )) {
1373                                         print "Skipping $name ($version) because have newer ".
1374                                                 "version ($nmuver) in db.\n"
1375                                                         if $verbose >= 2;
1376                                         next;
1377                                 }
1378                         } elsif (version_less($version, $pkg->{'version'})) {
1379                                 print "Skipping $name ($version) because have newer ".
1380                                         "version ($pkg->{'version'}) in db.\n"
1381                                                 if $verbose >= 2;
1382                                 next;
1383                         }
1384
1385                         if (!pkg_version_eq($pkg, $version) &&
1386                            $pkg->{'state'} ne "Installed") {
1387                                 warn "Warning: $name: newer version than expected appeared ".
1388                                          "in archive ($version vs. $pkg->{'version'})\n";
1389                                 delete $pkg->{'builder'};
1390                         }
1391
1392                         if (!isin( $pkg->{'state'}, qw(Uploaded) )) {
1393                                 warn "Warning: Package $name was not in uploaded state ".
1394                                          "before (but in '$pkg->{'state'}').\n";
1395                                 delete $pkg->{'builder'};
1396                                 delete $pkg->{'depends'};
1397                         }
1398                 } else {
1399                         $pkg = {};
1400                         $pkg->{'version'} = $version;
1401                 }
1402
1403                 change_state( \$pkg, 'Installed' );
1404                 $pkg->{'package'} = $name;
1405                 $pkg->{'installed_version'} = $binaryv;
1406                 if (defined $pkg->{'permbuildpri'}) {
1407                         $pkg->{'buildpri'} = $pkg->{'permbuildpri'};
1408                 } else {
1409                         delete $pkg->{'buildpri'};
1410                 }
1411                 $pkg->{'version'} = $version
1412                         if version_less( $pkg->{'version'}, $version);
1413                 delete $pkg->{'binary_nmu_version'};
1414                 delete $pkg->{'binary_nmu_changelog'};
1415                 log_ta( $pkg, "--merge-packages" );
1416                 update_source_info($pkg);
1417                 print "$name ($version) is up-to-date now.\n" if $verbose;
1418         }
1419
1420         check_dep_wait( "--merge-packages", $installed );
1421         return $installed;
1422 }
1423
1424 sub pretend_avail {
1425         my ($package, $name, $version, $installed);
1426
1427         foreach $package (@_) {
1428                 $package =~ s,^.*/,,; # strip path
1429                 $package =~ s/\.(dsc|diff\.gz|tar\.gz|deb)$//; # strip extension
1430                 $package =~ s/_[\w\d]+\.changes$//; # strip extension
1431                 if ($package =~ /^([\w\d.+-]+)_([\w\d:.+~-]+)/) {
1432                         ($name,$version) = ($1,$2);
1433                 }
1434                 else {
1435                         warn "$package: can't extract package name and version ".
1436                                  "(bad format)\n";
1437                         next;
1438                 }
1439                 $installed->{$name}{'version'} = $version;
1440         }
1441
1442         check_dep_wait( "--pretend-avail", $installed );
1443 }
1444
1445 sub check_dep_wait {
1446         my $action = shift;
1447         my $installed = shift;
1448
1449         # check all packages in state Dep-Wait if dependencies are all
1450         # available now
1451         my $name;
1452         my $db = get_all_source_info();
1453         foreach $name (keys %$db) {
1454                 next if $name =~ /^_/;
1455                 my $pkg = $db->{$name};
1456                 next if $pkg->{'state'} ne "Dep-Wait";
1457                 my $deps = $pkg->{'depends'};
1458                 if (!$deps) {
1459                         print "$name: was in state Dep-Wait, but with empty ",
1460                                   "dependencies!\n";
1461                         goto make_needs_build;
1462                 }
1463                 my $deplist = parse_deplist($deps);
1464                 my $new_deplist;
1465                 my $allok = 1;
1466                 my @removed_deps;
1467                 foreach (keys %$deplist) {
1468                         if (!exists $installed->{$_} ||
1469                                 ($deplist->{$_}->{'rel'} && $deplist->{$_}->{'version'} &&
1470                                  !version_compare( $installed->{$_}{'version'},
1471                                                                    $deplist->{$_}->{'rel'},
1472                                                                    $deplist->{$_}->{'version'}))) {
1473                                 $allok = 0;
1474                                 $new_deplist->{$_} = $deplist->{$_};
1475                         }
1476                         else {
1477                                 push( @removed_deps, $_ );
1478                         }
1479                 }
1480                 if ($allok) {
1481                   make_needs_build:
1482                         change_state( \$pkg, 'Needs-Build' );
1483                         log_ta( $pkg, $action );
1484                         delete $pkg->{'builder'};
1485                         delete $pkg->{'depends'};
1486                         print "$name ($pkg->{'version'}) has all ",
1487                                   "dependencies available now\n" if $verbose;
1488                         $new_vers{$name}++;
1489                         update_source_info($pkg);
1490                 }
1491                 elsif (@removed_deps) {
1492                         $pkg->{'depends'} = build_deplist( $new_deplist );
1493                         print "$name ($pkg->{'version'}): some dependencies ",
1494                                   "(@removed_deps) available now, but not all yet\n"
1495                                 if $verbose;
1496                         update_source_info($pkg);
1497                 }
1498         }
1499 }
1500
1501 # This function accepts quinn-diff output (either from a file named on
1502 # the command line, or on stdin) and sets the packages named there to
1503 # state 'Needs-Build'.
1504 sub parse_quinn_diff {
1505         my $partial = shift;
1506         my %quinn_pkgs;
1507         my $dubious = "";
1508
1509         my $pkgs = get_all_source_info();
1510
1511         while( <> ) {
1512                 my $change = 0;
1513                 next if !m,^([-\w\d/]*)/                        # section
1514                                ([-\w\d.+]+)_                    # package name
1515                                    ([\w\d:.~+-]+)\.dsc\s*       # version
1516                                    \[([^:]*):                           # priority
1517                                    ([^]]+)\]\s*$,x;                     # rest of notes
1518                 my($section,$name,$version,$priority,$notes) = ($1, $2, $3, $4, $5);
1519                 $quinn_pkgs{$name}++;
1520                 $section ||= "unknown";
1521                 $priority ||= "unknown";
1522                 $priority = "unknown" if $priority eq "-";
1523                 $priority = "standard" if ($name eq "debian-installer");
1524
1525                 my $pkg = $pkgs->{$name};
1526
1527                 # Always update section and priority.
1528                 if (defined($pkg)) {
1529
1530                         $pkg->{'section'}  = $section, $change++ if not defined
1531                                 $pkg->{'section'} or $section ne "unknown";
1532                         $pkg->{'priority'} = $priority, $change++ if not defined
1533                                 $pkg->{'priority'} or $priority ne "unknown";
1534                 }
1535
1536                 if (defined($pkg) &&
1537                         $pkg->{'state'} =~ /^Dep-Wait/ &&
1538                         version_less( $pkg->{'version'}, $version )) {
1539                         change_state( \$pkg, 'Dep-Wait' );
1540                         $pkg->{'version'}  = $version;
1541                         delete $pkg->{'binary_nmu_version'};
1542                         delete $pkg->{'binary_nmu_changelog'};
1543                         log_ta( $pkg, "--merge-quinn" );
1544                         $change++;
1545                         print "$name ($version) still waiting for dependencies.\n"
1546                                 if $verbose;
1547                 }
1548                 elsif (defined($pkg) &&
1549                            $pkg->{'state'} =~ /-Removed$/ &&
1550                            version_eq($pkg->{'version'}, $version)) {
1551                         # reinstantiate a package that has been removed earlier
1552                         # (probably due to a quinn-diff malfunction...)
1553                         my $newstate = $pkg->{'state'};
1554                         $newstate =~ s/-Removed$//;
1555                         change_state( \$pkg, $newstate );
1556                         $pkg->{'version'}  = $version;
1557                         $pkg->{'notes'}    = $notes;
1558                         log_ta( $pkg, "--merge-quinn" );
1559                         $change++;
1560                         print "$name ($version) reinstantiated to $newstate.\n"
1561                                 if $verbose;
1562                 }
1563                 elsif (defined($pkg) &&
1564                            $pkg->{'state'} eq "Not-For-Us" &&
1565                            version_less( $pkg->{'version'}, $version )) {
1566                         # for Not-For-Us packages just update the version etc., but
1567                         # keep the state
1568                         change_state( \$pkg, "Not-For-Us" );
1569                         $pkg->{'package'}  = $name;
1570                         $pkg->{'version'}  = $version;
1571                         $pkg->{'notes'}    = $notes;
1572                         delete $pkg->{'builder'};
1573                         log_ta( $pkg, "--merge-quinn" );
1574                         $change++;
1575                         print "$name ($version) still Not-For-Us.\n" if $verbose;
1576                 }
1577                 elsif (!defined($pkg) ||
1578                            $pkg->{'state'} ne "Not-For-Us" &&
1579                            (version_less( $pkg->{'version'}, $version ) ||
1580                            ($pkg->{'state'} eq "Installed" && version_less($pkg->{'installed_version'}, $version)))) {
1581
1582                         if (defined( $pkg->{'state'} ) && isin( $pkg->{'state'}, qw(Building Built Build-Attempted))) {
1583                                 send_mail( $pkg->{'builder'},
1584                                                    "new version of $name (dist=$distribution)",
1585                                                    "As far as I'm informed, you're currently ".
1586                                                    "building the package $name\n".
1587                                                    "in version $pkg->{'version'}.\n\n".
1588                                                    "Now there's a new source version $version. ".
1589                                                    "If you haven't finished\n".
1590                                                    "compiling $name yet, you can stop it to ".
1591                                                    "save some work.\n".
1592                                                    "Just to inform you...\n".
1593                                                    "(This is an automated message)\n" );
1594                                 print "$name: new version ($version) while building ".
1595                                           "$pkg->{'version'} -- sending mail ".
1596                                           "to builder ($pkg->{'builder'})\n"
1597                                   if $verbose;
1598                         }
1599                         change_state( \$pkg, 'Needs-Build' );
1600                         $pkg->{'package'}  = $name;
1601                         $pkg->{'version'}  = $version;
1602                         $pkg->{'section'}  = $section;
1603                         $pkg->{'priority'} = $priority;
1604                         $pkg->{'notes'}    = $notes;
1605                         delete $pkg->{'builder'};
1606                         delete $pkg->{'binary_nmu_version'};
1607                         delete $pkg->{'binary_nmu_changelog'};
1608                         log_ta( $pkg, "--merge-quinn" );
1609                         $new_vers{$name}++;
1610                         $change++;
1611                         print "$name ($version) needs rebuilding now.\n" if $verbose;
1612                 }
1613                 elsif (defined($pkg) &&
1614                            !version_eq( $pkg->{'version'}, $version ) &&
1615                            isin( $pkg->{'state'}, qw(Installed Not-For-Us) )) {
1616                         print "$name: skipping because version in db ".
1617                                   "($pkg->{'version'}) is >> than ".
1618                                   "what quinn-diff says ($version) ".
1619                                   "(state is $pkg->{'state'})\n"
1620                                           if $verbose;
1621                         $dubious .= "$pkg->{'state'}: ".
1622                                                 "db ${name}_$pkg->{'version'} >> ".
1623                                                 "quinn $version\n" if !$partial;
1624                 }
1625                 elsif ($verbose >= 2) {
1626                         if ($pkg->{'state'} eq "Not-For-Us") {
1627                                 print "Skipping $name because State == ".
1628                                           "$pkg->{'state'}\n";
1629                         }
1630                         elsif (!version_less($pkg->{'version'}, $version)) {
1631                                 print "Skipping $name because version in db ".
1632                                           "($pkg->{'version'}) is >= than ".
1633                                           "what quinn-diff says ($version)\n";
1634                         }
1635                 }
1636                 update_source_info($pkg) if $change;
1637         }
1638
1639         if ($dubious) {
1640                 send_mail( $conf::db_maint,
1641                                    "Dubious versions in " . table_name() . " "
1642                                    . $distribution . " table",
1643                                    "The following packages have a newer version in the ".
1644                                    "wanna-build database\n".
1645                                    "than what quinn-diff says, and this is strange for ".
1646                                    "their state\n".
1647                                    "It could be caused by a lame mirror, or the version ".
1648                                    "in the database\n".
1649                                    "is wrong.\n\n".
1650                                    $dubious );
1651         }
1652
1653         # Now re-check the DB for packages in states Needs-Build, Failed,
1654         # Dep-Wait or BD-Uninstallable and remove them if they're not listed
1655         # anymore by quinn-diff.
1656         if ( !$partial ) {
1657                 my $name;
1658                 my $db = get_all_source_info();
1659                 foreach $name (keys %$db) {
1660                         next if $name =~ /^_/;
1661                         my $pkg = $db->{$name};
1662                         next if defined $pkg->{'binary_nmu_version'};
1663                         next if !isin( $pkg->{'state'},
1664                                                    qw(Needs-Build Building Built Build-Attempted Uploaded Failed Dep-Wait BD-Uninstallable) );
1665                         my $virtual_delete = $pkg->{'state'} eq 'Failed';
1666
1667                         if (!$quinn_pkgs{$name}) {
1668                                 change_state( \$pkg, $virtual_delete ?
1669                                                           $pkg->{'state'}."-Removed" :
1670                                                           'deleted' );
1671                                 log_ta( $pkg, "--merge-quinn" );
1672                                 print "$name ($pkg->{'version'}): ".
1673                                           ($virtual_delete ? "(virtually) " : "") . "deleted ".
1674                                           "from database, because not in quinn-diff anymore\n"
1675                                                   if $verbose;
1676                                 if ($virtual_delete) {
1677                                     update_source_info($pkg);
1678                                 } else {
1679                                     del_source_info($name);
1680                                 }
1681                         }
1682                 }
1683         }
1684 }
1685
1686
1687 # for sorting priorities and sections
1688 BEGIN {
1689         %prioval = ( required             => -5,
1690                                  important            => -4,
1691                                  standard             => -3,
1692                                  optional             => -2,
1693                                  extra                => -1,
1694                                  unknown              => -1 );
1695         %sectval = (
1696                                  libs                   => -200,
1697                                  'debian-installer'     => -199,
1698                                  base                   => -198,
1699                                  devel                  => -197,
1700                                  kernel                 => -196,
1701                                  shells                 => -195,
1702                                  perl                   => -194,
1703                                  python                 => -193,
1704                                  graphics               => -192,
1705                                  admin                  => -191,
1706                                  utils                  => -190,
1707                                  x11                    => -189,
1708                                  editors                => -188,
1709                                  net                    => -187,
1710                                  httpd                  => -186,
1711                                  mail                   => -185,
1712                                  news                   => -184,
1713                                  tex                    => -183,
1714                                  text                   => -182,
1715                                  web                    => -181,
1716                                  vcs                    => -180,
1717                                  doc                    => -179,
1718                                  localizations          => -178,
1719                                  interpreters           => -177,
1720                                  ruby                   => -176,
1721                                  java                   => -175,
1722                                  ocaml                  => -174,
1723                                  lisp                   => -173,
1724                                  haskell                => -172,
1725                                  'cli-mono'             => -171,
1726                                  gnome                  => -170,
1727                                  kde                    => -169,
1728                                  xfce                   => -168,
1729                                  gnustep                => -167,
1730                                  database               => -166,
1731                                  video                  => -165,
1732                                  debug                  => -164,
1733                                  games                  => -163,
1734                                  misc                   => -162,
1735                                  fonts                  => -161,
1736                                  otherosfs              => -160,
1737                                  oldlibs                => -159,
1738                                  libdevel               => -158,
1739                                  sound                  => -157,
1740                                  math                   => -156,
1741                                  'gnu-r'                => -155,
1742                                  science                => -154,
1743                                  comm                   => -153,
1744                                  electronics            => -152,
1745                                  hamradio               => -151,
1746                                  embedded               => -150,
1747                                  php                    => -149,
1748                                  zope                   => -148,
1749         );
1750         foreach my $i (keys %sectval) {
1751                 $sectval{"contrib/$i"} = $sectval{$i}+40;
1752                 $sectval{"non-free/$i"} = $sectval{$i}+80;
1753         }
1754         $sectval{'unknown'}     = -165;
1755
1756         %catval =  ( "none"                           => -20,
1757                                  "uploaded-fixed-pkg" => -19,
1758                                  "fix-expected"       => -18,
1759                                  "reminder-sent"      => -17,
1760                                  "nmu-offered"        => -16,
1761                                  "easy"               => -15,
1762                                  "medium"                     => -14,
1763                                  "hard"                   => -13,
1764                                  "compiler-error"     => -12 );
1765 }
1766
1767 sub sort_list_func {
1768     my $map_funcs = {
1769         'C' => ['<=>', sub { return (-1) * $_[0]->{'calprio'}; }],
1770         'W' => ['<=>', sub { return (-1) * $_[0]->{'state_days'}; }],
1771         'P' => ['<=>', sub { return (-1) * $_[0]->{'buildpri'}; }],
1772         'p' => ['<=>', sub { return $prioval{$_[0]->{'priority'}}; }],
1773         's' => ['<=>', sub { return $sectval{$_[0]->{'section'}}; }],
1774         'n' => ['cmp', sub { return $_[0]->{'package'}; }],
1775         'b' => ['cmp', sub { return $_[0]->{'builder'}; }],
1776         'c' => ['<=>', sub { return ($_[0]->{'notes'} =~ /^(out-of-date|partial)/) ? 0: ($_[0]->{'notes'} =~ /^uncompiled/) ? 2 : 1; }],
1777         'f' => ['<=>', sub { return $catval{ $_[0]->{'failed_category'} ? $_[0]->{'failed_category'}: "none" }; }],
1778         'S' => ['<=>', sub { return $prioval{$_[0]->{'priority'}} > $prioval{'standard'}; }],
1779     };
1780
1781         foreach my $letter (split( //, $list_order )) {
1782             my $r;
1783             $r = &{$map_funcs->{$letter}[1]}($a) <=> &{$map_funcs->{$letter}[1]}($b) if $map_funcs->{$letter}[0] eq '<=>';
1784             $r = &{$map_funcs->{$letter}[1]}($a) cmp &{$map_funcs->{$letter}[1]}($b) if $map_funcs->{$letter}[0] eq 'cmp';
1785             return $r if $r != 0;
1786         }
1787         return 0;
1788 }
1789
1790 sub calculate_prio {
1791         my $priomap = $yamlmap->{priority};
1792         my $pkg = shift;
1793         my @s=split("/", $pkg->{'section'});
1794         $pkg->{'component'} = $s[0] if $s[1];
1795         $pkg->{'component'} ||= 'main';
1796         $pkg->{'calprio'} = 0;
1797         foreach my $k (keys %{$priomap->{keys}}) {
1798                 $pkg->{'calprio'} += $priomap->{keys}->{$k}{$pkg->{$k}} if $pkg->{$k} and $priomap->{keys}->{$k}{$pkg->{$k}};
1799         }
1800
1801         my $days = $pkg->{'state_days'};
1802         $days = $priomap->{'waitingdays'}->{'min'} if $priomap->{'waitingdays'}->{'min'} and $days < $priomap->{'waitingdays'}->{'min'};
1803         $days = $priomap->{'waitingdays'}->{'max'} if $priomap->{'waitingdays'}->{'max'} and $days > $priomap->{'waitingdays'}->{'max'};
1804         my $scale = $priomap->{'waitingdays'}->{'scale'} || 1;
1805         $pkg->{'calprio'} += $days * $scale;
1806
1807         $pkg->{'calprio'} += $pkg->{'permbuildpri'} if  $pkg->{'permbuildpri'};
1808         $pkg->{'calprio'} += $pkg->{'buildpri'} if  $pkg->{'buildpri'};
1809
1810         return $pkg;
1811 }
1812
1813
1814 sub use_fmt {
1815     my $r;
1816
1817     if (ref($_[0]) eq 'CODE') {
1818         $r = &{$_[0]};
1819     } else {
1820         $r = $_[0];
1821     }
1822
1823     shift;
1824     my $t = shift;
1825
1826     $r ||= "";
1827     return $r unless $t;
1828
1829     my $pkg = shift;
1830     my $var = shift;
1831     if (substr($t,0,1) eq '!') {
1832         $t = substr($t,1);
1833         return "" if $r;
1834     } else {
1835         return "" unless $r;
1836     }
1837     if ($t =~ /%/) {
1838         return print_format($t, $pkg, $var);
1839     }
1840     return $t;
1841 }
1842 sub make_fmt { my $c = shift; my $pkg = shift; my $var = shift; return sub { use_fmt($c, $_[0], $pkg, $var); } };
1843
1844 sub print_format {
1845     my $printfmt = shift;
1846     my $pkg = shift;
1847     my $var = shift;
1848 =pod
1849 Within an format string, the following values are allowed (need to be preceded by %).
1850 This can be combined to e.g.
1851 wanna-build --format='wanna-build -A %a --give-back %p_%v' -A mipsel --list=failed
1852
1853 a Architecture
1854 c section (e.g. libs or utils)
1855 D in case of BD-Uninstallable the reason for the uninstallability
1856 d distribution
1857 E in case of Dep-Wait the packages being waited on, in case of Needs-Build the number in the queue
1858 P previous state
1859 p Package name
1860 S Package state
1861 s Time in this state in full seconds since epoch
1862 t time of state change
1863 u Builder (e.g. buildd_mipsel-rem)
1864 v Package version
1865 V full Package version (i.e. with +b.., = %v%{+b}B%B
1866 X the string normally between [], e.g. optional:out-of-date:calprio{61}:days{25}
1867 F in case of Failed the fail reason
1868
1869 %{Text}?  print Text in case ? is not empty; ? is never printed
1870 %{!Text}? print Text in case ? is empty; ? is never printed
1871 Text could contain further %. To start with !, use %!
1872
1873 =cut
1874     return stringf($printfmt, (
1875         'p' => make_fmt( $pkg->{'package'}, $pkg, $var),
1876         'a' => make_fmt( $arch, $pkg, $var),
1877         's' => make_fmt( sub { return floor(str2time($pkg->{'state_change'})); }, $pkg, $var),
1878         'v' => make_fmt( $pkg->{'version'}, $pkg, $var),
1879         'V' => make_fmt( sub { $pkg->{'binary_nmu_version'} ? $pkg->{'version'}."+b".$pkg->{'binary_nmu_version'} : $pkg->{'version'} }, $pkg, $var),
1880         'S' => make_fmt( $pkg->{'state'}, $pkg, $var),
1881         'u' => make_fmt( $pkg->{'builder'}, $pkg, $var),
1882         'X' => make_fmt( sub {
1883             my $c = "$pkg->{'priority'}:$pkg->{'notes'}";
1884             $c .= ":PREV-FAILED" if $pkg->{'previous_state'} =~ /^Failed/;
1885             $c .= ":bp{" . $pkg->{'buildpri'} . "}" if defined $pkg->{'buildpri'};
1886             $c .= ":binNMU{" . $pkg->{'binary_nmu_version'} . "}" if defined $pkg->{'binary_nmu_version'};
1887             $c .= ":calprio{". $pkg->{'calprio'}."}";
1888             $c .= ":days{". $pkg->{'state_days'}."}";
1889             return $c;
1890             }, $pkg, $var),
1891         'c' => make_fmt( $pkg->{'section'}, $pkg, $var),
1892         'P' => make_fmt( $pkg->{'previous_state'} || "unknwon", $pkg, $var),
1893         'E' => make_fmt( sub { return $pkg->{'depends'} if $pkg->{'state'} eq "Dep-Wait";
1894             return $var->{scnt}{'Needs-Build'} + 1 if $pkg->{'state'} eq 'Needs-Build';
1895             return ""; }, $pkg, $var),
1896         'F' => make_fmt( sub { return "" unless $pkg->{'failed'};
1897             return $pkg->{'package'}."#".$arch."-failure\n ".
1898             join("\\0a",split("\n",$pkg->{'failed'}))."\\0a\n"; }, $pkg, $var),
1899         'D' => make_fmt( sub { return "" unless $pkg->{'bd_problem'};
1900             return $pkg->{'package'}."#".$arch."-bd-problem\n".
1901             join("\\0a",split("\n",$pkg->{'bd_problem'}))."\\0a\n"; }, $pkg, $var),
1902         'B' => make_fmt( sub { return $pkg->{'binary_nmu_version'} if defined $pkg->{'binary_nmu_version'}; }, $pkg, $var),
1903         'd' => make_fmt( $distribution, $pkg, $var),
1904         't' => make_fmt( $pkg->{'state_change'}, $pkg, $var),
1905     ));
1906 }
1907
1908 sub list_packages {
1909         my $state = shift;
1910         my( $name, $pkg, @list );
1911         my $cnt = 0;
1912         my %scnt;
1913         my $ctime = time;
1914
1915         my $db = get_all_source_info(state => $state, user => $user, category => $category, list_min_age => $list_min_age);
1916         foreach $name (keys %$db) {
1917                 next if $name =~ /^_/;
1918                 push @list, calculate_prio($db->{$name});
1919         }
1920
1921         # filter components
1922         @list = grep { my $i = $_->{'component'}; grep { $i eq $_ } split /[, ]+/, $yamlmap->{"restrict"}{'component'} } @list;
1923
1924         foreach $pkg (sort sort_list_func @list) {
1925                 if ($printformat) {
1926                     print print_format($printformat, $pkg, {'cnt' => $cnt, 'scnt' => \%scnt})."\n";
1927                     ++$cnt;
1928                     $scnt{$pkg->{'state'}}++;
1929                     next;
1930                 }
1931                 print "$pkg->{'section'}/$pkg->{'package'}_$pkg->{'version'}";
1932                 print ": $pkg->{'state'}"
1933                         if $state eq "all";
1934                 print " by $pkg->{'builder'}"
1935                         if $pkg->{'state'} ne "Needs-Build" && $pkg->{'builder'};
1936                 print " [$pkg->{'priority'}:$pkg->{'notes'}";
1937                 print ":PREV-FAILED"
1938                         if $pkg->{'previous_state'} =~ /^Failed/;
1939                 print ":bp{" . $pkg->{'buildpri'} . "}"
1940                         if defined $pkg->{'buildpri'};
1941                 print ":binNMU{" . $pkg->{'binary_nmu_version'} . "}"
1942                         if defined $pkg->{'binary_nmu_version'};
1943                 print ":calprio{". $pkg->{'calprio'}."}";
1944                 print ":days{". $pkg->{'state_days'}."}";
1945                 print "]\n";
1946                 print "  Reasons for failing:\n",
1947                           "    [Category: ",
1948                           defined $pkg->{'failed_category'} ? $pkg->{'failed_category'} : "none",
1949                           "]\n    ",
1950                           join("\n    ",split("\n",$pkg->{'failed'})), "\n"
1951                         if $pkg->{'state'} =~ /^Failed/;
1952                 print "  Dependencies: $pkg->{'depends'}\n"
1953                         if $pkg->{'state'} eq "Dep-Wait";
1954                 print "  Reasons for BD-Uninstallable:\n    ",
1955                           join("\n    ",split("\n",$pkg->{'bd_problem'})), "\n"
1956                         if $pkg->{'state'} eq "BD-Uninstallable";
1957                 print "  Previous state was $pkg->{'previous_state'}\n"
1958                         if $verbose && $pkg->{'previous_state'};
1959                 print "  No previous state recorded\n"
1960                         if $verbose && !$pkg->{'previous_state'};
1961                 print "  State changed at $pkg->{'state_change'}\n"
1962                         if $verbose && $pkg->{'state_change'};
1963                 print "  Previous state $pkg->{'previous_state'} left $pkg->{'state_time'} ago\n"
1964                         if $verbose && $pkg->{'previous_state'};
1965                 print "  Previous failing reasons:\n    ",
1966                       join("\n    ",split("\n",$pkg->{'old_failed'})), "\n"
1967                         if $verbose && $pkg->{'old_failed'};
1968                 ++$cnt;
1969                 $scnt{$pkg->{'state'}}++ if $state eq "all";
1970         }
1971         if ($state eq "all" && !$printformat) {
1972                 foreach (sort keys %scnt) {
1973                         print "Total $scnt{$_} package(s) in state $_.\n";
1974                 }
1975         }
1976         print "Total $cnt package(s)\n" unless $printformat;
1977
1978 }
1979
1980 sub info_packages {
1981         my( $name, $pkg, $key, $dist );
1982         my @firstkeys = qw(package version builder state section priority
1983                                            installed_version previous_state state_change);
1984         my @dists = $info_all_dists ? keys %conf::distributions : ($distribution);
1985         my %beautykeys = ( 'package' => 'Package', 'version' => 'Version', 'builder' => 'Builder',
1986                 'state' => 'State', 'section' => 'Section', 'priority' => 'Priority',
1987                 'installed_version' => 'Installed-Version', 'previous_state' => 'Previous-State',
1988                 'state_change' => 'State-Change',
1989                 'bd_problem' => 'BD-Problem',
1990                 'binary_nmu_changelog' => 'Binary-NMU-Changelog', 'binary_nmu_version' => 'Binary-NMU-Version',
1991                 'buildpri' => 'BuildPri', 'depends' => 'Depends', 'failed' => 'Failed',
1992                 'failed_category' => 'Failed-Category', 'notes' => 'Notes',
1993                 'distribution' => 'Distribution', 'old_failed' => 'Old-Failed',
1994                 'permbuildpri' => 'PermBuildPri', 'rel' => 'Rel',
1995                 'calprio' => 'CalculatedPri', 'state_days' => 'State-Days'
1996                          );
1997
1998         foreach $name (@_) {
1999                 $name =~ s/_.*$//; # strip version
2000                 foreach $dist (@dists) {
2001                         my $pname = "$name" . ($info_all_dists ? "($dist)" : "");
2002
2003                         $pkg = get_readonly_source_info($name);
2004                         if (!defined( $pkg )) {
2005                                 print "$pname: not registered\n";
2006                                 next;
2007                         }
2008                         $pkg = calculate_prio($pkg);
2009
2010                         print "$pname:\n";
2011                         foreach $key (@firstkeys) {
2012                                 next if !defined $pkg->{$key};
2013                                 my $val = $pkg->{$key};
2014                                 chomp( $val );
2015                                 $val = "\n$val" if isin( $key, qw(Failed Old-Failed));
2016                                 $val =~ s/\n/\n    /g;
2017                                 my $print_key = $key;
2018                                 $print_key = $beautykeys{$print_key} if $beautykeys{$print_key};
2019                                 printf "  %-20s: %s\n", $print_key, $val;
2020                         }
2021                         foreach $key (sort keys %$pkg) {
2022                                 next if isin( $key, @firstkeys );
2023                                 my $val = $pkg->{$key};
2024                                 next if !defined($val);
2025                                 chomp( $val );
2026                                 $val = "\n$val" if isin( $key, qw(Failed Old-Failed));
2027                                 $val =~ s/\n/\n    /g;
2028                                 my $print_key = $key;
2029                                 $print_key = $beautykeys{$print_key} if $beautykeys{$print_key};
2030                                 printf "  %-20s: %s\n", $print_key, $val;
2031                         }
2032                 }
2033         }
2034 }
2035
2036 sub forget_packages {
2037         my( $name, $pkg, $key, $data );
2038
2039         foreach $name (@_) {
2040                 $name =~ s/_.*$//; # strip version
2041                 $pkg = get_source_info($name);
2042                 if (!defined( $pkg )) {
2043                         print "$name: not registered\n";
2044                         next;
2045                 }
2046
2047                 $data = "";
2048                 foreach $key (sort keys %$pkg) {
2049                         my $val = $pkg->{$key};
2050                         chomp( $val );
2051                         $val =~ s/\n/\n /g;
2052                         $data .= sprintf "  %-20s: %s\n", $key, $val;
2053                 }
2054                 send_mail( $conf::db_maint,
2055                                    "$name deleted from DB " . table_name() . " " . $distribution,
2056                                    "The package '$name' has been deleted from the database ".
2057                                    "by $user.\n\n".
2058                                    "Data registered about the deleted package:\n".
2059                                    "$data\n" ) if $conf::db_maint;
2060                 change_state( \$pkg, 'deleted' );
2061                 log_ta( $pkg, "--forget" );
2062                 del_source_info($name);
2063                 print "$name: deleted from database\n" if $verbose;
2064         }
2065 }
2066
2067 sub forget_users {
2068         $dbh->do("DELETE from " . user_table_name() .
2069                 " WHERE distribution = ?", undef, $distribution) or die $dbh->errstr;
2070 }
2071
2072 sub read_db {
2073         my $file = shift;
2074
2075         print "Reading ASCII database from $file..." if $verbose >= 1;
2076         open( F, "<$file" ) or
2077                 die "Can't open database $file: $!\n";
2078
2079         local($/) = ""; # read in paragraph mode
2080         while( <F> ) {
2081                 my( %thispkg, $name );
2082                 s/[\s\n]+$//;
2083                 s/\n[ \t]+/\376\377/g;  # fix continuation lines
2084                 s/\376\377\s*\376\377/\376\377/og;
2085
2086                 while( /^(\S+):[ \t]*(.*)[ \t]*$/mg ) {
2087                         my ($key, $val) = ($1, $2);
2088                         $key =~ s/-/_/g;
2089                         $key =~ tr/A-Z/a-z/;
2090                         $val =~ s/\376\377/\n/g;
2091                         $thispkg{$key} = $val;
2092                 }
2093                 check_entry( \%thispkg );
2094                 # add to db
2095                 if (exists($thispkg{'package'})) {
2096                         update_source_info(\%thispkg);
2097                 }
2098                 elsif(exists($thispkg{'user'})) {
2099                         # user in import, username in database.
2100                         $dbh->do('INSERT INTO ' . user_table_name() .
2101                                         ' (username, distribution, last_seen)' .
2102                                         ' values (?, ?, ?)',
2103                                 undef, $thispkg{'user'}, $distribution,
2104                                 $thispkg{'last_seen'})
2105                                 or die $dbh->errstr;
2106                  }
2107         }
2108         close( F );
2109         print "done\n" if $verbose >= 1;
2110 }
2111
2112 sub check_entry {
2113         my $pkg = shift;
2114         my $field;
2115
2116         return if $op_mode eq "manual-edit"; # no checks then
2117
2118         # check for required fields
2119         if (exists $pkg->{'user'}) {
2120                 return;
2121         }
2122         if (!exists $pkg->{'package'}) {
2123                 print STDERR "Bad entry: ",
2124                           join( "\n", map { "$_: $pkg->{$_}" } keys %$pkg ), "\n";
2125                 die "Database entry lacks package or username field\n";
2126         }
2127         # if no State: field, generate one (for old db compat)
2128         if (!exists($pkg->{'state'})) {
2129                 $pkg->{'state'} =
2130                         exists $pkg->{'failed'} ? 'Failed' : 'Building';
2131         }
2132         if (!exists $pkg->{'version'} and $pkg->{'state'} ne 'Not-For-Us') {
2133                 die "Database entry for $pkg->{'package'} lacks Version: field\n";
2134         }
2135         # check state field
2136         die "Bad state $pkg->{'state'} of package $pkg->{Package}\n"
2137                 if !isin( $pkg->{'state'},
2138                                   qw(Needs-Build Building Built Build-Attempted Uploaded Installed Dep-Wait Dep-Wait-Removed
2139                                          Failed Failed-Removed Not-For-Us BD-Uninstallable
2140                                          ) );
2141 }
2142
2143 sub export_db {
2144         my $file = shift;
2145         my($name,$pkg,$key);
2146
2147         print "Writing ASCII database to $file..." if $verbose >= 1;
2148         open( F, ">$file" ) or
2149                 die "Can't open export $file: $!\n";
2150
2151         my $db = get_all_source_info();
2152         foreach $name (keys %$db) {
2153                 next if $name =~ /^_/;
2154                 my $pkg = $db->{$name};
2155                 foreach $key (keys %{$pkg}) {
2156                         my $val = $pkg->{$key};
2157                         next if !defined($val);
2158                         $val =~ s/\n*$//;
2159                         $val =~ s/^/ /mg;
2160                         $val =~ s/^ +$/ ./mg;
2161                         print F "$key: $val\n";
2162                 }
2163                 print F "\n";
2164        }
2165        close( F );
2166        print "done\n" if $verbose >= 1;
2167 }
2168
2169 sub change_state {
2170         my $pkgr = shift;
2171         my $pkg = $$pkgr;
2172         my $newstate = shift;
2173         my $state = \$pkg->{'state'};
2174
2175         return if defined($$state) and $$state eq $newstate;
2176         $pkg->{'previous_state'} = $$state if defined($$state);
2177         $pkg->{'state_change'} = $curr_date;
2178         $pkg->{'do_state_change'} = 1;
2179
2180         if (defined($$state) and $$state eq 'Failed') {
2181                 $pkg->{'old_failed'} =
2182                         "-"x20 . " $pkg->{'version'} " . "-"x20 . "\n" .
2183                         $pkg->{'failed'} . "\n" .
2184                         $pkg->{'old_failed'};
2185                 delete $pkg->{'failed'};
2186                 delete $pkg->{'failed_category'};
2187         }
2188         if (defined($$state) and $$state eq 'BD-Uninstallable') {
2189                 delete $pkg->{'bd_problem'};
2190         }
2191         $$state = $newstate;
2192 }
2193
2194 sub log_ta {
2195         my $pkg = shift;
2196         my $action = shift;
2197         my $dist = $distribution;
2198         my $str;
2199         my $prevstate;
2200
2201         $prevstate = $pkg->{'previous_state'};
2202         $str = "$action($dist): $pkg->{'package'}_$pkg->{'version'} ".
2203                    "changed from $prevstate to $pkg->{'state'} ".
2204                    "by $real_user as $user";
2205
2206         $dbh->do('INSERT INTO ' . transactions_table_name() .
2207                         ' (package, distribution, version, action, ' .
2208                         ' prevstate, state, real_user, set_user, time) ' .
2209                         ' values (?, ?, ?, ?, ?, ?, ?, ?, ?)',
2210                 undef, $pkg->{'package'}, $distribution,
2211                 $pkg->{'version'}, $action, $prevstate, $pkg->{'state'},
2212                 $real_user, $user, 'now()') or die $dbh->errstr;
2213
2214         if (!($prevstate eq 'Failed' && $pkg->{'state'} eq 'Failed')) {
2215                 $str .= " (with --override)"
2216                         if $opt_override;
2217                 $mail_logs .= "$str\n";
2218         }
2219 }
2220
2221
2222 sub send_mail {
2223         my $to = shift;
2224         my $subject = shift;
2225         my $text = shift;
2226
2227         my $from = $conf::db_maint;
2228         my $domain = $conf::buildd_domain;
2229
2230         $from .= "\@$domain" if $from !~ /\@/;
2231
2232         $to .= '@' . $domain if $to !~ /\@/;
2233         $text =~ s/^\.$/../mg;
2234         local $SIG{'PIPE'} = 'IGNORE';
2235         open( PIPE,  "| $conf::mailprog -oem $to" )
2236                 or die "Can't open pipe to $conf::mailprog: $!\n";
2237         chomp $text;
2238         print PIPE "From: $from\n";
2239         print PIPE "Subject: $subject\n\n";
2240         print PIPE "$text\n";
2241         close( PIPE );
2242 }
2243
2244 # for parsing input to dep-wait
2245 sub parse_deplist {
2246     my $deps = shift;
2247     my $verify = shift;
2248     my %result;
2249
2250     foreach (split( /\s*,\s*/, $deps )) {
2251         if ($verify) {
2252             # verification requires > starting prompts, no | crap
2253             if (!/^(\S+)\s*(\(\s*(>(?:[>=])?)\s*(\S+)\s*\))?\s*$/) {
2254                 return 0;
2255             }
2256             next;
2257         }
2258         my @alts = split( /\s*\|\s*/, $_ );
2259         # Anything with an | is ignored, as it can be configured on a
2260         # per-buildd basis what will be installed
2261         next if $#alts != 0;
2262         $_ = shift @alts;
2263
2264         if (!/^(\S+)\s*(\(\s*(>=|=|==|>|>>|<<|<=)\s*(\S+)\s*\))?\s*$/) {
2265             warn( "parse_deplist: bad dependency $_\n" );
2266             next;
2267         }
2268         my($dep, $rel, $relv) = ($1, $3, $4);
2269         $rel = ">>" if defined($rel) and $rel eq ">";
2270         $result{$dep}->{'package'} = $dep;
2271         if ($rel && $relv) {
2272             $result{$dep}->{'rel'} = $rel;
2273             $result{$dep}->{'version'} = $relv;
2274         }
2275     }
2276     return 1 if $verify;
2277     return \%result;
2278 }
2279
2280 sub build_deplist {
2281         my $list = shift;
2282         my($key, $result);
2283
2284         foreach $key (keys %$list) {
2285                 $result .= ", " if $result;
2286                 $result .= $key;
2287                 $result .= " ($list->{$key}->{'rel'} $list->{$key}->{'version'})"
2288                         if $list->{$key}->{'rel'} && $list->{$key}->{'version'};
2289         }
2290         return $result;
2291 }
2292
2293 sub call_edos_depcheck {
2294     my $packagesfile = shift;
2295     my $srcs = shift;
2296     my $key;
2297
2298     return if defined ($conf::distributions{$distribution}{noadw});
2299
2300     # We need to check all of needs-build, as any new upload could make
2301     # something in needs-build have uninstallable deps
2302     # We also check everything in bd-uninstallable, as any new upload could
2303     # make that work again
2304     my %interesting_packages;
2305     my $db = get_all_source_info();
2306     foreach $key (keys %$db) {
2307         my $pkg = $db->{$key};
2308         if (defined $pkg and isin($pkg->{'state'}, qw/Needs-Build BD-Uninstallable/)) {
2309                 $interesting_packages{$key} = undef;
2310         }
2311     }
2312
2313     #print "I would look at these sources with edos-depcheck:\n";
2314     #print join " ", keys %interesting_packages,"\n";
2315
2316     my $tmpfile_pattern = "/tmp/wanna-build-interesting-sources-$distribution.$$-";
2317     my ($tmpfile, $i);
2318     for( $i = 0;; ++$i ) {
2319             $tmpfile = $tmpfile_pattern . $i;
2320             last if ! -e $tmpfile;
2321     }
2322
2323     open SOURCES, '>', $tmpfile or die "Could not open temporary file $tmpfile\n";
2324     for my $key (keys %interesting_packages) {
2325         my $pkg = $db->{$key};
2326         print SOURCES "Package: $key\n";
2327         print SOURCES "Version: $pkg->{'version'}\n";
2328         print SOURCES "Build-Depends: $srcs->{$key}{'dep'}\n" if $srcs->{$key}{'dep'};
2329         print SOURCES "Build-Conflicts: $srcs->{$key}{'conf'}\n" if $srcs->{$key}{'conf'};
2330         print SOURCES "Architecture: all\n";
2331         print SOURCES "\n";
2332     }
2333     close SOURCES;
2334
2335     if (open(EDOS,"-|","wb-edos-builddebcheck", "-a", $arch, $packagesfile, $tmpfile))
2336     {
2337         local($/) = ""; # read in paragraph mode
2338         while( <EDOS> ) {
2339                 my( $key, $reason ) ;
2340                 s/\s*$//m;
2341                 /^Package:\s*(\S+)$/mi and $key = $1;
2342                 /^Failed-Why:(([^\n]|\n ([^\n]|\.))*)$/msi and $reason = $1;
2343                 $reason =~ s/^\s*//mg;
2344                 $reason ||= 'No reason given by edos-debcheck';
2345
2346                 if (exists $interesting_packages{$key}) {
2347                     $interesting_packages{$key} = $reason;
2348                 } else {
2349                     #print "TODO: edos reported a package we do not care about now\n" if $verbose;
2350                 }
2351         }
2352         close EDOS;
2353     } else {
2354         print "ERROR: Could not run wb-edos-builddebcheck. I am continuing, assuming\n" .
2355               "all packages have installable build-dependencies."
2356     }
2357
2358     unlink( $tmpfile );
2359
2360     for my $key (keys %interesting_packages) {
2361         my $pkg = $db->{$key};
2362         my $change =
2363             (defined $interesting_packages{$key} and $pkg->{'state'} eq 'Needs-Build') ||
2364             (not defined $interesting_packages{$key} and $pkg->{'state'} eq 'BD-Uninstallable');
2365         my $problemchange = $interesting_packages{$key} ne $pkg->{'bd_problem'};
2366         if ($change) {
2367             if (defined $interesting_packages{$key}) {
2368                     change_state( \$pkg, 'BD-Uninstallable' );
2369                     $pkg->{'bd_problem'} = $interesting_packages{$key};
2370             } else {
2371                     change_state( \$pkg, 'Needs-Build' );
2372             }
2373         }
2374         if ($problemchange) {
2375             if (defined $interesting_packages{$key}) {
2376                     $pkg->{'bd_problem'} = $interesting_packages{$key};
2377             }
2378         }
2379         if ($change) {
2380             log_ta( $pkg, "--merge-all" );
2381             print "edos-builddebchange changed state of ${key}_$pkg->{'version'} to $pkg->{'state'}\n" if $verbose;
2382         }
2383         if ($change || $problemchange) {
2384             update_source_info($pkg);
2385         }
2386     }
2387 }
2388
2389 sub usage {
2390         my $prgname;
2391         ($prgname = $0) =~ s,^.*/,,;
2392         print <<"EOF";
2393 Usage: $prgname <options...> <package_version...>
2394 Options:
2395     -v, --verbose: Verbose execution.
2396     -A arch: Architecture this operation is for.
2397     --take: Take package for building [default operation]
2398     -f, --failed: Record in database that a build failed due to
2399         deficiencies in the package (that aren't fixable without a new
2400         source version).
2401     -u, --uploaded: Record in the database that the packages build
2402         correctly and were uploaded.
2403     -n, --no-build: Record in the database that the packages aren't
2404         desired for this architecture and shouldn't appear in listings even
2405         if they're out of date.
2406     --dep-wait: Record in the database that the packages are waiting
2407         for some source dependencies to become available
2408     --binNMU num: Schedule a re-build of the package with unchanged source, but
2409          a new version number (source-version + "+b<num>")
2410     --give-back: Mark a package as ready to build that is in state Building,
2411          Built or Build-Attempted. To give back a package in state Failed, use
2412          --override. This command will actually put the package in state
2413          BD-Uninstallable, until the installability of its Build-Dependencies
2414          were verified. This happens at each call of --merge-all, usually
2415          every 15 minutes.
2416     --merge-quinn: Merge quinn-diff output into database.
2417     --merge-packages: Merge Packages files into database.
2418     --pretend-avail: Pretend that given packages are available now and give
2419         free packages waiting for them
2420     -i SRC_PKG, --info SRC_PKG: Show information for source package
2421     -l STATE, --list=STATE: List all packages in state STATE; can be
2422         combined with -U to restrict to a specific user; STATE can
2423         also be 'all'
2424     -m MESSAGE, --message=MESSAGE: Give reason why package failed or
2425         source dependency list
2426         (used with -f, --dep-wait, and --binNMU)
2427     -o, --override: Override another user's lock on a package, i.e.
2428         take it over; a notice mail will be sent to the other user
2429     -U USER, --user=USER: select user name for which listings should
2430         apply, if not given all users are listed.
2431         if -l is missing, set user name to be entered in db; usually
2432         automatically choosen
2433     --import FILE: Import database from a ASCII file FILE
2434     --export FILE: Export database to a ASCII file FILE
2435
2436 The remaining arguments (depending on operation) usually start with
2437 "name_version", the trailer is ignored. This allows to pass the names
2438 of .dsc files, for which file name completion can be used.
2439 --merge-packages and --merge-quinn take Package/quin--diff file names
2440 on the command line or read stdin. --list needs nothing more on the
2441 command line. --info takes source package names (without version).
2442 EOF
2443         exit 1;
2444 }
2445
2446 sub pkg_version_eq {
2447         my $pkg = shift;
2448         my $version = shift;
2449
2450         return 1
2451                if (defined $pkg->{'binary_nmu_version'}) and
2452                version_compare(binNMU_version($pkg->{'version'},
2453                         $pkg->{'binary_nmu_version'}),'=', $version);
2454         return version_compare( $pkg->{'version'}, "=", $version );
2455 }
2456
2457 sub table_name {
2458         return '"' . $arch . $schema_suffix . '".packages';
2459 }
2460
2461 sub user_table_name {
2462         return '"' . $arch . $schema_suffix . '".users';
2463 }
2464
2465 sub transactions_table_name {
2466         return '"' . $arch . $schema_suffix . '".transactions';
2467 }
2468
2469 sub get_readonly_source_info {
2470         my $name = shift;
2471         # SELECT FLOOR(EXTRACT('epoch' FROM age(localtimestamp, '2010-01-22  23:45')) / 86400) -- change to that?
2472         my $pkg = $dbh->selectrow_hashref('SELECT *, extract(days from date_trunc(\'days\', now() - state_change)) as state_days FROM ' .
2473                 table_name() . ' WHERE package = ? AND distribution = ?',
2474                 undef, $name, $distribution);
2475         return $pkg;
2476 }
2477
2478 sub get_source_info {
2479         my $name = shift;
2480         my $pkg = $dbh->selectrow_hashref('SELECT *, extract(days from date_trunc(\'days\', now() - state_change)) as state_days FROM ' .
2481                 table_name() . ' WHERE package = ? AND distribution = ?' .
2482                 ' FOR UPDATE',
2483                 undef, $name, $distribution);
2484         return $pkg;
2485 }
2486
2487 sub get_all_source_info {
2488         my %options = @_;
2489
2490         my $q = 'SELECT *, '.
2491                 'extract(days from date_trunc(\'days\', now() - state_change)) as state_days, '.
2492                 'date_trunc(\'seconds\', now() - state_change) as state_time'.
2493                 ' FROM ' . table_name()
2494                 . ' WHERE distribution = ? ';
2495         my @args = ($distribution);
2496         if ($options{state} && uc($options{state}) ne "ALL") {
2497                 $q .= ' AND upper(state) = ? ';
2498                 push @args, uc($options{state});
2499         }
2500
2501         if ($options{user}) {
2502                 #this basically means "this user, or no user at all":
2503                 $q .= ' AND (builder = ? OR upper(state) = ?)';
2504                 push @args, $options{user};
2505                 push @args, "NEEDS-BUILD";
2506         }
2507
2508         if ($options{category}) {
2509                 $q .= ' AND failed_category <> ? AND upper(state) = ? ';
2510                 push @args, $options{category};
2511                 push @args, "FAILED";
2512         }
2513
2514         if ($options{list_min_age} > 0) {
2515                 $q .= ' AND age(state_change) > ? ';
2516                 push @args, $options{list_min_age} . " days";
2517         }
2518
2519         if ($options{list_min_age} < 0) {
2520                 $q .= ' AND age(state_change) < ? ';
2521                 push @args, -$options{list_min_age} . " days";
2522         }
2523
2524         my $db = $dbh->selectall_hashref($q, 'package', undef, @args);
2525         return $db;
2526 }
2527
2528 sub update_source_info {
2529         my $pkg = shift;
2530
2531         my $pkg2 = get_source_info($pkg->{'package'});
2532         if (! defined $pkg2)
2533         {
2534                 add_source_info($pkg);
2535         }
2536
2537         $dbh->do('UPDATE ' . table_name() . ' SET ' .
2538                         'version = ?, ' .
2539                         'state = ?, ' .
2540                         'section = ?, ' .
2541                         'priority = ?, ' .
2542                         'installed_version = ?, ' .
2543                         'previous_state = ?, ' .
2544                         (($pkg->{'do_state_change'}) ? "state_change = now()," : "").
2545                         'notes = ?, ' .
2546                         'builder = ?, ' .
2547                         'failed = ?, ' .
2548                         'old_failed = ?, ' .
2549                         'binary_nmu_version = ?, ' .
2550                         'binary_nmu_changelog = ?, ' .
2551                         'failed_category = ?, ' .
2552                         'permbuildpri = ?, ' .
2553                         'buildpri = ?, ' .
2554                         'depends = ?, ' .
2555                         'rel = ?, ' .
2556                         'bd_problem = ? ' .
2557                         'WHERE package = ? AND distribution = ?',
2558                 undef,
2559                 $pkg->{'version'},
2560                 $pkg->{'state'},
2561                 $pkg->{'section'},
2562                 $pkg->{'priority'},
2563                 $pkg->{'installed_version'},
2564                 $pkg->{'previous_state'},
2565                 $pkg->{'notes'},
2566                 $pkg->{'builder'},
2567                 $pkg->{'failed'},
2568                 $pkg->{'old_failed'},
2569                 $pkg->{'binary_nmu_version'},
2570                 $pkg->{'binary_nmu_changelog'},
2571                 $pkg->{'failed_category'},
2572                 $pkg->{'permbuildpri'},
2573                 $pkg->{'buildpri'},
2574                 $pkg->{'depends'},
2575                 $pkg->{'rel'},
2576                 $pkg->{'bd_problem'},
2577                 $pkg->{'package'},
2578                 $distribution) or die $dbh->errstr;
2579 }
2580
2581 sub add_source_info {
2582         my $pkg = shift;
2583         $dbh->do('INSERT INTO ' . table_name() .
2584                         ' (package, distribution) values (?, ?)',
2585                 undef, $pkg->{'package'}, $distribution) or die $dbh->errstr;
2586 }
2587
2588 sub del_source_info {
2589         my $name = shift;
2590         $dbh->do('DELETE FROM ' . table_name() .
2591                         ' WHERE package = ? AND distribution = ?',
2592                 undef, $name, $distribution) or die $dbh->errstr;
2593 }
2594
2595 sub get_user_info {
2596         my $name = shift;
2597         my $user = $dbh->selectrow_hashref('SELECT * FROM ' .
2598                 user_table_name() . ' WHERE username = ? AND distribution = ?',
2599                 undef, $name, $distribution);
2600         return $user;
2601 }
2602
2603 sub update_user_info {
2604         my $user = shift;
2605         $dbh->do('UPDATE ' . user_table_name() .
2606                         ' SET last_seen = now() WHERE username = ?' .
2607                         ' AND distribution = ?',
2608                 undef, $user, $distribution)
2609                 or die $dbh->errstr;
2610 }
2611
2612
2613 sub add_user_info {
2614         my $user = shift;
2615         $dbh->do('INSERT INTO ' . user_table_name() .
2616                         ' (username, distribution, last_seen)' .
2617                         ' values (?, ?, now())',
2618                 undef, $user, $distribution)
2619                 or die $dbh->errstr;
2620 }
2621
2622 sub lock_table()
2623 {
2624         $dbh->do('LOCK TABLE ' . table_name() .
2625                 ' IN EXCLUSIVE MODE', undef) or die $dbh->errstr;
2626 }
2627