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