X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FBug%2FStatus.pm;fp=Debbugs%2FBug%2FStatus.pm;h=0000000000000000000000000000000000000000;hb=1e6633a3780f4fd53fc4303852e84d13cdad2dc6;hp=9209485690059479238bfde03e525917f82d2193;hpb=466f7faff129a5699c7674f59900a92aa256175d;p=debbugs.git diff --git a/Debbugs/Bug/Status.pm b/Debbugs/Bug/Status.pm deleted file mode 100644 index 9209485..0000000 --- a/Debbugs/Bug/Status.pm +++ /dev/null @@ -1,576 +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::Status; - -=head1 NAME - -Debbugs::Bug::Status -- OO interface to status files - -=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 Mouse::Util::TypeConstraints qw(enum); - -use DateTime; -use List::AllUtils qw(max first min); - -use Params::Validate qw(validate_with :types); -use Debbugs::Common qw(make_list); -use Debbugs::Config qw(:config); -use Debbugs::Status qw(get_bug_status); - -use Debbugs::OOTypes; - -use Carp; - -extends 'Debbugs::OOBase'; - -my $meta = __PACKAGE__->meta; - -has bug => (is => 'ro', isa => 'Int', - ); - -# status obtained from DB, filesystem, or hashref -has status_source => (is => 'ro', - isa => enum([qw(db filesystem hashref)]), - default => 'filesystem', - writer => '_set_status_source', - ); - -has _status => (is => 'bare', - writer => '_set_status', - reader => '_status', - predicate => '_has__status', - ); - -my %field_methods; - -sub BUILD { - my $self = shift; - my $args = shift; - state $field_mapping = - {originator => 'submitter', - keywords => 'tags', - msgid => 'message_id', - blockedby => 'blocked_by', - found_versions => 'found', - fixed_versions => 'fixed', - }; - if (not exists $args->{status} and exists $args->{bug}) { - if ($self->has_schema) { - ($args->{status}) = - $self->schema->resultset('BugStatus')-> - search_rs({id => [make_list($args->{bug})]}, - {result_class => 'DBIx::Class::ResultClass::HashRefInflator'})-> - all(); - for my $field (keys %{$field_mapping}) { - $args->{status}{$field_mapping->{$field}} = - $args->{status}{$field} if defined $args->{status}{$field}; - delete $args->{status}{$field}; - } - $self->_set_status_source('db'); - } else { - $args->{status} = get_bug_status(bug=>$args->{bug}); - for my $field (keys %{$field_mapping}) { - $args->{status}{$field_mapping->{$field}} = - $args->{status}{$field} if defined $args->{status}{$field}; - } - $self->_set_status_source('filesystem'); - } - } elsif (exists $args->{status}) { - for my $field (keys %{$field_mapping}) { - $args->{status}{$field_mapping->{$field}} = - $args->{status}{$field} if defined $args->{status}{$field}; - } - $self->_set_status_source('hashref'); - } - if (exists $args->{status}) { - if (ref($args->{status}) ne 'HASH') { - croak "status must be a HASHREF (argument to __PACKAGE__)"; - } - $self->_set_status($args->{status}); - delete $args->{status}; - } -} - -has saved => (is => 'ro', isa => 'Bool', - default => 0, - writer => '_set_set_saved', - ); - -sub __field_or_def { - my ($self,$field,$default) = @_; - if ($self->_has__status) { - my $s = $self->_status()->{$field}; - return $s if defined $s; - } - return $default; -} - -=head2 Status Fields - -=cut - -=head3 Single-value Fields - -=over - -=item submitter (single) - -=cut - -has submitter => - (is => 'ro', - isa => 'Str', - builder => - sub { - my $self = shift; - $self->__field_or_def('submitter', - $config{maintainer_email}); - }, - lazy => 1, - writer => '_set_submitter', - ); - -=item date (single) - -=cut - -has date => - (is => 'ro', - isa => 'Str', - builder => - sub { - my $self = shift; - $self->__field_or_def('date', - time); - }, - lazy => 1, - writer => '_set_date', - ); - -=item last_modified (single) - -=cut - -has last_modified => - (is => 'ro', - isa => 'Str', - builder => - sub { - my $self = shift; - $self->__field_or_def('last_modified', - time); - }, - lazy => 1, - writer => '_set_last_modified', - ); - -=item log_modified (single) - -=cut - -has log_modified => - (is => 'ro', - isa => 'Str', - builder => - sub { - my $self = shift; - $self->__field_or_def('log_modified', - time); - }, - lazy => 1, - writer => '_set_log_modified', - ); - - -=item subject - -=cut - -has subject => - (is => 'ro', - isa => 'Str', - builder => - sub { - my $self = shift; - $self->__field_or_def('subject', - 'No subject'); - }, - lazy => 1, - writer => '_set_subject', - ); - -=item message_id - -=cut - -has message_id => - (is => 'ro', - isa => 'Str', - lazy => 1, - builder => - sub { - my $self = shift; - $self->__field_or_def('message_id', - 'nomessageid.'.$self->date.'_'. - md5_hex($self->subject.$self->submitter). - '@'.$config{email_domain}, - ); - }, - writer => '_set_message_id', - ); - - -=item done - -=item severity - -=cut - -has severity => - (is => 'ro', - isa => 'Str', - lazy => 1, - builder => - sub { - my $self = shift; - $self->__field_or_def('severity', - $config{default_severity}); - }, - writer => '_set_severity', - ); - -=item unarchived - -Unix epoch the bug was last unarchived. Zero if the bug has never been -unarchived. - -=cut - -has unarchived => - (is => 'ro', - isa => 'Int', - lazy => 1, - builder => - sub { - my $self = shift; - $self->__field_or_def('unarchived', - 0); - }, - writer => '_set_unarchived', - ); - -=item archived - -True if the bug is archived, false otherwise. - -=cut - -has archived => - (is => 'ro', - isa => 'Int', - lazy => 1, - builder => - sub { - my $self = shift; - $self->__field_or_def('archived', - 0); - }, - writer => '_set_archived', - ); - -=item owner - -=item summary - -=item outlook - -=item done - -=item forwarded - -=cut - -for my $field (qw(owner unarchived summary outlook done forwarded)) { - has $field => - (is => 'ro', - isa => 'Str', - builder => - sub { - my $self = shift; - $self->__field_or_def($field, - ''); - }, - writer => '_set_'.$field, - lazy => 1, - ); - my $field_method = $meta->find_method_by_name($field); - die "No field method for $field" unless defined $field_method; - $meta->add_method('has_'.$field => - sub {my $self = shift; - return length($field_method->($self)); - }); -} - -=back - -=head3 Multi-value Fields - -=over - -=item affects - -=item package - -=item tags - -=cut - -for my $field (qw(affects package tags)) { - has '_'.$field => - (is => 'ro', - traits => [qw(Array)], - isa => 'ArrayRef[Str]', - builder => - sub { - my $self = shift; - if ($self->_has__status) { - my $s = $self->_status()->{$field}; - if (!ref($s)) { - $s = _build_split_field($s, - $field); - } - return $s; - } - return []; - }, - writer => '_set_'.$field, - handles => {$field => 'elements', - $field.'_count' => 'count', - $field.'_join' => 'join', - }, - lazy => 1, - ); - my $field_method = $meta->find_method_by_name($field); - if (defined $field_method) { - $meta->add_method($field.'_ref'=> - sub {my $self = shift; - return [$field_method->($self)] - }); - } -} - -=item found - -=item fixed - -=cut - -sub __hashref_field { - my ($self,$field) = @_; - - if ($self->_has__status) { - my $s = $self->_status()->{$field}; - if (!ref($s)) { - $s = _build_split_field($s, - $field); - } - return $s; - } - return []; -} - -for my $field (qw(found fixed)) { - has '_'.$field => - (is => 'ro', - traits => ['Hash'], - isa => 'HashRef[Str]', - builder => - sub { - my $self = shift; - if ($self->_has__status) { - my $s = $self->_status()->{$field}; - if (!ref($s)) { - $s = _build_split_field($s, - $field); - } - if (ref($s) ne 'HASH') { - $s = {map {$_,'1'} @{$s}}; - } - return $s; - } - return {}; - }, - default => sub {return {}}, - writer => '_set_'.$field, - handles => {$field => 'keys', - $field.'_count' => 'count', - }, - lazy => 1, - ); - my $field_method = $meta->find_method_by_name($field); - if (defined $field_method) { - $meta->add_method('_'.$field.'_ref'=> - sub {my $self = shift; - return [$field_method->($self)] - }); - $meta->add_method($field.'_join'=> - sub {my ($self,$joiner) = @_; - return join($joiner,$field_method->($self)); - }); - } -} - - -for (qw(found fixed)) { - around '_set_'.$_ => sub { - my $orig = shift; - my $self = shift; - if (defined ref($_[0]) and - ref($_[0]) eq 'ARRAY' - ) { - @_ = {map {$_,'1'} @{$_[0]}}; - } elsif (@_ > 1) { - @_ = {map {$_,'1'} @_}; - } - $self->$orig(@_); - }; -} - - - -=item mergedwith - -=item blocks - -=item blocked_by - -=cut - -for my $field (qw(blocks blocked_by mergedwith)) { - has '_'.$field => - (is => 'ro', - traits => ['Hash'], - isa => 'HashRef[Int]', - builder => - sub { - my $self = shift; - if ($self->_has__status) { - my $s = $self->_status()->{$field}; - if (!ref($s)) { - $s = _build_split_field($s, - $field); - } - if (ref($s) ne 'HASH') { - $s = {map {$_,'1'} @{$s}}; - } - return $s; - } - return {}; - }, - handles => {$field.'_count' => 'count', - }, - writer => '_set_'.$field, - lazy => 1, - ); - my $internal_field_method = $meta->find_method_by_name('_'.$field); - die "No field method for _$field" unless defined $internal_field_method; - $meta->add_method($field => - sub {my $self = shift; - return sort {$a <=> $b} - keys %{$internal_field_method->($self)}; - }); - my $field_method = $meta->find_method_by_name($field); - die "No field method for _$field" unless defined $field_method; - $meta->add_method('_'.$field.'_ref'=> - sub {my $self = shift; - return [$field_method->($self)] - }); - $meta->add_method($field.'_join'=> - sub {my ($self,$joiner) = @_; - return join($joiner,$field_method->($self)); - }); -} - -for (qw(blocks blocked_by mergedwith)) { - around '_set_'.$_ => sub { - my $orig = shift; - my $self = shift; - if (defined ref($_[0]) and - ref($_[0]) eq 'ARRAY' - ) { - $_[0] = {map {$_,'1'} @{$_[0]}}; - } elsif (@_ > 1) { - @_ = {map {$_,'1'} @{$_[0]}}; - } - $self->$orig(@_); - }; -} - -=back - -=cut - -sub _build_split_field { - sub sort_and_unique { - my @v; - my %u; - my $all_numeric = 1; - for my $v (@_) { - if ($all_numeric and $v =~ /\D/) { - $all_numeric = 0; - } - next if exists $u{$v}; - $u{$v} = 1; - push @v, $v; - } - if ($all_numeric) { - return sort {$a <=> $b} @v; - } else { - return sort @v; - } - } - sub split_ditch_empty { - return grep {length $_} map {split ' '} @_; - - } - my ($val,$field) = @_; - $val //= ''; - - if ($field =~ /^(package|affects|source)$/) { - return [grep {length $_} map lc, split /[\s,()?]+/, $val]; - } else { - return [sort_and_unique(split_ditch_empty($val))]; - } -} - - -__PACKAGE__->meta->make_immutable; - -no Mouse; -no Mouse::Util::TypeConstraints; -1; - - -__END__ -# Local Variables: -# indent-tabs-mode: nil -# cperl-indent-level: 4 -# End: