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 any);
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;
45 extends 'Debbugs::OOBase';
47 my $meta = __PACKAGE__->meta;
49 state $strong_severities =
50 {map {($_,1)} @{$config{strong_severities}}};
52 has bug => (is => 'ro', isa => 'Int',
60 has saved => (is => 'ro', isa => 'Bool',
62 writer => '_set_saved',
65 has status => (is => 'ro', isa => 'Debbugs::Bug::Status',
67 builder => '_build_status',
68 handles => {date => 'date',
70 message_id => 'message_id',
71 severity => 'severity',
72 archived => 'archived',
75 forwarded => 'forwarded',
81 return Debbugs::Bug::Status->new(bug=>$self->bug,
82 $self->schema_argument,
86 has log => (is => 'bare', isa => 'Debbugs::Log',
88 builder => '_build_log',
89 handles => {_read_record => 'read_record',
90 log_records => 'read_all_records',
96 return Debbugs::Log->new(bug_num => $self->id,
101 has spam => (is => 'bare', isa => 'Debbugs::Log::Spam',
103 builder => '_build_spam',
104 handles => ['is_spam'],
108 return Debbugs::Log::Spam->new(bug_num => $self->id);
111 has 'package_collection' => (is => 'ro',
112 isa => 'Debbugs::Collection::Package',
113 builder => '_build_package_collection',
117 sub _build_package_collection {
119 if ($self->has_schema) {
120 return Debbugs::Collection::Package->new(schema => $self->schema);
122 if (defined $config{database}) {
123 carp "No schema when building package collection";
125 return Debbugs::Collection::Package->new();
128 has bug_collection => (is => 'ro',
129 isa => 'Debbugs::Collection::Bug',
130 builder => '_build_bug_collection',
132 sub _build_bug_collection {
134 if ($self->has_schema) {
135 return Debbugs::Collection::Bug->new(schema => $self->schema);
137 return Debbugs::Collection::Bug->new();
140 has correspondent_collection =>
142 isa => 'Debbugs::Collection::Correspondent',
143 builder => '_build_correspondent_collection',
146 sub _build_correspondent_collection {
148 return Debbugs::Collection::Correspondent->new($self->schema_argument);
152 for my $attr (qw(packages affects sources)) {
155 isa => 'Debbugs::Collection::Package',
156 clearer => '_clear_'.$attr,
157 builder => '_build_'.$attr,
163 for my $attr (qw(blocks blocked_by mergedwith)) {
166 isa => 'Debbugs::Collection::Bug',
167 clearer => '_clear_'.$attr,
168 builder => '_build_'.$attr,
175 for my $attr (qw(owner submitter done)) {
178 isa => 'Maybe[Debbugs::Correspondent]',
180 builder => '_build_'.$attr.'_corr',
181 clearer => '_clear_'.$attr.'_corr',
182 handles => {$attr.'_url' => $attr.'_url',
183 $attr.'_email' => 'email',
184 $attr.'_phrase' => 'phrase',
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);
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);
208 return $self->has_done;
211 sub strong_severity {
213 return exists $strong_severities->{$self->severity};
217 $_[0]->severity =~ m/^(.)/;
221 sub _build_packages {
223 return $self->package_collection->
224 limit($self->status->package);
229 return $self->affects->count > 0;
234 return $self->package_collection->
235 limit($self->status->affects);
239 return $self->packages->sources->clone;
244 return defined $self->owner;
249 return $self->blocks->count > 0;
254 return $self->bug_collection->
255 limit($self->status->blocks);
260 return $self->blocked_by->count > 0;
263 sub _build_blocked_by {
265 return $self->bug_collection->
266 limit($self->status->blocked_by);
270 length($_[0]->forwarded) > 0;
273 for my $attr (qw(fixed found)) {
276 isa => 'Debbugs::Collection::Version',
277 clearer => '_clear_'.$attr,
278 builder => '_build_'.$attr,
286 return any {1} $self->status->found;
291 return $self->packages->
292 get_source_versions($self->status->found);
297 return any {1} $self->status->fixed;
302 return $self->packages->
303 get_source_versions($self->status->fixed);
308 return any {1} $self->status->mergedwith;
311 sub _build_mergedwith {
313 return $self->bug_collection->
314 limit($self->status->mergedwith);
317 for my $attr (qw(created modified)) {
318 has $attr => (is => 'rw', isa => 'Object',
319 clearer => '_clear_'.$attr,
320 builder => '_build_'.$attr,
325 from_epoch(epoch => $_[0]->status->date);
327 sub _build_modified {
329 from_epoch(epoch => max($_[0]->status->log_modified,
330 $_[0]->status->last_modified
334 has tags => (is => 'ro',
335 isa => 'Debbugs::Bug::Tag',
336 clearer => '_clear_tags',
337 builder => '_build_tags',
342 return Debbugs::Bug::Tag->new(keywords => join(' ',$self->status->tags),
344 users => $self->bug_collection->users,
348 has pending => (is => 'ro',
350 clearer => '_clear_pending',
351 builder => '_build_pending',
358 my $pending = 'pending';
359 if (length($self->status->forwarded)) {
360 $pending = 'forwarded';
362 if ($self->tags->tag_is_set('pending')) {
363 $pending = 'pending-fixed';
365 if ($self->tags->tag_is_set('pending')) {
368 # XXX This isn't quite right
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'),
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.
388 $self->package_collection->
389 universe->versiontree;
390 my $max_buggy = 'absent';
393 my @ver_opts = (version => $ver,
394 package => $self->status->package,
395 package_collection => $self->package_collection,
399 $ver = Debbugs::Version::Source->(@ver_opts);
401 $ver = Debbugs::Version::Binary->(@ver_opts);
404 $vertree->load($ver->source);
406 $vertree->buggy($ver,
409 if ($buggy eq 'found') {
412 if ($buggy eq 'fixed') {
413 $max_buggy = 'fixed';
420 (is => 'ro', isa => 'Bool',
421 writer => '_set_archiveable',
422 builder => '_build_archiveable',
423 clearer => '_clear_archiveable',
426 has when_archiveable =>
427 (is => 'ro', isa => 'Num',
428 writer => '_set_when_archiveable',
429 builder => '_build_when_archiveable',
430 clearer => '_clear_when_archiveable',
434 sub _build_archiveable {
436 $self->_populate_archiveable(0);
437 return $self->archiveable;
439 sub _build_when_archiveable {
441 $self->_populate_archiveable(1);
442 return $self->when_archiveable;
445 sub _populate_archiveable {
447 my ($need_time) = @_;
449 # Bugs can be archived if they are
451 if (not $self->done) {
452 $self->_set_archiveable(0);
453 $self->_set_when_archiveable(-1);
456 # 2. Have no unremovable tags set
457 if (@{$config{removal_unremovable_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);
469 state $remove_time = 24 * 60 * 60 * ($config{remove_age} // 30);
470 # 4. Have been modified more than remove_age 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;
480 @{$config{removal_default_distribution_tags}};
481 if ($self->strong_severity) {
483 @{$config{removal_strong_severity_default_distribution_tags}};
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);
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);
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);
509 my %param = validate_with(params => \@_,
510 spec => {seen_merged => {type => HASHREF,
511 default => sub {return {}},
513 repeat_merged => {type => BOOLEAN,
516 include => {type => HASHREF,
519 exclude => {type => HASHREF,
522 min_days => {type => SCALAR,
525 max_days => {type => SCALAR,
530 if (exists $param{include}) {
531 return 1 if not $self->matches($param{include});
533 if (exists $param{exclude}) {
534 return 1 if $self->matches($param{exclude});
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;
542 if (exists $param{min_days}) {
543 return 1 unless $param{min_days} <=
544 (DateTime->now() - $self->created)->days();
546 if (exists $param{max_days}) {
547 return 1 unless $param{max_days} >=
548 (DateTime->now() - $self->created)->days();
555 my ($field, $values) = @_;
556 my @ret = first {sub {$_ eq $field}} @{$values};
560 sub __contains_match {
561 my ($field, $values) = @_;
562 foreach my $value (@{$values}) {
563 return 1 if (index($field, $value) > -1);
569 {subject => sub {__contains_match($_[0]->subject,@_)},
571 for my $value (@{$_[1]}) {
572 if ($_[0]->tags->is_set($value)) {
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,@_)},
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";
594 return 1 if $sub->($self,$hash->{$key});
601 return $self->id.'@'.$config{email_domain};
604 sub subscribe_email {
606 return $self->id.'-subscribe@'.$config{email_domain};
611 return $config{web_domain}.'/'.$self->id;
616 return $config{web_domain}.'/mbox:'.$self->id;
619 sub mbox_status_url {
621 return $self->mbox_url.'?mboxstatus=yes';
626 $self->mbox_url.'?mboxmaint=yes';
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],
637 return $url->as_string;
640 sub related_packages_and_versions {
642 my @packages = $self->status->package;
643 my @versions = ($self->status->found,
644 $self->status->fixed);
645 my @unqualified_versions;
647 for my $ver (@versions) {
648 if ($ver =~ m{(<src>.+)/(<ver>.+)}) { # It's a src_pkg_ver
649 push @return, ['src:'.$+{src}, $+{ver}];
651 push @unqualified_versions,$ver;
654 for my $pkg (@packages) {
655 if (@unqualified_versions) {
657 [$pkg,@unqualified_versions];
662 push @return,$self->status->affects;
668 return 'Debbugs::Bug={bug='.$self->bug.'}';
671 __PACKAGE__->meta->make_immutable;
679 # indent-tabs-mode: nil
680 # cperl-indent-level: 4