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