bin/debbugs-loadsql

   1 #! /usr/bin/perl
   2 # debbugs-loadsql is part of debbugs, and is released
   3 # under the terms of the GPL version 2, or any later version, at your
   4 # option. See the file README and COPYING for more information.
   5 # Copyright 2012 by Don Armstrong <don@donarmstrong.com>.
   6
   7
   8 use warnings;
   9 use strict;
  10
  11 use Getopt::Long qw(:config no_ignore_case);
  12 use Pod::Usage;
  13
  14 =head1 NAME
  15
  16 debbugs-loadsql -- load debbugs sql database
  17
  18 =head1 SYNOPSIS
  19
  20 debbugs-loadsql [options]
  21
  22  Options:
  23   --quick, -q only load changed bugs
  24   --progress Show progress bar
  25   --service, -s service name
  26   --sysconfdir, -c postgresql service config dir
  27   --spool-dir debbugs spool directory
  28   --debug, -d debugging level (Default 0)
  29   --help, -h display this help
  30   --man, -m display manual
  31
  32 =head1 SUBCOMMANDS
  33
  34 =head2 help
  35
  36 Display this manual
  37
  38 =head2 bugs
  39
  40 Add bugs
  41
  42 =head2 versions
  43
  44 Add versions
  45
  46 =head2 maintainers
  47
  48 Add source maintainers
  49
  50 =head1 OPTIONS
  51
  52 =over
  53
  54 =item B<--quick, -q>
  55
  56 Only load changed bugs
  57
  58 =item B<--progress>
  59
  60 Show progress bar (requires Term::ProgressBar)
  61
  62 =item B<--service,-s>
  63
  64 Postgreql service to use; defaults to debbugs
  65
  66 =item B<--sysconfdir,-c>
  67
  68 System configuration directory to use; if not set, defaults to the
  69 postgresql default. [Operates by setting PGSYSCONFDIR]
  70
  71 =item B<--spool-dir>
  72
  73 Debbugs spool directory; defaults to the value configured in the
  74 debbugs configuration file.
  75
  76 =item B<--verbose>
  77
  78 Output more information about what is happening. Probably not useful
  79 if you also set --progress.
  80
  81 =item B<--debug, -d>
  82
  83 Debug verbosity.
  84
  85 =item B<--help, -h>
  86
  87 Display brief useage information.
  88
  89 =item B<--man, -m>
  90
  91 Display this manual.
  92
  93 =back
  94
  95
  96 =cut
  97
  98
  99 use vars qw($DEBUG);
 100
 101 use Debbugs::Common qw(checkpid lockpid get_hashname getparsedaddrs getbugcomponent make_list getsourcemaintainers);
 102 use Debbugs::Config qw(:config);
 103 use Debbugs::Status qw(read_bug split_status_fields);
 104 use Debbugs::Log;
 105 use Debbugs::DB;
 106 use Debbugs::DB::Load qw(load_bug handle_load_bug_queue);
 107 use DateTime;
 108 use File::stat;
 109
 110
 111 my %options =
 112     (debug           => 0,
 113      help            => 0,
 114      man             => 0,
 115      verbose         => 0,
 116      quiet           => 0,
 117      quick           => 0,
 118      service         => $config{debbugs_db},
 119      progress        => 0,
 120     );
 121
 122 Getopt::Long::Configure('pass_through');
 123 GetOptions(\%options,
 124            'quick|q',
 125            'service|s=s',
 126            'sysconfdir|c=s',
 127            'progress!',
 128            'spool_dir|spool-dir=s',
 129            'verbose|v+',
 130            'quiet+',
 131            'debug|d+','help|h|?','man|m');
 132 Getopt::Long::Configure('default');
 133
 134 pod2usage() if $options{help};
 135 pod2usage({verbose=>2}) if $options{man};
 136
 137 $DEBUG = $options{debug};
 138
 139 my %subcommands =
 140     ('bugs' => {function => \&add_bugs,
 141                },
 142      'versions' => {function => \&add_versions,
 143                    },
 144      'debinfo' => {function => \&add_debinfo,
 145                    arguments => {'0|null' => 0},
 146                   },
 147      'maintainers' => {function => \&add_maintainers,
 148                       },
 149      'configuration' => {function => \&add_configuration,
 150                         },
 151      'suites' => {function => \&add_suites,
 152                  },
 153      'logs' => {function => \&add_logs,
 154                },
 155      'help' => {function => sub {pod2usage({verbose => 2});}}
 156     );
 157
 158 my @USAGE_ERRORS;
 159 $options{verbose} = $options{verbose} - $options{quiet};
 160
 161 if ($options{progress}) {
 162     eval "use Term::ProgressBar";
 163     push @USAGE_ERRORS, "You asked for a progress bar, but Term::ProgressBar isn't installed" if $@;
 164 }
 165
 166
 167 pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
 168
 169 if (exists $options{sysconfdir}) {
 170     if (not defined $options{sysconfdir} or not length $options{sysconfdir}) {
 171         delete $ENV{PGSYSCONFDIR};
 172     } else {
 173         $ENV{PGSYSCONFDIR} = $options{sysconfdir};
 174     }
 175 }
 176
 177 if (exists $options{spool_dir} and defined $options{spool_dir}) {
 178     $config{spool_dir} = $options{spool_dir};
 179 }
 180
 181 my $prog_bar;
 182 if ($options{progress}) {
 183     $prog_bar = eval "Term::ProgressBar->new({count => 1,ETA=>q(linear)})";
 184     warn "Unable to initialize progress bar: $@" if not $prog_bar;
 185 }
 186
 187
 188 my ($subcommand) = shift @ARGV;
 189 if (not defined $subcommand) {
 190     $subcommand = 'help';
 191     print STDERR "You must provide a subcommand; displaying usage.\n";
 192     pod2usage();
 193 } elsif (not exists $subcommands{$subcommand}) {
 194     print STDERR "$subcommand is not a valid subcommand; displaying usage.\n";
 195     pod2usage();
 196 }
 197
 198 my $opts =
 199     handle_subcommand_arguments(\@ARGV,$subcommands{$subcommand}{arguments});
 200 $subcommands{$subcommand}{function}->(\%options,$opts,$prog_bar,\%config,\@ARGV);
 201
 202 sub add_bugs {
 203     my ($options,$opts,$p,$config,$argv) = @_;
 204     chdir($config->{spool_dir}) or
 205         die "chdir $config->{spool_dir} failed: $!";
 206
 207     my $verbose = $options->{debug};
 208
 209     my $initialdir = "db-h";
 210
 211     if (defined $argv->[0] and $argv->[0] eq "archive") {
 212         $initialdir = "archive";
 213     }
 214     my $s = db_connect($options);
 215
 216
 217     my $time = 0;
 218     my $start_time = time;
 219     my %tags;
 220     my %severities;
 221     my %queue;
 222
 223     walk_bugs([(@{$argv}?@{$argv} : $initialdir)],
 224               $p,
 225               'summary',
 226               $verbose,
 227               sub {
 228                   my $bug = shift;
 229                   my $stat = stat(getbugcomponent($bug,'summary',$initialdir));
 230                   if (not defined $stat) {
 231                       print STDERR "Unable to stat $bug $!\n";
 232                       next;
 233                   }
 234                   if ($options{quick}) {
 235                       my $rs = $s->resultset('Bug')->search({bug=>$bug})->single();
 236                       next if defined $rs and $stat->mtime < $rs->last_modified()->epoch();
 237                   }
 238                   my $data = read_bug(bug => $bug,
 239                                       location => $initialdir);
 240                   eval {
 241                       load_bug(db => $s,
 242                                data => split_status_fields($data),
 243                                tags => \%tags,
 244                                severities => \%severities,
 245                                queue => \%queue);
 246                   };
 247                   if ($@) {
 248                       use Data::Dumper;
 249                       print STDERR Dumper($data) if $DEBUG;
 250                       die "failure while trying to load bug $bug\n$@";
 251                   }
 252               }
 253              );
 254     handle_load_bug_queue(db => $s,
 255                           queue => \%queue);
 256 }
 257
 258 sub add_versions {
 259     my ($options,$opts,$p,$config,$argv) = @_;
 260
 261     my $s = db_connect($options);
 262
 263     my @files = @{$argv};
 264     $p->target(scalar @files) if $p;
 265     for my $file (@files) {
 266         my $fh = IO::File->new($file,'r') or
 267             die "Unable to open $file for reading: $!";
 268         my @versions;
 269         my %src_pkgs;
 270         while (<$fh>) {
 271             chomp;
 272             next unless length $_;
 273             if (/(\w[-+0-9a-z.]+) \(([^\(\) \t]+)\)/) {
 274                 push @versions, [$1,$2];
 275             }
 276         }
 277         close($fh);
 278         my $ancestor_sv;
 279         for my $i (reverse 0..($#versions)) {
 280             my $sp;
 281             if (not defined $src_pkgs{$versions[$i][0]}) {
 282                 $src_pkgs{$versions[$i][0]} =
 283                     $s->resultset('SrcPkg')->find_or_create({pkg => $versions[$i][0]});
 284             }
 285             $sp = $src_pkgs{$versions[$i][0]};
 286             # There's probably something wrong if the source package
 287             # doesn't exist, but we'll skip it for now
 288             next unless defined $sp;
 289             my $sv = $s->resultset('SrcVer')->find({src_pkg=>$sp->id(),
 290                                                     ver => $versions[$i][1],
 291                                                    });
 292             if (defined $ancestor_sv and defined $sv and not defined $sv->based_on()) {
 293                 $sv->update({based_on => $ancestor_sv->id()})
 294             }
 295             $ancestor_sv = $sv;
 296         }
 297         $p->update() if $p;
 298     }
 299     $p->remove() if $p;
 300 }
 301
 302 sub add_debinfo {
 303     my ($options,$opts,$p,$config,$argv) = @_;
 304
 305     my @files = @{$argv};
 306     if (not @files) {
 307        {
 308            if ($opts->{0}) {
 309                local $/ = "\0";
 310            }
 311            while (<STDIN>) {
 312                push @files, $_;
 313            }
 314        }
 315     }
 316     return unless @files;
 317     my $s = db_connect($options);
 318     my %arch;
 319     $p->target(scalar @files) if $p;
 320     for my $file (@files) {
 321         my $fh = IO::File->new($file,'r') or
 322             die "Unable to open $file for reading: $!";
 323         my $f_stat = stat($file);
 324         while (<$fh>) {
 325             chomp;
 326             next unless length $_;
 327             my ($binname, $binver, $binarch, $srcname, $srcver) = split;
 328             # if $srcver is not defined, this is probably a broken
 329             # .debinfo file [they were causing #686106, see commit
 330             # 49c85ab8 in dak.] Basically, $binarch didn't get put into
 331             # the file, so we'll fudge it from the filename.
 332             if (not defined $srcver) {
 333                 ($srcname,$srcver) = ($binarch,$srcname);
 334                 ($binarch) = $file =~ /_([^\.]+)\.debinfo/;
 335             }
 336             my $sp = $s->resultset('SrcPkg')->find_or_create({pkg => $srcname});
 337             # update the creation date if the data we have is earlier
 338             my $ct_date = DateTime->from_epoch(epoch => $f_stat->ctime);
 339             if ($ct_date < $sp->creation) {
 340                 $sp->creation($ct_date);
 341                 $sp->last_modified(DateTime->now);
 342                 $sp->update;
 343             }
 344             my $sv = $s->resultset('SrcVer')->find_or_create({src_pkg =>$sp->id(),
 345                                                               ver => $srcver});
 346             if (not defined $sv->upload_date() or $ct_date < $sv->upload_date()) {
 347                 $sv->upload_date($ct_date);
 348                 $sv->update;
 349             }
 350             my $arch;
 351             if (defined $arch{$binarch}) {
 352                 $arch = $arch{$binarch};
 353             } else {
 354                 $arch = $s->resultset('Arch')->find_or_create({arch => $binarch});
 355                 $arch{$binarch} = $arch;
 356             }
 357             my $bp = $s->resultset('BinPkg')->find_or_create({pkg => $binname});
 358             $s->resultset('BinVer')->find_or_create({bin_pkg => $bp->id(),
 359                                                      src_ver => $sv->id(),
 360                                                      arch    => $arch->id(),
 361                                                      ver        => $binver,
 362                                                     });
 363         }
 364         $p->update() if $p;
 365     }
 366     $p->remove() if $p;
 367 }
 368
 369 sub add_maintainers {
 370     my ($options,$opts,$p,$config,$argv) = @_;
 371
 372     my $s = db_connect($options);
 373     my $maintainers = getsourcemaintainers();
 374     $p->target(scalar keys %{$maintainers}) if $p;
 375     for my $pkg (keys %{$maintainers}) {
 376         my $maint = $maintainers->{$pkg};
 377         # see if a maintainer already exists; if so, we don't do
 378         # anything here
 379         my $maint_r = $s->resultset('Maintainer')->
 380             find({name => $maint});
 381         if (not defined $maint_r) {
 382             # get e-mail address of maintainer
 383             my $addr = getparsedaddrs($maint);
 384             my $e_mail = $addr->address();
 385             my $full_name = $addr->phrase();
 386             $full_name =~ s/^\"|\"$//g;
 387             $full_name =~ s/^\s+|\s+$//g;
 388             # find correspondent
 389             my $correspondent = $s->resultset('Correspondent')->
 390                 find_or_create({addr => $e_mail});
 391             if (length $full_name) {
 392                 my $c_full_name = $correspondent->find_or_create_related('correspondent_full_names',
 393                                                                         {full_name => $full_name}) if length $full_name;
 394                 $c_full_name->update({last_seen => 'NOW()'});
 395             }
 396             $maint_r =
 397                 $s->resultset('Maintainer')->
 398                 find_or_create({name => $maint,
 399                                 correspondent => $correspondent,
 400                                });
 401         }
 402         # add the maintainer to the source package for packages with
 403         # no maintainer
 404         $s->txn_do(sub {
 405                       $s->resultset('SrcPkg')->search({pkg => $pkg})->
 406                           search_related_rs('src_vers',{ maintainer => undef})->
 407                           update_all({maintainer => $maint_r->id()});
 408                   });
 409         $p->update() if $p;
 410     }
 411     $p->remove() if $p;
 412 }
 413
 414 sub add_configuration {
 415     my ($options,$opts,$p,$config,$argv) = @_;
 416
 417     my $s = db_connect($options);
 418
 419     # tags
 420     # add all tags
 421     # mark obsolete tags
 422
 423     # severities
 424     my %sev_names;
 425     my $order = 0;
 426     for my $sev_name (@{$config{severities}}) {
 427         # add all severitites
 428         my $sev = $s->resultset('Severity')->find_or_create({severity => $sev_name});
 429         # mark strong severities
 430         if (grep {$_ eq $sev_name} @{$config{strong_severities}}) {
 431             $sev->strong(1);
 432         }
 433         $sev->order($order);
 434         $sev->update();
 435         $order++;
 436         $sev_names{$sev_name} = 1;
 437     }
 438     # mark obsolete severities
 439     for my $sev ($s->resultset('Severity')->find()) {
 440         next if exists $sev_names{$sev->severity()};
 441         $sev->obsolete(1);
 442         $sev->update();
 443     }
 444 }
 445
 446 sub add_suite {
 447     my ($options,$opts,$p,$config,$argv) = @_;
 448     # suites
 449     die "add_suite is currently not implemented; modify suites manually using SQL."
 450 }
 451
 452 sub add_logs {
 453     my ($options,$opts,$p,$config,$argv) = @_;
 454
 455     chdir($config->{spool_dir}) or
 456         die "chdir $config->{spool_dir} failed: $!";
 457
 458     my $verbose = $options->{debug};
 459
 460     my $initialdir = "db-h";
 461
 462     if (defined $argv->[0] and $argv->[0] eq "archive") {
 463         $initialdir = "archive";
 464     }
 465     my $s = db_connect($options);
 466
 467
 468     my $time = 0;
 469     my $start_time = time;
 470
 471     walk_bugs([(@{$argv}?@{$argv} : $initialdir)],
 472               $p,
 473               'log',
 474               $verbose,
 475               sub {
 476                   my $bug = shift;
 477                   eval {
 478                       load_bug_log(db => $s,
 479                                    bug => $bug);
 480                   };
 481                   if ($@) {
 482                       die "failure while trying to load bug log $bug\n$@";
 483                   }
 484               });
 485 }
 486
 487 sub add_packages {
 488
 489 }
 490
 491 sub handle_subcommand_arguments {
 492     my ($argv,$args) = @_;
 493     my $subopt = {};
 494     Getopt::Long::GetOptionsFromArray($argv,
 495                               $subopt,
 496                               keys %{$args},
 497                              );
 498     my @usage_errors;
 499     for my $arg  (keys %{$args}) {
 500         next unless $args->{$arg};
 501         my $r_arg = $arg; # real argument name
 502         $r_arg =~ s/[=\|].+//g;
 503         if (not defined $subopt->{$r_arg}) {
 504             push @usage_errors, "You must give a $r_arg option";
 505         }
 506     }
 507     pod2usage(join("\n",@usage_errors)) if @usage_errors;
 508     return $subopt;
 509 }
 510
 511 sub get_lock{
 512     my ($subcommand,$config,$options) = @_;
 513     if (not lockpid($config->{spool_dir}.'/lock/debbugs-loadsql-$subcommand')) {
 514         if ($options->{quick}) {
 515             # If this is a quick run, just exit
 516             print STDERR "Another debbugs-loadsql is running; stopping\n" if $options->{verbose};
 517             exit 0;
 518         }
 519         print STDERR "Another debbugs-loadsql is running; stopping\n";
 520         exit 1;
 521     }
 522 }
 523
 524 sub db_connect {
 525     my ($options) = @_;
 526     # connect to the database; figure out how to handle errors
 527     # properly here.
 528     my $s = Debbugs::DB->connect('dbi:Pg:service='.$options->{service}) or
 529         die "Unable to connect to database: ";
 530 }
 531
 532 sub walk_bugs {
 533     my ($dirs,$p,$what,$verbose,$sub) = @_;
 534     my @dirs = @{$dirs};
 535     my $tot_dirs = @dirs;
 536     my $done_dirs = 0;
 537     my $avg_subfiles = 0;
 538     my $completed_files = 0;
 539     while (my $dir = shift @dirs) {
 540         printf "Doing dir %s ...\n", $dir if $verbose;
 541
 542         opendir(DIR, "$dir/.") or die "opendir $dir: $!";
 543         my @subdirs = readdir(DIR);
 544         closedir(DIR);
 545
 546         my @list = map { m/^(\d+)\.$what$/?($1):() } @subdirs;
 547         $tot_dirs -= @dirs;
 548         push @dirs, map { m/^(\d+)$/ && -d "$dir/$1"?("$dir/$1"):() } @subdirs;
 549         $tot_dirs += @dirs;
 550         if ($avg_subfiles == 0) {
 551             $avg_subfiles = @list;
 552         }
 553
 554         $p->target($avg_subfiles*($tot_dirs-$done_dirs)+$completed_files+@list) if $p;
 555         $avg_subfiles = ($avg_subfiles * $done_dirs + @list) / ($done_dirs+1);
 556         $done_dirs += 1;
 557
 558         for my $bug (@list) {
 559             $completed_files++;
 560             $p->update($completed_files) if $p;
 561             print "Up to $completed_files bugs...\n" if ($completed_files % 100 == 0 && $verbose);
 562             $sub->($bug);
 563         }
 564     }
 565     $p->remove() if $p;
 566 }
 567
 568
 569
 570 __END__