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