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),
103 use Debbugs::Config qw(:config);
104 use Debbugs::Status qw(read_bug split_status_fields);
107 use Debbugs::DB::Load qw(load_bug handle_load_bug_queue :load_package :load_suite);
114 use IO::Uncompress::AnyUncompress;
115 use Encode qw(decode_utf8);
124 service => $config{debbugs_db},
128 Getopt::Long::Configure('pass_through');
129 GetOptions(\%options,
134 'spool_dir|spool-dir=s',
137 'debug|d+','help|h|?','man|m');
138 Getopt::Long::Configure('default');
140 pod2usage() if $options{help};
141 pod2usage({verbose=>2}) if $options{man};
143 $DEBUG = $options{debug};
146 ('bugs' => {function => \&add_bugs,
147 arguments => {'preload' => 0},
149 'versions' => {function => \&add_versions,
151 'debinfo' => {function => \&add_debinfo,
152 arguments => {'0|null' => 0},
154 'maintainers' => {function => \&add_maintainers,
156 'configuration' => {function => \&add_configuration,
158 'suites' => {function => \&add_suite,
159 arguments => {'ftpdists=s' => 1,
162 'logs' => {function => \&add_logs,
164 'packages' => {function => \&add_packages,
165 arguments => {'ftpdists=s' => 1,
169 'help' => {function => sub {pod2usage({verbose => 2});}}
173 $options{verbose} = $options{verbose} - $options{quiet};
175 if ($options{progress}) {
176 eval "use Term::ProgressBar";
177 push @USAGE_ERRORS, "You asked for a progress bar, but Term::ProgressBar isn't installed" if $@;
181 pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;
183 if (exists $options{sysconfdir}) {
184 if (not defined $options{sysconfdir} or not length $options{sysconfdir}) {
185 delete $ENV{PGSYSCONFDIR};
187 $ENV{PGSYSCONFDIR} = $options{sysconfdir};
191 if (exists $options{spool_dir} and defined $options{spool_dir}) {
192 $config{spool_dir} = $options{spool_dir};
196 if ($options{progress}) {
197 $prog_bar = eval "Term::ProgressBar->new({count => 1,ETA=>q(linear)})";
198 warn "Unable to initialize progress bar: $@" if not $prog_bar;
202 my ($subcommand) = shift @ARGV;
203 if (not defined $subcommand) {
204 $subcommand = 'help';
205 print STDERR "You must provide a subcommand; displaying usage.\n";
207 } elsif (not exists $subcommands{$subcommand}) {
208 print STDERR "$subcommand is not a valid subcommand; displaying usage.\n";
212 binmode(STDOUT,':encoding(UTF-8)');
213 binmode(STDERR,':encoding(UTF-8)');
216 handle_subcommand_arguments(\@ARGV,$subcommands{$subcommand}{arguments});
217 $subcommands{$subcommand}{function}->(\%options,$opts,$prog_bar,\%config,\@ARGV);
220 my ($options,$opts,$p,$config,$argv) = @_;
221 chdir($config->{spool_dir}) or
222 die "chdir $config->{spool_dir} failed: $!";
224 my $verbose = $options->{debug};
226 my $initialdir = "db-h";
228 if (defined $argv->[0] and $argv->[0] eq "archive") {
229 $initialdir = "archive";
231 my $s = db_connect($options);
235 my $start_time = time;
240 if ($opts->{preload}) {
242 walk_bugs([(@{$argv}?@{$argv} : $initialdir)],
249 $s->resultset('Bug')->quick_insert_bugs(@bugs);
251 walk_bugs([(@{$argv}?@{$argv} : $initialdir)],
257 my $stat = stat(getbugcomponent($bug,'summary',$initialdir));
258 if (not defined $stat) {
259 print STDERR "Unable to stat $bug $!\n";
262 if ($options{quick}) {
263 my $rs = $s->resultset('Bug')->search({bug=>$bug})->single();
264 next if defined $rs and $stat->mtime < $rs->last_modified()->epoch();
266 my $data = read_bug(bug => $bug,
267 location => $initialdir);
270 data => split_status_fields($data),
272 severities => \%severities,
277 print STDERR Dumper($data) if $DEBUG;
278 die "failure while trying to load bug $bug\n$@";
282 handle_load_bug_queue(db => $s,
287 my ($options,$opts,$p,$config,$argv) = @_;
289 my $s = db_connect($options);
291 my @files = @{$argv};
292 $p->target(scalar @files) if $p;
293 for my $file (@files) {
294 my $fh = IO::File->new($file,'r') or
295 die "Unable to open $file for reading: $!";
300 next unless length $_;
301 if (/(\w[-+0-9a-z.]+) \(([^\(\) \t]+)\)/) {
302 push @versions, [$1,$2];
307 for my $i (reverse 0..($#versions)) {
309 if (not defined $src_pkgs{$versions[$i][0]}) {
310 $src_pkgs{$versions[$i][0]} =
311 $s->resultset('SrcPkg')->find_or_create({pkg => $versions[$i][0]});
313 $sp = $src_pkgs{$versions[$i][0]};
314 # There's probably something wrong if the source package
315 # doesn't exist, but we'll skip it for now
316 next unless defined $sp;
317 my $sv = $s->resultset('SrcVer')->find({src_pkg=>$sp->id(),
318 ver => $versions[$i][1],
320 if (defined $ancestor_sv and defined $sv and not defined $sv->based_on()) {
321 $sv->update({based_on => $ancestor_sv->id()})
331 my ($options,$opts,$p,$config,$argv) = @_;
333 my @files = @{$argv};
344 return unless @files;
345 my $s = db_connect($options);
347 $p->target(scalar @files) if $p;
348 for my $file (@files) {
349 my $fh = IO::File->new($file,'r') or
350 die "Unable to open $file for reading: $!";
351 my $f_stat = stat($file);
354 next unless length $_;
355 my ($binname, $binver, $binarch, $srcname, $srcver) = split;
356 # if $srcver is not defined, this is probably a broken
357 # .debinfo file [they were causing #686106, see commit
358 # 49c85ab8 in dak.] Basically, $binarch didn't get put into
359 # the file, so we'll fudge it from the filename.
360 if (not defined $srcver) {
361 ($srcname,$srcver) = ($binarch,$srcname);
362 ($binarch) = $file =~ /_([^\.]+)\.debinfo/;
364 my $sp = $s->resultset('SrcPkg')->find_or_create({pkg => $srcname});
365 # update the creation date if the data we have is earlier
366 my $ct_date = DateTime->from_epoch(epoch => $f_stat->ctime);
367 if ($ct_date < $sp->creation) {
368 $sp->creation($ct_date);
369 $sp->last_modified(DateTime->now);
372 my $sv = $s->resultset('SrcVer')->find_or_create({src_pkg =>$sp->id(),
374 if (not defined $sv->upload_date() or $ct_date < $sv->upload_date()) {
375 $sv->upload_date($ct_date);
379 if (defined $arch{$binarch}) {
380 $arch = $arch{$binarch};
382 $arch = $s->resultset('Arch')->find_or_create({arch => $binarch});
383 $arch{$binarch} = $arch;
385 my $bp = $s->resultset('BinPkg')->find_or_create({pkg => $binname});
386 $s->resultset('BinVer')->find_or_create({bin_pkg => $bp->id(),
387 src_ver => $sv->id(),
397 sub add_maintainers {
398 my ($options,$opts,$p,$config,$argv) = @_;
400 my $s = db_connect($options);
401 my $maintainers = getsourcemaintainers();
403 ## get all of the maintainers, and add the missing ones
404 my $maints = $s->resultset('Maintainer')->
405 get_maintainers(values %{$maintainers});
407 my @svs = $s->resultset('SrcVer')->
408 search({maintainer => undef
411 group_by => 'me.src_pkg, src_pkg.pkg',
412 result_class => 'DBIx::Class::ResultClass::HashRefInflator',
413 columns => [qw(me.src_pkg src_pkg.pkg)],
416 $p->target(2+@svs) if $p;
419 if (exists $maintainers->{$sv->{src_pkg}{pkg}}) {
420 my $pkg = $sv->{src_pkg}{pkg};
421 my $maint = $maints->
422 {$maintainers->{$pkg}};
423 $s->txn_do(sub {$s->resultset('SrcVer')->
424 search({maintainer => undef,
425 'src_pkg.pkg' => $pkg
428 )->update({maintainer => $maint})
436 sub add_configuration {
437 my ($options,$opts,$p,$config,$argv) = @_;
439 my $s = db_connect($options);
448 for my $sev_name (@{$config{severities}}) {
449 # add all severitites
450 my $sev = $s->resultset('Severity')->find_or_create({severity => $sev_name});
451 # mark strong severities
452 if (grep {$_ eq $sev_name} @{$config{strong_severities}}) {
458 $sev_names{$sev_name} = 1;
460 # mark obsolete severities
461 for my $sev ($s->resultset('Severity')->find()) {
462 next if exists $sev_names{$sev->severity()};
469 my ($options,$opts,$p,$config,$argv) = @_;
472 my $s = db_connect($options);
473 my $dist_dir = IO::Dir->new($opts->{ftpdists});
475 grep { $_ !~ /^\./ and
476 -d $opts->{ftpdists}.'/'.$_ and
477 not -l $opts->{ftpdists}.'/'.$_
479 while (my $dist = shift @dist_names) {
480 my $dist_dir = $opts->{ftpdists}.'/'.$dist;
481 my ($dist_info,$package_files) =
482 read_release_file($dist_dir.'/Release');
483 load_suite($s,$dist_info);
488 my ($options,$opts,$p,$config,$argv) = @_;
490 chdir($config->{spool_dir}) or
491 die "chdir $config->{spool_dir} failed: $!";
493 my $verbose = $options->{debug};
495 my $initialdir = "db-h";
497 if (defined $argv->[0] and $argv->[0] eq "archive") {
498 $initialdir = "archive";
500 my $s = db_connect($options);
504 my $start_time = time;
506 walk_bugs([(@{$argv}?@{$argv} : $initialdir)],
513 load_bug_log(db => $s,
517 die "failure while trying to load bug log $bug\n$@";
523 my ($options,$opts,$p,$config,$argv) = @_;
525 my $dist_dir = IO::Dir->new($opts->{ftpdists});
527 grep { $_ !~ /^\./ and
528 -d $opts->{ftpdists}.'/'.$_ and
529 not -l $opts->{ftpdists}.'/'.$_
532 while (my $dist = shift @dist_names) {
533 my $dist_dir = $opts->{ftpdists}.'/'.$dist;
534 my ($dist_info,$package_files) =
535 read_release_file($dist_dir.'/Release');
536 $s_p{$dist_info->{Codename}} = $package_files;
539 for my $suite (keys %s_p) {
540 for my $component (keys %{$s_p{$suite}}) {
541 $tot += scalar keys %{$s_p{$suite}{$component}};
544 $p->target($tot) if $p;
547 my $tot_suites = scalar keys %s_p;
549 my $completed_pkgs=0;
550 # parse packages files
551 for my $suite (keys %s_p) {
553 for my $component (keys %{$s_p{$suite}}) {
554 my @archs = keys %{$s_p{$suite}{$component}};
555 if (grep {$_ eq 'source'} @archs) {
556 @archs = ('source',grep {$_ ne 'source'} @archs);
558 for my $arch (@archs) {
559 my $pfh = open_compressed_file($s_p{$suite}{$component}{$arch}) or
560 die "Unable to open $s_p{$suite}{$component}{$arch} for reading: $!";
562 local $/ = ''; # paragraph mode
565 for my $field (qw(Package Maintainer Version Source)) {
566 /^\Q$field\E: (.*)/m;
569 next unless defined $pkg{Package} and
570 defined $pkg{Version};
571 push @pkgs,[$arch,$component,\%pkg];
575 my $s = db_connect($options);
579 $p->target($avg_pkgs*($tot_suites-$done_suites-1)+
580 $completed_pkgs+@pkgs) if $p;
585 $avg_pkgs=($avg_pkgs*$done_suites + @pkgs)/($done_suites+1);
586 $completed_pkgs += @pkgs;
592 sub handle_subcommand_arguments {
593 my ($argv,$args) = @_;
595 Getopt::Long::GetOptionsFromArray($argv,
600 for my $arg (keys %{$args}) {
601 next unless $args->{$arg};
602 my $r_arg = $arg; # real argument name
603 $r_arg =~ s/[=\|].+//g;
604 if (not defined $subopt->{$r_arg}) {
605 push @usage_errors, "You must give a $r_arg option";
608 pod2usage(join("\n",@usage_errors)) if @usage_errors;
613 my ($subcommand,$config,$options) = @_;
614 if (not lockpid($config->{spool_dir}.'/lock/debbugs-loadsql-$subcommand')) {
615 if ($options->{quick}) {
616 # If this is a quick run, just exit
617 print STDERR "Another debbugs-loadsql is running; stopping\n" if $options->{verbose};
620 print STDERR "Another debbugs-loadsql is running; stopping\n";
627 # connect to the database; figure out how to handle errors
629 my $s = Debbugs::DB->connect($options->{service}) or
630 die "Unable to connect to database: ";
633 sub open_compressed_file {
636 my $mode = '<:encoding(UTF-8)';
638 if ($file =~ /\.gz$/) {
639 $mode = '-|:encoding(UTF-8)';
640 push @opts,'gzip','-dc';
642 if ($file =~ /\.xz$/) {
643 $mode = '-|:encoding(UTF-8)';
644 push @opts,'xz','-dc';
646 if ($file =~ /\.bz2$/) {
647 $mode = '-|:encoding(UTF-8)';
648 push @opts,'bzip2','-dc';
650 open($fh,$mode,@opts,$file);
654 sub read_release_file {
657 my $rfh = open_compressed_file($file) or
658 die "Unable to open $file for reading: $!";
664 if (s/^(\S+):\s*//) {
665 if ($1 eq 'SHA1'or $1 eq 'SHA256') {
672 my ($sha,$size,$f) = split /\s+/,$_;
673 next unless $f =~ /(?:Packages|Sources)(?:\.gz|\.xz)$/;
674 next unless $f =~ m{^([^/]+)/([^/]+)/([^/]+)$};
675 my ($component,$arch,$package_source) = ($1,$2,$3);
676 $arch =~ s/binary-//;
677 next if exists $p_f{$component}{$arch};
678 $p_f{$component}{$arch} = File::Spec->catfile(dirname($file),$f);
681 return (\%dist_info,\%p_f);
685 my ($dirs,$p,$what,$verbose,$sub) = @_;
687 my $tot_dirs = @dirs;
689 my $avg_subfiles = 0;
690 my $completed_files = 0;
691 while (my $dir = shift @dirs) {
692 printf "Doing dir %s ...\n", $dir if $verbose;
694 opendir(DIR, "$dir/.") or die "opendir $dir: $!";
695 my @subdirs = readdir(DIR);
698 my @list = map { m/^(\d+)\.$what$/?($1):() } @subdirs;
700 push @dirs, map { m/^(\d+)$/ && -d "$dir/$1"?("$dir/$1"):() } @subdirs;
702 if ($avg_subfiles == 0) {
703 $avg_subfiles = @list;
706 $p->target($avg_subfiles*($tot_dirs-$done_dirs)+$completed_files+@list) if $p;
707 $avg_subfiles = ($avg_subfiles * $done_dirs + @list) / ($done_dirs+1);
710 for my $bug (@list) {
712 $p->update($completed_files) if $p;
713 print "Up to $completed_files bugs...\n" if ($completed_files % 100 == 0 && $verbose);