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>.
11 use Getopt::Long qw(:config no_ignore_case);
16 debbugs-loadsql -- load debbugs sql database
20 debbugs-loadsql [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
48 Add source maintainers
56 Only load changed bugs
60 Show progress bar (requires Term::ProgressBar)
64 Postgreql service to use; defaults to debbugs
66 =item B<--sysconfdir,-c>
68 System configuration directory to use; if not set, defaults to the
69 postgresql default. [Operates by setting PGSYSCONFDIR]
73 Debbugs spool directory; defaults to the value configured in the
74 debbugs configuration file.
78 Output more information about what is happening. Probably not useful
79 if you also set --progress.
87 Display brief useage information.
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);
106 use Debbugs::DB::Load qw(load_bug handle_load_bug_queue :load_package :load_suite);
110 use IO::Uncompress::AnyUncompress;
119 service => $config{debbugs_db},
123 Getopt::Long::Configure('pass_through');
124 GetOptions(\%options,
129 'spool_dir|spool-dir=s',
132 'debug|d+','help|h|?','man|m');
133 Getopt::Long::Configure('default');
135 pod2usage() if $options{help};
136 pod2usage({verbose=>2}) if $options{man};
138 $DEBUG = $options{debug};
141 ('bugs' => {function => \&add_bugs,
143 'versions' => {function => \&add_versions,
145 'debinfo' => {function => \&add_debinfo,
146 arguments => {'0|null' => 0},
148 'maintainers' => {function => \&add_maintainers,
150 'configuration' => {function => \&add_configuration,
152 'suites' => {function => \&add_suite,
153 arguments => {'ftpdists=s' => 1,
156 'logs' => {function => \&add_logs,
158 'packages' => {function => \&add_packages,
159 arguments => {'ftpdists=s' => 1,
162 'help' => {function => sub {pod2usage({verbose => 2});}}
166 $options{verbose} = $options{verbose} - $options{quiet};
168 if ($options{progress}) {
169 eval "use Term::ProgressBar";
170 push @USAGE_ERRORS, "You asked for a progress bar, but Term::ProgressBar isn't installed" if $@;
174 pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
176 if (exists $options{sysconfdir}) {
177 if (not defined $options{sysconfdir} or not length $options{sysconfdir}) {
178 delete $ENV{PGSYSCONFDIR};
180 $ENV{PGSYSCONFDIR} = $options{sysconfdir};
184 if (exists $options{spool_dir} and defined $options{spool_dir}) {
185 $config{spool_dir} = $options{spool_dir};
189 if ($options{progress}) {
190 $prog_bar = eval "Term::ProgressBar->new({count => 1,ETA=>q(linear)})";
191 warn "Unable to initialize progress bar: $@" if not $prog_bar;
195 my ($subcommand) = shift @ARGV;
196 if (not defined $subcommand) {
197 $subcommand = 'help';
198 print STDERR "You must provide a subcommand; displaying usage.\n";
200 } elsif (not exists $subcommands{$subcommand}) {
201 print STDERR "$subcommand is not a valid subcommand; displaying usage.\n";
206 handle_subcommand_arguments(\@ARGV,$subcommands{$subcommand}{arguments});
207 $subcommands{$subcommand}{function}->(\%options,$opts,$prog_bar,\%config,\@ARGV);
210 my ($options,$opts,$p,$config,$argv) = @_;
211 chdir($config->{spool_dir}) or
212 die "chdir $config->{spool_dir} failed: $!";
214 my $verbose = $options->{debug};
216 my $initialdir = "db-h";
218 if (defined $argv->[0] and $argv->[0] eq "archive") {
219 $initialdir = "archive";
221 my $s = db_connect($options);
225 my $start_time = time;
230 walk_bugs([(@{$argv}?@{$argv} : $initialdir)],
236 my $stat = stat(getbugcomponent($bug,'summary',$initialdir));
237 if (not defined $stat) {
238 print STDERR "Unable to stat $bug $!\n";
241 if ($options{quick}) {
242 my $rs = $s->resultset('Bug')->search({bug=>$bug})->single();
243 next if defined $rs and $stat->mtime < $rs->last_modified()->epoch();
245 my $data = read_bug(bug => $bug,
246 location => $initialdir);
249 data => split_status_fields($data),
251 severities => \%severities,
256 print STDERR Dumper($data) if $DEBUG;
257 die "failure while trying to load bug $bug\n$@";
261 handle_load_bug_queue(db => $s,
266 my ($options,$opts,$p,$config,$argv) = @_;
268 my $s = db_connect($options);
270 my @files = @{$argv};
271 $p->target(scalar @files) if $p;
272 for my $file (@files) {
273 my $fh = IO::File->new($file,'r') or
274 die "Unable to open $file for reading: $!";
279 next unless length $_;
280 if (/(\w[-+0-9a-z.]+) \(([^\(\) \t]+)\)/) {
281 push @versions, [$1,$2];
286 for my $i (reverse 0..($#versions)) {
288 if (not defined $src_pkgs{$versions[$i][0]}) {
289 $src_pkgs{$versions[$i][0]} =
290 $s->resultset('SrcPkg')->find_or_create({pkg => $versions[$i][0]});
292 $sp = $src_pkgs{$versions[$i][0]};
293 # There's probably something wrong if the source package
294 # doesn't exist, but we'll skip it for now
295 next unless defined $sp;
296 my $sv = $s->resultset('SrcVer')->find({src_pkg=>$sp->id(),
297 ver => $versions[$i][1],
299 if (defined $ancestor_sv and defined $sv and not defined $sv->based_on()) {
300 $sv->update({based_on => $ancestor_sv->id()})
310 my ($options,$opts,$p,$config,$argv) = @_;
312 my @files = @{$argv};
323 return unless @files;
324 my $s = db_connect($options);
326 $p->target(scalar @files) if $p;
327 for my $file (@files) {
328 my $fh = IO::File->new($file,'r') or
329 die "Unable to open $file for reading: $!";
330 my $f_stat = stat($file);
333 next unless length $_;
334 my ($binname, $binver, $binarch, $srcname, $srcver) = split;
335 # if $srcver is not defined, this is probably a broken
336 # .debinfo file [they were causing #686106, see commit
337 # 49c85ab8 in dak.] Basically, $binarch didn't get put into
338 # the file, so we'll fudge it from the filename.
339 if (not defined $srcver) {
340 ($srcname,$srcver) = ($binarch,$srcname);
341 ($binarch) = $file =~ /_([^\.]+)\.debinfo/;
343 my $sp = $s->resultset('SrcPkg')->find_or_create({pkg => $srcname});
344 # update the creation date if the data we have is earlier
345 my $ct_date = DateTime->from_epoch(epoch => $f_stat->ctime);
346 if ($ct_date < $sp->creation) {
347 $sp->creation($ct_date);
348 $sp->last_modified(DateTime->now);
351 my $sv = $s->resultset('SrcVer')->find_or_create({src_pkg =>$sp->id(),
353 if (not defined $sv->upload_date() or $ct_date < $sv->upload_date()) {
354 $sv->upload_date($ct_date);
358 if (defined $arch{$binarch}) {
359 $arch = $arch{$binarch};
361 $arch = $s->resultset('Arch')->find_or_create({arch => $binarch});
362 $arch{$binarch} = $arch;
364 my $bp = $s->resultset('BinPkg')->find_or_create({pkg => $binname});
365 $s->resultset('BinVer')->find_or_create({bin_pkg => $bp->id(),
366 src_ver => $sv->id(),
376 sub add_maintainers {
377 my ($options,$opts,$p,$config,$argv) = @_;
379 my $s = db_connect($options);
380 my $maintainers = getsourcemaintainers();
381 $p->target(scalar keys %{$maintainers}) if $p;
382 for my $pkg (keys %{$maintainers}) {
383 my $maint = $maintainers->{$pkg};
384 # see if a maintainer already exists; if so, we don't do
386 my $maint_r = $s->resultset('Maintainer')->
387 find({name => $maint});
388 if (not defined $maint_r) {
389 # get e-mail address of maintainer
390 my $addr = getparsedaddrs($maint);
391 my $e_mail = $addr->address();
392 my $full_name = $addr->phrase();
393 $full_name =~ s/^\"|\"$//g;
394 $full_name =~ s/^\s+|\s+$//g;
396 my $correspondent = $s->resultset('Correspondent')->
397 find_or_create({addr => $e_mail});
398 if (length $full_name) {
399 my $c_full_name = $correspondent->find_or_create_related('correspondent_full_names',
400 {full_name => $full_name}) if length $full_name;
401 $c_full_name->update({last_seen => 'NOW()'});
404 $s->resultset('Maintainer')->
405 find_or_create({name => $maint,
406 correspondent => $correspondent,
409 # add the maintainer to the source package for packages with
412 $s->resultset('SrcPkg')->search({pkg => $pkg})->
413 search_related_rs('src_vers',{ maintainer => undef})->
414 update_all({maintainer => $maint_r->id()});
421 sub add_configuration {
422 my ($options,$opts,$p,$config,$argv) = @_;
424 my $s = db_connect($options);
433 for my $sev_name (@{$config{severities}}) {
434 # add all severitites
435 my $sev = $s->resultset('Severity')->find_or_create({severity => $sev_name});
436 # mark strong severities
437 if (grep {$_ eq $sev_name} @{$config{strong_severities}}) {
443 $sev_names{$sev_name} = 1;
445 # mark obsolete severities
446 for my $sev ($s->resultset('Severity')->find()) {
447 next if exists $sev_names{$sev->severity()};
454 my ($options,$opts,$p,$config,$argv) = @_;
457 my $s = db_connect($options);
458 my $dist_dir = IO::Dir->new($opts->{ftpdists});
460 grep { $_ !~ /^\./ and
461 -d $opts->{ftpdists}.'/'.$_ and
462 not -l $opts->{ftpdists}.'/'.$_
464 while (my $dist = shift @dist_names) {
465 my $dist_dir = $opts->{ftpdists}.'/'.$dist;
466 my ($dist_info,$package_files) =
467 read_release_file($dist_dir.'/Release');
468 load_suite($s,$dist_info);
473 my ($options,$opts,$p,$config,$argv) = @_;
475 chdir($config->{spool_dir}) or
476 die "chdir $config->{spool_dir} failed: $!";
478 my $verbose = $options->{debug};
480 my $initialdir = "db-h";
482 if (defined $argv->[0] and $argv->[0] eq "archive") {
483 $initialdir = "archive";
485 my $s = db_connect($options);
489 my $start_time = time;
491 walk_bugs([(@{$argv}?@{$argv} : $initialdir)],
498 load_bug_log(db => $s,
502 die "failure while trying to load bug log $bug\n$@";
508 my ($options,$opts,$p,$config,$argv) = @_;
510 my $s = db_connect($options);
512 my $dist_dir = IO::Dir->new($opts->{ftpdists});
514 grep { $_ !~ /^\./ and
515 -d $opts->{ftpdists}.'/'.$_ and
516 not -l $opts->{ftpdists}.'/'.$_
520 while (my $dist = shift @dist_names) {
521 my $dist_dir = $opts->{ftpdists}.'/'.$dist;
523 my $rfh = IO::Uncompress::AnyUncompress->new($dist_dir.'/Release');
529 if (s/^(\S+):\s*//) {
530 if ($1 eq 'SHA1'or $1 eq 'SHA256') {
537 my ($sha,$size,$file) = split /\s+/,$_;
538 next unless $file =~ /(?:Packages|Sources)(?:\.gz|\.xz)$/;
539 next unless $file =~ m{^([^/]+)/([^/]+)/([^/]+)$};
540 my ($component,$arch,$package_source) = ($1,$2,$3);
541 $arch =~ s/binary-//;
542 next if exists $p_f{$component}{$arch};
543 $p_f{$component}{$arch} = $dist_dir.'/'.$file;
546 $s_p{$dist_info{Suite}} = \%p_f;
547 $s_info{$dist_info{Suite}} = \%s_info;
549 # parse packages files
550 for my $suite (keys %s_p) {
551 for my $component (keys %{$s_p{$suite}}) {
552 for my $arch (keys %{$s_p{$suite}{$component}}) {
553 my $pfh = IO::Uncompress::AnyUncompress->new($s_p{$suite}{$component}{$arch}) or
554 die "Unable to open $s_p{$suite}{$component}{$arch} for reading: $!";
559 load_package($s,$suite,$component,$arch,\%pkg);
563 if (my ($key, $value) = m/^(\S+): (.*)/) {
571 $pkg{$lastkey} .= "\n" . $_;
575 load_package($s,$suite,$component,$arch,\%pkg);
584 sub handle_subcommand_arguments {
585 my ($argv,$args) = @_;
587 Getopt::Long::GetOptionsFromArray($argv,
592 for my $arg (keys %{$args}) {
593 next unless $args->{$arg};
594 my $r_arg = $arg; # real argument name
595 $r_arg =~ s/[=\|].+//g;
596 if (not defined $subopt->{$r_arg}) {
597 push @usage_errors, "You must give a $r_arg option";
600 pod2usage(join("\n",@usage_errors)) if @usage_errors;
605 my ($subcommand,$config,$options) = @_;
606 if (not lockpid($config->{spool_dir}.'/lock/debbugs-loadsql-$subcommand')) {
607 if ($options->{quick}) {
608 # If this is a quick run, just exit
609 print STDERR "Another debbugs-loadsql is running; stopping\n" if $options->{verbose};
612 print STDERR "Another debbugs-loadsql is running; stopping\n";
619 # connect to the database; figure out how to handle errors
621 my $s = Debbugs::DB->connect($options->{service}) or
622 die "Unable to connect to database: ";
626 my ($dirs,$p,$what,$verbose,$sub) = @_;
628 my $tot_dirs = @dirs;
630 my $avg_subfiles = 0;
631 my $completed_files = 0;
632 while (my $dir = shift @dirs) {
633 printf "Doing dir %s ...\n", $dir if $verbose;
635 opendir(DIR, "$dir/.") or die "opendir $dir: $!";
636 my @subdirs = readdir(DIR);
639 my @list = map { m/^(\d+)\.$what$/?($1):() } @subdirs;
641 push @dirs, map { m/^(\d+)$/ && -d "$dir/$1"?("$dir/$1"):() } @subdirs;
643 if ($avg_subfiles == 0) {
644 $avg_subfiles = @list;
647 $p->target($avg_subfiles*($tot_dirs-$done_dirs)+$completed_files+@list) if $p;
648 $avg_subfiles = ($avg_subfiles * $done_dirs + @list) / ($done_dirs+1);
651 for my $bug (@list) {
653 $p->update($completed_files) if $p;
654 print "Up to $completed_files bugs...\n" if ($completed_files % 100 == 0 && $verbose);