+++ /dev/null
-# This module is part of debbugs, and
-# is released under the terms of the GPL version 2, or any later
-# version (at your option). See the file README and COPYING for more
-# information.
-# Copyright 2018 by Don Armstrong <don@donarmstrong.com>.
-
-package Debbugs::Bug;
-
-=head1 NAME
-
-Debbugs::Bug -- OO interface to bugs
-
-=head1 SYNOPSIS
-
- use Debbugs::Bug;
- Debbugs::Bug->new(schema => $s,binaries => [qw(foo)],sources => [qw(bar)]);
-
-=head1 DESCRIPTION
-
-
-
-=cut
-
-use Mouse;
-use strictures 2;
-use namespace::clean;
-use v5.10; # for state
-
-use DateTime;
-use List::AllUtils qw(max first min any);
-
-use Params::Validate qw(validate_with :types);
-use Debbugs::Config qw(:config);
-use Debbugs::Status qw(read_bug);
-use Debbugs::Bug::Tag;
-use Debbugs::Bug::Status;
-use Debbugs::Collection::Package;
-use Debbugs::Collection::Bug;
-use Debbugs::Collection::Correspondent;
-
-use Debbugs::OOTypes;
-
-use Carp;
-
-extends 'Debbugs::OOBase';
-
-my $meta = __PACKAGE__->meta;
-
-state $strong_severities =
- {map {($_,1)} @{$config{strong_severities}}};
-
-has bug => (is => 'ro', isa => 'Int',
- required => 1,
- );
-
-sub id {
- return $_[0]->bug;
-}
-
-has saved => (is => 'ro', isa => 'Bool',
- default => 0,
- writer => '_set_saved',
- );
-
-has status => (is => 'ro', isa => 'Debbugs::Bug::Status',
- lazy => 1,
- builder => '_build_status',
- handles => {date => 'date',
- subject => 'subject',
- message_id => 'message_id',
- severity => 'severity',
- archived => 'archived',
- summary => 'summary',
- outlook => 'outlook',
- forwarded => 'forwarded',
- },
- );
-
-sub _build_status {
- my $self = shift;
- return Debbugs::Bug::Status->new(bug=>$self->bug,
- $self->schema_argument,
- );
-}
-
-has log => (is => 'bare', isa => 'Debbugs::Log',
- lazy => 1,
- builder => '_build_log',
- handles => {_read_record => 'read_record',
- log_records => 'read_all_records',
- },
- );
-
-sub _build_log {
- my $self = shift;
- return Debbugs::Log->new(bug_num => $self->id,
- inner_file => 1,
- );
-}
-
-has spam => (is => 'bare', isa => 'Debbugs::Log::Spam',
- lazy => 1,
- builder => '_build_spam',
- handles => ['is_spam'],
- );
-sub _build_spam {
- my $self = shift;
- return Debbugs::Log::Spam->new(bug_num => $self->id);
-}
-
-has 'package_collection' => (is => 'ro',
- isa => 'Debbugs::Collection::Package',
- builder => '_build_package_collection',
- lazy => 1,
- );
-
-sub _build_package_collection {
- my $self = shift;
- if ($self->has_schema) {
- return Debbugs::Collection::Package->new(schema => $self->schema);
- }
- carp "No schema when building package collection";
- return Debbugs::Collection::Package->new();
-}
-
-has bug_collection => (is => 'ro',
- isa => 'Debbugs::Collection::Bug',
- builder => '_build_bug_collection',
- );
-sub _build_bug_collection {
- my $self = shift;
- if ($self->has_schema) {
- return Debbugs::Collection::Bug->new(schema => $self->schema);
- }
- return Debbugs::Collection::Bug->new();
-}
-
-has correspondent_collection =>
- (is => 'ro',
- isa => 'Debbugs::Collection::Correspondent',
- builder => '_build_correspondent_collection',
- lazy => 1,
- );
-sub _build_correspondent_collection {
- my $self = shift;
- return Debbugs::Collection::Correspondent->new($self->schema_argument);
-}
-
-# package attributes
-for my $attr (qw(packages affects sources)) {
- has $attr =>
- (is => 'rw',
- isa => 'Debbugs::Collection::Package',
- clearer => '_clear_'.$attr,
- builder => '_build_'.$attr,
- lazy => 1,
- );
-}
-
-# bugs
-for my $attr (qw(blocks blocked_by mergedwith)) {
- has $attr =>
- (is => 'ro',
- isa => 'Debbugs::Collection::Bug',
- clearer => '_clear_'.$attr,
- builder => '_build_'.$attr,
- handles => {},
- lazy => 1,
- );
-}
-
-
-for my $attr (qw(owner submitter done)) {
- has $attr,
- (is => 'ro',
- isa => 'Maybe[Debbugs::Correspondent]',
- lazy => 1,
- builder => '_build_'.$attr.'_corr',
- clearer => '_clear_'.$attr.'_corr',
- handles => {$attr.'_url' => $attr.'_url',
- $attr.'_email' => 'email',
- $attr.'_phrase' => 'phrase',
- },
- );
- $meta->add_method('has_'.$attr,
- sub {my $self = shift;
- my $m = $meta->find_method_by_name($attr);
- return defined $m->($self);
- });
- $meta->add_method('_build_'.$attr.'_corr',
- sub {my $self = shift;
- my $m = $self->status->meta->find_method_by_name($attr);
- my $v = $m->($self->status);
- if (defined $v and length($v)) {
- return $self->correspondent_collection->
- get_or_add_by_key($v);
- } else {
- return undef;
- }
- }
- );
-}
-
-sub is_done {
- my $self = shift;
- return $self->has_done;
-}
-
-sub strong_severity {
- my $self = shift;
- return exists $strong_severities->{$self->severity};
-}
-
-sub short_severity {
- $_[0]->severity =~ m/^(.)/;
- return $1;
-}
-
-sub _build_packages {
- my $self = shift;
- return $self->package_collection->
- limit($self->status->package);
-}
-
-sub is_affecting {
- my $self = shift;
- return $self->affects->count > 0;
-}
-
-sub _build_affects {
- my $self = shift;
- return $self->package_collection->
- limit($self->status->affects);
-}
-sub _build_sources {
- my $self = shift;
- return $self->packages->sources->clone;
-}
-
-sub is_owned {
- my $self = shift;
- return defined $self->owner;
-}
-
-sub is_blocking {
- my $self = shift;
- return $self->blocks->count > 0;
-}
-
-sub _build_blocks {
- my $self = shift;
- return $self->bug_collection->
- limit($self->status->blocks);
-}
-
-sub is_blocked {
- my $self = shift;
- return $self->blocked_by->count > 0;
-}
-
-sub _build_blocked_by {
- my $self = shift;
- return $self->bug_collection->
- limit($self->status->blocked_by);
-}
-
-sub is_forwarded {
- length($_[0]->forwarded) > 0;
-}
-
-for my $attr (qw(fixed found)) {
- has $attr =>
- (is => 'ro',
- isa => 'Debbugs::Collection::Version',
- clearer => '_clear_'.$attr,
- builder => '_build_'.$attr,
- handles => {},
- lazy => 1,
- );
-}
-
-sub has_found {
- my $self = shift;
- return any {1} $self->status->found;
-}
-
-sub _build_found {
- my $self = shift;
- return $self->packages->
- get_source_versions($self->status->found);
-}
-
-sub has_fixed {
- my $self = shift;
- return any {1} $self->status->fixed;
-}
-
-sub _build_fixed {
- my $self = shift;
- return $self->packages->
- get_source_versions($self->status->fixed);
-}
-
-sub is_merged {
- my $self = shift;
- return any {1} $self->status->mergedwith;
-}
-
-sub _build_mergedwith {
- my $self = shift;
- return $self->bug_collection->
- limit($self->status->mergedwith);
-}
-
-for my $attr (qw(created modified)) {
- has $attr => (is => 'rw', isa => 'Object',
- clearer => '_clear_'.$attr,
- builder => '_build_'.$attr,
- lazy => 1);
-}
-sub _build_created {
- return DateTime->
- from_epoch(epoch => $_[0]->status->date);
-}
-sub _build_modified {
- return DateTime->
- from_epoch(epoch => max($_[0]->status->log_modified,
- $_[0]->status->last_modified
- ));
-}
-
-has tags => (is => 'ro',
- isa => 'Debbugs::Bug::Tag',
- clearer => '_clear_tags',
- builder => '_build_tags',
- lazy => 1,
- );
-sub _build_tags {
- my $self = shift;
- return Debbugs::Bug::Tag->new(keywords => join(' ',$self->status->tags),
- bug => $self,
- users => $self->bug_collection->users,
- );
-}
-
-has pending => (is => 'ro',
- isa => 'Str',
- clearer => '_clear_pending',
- builder => '_build_pending',
- lazy => 1,
- );
-
-sub _build_pending {
- my $self = shift;
-
- my $pending = 'pending';
- if (length($self->status->forwarded)) {
- $pending = 'forwarded';
- }
- if ($self->tags->tag_is_set('pending')) {
- $pending = 'pending-fixed';
- }
- if ($self->tags->tag_is_set('pending')) {
- $pending = 'fixed';
- }
- # XXX This isn't quite right
- return $pending;
-}
-
-=head2 buggy
-
- $bug->buggy('debbugs/2.6.0-1','debbugs/2.6.0-2');
- $bug->buggy(Debbugs::Version->new('debbugs/2.6.0-1'),
- Debbugs::Version->new('debbugs/2.6.0-2'),
- );
-
-Returns the output of Debbugs::Versions::buggy for a particular
-package, version and found/fixed set. Automatically turns found, fixed
-and version into source/version strings.
-
-=cut
-
-sub buggy {
- my $self = shift;
- my $vertree =
- $self->package_collection->
- universe->versiontree;
- my $max_buggy = 'absent';
- for my $ver (@_) {
- if (not ref($ver)) {
- my @ver_opts = (version => $ver,
- package => $self->status->package,
- package_collection => $self->package_collection,
- $self->schema_arg
- );
- if ($ver =~ m{/}) {
- $ver = Debbugs::Version::Source->(@ver_opts);
- } else {
- $ver = Debbugs::Version::Binary->(@ver_opts);
- }
- }
- $vertree->load($ver->source);
- my $buggy =
- $vertree->buggy($ver,
- [$self->found],
- [$self->fixed]);
- if ($buggy eq 'found') {
- return 'found'
- }
- if ($buggy eq 'fixed') {
- $max_buggy = 'fixed';
- }
- }
- return $max_buggy;
-}
-
-has archiveable =>
- (is => 'ro', isa => 'Bool',
- writer => '_set_archiveable',
- builder => '_build_archiveable',
- clearer => '_clear_archiveable',
- lazy => 1,
- );
-has when_archiveable =>
- (is => 'ro', isa => 'Num',
- writer => '_set_when_archiveable',
- builder => '_build_when_archiveable',
- clearer => '_clear_when_archiveable',
- lazy => 1,
- );
-
-sub _build_archiveable {
- my $self = shift;
- $self->_populate_archiveable(0);
- return $self->archiveable;
-}
-sub _build_when_archiveable {
- my $self = shift;
- $self->_populate_archiveable(1);
- return $self->when_archiveable;
-}
-
-sub _populate_archiveable {
- my $self = shift;
- my ($need_time) = @_;
- $need_time //= 0;
- # Bugs can be archived if they are
- # 1. Closed
- if (not $self->done) {
- $self->_set_archiveable(0);
- $self->_set_when_archiveable(-1);
- return;
- }
- # 2. Have no unremovable tags set
- if (@{$config{removal_unremovable_tags}}) {
- state $unrem_tags =
- {map {($_=>1)} @{$config{removal_unremovable_tags}}};
- for my $tag ($self->tags) {
- if ($unrem_tags->{$tag}) {
- $self->_set_archiveable(0);
- $self->_set_when_archiveable(-1);
- return;
- }
- }
- }
- my $time = time;
- state $remove_time = 24 * 60 * 60 * ($config{removal_age} // 30);
- # 4. Have been modified more than removal_age ago
- my $moded_ago =
- $time - $self->modified->epoch;
- # if we don't need to know when we can archive, we can stop here if it's
- # been modified too recently
- if ($moded_ago < $remove_time) {
- $self->_set_archiveable(0);
- return unless $need_time;
- }
- my @distributions =
- @{$config{removal_default_distribution_tags}};
- if ($self->strong_severity) {
- @distributions =
- @{$config{removal_strong_severity_default_distribution_tags}};
- }
- # 3. Have a maximum buggy of fixed
- my $buggy = $self->buggy($self->packages->
- get_source_versions_distributions(@distributions));
- if ('found' eq $buggy) {
- $self->_set_archiveable(0);
- $self->_set_when_archiveable(-1);
- return;
- }
- my $fixed_ago = $moded_ago;
- # $fixed_ago = $time - $self->when_fixed(@distributions);
- # if ($fixed_ago < $remove_time) {
- # $self->_set_archiveable(0);
- # }
- $self->_set_when_archiveable(($remove_time - min($fixed_ago,$moded_ago)) / (24 * 60 * 60));
- if ($fixed_ago > $remove_time and
- $moded_ago > $remove_time) {
- $self->_set_archiveable(1);
- $self->_set_when_archiveable(0);
- }
- return;
-}
-
-sub filter {
- my $self = shift;
- my %param = validate_with(params => \@_,
- spec => {seen_merged => {type => HASHREF,
- default => sub {return {}},
- },
- repeat_merged => {type => BOOLEAN,
- default => 1,
- },
- include => {type => HASHREF,
- optional => 1,
- },
- exclude => {type => HASHREF,
- optional => 1,
- },
- min_days => {type => SCALAR,
- optional => 1,
- },
- max_days => {type => SCALAR,
- optional => 1,
- },
- },
- );
- if (exists $param{include}) {
- return 1 if not $self->matches($param{include});
- }
- if (exists $param{exclude}) {
- return 1 if $self->matches($param{exclude});
- }
- if (exists $param{repeat_merged} and not $param{repeat_merged}) {
- my @merged = sort {$a<=>$b} $self->bug, $self->status->mergedwith;
- return 1 if first {sub {defined $_}}
- @{$param{seen_merged}}{@merged};
- @{$param{seen_merged}}{@merged} = (1) x @merged;
- }
- if (exists $param{min_days}) {
- return 1 unless $param{min_days} <=
- (DateTime->now() - $self->created)->days();
- }
- if (exists $param{max_days}) {
- return 1 unless $param{max_days} >=
- (DateTime->now() - $self->created)->days();
- }
- return 0;
-
-}
-
-sub __exact_match {
- my ($field, $values) = @_;
- my @ret = first {sub {$_ eq $field}} @{$values};
- return @ret != 0;
-}
-
-sub __contains_match {
- my ($field, $values) = @_;
- foreach my $value (@{$values}) {
- return 1 if (index($field, $value) > -1);
- }
- return 0;
-}
-
-state $field_match =
- {subject => sub {__contains_match($_[0]->subject,@_)},
- tags => sub {
- for my $value (@{$_[1]}) {
- if ($_[0]->tags->is_set($value)) {
- return 1;
- }
- }
- return 0;
- },
- severity => sub {__exact_match($_[0]->severity,@_)},
- pending => sub {__exact_match($_[0]->pending,@_)},
- originator => sub {__exact_match($_[0]->submitter,@_)},
- submitter => sub {__exact_match($_[0]->submitter,@_)},
- forwarded => sub {__exact_match($_[0]->forwarded,@_)},
- owner => sub {__exact_match($_[0]->owner,@_)},
- };
-
-sub matches {
- my ($self,$hash) = @_;
- for my $key (keys %{$hash}) {
- my $sub = $field_match->{$key};
- if (not defined $sub) {
- carp "No subroutine for key: $key";
- next;
- }
- return 1 if $sub->($self,$hash->{$key});
- }
- return 0;
-}
-
-sub email {
- my $self = shift;
- return $self->id.'@'.$config{email_domain};
-}
-
-sub subscribe_email {
- my $self = shift;
- return $self->id.'-subscribe@'.$config{email_domain};
-}
-
-sub url {
- my $self = shift;
- return $config{web_domain}.'/'.$self->id;
-}
-
-sub mbox_url {
- my $self = shift;
- return $config{web_domain}.'/mbox:'.$self->id;
-}
-
-sub mbox_status_url {
- my $self = shift;
- return $self->mbox_url.'?mboxstatus=yes';
-}
-
-sub mbox_maint_url {
- my $self = shift;
- $self->mbox_url.'?mboxmaint=yes';
-}
-
-sub version_url {
- my $self = shift;
- my $url = Debbugs::URI->new('version.cgi?');
- $url->query_form(package => $self->status->package(),
- found => [$self->status->found],
- fixed => [$self->status->fixed],
- @_,
- );
- return $url->as_string;
-}
-
-sub related_packages_and_versions {
- my $self = shift;
- my @packages = $self->status->package;
- my @versions = ($self->status->found,
- $self->status->fixed);
- my @unqualified_versions;
- my @return;
- for my $ver (@versions) {
- if ($ver =~ m{(<src>.+)/(<ver>.+)}) { # It's a src_pkg_ver
- push @return, ['src:'.$+{src}, $+{ver}];
- } else {
- push @unqualified_versions,$ver;
- }
- }
- for my $pkg (@packages) {
- if (@unqualified_versions) {
- push @return,
- [$pkg,@unqualified_versions];
- } else {
- push @return,$pkg;
- }
- }
- return @return;
-}
-
-sub CARP_TRACE {
- my $self = shift;
- return 'Debbugs::Bug={bug='.$self->bug.'}';
-}
-
-__PACKAGE__->meta->make_immutable;
-
-no Mouse;
-1;
-
-
-__END__
-# Local Variables:
-# indent-tabs-mode: nil
-# cperl-indent-level: 4
-# End:
projects / debbugs.git / blobdiff