Debbugs/Bug.pm

   1 # This module is part of debbugs, and
   2 # is released under the terms of the GPL version 2, or any later
   3 # version (at your option). See the file README and COPYING for more
   4 # information.
   5 # Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
   6
   7 package Debbugs::Bug;
   8
   9 =head1 NAME
  10
  11 Debbugs::Bug -- OO interface to bugs
  12
  13 =head1 SYNOPSIS
  14
  15    use Debbugs::Bug;
  16    Debbugs::Bug->new(schema => $s,binaries => [qw(foo)],sources => [qw(bar)]);
  17
  18 =head1 DESCRIPTION
  19
  20
  21
  22 =cut
  23
  24 use Mouse;
  25 use strictures 2;
  26 use namespace::clean;
  27 use v5.10; # for state
  28
  29 use DateTime;
  30 use List::AllUtils qw(max first min);
  31
  32 use Params::Validate qw(validate_with :types);
  33 use Debbugs::Config qw(:config);
  34 use Debbugs::Status qw(read_bug);
  35 use Debbugs::Bug::Tag;
  36 use Debbugs::Collection::Package;
  37 use Debbugs::Collection::Bug;
  38 use Debbugs::Collection::Correspondent;
  39
  40 use Debbugs::OOTypes;
  41
  42 use Carp;
  43
  44 extends 'Debbugs::OOBase';
  45
  46 state $strong_severities =
  47    {map {($_,1)} @{$config{strong_severities}}};
  48
  49 has bug => (is => 'ro', isa => 'Int',
  50             required => 1,
  51            );
  52
  53 sub id {
  54     return $_[0]->bug;
  55 }
  56
  57 has saved => (is => 'ro', isa => 'Bool',
  58               default => 0,
  59               writer => '_set_saved',
  60              );
  61
  62 has status => (is => 'ro', isa => 'HashRef',
  63                lazy => 1,
  64                builder => '_build_status',
  65               );
  66
  67 sub _build_status {
  68     my $self = shift;
  69     $self->reset;
  70     my $status = read_bug(bug=>$self->bug) or
  71         confess("Unable to read bug ".$self->bug);
  72     return $status;
  73 }
  74
  75 has log => (is => 'bare', isa => 'Debbugs::Log',
  76             lazy => 1,
  77             builder => '_build_log',
  78             handles => {_read_record => 'read_record',
  79                         log_records => 'read_all_records',
  80                        },
  81            );
  82
  83 sub _build_log {
  84     my $self = shift;
  85     return Debbugs::Log->new(bug_num => $self->id,
  86                              inner_file => 1,
  87                             );
  88 }
  89
  90 has spam => (is => 'bare', isa => 'Debbugs::Log::Spam',
  91              lazy => 1,
  92              builder => '_build_spam',
  93              handles => ['is_spam'],
  94             );
  95 sub _build_spam {
  96     my $self = shift;
  97     return Debbugs::Log::Spam->new(bug_num => $self->id);
  98 }
  99
 100 has 'package_collection' => (is => 'ro',
 101                              isa => 'Debbugs::Collection::Package',
 102                              builder => '_build_package_collection',
 103                              lazy => 1,
 104                             );
 105
 106 sub _build_package_collection {
 107     my $self = shift;
 108     if ($self->has_schema) {
 109         return Debbugs::Collection::Package->new(schema => $self->schema);
 110     }
 111     carp "No schema when building package collection";
 112     return Debbugs::Collection::Package->new();
 113 }
 114
 115 has bug_collection => (is => 'ro',
 116                        isa => 'Debbugs::Collection::Bug',
 117                        builder => '_build_bug_collection',
 118                       );
 119 sub _build_bug_collection {
 120     my $self = shift;
 121     if ($self->has_schema) {
 122         return Debbugs::Collection::Bug->new(schema => $self->schema);
 123     }
 124     return Debbugs::Collection::Bug->new();
 125 }
 126
 127 has correspondent_collection =>
 128     (is => 'ro',
 129      isa => 'Debbugs::Collection::Correspondent',
 130      builder => '_build_package_collection',
 131      lazy => 1,
 132     );
 133 sub _build_correspondent_collection   {
 134     my $self = shift;
 135     return Debbugs::Collection::Correspondent->new($self->schema_argument);
 136 }
 137
 138 sub reset {
 139     my $self = shift;
 140     $self->_clear_done();
 141     $self->_clear_severity();
 142     $self->_clear_packages();
 143     $self->_clear_sources();
 144     $self->_clear_affects();
 145     $self->_clear_blocks();
 146     $self->_clear_blockedby();
 147     $self->_clear_found();
 148     $self->_clear_fixed();
 149     $self->_clear_mergedwith();
 150     $self->_clear_pending();
 151     $self->_clear_location();
 152     $self->_clear_archived();
 153     $self->_clear_archiveable();
 154     $self->_clear_when_archiveable();
 155     $self->_clear_submitter();
 156     $self->_clear_created();
 157     $self->_clear_modified();
 158     $self->_set_saved(1);
 159 }
 160
 161 sub _clear_saved_if_changed {
 162     my ($self,$new,$old) = @_;
 163     if (@_ > 2) {
 164         if ($new ne $old) {
 165             $self->_set_saved(0);
 166         }
 167     }
 168 }
 169
 170 # package attributes
 171 for my $attr (qw(packages affects sources)) {
 172     has $attr =>
 173         (is => 'rw',
 174          isa => 'Debbugs::Collection::Package',
 175          clearer => '_clear_'.$attr,
 176          builder => '_build_'.$attr,
 177          trigger => \&_clear_saved_if_changed,
 178          lazy => 1,
 179         );
 180 }
 181
 182 # bugs
 183 for my $attr (qw(blocks blockedby mergedwith)) {
 184     has $attr =>
 185         (is => 'ro',
 186          isa => 'Debbugs::Collection::Bug',
 187          clearer => '_clear_'.$attr,
 188          builder => '_build_'.$attr,
 189          handles => {},
 190          lazy => 1,
 191         );
 192 }
 193
 194
 195 for my $attr (qw(owner submitter)) {
 196     has $attr.'_corr' =>
 197         (is => 'ro',
 198          isa => 'Debbugs::Correspondent',
 199          lazy => 1,
 200          builder => '_build_'.$attr.'_corr',
 201          clearer => '_clear_'.$attr.'_corr',
 202          handles => {$attr.'_url' => $attr.'_url',
 203                      $attr.'_email' => 'email',
 204                      $attr.'_phrase' => 'phrase',
 205                     },
 206         );
 207 }
 208
 209 sub _build_owner_corr {
 210     my $self = shift;
 211     return $self->correspondent_collection->get_or_create($self->owner);
 212 }
 213
 214 sub _build_submitter_corr {
 215     my $self = shift;
 216     return $self->correspondent_collection->get_or_create($self->submitter);
 217 }
 218
 219 for my $attr (qw(done severity),
 220               qw(forwarded),
 221               qw(pending location submitter),
 222               qw(owner subject),
 223              ) {
 224     has $attr =>
 225         (is => 'rw',
 226          isa => 'Str',
 227          clearer => '_clear_'.$attr,
 228          builder => '_build_'.$attr,
 229          trigger => \&_clear_saved_if_changed,
 230          lazy => 1,
 231         );
 232 }
 233
 234 sub is_done {
 235     return length $_[0]->done?1:0;
 236 }
 237 sub _build_done {
 238     return $_[0]->status->{done} // '';
 239 }
 240
 241 sub _build_severity {
 242     return $_[0]->status->{severity} // $config{default_severity};
 243 }
 244
 245 sub _build_subject {
 246     return $_[0]->status->{subject} // '(No subject)';
 247 }
 248
 249 sub strong_severity {
 250     my $self = shift;
 251     return exists $strong_severities->{$self->severity};
 252 }
 253
 254 sub short_severity {
 255     $_[0]->severity =~ m/^(.)/;
 256     return $1;
 257 }
 258
 259 sub package {
 260     my $self = shift;
 261     return join(', ',$self->packages->apply(sub{$_->name}));
 262 }
 263
 264 sub _build_packages {
 265     my $self = shift;
 266     my @packages;
 267     if (length($self->status->{package}//'')) {
 268         @packages = split /,/,$self->status->{package}//'';
 269     }
 270     return $self->package_collection->
 271             limit(@packages);
 272 }
 273
 274 sub is_affecting {
 275     my $self = shift;
 276     return $self->affects->count > 0;
 277 }
 278
 279 sub affect {
 280     local $_;
 281     return join(', ',map {$_->name} $_[0]->affects->members);
 282 }
 283
 284 sub _build_affects {
 285     my @packages;
 286     if (length($_[0]->status->{affects}//'')) {
 287         @packages = split /,/,$_[0]->status->{affects}//'';
 288     }
 289     return $_[0]->package_collection->
 290             limit(@packages);
 291 }
 292 sub source {
 293     local $_;
 294     return join(', ',map {$_->name} $_[0]->sources->members);
 295 }
 296 sub _build_sources {
 297     local $_;
 298     my @sources = map {$_->sources} $_[0]->packages->members;
 299     return @sources;
 300 }
 301
 302 sub is_owned {
 303     my $self = shift;
 304     return length($self->owner) > 0;
 305 }
 306 sub _build_owner {
 307     my $self = shift;
 308     return $self->status->{owner} // '';
 309 }
 310
 311
 312 sub _split_if_defined {
 313     my ($self,$field,$split) = @_;
 314     $split //= ' ';
 315     my $e = $self->status->{$field};
 316     my @f;
 317     if (defined $e and
 318         length $e) {
 319         return split /$split/,$e;
 320     }
 321     return ();
 322 }
 323
 324 sub is_blocking {
 325     my $self = shift;
 326     return $self->blocks->count > 0;
 327 }
 328
 329 sub _build_blocks {
 330     my $self = shift;
 331     return $self->bug_collection->
 332         limit(sort {$a <=> $b}
 333               $self->_split_if_defined('blocks'));
 334 }
 335
 336 sub is_blocked {
 337     my $self = shift;
 338     return $self->blockedby->count > 0;
 339 }
 340
 341 sub _build_blockedby {
 342     my $self = shift;
 343     return $self->bug_collection->
 344         limit(sort {$a <=> $b}
 345               $self->_split_if_defined('blockedby'));
 346 }
 347
 348 sub is_forwarded {
 349     length($_[0]->forwarded) > 0;
 350 }
 351
 352 sub _build_forwarded {
 353     my $self = shift;
 354     return $self->status->{forwarded} // '';
 355 }
 356
 357
 358
 359 for my $attr (qw(fixed found)) {
 360     has $attr =>
 361         (is => 'ro',
 362          isa => 'Debbugs::Collection::Version',
 363          clearer => '_clear_'.$attr,
 364          builder => '_build_'.$attr,
 365          handles => {},
 366          lazy => 1,
 367         );
 368 }
 369
 370 sub has_found {
 371     my $self = shift;
 372     return $self->found->count > 0;
 373 }
 374
 375 sub _build_found {
 376     my $self = shift;
 377     return $self->packages->
 378         get_source_versions(@{$self->status->{found_versions} // []});
 379 }
 380
 381 sub has_fixed {
 382     my $self = shift;
 383     return $self->fixed->count > 0;
 384 }
 385
 386 sub _build_fixed {
 387     my $self = shift;
 388     return $self->packages->
 389         get_source_versions(@{$self->status->{fixed_versions} // []});
 390 }
 391
 392 sub is_merged {
 393     my $self = shift;
 394     return $self->mergedwith->count > 0;
 395 }
 396
 397 has _mergedwith_array =>
 398     (is => 'ro',
 399      isa => 'ArrayRef[Int]',
 400      builder => '_build_mergedwith_array',
 401      lazy => 1,
 402     );
 403
 404 sub _build_mergedwith_array {
 405     my $self = shift;
 406     return [sort {$a <=> $b}
 407             $self->_split_if_defined('mergedwith')];
 408 }
 409
 410 sub _build_mergedwith {
 411     my $self = shift;
 412     return $self->bug_collection->
 413         limit(@{$self->_mergedwith_array//[]});
 414 }
 415 sub _build_pending {
 416     return $_[0]->status->{pending} // '';
 417 }
 418 sub _build_submitter {
 419     return $_[0]->status->{originator} // '';
 420 }
 421
 422 for my $attr (qw(created modified)) {
 423     has $attr => (is => 'rw', isa => 'Object',
 424                 clearer => '_clear_'.$attr,
 425                 builder => '_build_'.$attr,
 426                 lazy => 1);
 427 }
 428 sub _build_created {
 429     return DateTime->
 430         from_epoch(epoch => $_[0]->status->{date} // time);
 431 }
 432 sub _build_modified {
 433     return DateTime->
 434         from_epoch(epoch => max($_[0]->status->{log_modified},
 435                                 $_[0]->status->{last_modified}
 436                                ));
 437 }
 438 sub _build_location {
 439     return $_[0]->status->{location};
 440 }
 441 has archived => (is => 'ro', isa => 'Bool',
 442                  clearer => '_clear_archived',
 443                  builder => '_build_archived',
 444                  lazy => 1);
 445 sub _build_archived {
 446     return $_[0]->location eq 'archived'?1:0;
 447 }
 448
 449 has tags => (is => 'ro',
 450              isa => 'Debbugs::Bug::Tag',
 451              clearer => '_clear_tags',
 452              builder => '_build_tags',
 453              lazy => 1,
 454             );
 455 sub _build_tags {
 456     my $self = shift;
 457     return Debbugs::Bug::Tag->new(keywords => $self->status->{keywords},
 458                                   bug => $self,
 459                                   users => $self->bug_collection->users,
 460                                  );
 461 }
 462
 463 =item buggy
 464
 465      $bug->buggy('debbugs/2.6.0-1','debbugs/2.6.0-2');
 466      $bug->buggy(Debbugs::Version->new('debbugs/2.6.0-1'),
 467                  Debbugs::Version->new('debbugs/2.6.0-2'),
 468                 );
 469
 470 Returns the output of Debbugs::Versions::buggy for a particular
 471 package, version and found/fixed set. Automatically turns found, fixed
 472 and version into source/version strings.
 473
 474 =cut
 475
 476 sub buggy {
 477     my $self = shift;
 478     my $vertree =
 479         $self->package_collection->
 480         universe->versiontree;
 481     my $max_buggy = 'absent';
 482     for my $ver (@_) {
 483         if (not ref($ver)) {
 484             $ver = Debbugs::Version->
 485                 new(version => $ver,
 486                     package => $self,
 487                     package_collection => $self->package_collection,
 488                    );
 489         }
 490         $vertree->load($ver->source);
 491         my $buggy =
 492             $vertree->buggy($ver,
 493                             [$self->found],
 494                             [$self->fixed]);
 495         if ($buggy eq 'found') {
 496             return 'found'
 497         }
 498         if ($buggy eq 'fixed') {
 499             $max_buggy = 'fixed';
 500         }
 501     }
 502     return $max_buggy;
 503 }
 504
 505 has archiveable =>
 506     (is => 'ro', isa => 'Bool',
 507      writer => '_set_archiveable',
 508      builder => '_build_archiveable',
 509      clearer => '_clear_archiveable',
 510      lazy => 1,
 511     );
 512 has when_archiveable =>
 513     (is => 'ro', isa => 'Num',
 514      writer => '_set_when_archiveable',
 515      builder => '_build_when_archiveable',
 516      clearer => '_clear_when_archiveable',
 517      lazy => 1,
 518     );
 519
 520 sub _build_archiveable {
 521     my $self = shift;
 522     $self->_populate_archiveable(0);
 523     return $self->archiveable;
 524 }
 525 sub _build_when_archiveable {
 526     my $self = shift;
 527     $self->_populate_archiveable(1);
 528     return $self->when_archiveable;
 529 }
 530
 531 sub _populate_archiveable {
 532     my $self = shift;
 533     my ($need_time) = @_;
 534     $need_time //= 0;
 535     # Bugs can be archived if they are
 536     # 1. Closed
 537     if (not $self->done) {
 538         $self->_set_archiveable(0);
 539         $self->_set_when_archiveable(-1);
 540         return;
 541     }
 542     # 2. Have no unremovable tags set
 543     if (@{$config{removal_unremovable_tags}}) {
 544         state $unrem_tags =
 545            {map {($_=>1)} @{$config{removal_unremovable_tags}}};
 546         for my $tag ($self->tags) {
 547             if ($unrem_tags->{$tag}) {
 548                 $self->_set_archiveable(0);
 549                 $self->_set_when_archiveable(-1);
 550                 return;
 551             }
 552         }
 553     }
 554     my $time = time;
 555     state $remove_time = 24 * 60 * 60 * ($config{removal_age} // 30);
 556     # 4. Have been modified more than removal_age ago
 557     my $moded_ago =
 558         $time - $self->modified->epoch;
 559     # if we don't need to know when we can archive, we can stop here if it's
 560     # been modified too recently
 561     if ($moded_ago < $remove_time) {
 562         $self->_set_archiveable(0);
 563         return unless $need_time;
 564     }
 565     my @distributions =
 566         @{$config{removal_default_distribution_tags}};
 567     if ($self->strong_severity) {
 568         @distributions =
 569             @{$config{removal_strong_severity_default_distribution_tags}};
 570     }
 571     # 3. Have a maximum buggy of fixed
 572     my $buggy = $self->buggy($self->packages->
 573                              get_source_versions_distributions(@distributions));
 574     if ('found' eq $buggy) {
 575         $self->_set_archiveable(0);
 576         $self->_set_when_archiveable(-1);
 577         return;
 578     }
 579     my $fixed_ago = $moded_ago;
 580     # $fixed_ago = $time - $self->when_fixed(@distributions);
 581     # if ($fixed_ago < $remove_time) {
 582     #     $self->_set_archiveable(0);
 583     # }
 584     $self->_set_when_archiveable(($remove_time - min($fixed_ago,$moded_ago)) / (24 * 60 * 60));
 585     if ($fixed_ago > $remove_time and
 586         $moded_ago > $remove_time) {
 587         $self->_set_archiveable(1);
 588         $self->_set_when_archiveable(0);
 589     }
 590     return;
 591 }
 592
 593 sub filter {
 594     my $self = shift;
 595     my %param = validate_with(params => \@_,
 596                               spec   => {seen_merged => {type => HASHREF,
 597                                                          default => sub {return {}},
 598                                                         },
 599                                          repeat_merged => {type => BOOLEAN,
 600                                                            default => 1,
 601                                                           },
 602                                          include => {type => HASHREF,
 603                                                      optional => 1,
 604                                                     },
 605                                          exclude => {type => HASHREF,
 606                                                      optional => 1,
 607                                                     },
 608                                          min_days => {type => SCALAR,
 609                                                       optional => 1,
 610                                                      },
 611                                          max_days => {type => SCALAR,
 612                                                       optional => 1,
 613                                                      },
 614                                          },
 615                              );
 616     if (exists $param{include}) {
 617         return 1 if not $self->matches($param{include});
 618     }
 619     if (exists $param{exclude}) {
 620         return 1 if $self->matches($param{exclude});
 621     }
 622     if (exists $param{repeat_merged} and not $param{repeat_merged}) {
 623         my @merged = sort {$a<=>$b} $self->bug, @{$self->_mergedwith_array // []};
 624         return 1 if first {sub {defined $_}}
 625             @{$param{seen_merged}}{@merged};
 626         @{$param{seen_merged}}{@merged} = (1) x @merged;
 627     }
 628     if (exists $param{min_days}) {
 629         return 1 unless $param{min_days} <=
 630             (DateTime->now() - $self->created)->days();
 631     }
 632     if (exists $param{max_days}) {
 633         return 1 unless $param{max_days} >=
 634             (DateTime->now() - $self->created)->days();
 635     }
 636     return 0;
 637
 638 }
 639
 640 sub __exact_match {
 641     my ($field, $values) = @_;
 642     my @ret = first {sub {$_ eq $field}} @{$values};
 643     return @ret != 0;
 644 }
 645
 646 sub __contains_match {
 647     my ($field, $values) = @_;
 648     foreach my $value (@{$values}) {
 649         return 1 if (index($field, $value) > -1);
 650     }
 651     return 0;
 652 }
 653
 654 state $field_match =
 655    {subject => sub {__contains_match($_[0]->subject,@_)},
 656     tags => sub {
 657         for my $value (@{$_[1]}) {
 658             if ($_[0]->tags->is_set($value)) {
 659                 return 1;
 660             }
 661         }
 662         return 0;
 663         },
 664     severity => sub {__exact_match($_[0]->severity,@_)},
 665     pending => sub {__exact_match($_[0]->pending,@_)},
 666     originator => sub {__exact_match($_[0]->submitter,@_)},
 667     submitter => sub {__exact_match($_[0]->submitter,@_)},
 668     forwarded => sub {__exact_match($_[0]->forwarded,@_)},
 669     owner => sub {__exact_match($_[0]->owner,@_)},
 670    };
 671
 672 sub matches {
 673     my ($self,$hash) = @_;
 674     for my $key (keys %{$hash}) {
 675         my $sub = $field_match->{$key};
 676         if (not defined $sub) {
 677             carp "No subroutine for key: $key";
 678             next;
 679         }
 680         return 1 if $sub->($self,$hash->{$key});
 681     }
 682     return 0;
 683 }
 684
 685 sub url {
 686     my $self = shift;
 687     return $config{web_domain}.'/'.$self->id;
 688 }
 689
 690 sub related_packages_and_versions {
 691     my $self = shift;
 692     my @packages;
 693     if (length($self->status->{package}//'')) {
 694         @packages = split /,/,$self->status->{package}//'';
 695     }
 696     if (length($self->status->{affects}//'')) {
 697         push @packages,
 698             split /,/,$self->status->{affects}//'';
 699     }
 700     my @versions =
 701         (@{$self->status->{found_versions}//[]},
 702          @{$self->status->{fixed_versions}//[]});
 703     my @unqualified_versions;
 704     my @return;
 705     for my $ver (@versions) {
 706         if ($ver =~ m{(<src>.+)/(<ver>.+)}) { # It's a src_pkg_ver
 707             push @return, ['src:'.$+{src}, $+{ver}];
 708         } else {
 709            push @unqualified_versions,$ver;
 710         }
 711     }
 712     for my $pkg (@packages) {
 713         if (@unqualified_versions) {
 714             push @return,
 715                 [$pkg,@unqualified_versions];
 716         } else {
 717            push @return,$pkg;
 718         }
 719     }
 720     return @return;
 721 }
 722
 723 sub CARP_TRACE {
 724     my $self = shift;
 725     return 'Debbugs::Bug={bug='.$self->bug.'}';
 726 }
 727
 728 __PACKAGE__->meta->make_immutable;
 729
 730 no Mouse;
 731 1;
 732
 733
 734 __END__
 735 # Local Variables:
 736 # indent-tabs-mode: nil
 737 # cperl-indent-level: 4
 738 # End: