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