--- /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);
+
+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:
--- /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::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:
--- /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::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:
--- /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::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:
--- /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::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:
--- /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::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:
--- /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::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:
--- /dev/null
+# 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 <don@donarmstrong.com>.
+
+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:
--- /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::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:
--- /dev/null
+# -*- 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 => <<EOF) or fail('Unable to send message');
+Package: foo
+Severity: normal
+Tags: wontfix moreinfo
+
+This is a silly bug $_
+EOF
+}
+
+
+my $bc = Debbugs::Collection::Bug->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);
+
projects / debbugs.git / commitdiff