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
5 # Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
11 Debbugs::Bug -- OO interface to bugs
16 Debbugs::Bug->new(schema => $s,binaries => [qw(foo)],sources => [qw(bar)]);
27 use v5.10; # for state
30 use List::AllUtils qw(max first min);
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;
44 extends 'Debbugs::OOBase';
46 state $strong_severities =
47 {map {($_,1)} @{$config{strong_severities}}};
49 has bug => (is => 'ro', isa => 'Int',
57 has saved => (is => 'ro', isa => 'Bool',
59 writer => '_set_saved',
62 has status => (is => 'ro', isa => 'HashRef',
64 builder => '_build_status',
70 my $status = read_bug(bug=>$self->bug) or
71 confess("Unable to read bug ".$self->bug);
75 has log => (is => 'bare', isa => 'Debbugs::Log',
77 builder => '_build_log',
78 handles => {_read_record => 'read_record',
79 log_records => 'read_all_records',
85 return Debbugs::Log->new(bug_num => $self->id,
90 has spam => (is => 'bare', isa => 'Debbugs::Log::Spam',
92 builder => '_build_spam',
93 handles => ['is_spam'],
97 return Debbugs::Log::Spam->new(bug_num => $self->id);
100 has 'package_collection' => (is => 'ro',
101 isa => 'Debbugs::Collection::Package',
102 builder => '_build_package_collection',
106 sub _build_package_collection {
108 if ($self->has_schema) {
109 return Debbugs::Collection::Package->new(schema => $self->schema);
111 carp "No schema when building package collection";
112 return Debbugs::Collection::Package->new();
115 has bug_collection => (is => 'ro',
116 isa => 'Debbugs::Collection::Bug',
117 builder => '_build_bug_collection',
119 sub _build_bug_collection {
121 if ($self->has_schema) {
122 return Debbugs::Collection::Bug->new(schema => $self->schema);
124 return Debbugs::Collection::Bug->new();
127 has correspondent_collection =>
129 isa => 'Debbugs::Collection::Correspondent',
130 builder => '_build_package_collection',
133 sub _build_correspondent_collection {
135 return Debbugs::Collection::Correspondent->new($self->schema_argument);
140 $self->_clear_done();
141 $self->_clear_severity();
142 $self->_clear_packages();
143 $self->_clear_sources();
144 $self->_clear_affects();
145 $self->_clear_blocks();
146 $self->_clear_blockedby();
147 $self->_clear_found();
148 $self->_clear_fixed();
149 $self->_clear_mergedwith();
150 $self->_clear_pending();
151 $self->_clear_location();
152 $self->_clear_archived();
153 $self->_clear_archiveable();
154 $self->_clear_when_archiveable();
155 $self->_clear_submitter();
156 $self->_clear_created();
157 $self->_clear_modified();
158 $self->_set_saved(1);
161 sub _clear_saved_if_changed {
162 my ($self,$new,$old) = @_;
165 $self->_set_saved(0);
171 for my $attr (qw(packages affects sources)) {
174 isa => 'Debbugs::Collection::Package',
175 clearer => '_clear_'.$attr,
176 builder => '_build_'.$attr,
177 trigger => \&_clear_saved_if_changed,
183 for my $attr (qw(blocks blockedby mergedwith)) {
186 isa => 'Debbugs::Collection::Bug',
187 clearer => '_clear_'.$attr,
188 builder => '_build_'.$attr,
195 for my $attr (qw(owner submitter)) {
198 isa => 'Debbugs::Correspondent',
200 builder => '_build_'.$attr.'_corr',
201 clearer => '_clear_'.$attr.'_corr',
202 handles => {$attr.'_url' => $attr.'_url',
203 $attr.'_email' => 'email',
204 $attr.'_phrase' => 'phrase',
209 sub _build_owner_corr {
211 return $self->correspondent_collection->get_or_create($self->owner);
214 sub _build_submitter_corr {
216 return $self->correspondent_collection->get_or_create($self->submitter);
219 for my $attr (qw(done severity),
221 qw(pending location submitter),
227 clearer => '_clear_'.$attr,
228 builder => '_build_'.$attr,
229 trigger => \&_clear_saved_if_changed,
235 return length $_[0]->done?1:0;
238 return $_[0]->status->{done} // '';
241 sub _build_severity {
242 return $_[0]->status->{severity} // $config{default_severity};
246 return $_[0]->status->{subject} // '(No subject)';
249 sub strong_severity {
251 return exists $strong_severities->{$self->severity};
255 $_[0]->severity =~ m/^(.)/;
261 return join(', ',$self->packages->apply(sub{$_->name}));
264 sub _build_packages {
267 if (length($self->status->{package}//'')) {
268 @packages = split /,/,$self->status->{package}//'';
270 return $self->package_collection->
276 return $self->affects->count > 0;
281 return join(', ',map {$_->name} $_[0]->affects->members);
286 if (length($_[0]->status->{affects}//'')) {
287 @packages = split /,/,$_[0]->status->{affects}//'';
289 return $_[0]->package_collection->
294 return join(', ',map {$_->name} $_[0]->sources->members);
298 my @sources = map {$_->sources} $_[0]->packages->members;
304 return length($self->owner) > 0;
308 return $self->status->{owner} // '';
312 sub _split_if_defined {
313 my ($self,$field,$split) = @_;
315 my $e = $self->status->{$field};
319 return split /$split/,$e;
326 return $self->blocks->count > 0;
331 return $self->bug_collection->
332 limit(sort {$a <=> $b}
333 $self->_split_if_defined('blocks'));
338 return $self->blockedby->count > 0;
341 sub _build_blockedby {
343 return $self->bug_collection->
344 limit(sort {$a <=> $b}
345 $self->_split_if_defined('blockedby'));
349 length($_[0]->forwarded) > 0;
352 sub _build_forwarded {
354 return $self->status->{forwarded} // '';
359 for my $attr (qw(fixed found)) {
362 isa => 'Debbugs::Collection::Version',
363 clearer => '_clear_'.$attr,
364 builder => '_build_'.$attr,
372 return $self->found->count > 0;
377 return $self->packages->
378 get_source_versions(@{$self->status->{found_versions} // []});
383 return $self->fixed->count > 0;
388 return $self->packages->
389 get_source_versions(@{$self->status->{fixed_versions} // []});
394 return $self->mergedwith->count > 0;
397 has _mergedwith_array =>
399 isa => 'ArrayRef[Int]',
400 builder => '_build_mergedwith_array',
404 sub _build_mergedwith_array {
406 return [sort {$a <=> $b}
407 $self->_split_if_defined('mergedwith')];
410 sub _build_mergedwith {
412 return $self->bug_collection->
413 limit(@{$self->_mergedwith_array//[]});
416 return $_[0]->status->{pending} // '';
418 sub _build_submitter {
419 return $_[0]->status->{originator} // '';
422 for my $attr (qw(created modified)) {
423 has $attr => (is => 'rw', isa => 'Object',
424 clearer => '_clear_'.$attr,
425 builder => '_build_'.$attr,
430 from_epoch(epoch => $_[0]->status->{date} // time);
432 sub _build_modified {
434 from_epoch(epoch => max($_[0]->status->{log_modified},
435 $_[0]->status->{last_modified}
438 sub _build_location {
439 return $_[0]->status->{location};
441 has archived => (is => 'ro', isa => 'Bool',
442 clearer => '_clear_archived',
443 builder => '_build_archived',
445 sub _build_archived {
446 return $_[0]->location eq 'archived'?1:0;
449 has tags => (is => 'ro',
450 isa => 'Debbugs::Bug::Tag',
451 clearer => '_clear_tags',
452 builder => '_build_tags',
457 return Debbugs::Bug::Tag->new(keywords => $self->status->{keywords},
459 users => $self->bug_collection->users,
465 $bug->buggy('debbugs/2.6.0-1','debbugs/2.6.0-2');
466 $bug->buggy(Debbugs::Version->new('debbugs/2.6.0-1'),
467 Debbugs::Version->new('debbugs/2.6.0-2'),
470 Returns the output of Debbugs::Versions::buggy for a particular
471 package, version and found/fixed set. Automatically turns found, fixed
472 and version into source/version strings.
479 $self->package_collection->
480 universe->versiontree;
481 my $max_buggy = 'absent';
484 $ver = Debbugs::Version->
487 package_collection => $self->package_collection,
490 $vertree->load($ver->source);
492 $vertree->buggy($ver,
495 if ($buggy eq 'found') {
498 if ($buggy eq 'fixed') {
499 $max_buggy = 'fixed';
506 (is => 'ro', isa => 'Bool',
507 writer => '_set_archiveable',
508 builder => '_build_archiveable',
509 clearer => '_clear_archiveable',
512 has when_archiveable =>
513 (is => 'ro', isa => 'Num',
514 writer => '_set_when_archiveable',
515 builder => '_build_when_archiveable',
516 clearer => '_clear_when_archiveable',
520 sub _build_archiveable {
522 $self->_populate_archiveable(0);
523 return $self->archiveable;
525 sub _build_when_archiveable {
527 $self->_populate_archiveable(1);
528 return $self->when_archiveable;
531 sub _populate_archiveable {
533 my ($need_time) = @_;
535 # Bugs can be archived if they are
537 if (not $self->done) {
538 $self->_set_archiveable(0);
539 $self->_set_when_archiveable(-1);
542 # 2. Have no unremovable tags set
543 if (@{$config{removal_unremovable_tags}}) {
545 {map {($_=>1)} @{$config{removal_unremovable_tags}}};
546 for my $tag ($self->tags) {
547 if ($unrem_tags->{$tag}) {
548 $self->_set_archiveable(0);
549 $self->_set_when_archiveable(-1);
555 state $remove_time = 24 * 60 * 60 * ($config{removal_age} // 30);
556 # 4. Have been modified more than removal_age ago
558 $time - $self->modified->epoch;
559 # if we don't need to know when we can archive, we can stop here if it's
560 # been modified too recently
561 if ($moded_ago < $remove_time) {
562 $self->_set_archiveable(0);
563 return unless $need_time;
566 @{$config{removal_default_distribution_tags}};
567 if ($self->strong_severity) {
569 @{$config{removal_strong_severity_default_distribution_tags}};
571 # 3. Have a maximum buggy of fixed
572 my $buggy = $self->buggy($self->packages->
573 get_source_versions_distributions(@distributions));
574 if ('found' eq $buggy) {
575 $self->_set_archiveable(0);
576 $self->_set_when_archiveable(-1);
579 my $fixed_ago = $moded_ago;
580 # $fixed_ago = $time - $self->when_fixed(@distributions);
581 # if ($fixed_ago < $remove_time) {
582 # $self->_set_archiveable(0);
584 $self->_set_when_archiveable(($remove_time - min($fixed_ago,$moded_ago)) / (24 * 60 * 60));
585 if ($fixed_ago > $remove_time and
586 $moded_ago > $remove_time) {
587 $self->_set_archiveable(1);
588 $self->_set_when_archiveable(0);
595 my %param = validate_with(params => \@_,
596 spec => {seen_merged => {type => HASHREF,
597 default => sub {return {}},
599 repeat_merged => {type => BOOLEAN,
602 include => {type => HASHREF,
605 exclude => {type => HASHREF,
608 min_days => {type => SCALAR,
611 max_days => {type => SCALAR,
616 if (exists $param{include}) {
617 return 1 if not $self->matches($param{include});
619 if (exists $param{exclude}) {
620 return 1 if $self->matches($param{exclude});
622 if (exists $param{repeat_merged} and not $param{repeat_merged}) {
623 my @merged = sort {$a<=>$b} $self->bug, @{$self->_mergedwith_array // []};
624 return 1 if first {sub {defined $_}}
625 @{$param{seen_merged}}{@merged};
626 @{$param{seen_merged}}{@merged} = (1) x @merged;
628 if (exists $param{min_days}) {
629 return 1 unless $param{min_days} <=
630 (DateTime->now() - $self->created)->days();
632 if (exists $param{max_days}) {
633 return 1 unless $param{max_days} >=
634 (DateTime->now() - $self->created)->days();
641 my ($field, $values) = @_;
642 my @ret = first {sub {$_ eq $field}} @{$values};
646 sub __contains_match {
647 my ($field, $values) = @_;
648 foreach my $value (@{$values}) {
649 return 1 if (index($field, $value) > -1);
655 {subject => sub {__contains_match($_[0]->subject,@_)},
657 for my $value (@{$_[1]}) {
658 if ($_[0]->tags->is_set($value)) {
664 severity => sub {__exact_match($_[0]->severity,@_)},
665 pending => sub {__exact_match($_[0]->pending,@_)},
666 originator => sub {__exact_match($_[0]->submitter,@_)},
667 submitter => sub {__exact_match($_[0]->submitter,@_)},
668 forwarded => sub {__exact_match($_[0]->forwarded,@_)},
669 owner => sub {__exact_match($_[0]->owner,@_)},
673 my ($self,$hash) = @_;
674 for my $key (keys %{$hash}) {
675 my $sub = $field_match->{$key};
676 if (not defined $sub) {
677 carp "No subroutine for key: $key";
680 return 1 if $sub->($self,$hash->{$key});
687 return $self->id.'@'.$config{email_domain};
690 sub subscribe_email {
692 return $self->id.'-subscribe@'.$config{email_domain};
697 return $config{web_domain}.'/'.$self->id;
702 return $config{web_domain}.'/mbox:'.$self->id;
705 sub mbox_status_url {
707 return $self->mbox_url.'?mboxstatus=yes';
712 $self->mbox_url.'?mboxmaint=yes';
717 return version_url(package => $self->package,
718 found => [$self->found->members],
719 fixed => [$self->fixed->members],
724 sub related_packages_and_versions {
727 if (length($self->status->{package}//'')) {
728 @packages = split /,/,$self->status->{package}//'';
730 if (length($self->status->{affects}//'')) {
732 split /,/,$self->status->{affects}//'';
735 (@{$self->status->{found_versions}//[]},
736 @{$self->status->{fixed_versions}//[]});
737 my @unqualified_versions;
739 for my $ver (@versions) {
740 if ($ver =~ m{(<src>.+)/(<ver>.+)}) { # It's a src_pkg_ver
741 push @return, ['src:'.$+{src}, $+{ver}];
743 push @unqualified_versions,$ver;
746 for my $pkg (@packages) {
747 if (@unqualified_versions) {
749 [$pkg,@unqualified_versions];
759 return 'Debbugs::Bug={bug='.$self->bug.'}';
762 __PACKAGE__->meta->make_immutable;
770 # indent-tabs-mode: nil
771 # cperl-indent-level: 4