From 0e16a5214d3617d0df54712869b2da0f3c64fcdb Mon Sep 17 00:00:00 2001 From: Don Armstrong Date: Tue, 1 May 2018 11:20:09 -0700 Subject: [PATCH] add start of Mouse/Moose based OO Interface to packages --- Debbugs/Bug.pm | 431 ++++++++++++++++++++++++++++++++++ Debbugs/Bug/Tag.pm | 91 +++++++ Debbugs/Collection.pm | 167 +++++++++++++ Debbugs/Collection/Bug.pm | 111 +++++++++ Debbugs/Collection/Package.pm | 82 +++++++ Debbugs/OOBase.pm | 39 +++ Debbugs/OOTypes.pm | 58 +++++ Debbugs/Package.pm | 136 +++++++++++ Debbugs/Version.pm | 142 +++++++++++ t/22_oo_interface.t | 104 ++++++++ 10 files changed, 1361 insertions(+) create mode 100644 Debbugs/Bug.pm create mode 100644 Debbugs/Bug/Tag.pm create mode 100644 Debbugs/Collection.pm create mode 100644 Debbugs/Collection/Bug.pm create mode 100644 Debbugs/Collection/Package.pm create mode 100644 Debbugs/OOBase.pm create mode 100644 Debbugs/OOTypes.pm create mode 100644 Debbugs/Package.pm create mode 100644 Debbugs/Version.pm create mode 100644 t/22_oo_interface.t diff --git a/Debbugs/Bug.pm b/Debbugs/Bug.pm new file mode 100644 index 0000000..05d03ac --- /dev/null +++ b/Debbugs/Bug.pm @@ -0,0 +1,431 @@ +# 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); + +use Debbugs::Config qw(:config); +use Debbugs::Status qw(read_bug); +use Debbugs::Bug::Tag; +use Debbugs::Collection::Package; +use Debbugs::Collection::Bug; + +use Debbugs::OOTypes; + +extends 'Debbugs::OOBase'; + +state $strong_severities = + {map {($_,1)} @{$config{strong_severities}}}; + +has bug => (is => 'ro', isa => 'Int', + required => 1, + ); + +has saved => (is => 'ro', isa => 'Bool', + default => 0, + writer => '_set_saved', + ); + +has status => (is => 'ro', isa => 'HashRef', + lazy => 1, + builder => '_build_status', + ); + +sub _build_status { + my $self = shift; + $self->reset; + my $status = read_bug(bug=>$self->bug) or + confess("Unable to read bug ".$self->bug); + return $status; +} + +has 'package_collection' => (is => 'ro', + isa => 'Debbugs::Collection::Package', + builder => '_build_package_collection', + lazy => 1, + ); + +sub _build_package_collection { + return Debbugs::Collection::Package->new(); +} +has bug_collection => (is => 'ro', + isa => 'Debbugs::Collection::Bug', + builder => '_build_bug_collection', + ); +sub _build_bug_collection { + return Debbugs::Collection::Bug->new(); +} + + +sub reset { + my $self = shift; + $self->_clear_done(); + $self->_clear_severity(); + $self->_clear_packages(); + $self->_clear_sources(); + $self->_clear_affects(); + $self->_clear_blocks(); + $self->_clear_blockedby(); + $self->_clear_found(); + $self->_clear_fixed(); + $self->_clear_mergedwith(); + $self->_clear_pending(); + $self->_clear_location(); + $self->_clear_archived(); + $self->_clear_archiveable(); + $self->_clear_when_archiveable(); + $self->_clear_submitter(); + $self->_clear_created(); + $self->_clear_modified(); + $self->_set_saved(1); +} + +sub _clear_saved_if_changed { + my ($self,$new,$old) = @_; + if (@_ > 2) { + if ($new ne $old) { + $self->_set_saved(0); + } + } +} + +# package attributes +for my $attr (qw(packages affects sources)) { + has $attr => + (is => 'rw', + isa => 'Debbugs::Collection::Package', + clearer => '_clear_'.$attr, + builder => '_build_'.$attr, + trigger => \&_clear_saved_if_changed, + lazy => 1, + ); +} + +# bugs +for my $attr (qw(blocks blockedby mergedwith)) { + has $attr => + (is => 'bare', + isa => 'Debbugs::Collection::Bug', + clearer => '_clear_'.$attr, + builder => '_build_'.$attr, + handles => {}, + lazy => 1, + ); +} + + + +for my $attr (qw(done severity), + qw(found fixed), + qw(pending location submitter), + ) { + has $attr => + (is => 'rw', + isa => 'Str', + clearer => '_clear_'.$attr, + builder => '_build_'.$attr, + trigger => \&_clear_saved_if_changed, + lazy => 1, + ); +} + +sub is_done { + return length $_[0]->done?1:0; +} +sub _build_done { + return $_[0]->status->{done} // ''; +} + +sub _build_severity { + return $_[0]->status->{severity} // $config{default_severity}; +} + +sub strong_severity { + my $self = shift; + return exists $strong_severities->{$self->severity}; +} + +sub package { + local $_; + return join(', ',map {$_->name} $_[0]->packages); +} + +sub _build_packages { + return [$_[0]->package_collection-> + get_package($_[0]->status->{package} // + '') + ]; +} + +sub affect { + local $_; + return join(', ',map {$_->name} $_[0]->affects->members); +} + +sub _build_affects { + return [$_[0]->package_collection-> + get_package($_[0]->status->{affects} // + '') + ]; +} +sub source { + local $_; + return join(', ',map {$_->name} $_[0]->sources->members); +} +sub _build_sources { + local $_; + my @sources = map {$_->sources} $_[0]->packages; +} + + +sub _split_if_defined { + my ($self,$field,$split) = @_; + $split //= ' '; + my $e = $self->status->{$field}; + my @f; + if (defined $e and + length $e) { + return split /$split/,$e; + } + return (); +} + +sub _build_blocks { + my $self = shift; + return $self->bug_collection-> + limit_or_create(sort {$a <=> $b} + $self->_split_if_defined('blocks')); +} + +sub _build_blockedby { + my $self = shift; + return $self->bug_collection-> + limit_or_create(sort {$a <=> $b} + $self->_split_if_defined('blockedby')); +} + +sub _build_found { + my $self = shift; + return $self->sources-> + versions($self->_split_if_defined('found',',\s*')); +} + + +sub _build_fixed { + my $self; + return $self->sources-> + versions($self->_split_if_defined('fixed',',\s*')); +} +sub _build_mergedwith { + my $self = shift; + return $self->bug_collection-> + limit_or_create(sort {$a <=> $b} + $self->_split_if_defined('mergedwith')); +} +sub _build_pending { + return $_[0]->status->{pending} // ''; +} +sub _build_submitter { + return $_[0]->status->{originator} // ''; +} + +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} // time); +} +sub _build_modified { + return DateTime-> + from_epoch(epoch => max($_[0]->status->{log_modified}, + $_[0]->status->{last_modified} + )); +} +sub _build_location { + return $_[0]->status->{location}; +} +has archived => (is => 'ro', isa => 'Bool', + clearer => '_clear_archived', + builder => '_build_archived', + lazy => 1); +sub _build_archived { + return $_[0]->location eq 'archived'?1:0; +} + +has tags => (is => 'ro', isa => 'Object', + clearer => '_clear_tags', + builder => '_build_tags', + lazy => 1, + ); +sub _build_tags { + return Debbugs::Bug::Tag->new($_[0]->status->{keywords}); +} + +=item 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-> + versions; + my $max_buggy = 'absent'; + for my $ver (@_) { + if (not ref($ver)) { + $ver = Debbugs::Version-> + new(string => $ver, + package_collection => $self->package_collection, + ); + } + $vertree->load($ver->source); + my $buggy = + $vertree->tree-> + buggy($ver->srcver, + [map {$_->srcver} $self->found], + [map {$_->srcver} $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}; + # 4. Have been modified more than removal_age ago + my $moded_ago = + $time - $self->last_modified; + # 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->package-> + dist_source_versions(@distributions)); + if ('found' eq $buggy) { + $self->_set_archiveable(0); + $self->_set_when_archiveable(-1); + return; + } + my $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; +} + + +no Mouse; +1; + + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/Debbugs/Bug/Tag.pm b/Debbugs/Bug/Tag.pm new file mode 100644 index 0000000..8ed9246 --- /dev/null +++ b/Debbugs/Bug/Tag.pm @@ -0,0 +1,91 @@ +# 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::Tag; + +=head1 NAME + +Debbugs::Bug::Tag -- OO interface to bug tags + +=head1 SYNOPSIS + + use Debbugs::Bug::Tag; + +=head1 DESCRIPTION + + + +=cut + +use Mouse; +use strictures 2; +use namespace::clean; +use v5.10; # for state + +use Debbugs::Config qw(:config); + +state $valid_tags = + {map {($_,1)} @{$config{tags}}}; + +extends 'Debbugs::OOBase'; + +around BUILDARGS => sub { + my $orig = shift; + my $class = shift; + if (@_ == 1 && !ref $_[0]) { + my @tags = split / /,$_[0]; + my %tags; + @tags{@tags} = (1) x @tags; + return $class->$orig(tags => \%tags); + } else { + return $class->$orig(@_); + } +}; + +has tags => (is => 'ro', isa => 'HashRef[Str]', + default => sub {{}}, + ); +has usertags => (is => 'ro',isa => 'HashRef[Str]', + default => sub {{}}, + ); + +sub tag_is_set { + return exists $_[0]->tags->{$_[1]} ? 1 : 0; +} + +sub unset_tag { + my $self = shift; + delete $self->tags->{$_} foreach @_; +} + +sub set_tag { + my $self = shift; + for my $tag (@_) { + if (not $self->valid_tag($tag)) { + confess("Invalid tag $tag"); + } + $self->tags->{$tag} = 1; + } + return $self; +} + +sub valid_tag { + return exists $valid_tags->{$_[1]}?1:0; +} + +sub as_string { + return join(' ',sort keys %{$_[0]->tags}) +} + +no Mouse; +1; + + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/Debbugs/Collection.pm b/Debbugs/Collection.pm new file mode 100644 index 0000000..ee478c6 --- /dev/null +++ b/Debbugs/Collection.pm @@ -0,0 +1,167 @@ +# 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::Collection; + +=head1 NAME + +Debbugs::Collection -- Collection base class which can generate lots of objects + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + + + +=cut + +use Mouse; +use strictures 2; +use namespace::autoclean; + +extends 'Debbugs::OOBase'; + +has 'members' => (is => 'bare', + isa => 'ArrayRef', + traits => ['Array'], + default => sub {[]}, + writer => '_set_members', + handles => {_add => 'push', + members => 'elements', + count => 'count', + _get_member => 'get', + grep => 'grep', + apply => 'apply', + sort => 'sort', + }, + ); + +has 'member_hash' => (traits => ['Hash'], + is => 'ro', + isa => 'HashRef[Int]', + lazy => 1, + reader => '_member_hash', + builder => '_build_member_hash', + clearer => '_clear_member_hash', + predicate => '_has_member_hash', + handles => {_add_member_hash => 'set', + _member_key_exists => 'exists', + _get_member_hash => 'get', + }, + ); + +has 'universe' => (is => 'ro', + isa => 'Debbugs::Collection', + required => 1, + builder => '_build_universe', + writer => '_set_universe', + predicate => 'has_universe', + ); + +sub _build_universe { + # By default, the universe is myself + return $_[0]; +} + +sub limit { + my $self = shift; + my $limit = $self->clone(); + # Set the universe to whatever my universe is (potentially myself) + $limit->_set_universe($self->universe); + $limit->_set_members(); + $limit->_clear_member_hash(); + $limit->add($self->universe->get_or_create(@_)); + return $limit; +} + +sub get_or_create { + my $self = shift; + my @return; + my @exists; + my @need_to_add; + for my $i (0..$#_) { + # we assume that if it's already a blessed reference, that it's the right + if (blessed($_[$i])) { + $return[$i] = + $_[$i]; + } + elsif ($self->_member_key_exists($_[$i])) { + push @exists,$i; + } else { + push @need_to_add,$i; + } + } + # create and add by key + @return[@need_to_add] = + $self->add_by_key(@_[@need_to_add]); + @return[@exists] = + $self->get(@_[@exists]); + return @return; +} + +has 'constructor_args' => (is => 'rw', + isa => 'ArrayRef', + default => sub {[]}, + ); + +sub add_by_key { + my $self = shift; + # we'll assume that add does the right thing. around this in subclasses + return $self->add(@_); +} + +sub add { + my $self = shift; + my @members_to_add; + for my $member (@_) { + if ($self->exists($member)) { + next; + } + $self->_add($member); + $self->_add_member_hash($self->member_key($member), + $self->count(), + ); + } + $self->_add(@members_to_add); + return @members_to_add; +} + +sub get { + my $self = shift; + return $self->_get_member($self->_get_member_hash(@_)); +} + + +sub member_key { + return $_[1]; +} + +sub exists { + my $self = shift; + return $self->_member_key_exists($self->member_key($_[0])); +} + +sub _build_member_hash { + my $self = shift; + my $hash = {}; + my $i = 0; + for my $member ($self->members) { + $hash->{$self->member_key($member)} = + $i++; + } + return $hash; +} + +__PACKAGE__->meta->make_immutable; + +1; + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/Debbugs/Collection/Bug.pm b/Debbugs/Collection/Bug.pm new file mode 100644 index 0000000..08f7a66 --- /dev/null +++ b/Debbugs/Collection/Bug.pm @@ -0,0 +1,111 @@ +# 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::Collection::Bug; + +=head1 NAME + +Debbugs::Collection::Bug -- Bug generation factory + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + + + +=cut + +use Mouse; +use strictures 2; +use namespace::autoclean; +use Debbugs::Common qw(make_list hash_slice); +use Debbugs::OOTypes; +use Debbugs::Status qw(get_bug_statuses); + +extends 'Debbugs::Collection'; + +has '+members' => (isa => 'ArrayRef[Bug]'); +has 'package_collection' => (is => 'rw', + isa => 'Debbugs::Collection::Package', + default => sub {Debbugs::Collection::Package->new()} + ); + +around BUILDARGS => sub { + my $orig = shift; + my $class = shift; + + my %args; + if (@_==1 and ref($_[0]) eq 'HASH') { + %args = %{$_[0]}; + } else { + %args = @_; + } + $args{members} //= []; + if (exists $args{bugs}) { + push @{$args{members}}, + _member_constructor(bugs => $args{bugs}, + hash_slice(%args,qw(schema constructor_args)), + ); + delete $args{bugs}; + } + return $class->$orig(%args); +}; + +sub _member_constructor { + # handle being called $self->_member_constructor; + if ((@_ % 2) == 1) { + shift; + } + my %args = @_; + my @return; + if (exists $args{schema}) { + my $statuses = get_bug_statuses(bug => [make_list($args{bugs})], + schema => $args{schema}, + ); + while (my ($bug, $status) = each %{$statuses}) { + push @return, + Debbugs::Bug->new(bug=>$bug, + status=>$status, + schema=>$args{schema}, + @{$args{constructor_args}//[]}, + ); + } + } else { + for my $bug (make_list($args{bugs})) { + push @return, + Debbugs::Bug->new(bug => $bug, + @{$args{constructor_args}//[]}, + ); + } + } + return @return; +} + +around add_by_key => sub { + my $orig = shift; + my $self = shift; + my @members = + _member_constructor(bugs => [@_], + $self->has_schema?(schema => $self->schema):(), + constructor_args => $self->constructor_args, + ); + return $self->$orig(@members); +}; + +sub member_key { + return $_[1]->bug; +} + +__PACKAGE__->meta->make_immutable; + +1; + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/Debbugs/Collection/Package.pm b/Debbugs/Collection/Package.pm new file mode 100644 index 0000000..0459b1e --- /dev/null +++ b/Debbugs/Collection/Package.pm @@ -0,0 +1,82 @@ +# 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::Collection::Package; + +=head1 NAME + +Debbugs::Collection::Package -- Package generation factory + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + + + +=cut + +use Mouse; +use strictures 2; +use namespace::autoclean; +use Debbugs::Common qw(make_list); +use Debbugs::OOTypes; +use Debbugs::Status qw(get_bug_statuses); + +extends 'Debbugs::Collection'; + +has '+members' => (isa => 'ArrayRef[Package]'); + +around BUILDARGS => sub { + my $orig = shift; + my $class = shift; + + my %args; + if (@_==1 and ref($_[0]) eq 'HASH') { + %args = %{$_[0]}; + } else { + %args = @_; + } + $args{members} //= []; + if (exists $args{packages}) { + if (exists $args{schema}) { + my $statuses = get_bug_statuses(bug => [make_list($args{bugs})], + schema => $args{schema}, + ); + while (my ($bug, $status) = each %{$statuses}) { + push @{$args{members}}, + Debbugs::Bug->new(bug=>$bug, + status=>$status, + schema=>$args{schema}, + @{$args{constructor_args}//[]}, + ); + } + } else { + for my $bug (make_list($args{bugs})) { + push @{$args{members}}, + Debbugs::Bug->new(bug => $bug, + @{$args{constructor_args}//[]}, + ); + } + } + delete $args{bugs}; + } + return $class->$orig(%args); +}; + +sub member_key { + return $_[1]->bug; +} + +__PACKAGE__->meta->make_immutable; + +1; + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/Debbugs/OOBase.pm b/Debbugs/OOBase.pm new file mode 100644 index 0000000..37896bc --- /dev/null +++ b/Debbugs/OOBase.pm @@ -0,0 +1,39 @@ +# 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::OOBase; + +=head1 NAME + +Debbugs::OOBase -- OO Base class for Debbugs + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + + + +=cut + +use Mouse; +use strictures 2; +use namespace::autoclean; + +has schema => (is => 'ro', isa => 'Object', + required => 0, + predicate => 'has_schema', + ); + +__PACKAGE__->meta->make_immutable; + +1; + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/Debbugs/OOTypes.pm b/Debbugs/OOTypes.pm new file mode 100644 index 0000000..37473d0 --- /dev/null +++ b/Debbugs/OOTypes.pm @@ -0,0 +1,58 @@ +# 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::OOTypes; + +=head1 NAME + +Debbugs::OOTypes -- OO Types for Debbugs + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + + + +=cut + +use Mouse::Util::TypeConstraints; +use strictures 2; +use namespace::autoclean; + +# Bug Subtype +subtype 'Bug' => + as 'Debbugs::Bug'; + +coerce 'Bug' => + from 'Int' => + via {Debbugs::Bug->new($_)}; + +# Package Subtype +subtype 'Package' => + as 'Debbugs::Package'; + +coerce 'Package' => + from 'Str' => + via {Debbugs::Package->new(package => $_)}; + + +# Version Subtype +subtype 'Version' => + as 'Debbugs::Version'; + +coerce 'Version' => + from 'Str' => + via {Debbugs::Version->new(string=>$_)}; + +no Mouse::Util::TypeConstraints; +1; + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/Debbugs/Package.pm b/Debbugs/Package.pm new file mode 100644 index 0000000..d73474c --- /dev/null +++ b/Debbugs/Package.pm @@ -0,0 +1,136 @@ +# This module is part of debbugs, and +# is released under the terms of the GPL version 3, or any later +# version (at your option). See the file README and COPYING for more +# information. +# Copyright 2018 by Don Armstrong . + +package Debbugs::Package; + +=head1 NAME + +Debbugs::Package -- OO interface to packages + +=head1 SYNOPSIS + + use Debbugs::Package; + Debbugs::Package->new(schema => $s,binaries => [qw(foo)],sources => [qw(bar)]); + +=head1 DESCRIPTION + + + +=cut + +use warnings; +use strict; + +use Mouse; + +use Debbugs::Version; + +extends 'Debbugs::OOBase'; + +has name => (is => 'ro', isa => 'Str', + lazy => 1, + required => 1, + builder => '_build_name', + ); + +has type => (is => 'ro', isa => 'Str', + lazy => 1, + builder => '_build_type', + clearer => '_clear_type', + ); + +has valid => (is => 'ro', isa => 'Bool', + lazy => 1, + builder => '_build_valid', + writer => '_set_valid', + ); + +has 'sources' => (is => 'ro',isa => 'Array'); +has 'dists' => (is => 'ro',isa => 'Array'); + +has 'versions' => (is => 'ro',isa => 'Array'); + +# gets used to retrieve packages +has 'package_collection' => (is => 'ro', + isa => 'Debbugs::Collection::Package', + builder => '_build_package_collection', + lazy => 1, + ); + +sub _build_package_collection { + return Debbugs::Collection::Package->new(); +} + +sub populate { + my $self = shift; + + my @binaries = $self->binaries; + my @sources = $self->sources; + my $s = $self->schema; + carp "No schema" unless $self->schema; + + my $src_rs = $s->resultset('SrcVer')-> + search({'src_pkg.pkg'=>[$self->sources], + -or => {'suite.codename' => [make_list($param{dist})], + 'suite.suite_name' => [make_list($param{dist})], + } + }, + {join => ['src_pkg', + { + src_associations=>'suite'}, + ], + '+select' => [qw(src_pkg.pkg), + qw(suite.codename), + qw(src_associations.modified), + q(CONCAT(src_pkg.pkg,'/',me.ver))], + '+as' => ['src_pkg_name','codename', + 'modified_time', + qw(src_pkg_ver)], + result_class => 'DBIx::Class::ResultClass::HashRefInflator', + order_by => {-desc => 'me.ver'}, + }, + ); + +} + +sub packages { + my $self = shift; + $self->populate() unless $self->initialized; +} + +sub versions { + my $self = shift; + $self->populate() unless $self->initialized; +} + + +package Debbugs::Package::Version; + +use base qw(Class::Accessor); +__PACKAGE__->mk_ro_accessors(qw(schema )); + +sub version { +} + +sub type { + +} + +sub + +package Debbugs::Package::Package; + +package Debbugs::Package::Maintainer; + + +1; + + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/Debbugs/Version.pm b/Debbugs/Version.pm new file mode 100644 index 0000000..58a643c --- /dev/null +++ b/Debbugs/Version.pm @@ -0,0 +1,142 @@ +# 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::Version; + +=head1 NAME + +Debbugs::Version -- OO interface to Version + +=head1 SYNOPSIS + + use Debbugs::Version; + Debbugs::Version->new(schema => $s,binaries => [qw(foo)],sources => [qw(bar)]); + +=head1 DESCRIPTION + + + +=cut + +use Mouse; +use strictures 2; +use namespace::autoclean; + +use Debbugs::Collection::Package; +use Debbugs::OOTypes; + +extends 'Debbugs::OOBase'; + +state $strong_severities = + {map {($_,1)} @{$config{strong_severities}}}; + +has version => (is => 'ro', isa => 'Str', + required => 1, + builder => '_build_version', + predicate => '_has_version', + ); + +has source_version => (is => 'ro', + isa => 'Str', + builder => '_build_source_version', + predicate => '_has_source_version', + clearer => '_clear_source_version', + ); + +has source => (is => 'ro', + isa => 'Debbugs::Package', + lazy => 1, + writer => 'set_source', + builder => '_build_source', + predicate => '_has_source', + clearer => '_clear_source', + ); + +has packages => (is => 'rw', + isa => 'Debbugs::Collection::Package', + writer => 'set_package', + builder => '_build_package', + predicate => '_has_package', + clearer => '_clear_package', + ); + +has 'package_collection' => (is => 'ro', + isa => 'Debbugs::Collection::Package', + builder => '_build_package_collection', + lazy => 1, + ); + +sub _build_package_collection { + return Debbugs::Collection::Package->new(); +} + +# one of source_version or version must be provided + +sub BUILD { + my $self = shift; + my $args = shift; + if (not $self->_has_version and + not $self->_has_source_version) { + confess("Version objects must have at least a source version or a version"); + } + if ($self->_has_source and + $self->source->is_source + ) { + confess("You have provided a source package which is not a source package"); + } +} + +sub _build_version { + my $self = shift; + my $srcver = $self->source_version; + $srcver =~ s{.+/}{}; + return $srcver; +} + +sub _build_source_version { + my $self = shift; + # should we verify that $self->source is a valid package? + my $src = $self->source; + if ($src->is_valid) { + return $self->source->name.'/'.$self->version; + } + # do we want invalid sources to be in parenthesis? + return $self->version; +} + +sub _build_source { + my $self = shift; + if ($self->_has_binaries) { + # this should be the standard case + if ($self->binaries->sources->count == 1) { + return $self->binaries->sources->first(sub {1}); + } + # might need to figure out how to speed up limit_by_version + return $self->binaries->limit_by_version($self->version)-> + sources; + } + confess("No binary package, cannot know what source package this version is for"); +} + +sub _build_packages { + my $self = shift; + if ($self->_has_source) { + return $self->package_collection-> + get_or_create($self->source->binaries,$self->source); + } + confess("No source package, cannot know what binary packages this version is for"); +} + +__PACKAGE__->meta->make_immutable; +no Mouse; +1; + + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/t/22_oo_interface.t b/t/22_oo_interface.t new file mode 100644 index 0000000..a14b685 --- /dev/null +++ b/t/22_oo_interface.t @@ -0,0 +1,104 @@ +# -*- mode: cperl;-*- + +use Test::More; + +use warnings; +use strict; + +# Here, we're going to shoot messages through a set of things that can +# happen. + +# First, we're going to send mesages to receive. +# To do so, we'll first send a message to submit, +# then send messages to the newly created bugnumber. + +use IO::File; +use File::Temp qw(tempdir); +use Cwd qw(getcwd); +use Debbugs::MIME qw(create_mime_message); +use File::Basename qw(dirname basename); +use Test::WWW::Mechanize; +use HTTP::Status qw(RC_NOT_MODIFIED); +# The test functions are placed here to make things easier +use lib qw(t/lib); +use DebbugsTest qw(:all); + +# This must happen before anything is used, otherwise Debbugs::Config will be +# set to wrong values. +my %config = create_debbugs_configuration(); + +my $tests = 0; +use_ok('Debbugs::Bug'); +$tests++; +use_ok('Debbugs::Collection::Bug'); +$tests++; + +# create 4 bugs +for (1..4) { + send_message(to=>'submit@bugs.something', + headers => [To => 'submit@bugs.something', + From => 'foo@bugs.something', + Subject => 'Submitting a bug '.$_, + ], + run_processall => ($_ == 4 ? 1 : 0), + body => <new(bugs => [1..4]); + +my $bug; +ok($bug = $bc->get(1), + "Created a bug correctly" + ); +$tests++; + +ok(!$bug->archiveable, + "Newly created bugs are not archiveable" + ); +$tests++; + +is($bug->submitter,'foo@bugs.something', + "Submitter works" + ); +$tests++; + +ok($bug->tags->tag_is_set('wontfix'), + "Wontfix tag set" + ); +$tests++; + +is($bug->tags->as_string(), + 'moreinfo wontfix', + "as_string works" + ); +$tests++; + +### run some tests with the database creation + +## create the database +my $pgsql = create_postgresql_database(); +update_postgresql_database($pgsql); + +use_ok('Debbugs::DB'); +$tests++; +my $s; +ok($s = Debbugs::DB->connect($pgsql->dsn), + "Able to connect to database"); +$tests++; + +$bc = Debbugs::Collection::Bug->new(bugs => [1..4], + schema => $s); +ok($bug = $bc->get(1), + "Created a bug correctly with DB" + ); +$tests++; + +done_testing($tests); + -- 2.39.2