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