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