X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FBug.pm;fp=Debbugs%2FBug.pm;h=0000000000000000000000000000000000000000;hb=1e6633a3780f4fd53fc4303852e84d13cdad2dc6;hp=21a26e39af2c443e34c0b260887d29146f1fc225;hpb=466f7faff129a5699c7674f59900a92aa256175d;p=debbugs.git diff --git a/Debbugs/Bug.pm b/Debbugs/Bug.pm deleted file mode 100644 index 21a26e3..0000000 --- a/Debbugs/Bug.pm +++ /dev/null @@ -1,678 +0,0 @@ -# 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 . - -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{(.+)/(.+)}) { # 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: