From: Don Armstrong Date: Wed, 24 Jul 2019 03:15:15 +0000 (-0700) Subject: move Debbugs to lib X-Git-Url: https://git.donarmstrong.com/?p=debbugs.git;a=commitdiff_plain;h=1e6633a3780f4fd53fc4303852e84d13cdad2dc6 move Debbugs to lib - We will eventually want to add more modules potentially outside of Debbugs --- 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: 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: diff --git a/Debbugs/Bug/Tag.pm b/Debbugs/Bug/Tag.pm deleted file mode 100644 index 06dfb3f..0000000 --- a/Debbugs/Bug/Tag.pm +++ /dev/null @@ -1,212 +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::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::User; -use List::AllUtils qw(uniq); -use Debbugs::Config qw(:config); -use Carp qw(croak); - -state $valid_tags = - {map {($_,1)} @{$config{tags}}}; - -state $short_tags = - {%{$config{tags_single_letter}}}; - -extends 'Debbugs::OOBase'; - -around BUILDARGS => sub { - my $orig = shift; - my $class = shift; - if (@_ == 1 && !ref $_[0]) { - return $class->$orig(keywords => $_[0]); - } else { - return $class->$orig(@_); - } -}; - -sub BUILD { - my $self = shift; - my $args = shift; - if (exists $args->{keywords}) { - my @tags; - if (ref($args->{keywords})) { - @tags = @{$args->{keywords}} - } else { - @tags = split /[, ]/,$args->{keywords}; - } - return unless @tags; - $self->_set_tag(map {($_,1)} @tags); - delete $args->{keywords}; - } -} - -has tags => (is => 'ro', - isa => 'HashRef[Str]', - traits => ['Hash'], - lazy => 1, - reader => '_tags', - builder => '_build_tags', - handles => {has_tags => 'count', - _set_tag => 'set', - unset_tag => 'delete', - }, - ); -has usertags => (is => 'ro', - isa => 'HashRef[Str]', - lazy => 1, - traits => ['Hash'], - handles => {unset_usertag => 'delete', - has_usertags => 'count', - }, - reader => '_usertags', - builder => '_build_usertags', - ); - -sub has_any_tags { - my $self = shift; - return ($self->has_tags || $self->has_usertags); -} - -has bug => (is => 'ro', - isa => 'Debbugs::Bug', - required => 1, - ); - -has users => (is => 'ro', - isa => 'ArrayRef[Debbugs::User]', - default => sub {[]}, - ); - -sub _build_tags { - return {}; -} - -sub _build_usertags { - my $self = shift; - local $_; - my $t = {}; - my $id = $self->bug->id; - for my $user (@{$self->users}) { - for my $tag ($user->tags_on_bug($id)) { - $t->{$tag} = $user->email; - } - } - return $t; -} - -sub is_set { - return ($_[0]->tag_is_set($_[1]) or - $_[0]->usertag_is_set($_[1])); -} - -sub tag_is_set { - return exists $_[0]->_tags->{$_[1]} ? 1 : 0; -} - -sub usertag_is_set { - return exists $_[0]->_usertags->{$_[1]} ? 1 : 0; -} - -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 { - my $self = shift; - return $self->join_all(' '); -} - -sub join_all { - my $self = shift; - my $joiner = shift; - $joiner //= ', '; - return join($joiner,$self->all_tags); -} - -sub join_usertags { - my $self = shift; - my $joiner = shift; - $joiner //= ', '; - return join($joiner,$self->usertags); -} - -sub join_tags { - my $self = shift; - my $joiner = shift; - $joiner //= ', '; - return join($joiner,$self->tags); -} - -sub all_tags { - return uniq sort $_[0]->tags,$_[0]->usertags; -} - -sub tags { - return sort keys %{$_[0]->_tags} -} - -sub short_tags { - my $self = shift; - my @r; - for my $tag ($self->tags) { - next unless exists $short_tags->{$tag}; - push @r, - {long => $tag, - short => $short_tags->{$tag}, - }; - } - if (wantarray) { - return @r; - } else { - return [@r]; - } -} - -sub usertags { - return sort keys %{$_[0]->_usertags} -} - -no Mouse; -1; - - -__END__ -# Local Variables: -# indent-tabs-mode: nil -# cperl-indent-level: 4 -# End: diff --git a/Debbugs/Bugs.pm b/Debbugs/Bugs.pm deleted file mode 100644 index 127e472..0000000 --- a/Debbugs/Bugs.pm +++ /dev/null @@ -1,959 +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 2007 by Don Armstrong . - -package Debbugs::Bugs; - -=head1 NAME - -Debbugs::Bugs -- Bug selection routines for debbugs - -=head1 SYNOPSIS - -use Debbugs::Bugs qw(get_bugs); - - -=head1 DESCRIPTION - -This module is a replacement for all of the various methods of -selecting different types of bugs. - -It implements a single function, get_bugs, which defines the master -interface for selecting bugs. - -It attempts to use subsidiary functions to actually do the selection, -in the order specified in the configuration files. [Unless you're -insane, they should be in order from fastest (and often most -incomplete) to slowest (and most complete).] - -=head1 BUGS - -=head1 FUNCTIONS - -=cut - -use warnings; -use strict; -use feature 'state'; -use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); -use Exporter qw(import); - -BEGIN{ - $VERSION = 1.00; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - %EXPORT_TAGS = (); - @EXPORT_OK = (qw(get_bugs count_bugs newest_bug bug_filter)); - $EXPORT_TAGS{all} = [@EXPORT_OK]; -} - -use Debbugs::Config qw(:config); -use Params::Validate qw(validate_with :types); -use IO::File; -use Debbugs::Status qw(splitpackages get_bug_status); -use Debbugs::Packages qw(getsrcpkgs getpkgsrc); -use Debbugs::Common qw(getparsedaddrs package_maintainer getmaintainers make_list hash_slice); -use Fcntl qw(O_RDONLY); -use MLDBM qw(DB_File Storable); -use List::AllUtils qw(first max); -use Carp; - -=head2 get_bugs - - get_bugs() - -=head3 Parameters - -The following parameters can either be a single scalar or a reference -to an array. The parameters are ANDed together, and the elements of -arrayrefs are a parameter are ORed. Future versions of this may allow -for limited regular expressions, and/or more complex expressions. - -=over - -=item package -- name of the binary package - -=item src -- name of the source package - -=item maint -- address of the maintainer - -=item submitter -- address of the submitter - -=item severity -- severity of the bug - -=item status -- status of the bug - -=item tag -- bug tags - -=item owner -- owner of the bug - -=item correspondent -- address of someone who sent mail to the log - -=item affects -- bugs which affect this package - -=item dist -- distribution (I don't know about this one yet) - -=item bugs -- list of bugs to search within - -=item function -- see description below - -=back - -=head3 Special options - -The following options are special options used to modulate how the -searches are performed. - -=over - -=item archive -- whether to search archived bugs or normal bugs; -defaults to false. As a special case, if archive is 'both', but -archived and unarchived bugs are returned. - -=item usertags -- set of usertags and the bugs they are applied to - -=back - - -=head3 Subsidiary routines - -All subsidiary routines get passed exactly the same set of options as -get_bugs. If for some reason they are unable to handle the options -passed (for example, they don't have the right type of index for the -type of selection) they should die as early as possible. [Using -Params::Validate and/or die when files don't exist makes this fairly -trivial.] - -This function will then immediately move on to the next subroutine, -giving it the same arguments. - -=head3 function - -This option allows you to provide an arbitrary function which will be -given the information in the index.db file. This will be super, super -slow, so only do this if there's no other way to write the search. - -You'll be given a list (which you can turn into a hash) like the -following: - - (pkg => ['a','b'], # may be a scalar (most common) - bug => 1234, - status => 'pending', - submitter => 'boo@baz.com', - severity => 'serious', - tags => ['a','b','c'], # may be an empty arrayref - ) - -The function should return 1 if the bug should be included; 0 if the -bug should not. - -=cut - -state $_non_search_key_regex = qr/^(bugs|archive|usertags|schema)$/; - -my %_get_bugs_common_options = - (package => {type => SCALAR|ARRAYREF, - optional => 1, - }, - src => {type => SCALAR|ARRAYREF, - optional => 1, - }, - maint => {type => SCALAR|ARRAYREF, - optional => 1, - }, - submitter => {type => SCALAR|ARRAYREF, - optional => 1, - }, - severity => {type => SCALAR|ARRAYREF, - optional => 1, - }, - status => {type => SCALAR|ARRAYREF, - optional => 1, - }, - tag => {type => SCALAR|ARRAYREF, - optional => 1, - }, - owner => {type => SCALAR|ARRAYREF, - optional => 1, - }, - dist => {type => SCALAR|ARRAYREF, - optional => 1, - }, - correspondent => {type => SCALAR|ARRAYREF, - optional => 1, - }, - affects => {type => SCALAR|ARRAYREF, - optional => 1, - }, - function => {type => CODEREF, - optional => 1, - }, - bugs => {type => SCALAR|ARRAYREF, - optional => 1, - }, - archive => {type => BOOLEAN|SCALAR, - default => 0, - }, - usertags => {type => HASHREF, - optional => 1, - }, - newest => {type => SCALAR|ARRAYREF, - optional => 1, - }, - schema => {type => OBJECT, - optional => 1, - }, - ); - - -state $_get_bugs_options = {%_get_bugs_common_options}; -sub get_bugs{ - my %param = validate_with(params => \@_, - spec => $_get_bugs_options, - ); - - # Normalize options - my %options = %param; - my @bugs; - if ($options{archive} eq 'both') { - push @bugs, get_bugs(%options,archive=>0); - push @bugs, get_bugs(%options,archive=>1); - my %bugs; - @bugs{@bugs} = @bugs; - return keys %bugs; - } - # A configuration option will set an array that we'll use here instead. - for my $routine (qw(Debbugs::Bugs::get_bugs_by_db Debbugs::Bugs::get_bugs_by_idx Debbugs::Bugs::get_bugs_flatfile)) { - my ($package) = $routine =~ m/^(.+)\:\:/; - eval "use $package;"; - if ($@) { - # We output errors here because using an invalid function - # in the configuration file isn't something that should - # be done. - warn "use $package failed with $@"; - next; - } - @bugs = eval "${routine}(\%options)"; - if ($@) { - - # We don't output errors here, because failure here - # via die may be a perfectly normal thing. - print STDERR "$@" if $DEBUG; - next; - } - last; - } - # If no one succeeded, die - if ($@) { - die "$@"; - } - return @bugs; -} - -=head2 count_bugs - - count_bugs(function => sub {...}) - -Uses a subroutine to classify bugs into categories and return the -number of bugs which fall into those categories - -=cut - -sub count_bugs { - my %param = validate_with(params => \@_, - spec => {function => {type => CODEREF, - }, - archive => {type => BOOLEAN, - default => 0, - }, - }, - ); - my $flatfile; - if ($param{archive}) { - $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r') - or die "Unable to open $config{spool_dir}/index.archive for reading: $!"; - } - else { - $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r') - or die "Unable to open $config{spool_dir}/index.db for reading: $!"; - } - my %count = (); - while(<$flatfile>) { - if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) { - my @x = $param{function}->(pkg => $1, - bug => $2, - status => $4, - submitter => $5, - severity => $6, - tags => $7, - ); - local $_; - $count{$_}++ foreach @x; - } - } - close $flatfile; - return %count; -} - -=head2 newest_bug - - my $bug = newest_bug(); - -Returns the bug number of the newest bug, which is nextnumber-1. - -=cut - -sub newest_bug { - my $nn_fh = IO::File->new("$config{spool_dir}/nextnumber",'r') - or die "Unable to open $config{spool_dir}nextnumber for reading: $!"; - local $/; - my $next_number = <$nn_fh>; - close $nn_fh; - chomp $next_number; - return $next_number-1; -} - -=head2 bug_filter - - bug_filter - -Allows filtering bugs on commonly used criteria - - - -=cut - -sub bug_filter { - my %param = validate_with(params => \@_, - spec => {bug => {type => ARRAYREF|SCALAR, - optional => 1, - }, - status => {type => HASHREF|ARRAYREF, - optional => 1, - }, - seen_merged => {type => HASHREF, - optional => 1, - }, - 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{repeat_merged} and - not $param{repeat_merged} and - not defined $param{seen_merged}) { - croak "repeat_merged false requires seen_merged to be passed"; - } - if (not exists $param{bug} and not exists $param{status}) { - croak "one of bug or status must be passed"; - } - - if (not exists $param{status}) { - my $location = getbuglocation($param{bug}, 'summary'); - return 0 if not defined $location or not length $location; - $param{status} = readbug( $param{bug}, $location ); - return 0 if not defined $param{status}; - } - - if (exists $param{include}) { - return 1 if (!__bug_matches($param{include}, $param{status})); - } - if (exists $param{exclude}) { - return 1 if (__bug_matches($param{exclude}, $param{status})); - } - if (exists $param{repeat_merged} and not $param{repeat_merged}) { - my @merged = sort {$a<=>$b} $param{bug}, split(/ /, $param{status}{mergedwith}); - return 1 if first {defined $_} @{$param{seen_merged}}{@merged}; - @{$param{seen_merged}}{@merged} = (1) x @merged; - } - my $daysold = int((time - $param{status}{date}) / 86400); # seconds to days - if (exists $param{min_days}) { - return 1 unless $param{min_days} <= $daysold; - } - if (exists $param{max_days}) { - return 1 unless $param{max_days} == -1 or - $param{max_days} >= $daysold; - } - return 0; -} - - -=head2 get_bugs_by_idx - -This routine uses the by-$index.idx indicies to try to speed up -searches. - - -=cut - - -state $_get_bugs_by_idx_options = - {hash_slice(%_get_bugs_common_options, - (qw(package submitter severity tag archive), - qw(owner src maint bugs correspondent), - qw(affects usertags newest)) - ) - }; -sub get_bugs_by_idx{ - my %param = validate_with(params => \@_, - spec => $_get_bugs_by_idx_options - ); - my %bugs = (); - - # If we're given an empty maint (unmaintained packages), we can't - # handle it, so bail out here - for my $maint (make_list(exists $param{maint}?$param{maint}:[])) { - if (defined $maint and $maint eq '') { - die "Can't handle empty maint (unmaintained packages) in get_bugs_by_idx"; - } - } - if ($param{newest}) { - my $newest_bug = newest_bug(); - my @bugs = ($newest_bug - max(make_list($param{newest})) + 1) .. $newest_bug; - $param{bugs} = [exists $param{bugs}?make_list($param{bugs}):(), - @bugs, - ]; - } - # We handle src packages, maint and maintenc by mapping to the - # appropriate binary packages, then removing all packages which - # don't match all queries - my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()} - qw(package src maint) - ); - if (exists $param{package} or - exists $param{src} or - exists $param{maint}) { - delete @param{qw(maint src)}; - $param{package} = [@packages]; - } - my $keys = grep {$_ !~ $_non_search_key_regex} keys(%param); - die "Need at least 1 key to search by" unless $keys; - my $arc = $param{archive} ? '-arc':''; - my %idx; - for my $key (grep {$_ !~ $_non_search_key_regex} keys %param) { - my $index = $key; - $index = 'submitter-email' if $key eq 'submitter'; - $index = "$config{spool_dir}/by-${index}${arc}.idx"; - tie(%idx, MLDBM => $index, O_RDONLY) - or die "Unable to open $index: $!"; - my %bug_matching = (); - for my $search (make_list($param{$key})) { - for my $bug (keys %{$idx{$search}||{}}) { - next if $bug_matching{$bug}; - # increment the number of searches that this bug matched - $bugs{$bug}++; - $bug_matching{$bug}=1; - } - if ($search ne lc($search)) { - for my $bug (keys %{$idx{lc($search)}||{}}) { - next if $bug_matching{$bug}; - # increment the number of searches that this bug matched - $bugs{$bug}++; - $bug_matching{$bug}=1; - } - } - } - if ($key eq 'tag' and exists $param{usertags}) { - for my $bug (make_list(grep {defined $_ } @{$param{usertags}}{make_list($param{tag})})) { - next if $bug_matching{$bug}; - $bugs{$bug}++; - $bug_matching{$bug}=1; - } - } - untie %idx or die 'Unable to untie %idx'; - } - if ($param{bugs}) { - $keys++; - for my $bug (make_list($param{bugs})) { - $bugs{$bug}++; - } - } - # Throw out results that do not match all of the search specifications - return map {$keys <= $bugs{$_}?($_):()} keys %bugs; -} - - -=head2 get_bugs_by_db - -This routine uses the database to try to speed up -searches. - - -=cut - -state $_get_bugs_by_db_options = - {hash_slice(%_get_bugs_common_options, - (qw(package submitter severity tag archive), - qw(owner src maint bugs correspondent), - qw(affects usertags newest)) - ), - schema => {type => OBJECT, - }, - }; -sub get_bugs_by_db{ - my %param = validate_with(params => \@_, - spec => $_get_bugs_by_db_options, - ); - my %bugs = (); - - my $s = $param{schema}; - my $keys = grep {$_ !~ $_non_search_key_regex} keys(%param); - die "Need at least 1 key to search by" unless $keys; - my $rs = $s->resultset('Bug'); - if (exists $param{severity}) { - $rs = $rs->search({'severity.severity' => - [make_list($param{severity})], - }, - {join => 'severity'}, - ); - } - for my $key (qw(owner submitter done)) { - if (exists $param{$key}) { - $rs = $rs->search({"${key}.addr" => - [make_list($param{$key})], - }, - {join => $key}, - ); - } - } - if (exists $param{newest}) { - $rs = - $rs->search({}, - {order_by => {-desc => 'me.creation'}, - rows => max(make_list($param{newest})), - }, - ); - } - if (exists $param{correspondent}) { - my $message_rs = - $s->resultset('Message')-> - search({'correspondent.addr' => - [make_list($param{correspondent})], - }, - {join => {message_correspondents => 'correspondent'}, - columns => ['id'], - group_by => ['me.id'], - }, - ); - $rs = $rs->search({'bug_messages.message' => - {-in => $message_rs->get_column('id')->as_query()}, - }, - {join => 'bug_messages', - }, - ); - } - if (exists $param{affects}) { - my @aff_list = make_list($param{affects}); - s/^src:// foreach @aff_list; - $rs = $rs->search({-or => {'bin_pkg.pkg' => - [@aff_list], - 'src_pkg.pkg' => - [@aff_list], - 'me.unknown_affects' => - [@aff_list] - }, - }, - {join => [{bug_affects_binpackages => 'bin_pkg'}, - {bug_affects_srcpackages => 'src_pkg'}, - ], - }, - ); - } - if (exists $param{package}) { - $rs = $rs->search({-or => {'bin_pkg.pkg' => - [make_list($param{package})], - 'me.unknown_packages' => - [make_list($param{package})]}, - }, - {join => {bug_binpackages => 'bin_pkg'}}); - } - if (exists $param{maint}) { - my @maint_list = - map {$_ eq '' ? undef : $_} - make_list($param{maint}); - my $bin_pkgs_rs = - $s->resultset('BinPkg')-> - search({'correspondent.addr' => [@maint_list]}, - {join => {bin_vers => - {src_ver => - {maintainer => 'correspondent'}}}, - columns => ['id'], - group_by => ['me.id'], - }, - ); - my $src_pkgs_rs = - $s->resultset('SrcPkg')-> - search({'correspondent.addr' => [@maint_list]}, - {join => {src_vers => - {maintainer => 'correspondent'}}, - columns => ['id'], - group_by => ['me.id'], - }, - ); - $rs = $rs->search({-or => {'bug_binpackages.bin_pkg' => - { -in => $bin_pkgs_rs->get_column('id')->as_query}, - 'bug_srcpackages.src_pkg' => - { -in => $src_pkgs_rs->get_column('id')->as_query}, - }, - }, - {join => ['bug_binpackages', - 'bug_srcpackages', - ]} - ); - } - if (exists $param{src}) { - # identify all of the srcpackages and binpackages that match first - my $src_pkgs_rs = - $s->resultset('SrcPkg')-> - search({'pkg' => [make_list($param{src})], - }, - { columns => ['id'], - group_by => ['me.id'], - }, - ); - my $bin_pkgs_rs = - $s->resultset('BinPkgSrcPkg')-> - search({'src_pkg.pkg' => [make_list($param{src})], - }, - {columns => ['bin_pkg'], - join => ['src_pkg'], - group_by => ['bin_pkg'], - }); - $rs = $rs->search({-or => {'bug_binpackages.bin_pkg' => - { -in => $bin_pkgs_rs->get_column('bin_pkg')->as_query}, - 'bug_srcpackages.src_pkg' => - { -in => $src_pkgs_rs->get_column('id')->as_query}, - 'me.unknown_packages' => - [make_list($param{src})], - }, - }, - {join => ['bug_binpackages', - 'bug_srcpackages', - ]} - ); - } - # tags are very odd, because we must handle usertags. - if (exists $param{tag}) { - # bugs from usertags which matter - my %bugs_matching_usertags; - for my $bug (make_list(grep {defined $_ } - @{$param{usertags}}{make_list($param{tag})})) { - $bugs_matching_usertags{$bug} = 1; - } - # we want all bugs which either match the tag name given in - # param, or have a usertag set which matches one of the tag - # names given in param. - $rs = $rs->search({-or => {map {('tag.tag' => $_)} - make_list($param{tag}), - map {('me.id' => $_)} - keys %bugs_matching_usertags - }, - }, - {join => {bug_tags => 'tag'}}); - } - if (exists $param{bugs}) { - $rs = $rs->search({-or => {map {('me.id' => $_)} - make_list($param{bugs})} - }); - } - # handle archive - if (defined $param{archive} and $param{archive} ne 'both') { - $rs = $rs->search({'me.archived' => $param{archive}}); - } - return $rs->get_column('id')->all(); -} - - -=head2 get_bugs_flatfile - -This is the fallback search routine. It should be able to complete all -searches. [Or at least, that's the idea.] - -=cut - -state $_get_bugs_flatfile_options = - {hash_slice(%_get_bugs_common_options, - map {$_ eq 'dist'?():($_)} keys %_get_bugs_common_options - ) - }; - -sub get_bugs_flatfile{ - my %param = validate_with(params => \@_, - spec => $_get_bugs_flatfile_options - ); - my $flatfile; - if ($param{newest}) { - my $newest_bug = newest_bug(); - my @bugs = ($newest_bug - max(make_list($param{newest})) + 1) .. $newest_bug; - $param{bugs} = [exists $param{bugs}?make_list($param{bugs}):(), - @bugs, - ]; - } - if ($param{archive}) { - $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r') - or die "Unable to open $config{spool_dir}/index.archive for reading: $!"; - } - else { - $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r') - or die "Unable to open $config{spool_dir}/index.db for reading: $!"; - } - my %usertag_bugs; - if (exists $param{tag} and exists $param{usertags}) { - # This complex slice makes a hash with the bugs which have the - # usertags passed in $param{tag} set. - @usertag_bugs{make_list(@{$param{usertags}}{make_list($param{tag})}) - } = (1) x make_list(@{$param{usertags}}{make_list($param{tag})}); - } - my $unmaintained_packages = 0; - # unmaintained packages is a special case - my @maints = make_list(exists $param{maint}?$param{maint}:[]); - $param{maint} = []; - for my $maint (@maints) { - if (defined $maint and $maint eq '' and not $unmaintained_packages) { - $unmaintained_packages = 1; - our %maintainers = %{getmaintainers()}; - $param{function} = [(exists $param{function}? - (ref $param{function}?@{$param{function}}:$param{function}):()), - sub {my %d=@_; - foreach my $try (make_list($d{"pkg"})) { - next unless length $try; - ($try) = $try =~ m/^(?:src:)?(.+)/; - return 1 if not exists $maintainers{$try}; - } - return 0; - } - ]; - } - elsif (defined $maint and $maint ne '') { - push @{$param{maint}},$maint; - } - } - # We handle src packages, maint and maintenc by mapping to the - # appropriate binary packages, then removing all packages which - # don't match all queries - my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()} - qw(package src maint) - ); - if (exists $param{package} or - exists $param{src} or - exists $param{maint}) { - delete @param{qw(maint src)}; - $param{package} = [@packages] if @packages; - } - my $grep_bugs = 0; - my %bugs; - if (exists $param{bugs}) { - $bugs{$_} = 1 for make_list($param{bugs}); - $grep_bugs = 1; - } - # These queries have to be handled by get_bugs_by_idx - if (exists $param{owner} - or exists $param{correspondent} - or exists $param{affects}) { - $bugs{$_} = 1 for get_bugs_by_idx(map {exists $param{$_}?($_,$param{$_}):()} - qw(owner correspondent affects), - ); - $grep_bugs = 1; - } - my @bugs; - BUG: while (<$flatfile>) { - next unless m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*(.*)\s*\]\s+(\w+)\s+(.*)$/; - my ($pkg,$bug,$time,$status,$submitter,$severity,$tags) = ($1,$2,$3,$4,$5,$6,$7); - next if $grep_bugs and not exists $bugs{$bug}; - if (exists $param{package}) { - my @packages = splitpackages($pkg); - next unless grep { my $pkg_list = $_; - grep {$pkg_list eq $_} make_list($param{package}) - } @packages; - } - if (exists $param{src}) { - my @src_packages = map { getsrcpkgs($_)} make_list($param{src}); - my @packages = splitpackages($pkg); - next unless grep { my $pkg_list = $_; - grep {$pkg_list eq $_} @packages - } @src_packages; - } - if (exists $param{submitter}) { - my @p_addrs = map {lc($_->address)} - map {getparsedaddrs($_)} - make_list($param{submitter}); - my @f_addrs = map {$_->address} - getparsedaddrs($submitter||''); - next unless grep { my $f_addr = $_; - grep {$f_addr eq $_} @p_addrs - } @f_addrs; - } - next if exists $param{severity} and not grep {$severity eq $_} make_list($param{severity}); - next if exists $param{status} and not grep {$status eq $_} make_list($param{status}); - if (exists $param{tag}) { - my $bug_ok = 0; - # either a normal tag, or a usertag must be set - $bug_ok = 1 if exists $param{usertags} and $usertag_bugs{$bug}; - my @bug_tags = split ' ', $tags; - $bug_ok = 1 if grep {my $bug_tag = $_; - grep {$bug_tag eq $_} make_list($param{tag}); - } @bug_tags; - next unless $bug_ok; - } - # We do this last, because a function may be slow... - if (exists $param{function}) { - my @bug_tags = split ' ', $tags; - my @packages = splitpackages($pkg); - my $package = (@packages > 1)?\@packages:$packages[0]; - for my $function (make_list($param{function})) { - next BUG unless - $function->(pkg => $package, - bug => $bug, - status => $status, - submitter => $submitter, - severity => $severity, - tags => \@bug_tags, - ); - } - } - push @bugs, $bug; - } - return @bugs; -} - -=head1 PRIVATE FUNCTIONS - -=head2 __handle_pkg_src_and_maint - - my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()} - qw(package src maint) - ); - -Turn package/src/maint into a list of packages - -=cut - -sub __handle_pkg_src_and_maint{ - my %param = validate_with(params => \@_, - spec => {package => {type => SCALAR|ARRAYREF, - optional => 1, - }, - src => {type => SCALAR|ARRAYREF, - optional => 1, - }, - maint => {type => SCALAR|ARRAYREF, - optional => 1, - }, - }, - allow_extra => 1, - ); - - my @packages; - @packages = make_list($param{package}) if exists $param{package}; - my $package_keys = @packages?1:0; - my %packages; - @packages{@packages} = (1) x @packages; - if (exists $param{src}) { - # We only want to increment the number of keys if there is - # something to match - my $key_inc = 0; - # in case there are binaries with the same name as the - # source - my %_temp_p = (); - for my $package ((map {getsrcpkgs($_)} make_list($param{src}))) { - $packages{$package}++ unless exists $_temp_p{$package}; - $_temp_p{$package} = 1; - $key_inc=1; - } - for my $package (make_list($param{src})) { - $packages{"src:$package"}++ unless exists $_temp_p{"src:$package"}; - $_temp_p{"src:$package"} = 1; - $key_inc=1; - # As a temporary hack, we will also include $param{src} - # in this list for packages passed which do not have a - # corresponding binary package - if (not exists getpkgsrc()->{$package}) { - $packages{$package}++ unless exists $_temp_p{$package}; - $_temp_p{$package} = 1; - } - } - $package_keys += $key_inc; - } - if (exists $param{maint}) { - my $key_inc = 0; - my %_temp_p = (); - for my $package (package_maintainer(maintainer=>$param{maint})) { - $packages{$package}++ unless exists $_temp_p{$package}; - $_temp_p{$package} = 1; - $key_inc = 1; - } - $package_keys += $key_inc; - } - return grep {$packages{$_} >= $package_keys} keys %packages; -} - -state $field_match = { - 'subject' => \&__contains_field_match, - 'tags' => sub { - my ($field, $values, $status) = @_; - my %values = map {$_=>1} @$values; - foreach my $t (split /\s+/, $status->{$field}) { - return 1 if (defined $values{$t}); - } - return 0; - }, - 'severity' => \&__exact_field_match, - 'pending' => \&__exact_field_match, - 'package' => \&__exact_field_match, - 'originator' => \&__contains_field_match, - 'forwarded' => \&__contains_field_match, - 'owner' => \&__contains_field_match, -}; - -sub __bug_matches { - my ($hash, $status) = @_; - foreach my $key( keys( %$hash ) ) { - my $value = $hash->{$key}; - next unless exists $field_match->{$key}; - my $sub = $field_match->{$key}; - if (not defined $sub) { - die "No defined subroutine for key: $key"; - } - return 1 if ($sub->($key, $value, $status)); - } - return 0; -} - -sub __exact_field_match { - my ($field, $values, $status) = @_; - my @values = @$values; - my @ret = grep {$_ eq $status->{$field} } @values; - $#ret != -1; -} - -sub __contains_field_match { - my ($field, $values, $status) = @_; - foreach my $data (@$values) { - return 1 if (index($status->{$field}, $data) > -1); - } - return 0; -} - - - - - -1; - -__END__ diff --git a/Debbugs/CGI.pm b/Debbugs/CGI.pm deleted file mode 100644 index 7dabb1e..0000000 --- a/Debbugs/CGI.pm +++ /dev/null @@ -1,1014 +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. -# -# [Other people have contributed to this file; their copyrights should -# go here too.] -# Copyright 2007 by Don Armstrong . - -package Debbugs::CGI; - -=head1 NAME - -Debbugs::CGI -- General routines for the cgi scripts - -=head1 SYNOPSIS - -use Debbugs::CGI qw(:url :html); - -=head1 DESCRIPTION - -This module is a replacement for parts of common.pl; subroutines in -common.pl will be gradually phased out and replaced with equivalent -(or better) functionality here. - -=head1 BUGS - -None known. - -=cut - -use warnings; -use strict; -use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); -use Exporter qw(import); - -use feature qw(state); - -our %URL_PARAMS = (); - -BEGIN{ - ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - %EXPORT_TAGS = (url => [qw(bug_links bug_linklist maybelink), - qw(set_url_params version_url), - qw(submitterurl mainturl munge_url), - qw(package_links bug_links), - ], - html => [qw(html_escape htmlize_bugs htmlize_packagelinks), - qw(maybelink htmlize_addresslinks htmlize_maintlinks), - ], - util => [qw(cgi_parameters quitcgi), - ], - forms => [qw(option_form form_options_and_normal_param)], - usertags => [qw(add_user)], - misc => [qw(maint_decode)], - package_search => [qw(@package_search_key_order %package_search_keys)], - cache => [qw(calculate_etag etag_does_not_match)], - #status => [qw(getbugstatus)], - ); - @EXPORT_OK = (); - Exporter::export_ok_tags(keys %EXPORT_TAGS); - $EXPORT_TAGS{all} = [@EXPORT_OK]; -} - -use Debbugs::URI; -use URI::Escape; -use HTML::Entities; -use Debbugs::Common qw(getparsedaddrs make_list); -use Params::Validate qw(validate_with :types); - -use Debbugs::Config qw(:config); -use Debbugs::Status qw(splitpackages isstrongseverity); -use Debbugs::User qw(); - -use Mail::Address; -use POSIX qw(ceil); -use Storable qw(dclone); -use Scalar::Util qw(looks_like_number); - -use List::AllUtils qw(max); -use File::stat; -use Digest::MD5 qw(md5_hex); -use Carp; - -use Debbugs::Text qw(fill_in_template); - - - -=head2 set_url_params - - set_url_params($uri); - - -Sets the url params which will be used to generate urls. - -=cut - -sub set_url_params{ - if (@_ > 1) { - %URL_PARAMS = @_; - } - else { - my $url = Debbugs::URI->new($_[0]||''); - %URL_PARAMS = %{$url->query_form_hash}; - } -} - - -=head2 munge_url - - my $url = munge_url($url,%params_to_munge); - -Munges a url, replacing parameters with %params_to_munge as appropriate. - -=cut - -sub munge_url { - my $url = shift; - my %params = @_; - my $new_url = Debbugs::URI->new($url); - my @old_param = $new_url->query_form(); - my @new_param; - while (my ($key,$value) = splice @old_param,0,2) { - push @new_param,($key,$value) unless exists $params{$key}; - } - $new_url->query_form(@new_param, - map {($_,$params{$_})} - sort keys %params); - return $new_url->as_string; -} - - -=head2 version_url - - version_url(package => $package,found => $found,fixed => $fixed) - -Creates a link to the version cgi script - -=over - -=item package -- source package whose graph to display - -=item found -- arrayref of found versions - -=item fixed -- arrayref of fixed versions - -=item format -- optional image format override - -=item width -- optional width of graph - -=item height -- optional height of graph - -=item info -- display html info surrounding graph; defaults to 1 if -width and height are not passed. - -=item collapse -- whether to collapse the graph; defaults to 1 if -width and height are passed. - -=back - -=cut - -sub version_url{ - my %params = validate_with(params => \@_, - spec => {package => {type => SCALAR|ARRAYREF, - }, - found => {type => ARRAYREF, - default => [], - }, - fixed => {type => ARRAYREF, - default => [], - }, - format => {type => SCALAR, - optional => 1, - }, - width => {type => SCALAR, - optional => 1, - }, - height => {type => SCALAR, - optional => 1, - }, - absolute => {type => BOOLEAN, - default => 0, - }, - collapse => {type => BOOLEAN, - default => 1, - }, - info => {type => BOOLEAN, - optional => 1, - }, - } - ); - if (not defined $params{width} and not defined $params{height}) { - $params{info} = 1 if not exists $params{info}; - } - my $url = Debbugs::URI->new('version.cgi?'); - $url->query_form(%params); - return $url->as_string; -} - -=head2 html_escape - - html_escape($string) - -Escapes html entities by calling HTML::Entities::encode_entities; - -=cut - -sub html_escape{ - my ($string) = @_; - - return HTML::Entities::encode_entities($string,q(<>&"')); -} - -=head2 cgi_parameters - - cgi_parameters - -Returns all of the cgi_parameters from a CGI script using CGI::Simple - -=cut - -sub cgi_parameters { - my %options = validate_with(params => \@_, - spec => {query => {type => OBJECT, - can => 'param', - }, - single => {type => ARRAYREF, - default => [], - }, - default => {type => HASHREF, - default => {}, - }, - }, - ); - my $q = $options{query}; - my %single; - @single{@{$options{single}}} = (1) x @{$options{single}}; - my %param; - for my $paramname ($q->param) { - if ($single{$paramname}) { - $param{$paramname} = $q->param($paramname); - } - else { - $param{$paramname} = [$q->param($paramname)]; - } - } - for my $default (keys %{$options{default}}) { - if (not exists $param{$default}) { - # We'll clone the reference here to avoid surprises later. - $param{$default} = ref($options{default}{$default})? - dclone($options{default}{$default}):$options{default}{$default}; - } - } - return %param; -} - - -sub quitcgi { - my ($msg, $status) = @_; - $status //= '500 Internal Server Error'; - print "Status: $status\n"; - print "Content-Type: text/html\n\n"; - print fill_in_template(template=>'cgi/quit', - variables => {msg => $msg} - ); - exit 0; -} - - -=head1 HTML - -=head2 htmlize_packagelinks - - htmlize_packagelinks - -Given a scalar containing a list of packages separated by something -that L can separate, returns a -formatted set of links to packages in html. - -=cut - -sub htmlize_packagelinks { - my ($pkgs) = @_; - return '' unless defined $pkgs and $pkgs ne ''; - my @pkglist = splitpackages($pkgs); - - carp "htmlize_packagelinks is deprecated, use package_links instead"; - - return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' . - package_links(package =>\@pkglist, - class => 'submitter' - ); -} - -=head2 package_links - - join(', ', package_links(packages => \@packages)) - -Given a list of packages, return a list of html which links to the package - -=over - -=item package -- arrayref or scalar of package(s) - -=item submitter -- arrayref or scalar of submitter(s) - -=item src -- arrayref or scalar of source(s) - -=item maintainer -- arrayref or scalar of maintainer(s) - -=item links_only -- return only links, not htmlized links, defaults to -returning htmlized links. - -=item class -- class of the a href, defaults to '' - -=back - -=cut - -our @package_search_key_order = (package => 'in package', - tag => 'tagged', - severity => 'with severity', - src => 'in source package', - maint => 'in packages maintained by', - submitter => 'submitted by', - owner => 'owned by', - status => 'with status', - affects => 'which affect package', - correspondent => 'with mail from', - newest => 'newest bugs', - bugs => 'in bug', - ); -our %package_search_keys = @package_search_key_order; -our %package_links_invalid_options = - map {($_,1)} (keys %package_search_keys, - qw(msg att)); - -sub package_links { - state $spec = - {(map { ($_,{type => SCALAR|ARRAYREF, - optional => 1, - }); - } keys %package_search_keys, - ## these are aliases for package - ## search keys - source => {type => SCALAR|ARRAYREF, - optional => 1, - }, - maintainer => {type => SCALAR|ARRAYREF, - optional => 1, - }, - ), - links_only => {type => BOOLEAN, - default => 0, - }, - class => {type => SCALAR, - default => '', - }, - separator => {type => SCALAR, - default => ', ', - }, - options => {type => HASHREF, - default => {}, - }, - }; - my %param = validate_with(params => \@_, - spec => $spec, - ); - my %options = %{$param{options}}; - for (grep {$package_links_invalid_options{$_}} keys %options) { - delete $options{$_}; - } - ## remove aliases for source and maintainer - if (exists $param{source}) { - $param{src} = [exists $param{src}?make_list($param{src}):(), - make_list($param{source}), - ]; - delete $param{source}; - } - if (exists $param{maintainer}) { - $param{maint} = [exists $param{maint}?make_list($param{maint}):(), - make_list($param{maintainer}), - ]; - delete $param{maintainer}; - } - my $has_options = keys %options; - my @links = (); - for my $type (qw(src package)) { - next unless exists $param{$type}; - for my $target (make_list($param{$type})) { - my $t_type = $type; - if ($target =~ s/^src://) { - $t_type = 'source'; - } elsif ($t_type eq 'source') { - $target = 'src:'.$target; - } - if ($has_options) { - push @links, - (munge_url('pkgreport.cgi?', - %options, - $t_type => $target, - ), - $target); - } else { - push @links, - ('pkgreport.cgi?'.$t_type.'='.uri_escape_utf8($target), - $target); - } - } - } - for my $type (qw(maint owner submitter correspondent)) { - next unless exists $param{$type}; - for my $target (make_list($param{$type})) { - if ($has_options) { - push @links, - (munge_url('pkgreport.cgi?', - %options, - $type => $target), - $target); - } else { - push @links, - ('pkgreport.cgi?'. - $type.'='.uri_escape_utf8($target), - $target); - } - } - } - my @return = (); - my ($link,$link_name); - my $class = ''; - if (length $param{class}) { - $class = q( class=").html_escape($param{class}).q("); - } - while (($link,$link_name) = splice(@links,0,2)) { - if ($param{links_only}) { - push @return,$link - } - else { - push @return, - qq(). - html_escape($link_name).q(); - } - } - if (wantarray) { - return @return; - } - else { - return join($param{separator},@return); - } -} - -=head2 bug_links - - join(', ', bug_links(bug => \@packages)) - -Given a list of bugs, return a list of html which links to the bugs - -=over - -=item bug -- arrayref or scalar of bug(s) - -=item links_only -- return only links, not htmlized links, defaults to -returning htmlized links. - -=item class -- class of the a href, defaults to '' - -=back - -=cut - -sub bug_links { - state $spec = {bug => {type => SCALAR|ARRAYREF, - optional => 1, - }, - links_only => {type => BOOLEAN, - default => 0, - }, - class => {type => SCALAR, - default => '', - }, - separator => {type => SCALAR, - default => ', ', - }, - options => {type => HASHREF, - default => {}, - }, - }; - my %param = validate_with(params => \@_, - spec => $spec, - ); - my %options = %{$param{options}}; - - for (qw(bug)) { - delete $options{$_} if exists $options{$_}; - } - my $has_options = keys %options; - my @links; - if ($has_options) { - push @links, map {(munge_url('bugreport.cgi?', - %options, - bug => $_, - ), - $_); - } make_list($param{bug}) if exists $param{bug}; - } else { - push @links, - map {my $b = ceil($_); - ('bugreport.cgi?bug='.$b, - $b)} - grep {looks_like_number($_)} - make_list($param{bug}) if exists $param{bug}; - } - my @return; - my ($link,$link_name); - my $class = ''; - if (length $param{class}) { - $class = q( class=").html_escape($param{class}).q("); - } - while (($link,$link_name) = splice(@links,0,2)) { - if ($param{links_only}) { - push @return,$link - } - else { - push @return, - qq(). - html_escape($link_name).q(); - } - } - if (wantarray) { - return @return; - } - else { - return join($param{separator},@return); - } -} - - - -=head2 maybelink - - maybelink($in); - maybelink('http://foobarbaz,http://bleh',qr/[, ]+/); - maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', '); - - -In the first form, links the link if it looks like a link. In the -second form, first splits based on the regex, then reassembles the -link, linking things that look like links. In the third form, rejoins -the split links with commas and spaces. - -=cut - -sub maybelink { - my ($links,$regex,$join) = @_; - if (not defined $regex and not defined $join) { - $links =~ s{(.*?)((?:(?:ftp|http|https)://[\S~-]+?/?)?)([\)\'\:\.\,]?(?:\s|\.<|$))} - {html_escape($1).(length $2?q().html_escape($2).q():'').html_escape($3)}geimo; - return $links; - } - $join = ' ' if not defined $join; - my @return; - my @segments; - if (defined $regex) { - @segments = split $regex, $links; - } - else { - @segments = ($links); - } - for my $in (@segments) { - if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme - push @return, qq{} . html_escape($in) . ''; - } else { - push @return, html_escape($in); - } - } - return @return?join($join,@return):''; -} - - -=head2 htmlize_addresslinks - - htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class); - - -Generate a comma-separated list of HTML links to each address given in -$addresses, which should be a comma-separated list of RFC822 -addresses. $urlfunc should be a reference to a function like mainturl -or submitterurl which returns the URL for each individual address. - - -=cut - -sub htmlize_addresslinks { - my ($prefixfunc, $urlfunc, $addresses,$class) = @_; - carp "htmlize_addresslinks is deprecated"; - - $class = defined $class?qq(class="$class" ):''; - if (defined $addresses and $addresses ne '') { - my @addrs = getparsedaddrs($addresses); - my $prefix = (ref $prefixfunc) ? - $prefixfunc->(scalar @addrs):$prefixfunc; - return $prefix . - join(', ', map - { sprintf qq(%s', - $urlfunc->($_->address), - html_escape($_->format) || - '(unknown)' - } @addrs - ); - } - else { - my $prefix = (ref $prefixfunc) ? - $prefixfunc->(1) : $prefixfunc; - return sprintf '%s(unknown)', - $prefix, $urlfunc->(''); - } -} - -sub emailfromrfc822{ - my $addr = getparsedaddrs($_[0] || ""); - $addr = defined $addr?$addr->address:''; - return $addr; -} - -sub mainturl { package_links(maintainer => $_[0], links_only => 1); } -sub submitterurl { package_links(submitter => $_[0], links_only => 1); } -sub htmlize_maintlinks { - my ($prefixfunc, $maints) = @_; - carp "htmlize_maintlinks is deprecated"; - return htmlize_addresslinks($prefixfunc, \&mainturl, $maints); -} - -=head2 bug_linklist - - bug_linklist($separator,$class,@bugs) - -Creates a set of links to C<@bugs> separated by C<$separator> with -link class C<$class>. - -XXX Use L; we want to be able to support query -arguments here too; we should be able to combine bug_links and this -function into one. - -=cut - - -sub bug_linklist{ - my ($sep,$class,@bugs) = @_; - carp "bug_linklist is deprecated; use bug_links instead"; - return scalar bug_links(bug=>\@bugs,class=>$class,separator=>$sep); -} - - -sub add_user { - my ($user,$usertags,$bug_usertags,$seen_users,$cats,$hidden) = @_; - $seen_users = {} if not defined $seen_users; - $bug_usertags = {} if not defined $bug_usertags; - $usertags = {} if not defined $usertags; - $cats = {} if not defined $cats; - $hidden = {} if not defined $hidden; - return if exists $seen_users->{$user}; - $seen_users->{$user} = 1; - - my $u = Debbugs::User::get_user($user); - - my %vis = map { $_, 1 } @{$u->{"visible_cats"}}; - for my $c (keys %{$u->{"categories"}}) { - $cats->{$c} = $u->{"categories"}->{$c}; - $hidden->{$c} = 1 unless defined $vis{$c}; - } - for my $t (keys %{$u->{"tags"}}) { - $usertags->{$t} = [] unless defined $usertags->{$t}; - push @{$usertags->{$t}}, @{$u->{"tags"}->{$t}}; - } - - %{$bug_usertags} = (); - for my $t (keys %{$usertags}) { - for my $b (@{$usertags->{$t}}) { - $bug_usertags->{$b} = [] unless defined $bug_usertags->{$b}; - push @{$bug_usertags->{$b}}, $t; - } - } -} - - - -=head1 Forms - -=cut - -=head2 form_options_and_normal_param - - my ($form_option,$param) = form_options_and_normal_param(\%param) - if $param{form_options}; - my $form_option = form_options_and_normal_param(\%param) - if $param{form_options}; - -Translates from special form_options to a set of parameters which can -be used to run the current page. - -The idea behind this is to allow complex forms to relatively easily -cause options that the existing cgi scripts understand to be set. - -Currently there are two commands which are understood: -combine, and concatenate. - -=head3 combine - -Combine works by entering key,value pairs into the parameters using -the key field option input field, and the value field option input -field. - -For example, you would have - - - -which would combine the _fo_searchkey and _fo_searchvalue input fields, so - - - - -would yield foo=>'bar' in %param. - -=head3 concatenate - -Concatenate concatenates values into a single entry in a parameter - -For example, you would have - - - -which would combine the _fo_searchkey and _fo_searchvalue input fields, so - - - - -would yield foo=>'bar:baz' in %param. - - -=cut - -my $form_option_leader = '_fo_'; -sub form_options_and_normal_param{ - my ($orig_param) = @_; - # all form_option parameters start with _fo_ - my ($param,$form_option) = ({},{}); - for my $key (keys %{$orig_param}) { - if ($key =~ /^\Q$form_option_leader\E/) { - $form_option->{$key} = $orig_param->{$key}; - } - else { - $param->{$key} = $orig_param->{$key}; - } - } - # at this point, we check for commands - COMMAND: for my $key (keys %{$form_option}) { - $key =~ s/^\Q$form_option_leader\E//; - if (my ($key_name,$value_name) = - $key =~ /combine_key(\Q$form_option_leader\E.+) - _value(\Q$form_option_leader\E.+)$/x - ) { - next unless defined $form_option->{$key_name}; - next unless defined $form_option->{$value_name}; - my @keys = make_list($form_option->{$key_name}); - my @values = make_list($form_option->{$value_name}); - for my $i (0 .. $#keys) { - last if $i > $#values; - next if not defined $keys[$i]; - next if not defined $values[$i]; - __add_to_param($param, - $keys[$i], - $values[$i], - ); - } - } - elsif (my ($field,$concatenate_key,$fields) = - $key =~ /concatenate_into_(.+?)((?:_with_[^_])?) - ((?:\Q$form_option_leader\E.+?)+) - $/x - ) { - if (length $concatenate_key) { - $concatenate_key =~ s/_with_//; - } - else { - $concatenate_key = ':'; - } - my @fields = $fields =~ m/(\Q$form_option_leader\E.+?)(?:(?=\Q$form_option_leader\E)|$)/g; - my %field_list; - my $max_num = 0; - for my $f (@fields) { - next COMMAND unless defined $form_option->{$f}; - $field_list{$f} = [make_list($form_option->{$f})]; - $max_num = max($max_num,$#{$field_list{$f}}); - } - for my $i (0 .. $max_num) { - next unless @fields == grep {$i <= $#{$field_list{$_}} and - defined $field_list{$_}[$i]} @fields; - __add_to_param($param, - $field, - join($concatenate_key, - map {$field_list{$_}[$i]} @fields - ) - ); - } - } - } - return wantarray?($form_option,$param):$form_option; -} - -=head2 option_form - - print option_form(template=>'pkgreport_options', - param => \%param, - form_options => $form_options, - ) - - - -=cut - -sub option_form{ - my %param = validate_with(params => \@_, - spec => {template => {type => SCALAR, - }, - variables => {type => HASHREF, - default => {}, - }, - language => {type => SCALAR, - optional => 1, - }, - param => {type => HASHREF, - default => {}, - }, - form_options => {type => HASHREF, - default => {}, - }, - }, - ); - - # First, we need to see if we need to add particular types of - # parameters - my $variables = dclone($param{variables}); - $variables->{param} = dclone($param{param}); - for my $key (keys %{$param{form_option}}) { - # strip out leader; shouldn't be anything here without one, - # but skip stupid things anyway - next unless $key =~ s/^\Q$form_option_leader\E//; - if ($key =~ /^add_(.+)$/) { - # this causes a specific parameter to be added - __add_to_param($variables->{param}, - $1, - '' - ); - } - elsif ($key =~ /^delete_(.+?)(?:_(\d+))?$/) { - next unless exists $variables->{param}{$1}; - if (ref $variables->{param}{$1} eq 'ARRAY' and - defined $2 and - defined $variables->{param}{$1}[$2] - ) { - splice @{$variables->{param}{$1}},$2,1; - } - else { - delete $variables->{param}{$1}; - } - } - # we'll add extra comands here once I figure out what they - # should be - } - # now at this point, we're ready to create the template - return Debbugs::Text::fill_in_template(template=>$param{template}, - (exists $param{language}?(language=>$param{language}):()), - variables => $variables, - hole_var => {'&html_escape' => \&html_escape, - }, - ); -} - -sub __add_to_param{ - my ($param,$key,@values) = @_; - - if (exists $param->{$key} and not - ref $param->{$key}) { - @{$param->{$key}} = [$param->{$key}, - @values - ]; - } - else { - push @{$param->{$key}}, @values; - } -} - - - -=head1 misc - -=cut - -=head2 maint_decode - - maint_decode - -Decodes the funky maintainer encoding. - -Don't ask me what in the world it does. - -=cut - -sub maint_decode { - my @input = @_; - return () unless @input; - my @output; - for my $input (@input) { - my $decoded = $input; - $decoded =~ s/-([^_]+)/-$1_-/g; - $decoded =~ s/_/-20_/g; - $decoded =~ s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/; - $decoded =~ s/^([^,]+),(.*),(.*),/$1-20_-3c_$2-40_$3-3e_/; - $decoded =~ s/\./-2e_/g; - $decoded =~ s/-([0-9a-f]{2})_/pack('H*',$1)/ge; - push @output,$decoded; - } - wantarray ? @output : $output[0]; -} - -=head1 cache - -=head2 calculate_etags - - calculate_etags(files => [qw(list of files)],additional_data => [qw(any additional data)]); - -=cut - -sub calculate_etags { - my %param = - validate_with(params => \@_, - spec => {files => {type => ARRAYREF, - default => [], - }, - additional_data => {type => ARRAYREF, - default => [], - }, - }, - ); - my @additional_data = @{$param{additional_data}}; - for my $file (@{$param{files}}) { - my $st = stat($file) or warn "Unable to stat $file: $!"; - push @additional_data,$st->mtime; - push @additional_data,$st->size; - } - return(md5_hex(join('',sort @additional_data))); -} - -=head2 etag_does_not_match - - etag_does_not_match(cgi=>$q,files=>[qw(list of files)], - additional_data=>[qw(any additional data)]) - - -Checks to see if the CGI request contains an etag which matches the calculated -etag. - -If there wasn't an etag given, or the etag given doesn't match, return the etag. - -If the etag does match, return 0. - -=cut - -sub etag_does_not_match { - my %param = - validate_with(params => \@_, - spec => {files => {type => ARRAYREF, - default => [], - }, - additional_data => {type => ARRAYREF, - default => [], - }, - cgi => {type => OBJECT}, - }, - ); - my $submitted_etag = - $param{cgi}->http('if-none-match'); - my $etag = - calculate_etags(files=>$param{files}, - additional_data=>$param{additional_data}); - if (not defined $submitted_etag or - length($submitted_etag) != 32 - or $etag ne $submitted_etag - ) { - return $etag; - } - if ($etag eq $submitted_etag) { - return 0; - } -} - - -1; - - -__END__ - - - - - - diff --git a/Debbugs/CGI/Bugreport.pm b/Debbugs/CGI/Bugreport.pm deleted file mode 100644 index a606394..0000000 --- a/Debbugs/CGI/Bugreport.pm +++ /dev/null @@ -1,507 +0,0 @@ -# This module is part of debbugs, and is released -# under the terms of the GPL version 2, or any later version. See the -# file README and COPYING for more information. -# -# [Other people have contributed to this file; their copyrights should -# be listed here too.] -# Copyright 2008 by Don Armstrong . - - -package Debbugs::CGI::Bugreport; - -=head1 NAME - -Debbugs::CGI::Bugreport -- specific routines for the bugreport cgi script - -=head1 SYNOPSIS - - -=head1 DESCRIPTION - - -=head1 BUGS - -None known. - -=cut - -use warnings; -use strict; -use utf8; -use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); -use Exporter qw(import); - -use IO::Scalar; -use Params::Validate qw(validate_with :types); -use Digest::MD5 qw(md5_hex); -use Debbugs::Mail qw(get_addresses :reply); -use Debbugs::MIME qw(decode_rfc1522 create_mime_message parse_to_mime_entity); -use Debbugs::CGI qw(:url :html :util); -use Debbugs::Common qw(globify_scalar english_join hash_slice); -use Debbugs::UTF8; -use Debbugs::Config qw(:config); -use Debbugs::Log qw(:read); -use POSIX qw(strftime); -use Encode qw(decode_utf8 encode_utf8); -use URI::Escape qw(uri_escape_utf8); -use Scalar::Util qw(blessed); -use List::AllUtils qw(sum); -use File::Temp; - -BEGIN{ - ($VERSION) = q$Revision: 494 $ =~ /^Revision:\s+([^\s+])/; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - %EXPORT_TAGS = (); - @EXPORT_OK = (qw(display_entity handle_record handle_email_message)); - Exporter::export_ok_tags(keys %EXPORT_TAGS); - $EXPORT_TAGS{all} = [@EXPORT_OK]; -} - - - -=head2 display_entity - - display_entity(entity => $entity, - bug_num => $ref, - outer => 1, - msg_num => $msg_num, - attachments => \@attachments, - output => \$output); - - -=over - -=item entity -- MIME::Parser entity - -=item bug_num -- Bug number - -=item outer -- Whether this is the outer entity; defaults to 1 - -=item msg_num -- message number in the log - -=item attachments -- arrayref of attachments - -=item output -- scalar reference for output - -=back - -=cut - -sub display_entity { - my %param = validate_with(params => \@_, - spec => {entity => {type => OBJECT, - }, - bug_num => {type => SCALAR, - regex => qr/^\d+$/, - }, - outer => {type => BOOLEAN, - default => 1, - }, - msg_num => {type => SCALAR, - }, - attachments => {type => ARRAYREF, - default => [], - }, - output => {type => SCALARREF|HANDLE, - default => \*STDOUT, - }, - terse => {type => BOOLEAN, - default => 0, - }, - msg => {type => SCALAR, - optional => 1, - }, - att => {type => SCALAR, - optional => 1, - }, - trim_headers => {type => BOOLEAN, - default => 1, - }, - avatars => {type => BOOLEAN, - default => 1, - }, - } - ); - - my $output = globify_scalar($param{output}); - my $entity = $param{entity}; - my $ref = $param{bug_num}; - my $xmessage = $param{msg_num}; - my $attachments = $param{attachments}; - - my $head = $entity->head; - my $disposition = $head->mime_attr('content-disposition'); - $disposition = 'inline' if not defined $disposition or $disposition eq ''; - my $type = $entity->effective_type; - my $filename = $entity->head->recommended_filename; - $filename = '' unless defined $filename; - $filename = decode_rfc1522($filename); - - if ($param{outer} and - not $param{terse} and - not exists $param{att}) { - print {$output} "
\n"; - if ($param{trim_headers}) { - my @headers; - foreach (qw(From To Cc Subject Date)) { - my $head_field = $head->get($_); - next unless defined $head_field and $head_field ne ''; - chomp $head_field; - if ($_ eq 'From' and $param{avatars}) { - my $libravatar_url = __libravatar_url(decode_rfc1522($head_field)); - if (defined $libravatar_url and length $libravatar_url) { - push @headers,q(\n); - } - } - push @headers, qq(
$_: ) . html_escape(decode_rfc1522($head_field))."
\n"; - } - print {$output} join(qq(), @headers); - } else { - print {$output} "
".html_escape(decode_rfc1522($entity->head->stringify))."
\n"; - } - print {$output} "
\n"; - } - - if (not (($param{outer} and $type =~ m{^text(?:/plain)?(?:;|$)}) - or $type =~ m{^multipart/} - )) { - push @$attachments, $param{entity}; - # output this attachment - if (exists $param{att} and - $param{att} == $#$attachments) { - my $head = $entity->head; - chomp(my $type = $entity->effective_type); - my $body = $entity->stringify_body; - # this attachment has its own content type, so we must not - # try to convert it to UTF-8 or do anything funky. - binmode($output,':raw'); - print {$output} "Content-Type: $type"; - my ($charset) = $head->get('Content-Type:') =~ m/charset\s*=\s*\"?([\w-]+)\"?/i; - print {$output} qq(; charset="$charset") if defined $charset; - print {$output} "\n"; - if ($filename ne '') { - my $qf = $filename; - $qf =~ s/"/\\"/g; - $qf =~ s[.*/][]; - print {$output} qq{Content-Disposition: inline; filename="$qf"\n}; - } - print {$output} "\n"; - my $decoder = MIME::Decoder->new($head->mime_encoding); - $decoder->decode(IO::Scalar->new(\$body), $output); - # we don't reset the layers here, because it makes no - # sense to add anything to the output handle after this - # point. - return(1); - } - elsif (not exists $param{att}) { - my @dlargs = (msg=>$xmessage, att=>$#$attachments); - push @dlargs, (filename=>$filename) if $filename ne ''; - my $printname = $filename; - $printname = 'Message part ' . ($#$attachments + 1) if $filename eq ''; - print {$output} '
[$printname } .
-				  "($type, $disposition)]
\n"; - } - } - - return 0 if not $param{outer} and $disposition eq 'attachment' and not exists $param{att}; - return 0 unless (($type =~ m[^text/?] and - $type !~ m[^text/(?:html|enriched)(?:;|$)]) or - $type =~ m[^application/pgp(?:;|$)] or - $entity->parts); - - if ($entity->is_multipart) { - my @parts = $entity->parts; - foreach my $part (@parts) { - my $raw_output = - display_entity(entity => $part, - bug_num => $ref, - outer => 0, - msg_num => $xmessage, - output => $output, - attachments => $attachments, - terse => $param{terse}, - hash_slice(%param,qw(msg att avatars)), - ); - if ($raw_output) { - return $raw_output; - } - # print {$output} "\n"; - } - } elsif ($entity->parts) { - # We must be dealing with a nested message. - if (not exists $param{att}) { - print {$output} "
\n"; - } - my @parts = $entity->parts; - foreach my $part (@parts) { - display_entity(entity => $part, - bug_num => $ref, - outer => 1, - msg_num => $xmessage, - output => $output, - attachments => $attachments, - terse => $param{terse}, - hash_slice(%param,qw(msg att avatars)), - ); - # print {$output} "\n"; - } - if (not exists $param{att}) { - print {$output} "
\n"; - } - } elsif (not $param{terse}) { - my $content_type = $entity->head->get('Content-Type:') || "text/html"; - my ($charset) = $content_type =~ m/charset\s*=\s*\"?([\w-]+)\"?/i; - my $body = $entity->bodyhandle->as_string; - $body = convert_to_utf8($body,$charset//'utf8'); - $body = html_escape($body); - my $css_class = "message"; - # Attempt to deal with format=flowed - if ($content_type =~ m/format\s*=\s*\"?flowed\"?/i) { - $body =~ s{^\ }{}mgo; - # we ignore the other things that you can do with - # flowed e-mails cause they don't really matter. - $css_class .= " flowed"; - } - - # if the message is composed entirely of lines which are separated by - # newlines, wrap it. [Allow the signature to have special formatting.] - if ($body =~ /^([^\n]+\n\n)*[^\n]*\n?(-- \n.+)*$/s or - # if the first 20 lines in the message which have any non-space - # characters are larger than 100 characters more often than they - # are not, then use CSS to try to impose sensible wrapping - sum(0,map {length ($_) > 100?1:-1} grep {/\S/} split /\n/,$body,20) > 0 - ) { - $css_class .= " wrapping"; - } - # Add links to URLs - # We don't html escape here because we escape above; - # wierd terminators are because of that - $body =~ s{((?:ftp|http|https|svn|ftps|rsync)://[\S~-]+?/?) # Url - ((?:\>\;)?[)]?(?:'|\&\#39\;|\"\;)?[:.\,]?(?:\s|$)) # terminators - }{$1$2}gox; - # Add links to bug closures - $body =~ s[((?:closes|see):\s* # start of closed/referenced bugs - (?:bug)?\#?\s?\d+\s? # first bug - (?:,?\s*(?:bug)?\#?\s?\d+)* # additional bugs - (?:\s|\n|\)|\]|\}|\.|\,|$)) # ends with a space, newline, end of string, or ); fixes #747267 - ] - [my $temp = $1; - $temp =~ s{(\d+)} - {bug_links(bug=>$1)}ge; - $temp;]gxie; - if (defined $config{cve_tracker} and - length $config{cve_tracker} - ) { - # Add links to CVE vulnerabilities (closes #568464) - $body =~ s{(^|\s|[\(\[])(CVE-\d{4}-\d{4,})(\s|[,.-\[\]\)]|$)} - {$1$2$3}gxm; - } - if (not exists $param{att}) { - print {$output} qq(
$body
\n); - } - } - return 0; -} - - -=head2 handle_email_message - - handle_email_message($record->{text}, - ref => $bug_number, - msg_num => $msg_number, - ); - -Returns a decoded e-mail message and displays entities/attachments as -appropriate. - - -=cut - -sub handle_email_message{ - my ($record,%param) = @_; - - my $output; - my $output_fh = globify_scalar(\$output); - my $entity; - my $tempdir; - if (not blessed $record) { - $entity = parse_to_mime_entity($record); - } else { - $entity = $record; - } - my @attachments = (); - my $raw_output = - display_entity(entity => $entity, - bug_num => $param{ref}, - outer => 1, - msg_num => $param{msg_num}, - output => $output_fh, - attachments => \@attachments, - terse => $param{terse}, - hash_slice(%param,qw(msg att trim_headers avatars), - ), - ); - return $raw_output?$output:decode_utf8($output); -} - -=head2 handle_record - - push @log, handle_record($record,$ref,$msg_num); - -Deals with a record in a bug log as returned by -L; returns the log information that -should be output to the browser. - -=cut - -sub handle_record{ - my ($record,$bug_number,$msg_number,$seen_msg_ids,%param) = @_; - - # output needs to have the is_utf8 flag on to avoid double - # encoding - my $output = decode_utf8(''); - local $_ = $record->{type}; - if (/html/) { - # $record->{text} is not in perl's internal encoding; convert it - my $text = decode_rfc1522(decode_utf8(record_text($record))); - my ($time) = $text =~ //; - my $class = $text =~ /^(?:Acknowledgement|Information|Report|Notification)/m ? 'infmessage':'msgreceived'; - $output .= $text; - # Link to forwarded http:// urls in the midst of the report - # (even though these links already exist at the top) - $output =~ s,((?:ftp|http|https)://[\S~-]+?/?)((?:[\)\'\:\.\,]|\&\#39;|\"\;)? - (?:\s|\.<|$)),$1$2,gxo; - # Add links to the cloned bugs - $output =~ s{(Bug )(\d+)( cloned as bugs? )(\d+)(?:\-(\d+)|)}{$1.bug_links(bug=>$2).$3.bug_links(bug=>(defined $5)?[$4..$5]:$4)}eo; - # Add links to merged bugs - $output =~ s{(?<=Merged )([\d\s]+)(?=[\.<])}{join(' ',map {bug_links(bug=>$_)} (split /\s+/, $1))}eo; - # Add links to blocked bugs - $output =~ s{(?<=Blocking bugs)(?:( of )(\d+))?( (?:added|set to|removed):\s+)([\d\s\,]+)} - {(defined $2?$1.bug_links(bug=>$2):'').$3. - english_join([map {bug_links(bug=>$_)} (split /\,?\s+/, $4)])}eo; - $output =~ s{((?:[Aa]dded|[Rr]emoved)\ blocking\ bug(?:\(s\))?)(?:(\ of\ )(\d+))?(:?\s+) - (\d+(?:,\s+\d+)*(?:\,?\s+and\s+\d+)?)} - {$1.(defined $3?$2.bug_links(bug=>$3):'').$4. - english_join([map {bug_links(bug=>$_)} (split /\,?\s+(?:and\s+)?/, $5)])}xeo; - $output =~ s{([Aa]dded|[Rr]emoved)( indication that bug )(\d+)( blocks ?)([\d\s\,]+)} - {$1.$2.(bug_links(bug=>$3)).$4. - english_join([map {bug_links(bug=>$_)} (split /\,?\s+(?:and\s+)?/, $5)])}eo; - # Add links to reassigned packages - $output =~ s{($config{bug}\sreassigned\sfrom\spackage\s(?:[\`']|\&\#39;))([^']+?)((?:'|\&\#39;|\"\;) - \sto\s(?:[\`']|\&\#39;|\"\;))([^']+?)((?:'|\&\#39;|\"\;))} - {$1.package_links(package=>$2).$3. - package_links(package=>$4).$5}exo; - if (defined $time) { - $output .= ' ('.strftime('%a, %d %b %Y %T GMT',gmtime($time)).') '; - } - $output .= qq{(full text, mbox, '. - qq{link).

}; - - $output = qq(

\n\n) . $output . "

\n"; - } - elsif (/recips/) { - my ($msg_id) = record_regex($record,qr/^Message-Id:\s+<(.+)>/i); - if (defined $msg_id and exists $$seen_msg_ids{$msg_id}) { - return (); - } - elsif (defined $msg_id) { - $$seen_msg_ids{$msg_id} = 1; - } - return () if defined $param{spam} and $param{spam}->is_spam($msg_id); - $output .= qq(

🔗\n); - $output .= 'View this message in rfc822 format

'; - $output .= handle_email_message($record, - ref => $bug_number, - msg_num => $msg_number, - %param, - ); - } - elsif (/autocheck/) { - # Do nothing - } - elsif (/incoming-recv/) { - my ($msg_id) = record_regex($record,qr/^Message-Id:\s+<(.+)>/i); - if (defined $msg_id and exists $$seen_msg_ids{$msg_id}) { - return (); - } - elsif (defined $msg_id) { - $$seen_msg_ids{$msg_id} = 1; - } - return () if defined $param{spam} and $param{spam}->is_spam($msg_id); - # Incomming Mail Message - my ($received,$hostname) = record_regex($record,qr/Received: \(at (\S+)\) by (\S+)\;/o); - $output .= qq|

Message #$msg_number received at |. - html_escape("$received\@$hostname") . - q| (full text'. - q|, mbox, '; - my $parser = MIME::Parser->new(); - - # this will be cleaned up once it goes out of scope - my $tempdir = File::Temp->newdir(); - $parser->output_under($tempdir->dirname()); - $parser->filer->ignore_filename(1); - my $entity; - if ($record->{inner_file}) { - $entity = $parser->parse($record->{fh}); - } else { - $entity = $parser->parse_data($record->{text}); - } - my $r_l = reply_headers($entity); - $output .= q(reply); - - $output .= ')'.":

\n"; - $output .= handle_email_message($entity, - ref => $bug_number, - msg_num => $msg_number, - %param, - ); - } - else { - die "Unknown record type $_"; - } - return $output; -} - - -sub __libravatar_url { - my ($email) = @_; - if (not defined $config{libravatar_uri} or not length $config{libravatar_uri}) { - return undef; - } - ($email) = grep {/\@/} get_addresses($email); - return $config{libravatar_uri}.uri_escape_utf8($email.($config{libravatar_uri_options}//'')); -} - - -1; - - -__END__ -# Local Variables: -# cperl-indent-level: 4 -# indent-tabs-mode: nil -# End: diff --git a/Debbugs/CGI/Pkgreport.pm b/Debbugs/CGI/Pkgreport.pm deleted file mode 100644 index e3dcc12..0000000 --- a/Debbugs/CGI/Pkgreport.pm +++ /dev/null @@ -1,654 +0,0 @@ -# This module is part of debbugs, and is released -# under the terms of the GPL version 2, or any later version. See the -# file README and COPYING for more information. -# -# [Other people have contributed to this file; their copyrights should -# be listed here too.] -# Copyright 2008 by Don Armstrong . - - -package Debbugs::CGI::Pkgreport; - -=head1 NAME - -Debbugs::CGI::Pkgreport -- specific routines for the pkgreport cgi script - -=head1 SYNOPSIS - - -=head1 DESCRIPTION - - -=head1 BUGS - -None known. - -=cut - -use warnings; -use strict; -use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); -use Exporter qw(import); - -use IO::Scalar; -use Params::Validate qw(validate_with :types); - -use Debbugs::Collection::Bug; - -use Carp; -use List::AllUtils qw(apply); - -use Debbugs::Config qw(:config :globals); -use Debbugs::CGI qw(:url :html :util); -use Debbugs::Common qw(:misc :util :date); -use Debbugs::Status qw(:status); -use Debbugs::Bugs qw(bug_filter); -use Debbugs::Packages qw(:mapping); - -use Debbugs::Text qw(:templates); -use Encode qw(decode_utf8); - -use POSIX qw(strftime); - - -BEGIN{ - ($VERSION) = q$Revision: 494 $ =~ /^Revision:\s+([^\s+])/; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - %EXPORT_TAGS = (html => [qw(short_bug_status_html pkg_htmlizebugs), - ], - misc => [qw(generate_package_info), - qw(determine_ordering), - ], - ); - @EXPORT_OK = (qw()); - Exporter::export_ok_tags(keys %EXPORT_TAGS); - $EXPORT_TAGS{all} = [@EXPORT_OK]; -} - -=head2 generate_package_info - - generate_package_info($srcorbin,$package) - -Generates the informational bits for a package and returns it - -=cut - -sub generate_package_info{ - my %param = validate_with(params => \@_, - spec => {binary => {type => BOOLEAN, - default => 1, - }, - package => {type => SCALAR,#|ARRAYREF, - }, - options => {type => HASHREF, - }, - bugs => {type => ARRAYREF, - }, - schema => {type => OBJECT, - optional => 1, - }, - }, - ); - - my $output_scalar = ''; - my $output = globify_scalar(\$output_scalar); - - my $package = $param{package}; - - my %pkgsrc = %{getpkgsrc()}; - my $srcforpkg = $package; - if ($param{binary}) { - $srcforpkg = - binary_to_source(source_only => 1, - scalar_only => 1, - binary => $package, - hash_slice(%param,qw(schema)), - ); - } - - my $showpkg = html_escape($package); - my @maint = package_maintainer($param{binary}?'binary':'source', - $package, - hash_slice(%param,qw(schema)), - ); - if (@maint) { - print {$output} '

'; - print {$output} (@maint > 1? "Maintainer for $showpkg is " - : "Maintainers for $showpkg are ") . - package_links(maintainer => \@maint); - print {$output} ".

\n"; - } - else { - print {$output} "

There is no maintainer for $showpkg. ". - "This means that this package no longer exists (or never existed). ". - "Please do not report new bugs against this package.

\n"; - } - my @pkgs = source_to_binary(source => $srcforpkg, - hash_slice(%param,qw(schema)), - binary_only => 1, - # if there are distributions, only bother to - # show packages which are currently in a - # distribution. - @{$config{distributions}//[]} ? - (dist => [@{$config{distributions}}]) : (), - ) if defined $srcforpkg; - @pkgs = grep( !/^\Q$package\E$/, @pkgs ); - if ( @pkgs ) { - @pkgs = sort @pkgs; - if ($param{binary}) { - print {$output} "

You may want to refer to the following packages that are part of the same source:\n"; - } - else { - print {$output} "

You may want to refer to the following individual bug pages:\n"; - } - #push @pkgs, $src if ( $src && !grep(/^\Q$src\E$/, @pkgs) ); - print {$output} scalar package_links(package=>[@pkgs]); - print {$output} ".\n"; - } - my @references; - my $pseudodesc = getpseudodesc(); - if ($package and defined($pseudodesc) and exists($pseudodesc->{$package})) { - push @references, "to the ". - "list of other pseudo-packages"; - } - else { - if ($package and defined $config{package_pages} and length $config{package_pages}) { - push @references, sprintf "to the %s package page", - html_escape("$config{package_pages}/$package"), html_escape("$package"); - } - if (defined $config{package_tracking_domain} and - length $config{package_tracking_domain}) { - my $ptslink = $param{binary} ? $srcforpkg : $package; - # the pts only wants the source, and doesn't care about src: (#566089) - $ptslink =~ s/^src://; - push @references, q(to the Package Tracking System); - } - # Only output this if the source listing is non-trivial. - if ($param{binary} and $srcforpkg) { - push @references, - "to the source package ". - package_links(src=>$srcforpkg, - options => $param{options}) . - "'s bug page"; - } - } - if (@references) { - $references[$#references] = "or $references[$#references]" if @references > 1; - print {$output} "

You might like to refer ", join(", ", @references), ".

\n"; - } - if (@maint) { - print {$output} "

If you find a bug not listed here, please\n"; - printf {$output} "report it.

\n", - html_escape("$config{web_domain}/Reporting$config{html_suffix}"); - } - return decode_utf8($output_scalar); -} - - -=head2 short_bug_status_html - - print short_bug_status_html(status => read_bug(bug => 5), - options => \%param, - ); - -=over - -=item status -- status hashref as returned by read_bug - -=item options -- hashref of options to pass to package_links (defaults -to an empty hashref) - -=item bug_options -- hashref of options to pass to bug_links (default -to an empty hashref) - -=item snippet -- optional snippet of information about the bug to -display below - - -=back - - - -=cut - -sub short_bug_status_html { - my %param = validate_with(params => \@_, - spec => {bug => {type => OBJECT, - isa => 'Debbugs::Bug', - }, - }, - ); - - return fill_in_template(template => 'cgi/short_bug_status', - variables => {bug => $param{bug}, - isstrongseverity => \&Debbugs::Status::isstrongseverity, - html_escape => \&Debbugs::CGI::html_escape, - looks_like_number => \&Scalar::Util::looks_like_number, - }, - hole_var => {'&package_links' => \&Debbugs::CGI::package_links, - '&bug_links' => \&Debbugs::CGI::bug_links, - '&version_url' => \&Debbugs::CGI::version_url, - '&secs_to_english' => \&Debbugs::Common::secs_to_english, - '&strftime' => \&POSIX::strftime, - '&maybelink' => \&Debbugs::CGI::maybelink, - }, - ); -} - - -sub pkg_htmlizebugs { - my %param = validate_with(params => \@_, - spec => {bugs => {type => OBJECT, - }, - names => {type => ARRAYREF, - }, - title => {type => ARRAYREF, - }, - prior => {type => ARRAYREF, - }, - order => {type => ARRAYREF, - }, - ordering => {type => SCALAR, - }, - bugusertags => {type => HASHREF, - default => {}, - }, - bug_rev => {type => BOOLEAN, - default => 0, - }, - bug_order => {type => SCALAR, - }, - repeatmerged => {type => BOOLEAN, - default => 1, - }, - include => {type => ARRAYREF, - default => [], - }, - exclude => {type => ARRAYREF, - default => [], - }, - this => {type => SCALAR, - default => '', - }, - options => {type => HASHREF, - default => {}, - }, - dist => {type => SCALAR, - optional => 1, - }, - schema => {type => OBJECT, - optional => 1, - }, - } - ); - my $bugs = $param{bugs}; - my %count; - my $header = ''; - my $footer = "

Summary

\n"; - - if ($bugs->count == 0) { - return "

No reports found!

\n"; - } - - my %seenmerged; - - my %common = ( - 'show_list_header' => 1, - 'show_list_footer' => 1, - ); - - my %section = (); - # Make the include/exclude map - my %include; - my %exclude; - for my $include (make_list($param{include})) { - next unless defined $include; - my ($key,$value) = split /\s*:\s*/,$include,2; - unless (defined $value) { - $key = 'tags'; - $value = $include; - } - push @{$include{$key}}, split /\s*,\s*/, $value; - } - for my $exclude (make_list($param{exclude})) { - next unless defined $exclude; - my ($key,$value) = split /\s*:\s*/,$exclude,2; - unless (defined $value) { - $key = 'tags'; - $value = $exclude; - } - push @{$exclude{$key}}, split /\s*,\s*/, $value; - } - - my $sorter = sub {$_[0]->id <=> $_[1]->id}; - if ($param{bug_rev}) { - $sorter = sub {$_[1]->id <=> $_[0]->id} - } - elsif ($param{bug_order} eq 'age') { - $sorter = sub {$_[0]->modified->epoch <=> $_[1]->modified->epoch}; - } - elsif ($param{bug_order} eq 'agerev') { - $sorter = sub {$_[1]->modified->epoch <=> $_[0]->modified->epoch}; - } - my @status; - for my $bug ($bugs->sort($sorter)) { - next if - $bug->filter(repeat_merged => $param{repeatmerged}, - seen_merged => \%seenmerged, - (keys %include ? (include => \%include):()), - (keys %exclude ? (exclude => \%exclude):()), - ); - - my $html = "
  • "; ##%d: %s\n
    ", - $html .= short_bug_status_html(bug => $bug, - ) . "\n"; - push @status, [ $bug, $html ]; - } - # parse bug order indexes into subroutines - my @order_subs = - map { - my $a = $_; - [map {parse_order_statement_to_subroutine($_)} @{$a}]; - } @{$param{prior}}; - for my $entry (@status) { - my $key = ""; - for my $i (0..$#order_subs) { - my $v = get_bug_order_index($order_subs[$i], $entry->[0]); - $count{"g_${i}_${v}"}++; - $key .= "_$v"; - } - $section{$key} .= $entry->[1]; - $count{"_$key"}++; - } - - my $result = ""; - if ($param{ordering} eq "raw") { - $result .= "
      \n" . join("", map( { $_->[ 1 ] } @status ) ) . "
    \n"; - } - else { - $header .= "
    \n
      \n"; - my @keys_in_order = (""); - for my $o (@{$param{order}}) { - push @keys_in_order, "X"; - while ((my $k = shift @keys_in_order) ne "X") { - for my $k2 (@{$o}) { - $k2+=0; - push @keys_in_order, "${k}_${k2}"; - } - } - } - for my $order (@keys_in_order) { - next unless defined $section{$order}; - my @ttl = split /_/, $order; - shift @ttl; - my $title = $param{title}[0]->[$ttl[0]] . " bugs"; - if ($#ttl > 0) { - $title .= " -- "; - $title .= join("; ", grep {($_ || "") ne ""} - map { $param{title}[$_]->[$ttl[$_]] } 1..$#ttl); - } - $title = html_escape($title); - - my $count = $count{"_$order"}; - my $bugs = $count == 1 ? "bug" : "bugs"; - - $header .= "
    • $title ($count $bugs)
      • \n"; - if ($common{show_list_header}) { - my $count = $count{"_$order"}; - my $bugs = $count == 1 ? "bug" : "bugs"; - $result .= "

      $title ($count $bugs)

      \n"; - } - else { - $result .= "

      $title

      \n"; - } - $result .= "
      \n
        \n"; - $result .= "\n\n\n\n"; - $result .= $section{$order}; - $result .= "\n\n\n\n"; - $result .= "
      \n
      \n"; - } - $header .= "
    \n"; - - $footer .= "
    \n
      \n"; - for my $i (0..$#{$param{prior}}) { - my $local_result = ''; - foreach my $key ( @{$param{order}[$i]} ) { - my $count = $count{"g_${i}_$key"}; - next if !$count or !$param{title}[$i]->[$key]; - $local_result .= "
    • $count $param{title}[$i]->[$key]
      • \n"; - } - if ( $local_result ) { - $footer .= "
    • $param{names}[$i]
        \n$local_result
      • \n"; - } - } - $footer .= "
    \n
    \n"; - } - - $result = $header . $result if ( $common{show_list_header} ); - $result .= $footer if ( $common{show_list_footer} ); - return $result; -} - -sub parse_order_statement_to_subroutine { - my ($statement) = @_; - if (not defined $statement or not length $statement) { - return sub {return 1}; - } - croak "invalid statement '$statement'" unless - $statement =~ /^(?:(package|tag|pending|severity) # field - = # equals - ([^=|\&,\+]+(?:,[^=|\&,+])*) #value - (\+|,|$) # joiner or end - )+ # one or more of these statements - /x; - my @sub_bits; - while ($statement =~ /(?^|,|\+) # joiner - (?package|tag|pending|severity) # field - = # equals - (?[^=|\&,\+]+(?:,[^=|\&,\+])*) #value - /xg) { - my $field = $+{field}; - my $value = $+{value}; - my $joiner = $+{joiner} // ''; - my @vals = apply {quotemeta($_)} split /,/,$value; - if (length $joiner) { - if ($joiner eq '+') { - push @sub_bits, ' and '; - } - else { - push @sub_bits, ' or '; - } - } - my @vals_bits; - for my $val (@vals) { - if ($field =~ /package|severity/o) { - push @vals_bits, '$_[0]->status->'.$field. - ' eq q('.$val.')'; - } elsif ($field eq 'tag') { - push @vals_bits, '$_[0]->tags->is_set('. - 'q('.$val.'))'; - } elsif ($field eq 'pending') { - push @vals_bits, '$_[0]->'.$field. - ' eq q('.$val.')'; - } - } - push @sub_bits ,' ('.join(' or ',@vals_bits).') '; - } - # return a subroutine reference which determines whether an order statement - # matches this bug - my $sub = 'sub { return ('.join ("\n",@sub_bits).');};'; - my $subref = eval $sub; - if ($@) { - croak "Unable to generate subroutine: $@; $sub"; - } - return $subref; -} - -sub parse_order_statement_into_boolean { - my ($statement,$status,$tags) = @_; - - if (not defined $tags) { - $tags = {map { $_, 1 } split / /, $status->{"tags"} - } - if defined $status->{"tags"}; - - } - # replace all + with && - $statement =~ s/\+/&&/g; - # replace all , with || - $statement =~ s/,/||/g; - $statement =~ s{([^\&\|\=]+) # field - = - ([^\&\|\=]+) # value - }{ - my $ok = 0; - if ($1 eq 'tag') { - $ok = 1 if defined $tags->{$2}; - } else { - $ok = 1 if defined $status->{$1} and - $status->{$1} eq $2; - } - $ok; - }exg; - # check that the parsed statement is just valid boolean statements - if ($statement =~ /^([01\(\)\&\|]+)$/) { - return eval "$1"; - } else { - # this is an invalid boolean statement - return 0; - } -} - -sub get_bug_order_index { - my ($order,$bug) = @_; - my $pos = 0; - for my $el (@{$order}) { - if ($el->($bug)) { - return $pos; - } - $pos++; - } - return $pos; -} - -# sets: my @names; my @prior; my @title; my @order; - -sub determine_ordering { - my %param = validate_with(params => \@_, - spec => {cats => {type => HASHREF, - }, - param => {type => HASHREF, - }, - ordering => {type => SCALARREF, - }, - names => {type => ARRAYREF, - }, - pend_rev => {type => BOOLEAN, - default => 0, - }, - sev_rev => {type => BOOLEAN, - default => 0, - }, - prior => {type => ARRAYREF, - }, - title => {type => ARRAYREF, - }, - order => {type => ARRAYREF, - }, - }, - ); - $param{cats}{status}[0]{ord} = [ reverse @{$param{cats}{status}[0]{ord}} ] - if ($param{pend_rev}); - $param{cats}{severity}[0]{ord} = [ reverse @{$param{cats}{severity}[0]{ord}} ] - if ($param{sev_rev}); - - my $i; - if (defined $param{param}{"pri0"}) { - my @c = (); - $i = 0; - while (defined $param{param}{"pri$i"}) { - my $h = {}; - - my ($pri) = make_list($param{param}{"pri$i"}); - if ($pri =~ m/^([^:]*):(.*)$/) { - $h->{"nam"} = $1; # overridden later if necesary - $h->{"pri"} = [ map { "$1=$_" } (split /,/, $2) ]; - } - else { - $h->{"pri"} = [ split /,/, $pri ]; - } - - ($h->{"nam"}) = make_list($param{param}{"nam$i"}) - if (defined $param{param}{"nam$i"}); - $h->{"ord"} = [ map {split /\s*,\s*/} make_list($param{param}{"ord$i"}) ] - if (defined $param{param}{"ord$i"}); - $h->{"ttl"} = [ map {split /\s*,\s*/} make_list($param{param}{"ttl$i"}) ] - if (defined $param{param}{"ttl$i"}); - - push @c, $h; - $i++; - } - $param{cats}{"_"} = [@c]; - ${$param{ordering}} = "_"; - } - - ${$param{ordering}} = "normal" unless defined $param{cats}{${$param{ordering}}}; - - sub get_ordering { - my @res; - my $cats = shift; - my $o = shift; - for my $c (@{$cats->{$o}}) { - if (ref($c) eq "HASH") { - push @res, $c; - } - else { - push @res, get_ordering($cats, $c); - } - } - return @res; - } - my @cats = get_ordering($param{cats}, ${$param{ordering}}); - - sub toenglish { - my $expr = shift; - $expr =~ s/[+]/ and /g; - $expr =~ s/[a-z]+=//g; - return $expr; - } - - $i = 0; - for my $c (@cats) { - $i++; - push @{$param{prior}}, $c->{"pri"}; - push @{$param{names}}, ($c->{"nam"} || "Bug attribute #" . $i); - if (defined $c->{"ord"}) { - push @{$param{order}}, $c->{"ord"}; - } - else { - push @{$param{order}}, [ 0..$#{$param{prior}[-1]} ]; - } - my @t = @{ $c->{"ttl"} } if defined $c->{ttl}; - if (@t < $#{$param{prior}[-1]}) { - push @t, map { toenglish($param{prior}[-1][$_]) } @t..($#{$param{prior}[-1]}); - } - push @t, $c->{"def"} || ""; - push @{$param{title}}, [@t]; - } -} - - - - -1; - - -__END__ - - - - - - diff --git a/Debbugs/Collection.pm b/Debbugs/Collection.pm deleted file mode 100644 index 6e3d49d..0000000 --- a/Debbugs/Collection.pm +++ /dev/null @@ -1,390 +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::Collection; - -=head1 NAME - -Debbugs::Collection -- Collection base class which can generate lots of objects - -=head1 SYNOPSIS - -This base class is designed for holding collections of objects which can be -uniquely identified by a key and added/generated by that same key. - -=head1 DESCRIPTION - - - -=cut - -use Mouse; -use strictures 2; -use namespace::autoclean; -use List::AllUtils qw(pairmap); -use Carp qw(croak); - -extends 'Debbugs::OOBase'; - -=head1 METHODS - -=head2 Debbugs::Collection->new(%params|$params) - -Creates a new Debbugs::Collection object. - -Parameters: - -=over - -=item universe - -To avoid unnecessarily constructing new members, collections have a universe to -which existing members can be obtained from. By default the universe is this -collection. Generally, you should create exactly one universe for each -collection type. - -=item schema - -Optional Debbugs::Schema object - - -=back - -=head2 $collection->members() - -Returns list of members of this collection - -=head2 $collection->members_ref() - -Returns an ARRAYREF of members of this collection - -=head2 $collection->keys_of_members() - -Returns a list of the keys of all members of this collection - -=head2 $collection->member_key($member) - -Given a member, returns the key of that member - -=head2 $collection->exists($member_key) - -Returns true if a member with $member_key exists in the collection - -=head2 $collection->clone() - -Returns a clone of this collection with the same universe as this collection - -=head2 $collection->limit(@member_keys) - -Returns a new collection limited to the list of member keys passed. Will add new -members to the universe if they do not currently exist. - -=head2 $collection->add($member) - -Add a member to this collection - -=head2 $collection->add_by_key($member_key) - -Add a member to this collection by key - -=head2 $collection->combine($collection2) or $collection + $collection2 - -Combines the members of both collections together and returns the new collection - -=head2 $collection->get($member_key) - -Get member(s) by key, returning undef for keys which do not exist in the -collection - -=head2 $collection->get_or_add_by_key($member_key) - -Get or add a member by the member key. - -=head2 $collection->count() - -Return the number of members in this collection - -=head2 $collection->grep({$_ eq 5}) - -Return the members in this collection which satisfy the condition, setting $_ -locally to each member object - -=head2 $collection->join(', ') - -Returns the keys of the members of this collection joined - -=head2 $collection->apply({$_*2}) - -Return the list of applying BLOCK to each member; each member can return 0 or -more results - -=head2 $collection->map({$_*2}) - -Returns the list of applying BLOCK to each member; each member should return -exactly one result - -=head2 $collection->sort({$a <=> $b}) - -Return the list of members sorted by BLOCK - -=cut - -has 'members' => (is => 'bare', - isa => 'ArrayRef', - traits => ['Array'], - default => sub {[]}, - writer => '_set_members', - predicate => '_has_members', - handles => {_add => 'push', - members => 'elements', - count => 'count', - _get_member => 'get', - grep => 'grep', - map => 'map', - sort => 'sort', - }, - ); - -sub apply { - my $self = shift; - my $block = shift; - my @r; - for ($self->members) { - push @r,$block->(); - } - return @r; -} - -sub members_ref { - my $self = shift; - return [$self->members]; -} - -has 'member_hash' => (traits => ['Hash'], - is => 'bare', - # really a HashRef[Int], but type checking is too slow - isa => 'HashRef', - lazy => 1, - reader => '_member_hash', - builder => '_build_member_hash', - clearer => '_clear_member_hash', - predicate => '_has_member_hash', - writer => '_set_member_hash', - handles => {# _add_member_hash => 'set', - _member_key_exists => 'exists', - _get_member_hash => 'get', - }, - ); - -# because _add_member_hash needs to be fast, we are overriding the default set -# method which is very safe but slow, because it makes copies. -sub _add_member_hash { - my ($self,@kv) = @_; - pairmap { - defined($a) - or $self->meta-> - throw_error("Hash keys passed to _add_member_hash must be defined" ); - ($b eq int($b)) or - $self->meta-> - throw_error("Values passed to _add_member_hash must be integer"); - } @kv; - my @return; - while (my ($key, $value) = splice @kv, 0, 2 ) { - push @return, - $self->{member_hash}{$key} = $value - } - wantarray ? return @return: return $return[0]; -} - -=head2 $collection->universe - - -=cut - -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 clone { - my $self = shift; - my $new = bless { %{$self} }, ref $self; - if ($self->_has_members) { - $new->_set_members([$self->members]); - } - if ($self->_has_member_hash) { - $new->_set_member_hash({%{$self->_member_hash}}) - } - return $new; -} - -sub _shallow_clone { - my $self = shift; - return bless { %{$self} }, ref $self; -} - -sub limit { - my $self = shift; - my $limit = $self->_shallow_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_add_by_key(@_)) if @_; - return $limit; -} - -sub get_or_add_by_key { - my $self = shift; - return () unless @_; - 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 object to return - if (ref $_[$i]) { - croak "Passed a reference instead of a key to get_or_add_by_key"; - } - elsif ($self->_member_key_exists($_[$i])) { - push @exists,$i; - } else { - push @need_to_add,$i; - } - } - # create and add by key - if (@need_to_add) { - @return[@need_to_add] = - $self->add_by_key(@_[@need_to_add]); - } - if (@exists) { - @return[@exists] = - $self->get(@_[@exists]); - } - # if we've only been asked to get or create one thing, then it's expected - # that we are returning only one thing - if (@_ == 1) { - return $return[0]; - } - return @return; -} - -has 'constructor_args' => (is => 'rw', - isa => 'ArrayRef', - lazy => 1, - builder => '_build_constructor_args', - ); - -sub _build_constructor_args { - return []; -} - -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_added; - for my $member (@_) { - if (not defined $member) { - confess("Undefined member to add"); - } - push @members_added,$member; - if ($self->exists($member)) { - next; - } - $self->_add($member); - $self->_add_member_hash($self->member_key($member), - $self->count()-1, - ); - } - return @members_added; -} - -use overload '+' => "combine", - '""' => "CARP_TRACE"; - -sub combine { - my $self = shift; - my $return = $self->clone; - $return->add($_->members) for @_; - return $return; -} - -sub get { - my $self = shift; - my @res = map {$self->_get_member($_)} - $self->_get_member_hash(@_); - wantarray?@res:$res[0]; -} - - -sub member_key { - return $_[1]; -} - -sub keys_of_members { - my $self = shift; - return $self->map(sub {$self->member_key($_)}); -} - -sub exists { - my $self = shift; - return $self->_member_key_exists($self->member_key($_[0])); -} - -sub join { - my $self = shift; - my $joiner = shift; - return CORE::join($joiner,$self->keys_of_members); -} - -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; -} - -sub CARP_TRACE { - my $self = shift; - my @members = $self->members; - if (@members > 5) { - @members = map {$self->member_key($_)} - @members[0..4]; - push @members,'...'; - } else { - @members = map {$self->member_key($_)} @members; - } - return __PACKAGE__.'={n_members='.$self->count(). - ',members=('.CORE::join(',',@members).')}'; -} - - -__PACKAGE__->meta->make_immutable; -no Mouse; -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 deleted file mode 100644 index 3f40b0c..0000000 --- a/Debbugs/Collection/Bug.pm +++ /dev/null @@ -1,216 +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::Collection::Bug; - -=head1 NAME - -Debbugs::Collection::Bug -- Bug generation factory - -=head1 SYNOPSIS - -This collection extends L and contains members of -L. Useful for any field which contains one or more bug or tracking -lists of packages - -=head1 DESCRIPTION - - - -=head1 METHODS - -=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); -use Debbugs::Collection::Package; -use Debbugs::Collection::Correspondent; - -use Debbugs::Bug; - -extends 'Debbugs::Collection'; - -=head2 my $bugs = Debbugs::Collection::Bug->new(%params|$param) - -Parameters in addition to those defined by L - -=over - -=item package_collection - -Optional L which is used to look up packages - - -=item correspondent_collection - -Optional L which is used to look up correspondents - - -=item users - -Optional arrayref of L which set usertags for bugs in this collection - -=back - -=head2 $bugs->package_collection() - -Returns the package collection that this bug collection is using - -=head2 $bugs->correspondent_collection() - -Returns the correspondent collection that this bug collection is using - -=head2 $bugs->users() - -Returns the arrayref of users that this bug collection is using - -=head2 $bugs->add_user($user) - -Add a user to the set of users that this bug collection is using - -=head2 $bugs->load_related_packages_and_versions() - -Preload all of the related packages and versions for the bugs in this bug -collection. You should call this if you plan on calculating whether the bugs in -this collection are present/absent. - -=cut - -has '+members' => (isa => 'ArrayRef[Bug]'); -has 'package_collection' => - (is => 'ro', - isa => 'Debbugs::Collection::Package', - builder => '_build_package_collection', - lazy => 1, - ); - -sub _build_package_collection { - my $self = shift; - return Debbugs::Collection::Package->new($self->has_schema?(schema => $self->schema):()); -} - -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->has_schema?(schema => $self->schema):()); -} - -has 'users' => - (is => 'ro', - isa => 'ArrayRef[Debbugs::User]', - traits => ['Array'], - default => sub {[]}, - handles => {'add_user' => 'push'}, - ); - -sub BUILD { - my $self = shift; - my $args = shift; - if (exists $args->{bugs}) { - $self->add( - $self->_member_constructor(bugs => $args->{bugs} - )); - } -} - -sub _member_constructor { - # handle being called $self->_member_constructor; - my $self = shift; - my %args = @_; - my @return; - my $schema; - $schema = $self->schema if $self->has_schema; - - if (defined $schema) { - my $statuses = get_bug_statuses(bug => [make_list($args{bugs})], - schema => $schema, - ); - # preload as many of the packages as we need - my %packages; - while (my ($bug, $status) = each %{$statuses}) { - if (defined $status->{package}) { - $packages{$_} = 1 for split /,/, $status->{package}; - } - if (defined $status->{source}) { - $packages{$_} = 1 for split /,/, $status->{source}; - } - } - $self->package_collection->universe->add_by_key(keys %packages); - while (my ($bug, $status) = each %{$statuses}) { - push @return, - Debbugs::Bug->new(bug => $bug, - status => - Debbugs::Bug::Status->new(status => $status, - bug => $bug, - status_source => 'db', - ), - schema => $schema, - package_collection => - $self->package_collection->universe, - bug_collection => - $self->universe, - correspondent_collection => - $self->correspondent_collection->universe, - @{$args{constructor_args}//[]}, - ); - } - } else { - for my $bug (make_list($args{bugs})) { - push @return, - Debbugs::Bug->new(bug => $bug, - package_collection => - $self->package_collection->universe, - bug_collection => - $self->universe, - correspondent_collection => - $self->correspondent_collection->universe, - @{$args{constructor_args}//[]}, - ); - } - } - return @return; -} - -around add_by_key => sub { - my $orig = shift; - my $self = shift; - my @members = - $self->_member_constructor(bugs => [@_], - ); - return $self->$orig(@members); -}; - -sub member_key { - return $_[1]->bug; -} - -sub load_related_packages_and_versions { - my $self = shift; - my @related_packages_and_versions = - $self->apply(sub {$_->related_packages_and_versions}); - $self->package_collection-> - add_packages_and_versions(@related_packages_and_versions); -} - -__PACKAGE__->meta->make_immutable; - -1; - -__END__ -# Local Variables: -# indent-tabs-mode: nil -# cperl-indent-level: 4 -# End: diff --git a/Debbugs/Collection/Correspondent.pm b/Debbugs/Collection/Correspondent.pm deleted file mode 100644 index 43ac8c0..0000000 --- a/Debbugs/Collection/Correspondent.pm +++ /dev/null @@ -1,83 +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::Collection::Correspondent; - -=head1 NAME - -Debbugs::Collection::Correspondent -- 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); - -use Debbugs::Correspondent; - -extends 'Debbugs::Collection'; - -has '+members' => (isa => 'ArrayRef[Debbugs::Correspondent]'); - -sub BUILD { - my $self = shift; - my $args = shift; - if (exists $args->{correspondent}) { - $self-> - add($self->_member_constructor(correspondent => - $args->{correspondent})); - } -} - - -sub _member_constructor { - # handle being called $self->_member_constructor; - my $self = shift; - my %args = @_; - my @return; - for my $corr (make_list($args{correspondent})) { - push @return, - Debbugs::Correspondent->new(name => $corr, - $self->schema_argument, - ); - } - return @return; -} - -around add_by_key => sub { - my $orig = shift; - my $self = shift; - my @members = - $self->_member_constructor(correspondent => [@_], - $self->schema_argument, - ); - return $self->$orig(@members); -}; - -sub member_key { - return $_[1]->name; -} - - -__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 deleted file mode 100644 index 055cbae..0000000 --- a/Debbugs/Collection/Package.pm +++ /dev/null @@ -1,293 +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::Collection::Package; - -=head1 NAME - -Debbugs::Collection::Package -- Package generation factory - -=head1 SYNOPSIS - -This collection extends L and contains members of -L. Useful for any field which contains one or more package or -tracking lists of packages - - -=head1 DESCRIPTION - - - -=cut - -use Mouse; -use strictures 2; -use v5.10; # for state -use namespace::autoclean; - -use Carp; -use Debbugs::Common qw(make_list hash_slice); -use Debbugs::Config qw(:config); -use Debbugs::OOTypes; -use Debbugs::Package; - -use List::AllUtils qw(part); - -use Debbugs::Version::Binary; -use Debbugs::Collection::Version; -use Debbugs::Collection::Correspondent; -use Debbugs::VersionTree; - -extends 'Debbugs::Collection'; - -=head1 Object Creation - -=head2 my $packages = Debbugs::Collection::Package->new(%params|$param) - -Parameters in addition to those defined by L - -=over - -=item correspondent_collection - -Optional L which is used to look up correspondents - - -=item versiontree - -Optional L which contains known package source versions - -=back - -=head1 Methods - -=head2 correspondent_collection - - $packages->correspondent_collection - -Returns the L for this package collection - -=head2 versiontree - -Returns the L for this package collection - -=cut - -has '+members' => (isa => 'ArrayRef[Debbugs::Package]'); - -sub BUILD { - my $self = shift; - my $args = shift; - if (exists $args->{packages}) { - $self-> - add($self->_member_constructor(packages => - $args->{packages})); - } -} - -around add_by_key => sub { - my $orig = shift; - my $self = shift; - my @members = - $self->_member_constructor(packages => [@_]); - return $self->$orig(@members); -}; - -sub _member_constructor { - # handle being called $self->_member_constructor; - my $self = shift; - my %args = @_; - my $schema; - if ($self->has_schema) { - $schema = $self->schema; - } - my @return; - if (defined $schema) { - if (not ref($args{packages}) or @{$args{packages}} == 1 and - $self->universe->count() > 0 - ) { - carp("Likely inefficiency; member_constructor called with one argument"); - } - my $packages = - Debbugs::Package::_get_valid_version_info_from_db(packages => $args{packages}, - schema => $schema, - ); - for my $package (keys %{$packages}) { - push @return, - Debbugs::Package->new(%{$packages->{$package}}, - schema => $schema, - package_collection => $self->universe, - correspondent_collection => - $self->correspondent_collection->universe, - ); - } - } else { - for my $package (make_list($args{packages})) { - push @return, - Debbugs::Package->new(name => $package, - package_collection => $self->universe, - correspondent_collection => - $self->correspondent_collection->universe, - ); - } - } - return @return; -} - -sub add_packages_and_versions { - my $self = shift; - $self->add($self->_member_constructor(packages => \@_)); -} - - -sub member_key { - return $_[1]->qualified_name; -} - -has 'correspondent_collection' => - (is => 'ro', - isa => 'Debbugs::Collection::Correspondent', - default => sub {Debbugs::Collection::Correspondent->new()}, - ); - -has 'versiontree' => - (is => 'ro', - isa => 'Debbugs::VersionTree', - lazy => 1, - builder => '_build_versiontree', - ); - -sub _build_versiontree { - my $self = shift; - return Debbugs::VersionTree->new($self->has_schema?(schema => $self->schema):()); -} - -=head2 get_source_versions_distributions - - $packages->get_source_versions_distributions('unstable') - -Given a list of distributions or suites, returns a -L of all of the versions in this package -collection which are known to match. - -Effectively, this calls L for -each package in the collection and merges the results and returns them - -=cut - -sub get_source_versions_distributions { - my $self = shift; - my @return; - push @return, - $self->map(sub {$_->get_source_version_distribution(@_)}); - if (@return > 1) { - return $return[0]->combine($return[1..$#return]); - } - return @return; -} - - -=head2 get_source_versions - - $packages->get_source_versions('1.2.3-1','foo/1.2.3-5') - -Given a list of binary versions or src/versions, returns a -L of all of the versions in this package -collection which are known to match. - -If you give a binary version ('1.2.3-1'), you must have already loaded source -packages into this package collection for it to find an appropriate match. - -If no package is known to match, an version which is invalid will be returned - -For fully qualified versions this loads the appropriate source package into the -universe of this collection and calls L. -For unqualified versions, calls L; if no -valid versions are returned, creates an invalid version. - -=cut - -sub get_source_versions { - my $self = shift; - my @return; - for my $ver (@_) { - my $sv; - if ($ver =~ m{(?.+?)/(?.+)$}) { - my $sp = $self->universe-> - get_or_add_by_key('src:'.$+{src}); - push @return, - $sp->get_source_version($+{ver}); - next; - } else { - my $found_valid = 0; - for my $p ($self->members) { - local $_; - my @vs = - grep {$_->is_valid} - $p->get_source_version($ver); - if (@vs) { - $found_valid = 1; - push @return,@vs; - next; - } - } - if (not $found_valid) { - push @return, - Debbugs::Version::Binary->new(version => $ver, - package_collection => $self->universe, - valid => 0, - $self->schema_argument, - ); - } - } - } - return - Debbugs::Collection::Version->new(members => \@return, - $self->schema_argument, - package_collection => $self->universe, - ); -} - -=head2 source_names - - $packages->source_names() - -Returns a unique list of source names from all members of this collection by -calling L on each member. - -=cut - -sub source_names { - my $self = shift; - local $_; - return uniq map {$_->source_names} $self->members; -} - -=head2 sources - - $packages->sources() - -Returns a L limited to source packages -corresponding to all packages in this collection - -=cut - -sub sources { - my $self = shift; - return $self->universe->limit($self->source_names); -} - - -__PACKAGE__->meta->make_immutable; -no Mouse; - -1; - -__END__ -# Local Variables: -# indent-tabs-mode: nil -# cperl-indent-level: 4 -# End: diff --git a/Debbugs/Collection/Version.pm b/Debbugs/Collection/Version.pm deleted file mode 100644 index f461afe..0000000 --- a/Debbugs/Collection/Version.pm +++ /dev/null @@ -1,148 +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::Collection::Version; - -=head1 NAME - -Debbugs::Collection::Version -- Version generation factory - -=head1 SYNOPSIS - -This collection extends L and contains members of -L. Useful for any field which contains package versions. - - -=head1 DESCRIPTION - - - -=cut - -use Mouse; -use strictures 2; -use v5.10; # for state -use namespace::autoclean; -use Debbugs::Common qw(make_list hash_slice); -use Debbugs::Config qw(:config); -use Debbugs::OOTypes; -use Debbugs::Version; - -use List::AllUtils qw(part); - -extends 'Debbugs::Collection'; - -=head2 my $bugs = Debbugs::Collection::version->new(%params|$param) - -Parameters in addition to those defined by L - -=over - -=item package_collection - -Optional L which is used to look up packages - -=item versions - -Optional arrayref of C string triples - -=back - -=cut - -has '+members' => (isa => 'ArrayRef[Debbugs::Version]'); - -has 'package_collection' => - (is => 'ro', - isa => 'Debbugs::Collection::Package', - builder => '_build_package_collection', - lazy => 1, - ); - -sub _build_package_collection { - my $self = shift; - return Debbugs::Collection::Package->new($self->schema_argument); -} - -sub member_key { - my ($self,$v) = @_; - confess("v not defined") unless defined $v; - return $v->package.'/'.$v->version.'/'.$v->arch; -} - - -around add_by_key => sub { - my $orig = shift; - my $self = shift; - my @members = - $self->_member_constructor(versions => [@_]); - return $self->$orig(@members); -}; - -sub _member_constructor { - my $self = shift; - my %args = @_; - my @return; - for my $pkg_ver_arch (make_list($args{versions})) { - my ($pkg,$ver,$arch) = $pkg_ver_arch =~ m{^([^/]+)/([^/]+)/?([^/]*)$} or - confess("Invalid version key: $pkg_ver_arch"); - if ($pkg =~ s/^src://) { - $arch = 'source'; - } - if (not length $arch) { - $arch = 'any'; - } - if ($arch eq 'source') { - push @return, - Debbugs::Version::Source-> - new($self->schema_argument, - package => $pkg, - version => $ver, - ); - } else { - push @return, - Debbugs::Version::Binary-> - new($self->schema_argument, - package => $pkg, - version => $ver, - arch => [$arch], - ); - } - } - return @return; -} - -=head2 $versions->universe - -Unlike most collections, Debbugs::Collection::Version do not have a universe. - -=cut - -sub universe { - return $_[0]; -} - -=head2 $versions->source - -Returns a (potentially duplicated) list of source packages which are part of -this version collection - -=cut - -sub source { - my $self = shift; - return $self->map(sub{$_->source}); -} - -__PACKAGE__->meta->make_immutable; - -1; - -__END__ -# Local Variables: -# indent-tabs-mode: nil -# cperl-indent-level: 4 -# End: diff --git a/Debbugs/Command.pm b/Debbugs/Command.pm deleted file mode 100644 index c68dd70..0000000 --- a/Debbugs/Command.pm +++ /dev/null @@ -1,101 +0,0 @@ -# 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 2017 by Don Armstrong . - -package Debbugs::Command; - -=head1 NAME - -Debbugs::Command -- Handle multiple subcommand-style commands - -=head1 SYNOPSIS - - use Debbugs::Command; - -=head1 DESCRIPTION - - -=head1 BUGS - -None known. - -=cut - -use warnings; -use strict; -use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); -use base qw(Exporter); - -BEGIN{ - $VERSION = '0.1'; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - %EXPORT_TAGS = (commands => [qw(handle_main_arguments), - qw(handle_subcommand_arguments) - ], - ); - @EXPORT_OK = (); - Exporter::export_ok_tags(keys %EXPORT_TAGS); - $EXPORT_TAGS{all} = [@EXPORT_OK]; - -} - -use Getopt::Long qw(:config no_ignore_case); -use Pod::Usage qw(pod2usage); - -=head1 Command processing (:commands) - -Functions which parse arguments for commands (exportable with -C<:commands>) - -=over - -=item handle_main_arguments( - -=cut - -sub handle_main_arguments { - my ($options,@args) = @_; - Getopt::Long::Configure('pass_through'); - GetOptions($options,@args); - Getopt::Long::Configure('default'); - return $options; -} - - - -sub handle_subcommand_arguments { - my ($argv,$args,$subopt) = @_; - $subopt //= {}; - Getopt::Long::GetOptionsFromArray($argv, - $subopt, - keys %{$args}, - ); - my @usage_errors; - for my $arg (keys %{$args}) { - next unless $args->{$arg}; - my $r_arg = $arg; # real argument name - $r_arg =~ s/[=\|].+//g; - if (not defined $subopt->{$r_arg}) { - push @usage_errors, "You must give a $r_arg option"; - } - } - pod2usage(join("\n",@usage_errors)) if @usage_errors; - return $subopt; -} - -=back - -=cut - - -1; - - -__END__ -# Local Variables: -# indent-tabs-mode: nil -# cperl-indent-level: 4 -# End: diff --git a/Debbugs/Common.pm b/Debbugs/Common.pm deleted file mode 100644 index b135c42..0000000 --- a/Debbugs/Common.pm +++ /dev/null @@ -1,1238 +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. -# -# [Other people have contributed to this file; their copyrights should -# go here too.] -# Copyright 2007 by Don Armstrong . - -package Debbugs::Common; - -=head1 NAME - -Debbugs::Common -- Common routines for all of Debbugs - -=head1 SYNOPSIS - -use Debbugs::Common qw(:url :html); - - -=head1 DESCRIPTION - -This module is a replacement for the general parts of errorlib.pl. -subroutines in errorlib.pl will be gradually phased out and replaced -with equivalent (or better) functionality here. - -=head1 FUNCTIONS - -=cut - -use warnings; -use strict; -use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); -use Exporter qw(import); -use v5.10; - -BEGIN{ - $VERSION = 1.00; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - %EXPORT_TAGS = (util => [qw(getbugcomponent getbuglocation getlocationpath get_hashname), - qw(appendfile overwritefile buglog getparsedaddrs getmaintainers), - qw(getsourcemaintainers getsourcemaintainers_reverse), - qw(bug_status), - qw(getmaintainers_reverse), - qw(getpseudodesc), - qw(package_maintainer), - qw(sort_versions), - qw(open_compressed_file), - qw(walk_bugs), - ], - misc => [qw(make_list globify_scalar english_join checkpid), - qw(cleanup_eval_fail), - qw(hash_slice), - ], - date => [qw(secs_to_english)], - quit => [qw(quit)], - lock => [qw(filelock unfilelock lockpid simple_filelock simple_unlockfile)], - ); - @EXPORT_OK = (); - Exporter::export_ok_tags(keys %EXPORT_TAGS); - $EXPORT_TAGS{all} = [@EXPORT_OK]; -} - -#use Debbugs::Config qw(:globals); - -use Carp; -$Carp::Verbose = 1; - -use Debbugs::Config qw(:config); -use IO::File; -use IO::Scalar; -use Debbugs::MIME qw(decode_rfc1522); -use Mail::Address; -use Cwd qw(cwd); -use Storable qw(dclone); -use Time::HiRes qw(usleep); -use File::Path qw(mkpath); -use File::Basename qw(dirname); -use MLDBM qw(DB_File Storable); -$MLDBM::DumpMeth='portable'; -use List::AllUtils qw(natatime); - -use Params::Validate qw(validate_with :types); - -use Fcntl qw(:DEFAULT :flock); -use Encode qw(is_utf8 decode_utf8); - -our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH; - -=head1 UTILITIES - -The following functions are exported by the C<:util> tag - -=head2 getbugcomponent - - my $file = getbugcomponent($bug_number,$extension,$location) - -Returns the path to the bug file in location C<$location>, bug number -C<$bugnumber> and extension C<$extension> - -=cut - -sub getbugcomponent { - my ($bugnum, $ext, $location) = @_; - - if (not defined $location) { - $location = getbuglocation($bugnum, $ext); - # Default to non-archived bugs only for now; CGI scripts want - # archived bugs but most of the backend scripts don't. For now, - # anything that is prepared to accept archived bugs should call - # getbuglocation() directly first. - return undef if defined $location and - ($location ne 'db' and $location ne 'db-h'); - } - my $dir = getlocationpath($location); - return undef if not defined $dir; - if (defined $location and $location eq 'db') { - return "$dir/$bugnum.$ext"; - } else { - my $hash = get_hashname($bugnum); - return "$dir/$hash/$bugnum.$ext"; - } -} - -=head2 getbuglocation - - getbuglocation($bug_number,$extension) - -Returns the the location in which a particular bug exists; valid -locations returned currently are archive, db-h, or db. If the bug does -not exist, returns undef. - -=cut - -sub getbuglocation { - my ($bugnum, $ext) = @_; - my $archdir = get_hashname($bugnum); - return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext"; - return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext"; - return 'db' if -r getlocationpath('db')."/$bugnum.$ext"; - return undef; -} - - -=head2 getlocationpath - - getlocationpath($location) - -Returns the path to a specific location - -=cut - -sub getlocationpath { - my ($location) = @_; - if (defined $location and $location eq 'archive') { - return "$config{spool_dir}/archive"; - } elsif (defined $location and $location eq 'db') { - return "$config{spool_dir}/db"; - } else { - return "$config{spool_dir}/db-h"; - } -} - - -=head2 get_hashname - - get_hashname - -Returns the hash of the bug which is the location within the archive - -=cut - -sub get_hashname { - return "" if ( $_[ 0 ] < 0 ); - return sprintf "%02d", $_[ 0 ] % 100; -} - -=head2 buglog - - buglog($bugnum); - -Returns the path to the logfile corresponding to the bug. - -Returns undef if the bug does not exist. - -=cut - -sub buglog { - my $bugnum = shift; - my $location = getbuglocation($bugnum, 'log'); - return getbugcomponent($bugnum, 'log', $location) if ($location); - $location = getbuglocation($bugnum, 'log.gz'); - return getbugcomponent($bugnum, 'log.gz', $location) if ($location); - return undef; -} - -=head2 bug_status - - bug_status($bugnum) - - -Returns the path to the summary file corresponding to the bug. - -Returns undef if the bug does not exist. - -=cut - -sub bug_status{ - my ($bugnum) = @_; - my $location = getbuglocation($bugnum, 'summary'); - return getbugcomponent($bugnum, 'summary', $location) if ($location); - return undef; -} - -=head2 appendfile - - appendfile($file,'data','to','append'); - -Opens a file for appending and writes data to it. - -=cut - -sub appendfile { - my ($file,@data) = @_; - my $fh = IO::File->new($file,'a') or - die "Unable top open $file for appending: $!"; - print {$fh} @data or die "Unable to write to $file: $!"; - close $fh or die "Unable to close $file: $!"; -} - -=head2 overwritefile - - ovewritefile($file,'data','to','append'); - -Opens file.new, writes data to it, then moves file.new to file. - -=cut - -sub overwritefile { - my ($file,@data) = @_; - my $fh = IO::File->new("${file}.new",'w') or - die "Unable top open ${file}.new for writing: $!"; - print {$fh} @data or die "Unable to write to ${file}.new: $!"; - close $fh or die "Unable to close ${file}.new: $!"; - rename("${file}.new",$file) or - die "Unable to rename ${file}.new to $file: $!"; -} - -=head2 open_compressed_file - - my $fh = open_compressed_file('foo.gz') or - die "Unable to open compressed file: $!"; - - -Opens a file; if the file ends in .gz, .xz, or .bz2, the appropriate -decompression program is forked and output from it is read. - -This routine by default opens the file with UTF-8 encoding; if you want some -other encoding, specify it with the second option. - -=cut -sub open_compressed_file { - my ($file,$encoding) = @_; - $encoding //= ':encoding(UTF-8)'; - my $fh; - my $mode = "<$encoding"; - my @opts; - if ($file =~ /\.gz$/) { - $mode = "-|$encoding"; - push @opts,'gzip','-dc'; - } - if ($file =~ /\.xz$/) { - $mode = "-|$encoding"; - push @opts,'xz','-dc'; - } - if ($file =~ /\.bz2$/) { - $mode = "-|$encoding"; - push @opts,'bzip2','-dc'; - } - open($fh,$mode,@opts,$file); - return $fh; -} - -=head2 walk_bugs - -Walk through directories of bugs, calling a subroutine with a list of bugs -found. - -C sub {print map {qq($_\n)} @_},dirs => [qw(db-h)];> - -=over - -=item callback -- CODEREF of a subroutine to call with a list of bugs - -=item dirs -- ARRAYREF of directories to get bugs from. Like C<[qw(db-h archive)]>. - -=item bugs -- ARRAYREF of bugs to walk through. If both C and C are -provided, both are walked through. - -=item bugs_per_call -- maximum number of bugs to provide to callback - -=item progress_bar -- optional L - -=item bug_file -- bug file to look for (generally C) - -=item logging -- optional filehandle to output logging information - -=back - -=cut - -sub walk_bugs { - state $spec = - {dirs => {type => ARRAYREF, - default => [], - }, - bugs => {type => ARRAYREF, - default => [], - }, - progress_bar => {type => OBJECT|UNDEF, - optional => 1, - }, - bug_file => {type => SCALAR, - default => 'summary', - }, - logging => {type => HANDLE, - optional => 1, - }, - callback => {type => CODEREF, - }, - bugs_per_call => {type => SCALAR, - default => 1, - }, - }; - my %param = validate_with(params => \@_, - spec => $spec - ); - my @dirs = @{$param{dirs}}; - my @initial_bugs = (); - if (@{$param{bugs}}) { - unshift @dirs,''; - @initial_bugs = @{$param{bugs}}; - } - my $tot_dirs = @dirs; - my $done_dirs = 0; - my $avg_subfiles = 0; - my $completed_files = 0; - my $dir; - while ($dir = shift @dirs or defined $dir) { - my @list; - my @subdirs; - if (not length $dir and @initial_bugs) { - push @list,@initial_bugs; - @initial_bugs = (); - } else { - printf {$param{verbose}} "Doing dir %s ...\n", $dir - if defined $param{verbose}; - opendir(my $DIR, "$dir/.") or - die "opendir $dir: $!"; - @subdirs = readdir($DIR) or - die "Unable to readdir $dir: $!"; - closedir($DIR) or - die "Unable to closedir $dir: $!"; - - @list = map { m/^(\d+)\.$param{bug_file}$/?($1):() } @subdirs; - } - $tot_dirs -= @dirs; - push @dirs, map { m/^(\d+)$/ && -d "$dir/$1"?("$dir/$1"):() } @subdirs; - $tot_dirs += @dirs; - if ($param{progress_bar}) { - if ($avg_subfiles == 0) { - $avg_subfiles = @list; - } - $param{progress_bar}-> - target($avg_subfiles*($tot_dirs-$done_dirs)+$completed_files+@list); - $avg_subfiles = ($avg_subfiles * $done_dirs + @list) / ($done_dirs+1); - $done_dirs += 1; - } - - my $it = natatime $param{bugs_per_call},@list; - while (my @bugs = $it->()) { - $param{callback}->(@bugs); - $completed_files += scalar @bugs; - if ($param{progress_bar}) { - $param{progress_bar}->update($completed_files) if $param{progress_bar}; - } - if ($completed_files % 100 == 0 and - defined $param{verbose}) { - print {$param{verbose}} "Up to $completed_files bugs...\n" - } - } - } - $param{progress_bar}->remove() if $param{progress_bar}; -} - - -=head2 getparsedaddrs - - my $address = getparsedaddrs($address); - my @address = getparsedaddrs($address); - -Returns the output from Mail::Address->parse, or the cached output if -this address has been parsed before. In SCALAR context returns the -first address parsed. - -=cut - - -our %_parsedaddrs; -sub getparsedaddrs { - my $addr = shift; - return () unless defined $addr; - return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0] - if exists $_parsedaddrs{$addr}; - { - # don't display the warnings from Mail::Address->parse - local $SIG{__WARN__} = sub { }; - @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr); - } - return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0]; -} - -=head2 getmaintainers - - my $maintainer = getmaintainers()->{debbugs} - -Returns a hashref of package => maintainer pairs. - -=cut - -our $_maintainer = undef; -our $_maintainer_rev = undef; -sub getmaintainers { - return $_maintainer if defined $_maintainer; - package_maintainer(rehash => 1); - return $_maintainer; -} - -=head2 getmaintainers_reverse - - my @packages = @{getmaintainers_reverse->{'don@debian.org'}||[]}; - -Returns a hashref of maintainer => [qw(list of packages)] pairs. - -=cut - -sub getmaintainers_reverse{ - return $_maintainer_rev if defined $_maintainer_rev; - package_maintainer(rehash => 1); - return $_maintainer_rev; -} - -=head2 getsourcemaintainers - - my $maintainer = getsourcemaintainers()->{debbugs} - -Returns a hashref of src_package => maintainer pairs. - -=cut - -our $_source_maintainer = undef; -our $_source_maintainer_rev = undef; -sub getsourcemaintainers { - return $_source_maintainer if defined $_source_maintainer; - package_maintainer(rehash => 1); - return $_source_maintainer; -} - -=head2 getsourcemaintainers_reverse - - my @src_packages = @{getsourcemaintainers_reverse->{'don@debian.org'}||[]}; - -Returns a hashref of maintainer => [qw(list of source packages)] pairs. - -=cut - -sub getsourcemaintainers_reverse{ - return $_source_maintainer_rev if defined $_source_maintainer_rev; - package_maintainer(rehash => 1); - return $_source_maintainer_rev; -} - -=head2 package_maintainer - - my @s = package_maintainer(source => [qw(foo bar baz)], - binary => [qw(bleh blah)], - ); - -=over - -=item source -- scalar or arrayref of source package names to return -maintainers for, defaults to the empty arrayref. - -=item binary -- scalar or arrayref of binary package names to return -maintainers for; automatically returns source package maintainer if -the package name starts with 'src:', defaults to the empty arrayref. - -=item maintainer -- scalar or arrayref of maintainers to return source packages -for. If given, binary and source cannot be given. - -=item rehash -- whether to reread the maintainer and source maintainer -files; defaults to 0 - -=item schema -- Debbugs::DB schema. If set, uses the database for maintainer -information. - -=back - -=cut - -sub package_maintainer { - my %param = validate_with(params => \@_, - spec => {source => {type => SCALAR|ARRAYREF, - default => [], - }, - binary => {type => SCALAR|ARRAYREF, - default => [], - }, - maintainer => {type => SCALAR|ARRAYREF, - default => [], - }, - rehash => {type => BOOLEAN, - default => 0, - }, - reverse => {type => BOOLEAN, - default => 0, - }, - schema => {type => OBJECT, - optional => 1, - } - }, - ); - my @binary = make_list($param{binary}); - my @source = make_list($param{source}); - my @maintainers = make_list($param{maintainer}); - if ((@binary or @source) and @maintainers) { - croak "It is nonsensical to pass both maintainers and source or binary"; - } - if (@binary) { - @source = grep {/^src:/} @binary; - @binary = grep {!/^src:/} @binary; - } - # remove leading src: from source package names - s/^src:// foreach @source; - if ($param{schema}) { - my $s = $param{schema}; - if (@maintainers) { - my $m_rs = $s->resultset('SrcPkg')-> - search({'correspondent.addr' => [@maintainers]}, - {join => {src_vers => - {maintainer => - 'correspondent'}, - }, - columns => ['pkg'], - group_by => [qw(me.pkg)], - }); - return $m_rs->get_column('pkg')->all(); - } elsif (@binary or @source) { - my $rs = $s->resultset('Maintainer'); - if (@binary) { - $rs = - $rs->search({'bin_pkg.pkg' => [@binary]}, - {join => {src_vers => - {bin_vers => 'bin_pkg'}, - }, - columns => ['name'], - group_by => [qw(me.name)], - } - ); - } - if (@source) { - $rs = - $rs->search({'src_pkg.pkg' => [@source]}, - {join => {src_vers => - 'src_pkg', - }, - columns => ['name'], - group_by => [qw(me.name)], - } - ); - } - return $rs->get_column('name')->all(); - } - return (); - } - if ($param{rehash}) { - $_source_maintainer = undef; - $_source_maintainer_rev = undef; - $_maintainer = undef; - $_maintainer_rev = undef; - } - if (not defined $_source_maintainer or - not defined $_source_maintainer_rev) { - $_source_maintainer = {}; - $_source_maintainer_rev = {}; - if (-e $config{spool_dir}.'/source_maintainers.idx' and - -e $config{spool_dir}.'/source_maintainers_reverse.idx' - ) { - tie %{$_source_maintainer}, - MLDBM => $config{spool_dir}.'/source_maintainers.idx', - O_RDONLY or - die "Unable to tie source maintainers: $!"; - tie %{$_source_maintainer_rev}, - MLDBM => $config{spool_dir}.'/source_maintainers_reverse.idx', - O_RDONLY or - die "Unable to tie source maintainers reverse: $!"; - } else { - for my $fn (@config{('source_maintainer_file', - 'source_maintainer_file_override', - 'pseudo_maint_file')}) { - next unless defined $fn and length $fn; - if (not -e $fn) { - warn "Missing source maintainer file '$fn'"; - next; - } - __add_to_hash($fn,$_source_maintainer, - $_source_maintainer_rev); - } - } - } - if (not defined $_maintainer or - not defined $_maintainer_rev) { - $_maintainer = {}; - $_maintainer_rev = {}; - if (-e $config{spool_dir}.'/maintainers.idx' and - -e $config{spool_dir}.'/maintainers_reverse.idx' - ) { - tie %{$_maintainer}, - MLDBM => $config{spool_dir}.'/binary_maintainers.idx', - O_RDONLY or - die "Unable to tie binary maintainers: $!"; - tie %{$_maintainer_rev}, - MLDBM => $config{spool_dir}.'/binary_maintainers_reverse.idx', - O_RDONLY or - die "Unable to binary maintainers reverse: $!"; - } else { - for my $fn (@config{('maintainer_file', - 'maintainer_file_override', - 'pseudo_maint_file')}) { - next unless defined $fn and length $fn; - if (not -e $fn) { - warn "Missing maintainer file '$fn'"; - next; - } - __add_to_hash($fn,$_maintainer, - $_maintainer_rev); - } - } - } - my @return; - for my $binary (@binary) { - if ($binary =~ /^src:/) { - push @source,$binary; - next; - } - push @return,grep {defined $_} make_list($_maintainer->{$binary}); - } - for my $source (@source) { - $source =~ s/^src://; - push @return,grep {defined $_} make_list($_source_maintainer->{$source}); - } - for my $maintainer (grep {defined $_} @maintainers) { - push @return,grep {defined $_} - make_list($_maintainer_rev->{$maintainer}); - push @return,map {$_ !~ /^src:/?'src:'.$_:$_} - grep {defined $_} - make_list($_source_maintainer_rev->{$maintainer}); - } - return @return; -} - -#=head2 __add_to_hash -# -# __add_to_hash($file,$forward_hash,$reverse_hash,'address'); -# -# Reads a maintainer/source maintainer/pseudo desc file and adds the -# maintainers from it to the forward and reverse hashref; assumes that -# the forward is unique; makes no assumptions of the reverse. -# -#=cut - -sub __add_to_hash { - my ($fn,$forward,$reverse,$type) = @_; - if (ref($forward) ne 'HASH') { - croak "__add_to_hash must be passed a hashref for the forward"; - } - if (defined $reverse and not ref($reverse) eq 'HASH') { - croak "if reverse is passed to __add_to_hash, it must be a hashref"; - } - $type //= 'address'; - my $fh = IO::File->new($fn,'r') or - croak "Unable to open $fn for reading: $!"; - binmode($fh,':encoding(UTF-8)'); - while (<$fh>) { - chomp; - next unless m/^(\S+)\s+(\S.*\S)\s*$/; - my ($key,$value)=($1,$2); - $key = lc $key; - $forward->{$key}= $value; - if (defined $reverse) { - if ($type eq 'address') { - for my $m (map {lc($_->address)} (getparsedaddrs($value))) { - push @{$reverse->{$m}},$key; - } - } - else { - push @{$reverse->{$value}}, $key; - } - } - } -} - - -=head2 getpseudodesc - - my $pseudopkgdesc = getpseudodesc(...); - -Returns the entry for a pseudo package from the -$config{pseudo_desc_file}. In cases where pseudo_desc_file is not -defined, returns an empty arrayref. - -This function can be used to see if a particular package is a -pseudopackage or not. - -=cut - -our $_pseudodesc = undef; -sub getpseudodesc { - return $_pseudodesc if defined $_pseudodesc; - $_pseudodesc = {}; - __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if - defined $config{pseudo_desc_file} and - length $config{pseudo_desc_file}; - return $_pseudodesc; -} - -=head2 sort_versions - - sort_versions('1.0-2','1.1-2'); - -Sorts versions using AptPkg::Versions::compare if it is available, or -Debbugs::Versions::Dpkg::vercmp if it isn't. - -=cut - -our $vercmp; -BEGIN{ - use Debbugs::Versions::Dpkg; - $vercmp=\&Debbugs::Versions::Dpkg::vercmp; - -# eventually we'll use AptPkg:::Version or similar, but the current -# implementation makes this *super* difficult. - -# eval { -# use AptPkg::Version; -# $vercmp=\&AptPkg::Version::compare; -# }; -} - -sub sort_versions{ - return sort {$vercmp->($a,$b)} @_; -} - - -=head1 DATE - - my $english = secs_to_english($seconds); - my ($days,$english) = secs_to_english($seconds); - -XXX This should probably be changed to use Date::Calc - -=cut - -sub secs_to_english{ - my ($seconds) = @_; - - my $days = int($seconds / 86400); - my $years = int($days / 365); - $days %= 365; - my $result; - my @age; - push @age, "1 year" if ($years == 1); - push @age, "$years years" if ($years > 1); - push @age, "1 day" if ($days == 1); - push @age, "$days days" if ($days > 1); - $result .= join(" and ", @age); - - return wantarray?(int($seconds/86400),$result):$result; -} - - -=head1 LOCK - -These functions are exported with the :lock tag - -=head2 filelock - - filelock($lockfile); - filelock($lockfile,$locks); - -FLOCKs the passed file. Use unfilelock to unlock it. - -Can be passed an optional $locks hashref, which is used to track which -files are locked (and how many times they have been locked) to allow -for cooperative locking. - -=cut - -our @filelocks; - -use Carp qw(cluck); - -sub filelock { - # NB - NOT COMPATIBLE WITH `with-lock' - my ($lockfile,$locks) = @_; - if ($lockfile !~ m{^/}) { - $lockfile = cwd().'/'.$lockfile; - } - # This is only here to allow for relocking bugs inside of - # Debbugs::Control. Nothing else should be using it. - if (defined $locks and exists $locks->{locks}{$lockfile} and - $locks->{locks}{$lockfile} >= 1) { - if (exists $locks->{relockable} and - exists $locks->{relockable}{$lockfile}) { - $locks->{locks}{$lockfile}++; - # indicate that the bug for this lockfile needs to be reread - $locks->{relockable}{$lockfile} = 1; - push @{$locks->{lockorder}},$lockfile; - return; - } - else { - use Data::Dumper; - confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]); - } - } - my ($fh,$t_lockfile,$errors) = - simple_filelock($lockfile,10,1); - if ($fh) { - push @filelocks, {fh => $fh, file => $lockfile}; - if (defined $locks) { - $locks->{locks}{$lockfile}++; - push @{$locks->{lockorder}},$lockfile; - } - } else { - use Data::Dumper; - croak "failed to get lock on $lockfile -- $errors". - (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):''); - } -} - -=head2 simple_filelock - - my ($fh,$t_lockfile,$errors) = - simple_filelock($lockfile,$count,$wait); - -Does a flock of lockfile. If C<$count> is zero, does a blocking lock. -Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait> -seconds in between. - -In list context, returns the lockfile filehandle, lockfile name, and -any errors which occured. - -When the lockfile filehandle is undef, locking failed. - -These lockfiles must be unlocked manually at process end. - - -=cut - -sub simple_filelock { - my ($lockfile,$count,$wait) = @_; - if (not defined $count) { - $count = 10; - } - if ($count < 0) { - $count = 0; - } - if (not defined $wait) { - $wait = 1; - } - my $errors= ''; - my $fh; - while (1) { - $fh = eval { - my $fh2 = IO::File->new($lockfile,'w') - or die "Unable to open $lockfile for writing: $!"; - # Do a blocking lock if count is zero - flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB)) - or die "Unable to lock $lockfile $!"; - return $fh2; - }; - if ($@) { - $errors .= $@; - } - if ($fh) { - last; - } - # use usleep for fractional wait seconds - usleep($wait * 1_000_000); - } continue { - last unless (--$count > 0); - } - if ($fh) { - return wantarray?($fh,$lockfile,$errors):$fh - } - return wantarray?(undef,$lockfile,$errors):undef; -} - -# clean up all outstanding locks at end time -END { - while (@filelocks) { - unfilelock(); - } -} - -=head2 simple_unlockfile - - simple_unlockfile($fh,$lockfile); - - -=cut - -sub simple_unlockfile { - my ($fh,$lockfile) = @_; - flock($fh,LOCK_UN) - or warn "Unable to unlock lockfile $lockfile: $!"; - close($fh) - or warn "Unable to close lockfile $lockfile: $!"; - unlink($lockfile) - or warn "Unable to unlink lockfile $lockfile: $!"; -} - - -=head2 unfilelock - - unfilelock() - unfilelock($locks); - -Unlocks the file most recently locked. - -Note that it is not currently possible to unlock a specific file -locked with filelock. - -=cut - -sub unfilelock { - my ($locks) = @_; - if (@filelocks == 0) { - carp "unfilelock called with no active filelocks!\n"; - return; - } - if (defined $locks and ref($locks) ne 'HASH') { - croak "hash not passsed to unfilelock"; - } - if (defined $locks and exists $locks->{lockorder} and - @{$locks->{lockorder}} and - exists $locks->{locks}{$locks->{lockorder}[-1]}) { - my $lockfile = pop @{$locks->{lockorder}}; - $locks->{locks}{$lockfile}--; - if ($locks->{locks}{$lockfile} > 0) { - return - } - delete $locks->{locks}{$lockfile}; - } - my %fl = %{pop(@filelocks)}; - simple_unlockfile($fl{fh},$fl{file}); -} - - -=head2 lockpid - - lockpid('/path/to/pidfile'); - -Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the -pid in the file does not respond to kill 0. - -Returns 1 on success, false on failure; dies on unusual errors. - -=cut - -sub lockpid { - my ($pidfile) = @_; - if (-e $pidfile) { - my $pid = checkpid($pidfile); - die "Unable to read pidfile $pidfile: $!" if not defined $pid; - return 0 if $pid != 0; - unlink $pidfile or - die "Unable to unlink stale pidfile $pidfile $!"; - } - mkpath(dirname($pidfile)); - my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or - die "Unable to open $pidfile for writing: $!"; - print {$pidfh} $$ or die "Unable to write to $pidfile $!"; - close $pidfh or die "Unable to close $pidfile $!"; - return 1; -} - -=head2 checkpid - - checkpid('/path/to/pidfile'); - -Checks a pid file and determines if the process listed in the pidfile -is still running. Returns the pid if it is, 0 if it isn't running, and -undef if the pidfile doesn't exist or cannot be read. - -=cut - -sub checkpid{ - my ($pidfile) = @_; - if (-e $pidfile) { - my $pidfh = IO::File->new($pidfile, 'r') or - return undef; - local $/; - my $pid = <$pidfh>; - close $pidfh; - ($pid) = $pid =~ /(\d+)/; - if (defined $pid and kill(0,$pid)) { - return $pid; - } - return 0; - } - else { - return undef; - } -} - - -=head1 QUIT - -These functions are exported with the :quit tag. - -=head2 quit - - quit() - -Exits the program by calling die. - -Usage of quit is deprecated; just call die instead. - -=cut - -sub quit { - print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG; - carp "quit() is deprecated; call die directly instead"; -} - - -=head1 MISC - -These functions are exported with the :misc tag - -=head2 make_list - - LIST = make_list(@_); - -Turns a scalar or an arrayref into a list; expands a list of arrayrefs -into a list. - -That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a -b)],[qw(c d)] returns qw(a b c d); - -=cut - -sub make_list { - return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_; -} - - -=head2 english_join - - print english_join(list => \@list); - print english_join(\@list); - -Joins list properly to make an english phrase. - -=over - -=item normal -- how to separate most values; defaults to ', ' - -=item last -- how to separate the last two values; defaults to ', and ' - -=item only_two -- how to separate only two values; defaults to ' and ' - -=item list -- ARRAYREF values to join; if the first argument is an -ARRAYREF, it's assumed to be the list of values to join - -=back - -In cases where C is empty, returns ''; when there is only one -element, returns that element. - -=cut - -sub english_join { - if (ref $_[0] eq 'ARRAY') { - return english_join(list=>$_[0]); - } - my %param = validate_with(params => \@_, - spec => {normal => {type => SCALAR, - default => ', ', - }, - last => {type => SCALAR, - default => ', and ', - }, - only_two => {type => SCALAR, - default => ' and ', - }, - list => {type => ARRAYREF, - }, - }, - ); - my @list = @{$param{list}}; - if (@list <= 1) { - return @list?$list[0]:''; - } - elsif (@list == 2) { - return join($param{only_two},@list); - } - my $ret = $param{last} . pop(@list); - return join($param{normal},@list) . $ret; -} - - -=head2 globify_scalar - - my $handle = globify_scalar(\$foo); - -if $foo isn't already a glob or a globref, turn it into one using -IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined. - -Will carp if given a scalar which isn't a scalarref or a glob (or -globref), and return /dev/null. May return undef if IO::Scalar or -IO::File fails. (Check $!) - -The scalar will fill with octets, not perl's internal encoding, so you -must use decode_utf8() after on the scalar, and encode_utf8() on it -before. This appears to be a bug in the underlying modules. - -=cut - -our $_NULL_HANDLE; - -sub globify_scalar { - my ($scalar) = @_; - my $handle; - if (defined $scalar) { - if (defined ref($scalar)) { - if (ref($scalar) eq 'SCALAR' and - not UNIVERSAL::isa($scalar,'GLOB')) { - if (is_utf8(${$scalar})) { - ${$scalar} = decode_utf8(${$scalar}); - carp(q(\$scalar must not be in perl's internal encoding)); - } - open $handle, '>:scalar:utf8', $scalar; - return $handle; - } - else { - return $scalar; - } - } - elsif (UNIVERSAL::isa(\$scalar,'GLOB')) { - return $scalar; - } - else { - carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle"; - } - } - if (not defined $_NULL_HANDLE or - not $_NULL_HANDLE->opened() - ) { - $_NULL_HANDLE = - IO::File->new('/dev/null','>:encoding(UTF-8)') or - die "Unable to open /dev/null for writing: $!"; - } - return $_NULL_HANDLE; -} - -=head2 cleanup_eval_fail() - - print "Something failed with: ".cleanup_eval_fail($@); - -Does various bits of cleanup on the failure message from an eval (or -any other die message) - -Takes at most two options; the first is the actual failure message -(usually $@ and defaults to $@), the second is the debug level -(defaults to $DEBUG). - -If debug is non-zero, the code at which the failure occured is output. - -=cut - -sub cleanup_eval_fail { - my ($error,$debug) = @_; - if (not defined $error or not @_) { - $error = $@ // 'unknown reason'; - } - if (@_ <= 1) { - $debug = $DEBUG // 0; - } - $debug = 0 if not defined $debug; - - if ($debug > 0) { - return $error; - } - # ditch the "at foo/bar/baz.pm line 5" - $error =~ s/\sat\s\S+\sline\s\d+//; - # ditch croak messages - $error =~ s/^\t+.+\n?//mg; - # ditch trailing multiple periods in case there was a cascade of - # die messages. - $error =~ s/\.+$/\./; - return $error; -} - -=head2 hash_slice - - hash_slice(%hash,qw(key1 key2 key3)) - -For each key, returns matching values and keys of the hash if they exist - -=cut - - -# NB: We use prototypes here SPECIFICALLY so that we can be passed a -# hash without uselessly making a reference to first. DO NOT USE -# PROTOTYPES USELESSLY ELSEWHERE. -sub hash_slice(\%@) { - my ($hashref,@keys) = @_; - return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys; -} - - -1; - -__END__ diff --git a/Debbugs/Config.pm b/Debbugs/Config.pm deleted file mode 100644 index 0d0abae..0000000 --- a/Debbugs/Config.pm +++ /dev/null @@ -1,1278 +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 2007 by Don Armstrong . - -package Debbugs::Config; - -=head1 NAME - -Debbugs::Config -- Configuration information for debbugs - -=head1 SYNOPSIS - - use Debbugs::Config; - -# to get the compatiblity interface - - use Debbugs::Config qw(:globals); - -=head1 DESCRIPTION - -This module provides configuration variables for all of debbugs. - -=head1 CONFIGURATION FILES - -The default configuration file location is /etc/debbugs/config; this -configuration file location can be set by modifying the -DEBBUGS_CONFIG_FILE env variable to point at a different location. - -=cut - -use warnings; -use strict; -use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT $USING_GLOBALS %config); -use base qw(Exporter); - -BEGIN { - # set the version for version checking - $VERSION = 1.00; - $DEBUG = 0 unless defined $DEBUG; - $USING_GLOBALS = 0; - - @EXPORT = (); - %EXPORT_TAGS = (globals => [qw($gEmailDomain $gListDomain $gWebHost $gWebHostBugDir), - qw($gWebDomain $gHTMLSuffix $gCGIDomain $gMirrors), - qw($gPackagePages $gSubscriptionDomain $gProject $gProjectTitle), - qw($gMaintainer $gMaintainerWebpage $gMaintainerEmail $gUnknownMaintainerEmail), - qw($gPackageTrackingDomain $gUsertagPackageDomain), - qw($gSubmitList $gMaintList $gQuietList $gForwardList), - qw($gDoneList $gRequestList $gSubmitterList $gControlList), - qw($gStrongList), - qw($gBugSubscriptionDomain), - qw($gPackageVersionRe), - qw($gSummaryList $gMirrorList $gMailer $gBug), - qw($gBugs $gRemoveAge $gSaveOldBugs $gDefaultSeverity), - qw($gShowSeverities $gBounceFroms $gConfigDir $gSpoolDir), - qw($gIncomingDir $gWebDir $gDocDir $gMaintainerFile), - qw($gMaintainerFileOverride $gPseudoMaintFile $gPseudoDescFile $gPackageSource), - qw($gVersionPackagesDir $gVersionIndex $gBinarySourceMap $gSourceBinaryMap), - qw($gVersionTimeIndex), - qw($gSimpleVersioning), - qw($gCVETracker), - qw($gSendmail @gSendmailArguments $gLibPath $gSpamScan @gExcludeFromControl), - qw(%gSeverityDisplay @gTags @gSeverityList @gStrongSeverities), - qw(%gTagsSingleLetter), - qw(%gSearchEstraier), - qw(%gDistributionAliases), - qw(%gObsoleteSeverities), - qw(@gPostProcessall @gRemovalDefaultDistributionTags @gRemovalDistributionTags @gRemovalArchitectures), - qw(@gRemovalStrongSeverityDefaultDistributionTags), - qw(@gAffectsDistributionTags), - qw(@gDefaultArchitectures), - qw($gMachineName), - qw($gTemplateDir), - qw($gDefaultPackage), - qw($gSpamMaxThreads $gSpamSpamsPerThread $gSpamKeepRunning $gSpamScan $gSpamCrossassassinDb), - qw($gDatabase), - ], - text => [qw($gBadEmailPrefix $gHTMLTail $gHTMLExpireNote), - ], - cgi => [qw($gLibravatarUri $gLibravatarCacheDir $gLibravatarUriOptions @gLibravatarBlacklist)], - config => [qw(%config)], - ); - @EXPORT_OK = (); - Exporter::export_ok_tags(keys %EXPORT_TAGS); - $EXPORT_TAGS{all} = [@EXPORT_OK]; - $ENV{HOME} = '' if not defined $ENV{HOME}; -} - -use Sys::Hostname; -use File::Basename qw(dirname); -use IO::File; -use Safe; - -=head1 CONFIGURATION VARIABLES - -=head2 General Configuration - -=over - -=cut - -# read in the files; -%config = (); -# untaint $ENV{DEBBUGS_CONFIG_FILE} if it's owned by us -# This enables us to test things that are -T. -if (exists $ENV{DEBBUGS_CONFIG_FILE}) { -# This causes all sorts of problems for mirrors of debbugs; disable -# it. -# if (${[stat($ENV{DEBBUGS_CONFIG_FILE})]}[4] == $<) { - $ENV{DEBBUGS_CONFIG_FILE} =~ /(.+)/; - $ENV{DEBBUGS_CONFIG_FILE} = $1; -# } -# else { -# die "Environmental variable DEBBUGS_CONFIG_FILE set, and $ENV{DEBBUGS_CONFIG_FILE} is not owned by the user running this script."; -# } -} -read_config(exists $ENV{DEBBUGS_CONFIG_FILE}?$ENV{DEBBUGS_CONFIG_FILE}:'/etc/debbugs/config'); - -=item email_domain $gEmailDomain - -The email domain of the bts - -=cut - -set_default(\%config,'email_domain','bugs.something'); - -=item list_domain $gListDomain - -The list domain of the bts, defaults to the email domain - -=cut - -set_default(\%config,'list_domain',$config{email_domain}); - -=item web_host $gWebHost - -The web host of the bts; defaults to the email domain - -=cut - -set_default(\%config,'web_host',$config{email_domain}); - -=item web_host_bug_dir $gWebHostDir - -The directory of the web host on which bugs are kept, defaults to C<''> - -=cut - -set_default(\%config,'web_host_bug_dir',''); - -=item web_domain $gWebDomain - -Full path of the web domain where bugs are kept including the protocol (http:// -or https://). Defaults to the concatenation of 'http://', L and -L - -=cut - -set_default(\%config,'web_domain','http://'.$config{web_host}.($config{web_host}=~m{/$}?'':'/').$config{web_host_bug_dir}); - -=item html_suffix $gHTMLSuffix - -Suffix of html pages, defaults to .html - -=cut - -set_default(\%config,'html_suffix','.html'); - -=item cgi_domain $gCGIDomain - -Full path of the web domain where cgi scripts are kept. Defaults to -the concatentation of L and cgi. - -=cut - -set_default(\%config,'cgi_domain',$config{web_domain}.($config{web_domain}=~m{/$}?'':'/').'cgi'); - -=item mirrors @gMirrors - -List of mirrors [What these mirrors are used for, no one knows.] - -=cut - - -set_default(\%config,'mirrors',[]); - -=item package_pages $gPackagePages - -Domain where the package pages are kept; links should work in a -package_pages/foopackage manner. Defaults to undef, which means that package -links will not be made. Should be prefixed with the appropriate protocol -(http/https). - -=cut - - -set_default(\%config,'package_pages',undef); - -=item package_tracking_domain $gPackageTrackingDomain - -Domain where the package pages are kept; links should work in a -package_tracking_domain/foopackage manner. Defaults to undef, which means that -package links will not be made. Should be prefixed with the appropriate protocol -(http or https). - -=cut - -set_default(\%config,'package_tracking_domain',undef); - -=item package_pages $gUsertagPackageDomain - -Domain where where usertags of packages belong; defaults to $gPackagePages - -=cut - -set_default(\%config,'usertag_package_domain',map {my $a = $_; defined $a?$a =~ s{https?://}{}:(); $a} $config{package_pages}); - - -=item subscription_domain $gSubscriptionDomain - -Domain where subscriptions to package lists happen - -=cut - -set_default(\%config,'subscription_domain',undef); - - -=item cc_all_mails_to_addr $gCcAllMailsToAddr - -Address to Cc (well, Bcc) all e-mails to - -=cut - -set_default(\%config,'cc_all_mails_to_addr',undef); - - -=item cve_tracker $gCVETracker - -URI to CVE security tracker; in bugreport.cgi, CVE-2001-0002 becomes -linked to $config{cve_tracker}CVE-2001-002 - -Default: https://security-tracker.debian.org/tracker/ - -=cut - -set_default(\%config,'cve_tracker','https://security-tracker.debian.org/tracker/'); - - -=back - -=cut - - -=head2 Project Identification - -=over - -=item project $gProject - -Name of the project - -Default: 'Something' - -=cut - -set_default(\%config,'project','Something'); - -=item project_title $gProjectTitle - -Name of this install of Debbugs, defaults to "L Debbugs Install" - -Default: "$config{project} Debbugs Install" - -=cut - -set_default(\%config,'project_title',"$config{project} Debbugs Install"); - -=item maintainer $gMaintainer - -Name of the maintainer of this debbugs install - -Default: 'Local DebBugs Owner's - -=cut - -set_default(\%config,'maintainer','Local DebBugs Owner'); - -=item maintainer_webpage $gMaintainerWebpage - -Webpage of the maintainer of this install of debbugs - -Default: "$config{web_domain}/~owner" - -=cut - -set_default(\%config,'maintainer_webpage',"$config{web_domain}/~owner"); - -=item maintainer_email $gMaintainerEmail - -Email address of the maintainer of this Debbugs install - -Default: 'root@'.$config{email_domain} - -=cut - -set_default(\%config,'maintainer_email','root@'.$config{email_domain}); - -=item unknown_maintainer_email - -Email address where packages with an unknown maintainer will be sent - -Default: $config{maintainer_email} - -=cut - -set_default(\%config,'unknown_maintainer_email',$config{maintainer_email}); - -=item machine_name - -The name of the machine that this instance of debbugs is running on -(currently used for debbuging purposes and web page output.) - -Default: Sys::Hostname::hostname() - -=back - -=cut - -set_default(\%config,'machine_name',Sys::Hostname::hostname()); - -=head2 BTS Mailing Lists - - -=over - -=item submit_list - -=item maint_list - -=item forward_list - -=item done_list - -=item request_list - -=item submitter_list - -=item control_list - -=item summary_list - -=item mirror_list - -=item strong_list - -=cut - -set_default(\%config, 'submit_list', 'bug-submit-list'); -set_default(\%config, 'maint_list', 'bug-maint-list'); -set_default(\%config, 'quiet_list', 'bug-quiet-list'); -set_default(\%config, 'forward_list', 'bug-forward-list'); -set_default(\%config, 'done_list', 'bug-done-list'); -set_default(\%config, 'request_list', 'bug-request-list'); -set_default(\%config,'submitter_list','bug-submitter-list'); -set_default(\%config, 'control_list', 'bug-control-list'); -set_default(\%config, 'summary_list', 'bug-summary-list'); -set_default(\%config, 'mirror_list', 'bug-mirror-list'); -set_default(\%config, 'strong_list', 'bug-strong-list'); - -=item bug_subscription_domain - -Domain of list for messages regarding a single bug; prefixed with -bug=${bugnum}@ when bugs are actually sent out. Set to undef or '' to -disable sending messages to the bug subscription list. - -Default: list_domain - -=back - -=cut - -set_default(\%config,'bug_subscription_domain',$config{list_domain}); - - - -=head2 Misc Options - -=over - -=item mailer - -Name of the mailer to use - -Default: exim - -=cut - -set_default(\%config,'mailer','exim'); - - -=item bug - -Default: bug - -=item ubug - -Default: ucfirst($config{bug}); - -=item bugs - -Default: bugs - -=item ubugs - -Default: ucfirst($config{ubugs}); - -=cut - -set_default(\%config,'bug','bug'); -set_default(\%config,'ubug',ucfirst($config{bug})); -set_default(\%config,'bugs','bugs'); -set_default(\%config,'ubugs',ucfirst($config{bugs})); - -=item remove_age - -Age at which bugs are archived/removed - -Default: 28 - -=cut - -set_default(\%config,'remove_age',28); - -=item save_old_bugs - -Whether old bugs are saved or deleted - -Default: 1 - -=cut - -set_default(\%config,'save_old_bugs',1); - -=item distribution_aliases - -Map of distribution aliases to the distribution name - -Default: - {experimental => 'experimental', - unstable => 'unstable', - testing => 'testing', - stable => 'stable', - oldstable => 'oldstable', - sid => 'unstable', - lenny => 'testing', - etch => 'stable', - sarge => 'oldstable', - } - -=cut - -set_default(\%config,'distribution_aliases', - {experimental => 'experimental', - unstable => 'unstable', - testing => 'testing', - stable => 'stable', - oldstable => 'oldstable', - sid => 'unstable', - lenny => 'testing', - etch => 'stable', - sarge => 'oldstable', - }, - ); - - - -=item distributions - -List of valid distributions - -Default: The values of the distribution aliases map. - -=cut - -my %_distributions_default; -@_distributions_default{values %{$config{distribution_aliases}}} = values %{$config{distribution_aliases}}; -set_default(\%config,'distributions',[keys %_distributions_default]); - - -=item default_architectures - -List of default architectures to use when architecture(s) are not -specified - -Default: i386 amd64 arm ppc sparc alpha - -=cut - -set_default(\%config,'default_architectures', - [qw(i386 amd64 arm powerpc sparc alpha)] - ); - -=item affects_distribution_tags - -List of tags which restrict the buggy state to a set of distributions. - -The set of distributions that are buggy is the intersection of the set -of distributions that would be buggy without reference to these tags -and the set of these tags that are distributions which are set on a -bug. - -Setting this to [] will remove this feature. - -Default: @{$config{distributions}} - -=cut - -set_default(\%config,'affects_distribution_tags', - [@{$config{distributions}}], - ); - -=item removal_unremovable_tags - -Bugs which have these tags set cannot be archived - -Default: [] - -=cut - -set_default(\%config,'removal_unremovable_tags', - [], - ); - -=item removal_distribution_tags - -Tags which specifiy distributions to check - -Default: @{$config{distributions}} - -=cut - -set_default(\%config,'removal_distribution_tags', - [@{$config{distributions}}]); - -=item removal_default_distribution_tags - -For removal/archival purposes, all bugs are assumed to have these tags -set. - -Default: qw(experimental unstable testing); - -=cut - -set_default(\%config,'removal_default_distribution_tags', - [qw(experimental unstable testing)] - ); - -=item removal_strong_severity_default_distribution_tags - -For removal/archival purposes, all bugs with strong severity are -assumed to have these tags set. - -Default: qw(experimental unstable testing stable); - -=cut - -set_default(\%config,'removal_strong_severity_default_distribution_tags', - [qw(experimental unstable testing stable)] - ); - - -=item removal_architectures - -For removal/archival purposes, these architectures are consulted if -there is more than one architecture applicable. If the bug is in a -package not in any of these architectures, the architecture actually -checked is undefined. - -Default: value of default_architectures - -=cut - -set_default(\%config,'removal_architectures', - $config{default_architectures}, - ); - - -=item package_name_re - -The regex which will match a package name - -Default: '[a-z0-9][a-z0-9\.+-]+' - -=cut - -set_default(\%config,'package_name_re', - '[a-z0-9][a-z0-9\.+-]+'); - -=item package_version_re - -The regex which will match a package version - -Default: '[A-Za-z0-9:+\.-]+' - -=cut - - -set_default(\%config,'package_version_re', - '[A-Za-z0-9:+\.~-]+'); - - -=item default_package - -This is the name of the default package. If set, bugs assigned to -packages without a maintainer and bugs missing a Package: psuedoheader -will be assigned to this package instead. - -Defaults to unset, which is the traditional debbugs behavoir - -=cut - -set_default(\%config,'default_package', - undef - ); - - -=item control_internal_requester - -This address is used by Debbugs::Control as the request address which -sent a control request for faked log messages. - -Default:"Debbugs Internal Request <$config{maintainer_email}>" - -=cut - -set_default(\%config,'control_internal_requester', - "Debbugs Internal Request <$config{maintainer_email}>", - ); - -=item control_internal_request_addr - -This address is used by Debbugs::Control as the address to which a -faked log message request was sent. - -Default: "internal_control\@$config{email_domain}"; - -=cut - -set_default(\%config,'control_internal_request_addr', - 'internal_control@'.$config{email_domain}, - ); - - -=item exclude_from_control - -Addresses which are not allowed to send messages to control - -=cut - -set_default(\%config,'exclude_from_control',[]); - - - -=item default_severity - -The default severity of bugs which have no severity set - -Default: normal - -=cut - -set_default(\%config,'default_severity','normal'); - -=item severity_display - -A hashref of severities and the informative text which describes them. - -Default: - - {critical => "Critical $config{bugs}", - grave => "Grave $config{bugs}", - normal => "Normal $config{bugs}", - wishlist => "Wishlist $config{bugs}", - } - -=cut - -set_default(\%config,'severity_display',{critical => "Critical $config{bugs}", - grave => "Grave $config{bugs}", - serious => "Serious $config{bugs}", - important=> "Important $config{bugs}", - normal => "Normal $config{bugs}", - minor => "Minor $config{bugs}", - wishlist => "Wishlist $config{bugs}", - }); - -=item show_severities - -A scalar list of the severities to show - -Defaults to the concatenation of the keys of the severity_display -hashlist with ', ' above. - -=cut - -set_default(\%config,'show_severities',join(', ',keys %{$config{severity_display}})); - -=item strong_severities - -An arrayref of the serious severities which shoud be emphasized - -Default: [qw(critical grave)] - -=cut - -set_default(\%config,'strong_severities',[qw(critical grave)]); - -=item severity_list - -An arrayref of a list of the severities - -Defaults to the keys of the severity display hashref - -=cut - -set_default(\%config,'severity_list',[keys %{$config{severity_display}}]); - -=item obsolete_severities - -A hashref of obsolete severities with the replacing severity - -Default: {} - -=cut - -set_default(\%config,'obsolete_severities',{}); - -=item tags - -An arrayref of the tags used - -Default: [qw(patch wontfix moreinfo unreproducible fixed)] and also -includes the distributions. - -=cut - -set_default(\%config,'tags',[qw(patch wontfix moreinfo unreproducible fixed), - @{$config{distributions}} - ]); - -set_default(\%config,'tags_single_letter', - {patch => '+', - wontfix => '', - moreinfo => 'M', - unreproducible => 'R', - fixed => 'F', - } - ); - -set_default(\%config,'bounce_froms','^mailer|^da?emon|^post.*mast|^root|^wpuser|^mmdf|^smt.*|'. - '^mrgate|^vmmail|^mail.*system|^uucp|-maiser-|^mal\@|'. - '^mail.*agent|^tcpmail|^bitmail|^mailman'); - -set_default(\%config,'config_dir',dirname(exists $ENV{DEBBUGS_CONFIG_FILE}?$ENV{DEBBUGS_CONFIG_FILE}:'/etc/debbugs/config')); -set_default(\%config,'spool_dir','/var/lib/debbugs/spool'); - -=item usertag_dir - -Directory which contains the usertags - -Default: $config{spool_dir}/user - -=cut - -set_default(\%config,'usertag_dir',$config{spool_dir}.'/user'); -set_default(\%config,'incoming_dir','incoming'); - -=item web_dir $gWebDir - -Directory where base html files are kept. Should normally be the same -as the web server's document root. - -Default: /var/lib/debbugs/www - -=cut - -set_default(\%config,'web_dir','/var/lib/debbugs/www'); -set_default(\%config,'doc_dir','/var/lib/debbugs/www/txt'); -set_default(\%config,'lib_path','/usr/lib/debbugs'); - - -=item template_dir - -directory of templates; defaults to /usr/share/debbugs/templates. - -=cut - -set_default(\%config,'template_dir','/usr/share/debbugs/templates'); - - -set_default(\%config,'maintainer_file',$config{config_dir}.'/Maintainers'); -set_default(\%config,'maintainer_file_override',$config{config_dir}.'/Maintainers.override'); -set_default(\%config,'source_maintainer_file',$config{config_dir}.'/Source_maintainers'); -set_default(\%config,'source_maintainer_file_override',undef); -set_default(\%config,'pseudo_maint_file',$config{config_dir}.'/pseudo-packages.maintainers'); -set_default(\%config,'pseudo_desc_file',$config{config_dir}.'/pseudo-packages.description'); -set_default(\%config,'package_source',$config{config_dir}.'/indices/sources'); - - -=item simple_versioning - -If true this causes debbugs to ignore version information and just -look at whether a bug is done or not done. Primarily of interest for -debbugs installs which don't track versions. defaults to false. - -=cut - -set_default(\%config,'simple_versioning',0); - - -=item version_packages_dir - -Location where the version package information is kept; defaults to -spool_dir/../versions/pkg - -=cut - -set_default(\%config,'version_packages_dir',$config{spool_dir}.'/../versions/pkg'); - -=item version_time_index - -Location of the version/time index file. Defaults to -spool_dir/../versions/idx/versions_time.idx if spool_dir/../versions -exists; otherwise defaults to undef. - -=cut - - -set_default(\%config,'version_time_index', -d $config{spool_dir}.'/../versions' ? $config{spool_dir}.'/../versions/indices/versions_time.idx' : undef); - -=item version_index - -Location of the version index file. Defaults to -spool_dir/../versions/indices/versions.idx if spool_dir/../versions -exists; otherwise defaults to undef. - -=cut - -set_default(\%config,'version_index',-d $config{spool_dir}.'/../versions' ? $config{spool_dir}.'/../versions/indices/versions.idx' : undef); - -=item binary_source_map - -Location of the binary -> source map. Defaults to -spool_dir/../versions/indices/bin2src.idx if spool_dir/../versions -exists; otherwise defaults to undef. - -=cut - -set_default(\%config,'binary_source_map',-d $config{spool_dir}.'/../versions' ? $config{spool_dir}.'/../versions/indices/binsrc.idx' : undef); - -=item source_binary_map - -Location of the source -> binary map. Defaults to -spool_dir/../versions/indices/src2bin.idx if spool_dir/../versions -exists; otherwise defaults to undef. - -=cut - -set_default(\%config,'source_binary_map',-d $config{spool_dir}.'/../versions' ? $config{spool_dir}.'/../versions/indices/srcbin.idx' : undef); - - - -set_default(\%config,'post_processall',[]); - -=item sendmail - -Sets the sendmail binary to execute; defaults to /usr/lib/sendmail - -=cut - -set_default(\%config,'sendmail','/usr/lib/sendmail'); - -=item sendmail_arguments - -Default arguments to pass to sendmail. Defaults to C. - -=cut - -set_default(\%config,'sendmail_arguments',[qw(-oem -oi)]); - -=item envelope_from - -Envelope from to use for sent messages. If not set, whatever sendmail picks is -used. - -=cut - -set_default(\%config,'envelope_from',undef); - -=item spam_scan - -Whether or not spamscan is being used; defaults to 0 (not being used - -=cut - -set_default(\%config,'spam_scan',0); - -=item spam_crossassassin_db - -Location of the crosassassin database, defaults to -spool_dir/../CrossAssassinDb - -=cut - -set_default(\%config,'spam_crossassassin_db',$config{spool_dir}.'/../CrossAssassinDb'); - -=item spam_max_cross - -Maximum number of cross-posted messages - -=cut - -set_default(\%config,'spam_max_cross',6); - - -=item spam_spams_per_thread - -Number of spams for each thread (on average). Defaults to 200 - -=cut - -set_default(\%config,'spam_spams_per_thread',200); - -=item spam_max_threads - -Maximum number of threads to start. Defaults to 20 - -=cut - -set_default(\%config,'spam_max_threads',20); - -=item spam_keep_running - -Maximum number of seconds to run without restarting. Defaults to 3600. - -=cut - -set_default(\%config,'spam_keep_running',3600); - -=item spam_mailbox - -Location to store spam messages; is run through strftime to allow for -%d,%m,%Y, et al. Defaults to 'spool_dir/../mail/spam/assassinated.%Y-%m-%d' - -=cut - -set_default(\%config,'spam_mailbox',$config{spool_dir}.'/../mail/spam/assassinated.%Y-%m-%d'); - -=item spam_crossassassin_mailbox - -Location to store crossassassinated messages; is run through strftime -to allow for %d,%m,%Y, et al. Defaults to -'spool_dir/../mail/spam/crossassassinated.%Y-%m-%d' - -=cut - -set_default(\%config,'spam_crossassassin_mailbox',$config{spool_dir}.'/../mail/spam/crossassassinated.%Y-%m-%d'); - -=item spam_local_tests_only - -Whether only local tests are run, defaults to 0 - -=cut - -set_default(\%config,'spam_local_tests_only',0); - -=item spam_user_prefs - -User preferences for spamassassin, defaults to $ENV{HOME}/.spamassassin/user_prefs - -=cut - -set_default(\%config,'spam_user_prefs',"$ENV{HOME}/.spamassassin/user_prefs"); - -=item spam_rules_dir - -Site rules directory for spamassassin, defaults to -'/usr/share/spamassassin' - -=cut - -set_default(\%config,'spam_rules_dir','/usr/share/spamassassin'); - -=back - -=head2 CGI Options - -=over - -=item libravatar_uri $gLibravatarUri - -URI to a libravatar configuration. If empty or undefined, libravatar -support will be disabled. Defaults to -libravatar.cgi, our internal federated libravatar system. - -=cut - -set_default(\%config,'libravatar_uri',$config{cgi_domain}.'/libravatar.cgi?email='); - -=item libravatar_uri_options $gLibravatarUriOptions - -Options to append to the md5_hex of the e-mail. This sets the default -avatar used when an avatar isn't available. Currently defaults to -'?d=retro', which causes a bitmap-looking avatar to be displayed for -unknown e-mails. - -Other options which make sense include ?d=404, ?d=wavatar, etc. See -the API of libravatar for details. - -=cut - -set_default(\%config,'libravatar_uri_options',''); - -=item libravatar_default_image - -Default image to serve for libravatar if there is no avatar for an -e-mail address. By default, this is a 1x1 png. [This will also be the -image served if someone specifies avatar=no.] - -Default: $config{web_dir}/1x1.png - -=cut - -set_default(\%config,'libravatar_default_image',$config{web_dir}.'/1x1.png'); - -=item libravatar_cache_dir - -Directory where cached libravatar images are stored - -Default: $config{web_dir}/libravatar/ - -=cut - -set_default(\%config,'libravatar_cache_dir',$config{web_dir}.'/libravatar/'); - -=item libravatar_blacklist - -Array of regular expressions to match against emails, domains, or -images to only show the default image - -Default: empty array - -=cut - -set_default(\%config,'libravatar_blacklist',[]); - -=back - -=head2 Database - -=over - -=item database - -Name of debbugs PostgreSQL database service. If you wish to not use a service -file, provide a full DBD::Pg compliant data-source, for example: -C<"dbi:Pg:dbname=dbname"> - -=back - -=cut - -set_default(\%config,'database',undef); - -=head2 Text Fields - -The following are the only text fields in general use in the scripts; -a few additional text fields are defined in text.in, but are only used -in db2html and a few other specialty scripts. - -Earlier versions of debbugs defined these values in /etc/debbugs/text, -but now they are required to be in the configuration file. [Eventually -the longer ones will move out into a fully fledged template system.] - -=cut - -=over - -=item bad_email_prefix - -This prefixes the text of all lines in a bad e-mail message ack. - -=cut - -set_default(\%config,'bad_email_prefix',''); - - -=item text_instructions - -This gives more information about bad e-mails to receive.in - -=cut - -set_default(\%config,'text_instructions',$config{bad_email_prefix}); - -=item html_tail - -This shows up at the end of (most) html pages - -In many pages this has been replaced by the html/tail template. - -=cut - -set_default(\%config,'html_tail',<$config{maintainer} <$config{maintainer_email}>. - Last modified: - - SUBSTITUTE_DTIME - -

    - Debian $config{bug} tracking system
    - Copyright (C) 1999 Darren O. Benham, - 1997,2003 nCipher Corporation Ltd, - 1994-97 Ian Jackson. -

    - -END - - -=item html_expire_note - -This message explains what happens to archive/remove-able bugs - -=cut - -set_default(\%config,'html_expire_note', - "(Closed $config{bugs} are archived $config{remove_age} days after the last related message is received.)"); - -=back - -=cut - - -sub read_config{ - my ($conf_file) = @_; - if (not -e $conf_file) { - print STDERR "configuration file '$conf_file' doesn't exist; skipping it\n" if $DEBUG; - return; - } - # first, figure out what type of file we're reading in. - my $fh = IO::File->new($conf_file,'r') - or die "Unable to open configuration file $conf_file for reading: $!"; - # A new version configuration file must have a comment as its first line - my $first_line = <$fh>; - my ($version) = defined $first_line?$first_line =~ /VERSION:\s*(\d+)/i:undef; - if (defined $version) { - if ($version == 1) { - # Do something here; - die "Version 1 configuration files not implemented yet"; - } - else { - die "Version $version configuration files are not supported"; - } - } - else { - # Ugh. Old configuration file - # What we do here is we create a new Safe compartment - # so fucked up crap in the config file doesn't sink us. - my $cpt = new Safe or die "Unable to create safe compartment"; - # perldoc Opcode; for details - $cpt->permit('require',':filesys_read','entereval','caller','pack','unpack','dofile'); - $cpt->reval(qq(require '$conf_file';)); - die "Error in configuration file: $@" if $@; - # Now what we do is check out the contents of %EXPORT_TAGS to see exactly which variables - # we want to glob in from the configuration file - for my $variable (map {$_ =~ /^(?:config|all)$/ ? () : @{$EXPORT_TAGS{$_}}} keys %EXPORT_TAGS) { - my ($hash_name,$glob_name,$glob_type) = __convert_name($variable); - my $var_glob = $cpt->varglob($glob_name); - my $value; #= $cpt->reval("return $variable"); - # print STDERR "$variable $value",qq(\n); - if (defined $var_glob) {{ - no strict 'refs'; - if ($glob_type eq '%') { - $value = {%{*{$var_glob}}} if defined *{$var_glob}{HASH}; - } - elsif ($glob_type eq '@') { - $value = [@{*{$var_glob}}] if defined *{$var_glob}{ARRAY}; - } - else { - $value = ${*{$var_glob}}; - } - # We punt here, because we can't tell if the value was - # defined intentionally, or if it was just left alone; - # this tries to set sane defaults. - set_default(\%config,$hash_name,$value) if defined $value; - }} - } - } -} - -sub __convert_name{ - my ($variable) = @_; - my $hash_name = $variable; - $hash_name =~ s/^([\$\%\@])g//; - my $glob_type = $1; - my $glob_name = 'g'.$hash_name; - $hash_name =~ s/(HTML|CGI|CVE)/ucfirst(lc($1))/ge; - $hash_name =~ s/^([A-Z]+)/lc($1)/e; - $hash_name =~ s/([A-Z]+)/'_'.lc($1)/ge; - return $hash_name unless wantarray; - return ($hash_name,$glob_name,$glob_type); -} - -# set_default - -# sets the configuration hash to the default value if it's not set, -# otherwise doesn't do anything -# If $USING_GLOBALS, then sets an appropriate global. - -sub set_default{ - my ($config,$option,$value) = @_; - my $varname; - if ($USING_GLOBALS) { - # fix up the variable name - $varname = 'g'.join('',map {ucfirst $_} split /_/, $option); - # Fix stupid HTML names - $varname =~ s/(Html|Cgi)/uc($1)/ge; - } - # update the configuration value - if (not $USING_GLOBALS and not exists $config->{$option}) { - $config->{$option} = $value; - } - elsif ($USING_GLOBALS) {{ - no strict 'refs'; - # Need to check if a value has already been set in a global - if (defined *{"Debbugs::Config::${varname}"}) { - $config->{$option} = *{"Debbugs::Config::${varname}"}; - } - else { - $config->{$option} = $value; - } - }} - if ($USING_GLOBALS) {{ - no strict 'refs'; - *{"Debbugs::Config::${varname}"} = $config->{$option}; - }} -} - - -### import magick - -# All we care about here is whether we've been called with the globals or text option; -# if so, then we need to export some symbols back up. -# In any event, we call exporter. - -sub import { - if (grep /^:(?:text|globals)$/, @_) { - $USING_GLOBALS=1; - for my $variable (map {@$_} @EXPORT_TAGS{map{(/^:(text|globals)$/?($1):())} @_}) { - my $tmp = $variable; - no strict 'refs'; - # Yes, I don't care if these are only used once - no warnings 'once'; - # No, it doesn't bother me that I'm assigning an undefined value to a typeglob - no warnings 'misc'; - my ($hash_name,$glob_name,$glob_type) = __convert_name($variable); - $tmp =~ s/^[\%\$\@]//; - *{"Debbugs::Config::${tmp}"} = ref($config{$hash_name})?$config{$hash_name}:\$config{$hash_name}; - } - } - Debbugs::Config->export_to_level(1,@_); -} - - -1; diff --git a/Debbugs/Control.pm b/Debbugs/Control.pm deleted file mode 100644 index 1f8b3aa..0000000 --- a/Debbugs/Control.pm +++ /dev/null @@ -1,3919 +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. -# -# [Other people have contributed to this file; their copyrights should -# go here too.] -# Copyright 2007,2008,2009 by Don Armstrong . - -package Debbugs::Control; - -=head1 NAME - -Debbugs::Control -- Routines for modifying the state of bugs - -=head1 SYNOPSIS - -use Debbugs::Control; - - -=head1 DESCRIPTION - -This module is an abstraction of a lot of functions which originally -were only present in service.in, but as time has gone on needed to be -called from elsewhere. - -All of the public functions take the following options: - -=over - -=item debug -- scalar reference to which debbuging information is -appended - -=item transcript -- scalar reference to which transcript information -is appended - -=item affected_bugs -- hashref which is updated with bugs affected by -this function - - -=back - -Functions which should (probably) append to the .log file take the -following options: - -=over - -=item requester -- Email address of the individual who requested the change - -=item request_addr -- Address to which the request was sent - -=item request_nn -- Name of queue file which caused this request - -=item request_msgid -- Message id of message which caused this request - -=item location -- Optional location; currently ignored but may be -supported in the future for updating archived bugs upon archival - -=item message -- The original message which caused the action to be taken - -=item append_log -- Whether or not to append information to the log. - -=back - -B (for most functions) is a special option. When set to -false, no appending to the log is done at all. When it is not present, -the above information is faked, and appended to the log file. When it -is true, the above options must be present, and their values are used. - - -=head1 GENERAL FUNCTIONS - -=cut - -use warnings; -use strict; -use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); -use Exporter qw(import); - -BEGIN{ - $VERSION = 1.00; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - %EXPORT_TAGS = (done => [qw(set_done)], - submitter => [qw(set_submitter)], - severity => [qw(set_severity)], - affects => [qw(affects)], - summary => [qw(summary)], - outlook => [qw(outlook)], - owner => [qw(owner)], - title => [qw(set_title)], - forward => [qw(set_forwarded)], - found => [qw(set_found set_fixed)], - fixed => [qw(set_found set_fixed)], - package => [qw(set_package)], - block => [qw(set_blocks)], - merge => [qw(set_merged)], - tag => [qw(set_tag)], - clone => [qw(clone_bug)], - archive => [qw(bug_archive bug_unarchive), - ], - limit => [qw(check_limit)], - log => [qw(append_action_to_log), - ], - ); - @EXPORT_OK = (); - Exporter::export_ok_tags(keys %EXPORT_TAGS); - $EXPORT_TAGS{all} = [@EXPORT_OK]; -} - -use Debbugs::Config qw(:config); -use Debbugs::Common qw(:lock buglog :misc get_hashname sort_versions); -use Debbugs::UTF8; -use Debbugs::Status qw(bug_archiveable :read :hook writebug new_bug splitpackages split_status_fields get_bug_status); -use Debbugs::CGI qw(html_escape); -use Debbugs::Log qw(:misc :write); -use Debbugs::Recipients qw(:add); -use Debbugs::Packages qw(:versions :mapping); - -use Data::Dumper qw(); -use Params::Validate qw(validate_with :types); -use File::Path qw(mkpath); -use File::Copy qw(copy); -use IO::File; - -use Debbugs::Text qw(:templates); - -use Debbugs::Mail qw(rfc822_date send_mail_message default_headers encode_headers); -use Debbugs::MIME qw(create_mime_message); - -use Mail::RFC822::Address qw(); - -use POSIX qw(strftime); - -use Storable qw(dclone nfreeze); -use List::AllUtils qw(first max); -use Encode qw(encode_utf8); - -use Carp; - -# These are a set of options which are common to all of these functions - -my %common_options = (debug => {type => SCALARREF|HANDLE, - optional => 1, - }, - transcript => {type => SCALARREF|HANDLE, - optional => 1, - }, - affected_bugs => {type => HASHREF, - optional => 1, - }, - affected_packages => {type => HASHREF, - optional => 1, - }, - recipients => {type => HASHREF, - default => {}, - }, - limit => {type => HASHREF, - default => {}, - }, - show_bug_info => {type => BOOLEAN, - default => 1, - }, - request_subject => {type => SCALAR, - default => 'Unknown Subject', - }, - request_msgid => {type => SCALAR, - default => '', - }, - request_nn => {type => SCALAR, - optional => 1, - }, - request_replyto => {type => SCALAR, - optional => 1, - }, - locks => {type => HASHREF, - optional => 1, - }, - ); - - -my %append_action_options = - (action => {type => SCALAR, - optional => 1, - }, - requester => {type => SCALAR, - optional => 1, - }, - request_addr => {type => SCALAR, - optional => 1, - }, - location => {type => SCALAR, - optional => 1, - }, - message => {type => SCALAR|ARRAYREF, - optional => 1, - }, - append_log => {type => BOOLEAN, - optional => 1, - depends => [qw(requester request_addr), - qw(message), - ], - }, - # locks is both an append_action option, and a common option; - # it's ok for it to be in both places. - locks => {type => HASHREF, - optional => 1, - }, - ); - -our $locks = 0; - - -# this is just a generic stub for Debbugs::Control functions. -# -# =head2 set_foo -# -# eval { -# set_foo(bug => $ref, -# transcript => $transcript, -# ($dl > 0 ? (debug => $transcript):()), -# requester => $header{from}, -# request_addr => $controlrequestaddr, -# message => \@log, -# affected_packages => \%affected_packages, -# recipients => \%recipients, -# summary => undef, -# ); -# }; -# if ($@) { -# $errors++; -# print {$transcript} "Failed to set foo $ref bar: $@"; -# } -# -# Foo frobinates -# -# =cut -# -# sub set_foo { -# my %param = validate_with(params => \@_, -# spec => {bug => {type => SCALAR, -# regex => qr/^\d+$/, -# }, -# # specific options here -# %common_options, -# %append_action_options, -# }, -# ); -# my %info = -# __begin_control(%param, -# command => 'foo' -# ); -# my ($debug,$transcript) = -# @info{qw(debug transcript)}; -# my @data = @{$info{data}}; -# my @bugs = @{$info{bugs}}; -# -# my $action = ''; -# for my $data (@data) { -# append_action_to_log(bug => $data->{bug_num}, -# get_lock => 0, -# __return_append_to_log_options( -# %param, -# action => $action, -# ), -# ) -# if not exists $param{append_log} or $param{append_log}; -# writebug($data->{bug_num},$data); -# print {$transcript} "$action\n"; -# } -# __end_control(%info); -# } - - -=head2 set_blocks - - eval { - set_block(bug => $ref, - transcript => $transcript, - ($dl > 0 ? (debug => $transcript):()), - requester => $header{from}, - request_addr => $controlrequestaddr, - message => \@log, - affected_packages => \%affected_packages, - recipients => \%recipients, - block => [], - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to set blockers of $ref: $@"; - } - -Alters the set of bugs that block this bug from being fixed - -This requires altering both this bug (and those it's merged with) as -well as the bugs that block this bug from being fixed (and those that -it's merged with) - -=over - -=item block -- scalar or arrayref of blocking bugs to set, add or remove - -=item add -- if true, add blocking bugs - -=item remove -- if true, remove blocking bugs - -=back - -=cut - -sub set_blocks { - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - # specific options here - block => {type => SCALAR|ARRAYREF, - default => [], - }, - add => {type => BOOLEAN, - default => 0, - }, - remove => {type => BOOLEAN, - default => 0, - }, - %common_options, - %append_action_options, - }, - ); - if ($param{add} and $param{remove}) { - croak "It's nonsensical to add and remove the same blocking bugs"; - } - if (grep {$_ !~ /^\d+$/} make_list($param{block})) { - croak "Invalid blocking bug(s):". - join(', ',grep {$_ !~ /^\d+$/} make_list($param{block})); - } - my $mode = 'set'; - if ($param{add}) { - $mode = 'add'; - } - elsif ($param{remove}) { - $mode = 'remove'; - } - - my %info = - __begin_control(%param, - command => 'blocks' - ); - my ($debug,$transcript) = - @info{qw(debug transcript)}; - my @data = @{$info{data}}; - my @bugs = @{$info{bugs}}; - - - # The first bit of this code is ugly, and should be cleaned up. - # Its purpose is to populate %removed_blockers and %add_blockers - # with all of the bugs that should be added or removed as blockers - # of all of the bugs which are merged with $param{bug} - my %ok_blockers; - my %bad_blockers; - for my $blocker (make_list($param{block})) { - next if $ok_blockers{$blocker} or $bad_blockers{$blocker}; - my $data = read_bug(bug=>$blocker, - ); - if (defined $data and not $data->{archived}) { - $data = split_status_fields($data); - $ok_blockers{$blocker} = 1; - my @merged_bugs; - push @merged_bugs, make_list($data->{mergedwith}); - @ok_blockers{@merged_bugs} = (1) x @merged_bugs if @merged_bugs; - } - else { - $bad_blockers{$blocker} = 1; - } - } - - # throw an error if we are setting the blockers and there is a bad - # blocker - if (keys %bad_blockers and $mode eq 'set') { - __end_control(%info); - croak "Unknown/archived blocking bug(s):".join(', ',keys %bad_blockers). - keys %ok_blockers?'':" and no good blocking bug(s)"; - } - # if there are no ok blockers and we are not setting the blockers, - # there's an error. - if (not keys %ok_blockers and $mode ne 'set') { - print {$transcript} "No valid blocking bug(s) given; not doing anything\n"; - if (keys %bad_blockers) { - __end_control(%info); - croak "Unknown/archived blocking bug(s):".join(', ',keys %bad_blockers); - } - __end_control(%info); - return; - } - - my @change_blockers = keys %ok_blockers; - - my %removed_blockers; - my %added_blockers; - my $action = ''; - my @blockers = map {split ' ', $_->{blockedby}} @data; - my %blockers; - @blockers{@blockers} = (1) x @blockers; - - # it is nonsensical for a bug to block itself (or a merged - # partner); We currently don't allow removal because we'd possibly - # deadlock - - my %bugs; - @bugs{@bugs} = (1) x @bugs; - for my $blocker (@change_blockers) { - if ($bugs{$blocker}) { - __end_control(%info); - croak "It is nonsensical for a bug to block itself (or a merged partner): $blocker"; - } - } - @blockers = keys %blockers; - if ($param{add}) { - %removed_blockers = (); - for my $blocker (@change_blockers) { - next if exists $blockers{$blocker}; - $blockers{$blocker} = 1; - $added_blockers{$blocker} = 1; - } - } - elsif ($param{remove}) { - %added_blockers = (); - for my $blocker (@change_blockers) { - next if exists $removed_blockers{$blocker}; - delete $blockers{$blocker}; - $removed_blockers{$blocker} = 1; - } - } - else { - @removed_blockers{@blockers} = (1) x @blockers; - %blockers = (); - for my $blocker (@change_blockers) { - next if exists $blockers{$blocker}; - $blockers{$blocker} = 1; - if (exists $removed_blockers{$blocker}) { - delete $removed_blockers{$blocker}; - } - else { - $added_blockers{$blocker} = 1; - } - } - } - for my $data (@data) { - my $old_data = dclone($data); - # remove blockers and/or add new ones as appropriate - if ($data->{blockedby} eq '') { - print {$transcript} "$data->{bug_num} was not blocked by any bugs.\n"; - } else { - print {$transcript} "$data->{bug_num} was blocked by: $data->{blockedby}\n"; - } - if ($data->{blocks} eq '') { - print {$transcript} "$data->{bug_num} was not blocking any bugs.\n"; - } else { - print {$transcript} "$data->{bug_num} was blocking: $data->{blocks}\n"; - } - my @changed; - push @changed, 'added blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %added_blockers]) if keys %added_blockers; - push @changed, 'removed blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %removed_blockers]) if keys %removed_blockers; - $action = ucfirst(join ('; ',@changed)) if @changed; - if (not @changed) { - print {$transcript} "Ignoring request to alter blocking bugs of bug #$data->{bug_num} to the same blocks previously set\n"; - next; - } - $data->{blockedby} = join(' ',keys %blockers); - append_action_to_log(bug => $data->{bug_num}, - command => 'block', - old_data => $old_data, - new_data => $data, - get_lock => 0, - __return_append_to_log_options( - %param, - action => $action, - ), - ) - if not exists $param{append_log} or $param{append_log}; - writebug($data->{bug_num},$data); - print {$transcript} "$action\n"; - } - # we do this bit below to avoid code duplication - my %mungable_blocks; - $mungable_blocks{remove} = \%removed_blockers if keys %removed_blockers; - $mungable_blocks{add} = \%added_blockers if keys %added_blockers; - my $new_locks = 0; - for my $add_remove (keys %mungable_blocks) { - my %munge_blockers; - for my $blocker (keys %{$mungable_blocks{$add_remove}}) { - next if $munge_blockers{$blocker}; - my ($temp_locks, @blocking_data) = - lock_read_all_merged_bugs(bug => $blocker, - ($param{archived}?(location => 'archive'):()), - exists $param{locks}?(locks => $param{locks}):(), - ); - $locks+= $temp_locks; - $new_locks+=$temp_locks; - if (not @blocking_data) { - for (1..$new_locks) { - unfilelock(exists $param{locks}?$param{locks}:()); - $locks--; - } - die "Unable to get file lock while trying to $add_remove blocker '$blocker'"; - } - for (map {$_->{bug_num}} @blocking_data) { - $munge_blockers{$_} = 1; - } - for my $data (@blocking_data) { - my $old_data = dclone($data); - my %blocks; - my @blocks = split ' ', $data->{blocks}; - @blocks{@blocks} = (1) x @blocks; - @blocks = (); - for my $bug (@bugs) { - if ($add_remove eq 'remove') { - next unless exists $blocks{$bug}; - delete $blocks{$bug}; - } - else { - next if exists $blocks{$bug}; - $blocks{$bug} = 1; - } - push @blocks, $bug; - } - $data->{blocks} = join(' ',sort keys %blocks); - my $action = ($add_remove eq 'add'?'Added':'Removed'). - " indication that bug $data->{bug_num} blocks ". - join(',',@blocks); - append_action_to_log(bug => $data->{bug_num}, - command => 'block', - old_data => $old_data, - new_data => $data, - get_lock => 0, - __return_append_to_log_options(%param, - action => $action - ) - ); - writebug($data->{bug_num},$data); - } - __handle_affected_packages(%param,data=>\@blocking_data); - add_recipients(recipients => $param{recipients}, - actions_taken => {blocks => 1}, - data => \@blocking_data, - debug => $debug, - transcript => $transcript, - ); - - for (1..$new_locks) { - unfilelock(exists $param{locks}?$param{locks}:()); - $locks--; - } - } - } - __end_control(%info); -} - - - -=head2 set_tag - - eval { - set_tag(bug => $ref, - transcript => $transcript, - ($dl > 0 ? (debug => $transcript):()), - requester => $header{from}, - request_addr => $controlrequestaddr, - message => \@log, - affected_packages => \%affected_packages, - recipients => \%recipients, - tag => [], - add => 1, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to set tag on $ref: $@"; - } - - -Sets, adds, or removes the specified tags on a bug - -=over - -=item tag -- scalar or arrayref of tags to set, add or remove - -=item add -- if true, add tags - -=item remove -- if true, remove tags - -=item warn_on_bad_tags -- if true (the default) warn if bad tags are -passed. - -=back - -=cut - -sub set_tag { - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - # specific options here - tag => {type => SCALAR|ARRAYREF, - default => [], - }, - add => {type => BOOLEAN, - default => 0, - }, - remove => {type => BOOLEAN, - default => 0, - }, - warn_on_bad_tags => {type => BOOLEAN, - default => 1, - }, - %common_options, - %append_action_options, - }, - ); - if ($param{add} and $param{remove}) { - croak "It's nonsensical to add and remove the same tags"; - } - - my %info = - __begin_control(%param, - command => 'tag' - ); - my $transcript = $info{transcript}; - my @data = @{$info{data}}; - my @tags = make_list($param{tag}); - if (not @tags and ($param{remove} or $param{add})) { - if ($param{remove}) { - print {$transcript} "Requested to remove no tags; doing nothing.\n"; - } - else { - print {$transcript} "Requested to add no tags; doing nothing.\n"; - } - __end_control(%info); - return; - } - # first things first, make the versions fully qualified source - # versions - for my $data (@data) { - my $action = 'Did not alter tags'; - my %tag_added = (); - my %tag_removed = (); - my @old_tags = split /\,?\s+/, $data->{keywords}; - my %tags; - @tags{@old_tags} = (1) x @old_tags; - my $old_data = dclone($data); - if (not $param{add} and not $param{remove}) { - $tag_removed{$_} = 1 for @old_tags; - %tags = (); - } - my @bad_tags = (); - for my $tag (@tags) { - if (not $param{remove} and - not defined first {$_ eq $tag} @{$config{tags}}) { - push @bad_tags, $tag; - next; - } - if ($param{add}) { - if (not exists $tags{$tag}) { - $tags{$tag} = 1; - $tag_added{$tag} = 1; - } - } - elsif ($param{remove}) { - if (exists $tags{$tag}) { - delete $tags{$tag}; - $tag_removed{$tag} = 1; - } - } - else { - if (exists $tag_removed{$tag}) { - delete $tag_removed{$tag}; - } - else { - $tag_added{$tag} = 1; - } - $tags{$tag} = 1; - } - } - if (@bad_tags and $param{warn_on_bad_tags}) { - print {$transcript} "Unknown tag(s): ".join(', ',@bad_tags).".\n"; - print {$transcript} "These tags are recognized: ".join(', ',@{$config{tags}}).".\n"; - } - $data->{keywords} = join(' ',keys %tags); - - my @changed; - push @changed, 'added tag(s) '.english_join([keys %tag_added]) if keys %tag_added; - push @changed, 'removed tag(s) '.english_join([keys %tag_removed]) if keys %tag_removed; - $action = ucfirst(join ('; ',@changed)) if @changed; - if (not @changed) { - print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n"; - next; - } - $action .= '.'; - append_action_to_log(bug => $data->{bug_num}, - get_lock => 0, - command => 'tag', - old_data => $old_data, - new_data => $data, - __return_append_to_log_options( - %param, - action => $action, - ), - ) - if not exists $param{append_log} or $param{append_log}; - writebug($data->{bug_num},$data); - print {$transcript} "$action\n"; - } - __end_control(%info); -} - - - -=head2 set_severity - - eval { - set_severity(bug => $ref, - transcript => $transcript, - ($dl > 0 ? (debug => $transcript):()), - requester => $header{from}, - request_addr => $controlrequestaddr, - message => \@log, - affected_packages => \%affected_packages, - recipients => \%recipients, - severity => 'normal', - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to set the severity of bug $ref: $@"; - } - -Sets the severity of a bug. If severity is not passed, is undefined, -or has zero length, sets the severity to the default severity. - -=cut - -sub set_severity { - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - # specific options here - severity => {type => SCALAR|UNDEF, - default => $config{default_severity}, - }, - %common_options, - %append_action_options, - }, - ); - if (not defined $param{severity} or - not length $param{severity} - ) { - $param{severity} = $config{default_severity}; - } - - # check validity of new severity - if (not defined first {$_ eq $param{severity}} (@{$config{severity_list}},$config{default_severity})) { - die "Severity '$param{severity}' is not a valid severity level"; - } - my %info = - __begin_control(%param, - command => 'severity' - ); - my $transcript = $info{transcript}; - my @data = @{$info{data}}; - - my $action = ''; - for my $data (@data) { - if (not defined $data->{severity}) { - $data->{severity} = $param{severity}; - $action = "Severity set to '$param{severity}'"; - } - else { - if ($data->{severity} eq '') { - $data->{severity} = $config{default_severity}; - } - if ($data->{severity} eq $param{severity}) { - print {$transcript} "Ignoring request to change severity of $config{bug} $data->{bug_num} to the same value.\n"; - next; - } - $action = "Severity set to '$param{severity}' from '$data->{severity}'"; - $data->{severity} = $param{severity}; - } - append_action_to_log(bug => $data->{bug_num}, - get_lock => 0, - __return_append_to_log_options( - %param, - action => $action, - ), - ) - if not exists $param{append_log} or $param{append_log}; - writebug($data->{bug_num},$data); - print {$transcript} "$action\n"; - } - __end_control(%info); -} - - -=head2 set_done - - eval { - set_done(bug => $ref, - transcript => $transcript, - ($dl > 0 ? (debug => $transcript):()), - requester => $header{from}, - request_addr => $controlrequestaddr, - message => \@log, - affected_packages => \%affected_packages, - recipients => \%recipients, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to set foo $ref bar: $@"; - } - -Foo frobinates - -=cut - -sub set_done { - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - reopen => {type => BOOLEAN, - default => 0, - }, - submitter => {type => SCALAR, - optional => 1, - }, - clear_fixed => {type => BOOLEAN, - default => 1, - }, - notify_submitter => {type => BOOLEAN, - default => 1, - }, - original_report => {type => SCALARREF, - optional => 1, - }, - done => {type => SCALAR|UNDEF, - optional => 1, - }, - %common_options, - %append_action_options, - }, - ); - - if (exists $param{submitter} and - not Mail::RFC822::Address::valid($param{submitter})) { - die "New submitter address '$param{submitter}' is not a valid e-mail address"; - } - if (exists $param{done} and defined $param{done} and $param{done} eq 1) { #special case this as using the requester address - $param{done} = $param{requester}; - } - if (exists $param{done} and - (not defined $param{done} or - not length $param{done})) { - delete $param{done}; - $param{reopen} = 1; - } - - my %info = - __begin_control(%param, - command => $param{reopen}?'reopen':'done', - ); - my $transcript = $info{transcript}; - my @data = @{$info{data}}; - my $action =''; - - if ($param{reopen}) { - # avoid warning multiple times if there are fixed versions - my $warn_fixed = 1; - for my $data (@data) { - if (not exists $data->{done} or - not defined $data->{done} or - not length $data->{done}) { - print {$transcript} "Bug $data->{bug_num} is not marked as done; doing nothing.\n"; - __end_control(%info); - return; - } - if (@{$data->{fixed_versions}} and $warn_fixed) { - print {$transcript} "'reopen' may be inappropriate when a bug has been closed with a version;\n"; - print {$transcript} "all fixed versions will be cleared, and you may need to re-add them.\n"; - $warn_fixed = 0; - } - } - $action = "Bug reopened"; - for my $data (@data) { - my $old_data = dclone($data); - $data->{done} = ''; - append_action_to_log(bug => $data->{bug_num}, - command => 'done', - new_data => $data, - old_data => $old_data, - get_lock => 0, - __return_append_to_log_options( - %param, - action => $action, - ), - ) - if not exists $param{append_log} or $param{append_log}; - writebug($data->{bug_num},$data); - } - print {$transcript} "$action\n"; - __end_control(%info); - if (exists $param{submitter}) { - set_submitter(bug => $param{bug}, - submitter => $param{submitter}, - hash_slice(%param, - keys %common_options, - keys %append_action_options) - ); - } - # clear the fixed revisions - if ($param{clear_fixed}) { - set_fixed(fixed => [], - bug => $param{bug}, - reopen => 0, - hash_slice(%param, - keys %common_options, - keys %append_action_options), - ); - } - } - else { - my %submitter_notified; - my $orig_report_set = 0; - for my $data (@data) { - if (exists $data->{done} and - defined $data->{done} and - length $data->{done}) { - print {$transcript} "Bug $data->{bug_num} is already marked as done; not doing anything.\n"; - __end_control(%info); - return; - } - } - for my $data (@data) { - my $old_data = dclone($data); - my $hash = get_hashname($data->{bug_num}); - my $report_fh = IO::File->new("$config{spool_dir}/db-h/$hash/$data->{bug_num}.report",'r') or - die "Unable to open original report $config{spool_dir}/db-h/$hash/$data->{bug_num}.report for reading: $!"; - my $orig_report; - { - local $/; - $orig_report= <$report_fh>; - } - close $report_fh; - if (not $orig_report_set and defined $orig_report and - length $orig_report and - exists $param{original_report}){ - ${$param{original_report}} = $orig_report; - $orig_report_set = 1; - } - - $action = "Marked $config{bug} as done"; - - # set done to the requester - $data->{done} = exists $param{done}?$param{done}:$param{requester}; - append_action_to_log(bug => $data->{bug_num}, - command => 'done', - new_data => $data, - old_data => $old_data, - get_lock => 0, - __return_append_to_log_options( - %param, - action => $action, - ), - ) - if not exists $param{append_log} or $param{append_log}; - writebug($data->{bug_num},$data); - print {$transcript} "$action\n"; - # get the original report - if ($param{notify_submitter}) { - my $submitter_message; - if(not exists $submitter_notified{$data->{originator}}) { - $submitter_message = - create_mime_message([default_headers(queue_file => $param{request_nn}, - data => $data, - msgid => $param{request_msgid}, - msgtype => 'notifdone', - pr_msg => 'they-closed', - headers => - [To => $data->{submitter}, - Subject => "$config{ubug}#$data->{bug_num} ". - "closed by $param{requester} ".(defined $param{request_subject}?"($param{request_subject})":""), - ], - ) - ], - __message_body_template('mail/process_your_bug_done', - {data => $data, - replyto => (exists $param{request_replyto} ? - $param{request_replyto} : - $param{requester} || 'Unknown'), - markedby => $param{requester}, - subject => $param{request_subject}, - messageid => $param{request_msgid}, - config => \%config, - }), - [join('',make_list($param{message})),$orig_report] - ); - send_mail_message(message => $submitter_message, - recipients => $old_data->{submitter}, - ); - $submitter_notified{$data->{originator}} = $submitter_message; - } - else { - $submitter_message = $submitter_notified{$data->{originator}}; - } - append_action_to_log(bug => $data->{bug_num}, - action => "Notification sent", - requester => '', - request_addr => $data->{originator}, - desc => "$config{bug} acknowledged by developer.", - recips => [$data->{originator}], - message => $submitter_message, - get_lock => 0, - ); - } - } - __end_control(%info); - if (exists $param{fixed}) { - set_fixed(fixed => $param{fixed}, - bug => $param{bug}, - reopen => 0, - hash_slice(%param, - keys %common_options, - keys %append_action_options - ), - ); - } - } -} - - -=head2 set_submitter - - eval { - set_submitter(bug => $ref, - transcript => $transcript, - ($dl > 0 ? (debug => $transcript):()), - requester => $header{from}, - request_addr => $controlrequestaddr, - message => \@log, - affected_packages => \%affected_packages, - recipients => \%recipients, - submitter => $new_submitter, - notify_submitter => 1, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to set the forwarded-to-address of $ref: $@"; - } - -Sets the submitter of a bug. If notify_submitter is true (the -default), notifies the old submitter of a bug on changes - -=cut - -sub set_submitter { - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - # specific options here - submitter => {type => SCALAR, - }, - notify_submitter => {type => BOOLEAN, - default => 1, - }, - %common_options, - %append_action_options, - }, - ); - if (not Mail::RFC822::Address::valid($param{submitter})) { - die "New submitter address $param{submitter} is not a valid e-mail address"; - } - my %info = - __begin_control(%param, - command => 'submitter' - ); - my ($debug,$transcript) = - @info{qw(debug transcript)}; - my @data = @{$info{data}}; - my $action = ''; - # here we only concern ourselves with the first of the merged bugs - for my $data ($data[0]) { - my $notify_old_submitter = 0; - my $old_data = dclone($data); - print {$debug} "Going to change bug submitter\n"; - if (((not defined $param{submitter} or not length $param{submitter}) and - (not defined $data->{originator} or not length $data->{originator})) or - (defined $param{submitter} and defined $data->{originator} and - $param{submitter} eq $data->{originator})) { - print {$transcript} "Ignoring request to change the submitter of bug#$data->{bug_num} to the same value\n"; - next; - } - else { - if (defined $data->{originator} and length($data->{originator})) { - $action= "Changed $config{bug} submitter to '$param{submitter}' from '$data->{originator}'."; - $notify_old_submitter = 1; - } - else { - $action= "Set $config{bug} submitter to '$param{submitter}'."; - } - $data->{originator} = $param{submitter}; - } - append_action_to_log(bug => $data->{bug_num}, - command => 'submitter', - new_data => $data, - old_data => $old_data, - get_lock => 0, - __return_append_to_log_options( - %param, - action => $action, - ), - ) - if not exists $param{append_log} or $param{append_log}; - writebug($data->{bug_num},$data); - print {$transcript} "$action\n"; - # notify old submitter - if ($notify_old_submitter and $param{notify_submitter}) { - send_mail_message(message => - create_mime_message([default_headers(queue_file => $param{request_nn}, - data => $data, - msgid => $param{request_msgid}, - msgtype => 'ack', - pr_msg => 'submitter-changed', - headers => - [To => $old_data->{submitter}, - Subject => "$config{ubug}#$data->{bug_num} submitter addressed changed ($param{request_subject})", - ], - ) - ], - __message_body_template('mail/submitter_changed', - {old_data => $old_data, - data => $data, - replyto => exists $param{header}{'reply-to'} ? $param{request_replyto} : $param{requester} || 'Unknown', - config => \%config, - }) - ), - recipients => $old_data->{submitter}, - ); - } - } - __end_control(%info); -} - - - -=head2 set_forwarded - - eval { - set_forwarded(bug => $ref, - transcript => $transcript, - ($dl > 0 ? (debug => $transcript):()), - requester => $header{from}, - request_addr => $controlrequestaddr, - message => \@log, - affected_packages => \%affected_packages, - recipients => \%recipients, - forwarded => $forward_to, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to set the forwarded-to-address of $ref: $@"; - } - -Sets the location to which a bug is forwarded. Given an undef -forwarded, unsets forwarded. - - -=cut - -sub set_forwarded { - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - # specific options here - forwarded => {type => SCALAR|UNDEF, - }, - %common_options, - %append_action_options, - }, - ); - if (defined $param{forwarded} and $param{forwarded} =~ /[^[:print:]]/) { - die "Non-printable characters are not allowed in the forwarded field"; - } - $param{forwarded} = undef if defined $param{forwarded} and not length $param{forwarded}; - my %info = - __begin_control(%param, - command => 'forwarded' - ); - my ($debug,$transcript) = - @info{qw(debug transcript)}; - my @data = @{$info{data}}; - my $action = ''; - for my $data (@data) { - my $old_data = dclone($data); - print {$debug} "Going to change bug forwarded\n"; - if (__all_undef_or_equal($param{forwarded},$data->{forwarded}) or - (not defined $param{forwarded} and - defined $data->{forwarded} and not length $data->{forwarded})) { - print {$transcript} "Ignoring request to change the forwarded-to-address of bug#$data->{bug_num} to the same value\n"; - next; - } - else { - if (not defined $param{forwarded}) { - $action= "Unset $config{bug} forwarded-to-address"; - } - elsif (defined $data->{forwarded} and length($data->{forwarded})) { - $action= "Changed $config{bug} forwarded-to-address to '$param{forwarded}' from '$data->{forwarded}'."; - } - else { - $action= "Set $config{bug} forwarded-to-address to '$param{forwarded}'."; - } - $data->{forwarded} = $param{forwarded}; - } - append_action_to_log(bug => $data->{bug_num}, - command => 'forwarded', - new_data => $data, - old_data => $old_data, - get_lock => 0, - __return_append_to_log_options( - %param, - action => $action, - ), - ) - if not exists $param{append_log} or $param{append_log}; - writebug($data->{bug_num},$data); - print {$transcript} "$action\n"; - } - __end_control(%info); -} - - - - -=head2 set_title - - eval { - set_title(bug => $ref, - transcript => $transcript, - ($dl > 0 ? (debug => $transcript):()), - requester => $header{from}, - request_addr => $controlrequestaddr, - message => \@log, - affected_packages => \%affected_packages, - recipients => \%recipients, - title => $new_title, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to set the title of $ref: $@"; - } - -Sets the title of a specific bug - - -=cut - -sub set_title { - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - # specific options here - title => {type => SCALAR, - }, - %common_options, - %append_action_options, - }, - ); - if ($param{title} =~ /[^[:print:]]/) { - die "Non-printable characters are not allowed in bug titles"; - } - - my %info = __begin_control(%param, - command => 'title', - ); - my ($debug,$transcript) = - @info{qw(debug transcript)}; - my @data = @{$info{data}}; - my $action = ''; - for my $data (@data) { - my $old_data = dclone($data); - print {$debug} "Going to change bug title\n"; - if (defined $data->{subject} and length($data->{subject}) and - $data->{subject} eq $param{title}) { - print {$transcript} "Ignoring request to change the title of bug#$data->{bug_num} to the same title\n"; - next; - } - else { - if (defined $data->{subject} and length($data->{subject})) { - $action= "Changed $config{bug} title to '$param{title}' from '$data->{subject}'."; - } else { - $action= "Set $config{bug} title to '$param{title}'."; - } - $data->{subject} = $param{title}; - } - append_action_to_log(bug => $data->{bug_num}, - command => 'title', - new_data => $data, - old_data => $old_data, - get_lock => 0, - __return_append_to_log_options( - %param, - action => $action, - ), - ) - if not exists $param{append_log} or $param{append_log}; - writebug($data->{bug_num},$data); - print {$transcript} "$action\n"; - } - __end_control(%info); -} - - -=head2 set_package - - eval { - set_package(bug => $ref, - transcript => $transcript, - ($dl > 0 ? (debug => $transcript):()), - requester => $header{from}, - request_addr => $controlrequestaddr, - message => \@log, - affected_packages => \%affected_packages, - recipients => \%recipients, - package => $new_package, - is_source => 0, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to assign or reassign $ref to a package: $@"; - } - -Indicates that a bug is in a particular package. If is_source is true, -indicates that the package is a source package. [Internally, this -causes src: to be prepended to the package name.] - -The default for is_source is 0. As a special case, if the package -starts with 'src:', it is assumed to be a source package and is_source -is overridden. - -The package option must match the package_name_re regex. - -=cut - -sub set_package { - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - # specific options here - package => {type => SCALAR|ARRAYREF, - }, - is_source => {type => BOOLEAN, - default => 0, - }, - %common_options, - %append_action_options, - }, - ); - my @new_packages = map {splitpackages($_)} make_list($param{package}); - if (grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages) { - croak "Invalid package name '". - join(',',grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages). - "'"; - } - my %info = __begin_control(%param, - command => 'package', - ); - my ($debug,$transcript) = - @info{qw(debug transcript)}; - my @data = @{$info{data}}; - # clean up the new package - my $new_package = - join(',', - map {my $temp = $_; - ($temp =~ s/^src:// or - $param{is_source}) ? 'src:'.$temp:$temp; - } @new_packages); - - my $action = ''; - my $package_reassigned = 0; - for my $data (@data) { - my $old_data = dclone($data); - print {$debug} "Going to change assigned package\n"; - if (defined $data->{package} and length($data->{package}) and - $data->{package} eq $new_package) { - print {$transcript} "Ignoring request to reassign bug #$data->{bug_num} to the same package\n"; - next; - } - else { - if (defined $data->{package} and length($data->{package})) { - $package_reassigned = 1; - $action= "$config{bug} reassigned from package '$data->{package}'". - " to '$new_package'."; - } else { - $action= "$config{bug} assigned to package '$new_package'."; - } - $data->{package} = $new_package; - } - append_action_to_log(bug => $data->{bug_num}, - command => 'package', - new_data => $data, - old_data => $old_data, - get_lock => 0, - __return_append_to_log_options( - %param, - action => $action, - ), - ) - if not exists $param{append_log} or $param{append_log}; - writebug($data->{bug_num},$data); - print {$transcript} "$action\n"; - } - __end_control(%info); - # Only clear the fixed/found versions if the package has been - # reassigned - if ($package_reassigned) { - my @params_for_found_fixed = - map {exists $param{$_}?($_,$param{$_}):()} - ('bug', - keys %common_options, - keys %append_action_options, - ); - set_found(found => [], - @params_for_found_fixed, - ); - set_fixed(fixed => [], - @params_for_found_fixed, - ); - } -} - -=head2 set_found - - eval { - set_found(bug => $ref, - transcript => $transcript, - ($dl > 0 ? (debug => $transcript):()), - requester => $header{from}, - request_addr => $controlrequestaddr, - message => \@log, - affected_packages => \%affected_packages, - recipients => \%recipients, - found => [], - add => 1, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to set found on $ref: $@"; - } - - -Sets, adds, or removes the specified found versions of a package - -If the version list is empty, and the bug is currently not "done", -causes the done field to be cleared. - -If any of the versions added to found are greater than any version in -which the bug is fixed (or when the bug is found and there are no -fixed versions) the done field is cleared. - -=cut - -sub set_found { - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - # specific options here - found => {type => SCALAR|ARRAYREF, - default => [], - }, - add => {type => BOOLEAN, - default => 0, - }, - remove => {type => BOOLEAN, - default => 0, - }, - %common_options, - %append_action_options, - }, - ); - if ($param{add} and $param{remove}) { - croak "It's nonsensical to add and remove the same versions"; - } - - my %info = - __begin_control(%param, - command => 'found' - ); - my ($debug,$transcript) = - @info{qw(debug transcript)}; - my @data = @{$info{data}}; - my %versions; - for my $version (make_list($param{found})) { - next unless defined $version; - $versions{$version} = - [make_source_versions(package => [splitpackages($data[0]{package})], - warnings => $transcript, - debug => $debug, - guess_source => 0, - versions => $version, - ) - ]; - # This is really ugly, but it's what we have to do - if (not @{$versions{$version}}) { - print {$transcript} "Unable to make a source version for version '$version'\n"; - } - } - if (not keys %versions and ($param{remove} or $param{add})) { - if ($param{remove}) { - print {$transcript} "Requested to remove no versions; doing nothing.\n"; - } - else { - print {$transcript} "Requested to add no versions; doing nothing.\n"; - } - __end_control(%info); - return; - } - # first things first, make the versions fully qualified source - # versions - for my $data (@data) { - # The 'done' field gets a bit weird with version tracking, - # because a bug may be closed by multiple people in different - # branches. Until we have something more flexible, we set it - # every time a bug is fixed, and clear it when a bug is found - # in a version greater than any version in which the bug is - # fixed or when a bug is found and there is no fixed version - my $action = 'Did not alter found versions'; - my %found_added = (); - my %found_removed = (); - my %fixed_removed = (); - my $reopened = 0; - my $old_data = dclone($data); - if (not $param{add} and not $param{remove}) { - $found_removed{$_} = 1 for @{$data->{found_versions}}; - $data->{found_versions} = []; - } - my %found_versions; - @found_versions{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}}; - my %fixed_versions; - @fixed_versions{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}}; - for my $version (keys %versions) { - if ($param{add}) { - my @svers = @{$versions{$version}}; - if (not @svers) { - @svers = $version; - } - elsif (not grep {$version eq $_} @svers) { - # The $version was not equal to one of the source - # versions, so it's probably unqualified (or just - # wrong). Delete it, and use the source versions - # instead. - if (exists $found_versions{$version}) { - delete $found_versions{$version}; - $found_removed{$version} = 1; - } - } - for my $sver (@svers) { - if (not exists $found_versions{$sver}) { - $found_versions{$sver} = 1; - $found_added{$sver} = 1; - } - # if the found we are adding matches any fixed - # versions, remove them - my @temp = grep m{(^|/)\Q$sver\E$}, keys %fixed_versions; - delete $fixed_versions{$_} for @temp; - $fixed_removed{$_} = 1 for @temp; - } - - # We only care about reopening the bug if the bug is - # not done - if (defined $data->{done} and length $data->{done}) { - my @svers_order = sort_versions(map {m{([^/]+)$}; $1;} - @svers); - # determine if we need to reopen - my @fixed_order = sort_versions(map {m{([^/]+)$}; $1;} - keys %fixed_versions); - if (not @fixed_order or - (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) { - $reopened = 1; - $data->{done} = ''; - } - } - } - elsif ($param{remove}) { - # in the case of removal, we only concern ourself with - # the version passed, not the source version it maps - # to - my @temp = grep m{(?:^|/)\Q$version\E$}, keys %found_versions; - delete $found_versions{$_} for @temp; - $found_removed{$_} = 1 for @temp; - } - else { - # set the keys to exactly these values - my @svers = @{$versions{$version}}; - if (not @svers) { - @svers = $version; - } - for my $sver (@svers) { - if (not exists $found_versions{$sver}) { - $found_versions{$sver} = 1; - if (exists $found_removed{$sver}) { - delete $found_removed{$sver}; - } - else { - $found_added{$sver} = 1; - } - } - } - } - } - - $data->{found_versions} = [keys %found_versions]; - $data->{fixed_versions} = [keys %fixed_versions]; - - my @changed; - push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added; - push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed; -# push @changed, 'marked as fixed in versions '.english_join([keys %fixed_addded]) if keys %fixed_added; - push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed; - $action = ucfirst(join ('; ',@changed)) if @changed; - if ($reopened) { - $action .= " and reopened" - } - if (not $reopened and not @changed) { - print {$transcript} "Ignoring request to alter found versions of bug #$data->{bug_num} to the same values previously set\n"; - next; - } - $action .= '.'; - append_action_to_log(bug => $data->{bug_num}, - get_lock => 0, - command => 'found', - old_data => $old_data, - new_data => $data, - __return_append_to_log_options( - %param, - action => $action, - ), - ) - if not exists $param{append_log} or $param{append_log}; - writebug($data->{bug_num},$data); - print {$transcript} "$action\n"; - } - __end_control(%info); -} - -=head2 set_fixed - - eval { - set_fixed(bug => $ref, - transcript => $transcript, - ($dl > 0 ? (debug => $transcript):()), - requester => $header{from}, - request_addr => $controlrequestaddr, - message => \@log, - affected_packages => \%affected_packages, - recipients => \%recipients, - fixed => [], - add => 1, - reopen => 0, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to set fixed on $ref: $@"; - } - - -Sets, adds, or removes the specified fixed versions of a package - -If the fixed versions are empty (or end up being empty after this -call) or the greatest fixed version is less than the greatest found -version and the reopen option is true, the bug is reopened. - -This function is also called by the reopen function, which causes all -of the fixed versions to be cleared. - -=cut - -sub set_fixed { - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - # specific options here - fixed => {type => SCALAR|ARRAYREF, - default => [], - }, - add => {type => BOOLEAN, - default => 0, - }, - remove => {type => BOOLEAN, - default => 0, - }, - reopen => {type => BOOLEAN, - default => 0, - }, - %common_options, - %append_action_options, - }, - ); - if ($param{add} and $param{remove}) { - croak "It's nonsensical to add and remove the same versions"; - } - my %info = - __begin_control(%param, - command => 'fixed' - ); - my ($debug,$transcript) = - @info{qw(debug transcript)}; - my @data = @{$info{data}}; - my %versions; - for my $version (make_list($param{fixed})) { - next unless defined $version; - $versions{$version} = - [make_source_versions(package => [splitpackages($data[0]{package})], - warnings => $transcript, - debug => $debug, - guess_source => 0, - versions => $version, - ) - ]; - # This is really ugly, but it's what we have to do - if (not @{$versions{$version}}) { - print {$transcript} "Unable to make a source version for version '$version'\n"; - } - } - if (not keys %versions and ($param{remove} or $param{add})) { - if ($param{remove}) { - print {$transcript} "Requested to remove no versions; doing nothing.\n"; - } - else { - print {$transcript} "Requested to add no versions; doing nothing.\n"; - } - __end_control(%info); - return; - } - # first things first, make the versions fully qualified source - # versions - for my $data (@data) { - my $old_data = dclone($data); - # The 'done' field gets a bit weird with version tracking, - # because a bug may be closed by multiple people in different - # branches. Until we have something more flexible, we set it - # every time a bug is fixed, and clear it when a bug is found - # in a version greater than any version in which the bug is - # fixed or when a bug is found and there is no fixed version - my $action = 'Did not alter fixed versions'; - my %found_added = (); - my %found_removed = (); - my %fixed_added = (); - my %fixed_removed = (); - my $reopened = 0; - if (not $param{add} and not $param{remove}) { - $fixed_removed{$_} = 1 for @{$data->{fixed_versions}}; - $data->{fixed_versions} = []; - } - my %found_versions; - @found_versions{@{$data->{found_versions}||[]}} = (1) x @{$data->{found_versions}||[]}; - my %fixed_versions; - @fixed_versions{@{$data->{fixed_versions}||[]}} = (1) x @{$data->{fixed_versions}||[]}; - for my $version (keys %versions) { - if ($param{add}) { - my @svers = @{$versions{$version}}; - if (not @svers) { - @svers = $version; - } - else { - if (exists $fixed_versions{$version}) { - $fixed_removed{$version} = 1; - delete $fixed_versions{$version}; - } - } - for my $sver (@svers) { - if (not exists $fixed_versions{$sver}) { - $fixed_versions{$sver} = 1; - $fixed_added{$sver} = 1; - } - } - } - elsif ($param{remove}) { - # in the case of removal, we only concern ourself with - # the version passed, not the source version it maps - # to - my @temp = grep m{(?:^|\/)\Q$version\E$}, keys %fixed_versions; - delete $fixed_versions{$_} for @temp; - $fixed_removed{$_} = 1 for @temp; - } - else { - # set the keys to exactly these values - my @svers = @{$versions{$version}}; - if (not @svers) { - @svers = $version; - } - for my $sver (@svers) { - if (not exists $fixed_versions{$sver}) { - $fixed_versions{$sver} = 1; - if (exists $fixed_removed{$sver}) { - delete $fixed_removed{$sver}; - } - else { - $fixed_added{$sver} = 1; - } - } - } - } - } - - $data->{found_versions} = [keys %found_versions]; - $data->{fixed_versions} = [keys %fixed_versions]; - - # If we're supposed to consider reopening, reopen if the - # fixed versions are empty or the greatest found version - # is greater than the greatest fixed version - if ($param{reopen} and defined $data->{done} - and length $data->{done}) { - my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);} - map {m{([^/]+)$}; $1;} @{$data->{found_versions}}; - # determine if we need to reopen - my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);} - map {m{([^/]+)$}; $1;} @{$data->{fixed_versions}}; - if (not @fixed_order or - (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) { - $reopened = 1; - $data->{done} = ''; - } - } - - my @changed; - push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added; - push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed; - push @changed, 'marked as fixed in versions '.english_join([keys %fixed_added]) if keys %fixed_added; - push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed; - $action = ucfirst(join ('; ',@changed)) if @changed; - if ($reopened) { - $action .= " and reopened" - } - if (not $reopened and not @changed) { - print {$transcript} "Ignoring request to alter fixed versions of bug #$data->{bug_num} to the same values previously set\n"; - next; - } - $action .= '.'; - append_action_to_log(bug => $data->{bug_num}, - command => 'fixed', - new_data => $data, - old_data => $old_data, - get_lock => 0, - __return_append_to_log_options( - %param, - action => $action, - ), - ) - if not exists $param{append_log} or $param{append_log}; - writebug($data->{bug_num},$data); - print {$transcript} "$action\n"; - } - __end_control(%info); -} - - -=head2 set_merged - - eval { - set_merged(bug => $ref, - transcript => $transcript, - ($dl > 0 ? (debug => $transcript):()), - requester => $header{from}, - request_addr => $controlrequestaddr, - message => \@log, - affected_packages => \%affected_packages, - recipients => \%recipients, - merge_with => 12345, - add => 1, - force => 1, - allow_reassign => 1, - reassign_same_source_only => 1, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to set merged on $ref: $@"; - } - - -Sets, adds, or removes the specified merged bugs of a bug - -By default, requires - -=cut - -sub set_merged { - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - # specific options here - merge_with => {type => ARRAYREF|SCALAR, - optional => 1, - }, - remove => {type => BOOLEAN, - default => 0, - }, - force => {type => BOOLEAN, - default => 0, - }, - masterbug => {type => BOOLEAN, - default => 0, - }, - allow_reassign => {type => BOOLEAN, - default => 0, - }, - reassign_different_sources => {type => BOOLEAN, - default => 1, - }, - %common_options, - %append_action_options, - }, - ); - my @merging = exists $param{merge_with} ? make_list($param{merge_with}):(); - my %merging; - @merging{@merging} = (1) x @merging; - if (grep {$_ !~ /^\d+$/} @merging) { - croak "Requested to merge with a non-numeric bug: ".join(',',map {qq('$_');} @merging); - } - $param{locks} = {} if not exists $param{locks}; - my %info = - __begin_control(%param, - command => 'merge' - ); - my ($debug,$transcript) = - @info{qw(debug transcript)}; - if (not @merging and exists $param{merge_with}) { - print {$transcript} "Requested to merge with no additional bugs; not doing anything\n"; - __end_control(%info); - return; - } - my @data = @{$info{data}}; - my %data; - my %merged_bugs; - for my $data (@data) { - $data{$data->{bug_num}} = $data; - my @merged_bugs = split / /, $data->{mergedwith}; - @merged_bugs{@merged_bugs} = (1) x @merged_bugs; - } - # handle unmerging - my $new_locks = 0; - if (not exists $param{merge_with}) { - delete $merged_bugs{$param{bug}}; - if (not keys %merged_bugs) { - print {$transcript} "Ignoring request to unmerge a bug which is not merged with any others.\n"; - __end_control(%info); - return; - } - my $action = "Disconnected #$param{bug} from all other report(s)."; - for my $data (@data) { - my $old_data = dclone($data); - if ($data->{bug_num} == $param{bug}) { - $data->{mergedwith} = ''; - } - else { - $data->{mergedwith} = - join(' ', - sort {$a <=> $b} - grep {$_ != $data->{bug_num}} - keys %merged_bugs); - } - append_action_to_log(bug => $data->{bug_num}, - command => 'merge', - new_data => $data, - old_data => $old_data, - get_lock => 0, - __return_append_to_log_options(%param, - action => $action, - ), - ) - if not exists $param{append_log} or $param{append_log}; - writebug($data->{bug_num},$data); - } - print {$transcript} "$action\n"; - __end_control(%info); - return; - } - # lock and load all of the bugs we need - my ($data,$n_locks) = - __lock_and_load_merged_bugs(bugs_to_load => [keys %merging], - data => \@data, - locks => $param{locks}, - debug => $debug, - ); - $new_locks += $n_locks; - %data = %{$data}; - @data = values %data; - if (not check_limit(data => [@data], - exists $param{limit}?(limit => $param{limit}):(), - transcript => $transcript, - )) { - die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data); - } - for my $data (@data) { - $data{$data->{bug_num}} = $data; - $merged_bugs{$data->{bug_num}} = 1; - my @merged_bugs = split / /, $data->{mergedwith}; - @merged_bugs{@merged_bugs} = (1) x @merged_bugs; - if (exists $param{affected_bugs}) { - $param{affected_bugs}{$data->{bug_num}} = 1; - } - } - __handle_affected_packages(%param,data => [@data]); - my %bug_info_shown; # which bugs have had information shown - $bug_info_shown{$param{bug}} = 1; - add_recipients(data => [@data], - recipients => $param{recipients}, - (exists $param{command}?(actions_taken => {$param{command} => 1}):()), - debug => $debug, - (__internal_request()?(transcript => $transcript):()), - ); - - # Figure out what the ideal state is for the bug, - my ($merge_status,$bugs_to_merge) = - __calculate_merge_status(\@data,\%data,$param{bug}); - # find out if we actually have any bugs to merge - if (not $bugs_to_merge) { - print {$transcript} "Requested to merge with no additional bugs; not doing anything\n"; - for (1..$new_locks) { - unfilelock($param{locks}); - $locks--; - } - __end_control(%info); - return; - } - # see what changes need to be made to merge the bugs - # check to make sure that the set of changes we need to make is allowed - my ($disallowed_changes,$changes) = - __calculate_merge_changes(\@data,$merge_status,\%param); - # at this point, stop if there are disallowed changes, otherwise - # make the allowed changes, and then reread the bugs in question - # to get the new data, then recaculate the merges; repeat - # reloading and recalculating until we try too many times or there - # are no changes to make. - - my $attempts = 0; - # we will allow at most 4 times through this; more than 1 - # shouldn't really happen. - my %bug_changed; - while ($attempts < 4 and (@{$disallowed_changes} or keys %{$changes})) { - if ($attempts > 1) { - print {$transcript} "Unable to complete merge on previous attempt; trying again (retry: $attempts)\n"; - } - if (@{$disallowed_changes}) { - # figure out the problems - print {$transcript} "Unable to merge bugs because:\n"; - for my $change (@{$disallowed_changes}) { - print {$transcript} "$change->{field} of #$change->{bug} is '$change->{text_orig_value}' not '$change->{text_value}'\n"; - } - if ($attempts > 0) { - __end_control(%info); - croak "Some bugs were altered while attempting to merge"; - } - else { - __end_control(%info); - croak "Did not alter merged bugs"; - } - } - my @bugs_to_change = keys %{$changes}; - for my $change_bug (@bugs_to_change) { - next unless exists $changes->{$change_bug}; - $bug_changed{$change_bug}++; - print {$transcript} __bug_info($data{$change_bug}) if - $param{show_bug_info} and not __internal_request(1); - $bug_info_shown{$change_bug} = 1; - __allow_relocking($param{locks},[keys %data]); - eval { - for my $change (@{$changes->{$change_bug}}) { - if ($change->{field} eq 'blockedby' or $change->{field} eq 'blocks') { - my %target_blockedby; - @target_blockedby{@{$change->{func_value}}} = (1) x @{$change->{func_value}}; - my %unhandled_targets = %target_blockedby; - for my $key (split / /,$change->{orig_value}) { - delete $unhandled_targets{$key}; - next if exists $target_blockedby{$key}; - set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug}, - block => $change->{field} eq 'blocks' ? $change->{bug} : $key, - remove => 1, - hash_slice(%param, - keys %common_options, - keys %append_action_options), - ); - } - for my $key (keys %unhandled_targets) { - set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug}, - block => $change->{field} eq 'blocks' ? $change->{bug} : $key, - add => 1, - hash_slice(%param, - keys %common_options, - keys %append_action_options), - ); - } - } - else { - $change->{function}->(bug => $change->{bug}, - $change->{key}, $change->{func_value}, - exists $change->{options}?@{$change->{options}}:(), - hash_slice(%param, - keys %common_options, - keys %append_action_options), - ); - } - } - }; - if ($@) { - __disallow_relocking($param{locks}); - __end_control(%info); - croak "Failure while trying to adjust bugs, please report this as a bug: $@"; - } - __disallow_relocking($param{locks}); - my ($data,$n_locks) = - __lock_and_load_merged_bugs(bugs_to_load => [keys %merging], - data => \@data, - locks => $param{locks}, - debug => $debug, - reload_all => 1, - ); - $new_locks += $n_locks; - $locks += $n_locks; - %data = %{$data}; - @data = values %data; - ($merge_status,$bugs_to_merge) = - __calculate_merge_status(\@data,\%data,$param{bug},$merge_status); - ($disallowed_changes,$changes) = - __calculate_merge_changes(\@data,$merge_status,\%param); - $attempts = max(values %bug_changed); - } - } - if ($param{show_bug_info} and not __internal_request(1)) { - for my $data (sort {$a->{bug_num} <=> $b->{bug_num}} @data) { - next if $bug_info_shown{$data->{bug_num}}; - print {$transcript} __bug_info($data); - } - } - if (keys %{$changes} or @{$disallowed_changes}) { - print {$transcript} "After four attempts, the following changes were unable to be made:\n"; - for (1..$new_locks) { - unfilelock($param{locks}); - $locks--; - } - __end_control(%info); - for my $change ((map {@{$_}} values %{$changes}), @{$disallowed_changes}) { - print {$transcript} "$change->{field} of #$change->{bug} is '$change->{text_orig_value}' not '$change->{text_value}'\n"; - } - die "Unable to modify bugs so they could be merged"; - return; - } - - # finally, we can merge the bugs - my $action = "Merged ".join(' ',sort { $a <=> $b } keys %merged_bugs); - for my $data (@data) { - my $old_data = dclone($data); - $data->{mergedwith} = - join(' ', - sort { $a <=> $b } - grep {$_ != $data->{bug_num}} - keys %merged_bugs); - append_action_to_log(bug => $data->{bug_num}, - command => 'merge', - new_data => $data, - old_data => $old_data, - get_lock => 0, - __return_append_to_log_options(%param, - action => $action, - ), - ) - if not exists $param{append_log} or $param{append_log}; - writebug($data->{bug_num},$data); - } - print {$transcript} "$action\n"; - # unlock the extra locks that we got earlier - for (1..$new_locks) { - unfilelock($param{locks}); - $locks--; - } - __end_control(%info); -} - -sub __allow_relocking{ - my ($locks,$bugs) = @_; - - my @locks = (@{$bugs},'merge'); - for my $lock (@locks) { - my @lockfiles = grep {m{/\Q$lock\E$}} keys %{$locks->{locks}}; - next unless @lockfiles; - $locks->{relockable}{$lockfiles[0]} = 0; - } -} - -sub __disallow_relocking{ - my ($locks) = @_; - delete $locks->{relockable}; -} - -sub __lock_and_load_merged_bugs{ - my %param = - validate_with(params => \@_, - spec => - {bugs_to_load => {type => ARRAYREF, - default => sub {[]}, - }, - data => {type => HASHREF|ARRAYREF, - }, - locks => {type => HASHREF, - default => sub {{};}, - }, - reload_all => {type => BOOLEAN, - default => 0, - }, - debug => {type => HANDLE, - }, - }, - ); - my %data; - my $new_locks = 0; - if (ref($param{data}) eq 'ARRAY') { - for my $data (@{$param{data}}) { - $data{$data->{bug_num}} = dclone($data); - } - } - else { - %data = %{dclone($param{data})}; - } - my @bugs_to_load = @{$param{bugs_to_load}}; - if ($param{reload_all}) { - push @bugs_to_load, keys %data; - } - my %temp; - @temp{@bugs_to_load} = (1) x @bugs_to_load; - @bugs_to_load = keys %temp; - my %loaded_this_time; - my $bug_to_load; - while ($bug_to_load = shift @bugs_to_load) { - if (not $param{reload_all}) { - next if exists $data{$bug_to_load}; - } - else { - next if $loaded_this_time{$bug_to_load}; - } - my $lock_bug = 1; - if ($param{reload_all}) { - if (exists $data{$bug_to_load}) { - $lock_bug = 0; - } - } - my $data = - read_bug(bug => $bug_to_load, - lock => $lock_bug, - locks => $param{locks}, - ) or - die "Unable to load bug $bug_to_load"; - print {$param{debug}} "read bug $bug_to_load\n"; - $data{$data->{bug_num}} = $data; - $new_locks += $lock_bug; - $loaded_this_time{$data->{bug_num}} = 1; - push @bugs_to_load, - grep {not exists $data{$_}} - split / /,$data->{mergedwith}; - } - return (\%data,$new_locks); -} - - -sub __calculate_merge_status{ - my ($data_a,$data_h,$master_bug,$merge_status) = @_; - my %merge_status = %{$merge_status // {}}; - my %merged_bugs; - my $bugs_to_merge = 0; - for my $data (@{$data_a}) { - # check to see if this bug is unmerged in the set - if (not length $data->{mergedwith} or - grep {not exists $merged_bugs{$_}} split / /,$data->{mergedwith}) { - $merged_bugs{$data->{bug_num}} = 1; - $bugs_to_merge = 1; - } - } - for my $data (@{$data_a}) { - # the master_bug is the bug that every other bug is made to - # look like. However, if merge is set, tags, fixed and found - # are merged. - if ($data->{bug_num} == $master_bug) { - for (qw(package forwarded severity done owner summary outlook affects)) { - $merge_status{$_} = $data->{$_} - } - # bugs which are in the newly merged set and are also - # blocks/blockedby must be removed before merging - for (qw(blocks blockedby)) { - $merge_status{$_} = - join(' ',grep {not exists $merged_bugs{$_}} - split / /,$data->{$_}); - } - } - if (defined $merge_status) { - next unless $data->{bug_num} == $master_bug; - } - $merge_status{tag} = {} if not exists $merge_status{tag}; - for my $tag (split /\s+/, $data->{keywords}) { - $merge_status{tag}{$tag} = 1; - } - $merge_status{keywords} = join(' ',sort keys %{$merge_status{tag}}); - for (qw(fixed found)) { - @{$merge_status{"${_}_versions"}}{@{$data->{"${_}_versions"}}} = (1) x @{$data->{"${_}_versions"}}; - } - } - # if there is a non-source qualified version with a corresponding - # source qualified version, we only want to merge the source - # qualified version(s) - for (qw(fixed found)) { - my @unqualified_versions = grep {m{/}?0:1} keys %{$merge_status{"${_}_versions"}}; - for my $unqualified_version (@unqualified_versions) { - if (grep {m{/\Q$unqualified_version\E}} keys %{$merge_status{"${_}_versions"}}) { - delete $merge_status{"${_}_versions"}{$unqualified_version}; - } - } - } - return (\%merge_status,$bugs_to_merge); -} - - - -sub __calculate_merge_changes{ - my ($datas,$merge_status,$param) = @_; - my %changes; - my @disallowed_changes; - for my $data (@{$datas}) { - # things that can be forced - # - # * func is the function to set the new value - # - # * key is the key of the function to set the value, - - # * modify_value is a function which is called to modify the new - # value so that the function will accept it - - # * options is an ARRAYREF of options to pass to the function - - # * allowed is a BOOLEAN which controls whether this setting - # is allowed to be different by default. - my %force_functions = - (forwarded => {func => \&set_forwarded, - key => 'forwarded', - options => [], - }, - severity => {func => \&set_severity, - key => 'severity', - options => [], - }, - blocks => {func => \&set_blocks, - modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]}, - key => 'block', - options => [], - }, - blockedby => {func => \&set_blocks, - modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]}, - key => 'block', - options => [], - }, - done => {func => \&set_done, - key => 'done', - options => [], - }, - owner => {func => \&owner, - key => 'owner', - options => [], - }, - summary => {func => \&summary, - key => 'summary', - options => [], - }, - outlook => {func => \&outlook, - key => 'outlook', - options => [], - }, - affects => {func => \&affects, - key => 'package', - options => [], - }, - package => {func => \&set_package, - key => 'package', - options => [], - }, - keywords => {func => \&set_tag, - key => 'tag', - modify_value => sub {defined $_[0]?[sort split /\s+/,$_[0]]:[]}, - allowed => 1, - }, - fixed_versions => {func => \&set_fixed, - key => 'fixed', - modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]}, - allowed => 1, - }, - found_versions => {func => \&set_found, - key => 'found', - modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]}, - allowed => 1, - }, - ); - for my $field (qw(forwarded severity blocks blockedby done owner summary outlook affects package fixed_versions found_versions keywords)) { - # if the ideal bug already has the field set properly, we - # continue on. - if ($field eq 'keywords'){ - next if join(' ',sort split /\s+/,$data->{keywords}) eq - join(' ',sort keys %{$merge_status->{tag}}); - } - elsif ($field =~ /^(?:fixed|found)_versions$/) { - next if join(' ', sort @{$data->{$field}}) eq - join(' ',sort keys %{$merge_status->{$field}}); - } - elsif ($field eq 'done') { - # for done, we only care if the bug is done or not - # done, not the value it's set to. - if (defined $merge_status->{$field} and length $merge_status->{$field} and - defined $data->{$field} and length $data->{$field}) { - next; - } - elsif ((not defined $merge_status->{$field} or not length $merge_status->{$field}) and - (not defined $data->{$field} or not length $data->{$field}) - ) { - next; - } - } - elsif ($merge_status->{$field} eq $data->{$field}) { - next; - } - my $change = - {field => $field, - bug => $data->{bug_num}, - orig_value => $data->{$field}, - func_value => - (exists $force_functions{$field}{modify_value} ? - $force_functions{$field}{modify_value}->($merge_status->{$field}): - $merge_status->{$field}), - value => $merge_status->{$field}, - function => $force_functions{$field}{func}, - key => $force_functions{$field}{key}, - options => $force_functions{$field}{options}, - allowed => exists $force_functions{$field}{allowed} ? $force_functions{$field}{allowed} : 0, - }; - $change->{text_value} = ref($change->{func_value}) eq 'ARRAY'?join(' ',@{$change->{func_value}}):$change->{func_value}; - $change->{text_orig_value} = ref($change->{orig_value}) eq 'ARRAY'?join(' ',@{$change->{orig_value}}):$change->{orig_value}; - if ($param->{force} or $change->{allowed}) { - if ($field ne 'package' or $change->{allowed}) { - push @{$changes{$data->{bug_num}}},$change; - next; - } - if ($param->{allow_reassign}) { - if ($param->{reassign_different_sources}) { - push @{$changes{$data->{bug_num}}},$change; - next; - } - # allow reassigning if binary_to_source returns at - # least one of the same source packages - my @merge_status_source = - binary_to_source(package => $merge_status->{package}, - source_only => 1, - ); - my @other_bug_source = - binary_to_source(package => $data->{package}, - source_only => 1, - ); - my %merge_status_sources; - @merge_status_sources{@merge_status_source} = - (1) x @merge_status_source; - if (grep {$merge_status_sources{$_}} @other_bug_source) { - push @{$changes{$data->{bug_num}}},$change; - next; - } - } - } - push @disallowed_changes,$change; - } - # blocks and blocked by are weird; we have to go through and - # set blocks to the other half of the merged bugs - } - return (\@disallowed_changes,\%changes); -} - -=head2 affects - - eval { - affects(bug => $ref, - transcript => $transcript, - ($dl > 0 ? (debug => $transcript):()), - requester => $header{from}, - request_addr => $controlrequestaddr, - message => \@log, - affected_packages => \%affected_packages, - recipients => \%recipients, - packages => undef, - add => 1, - remove => 0, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to mark $ref as affecting $packages: $@"; - } - -This marks a bug as affecting packages which the bug is not actually -in. This should only be used in cases where fixing the bug instantly -resolves the problem in the other packages. - -By default, the packages are set to the list of packages passed. -However, if you pass add => 1 or remove => 1, the list of packages -passed are added or removed from the affects list, respectively. - -=cut - -sub affects { - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - # specific options here - package => {type => SCALAR|ARRAYREF|UNDEF, - default => [], - }, - add => {type => BOOLEAN, - default => 0, - }, - remove => {type => BOOLEAN, - default => 0, - }, - %common_options, - %append_action_options, - }, - ); - if ($param{add} and $param{remove}) { - croak "Asking to both add and remove affects is nonsensical"; - } - if (not defined $param{package}) { - $param{package} = []; - } - my %info = - __begin_control(%param, - command => 'affects' - ); - my ($debug,$transcript) = - @info{qw(debug transcript)}; - my @data = @{$info{data}}; - my $action = ''; - for my $data (@data) { - $action = ''; - print {$debug} "Going to change affects\n"; - my @packages = splitpackages($data->{affects}); - my %packages; - @packages{@packages} = (1) x @packages; - if ($param{add}) { - my @added = (); - for my $package (make_list($param{package})) { - next unless defined $package and length $package; - if (not $packages{$package}) { - $packages{$package} = 1; - push @added,$package; - } - } - if (@added) { - $action = "Added indication that $data->{bug_num} affects ". - english_join(\@added); - } - } - elsif ($param{remove}) { - my @removed = (); - for my $package (make_list($param{package})) { - if ($packages{$package}) { - next unless defined $package and length $package; - delete $packages{$package}; - push @removed,$package; - } - } - $action = "Removed indication that $data->{bug_num} affects " . - english_join(\@removed); - } - else { - my %added_packages = (); - my %removed_packages = %packages; - %packages = (); - for my $package (make_list($param{package})) { - next unless defined $package and length $package; - $packages{$package} = 1; - delete $removed_packages{$package}; - $added_packages{$package} = 1; - } - if (keys %removed_packages) { - $action = "Removed indication that $data->{bug_num} affects ". - english_join([keys %removed_packages]); - $action .= "\n" if keys %added_packages; - } - if (keys %added_packages) { - $action .= "Added indication that $data->{bug_num} affects " . - english_join([keys %added_packages]); - } - } - if (not length $action) { - print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n"; - next; - } - my $old_data = dclone($data); - $data->{affects} = join(',',keys %packages); - append_action_to_log(bug => $data->{bug_num}, - get_lock => 0, - command => 'affects', - new_data => $data, - old_data => $old_data, - __return_append_to_log_options( - %param, - action => $action, - ), - ) - if not exists $param{append_log} or $param{append_log}; - writebug($data->{bug_num},$data); - print {$transcript} "$action\n"; - } - __end_control(%info); -} - - -=head1 SUMMARY FUNCTIONS - -=head2 summary - - eval { - summary(bug => $ref, - transcript => $transcript, - ($dl > 0 ? (debug => $transcript):()), - requester => $header{from}, - request_addr => $controlrequestaddr, - message => \@log, - affected_packages => \%affected_packages, - recipients => \%recipients, - summary => undef, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to mark $ref with summary foo: $@"; - } - -Handles all setting of summary fields - -If summary is undef, unsets the summary - -If summary is 0 or -1, sets the summary to the first paragraph contained in -the message passed. - -If summary is a positive integer, sets the summary to the message specified. - -Otherwise, sets summary to the value passed. - -=cut - - -sub summary { - # outlook and summary are exactly the same, basically - return _summary('summary',@_); -} - -=head1 OUTLOOK FUNCTIONS - -=head2 outlook - - eval { - outlook(bug => $ref, - transcript => $transcript, - ($dl > 0 ? (debug => $transcript):()), - requester => $header{from}, - request_addr => $controlrequestaddr, - message => \@log, - affected_packages => \%affected_packages, - recipients => \%recipients, - outlook => undef, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to mark $ref with outlook foo: $@"; - } - -Handles all setting of outlook fields - -If outlook is undef, unsets the outlook - -If outlook is 0, sets the outlook to the first paragraph contained in -the message passed. - -If outlook is a positive integer, sets the outlook to the message specified. - -Otherwise, sets outlook to the value passed. - -=cut - - -sub outlook { - return _summary('outlook',@_); -} - -sub _summary { - my ($cmd,@params) = @_; - my %param = validate_with(params => \@params, - spec => {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - # specific options here - $cmd , {type => SCALAR|UNDEF, - default => 0, - }, - %common_options, - %append_action_options, - }, - ); - my %info = - __begin_control(%param, - command => $cmd, - ); - my ($debug,$transcript) = - @info{qw(debug transcript)}; - my @data = @{$info{data}}; - # figure out the log that we're going to use - my $summary = ''; - my $summary_msg = ''; - my $action = ''; - if (not defined $param{$cmd}) { - # do nothing - print {$debug} "Removing $cmd fields\n"; - $action = "Removed $cmd"; - } - elsif ($param{$cmd} =~ /^-?\d+$/) { - my $log = []; - my @records = Debbugs::Log::read_log_records(bug_num => $param{bug}); - if ($param{$cmd} == 0 or $param{$cmd} == -1) { - $log = $param{message}; - $summary_msg = @records + 1; - } - else { - if (($param{$cmd} - 1 ) > $#records) { - die "Message number '$param{$cmd}' exceeds the maximum message '$#records'"; - } - my $record = $records[($param{$cmd} - 1 )]; - if ($record->{type} !~ /incoming-recv|recips/) { - die "Message number '$param{$cmd}' is a invalid message type '$record->{type}'"; - } - $summary_msg = $param{$cmd}; - $log = [$record->{text}]; - } - my $p_o = Debbugs::MIME::parse(join('',@{$log})); - my $body = $p_o->{body}; - my $in_pseudoheaders = 0; - my $paragraph = ''; - # walk through body until we get non-blank lines - for my $line (@{$body}) { - if ($line =~ /^\s*$/) { - if (length $paragraph) { - if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) { - $paragraph = ''; - next; - } - last; - } - $in_pseudoheaders = 0; - next; - } - # skip a paragraph if it looks like it's control or - # pseudo-headers - if ($line =~ m{^\s*(?:Package|Source|Version|User|Tag|Severity|Control)\:\s+\S}xi or #pseudo headers - $line =~ m{^(?:package:?|(?:no|)owner|severity|tags?|summary| #control - \#|reopen|close|(?:not|)(?:fixed|found)|clone| - debug|(?:not|)forwarded|priority| - (?:un|)block|limit|(?:un|)archive| - reassign|retitle|affects|package| - outlook| - (?:un|force|)merge|user(?:category|tags?|) - )\s+\S}xis) { - if (not length $paragraph) { - print {$debug} "Found control/pseudo-headers and skiping them\n"; - $in_pseudoheaders = 1; - next; - } - } - next if $in_pseudoheaders; - $paragraph .= $line ." \n"; - } - print {$debug} ucfirst($cmd)." is going to be '$paragraph'\n"; - $summary = $paragraph; - $summary =~ s/[\n\r]/ /g; - if (not length $summary) { - die "Unable to find $cmd message to use"; - } - # trim off a trailing spaces - $summary =~ s/\ *$//; - } - else { - $summary = $param{$cmd}; - } - for my $data (@data) { - print {$debug} "Going to change $cmd\n"; - if (((not defined $summary or not length $summary) and - (not defined $data->{$cmd} or not length $data->{$cmd})) or - $summary eq $data->{$cmd}) { - print {$transcript} "Ignoring request to change the $cmd of bug $param{bug} to the same value\n"; - next; - } - if (length $summary) { - if (length $data->{$cmd}) { - $action = ucfirst($cmd)." replaced with message bug $param{bug} message $summary_msg"; - } - else { - $action = ucfirst($cmd)." recorded from message bug $param{bug} message $summary_msg"; - } - } - my $old_data = dclone($data); - $data->{$cmd} = $summary; - append_action_to_log(bug => $data->{bug_num}, - command => $cmd, - old_data => $old_data, - new_data => $data, - get_lock => 0, - __return_append_to_log_options( - %param, - action => $action, - ), - ) - if not exists $param{append_log} or $param{append_log}; - writebug($data->{bug_num},$data); - print {$transcript} "$action\n"; - } - __end_control(%info); -} - - - -=head2 clone_bug - - eval { - clone_bug(bug => $ref, - transcript => $transcript, - ($dl > 0 ? (debug => $transcript):()), - requester => $header{from}, - request_addr => $controlrequestaddr, - message => \@log, - affected_packages => \%affected_packages, - recipients => \%recipients, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to clone bug $ref bar: $@"; - } - -Clones the given bug. - -We currently don't support cloning merged bugs, but this could be -handled by internally unmerging, cloning, then remerging the bugs. - -=cut - -sub clone_bug { - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - new_bugs => {type => ARRAYREF, - }, - new_clones => {type => HASHREF, - default => {}, - }, - %common_options, - %append_action_options, - }, - ); - my %info = - __begin_control(%param, - command => 'clone' - ); - my $transcript = $info{transcript}; - my @data = @{$info{data}}; - - my $action = ''; - for my $data (@data) { - if (length($data->{mergedwith})) { - die "Bug is marked as being merged with others. Use an existing clone.\n"; - } - } - if (@data != 1) { - die "Not exactly one bug‽ This shouldn't happen."; - } - my $data = $data[0]; - my %clones; - for my $newclone_id (@{$param{new_bugs}}) { - my $new_bug_num = new_bug(copy => $data->{bug_num}); - $param{new_clones}{$newclone_id} = $new_bug_num; - $clones{$newclone_id} = $new_bug_num; - } - my @new_bugs = sort values %clones; - my @collapsed_ids; - for my $new_bug (@new_bugs) { - # no collapsed ids or the higher collapsed id is not one less - # than the next highest new bug - if (not @collapsed_ids or - $collapsed_ids[-1][1]+1 != $new_bug) { - push @collapsed_ids,[$new_bug,$new_bug]; - } - else { - $collapsed_ids[-1][1] = $new_bug; - } - } - my @collapsed; - for my $ci (@collapsed_ids) { - if ($ci->[0] == $ci->[1]) { - push @collapsed,$ci->[0]; - } - else { - push @collapsed,$ci->[0].'-'.$ci->[1] - } - } - my $collapsed_str = english_join(\@collapsed); - $action = "Bug $data->{bug_num} cloned as bug".(@new_bugs > 1?'s':'').' '.$collapsed_str; - for my $new_bug (@new_bugs) { - append_action_to_log(bug => $new_bug, - get_lock => 1, - __return_append_to_log_options( - %param, - action => $action, - ), - ) - if not exists $param{append_log} or $param{append_log}; - } - append_action_to_log(bug => $data->{bug_num}, - get_lock => 0, - __return_append_to_log_options( - %param, - action => $action, - ), - ) - if not exists $param{append_log} or $param{append_log}; - writebug($data->{bug_num},$data); - print {$transcript} "$action\n"; - __end_control(%info); - # bugs that this bug is blocking are also blocked by the new clone(s) - for my $bug (split ' ', $data->{blocks}) { - for my $new_bug (@new_bugs) { - set_blocks(bug => $bug, - block => $new_bug, - add => 1, - hash_slice(%param, - keys %common_options, - keys %append_action_options), - ); - } - } - # bugs that are blocking this bug are also blocking the new clone(s) - for my $bug (split ' ', $data->{blockedby}) { - for my $new_bug (@new_bugs) { - set_blocks(bug => $new_bug, - block => $bug, - add => 1, - hash_slice(%param, - keys %common_options, - keys %append_action_options), - ); - } - } -} - - - -=head1 OWNER FUNCTIONS - -=head2 owner - - eval { - owner(bug => $ref, - transcript => $transcript, - ($dl > 0 ? (debug => $transcript):()), - requester => $header{from}, - request_addr => $controlrequestaddr, - message => \@log, - recipients => \%recipients, - owner => undef, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to mark $ref as having an owner: $@"; - } - -Handles all setting of the owner field; given an owner of undef or of -no length, indicates that a bug is not owned by anyone. - -=cut - -sub owner { - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - owner => {type => SCALAR|UNDEF, - }, - %common_options, - %append_action_options, - }, - ); - my %info = - __begin_control(%param, - command => 'owner', - ); - my ($debug,$transcript) = - @info{qw(debug transcript)}; - my @data = @{$info{data}}; - my $action = ''; - for my $data (@data) { - print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n"; - print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n"; - if (not defined $param{owner} or not length $param{owner}) { - if (not defined $data->{owner} or not length $data->{owner}) { - print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n"; - next; - } - $param{owner} = ''; - $action = "Removed annotation that $config{bug} was owned by " . - "$data->{owner}."; - } - else { - if ($data->{owner} eq $param{owner}) { - print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n"; - next; - } - if (length $data->{owner}) { - $action = "Owner changed from $data->{owner} to $param{owner}."; - } - else { - $action = "Owner recorded as $param{owner}." - } - } - my $old_data = dclone($data); - $data->{owner} = $param{owner}; - append_action_to_log(bug => $data->{bug_num}, - command => 'owner', - new_data => $data, - old_data => $old_data, - get_lock => 0, - __return_append_to_log_options( - %param, - action => $action, - ), - ) - if not exists $param{append_log} or $param{append_log}; - writebug($data->{bug_num},$data); - print {$transcript} "$action\n"; - } - __end_control(%info); -} - - -=head1 ARCHIVE FUNCTIONS - - -=head2 bug_archive - - my $error = ''; - eval { - bug_archive(bug => $bug_num, - debug => \$debug, - transcript => \$transcript, - ); - }; - if ($@) { - $errors++; - transcript("Unable to archive $bug_num\n"); - warn $@; - } - transcript($transcript); - - -This routine archives a bug - -=over - -=item bug -- bug number - -=item check_archiveable -- check wether a bug is archiveable before -archiving; defaults to 1 - -=item archive_unarchived -- whether to archive bugs which have not -previously been archived; defaults to 1. [Set to 0 when used from -control@] - -=item ignore_time -- whether to ignore time constraints when archiving -a bug; defaults to 0. - -=back - -=cut - -sub bug_archive { - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - check_archiveable => {type => BOOLEAN, - default => 1, - }, - archive_unarchived => {type => BOOLEAN, - default => 1, - }, - ignore_time => {type => BOOLEAN, - default => 0, - }, - %common_options, - %append_action_options, - }, - ); - my %info = __begin_control(%param, - command => 'archive', - ); - my ($debug,$transcript) = @info{qw(debug transcript)}; - my @data = @{$info{data}}; - my @bugs = @{$info{bugs}}; - my $action = "$config{bug} archived."; - if ($param{check_archiveable} and - not bug_archiveable(bug=>$param{bug}, - ignore_time => $param{ignore_time}, - )) { - print {$transcript} "Bug $param{bug} cannot be archived\n"; - die "Bug $param{bug} cannot be archived"; - } - if (not $param{archive_unarchived} and - not exists $data[0]{unarchived} - ) { - print {$transcript} "$param{bug} has not been archived previously\n"; - die "$param{bug} has not been archived previously"; - } - add_recipients(recipients => $param{recipients}, - data => \@data, - debug => $debug, - transcript => $transcript, - ); - print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n"; - for my $bug (@bugs) { - if ($param{check_archiveable}) { - die "Bug $bug cannot be archived (but $param{bug} can?)" - unless bug_archiveable(bug=>$bug, - ignore_time => $param{ignore_time}, - ); - } - } - # If we get here, we can archive/remove this bug - print {$debug} "$param{bug} removing\n"; - for my $bug (@bugs) { - #print "$param{bug} removing $bug\n" if $debug; - my $dir = get_hashname($bug); - # First indicate that this bug is being archived - append_action_to_log(bug => $bug, - get_lock => 0, - command => 'archive', - # we didn't actually change the data - # when we archived, so we don't pass - # a real new_data or old_data - new_data => {}, - old_data => {}, - __return_append_to_log_options( - %param, - action => $action, - ) - ) - if not exists $param{append_log} or $param{append_log}; - my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*"); - if ($config{save_old_bugs}) { - mkpath("$config{spool_dir}/archive/$dir"); - foreach my $file (@files_to_remove) { - link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or - copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or - # we need to bail out here if things have - # gone horribly wrong to avoid removing a - # bug altogether - die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!"; - } - - print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n"; - } - unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove); - print {$debug} "deleted $bug (from $param{bug})\n"; - } - bughook_archive(@bugs); - __end_control(%info); -} - -=head2 bug_unarchive - - my $error = ''; - eval { - bug_unarchive(bug => $bug_num, - debug => \$debug, - transcript => \$transcript, - ); - }; - if ($@) { - $errors++; - transcript("Unable to archive bug: $bug_num"); - } - transcript($transcript); - -This routine unarchives a bug - -=cut - -sub bug_unarchive { - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+/, - }, - %common_options, - %append_action_options, - }, - ); - - my %info = __begin_control(%param, - archived=>1, - command=>'unarchive'); - my ($debug,$transcript) = - @info{qw(debug transcript)}; - my @bugs = @{$info{bugs}}; - my $action = "$config{bug} unarchived."; - my @files_to_remove; - ## error out if we're unarchiving unarchived bugs - for my $data (@{$info{data}}) { - if (not defined $data->{archived} or - not $data->{archived} - ) { - __end_control(%info); - croak("Bug $data->{bug_num} was not archived; not unarchiving it."); - } - } - for my $bug (@bugs) { - print {$debug} "$param{bug} removing $bug\n"; - my $dir = get_hashname($bug); - my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*"); - mkpath("archive/$dir"); - foreach my $file (@files_to_copy) { - # die'ing here sucks - link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or - copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or - die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file"; - } - push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy; - print {$transcript} "Unarchived $config{bug} $bug\n"; - } - unlink(@files_to_remove) or die "Unable to unlink bugs"; - # Indicate that this bug has been archived previously - for my $bug (@bugs) { - my $newdata = readbug($bug); - my $old_data = dclone($newdata); - if (not defined $newdata) { - print {$transcript} "$config{bug} $bug disappeared!\n"; - die "Bug $bug disappeared!"; - } - $newdata->{unarchived} = time; - append_action_to_log(bug => $bug, - get_lock => 0, - command => 'unarchive', - new_data => $newdata, - old_data => $old_data, - __return_append_to_log_options( - %param, - action => $action, - ) - ) - if not exists $param{append_log} or $param{append_log}; - writebug($bug,$newdata); - } - __end_control(%info); -} - -=head2 append_action_to_log - - append_action_to_log - -This should probably be moved to Debbugs::Log; have to think that out -some more. - -=cut - -sub append_action_to_log{ - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+/, - }, - new_data => {type => HASHREF, - optional => 1, - }, - old_data => {type => HASHREF, - optional => 1, - }, - command => {type => SCALAR, - optional => 1, - }, - action => {type => SCALAR, - }, - requester => {type => SCALAR, - default => '', - }, - request_addr => {type => SCALAR, - default => '', - }, - location => {type => SCALAR, - optional => 1, - }, - message => {type => SCALAR|ARRAYREF, - default => '', - }, - recips => {type => SCALAR|ARRAYREF, - optional => 1 - }, - desc => {type => SCALAR, - default => '', - }, - get_lock => {type => BOOLEAN, - default => 1, - }, - locks => {type => HASHREF, - optional => 1, - }, - # we don't use - # append_action_options here - # because some of these - # options aren't actually - # optional, even though the - # original function doesn't - # require them - }, - ); - # Fix this to use $param{location} - my $log_location = buglog($param{bug}); - die "Unable to find .log for $param{bug}" - if not defined $log_location; - if ($param{get_lock}) { - filelock("lock/$param{bug}",exists $param{locks}?$param{locks}:()); - $locks++; - } - my @records; - my $logfh = IO::File->new(">>$log_location") or - die "Unable to open $log_location for appending: $!"; - # determine difference between old and new - my $data_diff = ''; - if (exists $param{old_data} and exists $param{new_data}) { - my $old_data = dclone($param{old_data}); - my $new_data = dclone($param{new_data}); - for my $key (keys %{$old_data}) { - if (not exists $Debbugs::Status::fields{$key}) { - delete $old_data->{$key}; - next; - } - next unless exists $new_data->{$key}; - next unless defined $new_data->{$key}; - if (not defined $old_data->{$key}) { - delete $old_data->{$key}; - next; - } - if (ref($new_data->{$key}) and - ref($old_data->{$key}) and - ref($new_data->{$key}) eq ref($old_data->{$key})) { - local $Storable::canonical = 1; - if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) { - delete $new_data->{$key}; - delete $old_data->{$key}; - } - } - elsif ($new_data->{$key} eq $old_data->{$key}) { - delete $new_data->{$key}; - delete $old_data->{$key}; - } - } - for my $key (keys %{$new_data}) { - if (not exists $Debbugs::Status::fields{$key}) { - delete $new_data->{$key}; - next; - } - next unless exists $old_data->{$key}; - next unless defined $old_data->{$key}; - if (not defined $new_data->{$key} or - not exists $Debbugs::Status::fields{$key}) { - delete $new_data->{$key}; - next; - } - if (ref($new_data->{$key}) and - ref($old_data->{$key}) and - ref($new_data->{$key}) eq ref($old_data->{$key})) { - local $Storable::canonical = 1; - if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) { - delete $new_data->{$key}; - delete $old_data->{$key}; - } - } - elsif ($new_data->{$key} eq $old_data->{$key}) { - delete $new_data->{$key}; - delete $old_data->{$key}; - } - } - $data_diff .= "\n"; - $data_diff .= "\n"; - } - my $msg = join('', - (exists $param{command} ? - "\n":"" - ), - (length $param{requester} ? - "\n":"" - ), - (length $param{request_addr} ? - "\n":"" - ), - "\n", - $data_diff, - "".html_escape(encode_utf8_safely($param{action}))."\n"); - if (length $param{requester}) { - $msg .= "Request was from ".html_escape(encode_utf8_safely($param{requester}))."\n"; - } - if (length $param{request_addr}) { - $msg .= "to ".html_escape(encode_utf8_safely($param{request_addr})).""; - } - if (length $param{desc}) { - $msg .= ":
    \n".encode_utf8_safely($param{desc})."\n"; - } - else { - $msg .= ".\n"; - } - push @records, {type => 'html', - text => $msg, - }; - $msg = ''; - if ((ref($param{message}) and @{$param{message}}) or length($param{message})) { - push @records, {type => exists $param{recips}?'recips':'incoming-recv', - exists $param{recips}?(recips => [map {encode_utf8_safely($_)} make_list($param{recips})]):(), - text => join('',make_list($param{message})), - }; - } - write_log_records(logfh=>$logfh, - records => \@records, - ); - close $logfh or die "Unable to close $log_location: $!"; - if ($param{get_lock}) { - unfilelock(exists $param{locks}?$param{locks}:()); - $locks--; - } - - -} - - -=head1 PRIVATE FUNCTIONS - -=head2 __handle_affected_packages - - __handle_affected_packages(affected_packages => {}, - data => [@data], - ) - - - -=cut - -sub __handle_affected_packages{ - my %param = validate_with(params => \@_, - spec => {%common_options, - data => {type => ARRAYREF|HASHREF - }, - }, - allow_extra => 1, - ); - for my $data (make_list($param{data})) { - next unless exists $data->{package} and defined $data->{package}; - my @packages = split /\s*,\s*/,$data->{package}; - @{$param{affected_packages}}{@packages} = (1) x @packages; - } -} - -=head2 __handle_debug_transcript - - my ($debug,$transcript) = __handle_debug_transcript(%param); - -Returns a debug and transcript filehandle - - -=cut - -sub __handle_debug_transcript{ - my %param = validate_with(params => \@_, - spec => {%common_options}, - allow_extra => 1, - ); - my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef); - my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef); - return ($debug,$transcript); -} - -=head2 __bug_info - - __bug_info($data) - -Produces a small bit of bug information to kick out to the transcript - -=cut - -sub __bug_info{ - my $return = ''; - for my $data (@_) { - next unless defined $data and exists $data->{bug_num}; - $return .= "Bug #".($data->{bug_num}||''). - ((defined $data->{done} and length $data->{done})? - " {Done: $data->{done}}":'' - ). - " [".($data->{package}||'(no package)'). "] ". - ($data->{subject}||'(no subject)')."\n"; - } - return $return; -} - - -=head2 __internal_request - - __internal_request() - __internal_request($level) - -Returns true if the caller of the function calling __internal_request -belongs to __PACKAGE__ - -This allows us to be magical, and don't bother to print bug info if -the second caller is from this package, amongst other things. - -An optional level is allowed, which increments the number of levels to -check by the given value. [This is basically for use by internal -functions like __begin_control which are always called by -C<__PACKAGE__>. - -=cut - -sub __internal_request{ - my ($l) = @_; - $l = 0 if not defined $l; - if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) { - return 1; - } - return 0; -} - -sub __return_append_to_log_options{ - my %param = @_; - my $action = $param{action} if exists $param{action}; - if (not exists $param{requester}) { - $param{requester} = $config{control_internal_requester}; - } - if (not exists $param{request_addr}) { - $param{request_addr} = $config{control_internal_request_addr}; - } - if (not exists $param{message}) { - my $date = rfc822_date(); - $param{message} = - encode_headers(fill_in_template(template => 'mail/fake_control_message', - variables => {request_addr => $param{request_addr}, - requester => $param{requester}, - date => $date, - action => $action - }, - )); - } - if (not defined $action) { - carp "Undefined action!"; - $action = "unknown action"; - } - return (action => $action, - hash_slice(%param,keys %append_action_options), - ); -} - -=head2 __begin_control - - my %info = __begin_control(%param, - archived=>1, - command=>'unarchive'); - my ($debug,$transcript) = @info{qw(debug transcript)}; - my @data = @{$info{data}}; - my @bugs = @{$info{bugs}}; - - -Starts the process of modifying a bug; handles all of the generic -things that almost every control request needs - -Returns a hash containing - -=over - -=item new_locks -- number of new locks taken out by this call - -=item debug -- the debug file handle - -=item transcript -- the transcript file handle - -=item data -- an arrayref containing the data of the bugs -corresponding to this request - -=item bugs -- an arrayref containing the bug numbers of the bugs -corresponding to this request - -=back - -=cut - -our $lockhash; - -sub __begin_control { - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+/, - }, - archived => {type => BOOLEAN, - default => 0, - }, - command => {type => SCALAR, - optional => 1, - }, - %common_options, - }, - allow_extra => 1, - ); - my $new_locks; - my ($debug,$transcript) = __handle_debug_transcript(@_); - print {$debug} "considering bug $param{bug} for ".(exists $param{command}?$param{command}:scalar caller())."\n"; -# print {$debug} Data::Dumper->Dump([[caller(1)],\%param],[qw(caller param)])."\n"; - $lockhash = $param{locks} if exists $param{locks}; - my @data = (); - my $old_die = $SIG{__DIE__}; - $SIG{__DIE__} = *sig_die{CODE}; - - ($new_locks, @data) = - lock_read_all_merged_bugs(bug => $param{bug}, - $param{archived}?(location => 'archive'):(), - exists $param{locks} ? (locks => $param{locks}):(), - ); - $locks += $new_locks; - if (not @data) { - die "Unable to read any bugs successfully."; - } - if (not $param{archived}) { - for my $data (@data) { - if ($data->{archived}) { - die "Not altering archived bugs; see unarchive."; - } - } - } - if (not check_limit(data => \@data, - exists $param{limit}?(limit => $param{limit}):(), - transcript => $transcript, - )) { - die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data); - } - - __handle_affected_packages(%param,data => \@data); - print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1); - print {$debug} "$param{bug} read $locks locks\n"; - if (not @data or not defined $data[0]) { - print {$transcript} "No bug found for $param{bug}\n"; - die "No bug found for $param{bug}"; - } - - add_recipients(data => \@data, - recipients => $param{recipients}, - (exists $param{command}?(actions_taken => {$param{command} => 1}):()), - debug => $debug, - (__internal_request()?(transcript => $transcript):()), - ); - - print {$debug} "$param{bug} read done\n"; - my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data; - print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n"; - return (data => \@data, - bugs => \@bugs, - old_die => $old_die, - new_locks => $new_locks, - debug => $debug, - transcript => $transcript, - param => \%param, - exists $param{locks}?(locks => $param{locks}):(), - ); -} - -=head2 __end_control - - __end_control(%info); - -Handles tearing down from a control request - -=cut - -sub __end_control { - my %info = @_; - if (exists $info{new_locks} and $info{new_locks} > 0) { - print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n"; - for (1..$info{new_locks}) { - unfilelock(exists $info{locks}?$info{locks}:()); - $locks--; - } - } - $SIG{__DIE__} = $info{old_die}; - if (exists $info{param}{affected_bugs}) { - @{$info{param}{affected_bugs}}{@{$info{bugs}}} = (1) x @{$info{bugs}}; - } - add_recipients(recipients => $info{param}{recipients}, - (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()), - data => $info{data}, - debug => $info{debug}, - transcript => $info{transcript}, - ); - __handle_affected_packages(%{$info{param}},data=>$info{data}); -} - - -=head2 check_limit - - check_limit(data => \@data, limit => $param{limit}); - - -Checks to make sure that bugs match any limits; each entry of @data -much satisfy the limit. - -Returns true if there are no entries in data, or there are no keys in -limit; returns false (0) if there are any entries which do not match. - -The limit hashref elements can contain an arrayref of scalars to -match; regexes are also acccepted. At least one of the entries in each -element needs to match the corresponding field in all data for the -limit to succeed. - -=cut - - -sub check_limit{ - my %param = validate_with(params => \@_, - spec => {data => {type => ARRAYREF|HASHREF, - }, - limit => {type => HASHREF|UNDEF, - }, - transcript => {type => SCALARREF|HANDLE, - optional => 1, - }, - }, - ); - my @data = make_list($param{data}); - if (not @data or - not defined $param{limit} or - not keys %{$param{limit}}) { - return 1; - } - my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef); - my $going_to_fail = 0; - for my $data (@data) { - $data = split_status_fields(get_bug_status(bug => $data->{bug_num}, - status => dclone($data), - )); - for my $field (keys %{$param{limit}}) { - next unless exists $param{limit}{$field}; - my $match = 0; - my @data_fields = make_list($data->{$field}); -LIMIT: for my $limit (make_list($param{limit}{$field})) { - if (not ref $limit) { - for my $data_field (@data_fields) { - if ($data_field eq $limit) { - $match = 1; - last LIMIT; - } - } - } - elsif (ref($limit) eq 'Regexp') { - for my $data_field (@data_fields) { - if ($data_field =~ $limit) { - $match = 1; - last LIMIT; - } - } - } - else { - warn "Unknown type of reference: '".ref($limit)."' in key '$field'"; - } - } - if (not $match) { - $going_to_fail = 1; - print {$transcript} qq($field: ').join(', ',map{qq("$_")} make_list($data->{$field})). - "' does not match at least one of ". - join(', ',map {ref($_)?'(regex)':qq("$_")} make_list($param{limit}{$field}))."\n"; - } - } - } - return $going_to_fail?0:1; -} - - -=head2 die - - sig_die "foo" - -We override die to specially handle unlocking files in the cases where -we are called via eval. [If we're not called via eval, it doesn't -matter.] - -=cut - -sub sig_die{ - if ($^S) { # in eval - if ($locks) { - for (1..$locks) { unfilelock(defined $lockhash?$lockhash:()); } - $locks = 0; - } - } -} - - -# =head2 __message_body_template -# -# message_body_template('mail/ack',{ref=>'foo'}); -# -# Creates a message body using a template -# -# =cut - -sub __message_body_template{ - my ($template,$extra_var) = @_; - $extra_var ||={}; - my $hole_var = {'&bugurl' => - sub{"$_[0]: ". - $config{cgi_domain}.'/'. - Debbugs::CGI::bug_links(bug => $_[0], - links_only => 1, - ); - } - }; - - my $body = fill_in_template(template => $template, - variables => {config => \%config, - %{$extra_var}, - }, - hole_var => $hole_var, - ); - return fill_in_template(template => 'mail/message_body', - variables => {config => \%config, - %{$extra_var}, - body => $body, - }, - hole_var => $hole_var, - ); -} - -sub __all_undef_or_equal { - my @values = @_; - return 1 if @values == 1 or @values == 0; - my $not_def = grep {not defined $_} @values; - if ($not_def == @values) { - return 1; - } - if ($not_def > 0 and $not_def != @values) { - return 0; - } - my $first_val = shift @values; - for my $val (@values) { - if ($first_val ne $val) { - return 0; - } - } - return 1; -} - - -1; - -__END__ diff --git a/Debbugs/Control/Service.pm b/Debbugs/Control/Service.pm deleted file mode 100644 index 52d7d10..0000000 --- a/Debbugs/Control/Service.pm +++ /dev/null @@ -1,728 +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. -# -# [Other people have contributed to this file; their copyrights should -# go here too.] -# Copyright 2007,2008,2009 by Don Armstrong . - -package Debbugs::Control::Service; - -=head1 NAME - -Debbugs::Control::Service -- Handles the modification parts of scripts/service by calling Debbugs::Control - -=head1 SYNOPSIS - -use Debbugs::Control::Service; - - -=head1 DESCRIPTION - -This module contains the code to implement the grammar of control@. It -is abstracted here so that it can be called from process at submit -time. - -All of the public functions take the following options: - -=over - -=item debug -- scalar reference to which debbuging information is -appended - -=item transcript -- scalar reference to which transcript information -is appended - -=item affected_bugs -- hashref which is updated with bugs affected by -this function - - -=back - -Functions which should (probably) append to the .log file take the -following options: - -=over - -=item requester -- Email address of the individual who requested the change - -=item request_addr -- Address to which the request was sent - -=item request_nn -- Name of queue file which caused this request - -=item request_msgid -- Message id of message which caused this request - -=item location -- Optional location; currently ignored but may be -supported in the future for updating archived bugs upon archival - -=item message -- The original message which caused the action to be taken - -=item append_log -- Whether or not to append information to the log. - -=back - -B (for most functions) is a special option. When set to -false, no appending to the log is done at all. When it is not present, -the above information is faked, and appended to the log file. When it -is true, the above options must be present, and their values are used. - - -=head1 GENERAL FUNCTIONS - -=cut - -use warnings; -use strict; -use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); -use Exporter qw(import); - -BEGIN{ - $VERSION = 1.00; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - %EXPORT_TAGS = (control => [qw(control_line valid_control)], - ); - @EXPORT_OK = (); - Exporter::export_ok_tags(keys %EXPORT_TAGS); - $EXPORT_TAGS{all} = [@EXPORT_OK]; -} - -use Debbugs::Config qw(:config); -use Debbugs::Common qw(cleanup_eval_fail); -use Debbugs::Control qw(:all); -use Debbugs::Status qw(splitpackages); -use Params::Validate qw(:types validate_with); -use List::AllUtils qw(first); - -my $bug_num_re = '-?\d+'; -my %control_grammar = - (close => qr/(?i)^close\s+\#?($bug_num_re)(?:\s+(\d.*))?$/, - reassign => qr/(?i)^reassign\s+\#?($bug_num_re)\s+ # bug and command - (?:(?:((?:src:|source:)?$config{package_name_re}) # new package - (?:\s+((?:$config{package_name_re}\/)? - $config{package_version_re}))?)| # optional version - ((?:src:|source:)?$config{package_name_re} # multiple package form - (?:\s*\,\s*(?:src:|source:)?$config{package_name_re})+)) - \s*$/x, - reopen => qr/(?i)^reopen\s+\#?($bug_num_re)(?:\s+([\=\!]|(?:\S.*\S)))?$/, - found => qr{^(?:(?i)found)\s+\#?($bug_num_re) - (?:\s+((?:$config{package_name_re}\/)? - $config{package_version_re} - # allow for multiple packages - (?:\s*,\s*(?:$config{package_name_re}\/)? - $config{package_version_re})*) - )?$}x, - notfound => qr{^(?:(?i)notfound)\s+\#?($bug_num_re) - \s+((?:$config{package_name_re}\/)? - $config{package_version_re} - # allow for multiple packages - (?:\s*,\s*(?:$config{package_name_re}\/)? - $config{package_version_re})* - )$}x, - fixed => qr{^(?:(?i)fixed)\s+\#?($bug_num_re) - \s+((?:$config{package_name_re}\/)? - $config{package_version_re} - # allow for multiple packages - (?:\s*,\s*(?:$config{package_name_re}\/)? - $config{package_version_re})*) - \s*$}x, - notfixed => qr{^(?:(?i)notfixed)\s+\#?($bug_num_re) - \s+((?:$config{package_name_re}\/)? - $config{package_version_re} - # allow for multiple packages - (?:\s*,\s*(?:$config{package_name_re}\/)? - $config{package_version_re})*) - \s*$}x, - submitter => qr/(?i)^submitter\s+\#?($bug_num_re)\s+(\!|\S.*\S)$/, - forwarded => qr/(?i)^forwarded\s+\#?($bug_num_re)\s+(\S.*\S)$/, - notforwarded => qr/(?i)^notforwarded\s+\#?($bug_num_re)$/, - severity => qr/(?i)^(?:severity|priority)\s+\#?($bug_num_re)\s+([-0-9a-z]+)$/, - tag => qr/(?i)^tags?\s+\#?($bug_num_re)\s+(\S.*)$/, - block => qr/(?i)^(un)?block\s+\#?($bug_num_re)\s+(?:by|with)\s+(\S.*)?$/, - retitle => qr/(?i)^retitle\s+\#?($bug_num_re)\s+(\S.*\S)\s*$/, - unmerge => qr/(?i)^unmerge\s+\#?($bug_num_re)$/, - merge => qr/(?i)^merge\s+#?($bug_num_re(\s+#?$bug_num_re)+)\s*$/, - forcemerge => qr/(?i)^forcemerge\s+\#?($bug_num_re(?:\s+\#?$bug_num_re)+)\s*$/, - clone => qr/(?i)^clone\s+#?($bug_num_re)\s+((?:$bug_num_re\s+)*$bug_num_re)\s*$/, - package => qr/(?i)^package\:?\s+(\S.*\S)?\s*$/, - limit => qr/(?i)^limit\:?\s+(\S.*\S)\s*$/, - affects => qr/(?i)^affects?\s+\#?($bug_num_re)(?:\s+((?:[=+-])?)\s*(\S.*)?)?\s*$/, - summary => qr/(?i)^summary\s+\#?($bug_num_re)\s*(.*)\s*$/, - outlook => qr/(?i)^outlook\s+\#?($bug_num_re)\s*(.*)\s*$/, - owner => qr/(?i)^owner\s+\#?($bug_num_re)\s+((?:\S.*\S)|\!)\s*$/, - noowner => qr/(?i)^noowner\s+\#?($bug_num_re)\s*$/, - unarchive => qr/(?i)^unarchive\s+#?($bug_num_re)$/, - archive => qr/(?i)^archive\s+#?($bug_num_re)$/, - ); - -sub valid_control { - my ($line,$matches) = @_; - my @matches; - for my $ctl (keys %control_grammar) { - if (@matches = $line =~ $control_grammar{$ctl}) { - @{$matches} = @matches if defined $matches and ref($matches) eq 'ARRAY'; - return $ctl; - } - } - @{$matches} = () if defined $matches and ref($matches) eq 'ARRAY'; - return undef; -} - -sub control_line { - my %param = - validate_with(params => \@_, - spec => {line => {type => SCALAR, - }, - clonebugs => {type => HASHREF, - }, - common_control_options => {type => ARRAYREF, - }, - errors => {type => SCALARREF, - }, - transcript => {type => HANDLE, - }, - debug => {type => SCALAR, - default => 0, - }, - ok => {type => SCALARREF, - }, - limit => {type => HASHREF, - }, - replyto => {type => SCALAR, - }, - }, - ); - my $line = $param{line}; - my @matches; - my $ctl = valid_control($line,\@matches); - my $transcript = $param{transcript}; - my $debug = $param{debug}; - if (not defined $ctl) { - ${$param{errors}}++; - print {$param{transcript}} "Unknown command or invalid options to control\n"; - return; - } - # in almost all cases, the first match is the bug; the exception - # to this is block. - my $ref = $matches[0]; - if (defined $ref) { - $ref = $param{clonebugs}{$ref} if exists $param{clonebugs}{$ref}; - } - ${$param{ok}}++; - my $errors = 0; - my $terminate_control = 0; - - if ($ctl eq 'close') { - if (defined $matches[1]) { - eval { - set_fixed(@{$param{common_control_options}}, - bug => $ref, - fixed => $matches[1], - add => 1, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to add fixed version '$matches[1]' to $ref: ".cleanup_eval_fail($@,$debug)."\n"; - } - } - eval { - set_done(@{$param{common_control_options}}, - done => 1, - bug => $ref, - reopen => 0, - notify_submitter => 1, - clear_fixed => 0, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to mark $ref as done: ".cleanup_eval_fail($@,$debug)."\n"; - } - } elsif ($ctl eq 'reassign') { - my @new_packages; - if (not defined $matches[1]) { - push @new_packages, split /\s*\,\s*/,$matches[3]; - } - else { - push @new_packages, $matches[1]; - } - @new_packages = map {y/A-Z/a-z/; s/^(?:src|source):/src:/; $_;} @new_packages; - my $version= $matches[2]; - eval { - set_package(@{$param{common_control_options}}, - bug => $ref, - package => \@new_packages, - ); - # if there is a version passed, we make an internal call - # to set_found - if (defined($version) && length $version) { - set_found(@{$param{common_control_options}}, - bug => $ref, - found => $version, - ); - } - }; - if ($@) { - $errors++; - print {$transcript} "Failed to clear fixed versions and reopen on $ref: ".cleanup_eval_fail($@,$debug)."\n"; - } - } elsif ($ctl eq 'reopen') { - my $new_submitter = $matches[1]; - if (defined $new_submitter) { - if ($new_submitter eq '=') { - undef $new_submitter; - } - elsif ($new_submitter eq '!') { - $new_submitter = $param{replyto}; - } - } - eval { - set_done(@{$param{common_control_options}}, - bug => $ref, - reopen => 1, - defined $new_submitter? (submitter => $new_submitter):(), - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to reopen $ref: ".cleanup_eval_fail($@,$debug)."\n"; - } - } elsif ($ctl eq 'found') { - my @versions; - if (defined $matches[1]) { - @versions = split /\s*,\s*/,$matches[1]; - eval { - set_found(@{$param{common_control_options}}, - bug => $ref, - found => \@versions, - add => 1, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to add found on $ref: ".cleanup_eval_fail($@,$debug)."\n"; - } - } - else { - eval { - set_fixed(@{$param{common_control_options}}, - bug => $ref, - fixed => [], - reopen => 1, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to clear fixed versions and reopen on $ref: ".cleanup_eval_fail($@,$debug)."\n"; - } - } - } - elsif ($ctl eq 'notfound') { - my @versions; - @versions = split /\s*,\s*/,$matches[1]; - eval { - set_found(@{$param{common_control_options}}, - bug => $ref, - found => \@versions, - remove => 1, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to remove found on $ref: ".cleanup_eval_fail($@,$debug)."\n"; - } - } - elsif ($ctl eq 'fixed') { - my @versions; - @versions = split /\s*,\s*/,$matches[1]; - eval { - set_fixed(@{$param{common_control_options}}, - bug => $ref, - fixed => \@versions, - add => 1, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to add fixed on $ref: ".cleanup_eval_fail($@,$debug)."\n"; - } - } - elsif ($ctl eq 'notfixed') { - my @versions; - @versions = split /\s*,\s*/,$matches[1]; - eval { - set_fixed(@{$param{common_control_options}}, - bug => $ref, - fixed => \@versions, - remove => 1, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to remove fixed on $ref: ".cleanup_eval_fail($@,$debug)."\n"; - } - } - elsif ($ctl eq 'submitter') { - my $newsubmitter = $matches[1] eq '!' ? $param{replyto} : $matches[1]; - if (not Mail::RFC822::Address::valid($newsubmitter)) { - print {$transcript} "$newsubmitter is not a valid e-mail address; not changing submitter\n"; - $errors++; - } - else { - eval { - set_submitter(@{$param{common_control_options}}, - bug => $ref, - submitter => $newsubmitter, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to set submitter on $ref: ".cleanup_eval_fail($@,$debug)."\n"; - } - } - } elsif ($ctl eq 'forwarded') { - my $forward_to= $matches[1]; - eval { - set_forwarded(@{$param{common_control_options}}, - bug => $ref, - forwarded => $forward_to, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to set the forwarded-to-address of $ref: ".cleanup_eval_fail($@,$debug)."\n"; - } - } elsif ($ctl eq 'notforwarded') { - eval { - set_forwarded(@{$param{common_control_options}}, - bug => $ref, - forwarded => undef, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to clear the forwarded-to-address of $ref: ".cleanup_eval_fail($@,$debug)."\n"; - } - } elsif ($ctl eq 'severity') { - my $newseverity= $matches[1]; - if (exists $config{obsolete_severities}{$newseverity}) { - print {$transcript} "Severity level \`$newseverity' is obsolete. " . - "Use $config{obsolete_severities}{$newseverity} instead.\n\n"; - $errors++; - } elsif (not defined first {$_ eq $newseverity} - (@{$config{severity_list}}, $config{default_severity})) { - print {$transcript} "Severity level \`$newseverity' is not known.\n". - "Recognized are: $config{show_severities}.\n\n"; - $errors++; - } else { - eval { - set_severity(@{$param{common_control_options}}, - bug => $ref, - severity => $newseverity, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to set severity of $config{bug} $ref to $newseverity: ".cleanup_eval_fail($@,$debug)."\n"; - } - } - } elsif ($ctl eq 'tag') { - my $tags = $matches[1]; - my @tags = map {m/^([+=-])(.+)/ ? ($1,$2):($_)} split /[\s,]+/, $tags; - # this is an array of hashrefs which contain two elements, the - # first of which is the array of tags, the second is the - # option to pass to set_tag (we use a hashref here to make it - # more obvious what is happening) - my @tag_operations; - my @badtags; - for my $tag (@tags) { - if ($tag =~ /^[=+-]$/) { - if ($tag eq '=') { - @tag_operations = {tags => [], - option => [], - }; - } - elsif ($tag eq '-') { - push @tag_operations, - {tags => [], - option => [remove => 1], - }; - } - elsif ($tag eq '+') { - push @tag_operations, - {tags => [], - option => [add => 1], - }; - } - next; - } - if (not defined first {$_ eq $tag} @{$config{tags}}) { - push @badtags, $tag; - next; - } - if (not @tag_operations) { - @tag_operations = {tags => [], - option => [add => 1], - }; - } - push @{$tag_operations[-1]{tags}},$tag; - } - if (@badtags) { - print {$transcript} "Unknown tag/s: ".join(', ', @badtags).".\n". - "Recognized are: ".join(' ', @{$config{tags}}).".\n\n"; - $errors++; - } - eval { - for my $operation (@tag_operations) { - set_tag(@{$param{common_control_options}}, - bug => $ref, - tag => [@{$operation->{tags}}], - warn_on_bad_tags => 0, # don't warn on bad tags, - # 'cause we do that above - @{$operation->{option}}, - ); - } - }; - if ($@) { - # we intentionally have two errors here if there is a bad - # tag and the above fails for some reason - $errors++; - print {$transcript} "Failed to alter tags of $config{bug} $ref: ".cleanup_eval_fail($@,$debug)."\n"; - } - } elsif ($ctl eq 'block') { - my $add_remove = defined $matches[0] && $matches[0] eq 'un'; - $ref = $matches[1]; - $ref = exists $param{clonebugs}{$ref} ? $param{clonebugs}{$ref} : $ref; - my @blockers = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_} split /[\s,]+/, $matches[2]; - eval { - set_blocks(@{$param{common_control_options}}, - bug => $ref, - block => \@blockers, - $add_remove ? (remove => 1):(add => 1), - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to set blocking bugs of $ref: ".cleanup_eval_fail($@,$debug)."\n"; - } - } elsif ($ctl eq 'retitle') { - my $newtitle= $matches[1]; - eval { - set_title(@{$param{common_control_options}}, - bug => $ref, - title => $newtitle, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to set the title of $ref: ".cleanup_eval_fail($@,$debug)."\n"; - } - } elsif ($ctl eq 'unmerge') { - eval { - set_merged(@{$param{common_control_options}}, - bug => $ref, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to unmerge $ref: ".cleanup_eval_fail($@,$debug)."\n"; - } - } elsif ($ctl eq 'merge') { - my @tomerge; - ($ref,@tomerge) = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_} - split(/\s+#?/,$matches[0]); - eval { - set_merged(@{$param{common_control_options}}, - bug => $ref, - merge_with => \@tomerge, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to merge $ref: ".cleanup_eval_fail($@,$debug)."\n"; - } - } elsif ($ctl eq 'forcemerge') { - my @tomerge; - ($ref,@tomerge) = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_} - split(/\s+#?/,$matches[0]); - eval { - set_merged(@{$param{common_control_options}}, - bug => $ref, - merge_with => \@tomerge, - force => 1, - masterbug => 1, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to forcibly merge $ref: ".cleanup_eval_fail($@,$debug)."\n"; - } - } elsif ($ctl eq 'clone') { - my @newclonedids = split /\s+/, $matches[1]; - - eval { - my %new_clones; - clone_bug(@{$param{common_control_options}}, - bug => $ref, - new_bugs => \@newclonedids, - new_clones => \%new_clones, - ); - %{$param{clonebugs}} = (%{$param{clonebugs}}, - %new_clones); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to clone $ref: ".cleanup_eval_fail($@,$debug)."\n"; - } - } elsif ($ctl eq 'package') { - my @pkgs = split /\s+/, $matches[0]; - if (scalar(@pkgs) > 0) { - $param{limit}{package} = [@pkgs]; - print {$transcript} "Limiting to bugs with field 'package' containing at least one of ".join(', ',map {qq('$_')} @pkgs)."\n"; - print {$transcript} "Limit currently set to"; - for my $limit_field (keys %{$param{limit}}) { - print {$transcript} " '$limit_field':".join(', ',map {qq('$_')} @{$param{limit}{$limit_field}})."\n"; - } - print {$transcript} "\n"; - } else { - $param{limit}{package} = []; - print {$transcript} "Limit cleared.\n\n"; - } - } elsif ($ctl eq 'limit') { - my ($field,@options) = split /\s+/, $matches[0]; - $field = lc($field); - if ($field =~ /^(?:clear|unset|blank)$/) { - %{$param{limit}} = (); - print {$transcript} "Limit cleared.\n\n"; - } - elsif (exists $Debbugs::Status::fields{$field} or $field eq 'source') { - # %{$param{limit}} can actually contain regexes, but because they're - # not evaluated in Safe, DO NOT allow them through without - # fixing this. - $param{limit}{$field} = [@options]; - print {$transcript} "Limiting to bugs with field '$field' containing at least one of ".join(', ',map {qq('$_')} @options)."\n"; - print {$transcript} "Limit currently set to"; - for my $limit_field (keys %{$param{limit}}) { - print {$transcript} " '$limit_field':".join(', ',map {qq('$_')} @{$param{limit}{$limit_field}})."\n"; - } - print {$transcript} "\n"; - } - else { - print {$transcript} "Limit key $field not understood. Stopping processing here.\n\n"; - $errors++; - # this needs to be fixed - syntax error for fixing it - last; - } - } elsif ($ctl eq 'affects') { - my $add_remove = $matches[1]; - my $packages = $matches[2]; - # if there isn't a package given, assume that we should unset - # affects; otherwise default to adding - if (not defined $packages or - not length $packages) { - $packages = ''; - $add_remove ||= '='; - } - elsif (not defined $add_remove or - not length $add_remove) { - $add_remove = '+'; - } - eval { - affects(@{$param{common_control_options}}, - bug => $ref, - package => [splitpackages($packages)], - ($add_remove eq '+'?(add => 1):()), - ($add_remove eq '-'?(remove => 1):()), - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to mark $ref as affecting package(s): ".cleanup_eval_fail($@,$debug)."\n"; - } - - } elsif ($ctl eq 'summary') { - my $summary_msg = length($matches[1])?$matches[1]:undef; - eval { - summary(@{$param{common_control_options}}, - bug => $ref, - summary => $summary_msg, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to give $ref a summary: ".cleanup_eval_fail($@,$debug)."\n"; - } - - } elsif ($ctl eq 'outlook') { - my $outlook_msg = length($matches[1])?$matches[1]:undef; - eval { - outlook(@{$param{common_control_options}}, - bug => $ref, - outlook => $outlook_msg, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to give $ref a outlook: ".cleanup_eval_fail($@,$debug)."\n"; - } - - } elsif ($ctl eq 'owner') { - my $newowner = $matches[1]; - if ($newowner eq '!') { - $newowner = $param{replyto}; - } - eval { - owner(@{$param{common_control_options}}, - bug => $ref, - owner => $newowner, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to mark $ref as having an owner: ".cleanup_eval_fail($@,$debug)."\n"; - } - } elsif ($ctl eq 'noowner') { - eval { - owner(@{$param{common_control_options}}, - bug => $ref, - owner => undef, - ); - }; - if ($@) { - $errors++; - print {$transcript} "Failed to mark $ref as not having an owner: ".cleanup_eval_fail($@,$debug)."\n"; - } - } elsif ($ctl eq 'unarchive') { - eval { - bug_unarchive(@{$param{common_control_options}}, - bug => $ref, - ); - }; - if ($@) { - $errors++; - } - } elsif ($ctl eq 'archive') { - eval { - bug_archive(@{$param{common_control_options}}, - bug => $ref, - ignore_time => 1, - archive_unarchived => 0, - ); - }; - if ($@) { - $errors++; - } - } - if ($errors) { - ${$param{errors}}+=$errors; - } - return($errors,$terminate_control); -} - -1; - -__END__ diff --git a/Debbugs/Correspondent.pm b/Debbugs/Correspondent.pm deleted file mode 100644 index 0044347..0000000 --- a/Debbugs/Correspondent.pm +++ /dev/null @@ -1,99 +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::Correspondent; - -=head1 NAME - -Debbugs::Correspondent -- OO interface to bugs - -=head1 SYNOPSIS - - use Debbugs::Correspondent; - Debbugs::Correspondent->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 Mail::Address; -use Debbugs::OOTypes; -use Debbugs::Config qw(:config); - -use Carp; - -extends 'Debbugs::OOBase'; - -has name => (is => 'ro', isa => 'Str', - required => 1, - writer => '_set_name', - ); - -has _mail_address => (is => 'bare', isa => 'Mail::Address', - lazy => 1, - handles => [qw(address phrase comment)], - builder => '_build_mail_address', - ); - -sub _build_mail_address { - my @addr = Mail::Address->parse($_[0]->name) or - confess("unable to parse mail address"); - if (@addr > 1) { - warn("Multiple addresses to Debbugs::Correspondent"); - } - return $addr[0]; -} - -sub email { - my $email = $_[0]->address; - warn "No email" unless defined $email; - return $email; -} - -sub url { - my $self = shift; - return $config{web_domain}.'/correspondent:'.$self->email; -} - -sub maintainer_url { - my $self = shift; - return $config{web_domain}.'/maintainer:'.$self->email; -} - -sub owner_url { - my $self = shift; - return $config{web_domain}.'/owner:'.$self->email; -} - -sub submitter_url { - my $self = shift; - return $config{web_domain}.'/submitter:'.$self->email; -} - -sub CARP_TRACE { - my $self = shift; - return 'Debbugs::Correspondent={name='.$self->name.'}'; -} - - -__PACKAGE__->meta->make_immutable; - -no Mouse; -1; - - -__END__ -# Local Variables: -# indent-tabs-mode: nil -# cperl-indent-level: 4 -# End: diff --git a/Debbugs/DB.pm b/Debbugs/DB.pm deleted file mode 100644 index 5f6bd04..0000000 --- a/Debbugs/DB.pm +++ /dev/null @@ -1,33 +0,0 @@ -use utf8; -package Debbugs::DB; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -use strict; -use warnings; - -use base 'DBIx::Class::Schema'; - -__PACKAGE__->load_namespaces; - - -# Created by DBIx::Class::Schema::Loader v0.07025 @ 2012-07-17 10:25:29 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:wiMg1t5hFUhnyufL3yT5fQ - -# This version must be incremented any time the schema changes so that -# DBIx::Class::DeploymentHandler can do its work -our $VERSION=12; - -# You can replace this text with custom code or comments, and it will be preserved on regeneration - -# override connect to handle just passing a bare service -sub connect { - my ($self,@rem) = @_; - if ($rem[0] !~ /:/) { - $rem[0] = 'dbi:Pg:service='.$rem[0]; - } - $self->clone->connection(@rem); -} - -1; diff --git a/Debbugs/DB/Load.pm b/Debbugs/DB/Load.pm deleted file mode 100644 index 03ab770..0000000 --- a/Debbugs/DB/Load.pm +++ /dev/null @@ -1,771 +0,0 @@ -# This module is part of debbugs, and is released -# under the terms of the GPL version 2, or any later version. See the -# file README and COPYING for more information. -# Copyright 2013 by Don Armstrong . - -package Debbugs::DB::Load; - -=head1 NAME - -Debbugs::DB::Load -- Utility routines for loading the database - -=head1 SYNOPSIS - - -=head1 DESCRIPTION - - -=head1 BUGS - -None known. - -=cut - -use warnings; -use strict; -use v5.10; -use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); -use base qw(Exporter); - -BEGIN{ - ($VERSION) = q$Revision$ =~ /^Revision:\s+([^\s+])/; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - %EXPORT_TAGS = (load_bug => [qw(load_bug handle_load_bug_queue load_bug_log)], - load_debinfo => [qw(load_debinfo)], - load_package => [qw(load_packages)], - load_suite => [qw(load_suite)], - ); - @EXPORT_OK = (); - Exporter::export_ok_tags(keys %EXPORT_TAGS); - $EXPORT_TAGS{all} = [@EXPORT_OK]; -} - -use Params::Validate qw(validate_with :types); -use List::AllUtils qw(natatime); - -use Debbugs::Status qw(read_bug split_status_fields); -use Debbugs::DB; -use DateTime; -use Debbugs::Common qw(make_list getparsedaddrs); -use Debbugs::Config qw(:config); -use Debbugs::MIME qw(parse_to_mime_entity decode_rfc1522); -use DateTime::Format::Mail; -use Carp; - -=head2 Bug loading - -Routines to load bug; exported with :load_bug - -=over - -=item load_bug - - load_bug(db => $schema, - data => split_status_fields($data), - tags => \%tags, - queue => \%queue); - -Loads a bug's metadata into the database. (Does not load any messages) - -=over - -=item db -- Debbugs::DB object - -=item data -- Bug data (from read_bug) which has been split with split_status_fields - -=item tags -- tag cache (hashref); optional - -=item queue -- queue of operations to perform after bug is loaded; optional. - -=back - -=cut - -sub load_bug { - my %param = validate_with(params => \@_, - spec => {db => {type => OBJECT, - }, - data => {type => HASHREF, - optional => 1, - }, - bug => {type => SCALAR, - optional => 1, - }, - tags => {type => HASHREF, - default => sub {return {}}, - optional => 1}, - severities => {type => HASHREF, - default => sub {return {}}, - optional => 1, - }, - queue => {type => HASHREF, - optional => 1}, - packages => {type => HASHREF, - default => sub {return {}}, - optional => 1, - }, - }); - my $s = $param{db}; - if (not exists $param{data} and not exists $param{bug}) { - croak "One of data or bug must be provided to load_bug"; - } - if (not exists $param{data}) { - $param{data} = read_bug(bug => $param{bug}); - } - my $data = $param{data}; - my $tags = $param{tags}; - my $queue = $param{queue}; - my $severities = $param{severities}; - my $can_queue = 1; - if (not defined $queue) { - $can_queue = 0; - $queue = {}; - } - my %tags; - $data = split_status_fields($data); - for my $tag (make_list($data->{keywords})) { - next unless defined $tag and length $tag; - # this allows for invalid tags. But we'll use this to try to - # find those bugs and clean them up - if (not exists $tags->{$tag}) { - $tags->{$tag} = $s->resultset('Tag')-> - find_or_create({tag => $tag}); - } - $tags{$tag} = $tags->{$tag}; - } - my $severity = length($data->{severity}) ? $data->{severity} : - $config{default_severity}; - if (not exists $severities->{$severity}) { - $severities->{$severity} = - $s->resultset('Severity')-> - find_or_create({severity => $severity}, - ); - } - $severity = $severities->{$severity}; - my $bug = - {id => $data->{bug_num}, - creation => DateTime->from_epoch(epoch => $data->{date}), - log_modified => DateTime->from_epoch(epoch => $data->{log_modified}), - last_modified => DateTime->from_epoch(epoch => $data->{last_modified}), - archived => $data->{archived}, - (defined $data->{unarchived} and length($data->{unarchived}))? - (unarchived => DateTime->from_epoch(epoch => $data->{unarchived})):(), - forwarded => $data->{forwarded} // '', - summary => $data->{summary} // '', - outlook => $data->{outlook} // '', - subject => $data->{subject} // '', - done_full => $data->{done} // '', - severity => $severity, - owner_full => $data->{owner} // '', - submitter_full => $data->{originator} // '', - }; - my %addr_map = - (done => 'done', - owner => 'owner', - submitter => 'originator', - ); - for my $addr_type (keys %addr_map) { - $bug->{$addr_type} = undef; - next unless defined $data->{$addr_map{$addr_type}} and - length($data->{$addr_map{$addr_type}}); - $bug->{$addr_type} = - $s->resultset('Correspondent')-> - get_correspondent_id($data->{$addr_map{$addr_type}}) - } - my $b = $s->resultset('Bug')->update_or_create($bug) or - die "Unable to update or create bug $bug->{id}"; - $s->txn_do(sub { - my @unknown_packages; - my @unknown_affects_packages; - push @unknown_packages, - $b->set_related_packages('binpackages', - [grep {defined $_ and - length $_ and $_ !~ /^src:/} - make_list($data->{package})], - $param{packages}, - ); - push @unknown_packages, - $b->set_related_packages('srcpackages', - [map {s/src://; - $_} - grep {defined $_ and - $_ =~ /^src:/} - make_list($data->{package})], - $param{packages}, - ); - push @unknown_affects_packages, - $b->set_related_packages('affects_binpackages', - [grep {defined $_ and - length $_ and $_ !~ /^src:/} - make_list($data->{affects}) - ], - $param{packages}, - ); - push @unknown_affects_packages, - $b->set_related_packages('affects_srcpackages', - [map {s/src://; - $_} - grep {defined $_ and - $_ =~ /^src:/} - make_list($data->{affects})], - $param{packages}, - ); - $b->unknown_packages(join(', ',@unknown_packages)); - $b->unknown_affects(join(', ',@unknown_affects_packages)); - $b->update(); - for my $ff (qw(found fixed)) { - my @elements = $s->resultset('BugVer')->search({bug => $data->{bug_num}, - found => $ff eq 'found'?1:0, - }); - my %elements_to_delete = map {($elements[$_]->ver_string(), - $elements[$_])} 0..$#elements; - my %elements_to_add; - my @elements_to_keep; - for my $version (@{$data->{"${ff}_versions"}}) { - if (exists $elements_to_delete{$version}) { - push @elements_to_keep,$version; - } else { - $elements_to_add{$version} = 1; - } - } - for my $version (@elements_to_keep) { - delete $elements_to_delete{$version}; - } - for my $element (keys %elements_to_delete) { - $elements_to_delete{$element}->delete(); - } - for my $element (keys %elements_to_add) { - # find source package and source version id - my $ne = $s->resultset('BugVer')->new_result({bug => $data->{bug_num}, - ver_string => $element, - found => $ff eq 'found'?1:0, - } - ); - if (my ($src_pkg,$src_ver) = $element =~ m{^([^\/]+)/(.+)$}) { - my $src_pkg_e = $s->resultset('SrcPkg')->single({pkg => $src_pkg}); - if (defined $src_pkg_e) { - $ne->src_pkg($src_pkg_e->id()); - my $src_ver_e = $s->resultset('SrcVer')->single({src_pkg => $src_pkg_e->id(), - ver => $src_ver - }); - $ne->src_ver($src_ver_e->id()) if defined $src_ver_e; - } - } - $ne->insert(); - } - } - }); - ### set bug tags - $s->txn_do(sub {$b->set_tags([values %tags ] )}); - # because these bugs reference other bugs which might not exist - # yet, we can't handle them until we've loaded all bugs. queue - # them up. - for my $merge_block (qw(mergedwith blocks)) { - my $count = 0; - if (@{$data->{$merge_block}}) { - $count = - $s->resultset('Bug')-> - search({id => [@{$data->{$merge_block}}]})-> - count(); - } - # if all of the bugs exist, immediately fix the merge/blocks - if ($count == @{$data->{$merge_block}}) { - handle_load_bug_queue(db=>$s, - queue => {$merge_block, - {$data->{bug_num},[@{$data->{$merge_block}}]} - }); - } else { - $queue->{$merge_block}{$data->{bug_num}} = [@{$data->{$merge_block}}]; - } - } - - if (not $can_queue and keys %{$queue}) { - handle_load_bug_queue(db => $s,queue => $queue); - } - - # still need to handle merges, versions, etc. -} - -=item handle_load_bug_queue - - handle_load_bug_queue(db => $schema,queue => $queue); - -Handles a queue of operations created by load bug. [These operations -are used to handle cases where a bug referenced by a loaded bug may -not exist yet. In cases where the bugs should exist, the queue is -cleared automatically by load_bug if queue is undefined. - -=cut - -sub handle_load_bug_queue{ - my %param = validate_with(params => \@_, - spec => {db => {type => OBJECT, - }, - queue => {type => HASHREF, - }, - }); - my $s = $param{db}; - my $queue = $param{queue}; - my %queue_types = - (mergedwith => {set => 'BugMerged', - columns => [qw(bug merged)], - bug => 'bug', - }, - blocks => {set => 'BugBlock', - columns => [qw(bug blocks)], - bug => 'bug', - }, - ); - for my $queue_type (keys %queue_types) { - my $qt = $queue_types{$queue_type}; - my @bugs = keys %{$queue->{$queue_type}}; - next unless @bugs; - my @entries; - for my $bug (@bugs) { - push @entries, - map {[$bug,$_]} - @{$queue->{$queue_type}{$bug}}; - } - $s->txn_do(sub { - $s->resultset($qt->{set})-> - search({$qt->{bug}=>\@bugs})->delete(); - $s->resultset($qt->{set})-> - populate([[@{$qt->{columns}}], - @entries]) if @entries; - } - ); - } -} - -=item load_bug_log -- load bug logs - - load_bug_log(db => $s, - bug => $bug); - - -=over - -=item db -- database - -=item bug -- bug whose log should be loaded - -=back - -=cut - -sub load_bug_log { - my %param = validate_with(params => \@_, - spec => {db => {type => OBJECT, - }, - bug => {type => SCALAR, - }, - queue => {type => HASHREF, - optional => 1}, - }); - my $s = $param{db}; - my $msg_num=0; - my %seen_msg_ids; - my $log = Debbugs::Log->new(bug_num => $param{bug}) or - die "Unable to open log for $param{bug} for reading: $!"; - while (my $record = $log->read_record()) { - next unless $record->{type} eq 'incoming-recv'; - my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im; - next if defined $msg_id and exists $seen_msg_ids{$msg_id}; - $seen_msg_ids{$msg_id} = 1 if defined $msg_id; - next if defined $msg_id and $msg_id =~ /handler\..+\.ack(?:info)?\@/; - my $entity = parse_to_mime_entity($record); - # search for a message with this message id in the database - $msg_id = $entity->head->get('Message-Id') // - $entity->head->get('Resent-Message-ID') // - ''; - $msg_id =~ s/^\s*\\s*$//; - # check to see if the subject, to, and from match. if so, it's - # probably the same message. - my $subject = decode_rfc1522($entity->head->get('Subject')//''); - $subject =~ s/\n(?:(\s)\s*|\s*$)//g; - my $to = decode_rfc1522($entity->head->get('To')//''); - $to =~ s/\n(?:(\s)\s*|\s*$)//g; - my $from = decode_rfc1522($entity->head->get('From')//''); - $from =~ s/\n(?:(\s)\s*|\s*$)//g; - my $m = $s->resultset('Message')-> - find({msgid => $msg_id, - from_complete => $from, - to_complete => $to, - subject => $subject - }); - if (not defined $m) { - # if not, create a new message - $m = $s->resultset('Message')-> - find_or_create({msgid => $msg_id, - from_complete => $from, - to_complete => $to, - subject => $subject - }); - eval { - my $date = DateTime::Format::Mail-> - parse_datetime($entity->head->get('Date',0)); - if (abs($date->offset) >= 60 * 60 * 12) { - $date = $date->set_time_zone('UTC'); - } - $m->sent_date($date); - }; - my $spam = $entity->head->get('X-Spam-Status',0)//''; - if ($spam=~ /score=([\d\.]+)/) { - $m->spam_score($1); - } - my %corr; - @{$corr{from}} = getparsedaddrs($from); - @{$corr{to}} = getparsedaddrs($to); - @{$corr{cc}} = getparsedaddrs($entity->head->get('Cc')); - # add correspondents if necessary - my @cors; - for my $type (keys %corr) { - for my $addr (@{$corr{$type}}) { - my $cor = $s->resultset('Correspondent')-> - get_correspondent_id($addr); - next unless defined $cor; - push @cors, - {correspondent => $cor, - correspondent_type => $type, - }; - } - } - $m->update(); - $s->txn_do(sub { - $m->message_correspondents()->delete(); - $m->add_to_message_correspondents(@cors) if - @cors; - } - ); - } - my $recv; - if ($entity->head->get('Received',0) - =~ /via spool by (\S+)/) { - $recv = $s->resultset('Correspondent')-> - get_correspondent_id($1); - $m->add_to_message_correspondents({correspondent=>$recv, - correspondent_type => 'recv'}); - } - # link message to bugs if necessary - $m->find_or_create_related('bug_messages', - {bug=>$param{bug}, - message_number => $msg_num}); - } - -} - -=back - -=head2 Debinfo - -Commands to handle src and package version loading from debinfo files - -=over - -=item load_debinfo - - load_debinfo($schema,$binname, $binver, $binarch, $srcname, $srcver); - - - -=cut - -sub load_debinfo { - my ($s,$binname, $binver, $binarch, $srcname, $srcver,$ct_date,$cache) = @_; - $cache //= {}; - my $sp; - if (not defined $cache->{sp}{$srcname}) { - $cache->{sp}{$srcname} = - $s->resultset('SrcPkg')->find_or_create({pkg => $srcname}); - } - $sp = $cache->{sp}{$srcname}; - # update the creation date if the data we have is earlier - if (defined $ct_date and - (not defined $sp->creation or - $ct_date < $sp->creation)) { - $sp->creation($ct_date); - $sp->last_modified(DateTime->now); - $sp->update; - } - my $sv; - if (not defined $cache->{sv}{$srcname}{$srcver}) { - $cache->{sv}{$srcname}{$srcver} = - $s->resultset('SrcVer')-> - find_or_create({src_pkg =>$sp->id(), - ver => $srcver}); - } - $sv = $cache->{sv}{$srcname}{$srcver}; - if (defined $ct_date and - (not defined $sv->upload_date() or $ct_date < $sv->upload_date())) { - $sv->upload_date($ct_date); - $sv->update; - } - my $arch; - if (not defined $cache->{arch}{$binarch}) { - $cache->{arch}{$binarch} = - $s->resultset('Arch')-> - find_or_create({arch => $binarch}, - )->id(); - } - $arch = $cache->{arch}{$binarch}; - my $bp; - if (not defined $cache->{bp}{$binname}) { - $cache->{bp}{$binname} = - $s->resultset('BinPkg')-> - get_or_create_bin_pkg_id($binname); - } - $bp = $cache->{bp}{$binname}; - $s->resultset('BinVer')-> - get_bin_ver_id($bp,$binver,$arch,$sv->id()); -} - - -=back - -=head2 Packages - -=over - -=item load_package - - load_package($schema,$suite,$component,$arch,$pkg) - -=cut - -sub load_packages { - my ($schema,$suite,$pkgs,$p) = @_; - my $suite_id = $schema->resultset('Suite')-> - find_or_create({codename => $suite})->id; - my %maint_cache; - my %arch_cache; - my %source_cache; - my $src_max_last_modified = $schema->resultset('SrcAssociation')-> - search_rs({suite => $suite_id}, - {order_by => {-desc => ['me.modified']}, - rows => 1, - page => 1 - } - )->single(); - my $bin_max_last_modified = $schema->resultset('BinAssociation')-> - search_rs({suite => $suite_id}, - {order_by => {-desc => ['me.modified']}, - rows => 1, - page => 1 - } - )->single(); - my %maints; - my %sources; - my %bins; - for my $pkg_tuple (@{$pkgs}) { - my ($arch,$component,$pkg) = @{$pkg_tuple}; - $maints{$pkg->{Maintainer}} = $pkg->{Maintainer}; - if ($arch eq 'source') { - my $source = $pkg->{Package}; - my $source_ver = $pkg->{Version}; - $sources{$source}{$source_ver} = $pkg->{Maintainer}; - } else { - my $source = $pkg->{Source} // $pkg->{Package}; - my $source_ver = $pkg->{Version}; - if ($source =~ /^\s*(\S+) \(([^\)]+)\)\s*$/) { - ($source,$source_ver) = ($1,$2); - } - $sources{$source}{$source_ver} = $pkg->{Maintainer}; - $bins{$arch}{$pkg->{Package}} = - {arch => $arch, - bin => $pkg->{Package}, - bin_ver => $pkg->{Version}, - src_ver => $source_ver, - source => $source, - maint => $pkg->{Maintainer}, - }; - } - } - # Retrieve and Insert new maintainers - my $maints = - $schema->resultset('Maintainer')-> - get_maintainers(keys %maints); - my $archs = - $schema->resultset('Arch')-> - get_archs(keys %bins); - # We want all of the source package/versions which are in this suite to - # start with - my @sa_to_add; - my @sa_to_del; - my %included_sa; - # Calculate which source packages are no longer in this suite - for my $s ($schema->resultset('SrcPkg')-> - src_pkg_and_ver_in_suite($suite)) { - if (not exists $sources{$s->{pkg}} or - not exists $sources{$s->{pkg}}{$s->{src_vers}{ver}} - ) { - push @sa_to_del, - $s->{src_associations}{id}; - } - $included_sa{$s->{pkg}}{$s->{src_vers}} = 1; - } - # Calculate which source packages are newly in this suite - for my $s (keys %sources) { - for my $v (keys %{$sources{$s}}) { - if (not exists $included_sa{$s} and - not $included_sa{$s}{$v}) { - push @sa_to_add, - [$s,$v,$sources{$s}{$v}]; - } else { - $p->update() if defined $p; - } - } - } - # add new source packages - my $it = natatime 100, @sa_to_add; - while (my @v = $it->()) { - $schema->txn_do( - sub { - for my $svm (@_) { - my $s_id = $schema->resultset('SrcPkg')-> - get_or_create_src_pkg_id($svm->[0]); - my $sv_id = $schema->resultset('SrcVer')-> - get_src_ver_id($s_id,$svm->[1],$maints->{$svm->[2]}); - $schema->resultset('SrcAssociation')-> - insert_suite_src_ver_association($suite_id,$sv_id); - } - }, - @v - ); - $p->update($p->last_update()+ - scalar @v) if defined $p; - } - # remove associations for packages not in this suite - if (@sa_to_del) { - $it = natatime 1000, @sa_to_del; - while (my @v = $it->()) { - $schema-> - txn_do(sub { - $schema->resultset('SrcAssociation')-> - search_rs({id => \@v})-> - delete(); - }); - } - } - # update packages in this suite to have a modification time of now - $schema->resultset('SrcAssociation')-> - search_rs({suite => $suite_id})-> - update({modified => 'NOW()'}); - ## Handle binary packages - my @bin_to_del; - my @bin_to_add; - my %included_bin; - # calculate which binary packages are no longer in this suite - for my $b ($schema->resultset('BinPkg')-> - bin_pkg_and_ver_in_suite($suite)) { - if (not exists $bins{$b->{arch}{arch}} or - not exists $bins{$b->{arch}{arch}}{$b->{pkg}} or - ($bins{$b->{arch}{arch}}{$b->{pkg}}{bin_ver} ne - $b->{bin_vers}{ver} - ) - ) { - push @bin_to_del, - $b->{bin_associations}{id}; - } - $included_bin{$b->{arch}{arch}}{$b->{pkg}} = - $b->{bin_vers}{ver}; - } - # calculate which binary packages are newly in this suite - for my $a (keys %bins) { - for my $pkg (keys %{$bins{$a}}) { - if (not exists $included_bin{$a} or - not exists $included_bin{$a}{$pkg} or - $bins{$a}{$pkg}{bin_ver} ne - $included_bin{$a}{$pkg}) { - push @bin_to_add, - $bins{$a}{$pkg}; - } else { - $p->update() if defined $p; - } - } - } - $it = natatime 100, @bin_to_add; - while (my @v = $it->()) { - $schema->txn_do( - sub { - for my $bvm (@_) { - my $s_id = $schema->resultset('SrcPkg')-> - get_or_create_src_pkg_id($bvm->{source}); - my $sv_id = $schema->resultset('SrcVer')-> - get_src_ver_id($s_id,$bvm->{src_ver},$maints->{$bvm->{maint}}); - my $b_id = $schema->resultset('BinPkg')-> - get_or_create_bin_pkg_id($bvm->{bin}); - my $bv_id = $schema->resultset('BinVer')-> - get_bin_ver_id($b_id,$bvm->{bin_ver}, - $archs->{$bvm->{arch}},$sv_id); - $schema->resultset('BinAssociation')-> - insert_suite_bin_ver_association($suite_id,$bv_id); - } - }, - @v - ); - $p->update($p->last_update()+ - scalar @v) if defined $p; - } - if (@bin_to_del) { - $it = natatime 1000, @bin_to_del; - while (my @v = $it->()) { - $schema-> - txn_do(sub { - $schema->resultset('BinAssociation')-> - search_rs({id => \@v})-> - delete(); - }); - } - } - $schema->resultset('BinAssociation')-> - search_rs({suite => $suite_id})-> - update({modified => 'NOW()'}); - -} - - -=back - -=cut - -=head2 Suites - -=over - -=item load_suite - - load_suite($schema,$codename,$suite,$version,$active); - -=cut - -sub load_suite { - my ($schema,$codename,$suite,$version,$active) = @_; - if (ref($codename)) { - ($codename,$suite,$version) = - @{$codename}{qw(Codename Suite Version)}; - $active = 1; - } - my $s = $schema->resultset('Suite')->find_or_create({codename => $codename}); - $s->suite_name($suite); - $s->version($version); - $s->active($active); - $s->update(); - return $s; - -} - -=back - -=cut - -1; - - -__END__ -# Local Variables: -# indent-tabs-mode: nil -# cperl-indent-level: 4 -# End: diff --git a/Debbugs/DB/Result/.gitignore b/Debbugs/DB/Result/.gitignore deleted file mode 100644 index 5a4e08f..0000000 --- a/Debbugs/DB/Result/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -ColumnComment.pm -TableComment.pm diff --git a/Debbugs/DB/Result/Arch.pm b/Debbugs/DB/Result/Arch.pm deleted file mode 100644 index 3045047..0000000 --- a/Debbugs/DB/Result/Arch.pm +++ /dev/null @@ -1,134 +0,0 @@ -use utf8; -package Debbugs::DB::Result::Arch; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::Arch - Architectures - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("arch"); - -=head1 ACCESSORS - -=head2 id - - data_type: 'integer' - is_auto_increment: 1 - is_nullable: 0 - sequence: 'arch_id_seq' - -Architecture id - -=head2 arch - - data_type: 'text' - is_nullable: 0 - -Architecture name - -=cut - -__PACKAGE__->add_columns( - "id", - { - data_type => "integer", - is_auto_increment => 1, - is_nullable => 0, - sequence => "arch_id_seq", - }, - "arch", - { data_type => "text", is_nullable => 0 }, -); - -=head1 PRIMARY KEY - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->set_primary_key("id"); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("arch_arch_key", ["arch"]); - -=head1 RELATIONS - -=head2 bin_vers - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bin_vers", - "Debbugs::DB::Result::BinVer", - { "foreign.arch" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bug_status_caches - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_status_caches", - "Debbugs::DB::Result::BugStatusCache", - { "foreign.arch" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07042 @ 2014-11-30 21:56:51 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:9pDiZg68Odz66DpCB9GpsA - - -# You can replace this text with custom code or comments, and it will be preserved on regeneration -1; diff --git a/Debbugs/DB/Result/BinAssociation.pm b/Debbugs/DB/Result/BinAssociation.pm deleted file mode 100644 index 7ae23fa..0000000 --- a/Debbugs/DB/Result/BinAssociation.pm +++ /dev/null @@ -1,179 +0,0 @@ -use utf8; -package Debbugs::DB::Result::BinAssociation; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::BinAssociation - Binary <-> suite associations - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("bin_associations"); - -=head1 ACCESSORS - -=head2 id - - data_type: 'integer' - is_auto_increment: 1 - is_nullable: 0 - sequence: 'bin_associations_id_seq' - -Binary <-> suite association id - -=head2 suite - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Suite id (matches suite) - -=head2 bin - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Binary version id (matches bin_ver) - -=head2 created - - data_type: 'timestamp with time zone' - default_value: current_timestamp - is_nullable: 0 - original: {default_value => \"now()"} - -Time this binary package entered this suite - -=head2 modified - - data_type: 'timestamp with time zone' - default_value: current_timestamp - is_nullable: 0 - original: {default_value => \"now()"} - -Time this entry was modified - -=cut - -__PACKAGE__->add_columns( - "id", - { - data_type => "integer", - is_auto_increment => 1, - is_nullable => 0, - sequence => "bin_associations_id_seq", - }, - "suite", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "bin", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "created", - { - data_type => "timestamp with time zone", - default_value => \"current_timestamp", - is_nullable => 0, - original => { default_value => \"now()" }, - }, - "modified", - { - data_type => "timestamp with time zone", - default_value => \"current_timestamp", - is_nullable => 0, - original => { default_value => \"now()" }, - }, -); - -=head1 PRIMARY KEY - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->set_primary_key("id"); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("bin_associations_bin_suite", ["bin", "suite"]); - -=head1 RELATIONS - -=head2 bin - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "bin", - "Debbugs::DB::Result::BinVer", - { id => "bin" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - -=head2 suite - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "suite", - "Debbugs::DB::Result::Suite", - { id => "suite" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07045 @ 2016-11-24 09:00:00 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:3F77iWjlJrHs/98TOfroAA - - -# You can replace this text with custom code or comments, and it will be preserved on regeneration -1; diff --git a/Debbugs/DB/Result/BinPkg.pm b/Debbugs/DB/Result/BinPkg.pm deleted file mode 100644 index 0e0c554..0000000 --- a/Debbugs/DB/Result/BinPkg.pm +++ /dev/null @@ -1,164 +0,0 @@ -use utf8; -package Debbugs::DB::Result::BinPkg; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::BinPkg - Binary packages - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("bin_pkg"); - -=head1 ACCESSORS - -=head2 id - - data_type: 'integer' - is_auto_increment: 1 - is_nullable: 0 - sequence: 'bin_pkg_id_seq' - -Binary package id - -=head2 pkg - - data_type: 'text' - is_nullable: 0 - -Binary package name - -=cut - -__PACKAGE__->add_columns( - "id", - { - data_type => "integer", - is_auto_increment => 1, - is_nullable => 0, - sequence => "bin_pkg_id_seq", - }, - "pkg", - { data_type => "text", is_nullable => 0 }, -); - -=head1 PRIMARY KEY - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->set_primary_key("id"); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("bin_pkg_pkg_key", ["pkg"]); - -=head1 RELATIONS - -=head2 bin_pkg_src_pkgs - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bin_pkg_src_pkgs", - "Debbugs::DB::Result::BinPkgSrcPkg", - { "foreign.bin_pkg" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bin_vers - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bin_vers", - "Debbugs::DB::Result::BinVer", - { "foreign.bin_pkg" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bug_affects_binpackages - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_affects_binpackages", - "Debbugs::DB::Result::BugAffectsBinpackage", - { "foreign.bin_pkg" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bug_binpackages - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_binpackages", - "Debbugs::DB::Result::BugBinpackage", - { "foreign.bin_pkg" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07049 @ 2019-07-05 20:56:47 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:VH/9QrwjZx0r7FLaEWGYMg - - -# You can replace this text with custom code or comments, and it will be preserved on regeneration -1; diff --git a/Debbugs/DB/Result/BinPkgSrcPkg.pm b/Debbugs/DB/Result/BinPkgSrcPkg.pm deleted file mode 100644 index 4836b05..0000000 --- a/Debbugs/DB/Result/BinPkgSrcPkg.pm +++ /dev/null @@ -1,198 +0,0 @@ -use utf8; -package Debbugs::DB::Result::BinPkgSrcPkg; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::BinPkgSrcPkg - Binary package <-> source package mapping sumpmary table - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("bin_pkg_src_pkg"); - -=head1 ACCESSORS - -=head2 bin_pkg - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Binary package id (matches bin_pkg) - -=head2 src_pkg - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Source package id (matches src_pkg) - -=cut - -__PACKAGE__->add_columns( - "bin_pkg", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "src_pkg", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, -); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("bin_pkg_src_pkg_bin_pkg_src_pkg", ["bin_pkg", "src_pkg"]); - -=head2 C - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("bin_pkg_src_pkg_src_pkg_bin_pkg", ["src_pkg", "bin_pkg"]); - -=head1 RELATIONS - -=head2 bin_pkg - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "bin_pkg", - "Debbugs::DB::Result::BinPkg", - { id => "bin_pkg" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - -=head2 src_pkg - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "src_pkg", - "Debbugs::DB::Result::SrcPkg", - { id => "src_pkg" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07048 @ 2018-04-18 16:55:56 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:O/v5RtjJF9SgxXEy76U/xw - -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - $sqlt_table->schema-> - add_procedure(name => 'bin_ver_to_src_pkg', - sql => <<'EOF', -CREATE OR REPLACE FUNCTION bin_ver_to_src_pkg(bin_ver INT) RETURNS INT - AS $src_pkg_from_bin_ver$ - DECLARE - src_pkg int; - BEGIN - SELECT sv.src_pkg INTO STRICT src_pkg - FROM bin_ver bv JOIN src_ver sv ON bv.src_ver=sv.id - WHERE bv.id=bin_ver; - RETURN src_pkg; - END - $src_pkg_from_bin_ver$ LANGUAGE plpgsql; -EOF - ); - $sqlt_table->schema-> - add_procedure(name => 'src_ver_to_src_pkg', - sql => <<'EOF', -CREATE OR REPLACE FUNCTION src_ver_to_src_pkg(src_ver INT) RETURNS INT - AS $src_ver_to_src_pkg$ - DECLARE - src_pkg int; - BEGIN - SELECT sv.src_pkg INTO STRICT src_pkg - FROM src_ver sv WHERE sv.id=src_ver; - RETURN src_pkg; - END - $src_ver_to_src_pkg$ LANGUAGE plpgsql; -EOF - ); - $sqlt_table->schema-> - add_procedure(name => 'update_bin_pkg_src_pkg_bin_ver', - sql => <<'EOF', -CREATE OR REPLACE FUNCTION update_bin_pkg_src_pkg_bin_ver () RETURNS TRIGGER - AS $update_bin_pkg_src_pkg_bin_ver$ - DECLARE - src_ver_rows integer; - BEGIN - IF (TG_OP = 'DELETE' OR TG_OP = 'UPDATE' ) THEN - -- if there is still a bin_ver with this src_pkg, then do nothing - PERFORM * FROM bin_ver bv JOIN src_ver sv ON bv.src_ver = sv.id - WHERE sv.id = OLD.src_ver LIMIT 2; - GET DIAGNOSTICS src_ver_rows = ROW_COUNT; - IF (src_ver_rows <= 1) THEN - DELETE FROM bin_pkg_src_pkg - WHERE bin_pkg=OLD.bin_pkg AND - src_pkg=src_ver_to_src_pkg(OLD.src_ver); - END IF; - END IF; - IF (TG_OP = 'INSERT' OR TG_OP = 'UPDATE') THEN - BEGIN - INSERT INTO bin_pkg_src_pkg (bin_pkg,src_pkg) - VALUES (NEW.bin_pkg,src_ver_to_src_pkg(NEW.src_ver)) - ON CONFLICT (bin_pkg,src_pkg) DO NOTHING; - END; - END IF; - RETURN NULL; - END - $update_bin_pkg_src_pkg_bin_ver$ LANGUAGE plpgsql; -EOF - ); - -} - -1; diff --git a/Debbugs/DB/Result/BinVer.pm b/Debbugs/DB/Result/BinVer.pm deleted file mode 100644 index 9eb144b..0000000 --- a/Debbugs/DB/Result/BinVer.pm +++ /dev/null @@ -1,264 +0,0 @@ -use utf8; -package Debbugs::DB::Result::BinVer; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::BinVer - Binary versions - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("bin_ver"); - -=head1 ACCESSORS - -=head2 id - - data_type: 'integer' - is_auto_increment: 1 - is_nullable: 0 - sequence: 'bin_ver_id_seq' - -Binary version id - -=head2 bin_pkg - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Binary package id (matches bin_pkg) - -=head2 src_ver - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Source version (matchines src_ver) - -=head2 arch - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Architecture id (matches arch) - -=head2 ver - - data_type: 'debversion' - is_nullable: 0 - -Binary version - -=cut - -__PACKAGE__->add_columns( - "id", - { - data_type => "integer", - is_auto_increment => 1, - is_nullable => 0, - sequence => "bin_ver_id_seq", - }, - "bin_pkg", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "src_ver", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "arch", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "ver", - { data_type => "debversion", is_nullable => 0 }, -); - -=head1 PRIMARY KEY - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->set_primary_key("id"); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("bin_ver_bin_pkg_id_arch_idx", ["bin_pkg", "arch", "ver"]); - -=head1 RELATIONS - -=head2 arch - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "arch", - "Debbugs::DB::Result::Arch", - { id => "arch" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - -=head2 bin_associations - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bin_associations", - "Debbugs::DB::Result::BinAssociation", - { "foreign.bin" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bin_pkg - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "bin_pkg", - "Debbugs::DB::Result::BinPkg", - { id => "bin_pkg" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - -=head2 src_ver - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "src_ver", - "Debbugs::DB::Result::SrcVer", - { id => "src_ver" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07045 @ 2016-11-24 09:08:27 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:DzTzZbPkilT8WMhXoZv9xw - - -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - for my $idx (qw(ver bin_pkg src_ver)) { - $sqlt_table->add_index(name => 'bin_ver_'.$idx.'_id_idx', - fields => [$idx]); - } - $sqlt_table->add_index(name => 'bin_ver_src_ver_id_arch_idx', - fields => [qw(src_ver arch)] - ); - $sqlt_table->schema-> - add_procedure(name => 'bin_ver_to_src_pkg', - sql => <<'EOF', -CREATE OR REPLACE FUNCTION bin_ver_to_src_pkg(bin_ver INT) RETURNS INT - AS $src_pkg_from_bin_ver$ - DECLARE - src_pkg int; - BEGIN - SELECT sv.src_pkg INTO STRICT src_pkg - FROM bin_ver bv JOIN src_ver sv ON bv.src_ver=sv.id - WHERE bv.id=bin_ver; - RETURN src_pkg; - END - $src_pkg_from_bin_ver$ LANGUAGE plpgsql; -EOF - ); - $sqlt_table->schema-> - add_procedure(name => 'update_bin_pkg_src_pkg_bin_ver', - sql => <<'EOF', -CREATE OR REPLACE FUNCTION update_bin_pkg_src_pkg_bin_ver () RETURNS TRIGGER - AS $update_bin_pkg_src_pkg_bin_ver$ - DECLARE - src_ver_rows integer; - BEGIN - IF (TG_OP = 'DELETE' OR TG_OP = 'UPDATE' ) THEN - -- if there is still a bin_ver with this src_pkg, then do nothing - PERFORM * FROM bin_ver bv JOIN src_ver sv ON bv.src_ver = sv.id - WHERE sv.id = OLD.src_ver LIMIT 2; - GET DIAGNOSTICS src_ver_rows = ROW_COUNT; - IF (src_ver_rows <= 1) THEN - DELETE FROM bin_pkg_src_pkg - WHERE bin_pkg=OLD.bin_pkg AND - src_pkg=src_ver_to_src_pkg(OLD.src_ver); - END IF; - END IF; - IF (TG_OP = 'INSERT' OR TG_OP = 'UPDATE') THEN - BEGIN - INSERT INTO bin_pkg_src_pkg (bin_pkg,src_pkg) - VALUES (NEW.bin_pkg,src_ver_to_src_pkg(NEW.src_ver)) - ON CONFLICT (bin_pkg,src_pkg) DO NOTHING; - END; - END IF; - RETURN NULL; - END - $update_bin_pkg_src_pkg_bin_ver$ LANGUAGE plpgsql; -EOF - ); -# $sqlt_table->schema-> -# add_trigger(name => 'bin_ver_update_bin_pkg_src_pkg', -# perform_action_when => 'after', -# database_events => [qw(INSERT UPDATE DELETE)], -# on_table => 'bin_ver', -# action => <<'EOF', -# FOR EACH ROW EXECUTE PROCEDURE update_bin_pkg_src_pkg_bin_ver(); -# EOF -# ); -} - -1; diff --git a/Debbugs/DB/Result/BinaryVersion.pm b/Debbugs/DB/Result/BinaryVersion.pm deleted file mode 100644 index 426b725..0000000 --- a/Debbugs/DB/Result/BinaryVersion.pm +++ /dev/null @@ -1,112 +0,0 @@ -use utf8; -package Debbugs::DB::Result::BinaryVersion; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::BinaryVersion - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); -__PACKAGE__->table_class("DBIx::Class::ResultSource::View"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("binary_versions"); -__PACKAGE__->result_source_instance->view_definition(" SELECT sp.pkg AS src_pkg,\n sv.ver AS src_ver,\n bp.pkg AS bin_pkg,\n a.arch,\n b.ver AS bin_ver,\n svb.ver AS src_ver_based_on,\n spb.pkg AS src_pkg_based_on\n FROM ((((((bin_ver b\n JOIN arch a ON ((b.arch = a.id)))\n JOIN bin_pkg bp ON ((b.bin_pkg = bp.id)))\n JOIN src_ver sv ON ((b.src_ver = sv.id)))\n JOIN src_pkg sp ON ((sv.src_pkg = sp.id)))\n LEFT JOIN src_ver svb ON ((sv.based_on = svb.id)))\n LEFT JOIN src_pkg spb ON ((spb.id = svb.src_pkg)))"); - -=head1 ACCESSORS - -=head2 src_pkg - - data_type: 'text' - is_nullable: 1 - -=head2 src_ver - - data_type: 'debversion' - is_nullable: 1 - -=head2 bin_pkg - - data_type: 'text' - is_nullable: 1 - -=head2 arch - - data_type: 'text' - is_nullable: 1 - -=head2 bin_ver - - data_type: 'debversion' - is_nullable: 1 - -=head2 src_ver_based_on - - data_type: 'debversion' - is_nullable: 1 - -=head2 src_pkg_based_on - - data_type: 'text' - is_nullable: 1 - -=cut - -__PACKAGE__->add_columns( - "src_pkg", - { data_type => "text", is_nullable => 1 }, - "src_ver", - { data_type => "debversion", is_nullable => 1 }, - "bin_pkg", - { data_type => "text", is_nullable => 1 }, - "arch", - { data_type => "text", is_nullable => 1 }, - "bin_ver", - { data_type => "debversion", is_nullable => 1 }, - "src_ver_based_on", - { data_type => "debversion", is_nullable => 1 }, - "src_pkg_based_on", - { data_type => "text", is_nullable => 1 }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-04 10:59:03 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:0MeJnGxBc8gdEoPE6Sn6Sw - -__PACKAGE__->result_source_instance->view_definition(< - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("bug"); - -=head1 ACCESSORS - -=head2 id - - data_type: 'integer' - is_nullable: 0 - -Bug number - -=head2 creation - - data_type: 'timestamp with time zone' - default_value: current_timestamp - is_nullable: 0 - original: {default_value => \"now()"} - -Time bug created - -=head2 log_modified - - data_type: 'timestamp with time zone' - default_value: current_timestamp - is_nullable: 0 - original: {default_value => \"now()"} - -Time bug log was last modified - -=head2 last_modified - - data_type: 'timestamp with time zone' - default_value: current_timestamp - is_nullable: 0 - original: {default_value => \"now()"} - -Time bug status was last modified - -=head2 archived - - data_type: 'boolean' - default_value: false - is_nullable: 0 - -True if bug has been archived - -=head2 unarchived - - data_type: 'timestamp with time zone' - is_nullable: 1 - -Time bug was last unarchived; null if bug has never been unarchived - -=head2 forwarded - - data_type: 'text' - default_value: (empty string) - is_nullable: 0 - -Where bug has been forwarded to; empty if it has not been forwarded - -=head2 summary - - data_type: 'text' - default_value: (empty string) - is_nullable: 0 - -Summary of the bug; empty if it has no summary - -=head2 outlook - - data_type: 'text' - default_value: (empty string) - is_nullable: 0 - -Outlook of the bug; empty if it has no outlook - -=head2 subject - - data_type: 'text' - is_nullable: 0 - -Subject of the bug - -=head2 severity - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -=head2 done - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 1 - -Individual who did the -done; empty if it has never been -done - -=head2 done_full - - data_type: 'text' - default_value: (empty string) - is_nullable: 0 - -=head2 owner - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 1 - -Individual who owns this bug; empty if no one owns it - -=head2 owner_full - - data_type: 'text' - default_value: (empty string) - is_nullable: 0 - -=head2 submitter - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 1 - -Individual who submitted this bug; empty if there is no submitter - -=head2 submitter_full - - data_type: 'text' - default_value: (empty string) - is_nullable: 0 - -=head2 unknown_packages - - data_type: 'text' - default_value: (empty string) - is_nullable: 0 - -Package name if the package is not known - -=head2 unknown_affects - - data_type: 'text' - default_value: (empty string) - is_nullable: 0 - -Package name if the affected package is not known - -=cut - -__PACKAGE__->add_columns( - "id", - { data_type => "integer", is_nullable => 0 }, - "creation", - { - data_type => "timestamp with time zone", - default_value => \"current_timestamp", - is_nullable => 0, - original => { default_value => \"now()" }, - }, - "log_modified", - { - data_type => "timestamp with time zone", - default_value => \"current_timestamp", - is_nullable => 0, - original => { default_value => \"now()" }, - }, - "last_modified", - { - data_type => "timestamp with time zone", - default_value => \"current_timestamp", - is_nullable => 0, - original => { default_value => \"now()" }, - }, - "archived", - { data_type => "boolean", default_value => \"false", is_nullable => 0 }, - "unarchived", - { data_type => "timestamp with time zone", is_nullable => 1 }, - "forwarded", - { data_type => "text", default_value => "", is_nullable => 0 }, - "summary", - { data_type => "text", default_value => "", is_nullable => 0 }, - "outlook", - { data_type => "text", default_value => "", is_nullable => 0 }, - "subject", - { data_type => "text", is_nullable => 0 }, - "severity", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "done", - { data_type => "integer", is_foreign_key => 1, is_nullable => 1 }, - "done_full", - { data_type => "text", default_value => "", is_nullable => 0 }, - "owner", - { data_type => "integer", is_foreign_key => 1, is_nullable => 1 }, - "owner_full", - { data_type => "text", default_value => "", is_nullable => 0 }, - "submitter", - { data_type => "integer", is_foreign_key => 1, is_nullable => 1 }, - "submitter_full", - { data_type => "text", default_value => "", is_nullable => 0 }, - "unknown_packages", - { data_type => "text", default_value => "", is_nullable => 0 }, - "unknown_affects", - { data_type => "text", default_value => "", is_nullable => 0 }, -); - -=head1 PRIMARY KEY - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->set_primary_key("id"); - -=head1 RELATIONS - -=head2 bug_affects_binpackages - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_affects_binpackages", - "Debbugs::DB::Result::BugAffectsBinpackage", - { "foreign.bug" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bug_affects_srcpackages - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_affects_srcpackages", - "Debbugs::DB::Result::BugAffectsSrcpackage", - { "foreign.bug" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bug_binpackages - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_binpackages", - "Debbugs::DB::Result::BugBinpackage", - { "foreign.bug" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bug_blocks_blocks - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_blocks_blocks", - "Debbugs::DB::Result::BugBlock", - { "foreign.blocks" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bug_blocks_bugs - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_blocks_bugs", - "Debbugs::DB::Result::BugBlock", - { "foreign.bug" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bug_merged_bugs - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_merged_bugs", - "Debbugs::DB::Result::BugMerged", - { "foreign.bug" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bug_mergeds_merged - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_mergeds_merged", - "Debbugs::DB::Result::BugMerged", - { "foreign.merged" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bug_messages - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_messages", - "Debbugs::DB::Result::BugMessage", - { "foreign.bug" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bug_srcpackages - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_srcpackages", - "Debbugs::DB::Result::BugSrcpackage", - { "foreign.bug" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bug_status_caches - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_status_caches", - "Debbugs::DB::Result::BugStatusCache", - { "foreign.bug" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bug_tags - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_tags", - "Debbugs::DB::Result::BugTag", - { "foreign.bug" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bug_user_tags - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_user_tags", - "Debbugs::DB::Result::BugUserTag", - { "foreign.bug" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bug_vers - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_vers", - "Debbugs::DB::Result::BugVer", - { "foreign.bug" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 done - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "done", - "Debbugs::DB::Result::Correspondent", - { id => "done" }, - { - is_deferrable => 0, - join_type => "LEFT", - on_delete => "NO ACTION", - on_update => "NO ACTION", - }, -); - -=head2 owner - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "owner", - "Debbugs::DB::Result::Correspondent", - { id => "owner" }, - { - is_deferrable => 0, - join_type => "LEFT", - on_delete => "NO ACTION", - on_update => "NO ACTION", - }, -); - -=head2 severity - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "severity", - "Debbugs::DB::Result::Severity", - { id => "severity" }, - { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, -); - -=head2 submitter - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "submitter", - "Debbugs::DB::Result::Correspondent", - { id => "submitter" }, - { - is_deferrable => 0, - join_type => "LEFT", - on_delete => "NO ACTION", - on_update => "NO ACTION", - }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07048 @ 2018-04-11 13:06:55 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:qxkLXbv8JGoV9reebbOUEw - -use Carp; -use List::AllUtils qw(uniq); - -__PACKAGE__->many_to_many(tags => 'bug_tags','tag'); -__PACKAGE__->many_to_many(user_tags => 'bug_user_tags','user_tag'); -__PACKAGE__->many_to_many(srcpackages => 'bug_srcpackages','src_pkg'); -__PACKAGE__->many_to_many(binpackages => 'bug_binpackages','bin_pkg'); -__PACKAGE__->many_to_many(affects_binpackages => 'bug_affects_binpackages','bin_pkg'); -__PACKAGE__->many_to_many(affects_srcpackages => 'bug_affects_srcpackages','src_pkg'); -__PACKAGE__->many_to_many(messages => 'bug_messages','message'); - -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - # CREATE INDEX bug_idx_owner ON bug(owner); - # CREATE INDEX bug_idx_submitter ON bug(submitter); - # CREATE INDEX bug_idx_done ON bug(done); - # CREATE INDEX bug_idx_forwarded ON bug(forwarded); - # CREATE INDEX bug_idx_last_modified ON bug(last_modified); - # CREATE INDEX bug_idx_severity ON bug(severity); - # CREATE INDEX bug_idx_creation ON bug(creation); - # CREATE INDEX bug_idx_log_modified ON bug(log_modified); - for my $idx (qw(owner submitter done forwarded last_modified), - qw(severity creation log_modified), - ) { - $sqlt_table->add_index(name => 'bug_idx'.$idx, - fields => [$idx]); - } -} - -=head1 Utility Functions - -=cut - -=head2 set_related_packages - - $b->set_related_packages($relationship, - \@packages, - $package_cache , - ); - -Set bug-related packages. - -=cut - -sub set_related_packages { - my ($self,$relationship,$pkgs,$pkg_cache) = @_; - - my @unset_packages; - my @pkg_ids; - if ($relationship =~ /binpackages/) { - for my $pkg (@{$pkgs}) { - my $pkg_id = - $self->result_source->schema->resultset('BinPkg')-> - get_bin_pkg_id($pkg); - if (not defined $pkg_id) { - push @unset_packages,$pkg; - } else { - push @pkg_ids, $pkg_id; - } - } - } elsif ($relationship =~ /srcpackages/) { - for my $pkg (@{$pkgs}) { - my $pkg_id = - $self->result_source->schema->resultset('SrcPkg')-> - get_src_pkg_id($pkg); - if (not defined $pkg_id) { - push @unset_packages,$pkg; - } else { - push @pkg_ids,$pkg_id; - } - } - } else { - croak "Unsupported relationship $relationship"; - } - @pkg_ids = uniq @pkg_ids; - if ($relationship eq 'binpackages') { - $self->set_binpackages([map {{id => $_}} @pkg_ids]); - } elsif ($relationship eq 'srcpackages') { - $self->set_srcpackages([map {{id => $_}} @pkg_ids]); - } elsif ($relationship eq 'affects_binpackages') { - $self->set_affects_binpackages([map {{id => $_}} @pkg_ids]); - } elsif ($relationship eq 'affects_srcpackages') { - $self->set_affects_srcpackages([map {{id => $_}} @pkg_ids]); - } else { - croak "Unsupported relationship $relationship"; - } - return @unset_packages -} -# You can replace this text with custom code or comments, and it will be preserved on regeneration -1; diff --git a/Debbugs/DB/Result/BugAffectsBinpackage.pm b/Debbugs/DB/Result/BugAffectsBinpackage.pm deleted file mode 100644 index ce4b57e..0000000 --- a/Debbugs/DB/Result/BugAffectsBinpackage.pm +++ /dev/null @@ -1,119 +0,0 @@ -use utf8; -package Debbugs::DB::Result::BugAffectsBinpackage; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::BugAffectsBinpackage - Bug <-> binary package mapping - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("bug_affects_binpackage"); - -=head1 ACCESSORS - -=head2 bug - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Bug id (matches bug) - -=head2 bin_pkg - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Binary package id (matches bin_pkg) - -=cut - -__PACKAGE__->add_columns( - "bug", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "bin_pkg", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, -); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("bug_affects_binpackage_id_pkg", ["bug", "bin_pkg"]); - -=head1 RELATIONS - -=head2 bin_pkg - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "bin_pkg", - "Debbugs::DB::Result::BinPkg", - { id => "bin_pkg" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - -=head2 bug - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "bug", - "Debbugs::DB::Result::Bug", - { id => "bug" }, - { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-04 10:59:03 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:qPJSly5VwC8Fl9hchBtB1Q - - -# You can replace this text with custom code or comments, and it will be preserved on regeneration -1; diff --git a/Debbugs/DB/Result/BugAffectsSrcpackage.pm b/Debbugs/DB/Result/BugAffectsSrcpackage.pm deleted file mode 100644 index e25fa60..0000000 --- a/Debbugs/DB/Result/BugAffectsSrcpackage.pm +++ /dev/null @@ -1,119 +0,0 @@ -use utf8; -package Debbugs::DB::Result::BugAffectsSrcpackage; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::BugAffectsSrcpackage - Bug <-> source package mapping - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("bug_affects_srcpackage"); - -=head1 ACCESSORS - -=head2 bug - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Bug id (matches bug) - -=head2 src_pkg - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Source package id (matches src_pkg) - -=cut - -__PACKAGE__->add_columns( - "bug", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "src_pkg", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, -); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("bug_affects_srcpackage_id_pkg", ["bug", "src_pkg"]); - -=head1 RELATIONS - -=head2 bug - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "bug", - "Debbugs::DB::Result::Bug", - { id => "bug" }, - { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, -); - -=head2 src_pkg - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "src_pkg", - "Debbugs::DB::Result::SrcPkg", - { id => "src_pkg" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-04 10:59:03 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:1TkTacVNBhXOnzV1ttCF2A - - -# You can replace this text with custom code or comments, and it will be preserved on regeneration -1; diff --git a/Debbugs/DB/Result/BugBinpackage.pm b/Debbugs/DB/Result/BugBinpackage.pm deleted file mode 100644 index 2f2a29d..0000000 --- a/Debbugs/DB/Result/BugBinpackage.pm +++ /dev/null @@ -1,139 +0,0 @@ -use utf8; -package Debbugs::DB::Result::BugBinpackage; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::BugBinpackage - Bug <-> binary package mapping - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("bug_binpackage"); - -=head1 ACCESSORS - -=head2 bug - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Bug id (matches bug) - -=head2 bin_pkg - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Binary package id (matches bin_pkg) - -=cut - -__PACKAGE__->add_columns( - "bug", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "bin_pkg", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, -); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("bug_binpackage_bin_pkg_bug_idx", ["bin_pkg", "bug"]); - -=head2 C - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("bug_binpackage_id_pkg", ["bug", "bin_pkg"]); - -=head1 RELATIONS - -=head2 bin_pkg - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "bin_pkg", - "Debbugs::DB::Result::BinPkg", - { id => "bin_pkg" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - -=head2 bug - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "bug", - "Debbugs::DB::Result::Bug", - { id => "bug" }, - { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07049 @ 2019-07-05 21:00:23 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:STaqCap5Dk4AORK6ghGnPg - - -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - $sqlt_table->add_index(name => 'bug_binpackage_bin_pkg_idx', - fields => [qw(bin_pkg)], - ); -} - -1; diff --git a/Debbugs/DB/Result/BugBlock.pm b/Debbugs/DB/Result/BugBlock.pm deleted file mode 100644 index 0200a31..0000000 --- a/Debbugs/DB/Result/BugBlock.pm +++ /dev/null @@ -1,152 +0,0 @@ -use utf8; -package Debbugs::DB::Result::BugBlock; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::BugBlock - Bugs which block other bugs - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("bug_blocks"); - -=head1 ACCESSORS - -=head2 id - - data_type: 'integer' - is_auto_increment: 1 - is_nullable: 0 - sequence: 'bug_blocks_id_seq' - -=head2 bug - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Bug number - -=head2 blocks - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Bug number which is blocked by bug - -=cut - -__PACKAGE__->add_columns( - "id", - { - data_type => "integer", - is_auto_increment => 1, - is_nullable => 0, - sequence => "bug_blocks_id_seq", - }, - "bug", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "blocks", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, -); - -=head1 PRIMARY KEY - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->set_primary_key("id"); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("bug_blocks_bug_id_blocks_idx", ["bug", "blocks"]); - -=head1 RELATIONS - -=head2 block - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "block", - "Debbugs::DB::Result::Bug", - { id => "blocks" }, - { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, -); - -=head2 bug - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "bug", - "Debbugs::DB::Result::Bug", - { id => "bug" }, - { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07042 @ 2014-11-30 21:56:51 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:Rkt0XlA4r2YFX0KnUZmS6A - - -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - for my $idx (qw(bug blocks)) { - $sqlt_table->add_index(name => 'bug_blocks_'.$idx.'_idx', - fields => [$idx]); - } -} - -1; diff --git a/Debbugs/DB/Result/BugMerged.pm b/Debbugs/DB/Result/BugMerged.pm deleted file mode 100644 index 477919b..0000000 --- a/Debbugs/DB/Result/BugMerged.pm +++ /dev/null @@ -1,151 +0,0 @@ -use utf8; -package Debbugs::DB::Result::BugMerged; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::BugMerged - Bugs which are merged with other bugs - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("bug_merged"); - -=head1 ACCESSORS - -=head2 id - - data_type: 'integer' - is_auto_increment: 1 - is_nullable: 0 - sequence: 'bug_merged_id_seq' - -=head2 bug - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Bug number - -=head2 merged - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Bug number which is merged with bug - -=cut - -__PACKAGE__->add_columns( - "id", - { - data_type => "integer", - is_auto_increment => 1, - is_nullable => 0, - sequence => "bug_merged_id_seq", - }, - "bug", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "merged", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, -); - -=head1 PRIMARY KEY - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->set_primary_key("id"); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("bug_merged_bug_id_merged_idx", ["bug", "merged"]); - -=head1 RELATIONS - -=head2 bug - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "bug", - "Debbugs::DB::Result::Bug", - { id => "bug" }, - { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, -); - -=head2 merged - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "merged", - "Debbugs::DB::Result::Bug", - { id => "merged" }, - { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07042 @ 2014-11-30 21:56:51 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:HdGeCb1Fh2cU08+TTQVi/Q - -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - for my $idx (qw(bug merged)) { - $sqlt_table->add_index(name => 'bug_merged_'.$idx.'_idx', - fields => [$idx]); - } -} - -1; diff --git a/Debbugs/DB/Result/BugMessage.pm b/Debbugs/DB/Result/BugMessage.pm deleted file mode 100644 index b5fccc5..0000000 --- a/Debbugs/DB/Result/BugMessage.pm +++ /dev/null @@ -1,150 +0,0 @@ -use utf8; -package Debbugs::DB::Result::BugMessage; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::BugMessage - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("bug_message"); - -=head1 ACCESSORS - -=head2 bug - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Bug id (matches bug) - -=head2 message - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Message id (matches message) - -=head2 message_number - - data_type: 'integer' - is_nullable: 0 - -Message number in the bug log - -=head2 bug_log_offset - - data_type: 'integer' - is_nullable: 1 - -Byte offset in the bug log - -=head2 offset_valid - - data_type: 'timestamp with time zone' - is_nullable: 1 - -Time offset was valid - -=cut - -__PACKAGE__->add_columns( - "bug", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "message", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "message_number", - { data_type => "integer", is_nullable => 0 }, - "bug_log_offset", - { data_type => "integer", is_nullable => 1 }, - "offset_valid", - { data_type => "timestamp with time zone", is_nullable => 1 }, -); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("bug_message_bug_message_idx", ["bug", "message"]); - -=head1 RELATIONS - -=head2 bug - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "bug", - "Debbugs::DB::Result::Bug", - { id => "bug" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - -=head2 message - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "message", - "Debbugs::DB::Result::Message", - { id => "message" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-04 10:59:03 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:BRbN9C6P/wvWWmSmjNGjLA - -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - $sqlt_table->add_index(name => 'bug_message_idx_bug_message_number', - fields => [qw(bug message_number)], - ); -} -1; diff --git a/Debbugs/DB/Result/BugPackage.pm b/Debbugs/DB/Result/BugPackage.pm deleted file mode 100644 index db6f200..0000000 --- a/Debbugs/DB/Result/BugPackage.pm +++ /dev/null @@ -1,86 +0,0 @@ -use utf8; -package Debbugs::DB::Result::BugPackage; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::BugPackage - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); -__PACKAGE__->table_class("DBIx::Class::ResultSource::View"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("bug_package"); -__PACKAGE__->result_source_instance->view_definition(" SELECT b.bug,\n b.bin_pkg AS pkg_id,\n 'binary'::text AS pkg_type,\n bp.pkg AS package\n FROM (bug_binpackage b\n JOIN bin_pkg bp ON ((bp.id = b.bin_pkg)))\nUNION\n SELECT s.bug,\n s.src_pkg AS pkg_id,\n 'source'::text AS pkg_type,\n sp.pkg AS package\n FROM (bug_srcpackage s\n JOIN src_pkg sp ON ((sp.id = s.src_pkg)))\nUNION\n SELECT b.bug,\n b.bin_pkg AS pkg_id,\n 'binary_affects'::text AS pkg_type,\n bp.pkg AS package\n FROM (bug_affects_binpackage b\n JOIN bin_pkg bp ON ((bp.id = b.bin_pkg)))\nUNION\n SELECT s.bug,\n s.src_pkg AS pkg_id,\n 'source_affects'::text AS pkg_type,\n sp.pkg AS package\n FROM (bug_affects_srcpackage s\n JOIN src_pkg sp ON ((sp.id = s.src_pkg)))"); - -=head1 ACCESSORS - -=head2 bug - - data_type: 'integer' - is_nullable: 1 - -=head2 pkg_id - - data_type: 'integer' - is_nullable: 1 - -=head2 pkg_type - - data_type: 'text' - is_nullable: 1 - -=head2 package - - data_type: 'text' - is_nullable: 1 - -=cut - -__PACKAGE__->add_columns( - "bug", - { data_type => "integer", is_nullable => 1 }, - "pkg_id", - { data_type => "integer", is_nullable => 1 }, - "pkg_type", - { data_type => "text", is_nullable => 1 }, - "package", - { data_type => "text", is_nullable => 1 }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-04-13 11:30:02 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:2Nrl+KO8b94gK5GcCkdNcw - -__PACKAGE__->result_source_instance->view_definition(< source package mapping - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("bug_srcpackage"); - -=head1 ACCESSORS - -=head2 bug - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Bug id (matches bug) - -=head2 src_pkg - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Source package id (matches src_pkg) - -=cut - -__PACKAGE__->add_columns( - "bug", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "src_pkg", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, -); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("bug_srcpackage_id_pkg", ["bug", "src_pkg"]); - -=head1 RELATIONS - -=head2 bug - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "bug", - "Debbugs::DB::Result::Bug", - { id => "bug" }, - { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, -); - -=head2 src_pkg - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "src_pkg", - "Debbugs::DB::Result::SrcPkg", - { id => "src_pkg" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-04 10:59:03 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:5SduyMaGHABDrX19Cxg4fg - -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - $sqlt_table->add_index(name => 'bug_srcpackage_src_pkg_idx', - fields => [qw(src_pkg)], - ); -} - -1; diff --git a/Debbugs/DB/Result/BugStatus.pm b/Debbugs/DB/Result/BugStatus.pm deleted file mode 100644 index ee3efc8..0000000 --- a/Debbugs/DB/Result/BugStatus.pm +++ /dev/null @@ -1,179 +0,0 @@ -use utf8; -package Debbugs::DB::Result::BugStatus; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::BugStatus - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); -__PACKAGE__->table_class("DBIx::Class::ResultSource::View"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("bug_status"); -__PACKAGE__->result_source_instance->view_definition(" SELECT b.id,\n b.id AS bug_num,\n string_agg(t.tag, ','::text) AS tags,\n b.subject,\n ( SELECT s.severity\n FROM severity s\n WHERE (s.id = b.severity)) AS severity,\n ( SELECT string_agg(package.package, ','::text ORDER BY package.package) AS string_agg\n FROM ( SELECT bp.pkg AS package\n FROM (bug_binpackage bbp\n JOIN bin_pkg bp ON ((bbp.bin_pkg = bp.id)))\n WHERE (bbp.bug = b.id)\n UNION\n SELECT concat('src:', sp.pkg) AS package\n FROM (bug_srcpackage bsp\n JOIN src_pkg sp ON ((bsp.src_pkg = sp.id)))\n WHERE (bsp.bug = b.id)) package) AS package,\n ( SELECT string_agg(affects.affects, ','::text ORDER BY affects.affects) AS string_agg\n FROM ( SELECT bp.pkg AS affects\n FROM (bug_affects_binpackage bbp\n JOIN bin_pkg bp ON ((bbp.bin_pkg = bp.id)))\n WHERE (bbp.bug = b.id)\n UNION\n SELECT concat('src:', sp.pkg) AS affects\n FROM (bug_affects_srcpackage bsp\n JOIN src_pkg sp ON ((bsp.src_pkg = sp.id)))\n WHERE (bsp.bug = b.id)) affects) AS affects,\n ( SELECT m.msgid\n FROM (message m\n LEFT JOIN bug_message bm ON ((bm.message = m.id)))\n WHERE (bm.bug = b.id)\n ORDER BY m.sent_date\n LIMIT 1) AS message_id,\n b.submitter_full AS originator,\n date_part('epoch'::text, b.log_modified) AS log_modified,\n date_part('epoch'::text, b.creation) AS date,\n date_part('epoch'::text, b.last_modified) AS last_modified,\n b.done_full AS done,\n string_agg((bb.blocks)::text, ' '::text ORDER BY bb.blocks) AS blocks,\n string_agg((bbb.bug)::text, ' '::text ORDER BY bbb.bug) AS blockedby,\n ( SELECT string_agg((bug.bug)::text, ' '::text ORDER BY bug.bug) AS string_agg\n FROM ( SELECT bm.merged AS bug\n FROM bug_merged bm\n WHERE (bm.bug = b.id)\n UNION\n SELECT bm.bug\n FROM bug_merged bm\n WHERE (bm.merged = b.id)) bug) AS mergedwith,\n ( SELECT string_agg(bv.ver_string, ' '::text) AS string_agg\n FROM bug_ver bv\n WHERE ((bv.bug = b.id) AND (bv.found IS TRUE))) AS found_versions,\n ( SELECT string_agg(bv.ver_string, ' '::text) AS string_agg\n FROM bug_ver bv\n WHERE ((bv.bug = b.id) AND (bv.found IS FALSE))) AS fixed_versions\n FROM ((((bug b\n LEFT JOIN bug_tag bt ON ((bt.bug = b.id)))\n LEFT JOIN tag t ON ((bt.tag = t.id)))\n LEFT JOIN bug_blocks bb ON ((bb.bug = b.id)))\n LEFT JOIN bug_blocks bbb ON ((bbb.blocks = b.id)))\n GROUP BY b.id"); - -=head1 ACCESSORS - -=head2 id - - data_type: 'integer' - is_nullable: 1 - -=head2 bug_num - - data_type: 'integer' - is_nullable: 1 - -=head2 tags - - data_type: 'text' - is_nullable: 1 - -=head2 subject - - data_type: 'text' - is_nullable: 1 - -=head2 severity - - data_type: 'text' - is_nullable: 1 - -=head2 package - - data_type: 'text' - is_nullable: 1 - -=head2 affects - - data_type: 'text' - is_nullable: 1 - -=head2 message_id - - data_type: 'text' - is_nullable: 1 - -=head2 originator - - data_type: 'text' - is_nullable: 1 - -=head2 log_modified - - data_type: 'double precision' - is_nullable: 1 - -=head2 date - - data_type: 'double precision' - is_nullable: 1 - -=head2 last_modified - - data_type: 'double precision' - is_nullable: 1 - -=head2 done - - data_type: 'text' - is_nullable: 1 - -=head2 blocks - - data_type: 'text' - is_nullable: 1 - -=head2 blockedby - - data_type: 'text' - is_nullable: 1 - -=head2 mergedwith - - data_type: 'text' - is_nullable: 1 - -=head2 found_versions - - data_type: 'text' - is_nullable: 1 - -=head2 fixed_versions - - data_type: 'text' - is_nullable: 1 - -=cut - -__PACKAGE__->add_columns( - "id", - { data_type => "integer", is_nullable => 1 }, - "bug_num", - { data_type => "integer", is_nullable => 1 }, - "tags", - { data_type => "text", is_nullable => 1 }, - "subject", - { data_type => "text", is_nullable => 1 }, - "severity", - { data_type => "text", is_nullable => 1 }, - "package", - { data_type => "text", is_nullable => 1 }, - "affects", - { data_type => "text", is_nullable => 1 }, - "message_id", - { data_type => "text", is_nullable => 1 }, - "originator", - { data_type => "text", is_nullable => 1 }, - "log_modified", - { data_type => "double precision", is_nullable => 1 }, - "date", - { data_type => "double precision", is_nullable => 1 }, - "last_modified", - { data_type => "double precision", is_nullable => 1 }, - "done", - { data_type => "text", is_nullable => 1 }, - "blocks", - { data_type => "text", is_nullable => 1 }, - "blockedby", - { data_type => "text", is_nullable => 1 }, - "mergedwith", - { data_type => "text", is_nullable => 1 }, - "found_versions", - { data_type => "text", is_nullable => 1 }, - "fixed_versions", - { data_type => "text", is_nullable => 1 }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07049 @ 2019-07-05 20:55:00 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:xkAEshcLIPrG/6hoRbSsrw - - -# You can replace this text with custom code or comments, and it will be preserved on regeneration -1; diff --git a/Debbugs/DB/Result/BugStatusCache.pm b/Debbugs/DB/Result/BugStatusCache.pm deleted file mode 100644 index 26b850e..0000000 --- a/Debbugs/DB/Result/BugStatusCache.pm +++ /dev/null @@ -1,220 +0,0 @@ -use utf8; -package Debbugs::DB::Result::BugStatusCache; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::BugStatusCache - Bug Status Cache - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("bug_status_cache"); - -=head1 ACCESSORS - -=head2 bug - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Bug number (matches bug) - -=head2 suite - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 1 - -Suite id (matches suite) - -=head2 arch - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 1 - -Architecture id (matches arch) - -=head2 status - - data_type: 'enum' - extra: {custom_type_name => "bug_status_type",list => ["absent","found","fixed","undef"]} - is_nullable: 0 - -Status (bug status) - -=head2 modified - - data_type: 'timestamp with time zone' - default_value: current_timestamp - is_nullable: 0 - original: {default_value => \"now()"} - -Time that this status was last modified - -=head2 asof - - data_type: 'timestamp with time zone' - default_value: current_timestamp - is_nullable: 0 - original: {default_value => \"now()"} - -Time that this status was last calculated - -=cut - -__PACKAGE__->add_columns( - "bug", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "suite", - { data_type => "integer", is_foreign_key => 1, is_nullable => 1 }, - "arch", - { data_type => "integer", is_foreign_key => 1, is_nullable => 1 }, - "status", - { - data_type => "enum", - extra => { - custom_type_name => "bug_status_type", - list => ["absent", "found", "fixed", "undef"], - }, - is_nullable => 0, - }, - "modified", - { - data_type => "timestamp with time zone", - default_value => \"current_timestamp", - is_nullable => 0, - original => { default_value => \"now()" }, - }, - "asof", - { - data_type => "timestamp with time zone", - default_value => \"current_timestamp", - is_nullable => 0, - original => { default_value => \"now()" }, - }, -); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint( - "bug_status_cache_bug_suite_arch_idx", - ["bug", "suite", "arch"], -); - -=head1 RELATIONS - -=head2 arch - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "arch", - "Debbugs::DB::Result::Arch", - { id => "arch" }, - { - is_deferrable => 0, - join_type => "LEFT", - on_delete => "CASCADE", - on_update => "CASCADE", - }, -); - -=head2 bug - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "bug", - "Debbugs::DB::Result::Bug", - { id => "bug" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - -=head2 suite - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "suite", - "Debbugs::DB::Result::Suite", - { id => "suite" }, - { - is_deferrable => 0, - join_type => "LEFT", - on_delete => "CASCADE", - on_update => "CASCADE", - }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-08-07 09:58:56 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:RNAken/j2+82FVCyCTnvQw - -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; -# $sqlt_table->add_index(name => 'bug_status_cache_bug_suite_arch_idx', -# fields => ['bug', -# q{COALESCE(suite,0)}, -# q{COALESCE(arch,0)},] -# ); - for my $f (qw(bug status arch suite asof)) { - $sqlt_table->add_index(name => 'bug_status_cache_idx_'.$f, - fields => [$f], - ); - } -} - -1; diff --git a/Debbugs/DB/Result/BugTag.pm b/Debbugs/DB/Result/BugTag.pm deleted file mode 100644 index f5c6c24..0000000 --- a/Debbugs/DB/Result/BugTag.pm +++ /dev/null @@ -1,125 +0,0 @@ -use utf8; -package Debbugs::DB::Result::BugTag; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::BugTag - Bug <-> tag mapping - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("bug_tag"); - -=head1 ACCESSORS - -=head2 bug - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Bug id (matches bug) - -=head2 tag - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Tag id (matches tag) - -=cut - -__PACKAGE__->add_columns( - "bug", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "tag", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, -); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("bug_tag_bug_tag", ["bug", "tag"]); - -=head1 RELATIONS - -=head2 bug - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "bug", - "Debbugs::DB::Result::Bug", - { id => "bug" }, - { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, -); - -=head2 tag - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "tag", - "Debbugs::DB::Result::Tag", - { id => "tag" }, - { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-04 10:59:03 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:yyHP5f8zAxn/AdjOCr8WAg - - -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - $sqlt_table->add_index(name => 'bug_tag_tag', - fields => [qw(tag)], - ); -} - -1; diff --git a/Debbugs/DB/Result/BugUserTag.pm b/Debbugs/DB/Result/BugUserTag.pm deleted file mode 100644 index 6d83c63..0000000 --- a/Debbugs/DB/Result/BugUserTag.pm +++ /dev/null @@ -1,123 +0,0 @@ -use utf8; -package Debbugs::DB::Result::BugUserTag; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::BugUserTag - Bug <-> user tag mapping - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("bug_user_tag"); - -=head1 ACCESSORS - -=head2 bug - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Bug id (matches bug) - -=head2 user_tag - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -=cut - -__PACKAGE__->add_columns( - "bug", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "user_tag", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, -); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("bug_user_tag_bug_tag", ["bug", "user_tag"]); - -=head1 RELATIONS - -=head2 bug - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "bug", - "Debbugs::DB::Result::Bug", - { id => "bug" }, - { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, -); - -=head2 user_tag - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "user_tag", - "Debbugs::DB::Result::UserTag", - { id => "user_tag" }, - { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-04 10:59:03 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:jZngUCQ1eBBcfXd/jWCKGA - - -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - $sqlt_table->add_index(name => 'bug_user_tag_tag', - fields => [qw(user_tag)], - ); -} - -1; diff --git a/Debbugs/DB/Result/BugVer.pm b/Debbugs/DB/Result/BugVer.pm deleted file mode 100644 index 472a1df..0000000 --- a/Debbugs/DB/Result/BugVer.pm +++ /dev/null @@ -1,247 +0,0 @@ -use utf8; -package Debbugs::DB::Result::BugVer; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::BugVer - Bug versions - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("bug_ver"); - -=head1 ACCESSORS - -=head2 id - - data_type: 'integer' - is_auto_increment: 1 - is_nullable: 0 - sequence: 'bug_ver_id_seq' - -Bug version id - -=head2 bug - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Bug number - -=head2 ver_string - - data_type: 'text' - is_nullable: 1 - -Version string - -=head2 src_pkg - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 1 - -Source package id (matches src_pkg table) - -=head2 src_ver - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 1 - -Source package version id (matches src_ver table) - -=head2 found - - data_type: 'boolean' - default_value: true - is_nullable: 0 - -True if this is a found version; false if this is a fixed version - -=head2 creation - - data_type: 'timestamp with time zone' - default_value: current_timestamp - is_nullable: 0 - original: {default_value => \"now()"} - -Time that this entry was created - -=head2 last_modified - - data_type: 'timestamp with time zone' - default_value: current_timestamp - is_nullable: 0 - original: {default_value => \"now()"} - -Time that this entry was modified - -=cut - -__PACKAGE__->add_columns( - "id", - { - data_type => "integer", - is_auto_increment => 1, - is_nullable => 0, - sequence => "bug_ver_id_seq", - }, - "bug", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "ver_string", - { data_type => "text", is_nullable => 1 }, - "src_pkg", - { data_type => "integer", is_foreign_key => 1, is_nullable => 1 }, - "src_ver", - { data_type => "integer", is_foreign_key => 1, is_nullable => 1 }, - "found", - { data_type => "boolean", default_value => \"true", is_nullable => 0 }, - "creation", - { - data_type => "timestamp with time zone", - default_value => \"current_timestamp", - is_nullable => 0, - original => { default_value => \"now()" }, - }, - "last_modified", - { - data_type => "timestamp with time zone", - default_value => \"current_timestamp", - is_nullable => 0, - original => { default_value => \"now()" }, - }, -); - -=head1 PRIMARY KEY - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->set_primary_key("id"); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint( - "bug_ver_bug_ver_string_found_idx", - ["bug", "ver_string", "found"], -); - -=head1 RELATIONS - -=head2 bug - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "bug", - "Debbugs::DB::Result::Bug", - { id => "bug" }, - { is_deferrable => 0, on_delete => "RESTRICT", on_update => "CASCADE" }, -); - -=head2 src_pkg - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "src_pkg", - "Debbugs::DB::Result::SrcPkg", - { id => "src_pkg" }, - { - is_deferrable => 0, - join_type => "LEFT", - on_delete => "SET NULL", - on_update => "CASCADE", - }, -); - -=head2 src_ver - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "src_ver", - "Debbugs::DB::Result::SrcVer", - { id => "src_ver" }, - { - is_deferrable => 0, - join_type => "LEFT", - on_delete => "SET NULL", - on_update => "CASCADE", - }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07042 @ 2014-11-30 21:56:51 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:cvdjFL2o+rBg2PfcintuNA - - -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - for my $idx (qw(src_pkg src_ver)) { - $sqlt_table->add_index(name => 'bug_ver_'.$idx.'_id_idx', - fields => [$idx]); - } - $sqlt_table->add_index(name => 'bug_ver_src_pkg_id_src_ver_id_idx', - fields => [qw(src_pkg src_ver)], - ); -} -1; diff --git a/Debbugs/DB/Result/Correspondent.pm b/Debbugs/DB/Result/Correspondent.pm deleted file mode 100644 index b0a57ae..0000000 --- a/Debbugs/DB/Result/Correspondent.pm +++ /dev/null @@ -1,209 +0,0 @@ -use utf8; -package Debbugs::DB::Result::Correspondent; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::Correspondent - Individual who has corresponded with the BTS - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("correspondent"); - -=head1 ACCESSORS - -=head2 id - - data_type: 'integer' - is_auto_increment: 1 - is_nullable: 0 - sequence: 'correspondent_id_seq' - -Correspondent ID - -=head2 addr - - data_type: 'text' - is_nullable: 0 - -Correspondent address - -=cut - -__PACKAGE__->add_columns( - "id", - { - data_type => "integer", - is_auto_increment => 1, - is_nullable => 0, - sequence => "correspondent_id_seq", - }, - "addr", - { data_type => "text", is_nullable => 0 }, -); - -=head1 PRIMARY KEY - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->set_primary_key("id"); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("correspondent_addr_idx", ["addr"]); - -=head1 RELATIONS - -=head2 bug_owners - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_owners", - "Debbugs::DB::Result::Bug", - { "foreign.owner" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bug_submitters - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_submitters", - "Debbugs::DB::Result::Bug", - { "foreign.submitter" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bugs_done - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bugs_done", - "Debbugs::DB::Result::Bug", - { "foreign.done" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 correspondent_full_names - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "correspondent_full_names", - "Debbugs::DB::Result::CorrespondentFullName", - { "foreign.correspondent" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 maintainers - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "maintainers", - "Debbugs::DB::Result::Maintainer", - { "foreign.correspondent" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 message_correspondents - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "message_correspondents", - "Debbugs::DB::Result::MessageCorrespondent", - { "foreign.correspondent" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 user_tags - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "user_tags", - "Debbugs::DB::Result::UserTag", - { "foreign.correspondent" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07045 @ 2016-09-24 14:51:07 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:CUVcqt94wCYJOPbiPt00+Q - - -# You can replace this text with custom code or comments, and it will be preserved on regeneration -1; diff --git a/Debbugs/DB/Result/CorrespondentFullName.pm b/Debbugs/DB/Result/CorrespondentFullName.pm deleted file mode 100644 index a5be283..0000000 --- a/Debbugs/DB/Result/CorrespondentFullName.pm +++ /dev/null @@ -1,126 +0,0 @@ -use utf8; -package Debbugs::DB::Result::CorrespondentFullName; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::CorrespondentFullName - Full names of BTS correspondents - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("correspondent_full_name"); - -=head1 ACCESSORS - -=head2 correspondent - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Correspondent ID (matches correspondent) - -=head2 full_name - - data_type: 'text' - is_nullable: 0 - -Correspondent full name (includes e-mail address) - -=head2 last_seen - - data_type: 'timestamp' - default_value: current_timestamp - is_nullable: 0 - original: {default_value => \"now()"} - -=cut - -__PACKAGE__->add_columns( - "correspondent", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "full_name", - { data_type => "text", is_nullable => 0 }, - "last_seen", - { - data_type => "timestamp", - default_value => \"current_timestamp", - is_nullable => 0, - original => { default_value => \"now()" }, - }, -); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint( - "correspondent_full_name_correspondent_full_name_idx", - ["correspondent", "full_name"], -); - -=head1 RELATIONS - -=head2 correspondent - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "correspondent", - "Debbugs::DB::Result::Correspondent", - { id => "correspondent" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-04 10:59:03 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:2Ac8mrDV2IsE/11YsYoqQQ - -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - for my $idx (qw(full_name last_seen)) { - $sqlt_table->add_index(name => 'correspondent_full_name_idx_'.$idx, - fields => [$idx]); - } -} - -1; diff --git a/Debbugs/DB/Result/Maintainer.pm b/Debbugs/DB/Result/Maintainer.pm deleted file mode 100644 index d8c04ec..0000000 --- a/Debbugs/DB/Result/Maintainer.pm +++ /dev/null @@ -1,181 +0,0 @@ -use utf8; -package Debbugs::DB::Result::Maintainer; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::Maintainer - Package maintainer names - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("maintainer"); - -=head1 ACCESSORS - -=head2 id - - data_type: 'integer' - is_auto_increment: 1 - is_nullable: 0 - sequence: 'maintainer_id_seq' - -Package maintainer id - -=head2 name - - data_type: 'text' - is_nullable: 0 - -Name of package maintainer - -=head2 correspondent - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Correspondent ID - -=head2 created - - data_type: 'timestamp with time zone' - default_value: current_timestamp - is_nullable: 0 - original: {default_value => \"now()"} - -Time maintainer record created - -=head2 modified - - data_type: 'timestamp with time zone' - default_value: current_timestamp - is_nullable: 0 - original: {default_value => \"now()"} - -Time maintainer record modified - -=cut - -__PACKAGE__->add_columns( - "id", - { - data_type => "integer", - is_auto_increment => 1, - is_nullable => 0, - sequence => "maintainer_id_seq", - }, - "name", - { data_type => "text", is_nullable => 0 }, - "correspondent", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "created", - { - data_type => "timestamp with time zone", - default_value => \"current_timestamp", - is_nullable => 0, - original => { default_value => \"now()" }, - }, - "modified", - { - data_type => "timestamp with time zone", - default_value => \"current_timestamp", - is_nullable => 0, - original => { default_value => \"now()" }, - }, -); - -=head1 PRIMARY KEY - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->set_primary_key("id"); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("maintainer_name_idx", ["name"]); - -=head1 RELATIONS - -=head2 correspondent - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "correspondent", - "Debbugs::DB::Result::Correspondent", - { id => "correspondent" }, - { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, -); - -=head2 src_vers - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "src_vers", - "Debbugs::DB::Result::SrcVer", - { "foreign.maintainer" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07042 @ 2014-11-30 21:56:51 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:rkpgeXltH2wiC1Us7FIijw - -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - $sqlt_table->add_index(name => 'maintainer_idx_correspondent', - fields => [qw(correspondent)], - ); -} - -1; diff --git a/Debbugs/DB/Result/Message.pm b/Debbugs/DB/Result/Message.pm deleted file mode 100644 index cd42f48..0000000 --- a/Debbugs/DB/Result/Message.pm +++ /dev/null @@ -1,255 +0,0 @@ -use utf8; -package Debbugs::DB::Result::Message; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::Message - Messages sent to bugs - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("message"); - -=head1 ACCESSORS - -=head2 id - - data_type: 'integer' - is_auto_increment: 1 - is_nullable: 0 - sequence: 'message_id_seq' - -Message id - -=head2 msgid - - data_type: 'text' - default_value: (empty string) - is_nullable: 0 - -Message id header - -=head2 from_complete - - data_type: 'text' - default_value: (empty string) - is_nullable: 0 - -Complete from header of message - -=head2 to_complete - - data_type: 'text' - default_value: (empty string) - is_nullable: 0 - -Complete to header of message - -=head2 subject - - data_type: 'text' - default_value: (empty string) - is_nullable: 0 - -Subject of the message - -=head2 sent_date - - data_type: 'timestamp with time zone' - is_nullable: 1 - -Time/date message was sent (from Date header) - -=head2 refs - - data_type: 'text' - default_value: (empty string) - is_nullable: 0 - -Contents of References: header - -=head2 spam_score - - data_type: 'double precision' - default_value: 0 - is_nullable: 0 - -Spam score from spamassassin - -=head2 is_spam - - data_type: 'boolean' - default_value: false - is_nullable: 0 - -True if this message was spam and should not be shown - -=cut - -__PACKAGE__->add_columns( - "id", - { - data_type => "integer", - is_auto_increment => 1, - is_nullable => 0, - sequence => "message_id_seq", - }, - "msgid", - { data_type => "text", default_value => "", is_nullable => 0 }, - "from_complete", - { data_type => "text", default_value => "", is_nullable => 0 }, - "to_complete", - { data_type => "text", default_value => "", is_nullable => 0 }, - "subject", - { data_type => "text", default_value => "", is_nullable => 0 }, - "sent_date", - { data_type => "timestamp with time zone", is_nullable => 1 }, - "refs", - { data_type => "text", default_value => "", is_nullable => 0 }, - "spam_score", - { data_type => "double precision", default_value => 0, is_nullable => 0 }, - "is_spam", - { data_type => "boolean", default_value => \"false", is_nullable => 0 }, -); - -=head1 PRIMARY KEY - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->set_primary_key("id"); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint( - "message_msgid_from_complete_to_complete_subject_idx", - ["msgid", "from_complete", "to_complete", "subject"], -); - -=head1 RELATIONS - -=head2 bug_messages - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_messages", - "Debbugs::DB::Result::BugMessage", - { "foreign.message" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 message_correspondents - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "message_correspondents", - "Debbugs::DB::Result::MessageCorrespondent", - { "foreign.message" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 message_refs_messages - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "message_refs_messages", - "Debbugs::DB::Result::MessageRef", - { "foreign.message" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 message_refs_refs - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "message_refs_refs", - "Debbugs::DB::Result::MessageRef", - { "foreign.refs" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-07 19:03:32 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:n8U0vD9R8M5wFoeoLlIWeQ - -__PACKAGE__->many_to_many(bugs => 'bug_messages','bug'); -__PACKAGE__->many_to_many(correspondents => 'message_correspondents','correspondent'); -__PACKAGE__->many_to_many(references => 'message_refs_message','message'); -__PACKAGE__->many_to_many(referenced_by => 'message_refs_refs','message'); - - -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - for my $idx (qw(msgid subject)) { - $sqlt_table->add_index(name => 'message_'.$idx.'_idx', - fields => [$idx]); - } -} - -1; diff --git a/Debbugs/DB/Result/MessageCorrespondent.pm b/Debbugs/DB/Result/MessageCorrespondent.pm deleted file mode 100644 index ddc79d1..0000000 --- a/Debbugs/DB/Result/MessageCorrespondent.pm +++ /dev/null @@ -1,150 +0,0 @@ -use utf8; -package Debbugs::DB::Result::MessageCorrespondent; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::MessageCorrespondent - Linkage between correspondent and message - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("message_correspondent"); - -=head1 ACCESSORS - -=head2 message - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Message id (matches message) - -=head2 correspondent - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Correspondent (matches correspondent) - -=head2 correspondent_type - - data_type: 'enum' - default_value: 'to' - extra: {custom_type_name => "message_correspondent_type",list => ["to","from","envfrom","cc","recv"]} - is_nullable: 0 - -Type of correspondent (to, from, envfrom, cc, etc.) - -=cut - -__PACKAGE__->add_columns( - "message", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "correspondent", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "correspondent_type", - { - data_type => "enum", - default_value => "to", - extra => { - custom_type_name => "message_correspondent_type", - list => ["to", "from", "envfrom", "cc", "recv"], - }, - is_nullable => 0, - }, -); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint( - "message_correspondent_message_correspondent_correspondent_t_idx", - ["message", "correspondent", "correspondent_type"], -); - -=head1 RELATIONS - -=head2 correspondent - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "correspondent", - "Debbugs::DB::Result::Correspondent", - { id => "correspondent" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - -=head2 message - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "message", - "Debbugs::DB::Result::Message", - { id => "message" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-07 19:03:32 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:kIhya7skj4ZNM3DkC+gAPw - - -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - for my $idx (qw(correspondent message)) { - $sqlt_table->add_index(name => 'message_correspondent_idx'.$idx, - fields => [$idx]); - } -} - -1; diff --git a/Debbugs/DB/Result/MessageRef.pm b/Debbugs/DB/Result/MessageRef.pm deleted file mode 100644 index 98e2a2d..0000000 --- a/Debbugs/DB/Result/MessageRef.pm +++ /dev/null @@ -1,145 +0,0 @@ -use utf8; -package Debbugs::DB::Result::MessageRef; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::MessageRef - Message references - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("message_refs"); - -=head1 ACCESSORS - -=head2 message - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Message id (matches message) - -=head2 refs - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Reference id (matches message) - -=head2 inferred - - data_type: 'boolean' - default_value: false - is_nullable: 1 - -TRUE if this message reference was reconstructed; primarily of use for messages which lack In-Reply-To: or References: headers - -=head2 primary_ref - - data_type: 'boolean' - default_value: false - is_nullable: 1 - -TRUE if this message->ref came from In-Reply-To: or similar. - -=cut - -__PACKAGE__->add_columns( - "message", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "refs", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "inferred", - { data_type => "boolean", default_value => \"false", is_nullable => 1 }, - "primary_ref", - { data_type => "boolean", default_value => \"false", is_nullable => 1 }, -); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("message_refs_message_refs_idx", ["message", "refs"]); - -=head1 RELATIONS - -=head2 message - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "message", - "Debbugs::DB::Result::Message", - { id => "message" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - -=head2 ref - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "ref", - "Debbugs::DB::Result::Message", - { id => "refs" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-04 10:59:03 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:0YaAP/sB5N2Xr2rAFNK1lg - -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - for my $idx (qw(refs message)) { - $sqlt_table->add_index(name => 'message_refs_idx_'.$idx, - fields => [$idx]); - } -} - -1; diff --git a/Debbugs/DB/Result/Severity.pm b/Debbugs/DB/Result/Severity.pm deleted file mode 100644 index edea9a9..0000000 --- a/Debbugs/DB/Result/Severity.pm +++ /dev/null @@ -1,154 +0,0 @@ -use utf8; -package Debbugs::DB::Result::Severity; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::Severity - Bug severity - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("severity"); - -=head1 ACCESSORS - -=head2 id - - data_type: 'integer' - is_auto_increment: 1 - is_nullable: 0 - sequence: 'severity_id_seq' - -Severity id - -=head2 severity - - data_type: 'text' - is_nullable: 0 - -Severity name - -=head2 ordering - - data_type: 'integer' - default_value: 5 - is_nullable: 0 - -Severity ordering (more severe severities have higher numbers) - -=head2 strong - - data_type: 'boolean' - default_value: false - is_nullable: 1 - -True if severity is a strong severity - -=head2 obsolete - - data_type: 'boolean' - default_value: false - is_nullable: 1 - -Whether a severity level is obsolete (should not be set on new bugs) - -=cut - -__PACKAGE__->add_columns( - "id", - { - data_type => "integer", - is_auto_increment => 1, - is_nullable => 0, - sequence => "severity_id_seq", - }, - "severity", - { data_type => "text", is_nullable => 0 }, - "ordering", - { data_type => "integer", default_value => 5, is_nullable => 0 }, - "strong", - { data_type => "boolean", default_value => \"false", is_nullable => 1 }, - "obsolete", - { data_type => "boolean", default_value => \"false", is_nullable => 1 }, -); - -=head1 PRIMARY KEY - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->set_primary_key("id"); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("severity_severity_idx", ["severity"]); - -=head1 RELATIONS - -=head2 bugs - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bugs", - "Debbugs::DB::Result::Bug", - { "foreign.severity" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07042 @ 2014-11-30 21:56:51 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:nI4ZqWa6IW7LgWuG7S1Gog - -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - $sqlt_table->add_index(name => 'severity_ordering_idx', - fields => [qw(ordering)], - ); -} - -1; diff --git a/Debbugs/DB/Result/SrcAssociation.pm b/Debbugs/DB/Result/SrcAssociation.pm deleted file mode 100644 index 01ac4bd..0000000 --- a/Debbugs/DB/Result/SrcAssociation.pm +++ /dev/null @@ -1,179 +0,0 @@ -use utf8; -package Debbugs::DB::Result::SrcAssociation; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::SrcAssociation - Source <-> suite associations - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("src_associations"); - -=head1 ACCESSORS - -=head2 id - - data_type: 'integer' - is_auto_increment: 1 - is_nullable: 0 - sequence: 'src_associations_id_seq' - -Source <-> suite association id - -=head2 suite - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Suite id (matches suite) - -=head2 source - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Source version id (matches src_ver) - -=head2 created - - data_type: 'timestamp with time zone' - default_value: current_timestamp - is_nullable: 0 - original: {default_value => \"now()"} - -Time this source package entered this suite - -=head2 modified - - data_type: 'timestamp with time zone' - default_value: current_timestamp - is_nullable: 0 - original: {default_value => \"now()"} - -Time this entry was modified - -=cut - -__PACKAGE__->add_columns( - "id", - { - data_type => "integer", - is_auto_increment => 1, - is_nullable => 0, - sequence => "src_associations_id_seq", - }, - "suite", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "source", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "created", - { - data_type => "timestamp with time zone", - default_value => \"current_timestamp", - is_nullable => 0, - original => { default_value => \"now()" }, - }, - "modified", - { - data_type => "timestamp with time zone", - default_value => \"current_timestamp", - is_nullable => 0, - original => { default_value => \"now()" }, - }, -); - -=head1 PRIMARY KEY - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->set_primary_key("id"); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("src_associations_source_suite", ["source", "suite"]); - -=head1 RELATIONS - -=head2 source - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "source", - "Debbugs::DB::Result::SrcVer", - { id => "source" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - -=head2 suite - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "suite", - "Debbugs::DB::Result::Suite", - { id => "suite" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07045 @ 2016-11-24 08:52:49 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:B3gOeYD0JxOUtV92mBocZQ - - -# You can replace this text with custom code or comments, and it will be preserved on regeneration -1; diff --git a/Debbugs/DB/Result/SrcPkg.pm b/Debbugs/DB/Result/SrcPkg.pm deleted file mode 100644 index 26e56a4..0000000 --- a/Debbugs/DB/Result/SrcPkg.pm +++ /dev/null @@ -1,287 +0,0 @@ -use utf8; -package Debbugs::DB::Result::SrcPkg; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::SrcPkg - Source packages - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("src_pkg"); - -=head1 ACCESSORS - -=head2 id - - data_type: 'integer' - is_auto_increment: 1 - is_nullable: 0 - sequence: 'src_pkg_id_seq' - -Source package id - -=head2 pkg - - data_type: 'text' - is_nullable: 0 - -Source package name - -=head2 pseduopkg - - data_type: 'boolean' - default_value: false - is_nullable: 0 - -=head2 alias_of - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 1 - -Source package id which this source package is an alias of - -=head2 creation - - data_type: 'timestamp with time zone' - default_value: current_timestamp - is_nullable: 0 - original: {default_value => \"now()"} - -=head2 disabled - - data_type: 'timestamp with time zone' - default_value: infinity - is_nullable: 0 - -=head2 last_modified - - data_type: 'timestamp with time zone' - default_value: current_timestamp - is_nullable: 0 - original: {default_value => \"now()"} - -=head2 obsolete - - data_type: 'boolean' - default_value: false - is_nullable: 0 - -=cut - -__PACKAGE__->add_columns( - "id", - { - data_type => "integer", - is_auto_increment => 1, - is_nullable => 0, - sequence => "src_pkg_id_seq", - }, - "pkg", - { data_type => "text", is_nullable => 0 }, - "pseduopkg", - { data_type => "boolean", default_value => \"false", is_nullable => 0 }, - "alias_of", - { data_type => "integer", is_foreign_key => 1, is_nullable => 1 }, - "creation", - { - data_type => "timestamp with time zone", - default_value => \"current_timestamp", - is_nullable => 0, - original => { default_value => \"now()" }, - }, - "disabled", - { - data_type => "timestamp with time zone", - default_value => "infinity", - is_nullable => 0, - }, - "last_modified", - { - data_type => "timestamp with time zone", - default_value => \"current_timestamp", - is_nullable => 0, - original => { default_value => \"now()" }, - }, - "obsolete", - { data_type => "boolean", default_value => \"false", is_nullable => 0 }, -); - -=head1 PRIMARY KEY - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->set_primary_key("id"); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("src_pkg_pkg_disabled", ["pkg", "disabled"]); - -=head1 RELATIONS - -=head2 alias_of - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "alias_of", - "Debbugs::DB::Result::SrcPkg", - { id => "alias_of" }, - { - is_deferrable => 0, - join_type => "LEFT", - on_delete => "CASCADE", - on_update => "CASCADE", - }, -); - -=head2 bin_pkg_src_pkgs - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bin_pkg_src_pkgs", - "Debbugs::DB::Result::BinPkgSrcPkg", - { "foreign.src_pkg" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bug_affects_srcpackages - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_affects_srcpackages", - "Debbugs::DB::Result::BugAffectsSrcpackage", - { "foreign.src_pkg" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bug_srcpackages - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_srcpackages", - "Debbugs::DB::Result::BugSrcpackage", - { "foreign.src_pkg" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bug_vers - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_vers", - "Debbugs::DB::Result::BugVer", - { "foreign.src_pkg" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 src_pkgs - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "src_pkgs", - "Debbugs::DB::Result::SrcPkg", - { "foreign.alias_of" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 src_vers - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "src_vers", - "Debbugs::DB::Result::SrcVer", - { "foreign.src_pkg" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07049 @ 2019-07-05 20:56:47 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:G2uhLQ7coWRoAHFiDkF5cQ - - -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - $sqlt_table->add_index(name => 'src_pkg_pkg', - fields => 'pkg', - ); -} -1; diff --git a/Debbugs/DB/Result/SrcVer.pm b/Debbugs/DB/Result/SrcVer.pm deleted file mode 100644 index 4181c1e..0000000 --- a/Debbugs/DB/Result/SrcVer.pm +++ /dev/null @@ -1,285 +0,0 @@ -use utf8; -package Debbugs::DB::Result::SrcVer; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::SrcVer - Source Package versions - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("src_ver"); - -=head1 ACCESSORS - -=head2 id - - data_type: 'integer' - is_auto_increment: 1 - is_nullable: 0 - sequence: 'src_ver_id_seq' - -Source package version id - -=head2 src_pkg - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -Source package id (matches src_pkg table) - -=head2 ver - - data_type: 'debversion' - is_nullable: 0 - -Version of the source package - -=head2 maintainer - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 1 - -Maintainer id (matches maintainer table) - -=head2 upload_date - - data_type: 'timestamp with time zone' - default_value: current_timestamp - is_nullable: 0 - original: {default_value => \"now()"} - -Date this version of the source package was uploaded - -=head2 based_on - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 1 - -Source package version this version is based on - -=cut - -__PACKAGE__->add_columns( - "id", - { - data_type => "integer", - is_auto_increment => 1, - is_nullable => 0, - sequence => "src_ver_id_seq", - }, - "src_pkg", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, - "ver", - { data_type => "debversion", is_nullable => 0 }, - "maintainer", - { data_type => "integer", is_foreign_key => 1, is_nullable => 1 }, - "upload_date", - { - data_type => "timestamp with time zone", - default_value => \"current_timestamp", - is_nullable => 0, - original => { default_value => \"now()" }, - }, - "based_on", - { data_type => "integer", is_foreign_key => 1, is_nullable => 1 }, -); - -=head1 PRIMARY KEY - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->set_primary_key("id"); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("src_ver_src_pkg_id_ver", ["src_pkg", "ver"]); - -=head1 RELATIONS - -=head2 based_on - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "based_on", - "Debbugs::DB::Result::SrcVer", - { id => "based_on" }, - { - is_deferrable => 0, - join_type => "LEFT", - on_delete => "CASCADE", - on_update => "CASCADE", - }, -); - -=head2 bin_vers - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bin_vers", - "Debbugs::DB::Result::BinVer", - { "foreign.src_ver" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bug_vers - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_vers", - "Debbugs::DB::Result::BugVer", - { "foreign.src_ver" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 maintainer - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "maintainer", - "Debbugs::DB::Result::Maintainer", - { id => "maintainer" }, - { - is_deferrable => 0, - join_type => "LEFT", - on_delete => "SET NULL", - on_update => "CASCADE", - }, -); - -=head2 src_associations - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "src_associations", - "Debbugs::DB::Result::SrcAssociation", - { "foreign.source" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 src_pkg - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "src_pkg", - "Debbugs::DB::Result::SrcPkg", - { id => "src_pkg" }, - { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, -); - -=head2 src_vers - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "src_vers", - "Debbugs::DB::Result::SrcVer", - { "foreign.based_on" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07042 @ 2014-11-30 21:56:51 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:gY5LidUaQeuJ5AnN06CfKQ - - -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - $sqlt_table->schema-> - add_procedure(name => 'src_ver_to_src_pkg', - sql => <<'EOF', -CREATE OR REPLACE FUNCTION src_ver_to_src_pkg(src_ver INT) RETURNS INT - AS $src_ver_to_src_pkg$ - DECLARE - src_pkg int; - BEGIN - SELECT sv.src_pkg INTO STRICT src_pkg - FROM src_ver sv WHERE sv.id=src_ver; - RETURN src_pkg; - END - $src_ver_to_src_pkg$ LANGUAGE plpgsql; -EOF - ); -} -# You can replace this text with custom code or comments, and it will be preserved on regeneration -1; diff --git a/Debbugs/DB/Result/Suite.pm b/Debbugs/DB/Result/Suite.pm deleted file mode 100644 index 37c875c..0000000 --- a/Debbugs/DB/Result/Suite.pm +++ /dev/null @@ -1,201 +0,0 @@ -use utf8; -package Debbugs::DB::Result::Suite; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::Suite - Debian Release Suite (stable, testing, etc.) - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("suite"); - -=head1 ACCESSORS - -=head2 id - - data_type: 'integer' - is_auto_increment: 1 - is_nullable: 0 - sequence: 'suite_id_seq' - -Suite id - -=head2 codename - - data_type: 'text' - is_nullable: 0 - -Suite codename (sid, squeeze, etc.) - -=head2 suite_name - - data_type: 'text' - is_nullable: 1 - -Suite name (testing, stable, etc.) - -=head2 version - - data_type: 'text' - is_nullable: 1 - -Suite version; NULL if there is no appropriate version - -=head2 active - - data_type: 'boolean' - default_value: true - is_nullable: 1 - -TRUE if the suite is still accepting uploads - -=cut - -__PACKAGE__->add_columns( - "id", - { - data_type => "integer", - is_auto_increment => 1, - is_nullable => 0, - sequence => "suite_id_seq", - }, - "codename", - { data_type => "text", is_nullable => 0 }, - "suite_name", - { data_type => "text", is_nullable => 1 }, - "version", - { data_type => "text", is_nullable => 1 }, - "active", - { data_type => "boolean", default_value => \"true", is_nullable => 1 }, -); - -=head1 PRIMARY KEY - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->set_primary_key("id"); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("suite_idx_codename", ["codename"]); - -=head2 C - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("suite_idx_version", ["version"]); - -=head2 C - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("suite_suite_name_key", ["suite_name"]); - -=head1 RELATIONS - -=head2 bin_associations - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bin_associations", - "Debbugs::DB::Result::BinAssociation", - { "foreign.suite" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 bug_status_caches - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_status_caches", - "Debbugs::DB::Result::BugStatusCache", - { "foreign.suite" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 src_associations - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "src_associations", - "Debbugs::DB::Result::SrcAssociation", - { "foreign.suite" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07045 @ 2016-11-24 08:52:49 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:nXoQCYZhM9cFgC1x+RY9rA - - -# You can replace this text with custom code or comments, and it will be preserved on regeneration -1; diff --git a/Debbugs/DB/Result/Tag.pm b/Debbugs/DB/Result/Tag.pm deleted file mode 100644 index c8d5397..0000000 --- a/Debbugs/DB/Result/Tag.pm +++ /dev/null @@ -1,129 +0,0 @@ -use utf8; -package Debbugs::DB::Result::Tag; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::Tag - Bug tags - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("tag"); - -=head1 ACCESSORS - -=head2 id - - data_type: 'integer' - is_auto_increment: 1 - is_nullable: 0 - sequence: 'tag_id_seq' - -Tag id - -=head2 tag - - data_type: 'text' - is_nullable: 0 - -Tag name - -=head2 obsolete - - data_type: 'boolean' - default_value: false - is_nullable: 1 - -Whether a tag is obsolete (should not be set on new bugs) - -=cut - -__PACKAGE__->add_columns( - "id", - { - data_type => "integer", - is_auto_increment => 1, - is_nullable => 0, - sequence => "tag_id_seq", - }, - "tag", - { data_type => "text", is_nullable => 0 }, - "obsolete", - { data_type => "boolean", default_value => \"false", is_nullable => 1 }, -); - -=head1 PRIMARY KEY - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->set_primary_key("id"); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("tag_tag_key", ["tag"]); - -=head1 RELATIONS - -=head2 bug_tags - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_tags", - "Debbugs::DB::Result::BugTag", - { "foreign.tag" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07042 @ 2014-11-30 21:56:51 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:HH2aKSj4xl+co6qffSdrrQ - - -# You can replace this text with custom code or comments, and it will be preserved on regeneration -1; diff --git a/Debbugs/DB/Result/UserTag.pm b/Debbugs/DB/Result/UserTag.pm deleted file mode 100644 index 0883a2e..0000000 --- a/Debbugs/DB/Result/UserTag.pm +++ /dev/null @@ -1,151 +0,0 @@ -use utf8; -package Debbugs::DB::Result::UserTag; - -# Created by DBIx::Class::Schema::Loader -# DO NOT MODIFY THE FIRST PART OF THIS FILE - -=head1 NAME - -Debbugs::DB::Result::UserTag - User bug tags - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::Core'; - -=head1 COMPONENTS LOADED - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); - -=head1 TABLE: C - -=cut - -__PACKAGE__->table("user_tag"); - -=head1 ACCESSORS - -=head2 id - - data_type: 'integer' - is_auto_increment: 1 - is_nullable: 0 - sequence: 'user_tag_id_seq' - -User bug tag id - -=head2 tag - - data_type: 'text' - is_nullable: 0 - -User bug tag name - -=head2 correspondent - - data_type: 'integer' - is_foreign_key: 1 - is_nullable: 0 - -User bug tag correspondent - -=cut - -__PACKAGE__->add_columns( - "id", - { - data_type => "integer", - is_auto_increment => 1, - is_nullable => 0, - sequence => "user_tag_id_seq", - }, - "tag", - { data_type => "text", is_nullable => 0 }, - "correspondent", - { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, -); - -=head1 PRIMARY KEY - -=over 4 - -=item * L - -=back - -=cut - -__PACKAGE__->set_primary_key("id"); - -=head1 UNIQUE CONSTRAINTS - -=head2 C - -=over 4 - -=item * L - -=item * L - -=back - -=cut - -__PACKAGE__->add_unique_constraint("user_tag_tag_correspondent", ["tag", "correspondent"]); - -=head1 RELATIONS - -=head2 bug_user_tags - -Type: has_many - -Related object: L - -=cut - -__PACKAGE__->has_many( - "bug_user_tags", - "Debbugs::DB::Result::BugUserTag", - { "foreign.user_tag" => "self.id" }, - { cascade_copy => 0, cascade_delete => 0 }, -); - -=head2 correspondent - -Type: belongs_to - -Related object: L - -=cut - -__PACKAGE__->belongs_to( - "correspondent", - "Debbugs::DB::Result::Correspondent", - { id => "correspondent" }, - { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, -); - - -# Created by DBIx::Class::Schema::Loader v0.07045 @ 2016-09-24 14:51:07 -# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:ZPmTBeTue62dG2NdQdPrQg - -sub sqlt_deploy_hook { - my ($self, $sqlt_table) = @_; - $sqlt_table->add_index(name => 'user_tag_correspondent', - fields => [qw(correspondent)], - ); -} - -1; diff --git a/Debbugs/DB/ResultSet/Arch.pm b/Debbugs/DB/ResultSet/Arch.pm deleted file mode 100644 index 572ed0a..0000000 --- a/Debbugs/DB/ResultSet/Arch.pm +++ /dev/null @@ -1,55 +0,0 @@ -# This module is part of debbugs, and is released -# under the terms of the GPL version 2, or any later version. See the -# file README and COPYING for more information. -# Copyright 2016 by Don Armstrong . -use utf8; -package Debbugs::DB::ResultSet::Arch; - -=head1 NAME - -Debbugs::DB::ResultSet::Arch - Architecture result set operations - -=head1 SYNOPSIS - - - -=head1 DESCRIPTION - - - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::ResultSet'; - -# required for hash slices -use v5.20; - -sub get_archs { - my ($self,@archs) = @_; - my %archs; - for my $a ($self->result_source->schema->resultset('Arch')-> - search(undef, - {result_class => 'DBIx::Class::ResultClass::HashRefInflator', - columns => [qw[id arch]], - })->all()) { - $archs{$a->{arch}} = $a->{id}; - } - for my $a (grep {not exists $archs{$_}} @archs) { - $archs{$a} = - $self->result_source->schema->resultset('Arch')-> - find_or_create({arch => $a}, - {columns => [qw[id arch]], - } - )->id; - } - - return {%archs{@archs}}; -} - - -1; - -__END__ diff --git a/Debbugs/DB/ResultSet/BinAssociation.pm b/Debbugs/DB/ResultSet/BinAssociation.pm deleted file mode 100644 index 5756199..0000000 --- a/Debbugs/DB/ResultSet/BinAssociation.pm +++ /dev/null @@ -1,48 +0,0 @@ -# This module is part of debbugs, and is released -# under the terms of the GPL version 2, or any later version. See the -# file README and COPYING for more information. -# Copyright 2017 by Don Armstrong . -use utf8; -package Debbugs::DB::ResultSet::BinAssociation; - -=head1 NAME - -Debbugs::DB::ResultSet::BinAssociation - Binary/Suite Associations - -=head1 SYNOPSIS - - - -=head1 DESCRIPTION - - - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::ResultSet'; - -use Debbugs::DB::Util qw(select_one); - - -sub insert_suite_bin_ver_association { - my ($self,$suite_id,$bin_ver_id) = @_; - return $self->result_source->schema->storage-> - dbh_do(sub { - my ($s,$dbh,$s_id,$bv_id) = @_; - return select_one($dbh,<<'SQL',$s_id,$bv_id); -INSERT INTO bin_associations (suite,bin) - VALUES (?,?) ON CONFLICT (suite,bin) DO - UPDATE SET modified = NOW() - RETURNING id; -SQL - }, - $suite_id,$bin_ver_id - ); -} - -1; - -__END__ diff --git a/Debbugs/DB/ResultSet/BinPkg.pm b/Debbugs/DB/ResultSet/BinPkg.pm deleted file mode 100644 index e938cda..0000000 --- a/Debbugs/DB/ResultSet/BinPkg.pm +++ /dev/null @@ -1,78 +0,0 @@ -# This module is part of debbugs, and is released -# under the terms of the GPL version 2, or any later version. See the -# file README and COPYING for more information. -# Copyright 2017 by Don Armstrong . -use utf8; -package Debbugs::DB::ResultSet::BinPkg; - -=head1 NAME - -Debbugs::DB::ResultSet::BinPkg - Source Package - -=head1 SYNOPSIS - - - -=head1 DESCRIPTION - - - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::ResultSet'; - -use Debbugs::DB::Util qw(select_one); - -sub bin_pkg_and_ver_in_suite { - my ($self,$suite) = @_; - $suite = $self->result_source->schema-> - resultset('Suite')->get_suite_id($suite); - return - $self->search_rs({'bin_associations.suite' => $suite, - }, - {join => {bin_vers => ['bin_associations','arch']}, - result_class => 'DBIx::Class::ResultClass::HashRefInflator', - columns => [qw(me.pkg bin_vers.ver arch.arch bin_associations.id)] - }, - )->all; -} - - -sub get_bin_pkg_id { - my ($self,$pkg) = @_; - return $self->result_source->schema->storage-> - dbh_do(sub { - my ($s,$dbh,$bin_pkg) = @_; - return select_one($dbh,<<'SQL',$bin_pkg); -SELECT id FROM bin_pkg where pkg = ?; -SQL - }, - $pkg - ); -} -sub get_or_create_bin_pkg_id { - my ($self,$pkg) = @_; - return $self->result_source->schema->storage-> - dbh_do(sub { - my ($s,$dbh,$bin_pkg) = @_; - return select_one($dbh,<<'SQL',$bin_pkg,$bin_pkg); -WITH ins AS ( -INSERT INTO bin_pkg (pkg) -VALUES (?) ON CONFLICT (pkg) DO NOTHING RETURNING id -) -SELECT id FROM ins -UNION ALL -SELECT id FROM bin_pkg where pkg = ? -LIMIT 1; -SQL - }, - $pkg - ); -} - -1; - -__END__ diff --git a/Debbugs/DB/ResultSet/BinVer.pm b/Debbugs/DB/ResultSet/BinVer.pm deleted file mode 100644 index fcd8b59..0000000 --- a/Debbugs/DB/ResultSet/BinVer.pm +++ /dev/null @@ -1,56 +0,0 @@ -# This module is part of debbugs, and is released -# under the terms of the GPL version 2, or any later version. See the -# file README and COPYING for more information. -# Copyright 2017 by Don Armstrong . -use utf8; -package Debbugs::DB::ResultSet::BinVer; - -=head1 NAME - -Debbugs::DB::ResultSet::BinVer - Source Version association - -=head1 SYNOPSIS - - - -=head1 DESCRIPTION - - - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::ResultSet'; - -use Debbugs::DB::Util qw(select_one); - - -sub get_bin_ver_id { - my ($self,$bin_pkg_id,$bin_ver,$arch_id,$src_ver_id) = @_; - return $self->result_source->schema->storage-> - dbh_do(sub { - my ($s,$dbh,$bp_id,$bv,$a_id,$sv_id) = @_; - return select_one($dbh,<<'SQL', -WITH ins AS ( -INSERT INTO bin_ver (bin_pkg,src_ver,arch,ver) -VALUES (?,?,?,?) ON CONFLICT (bin_pkg,arch,ver) DO NOTHING RETURNING id -) -SELECT id FROM ins -UNION ALL -SELECT id FROM bin_ver WHERE bin_pkg = ? AND arch = ? AND ver = ? -LIMIT 1; -SQL - $bp_id,$sv_id, - $a_id,$bv, - $bp_id,$a_id, - $bv); - }, - $bin_pkg_id,$bin_ver,$arch_id,$src_ver_id - ); -} - -1; - -__END__ diff --git a/Debbugs/DB/ResultSet/Bug.pm b/Debbugs/DB/ResultSet/Bug.pm deleted file mode 100644 index 265d4d9..0000000 --- a/Debbugs/DB/ResultSet/Bug.pm +++ /dev/null @@ -1,92 +0,0 @@ -# This module is part of debbugs, and is released -# under the terms of the GPL version 2, or any later version. See the -# file README and COPYING for more information. -# Copyright 2017 by Don Armstrong . -use utf8; -package Debbugs::DB::ResultSet::Bug; - -=head1 NAME - -Debbugs::DB::ResultSet::Bug - Bug result set operations - -=head1 SYNOPSIS - - - -=head1 DESCRIPTION - - - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::ResultSet'; - -use Debbugs::DB::Util qw(select_one); - -use List::AllUtils qw(natatime); - - -=over - -=item quick_insert_bugs - - $s->result_set('Bug')->quick_insert_bugs(@bugs); - -Quickly insert a set of bugs (without any useful information, like subject, -etc). This should probably only be called when inserting bugs in the database -for first time. - -=cut - - -sub quick_insert_bugs { - my ($self,@bugs) = @_; - - my $it = natatime 2000, @bugs; - - while (my @b = $it->()) { - $self->result_source->schema-> - txn_do(sub{ - for my $b (@b) { - $self->quick_insert_bug($b); - } - }); - } -} - -=item quick_insert_bug - - $s->result_set('Bug')->quick_insert_bug($bug); - -Quickly insert a single bug (called by quick_insert_bugs). You should probably -actually be calling C instead of this function. - -=cut - -sub quick_insert_bug { - my ($self,$bug) = @_; - return $self->result_source->schema->storage-> - dbh_do(sub { - my ($s,$dbh,$b) = @_; - select_one($dbh,<<'SQL',$b); -INSERT INTO bug (id,subject,severity) VALUES (?,'',1) -ON CONFLICT (id) DO NOTHING RETURNING id; -SQL - }, - $bug - ); - -} - - -=back - -=cut - - -1; - -__END__ diff --git a/Debbugs/DB/ResultSet/BugStatusCache.pm b/Debbugs/DB/ResultSet/BugStatusCache.pm deleted file mode 100644 index 7ad8f0e..0000000 --- a/Debbugs/DB/ResultSet/BugStatusCache.pm +++ /dev/null @@ -1,74 +0,0 @@ -# This module is part of debbugs, and is released -# under the terms of the GPL version 2, or any later version. See the -# file README and COPYING for more information. -# Copyright 2017 by Don Armstrong . -use utf8; -package Debbugs::DB::ResultSet::BugStatusCache; - -=head1 NAME - -Debbugs::DB::ResultSet::BugStatusCache - Bug result set operations - -=head1 SYNOPSIS - - - -=head1 DESCRIPTION - - - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::ResultSet'; - -use Debbugs::DB::Util qw(select_one); - -use List::AllUtils qw(natatime); - - -=over - -=item update_bug_status - - $s->resultset('BugStatusCache')-> - update_bug_status($bug->id, - $suite->{id}, - undef, - $presence, - ); - -Update the status information for a particular bug at a particular suite - -=cut - -sub update_bug_status { - my ($self,@args) = @_; - return $self->result_source->schema->storage-> - dbh_do(sub { - my ($s,$dbh,$bug,$suite,$arch,$status,$modified,$asof) = @_; - select_one($dbh,<<'SQL',$bug,$suite,$arch,$status,$status); -INSERT INTO bug_status_cache AS bsc -(bug,suite,arch,status,modified,asof) -VALUES (?,?,?,?,NOW(),NOW()) -ON CONFLICT (bug,COALESCE(suite,0),COALESCE(arch,0)) DO -UPDATE - SET asof=NOW(),modified=CASE WHEN bsc.status=? THEN bsc.modified ELSE NOW() END -RETURNING status; -SQL - }, - @args - ); -} - - -=back - -=cut - - -1; - -__END__ diff --git a/Debbugs/DB/ResultSet/Correspondent.pm b/Debbugs/DB/ResultSet/Correspondent.pm deleted file mode 100644 index d722a5f..0000000 --- a/Debbugs/DB/ResultSet/Correspondent.pm +++ /dev/null @@ -1,92 +0,0 @@ -# This module is part of debbugs, and is released -# under the terms of the GPL version 2, or any later version. See the -# file README and COPYING for more information. -# Copyright 2017 by Don Armstrong . -use utf8; -package Debbugs::DB::ResultSet::Correspondent; - -=head1 NAME - -Debbugs::DB::ResultSet::Correspondent - Correspondent table actions - -=head1 SYNOPSIS - - - -=head1 DESCRIPTION - - - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::ResultSet'; - -use Debbugs::DB::Util qw(select_one); - -use Debbugs::Common qw(getparsedaddrs); -use Debbugs::DB::Util qw(select_one); -use Scalar::Util qw(blessed); - -sub get_correspondent_id { - my ($self,$addr) = @_; - my $full_name; - if (blessed($addr)) { - $full_name = $addr->phrase(); - $addr = $addr->address(); - } elsif ($addr =~ /phrase(); - $addr = $addr->address(); - } - if (defined $full_name) { - $full_name =~ s/^\"|\"$//g; - $full_name =~ s/^\s+|\s+$//g; - } - my $rs = - $self-> - search({addr => $addr}, - {result_class => 'DBIx::Class::ResultClass::HashRefInflator', - } - )->first(); - if (defined $rs) { - return $rs->{id}; - } - return $self->result_source->schema->storage-> - dbh_do(sub { - my ($s,$dbh,$addr,$full_name) = @_; - my $ci = select_one($dbh,<<'SQL',$addr,$addr); -WITH ins AS ( -INSERT INTO correspondent (addr) VALUES (?) - ON CONFLICT (addr) DO NOTHING RETURNING id -) -SELECT id FROM ins -UNION ALL -SELECT id FROM correspondent WHERE addr = ? -LIMIT 1; -SQL - if (defined $full_name) { - select_one($dbh,<<'SQL',$ci,$full_name); -WITH ins AS ( -INSERT INTO correspondent_full_name (correspondent,full_name) - VALUES (?,?) ON CONFLICT (correspondent,full_name) DO NOTHING RETURNING 1 -) SELECT 1 FROM ins -UNION ALL -SELECT 1; -SQL - } - return $ci; -}, - $addr, - $full_name - ); - -} - - - -1; - -__END__ diff --git a/Debbugs/DB/ResultSet/Maintainer.pm b/Debbugs/DB/ResultSet/Maintainer.pm deleted file mode 100644 index 7c889f3..0000000 --- a/Debbugs/DB/ResultSet/Maintainer.pm +++ /dev/null @@ -1,117 +0,0 @@ -# This module is part of debbugs, and is released -# under the terms of the GPL version 2, or any later version. See the -# file README and COPYING for more information. -# Copyright 2016 by Don Armstrong . -use utf8; -package Debbugs::DB::ResultSet::Maintainer; - -=head1 NAME - -Debbugs::DB::ResultSet::Maintainer - Package maintainer result set operations - -=head1 SYNOPSIS - - - -=head1 DESCRIPTION - - - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::ResultSet'; - -use Debbugs::DB::Util qw(select_one); - - -=over - -=item get_maintainers - - $s->resultset('Maintainers')->get_maintainers(); - - $s->resultset('Maintainers')->get_maintainers(@maints); - -Retrieve a HASHREF of all maintainers with the maintainer name as the key and -the id of the database as the value. If given an optional list of maintainers, -adds those maintainers to the database if they do not already exist in the -database. - -=cut -sub get_maintainers { - my ($self,@maints) = @_; - my %maints; - for my $m ($self->result_source->schema->resultset('Maintainer')-> - search(undef, - {result_class => 'DBIx::Class::ResultClass::HashRefInflator', - columns => [qw[id name] ] - })->all()) { - $maints{$m->{name}} = $m->{id}; - } - my @maint_names = grep {not exists $maints{$_}} @maints; - my @maint_ids = $self->result_source->schema-> - txn_do(sub { - my @ids; - for my $name (@_) { - push @ids, - $self->result_source->schema-> - resultset('Maintainer')->get_maintainer_id($name); - } - return @ids; - },@maint_names); - @maints{@maint_names} = @maint_ids; - return \%maints; -} - -=item get_maintainer_id - - $s->resultset('Maintainer')->get_maintainer_id('Foo Bar ') - -Given a maintainer name returns the maintainer id, possibly inserting the -maintainer (and correspondent) if either do not exist in the database. - - -=cut - -sub get_maintainer_id { - my ($self,$maint) = @_; - my $rs = - $self-> - search({name => $maint}, - {result_class => 'DBIx::Class::ResultClass::HashRefInflator', - } - )->first(); - if (defined $rs) { - return $rs->{id}; - } - my $ci = - $self->result_source->schema->resultset('Correspondent')-> - get_correspondent_id($maint); - return $self->result_source->schema->storage-> - dbh_do(sub { - my ($s,$dbh,$maint,$ci) = @_; - return select_one($dbh,<<'SQL',$maint,$ci,$maint); -WITH ins AS ( -INSERT INTO maintainer (name,correspondent) VALUES (?,?) -ON CONFLICT (name) DO NOTHING RETURNING id -) -SELECT id FROM ins -UNION ALL -SELECT id FROM maintainer WHERE name = ? -LIMIT 1; -SQL - }, - $maint,$ci - ); -} - -=back - -=cut - -1; - -__END__ diff --git a/Debbugs/DB/ResultSet/Message.pm b/Debbugs/DB/ResultSet/Message.pm deleted file mode 100644 index 08509ce..0000000 --- a/Debbugs/DB/ResultSet/Message.pm +++ /dev/null @@ -1,56 +0,0 @@ -# This module is part of debbugs, and is released -# under the terms of the GPL version 2, or any later version. See the -# file README and COPYING for more information. -# Copyright 2017 by Don Armstrong . -use utf8; -package Debbugs::DB::ResultSet::Message; - -=head1 NAME - -Debbugs::DB::ResultSet::Message - Message table actions - -=head1 SYNOPSIS - - - -=head1 DESCRIPTION - - - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::ResultSet'; - -use Debbugs::DB::Util qw(select_one); - -sub get_message_id { - my ($self,$msg_id,$from,$to,$subject) = @_; - return $self->result_source->schema->storage-> - dbh_do(sub { - my ($dbh,$msg_id,$from,$to,$subject) = @_; - my $mi = select_one($dbh,<<'SQL',@_[1..$#_],@_[1..$#_]); -WITH ins AS ( -INSERT INTO message (msgid,from_complete,to_complete,subject) VALUES (?,?,?,?) - ON CONFLICT (msgid,from_complete,to_complete,subject) DO NOTHING RETURNING id -) -SELECT id FROM ins -UNION ALL -SELECT id FROM correspondent WHERE msgid=? AND from_complete = ? -AND to_complete = ? AND subject = ? -LIMIT 1; -SQL - return $mi; -}, - @_[1..$#_] - ); - -} - - - -1; - -__END__ diff --git a/Debbugs/DB/ResultSet/SrcAssociation.pm b/Debbugs/DB/ResultSet/SrcAssociation.pm deleted file mode 100644 index 047c54d..0000000 --- a/Debbugs/DB/ResultSet/SrcAssociation.pm +++ /dev/null @@ -1,48 +0,0 @@ -# This module is part of debbugs, and is released -# under the terms of the GPL version 2, or any later version. See the -# file README and COPYING for more information. -# Copyright 2017 by Don Armstrong . -use utf8; -package Debbugs::DB::ResultSet::SrcAssociation; - -=head1 NAME - -Debbugs::DB::ResultSet::SrcAssociation - Source/Suite Associations - -=head1 SYNOPSIS - - - -=head1 DESCRIPTION - - - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::ResultSet'; - -use Debbugs::DB::Util qw(select_one); - - -sub insert_suite_src_ver_association { - my ($self,$suite_id,$src_ver_id) = @_; - return $self->result_source->schema->storage-> - dbh_do(sub { - my ($s,$dbh,$suite_id,$src_ver_id) = @_; - return select_one($dbh,<<'SQL',$suite_id,$src_ver_id); -INSERT INTO src_associations (suite,source) - VALUES (?,?) ON CONFLICT (suite,source) DO - UPDATE SET modified = NOW() -RETURNING id; -SQL - }, - $suite_id,$src_ver_id - ); -} - -1; - -__END__ diff --git a/Debbugs/DB/ResultSet/SrcPkg.pm b/Debbugs/DB/ResultSet/SrcPkg.pm deleted file mode 100644 index 36fab13..0000000 --- a/Debbugs/DB/ResultSet/SrcPkg.pm +++ /dev/null @@ -1,95 +0,0 @@ -# This module is part of debbugs, and is released -# under the terms of the GPL version 2, or any later version. See the -# file README and COPYING for more information. -# Copyright 2017 by Don Armstrong . -use utf8; -package Debbugs::DB::ResultSet::SrcPkg; - -=head1 NAME - -Debbugs::DB::ResultSet::SrcPkg - Source Package - -=head1 SYNOPSIS - - - -=head1 DESCRIPTION - - - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::ResultSet'; - -use Debbugs::DB::Util qw(select_one); - -sub src_pkg_and_ver_in_suite { - my ($self,$suite) = @_; - if (ref($suite)) { - if (ref($suite) eq 'HASH') { - $suite = $suite->{id} - } else { - $suite = $suite->id(); - } - } else { - if ($suite !~ /^\d+$/) { - $suite = $self->result_source->schema-> - resultset('Suite')-> - search_rs({codename => $suite}, - {result_class => 'DBIx::Class::ResultClass::HashRefInflator', - })->first(); - if (defined $suite) { - $suite = $suite->{id}; - } - } - } - return - $self->search_rs({'src_associations.suite' => $suite, - }, - {join => {src_vers => 'src_associations'}, - result_class => 'DBIx::Class::ResultClass::HashRefInflator', - columns => [qw(me.pkg src_vers.ver src_associations.id)] - }, - )->all; -} - - -sub get_src_pkg_id { - my ($self,$source) = @_; - return $self->result_source->schema->storage-> - dbh_do(sub { - my ($s,$dbh,$src_pkg) = @_; - return select_one($dbh,<<'SQL',$src_pkg); -SELECT id FROM src_pkg where pkg = ?; -SQL - }, - $source - ); -} - -sub get_or_create_src_pkg_id { - my ($self,$source) = @_; - return $self->result_source->schema->storage-> - dbh_do(sub { - my ($s,$dbh,$source) = @_; - return select_one($dbh,<<'SQL',$source,$source); -WITH ins AS ( -INSERT INTO src_pkg (pkg) - VALUES (?) ON CONFLICT (pkg,disabled) DO NOTHING RETURNING id -) -SELECT id FROM ins -UNION ALL -SELECT id FROM src_pkg where pkg = ? AND disabled = 'infinity'::timestamptz -LIMIT 1; -SQL - }, - $source - ); -} - -1; - -__END__ diff --git a/Debbugs/DB/ResultSet/SrcVer.pm b/Debbugs/DB/ResultSet/SrcVer.pm deleted file mode 100644 index 254816c..0000000 --- a/Debbugs/DB/ResultSet/SrcVer.pm +++ /dev/null @@ -1,50 +0,0 @@ -# This module is part of debbugs, and is released -# under the terms of the GPL version 2, or any later version. See the -# file README and COPYING for more information. -# Copyright 2017 by Don Armstrong . -use utf8; -package Debbugs::DB::ResultSet::SrcVer; - -=head1 NAME - -Debbugs::DB::ResultSet::SrcVer - Source Version association - -=head1 SYNOPSIS - - - -=head1 DESCRIPTION - - - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::ResultSet'; - -use Debbugs::DB::Util qw(select_one); - - -sub get_src_ver_id { - my ($self,$src_pkg_id,$src_ver,$maint_id) = @_; - return $self->result_source->schema->storage-> - dbh_do(sub { - my ($s,$dbh,$src_pkg_id,$src_ver,$maint_id) = @_; - return select_one($dbh,<<'SQL', -INSERT INTO src_ver (src_pkg,ver,maintainer) - VALUES (?,?,?) ON CONFLICT (src_pkg,ver) DO - UPDATE SET maintainer = ? - RETURNING id; -SQL - $src_pkg_id,$src_ver, - $maint_id,$maint_id); - }, - $src_pkg_id,$src_ver,$maint_id - ); -} - -1; - -__END__ diff --git a/Debbugs/DB/ResultSet/Suite.pm b/Debbugs/DB/ResultSet/Suite.pm deleted file mode 100644 index c920080..0000000 --- a/Debbugs/DB/ResultSet/Suite.pm +++ /dev/null @@ -1,53 +0,0 @@ -# This module is part of debbugs, and is released -# under the terms of the GPL version 2, or any later version. See the -# file README and COPYING for more information. -# Copyright 2017 by Don Armstrong . -use utf8; -package Debbugs::DB::ResultSet::Suite; - -=head1 NAME - -Debbugs::DB::ResultSet::Suite - Suite table actions - -=head1 SYNOPSIS - - - -=head1 DESCRIPTION - - - -=cut - -use strict; -use warnings; - -use base 'DBIx::Class::ResultSet'; - -sub get_suite_id { - my ($self,$suite) = @_; - if (ref($suite)) { - if (ref($suite) eq 'HASH') { - $suite = $suite->{id} - } else { - $suite = $suite->id(); - } - } - else { - if ($suite !~ /^\d+$/) { - $suite = $self->result_source->schema-> - resultset('Suite')-> - search_rs({codename => $suite}, - {result_class => 'DBIx::Class::ResultClass::HashRefInflator', - })->first(); - if (defined $suite) { - $suite = $suite->{id}; - } - } - } - return $suite; -} - -1; - -__END__ diff --git a/Debbugs/DB/Util.pm b/Debbugs/DB/Util.pm deleted file mode 100644 index d241f33..0000000 --- a/Debbugs/DB/Util.pm +++ /dev/null @@ -1,96 +0,0 @@ -# This module is part of debbugs, and is released -# under the terms of the GPL version 2, or any later version. See the -# file README and COPYING for more information. -# Copyright 2017 by Don Armstrong . - -package Debbugs::DB::Util; - -=head1 NAME - -Debbugs::DB::Util -- Utility routines for the database - -=head1 SYNOPSIS - - -=head1 DESCRIPTION - - -=head1 BUGS - -None known. - -=cut - -use warnings; -use strict; -use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); -use base qw(Exporter); - -BEGIN{ - ($VERSION) = q$Revision$ =~ /^Revision:\s+([^\s+])/; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - %EXPORT_TAGS = (select => [qw(select_one)], - execute => [qw(prepare_execute)] - ); - @EXPORT_OK = (); - Exporter::export_ok_tags(keys %EXPORT_TAGS); - $EXPORT_TAGS{all} = [@EXPORT_OK]; -} - -=head2 select - -Routines for select requests - -=over - -=item select_one - - select_one($dbh,$sql,@bind_vals) - -Returns the first column from the first row returned from a select statement - -=cut - -sub select_one { - my ($dbh,$sql,@bind_vals) = @_; - my $sth = $dbh-> - prepare_cached($sql, - {dbi_dummy => __FILE__.__LINE__ }) - or die "Unable to prepare statement: $sql"; - $sth->execute(@bind_vals) or - die "Unable to select one: ".$dbh->errstr(); - my $results = $sth->fetchall_arrayref([0]); - $sth->finish(); - return (ref($results) and ref($results->[0]))?$results->[0][0]:undef; -} - -=item prepare_execute - - prepare_execute($dbh,$sql,@bind_vals) - -Prepares and executes a statement - -=cut - -sub prepare_execute { - my ($dbh,$sql,@bind_vals) = @_; - my $sth = $dbh-> - prepare_cached($sql, - {dbi_dummy => __FILE__.__LINE__ }) - or die "Unable to prepare statement: $sql"; - $sth->execute(@bind_vals) or - die "Unable to execute statement: ".$dbh->errstr(); - $sth->finish(); -} - - -=back - -=cut - -1; - - -__END__ diff --git a/Debbugs/DebArchive.pm b/Debbugs/DebArchive.pm deleted file mode 100644 index ccb321a..0000000 --- a/Debbugs/DebArchive.pm +++ /dev/null @@ -1,204 +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 2017 by Don Armstrong . - -package Debbugs::DebArchive; - -use warnings; -use strict; - -=head1 NAME - -Debbugs::DebArchive -- Routines for reading files from Debian archives - -=head1 SYNOPSIS - -use Debbugs::DebArchive; - - read_packages('/srv/mirrors/ftp.debian.org/ftp/dist', - sub { print map {qq($_\n)} @_ }, - Term::ProgressBar->new(), - ); - - -=head1 DESCRIPTION - -This module implements a set of routines for reading Packages.gz, Sources.gz and -Release files from the dists directory of a Debian archive. - -=head1 BUGS - -None known. - -=cut - - -use vars qw($DEBUG $VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT); -use base qw(Exporter); - -BEGIN { - $VERSION = 1.00; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - %EXPORT_TAGS = (read => [qw(read_release_file read_packages), - ], - ); - @EXPORT_OK = (); - Exporter::export_ok_tags(keys %EXPORT_TAGS); - $EXPORT_TAGS{all} = [@EXPORT_OK]; -} - -use File::Spec qw(); -use File::Basename; -use Debbugs::Config qw(:config); -use Debbugs::Common qw(open_compressed_file make_list); -use IO::Dir; - -use Carp; - -=over - -=item read_release_file - - read_release_file('stable/Release') - -Reads a Debian release file and returns a hashref of information about the -release file, including the Packages and Sources files for that distribution - -=cut - -sub read_release_file { - my ($file) = @_; - # parse release - my $rfh = open_compressed_file($file) or - die "Unable to open $file for reading: $!"; - my %dist_info; - my $in_sha1; - my %p_f; - while (<$rfh>) { - chomp; - if (s/^(\S+):\s*//) { - if ($1 eq 'SHA1'or $1 eq 'SHA256') { - $in_sha1 = 1; - next; - } - $dist_info{$1} = $_; - } elsif ($in_sha1) { - s/^\s//; - my ($sha,$size,$f) = split /\s+/,$_; - next unless $f =~ /(?:Packages|Sources)(?:\.gz|\.xz)$/; - next unless $f =~ m{^([^/]+)/([^/]+)/([^/]+)$}; - my ($component,$arch,$package_source) = ($1,$2,$3); - $arch =~ s/binary-//; - next if exists $p_f{$component}{$arch} and - $p_f{$component}{$arch} =~ /\.xz$/; - $p_f{$component}{$arch} = File::Spec->catfile(dirname($file),$f); - } - } - return (\%dist_info,\%p_f); -} - -=item read_packages - - read_packages($dist_dir,$callback,$progress) - -=over - -=item dist_dir - -Path to dists directory - -=item callback - -Function which is called with key, value pairs of suite, arch, component, -Package, Source, Version, and Maintainer information for each package in the -Packages file. - -=item progress - -Optional Term::ProgressBar object to output progress while reading packages. - -=back - - -=cut - -sub read_packages { - my ($dist_dir,$callback,$p) = @_; - - my %s_p; - my $tot = 0; - for my $dist (make_list($dist_dir)) { - my $dist_dir_h = IO::Dir->new($dist); - my @dist_names = - grep { $_ !~ /^\./ and - -d $dist.'/'.$_ and - not -l $dist.'/'.$_ - } $dist_dir_h->read or - die "Unable to read from dir: $!"; - $dist_dir_h->close or - die "Unable to close dir: $!"; - while (my $dist = shift @dist_names) { - my $dir = $dist_dir.'/'.$dist; - my ($dist_info,$package_files) = - read_release_file(File::Spec->catfile($dist_dir, - $dist, - 'Release')); - $s_p{$dist_info->{Codename}} = $package_files; - } - for my $suite (keys %s_p) { - for my $component (keys %{$s_p{$suite}}) { - $tot += scalar keys %{$s_p{$suite}{$component}}; - } - } - } - $p->target($tot) if $p; - my $done_archs = 0; - # parse packages files - for my $suite (keys %s_p) { - my $pkgs = 0; - for my $component (keys %{$s_p{$suite}}) { - my @archs = keys %{$s_p{$suite}{$component}}; - if (grep {$_ eq 'source'} @archs) { - @archs = ('source',grep {$_ ne 'source'} @archs); - } - for my $arch (@archs) { - my $pfh = open_compressed_file($s_p{$suite}{$component}{$arch}) or - die "Unable to open $s_p{$suite}{$component}{$arch} for reading: $!"; - local $_; - local $/ = ''; # paragraph mode - while (<$pfh>) { - my %pkg; - for my $field (qw(Package Maintainer Version Source)) { - /^\Q$field\E: (.*)/m; - $pkg{$field} = $1; - } - next unless defined $pkg{Package} and - defined $pkg{Version}; - $pkg{suite} = $suite; - $pkg{arch} = $arch; - $pkg{component} = $component; - $callback->(%pkg); - } - $p->update(++$done_archs) if $p; - } - } - } - $p->remove() if $p; -} - -=back - -=cut - -1; - -__END__ -# Local Variables: -# indent-tabs-mode: nil -# cperl-indent-level: 4 -# End: diff --git a/Debbugs/Estraier.pm b/Debbugs/Estraier.pm deleted file mode 100644 index 174ad4c..0000000 --- a/Debbugs/Estraier.pm +++ /dev/null @@ -1,177 +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 2007 by Don Armstrong . - -package Debbugs::Estraier; - -=head1 NAME - -Debbugs::Estraier -- Routines for interfacing bugs to HyperEstraier - -=head1 SYNOPSIS - -use Debbugs::Estraier; - - -=head1 DESCRIPTION - - -=head1 BUGS - -None known. - -=cut - -use warnings; -use strict; -use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); -use Exporter qw(import); -use Debbugs::Log; -use Search::Estraier; -use Debbugs::Common qw(getbuglocation getbugcomponent make_list); -use Debbugs::Status qw(readbug); -use Debbugs::MIME qw(parse); -use Encode qw(encode_utf8); - -BEGIN{ - ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - %EXPORT_TAGS = (add => [qw(add_bug_log add_bug_message)], - ); - @EXPORT_OK = (); - Exporter::export_ok_tags(qw(add)); - $EXPORT_TAGS{all} = [@EXPORT_OK]; -} - - -sub add_bug_log{ - my ($est,$bug_num) = @_; - - # We want to read the entire bug log, pulling out individual - # messages, and shooting them through hyper estraier - - my $location = getbuglocation($bug_num,'log'); - my $bug_log = getbugcomponent($bug_num,'log',$location); - my $log_fh = new IO::File $bug_log, 'r' or - die "Unable to open bug log $bug_log for reading: $!"; - - my $log = Debbugs::Log->new($log_fh) or - die "Debbugs::Log was unable to be initialized"; - - my %seen_msg_ids; - my $msg_num=0; - my $status = {}; - if (my $location = getbuglocation($bug_num,'summary')) { - $status = readbug($bug_num,$location); - } - while (my $record = $log->read_record()) { - $msg_num++; - next unless $record->{type} eq 'incoming-recv'; - my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im; - next if defined $msg_id and exists $seen_msg_ids{$msg_id}; - $seen_msg_ids{$msg_id} = 1 if defined $msg_id; - next if defined $msg_id and $msg_id =~ /handler\..+\.ack(?:info)?\@/; - add_bug_message($est,$record->{text},$bug_num,$msg_num,$status) - } - return $msg_num; -} - -=head2 remove_old_message - - remove_old_message($est,300000,50); - -Removes all messages which are no longer in the log - -=cut - -sub remove_old_messages{ - my ($est,$bug_num,$max_message) = @_; - # remove records which are no longer present in the log (uri > $msg_num) - my $cond = new Search::Estraier::Condition; - $cond->add_attr('@uri STRBW '.$bug_num.'/'); - $cond->set_max(50); - my $nres; - while ($nres = $est->search($cond,0) and $nres->doc_num > 0){ - for my $rdoc (map {$nres->get_doc($_)} 0..($nres->doc_num-1)) { - my $uri = $rdoc->uri; - my ($this_message) = $uri =~ m{/(\d+)$}; - next unless $this_message > $max_message; - $est->out_doc_by_uri($uri); - } - last unless $nres->doc_num >= $cond->max; - $cond->set_skip($cond->skip+$cond->max); - } - -} - -sub add_bug_message{ - my ($est,$bug_message,$bug_num, - $msg_num,$status) = @_; - - my $doc; - my $uri = "$bug_num/$msg_num"; - $doc = $est->get_doc_by_uri($uri); - $doc = new Search::Estraier::Document if not defined $doc; - - my $message = parse($bug_message); - $doc->add_text(encode_utf8(join("\n",make_list(values %{$message})))); - - # * @id : the ID number determined automatically when the document is registered. - # * @uri : the location of a document which any document should have. - # * @digest : the message digest calculated automatically when the document is registered. - # * @cdate : the creation date. - # * @mdate : the last modification date. - # * @adate : the last access date. - # * @title : the title used as a headline in the search result. - # * @author : the author. - # * @type : the media type. - # * @lang : the language. - # * @genre : the genre. - # * @size : the size. - # * @weight : the scoring weight. - # * @misc : miscellaneous information. - my @attr = qw(status subject date submitter package tags severity); - # parse the date - my ($date) = $bug_message =~ /^Date:\s+(.+?)\s*$/mi; - $doc->add_attr('@cdate' => encode_utf8($date)) if defined $date; - # parse the title - my ($subject) = $bug_message =~ /^Subject:\s+(.+?)\s*$/mi; - $doc->add_attr('@title' => encode_utf8($subject)) if defined $subject; - # parse the author - my ($author) = $bug_message =~ /^From:\s+(.+?)\s*$/mi; - $doc->add_attr('@author' => encode_utf8($author)) if defined $author; - # create the uri - $doc->add_attr('@uri' => encode_utf8($uri)); - foreach my $attr (@attr) { - $doc->add_attr($attr => encode_utf8($status->{$attr})) if defined $status->{$attr}; - } - print STDERR "adding $uri\n" if $DEBUG; - # Try a bit harder if estraier is returning timeouts - my $attempt = 5; - while ($attempt > 0) { - $est->put_doc($doc) and last; - my $status = $est->status; - $attempt--; - print STDERR "Failed to add $uri\n".$status."\n"; - last unless $status =~ /^5/; - sleep 20; - } - -} - - -1; - - -__END__ - - - - - - diff --git a/Debbugs/Libravatar.pm b/Debbugs/Libravatar.pm deleted file mode 100644 index 373a9f5..0000000 --- a/Debbugs/Libravatar.pm +++ /dev/null @@ -1,333 +0,0 @@ -# This module is part of debbugs, and is released -# under the terms of the GPL version 2, or any later version. See the -# file README and COPYING for more information. -# Copyright 2013 by Don Armstrong . - -package Debbugs::Libravatar; - -=head1 NAME - -Debbugs::Libravatar -- Libravatar service handler (mod_perl) - -=head1 SYNOPSIS - - - SetHandler perl-script - PerlResponseHandler Debbugs::Libravatar - - -=head1 DESCRIPTION - -Debbugs::Libravatar is a libravatar service handler which will serve -libravatar requests. It also contains utility routines which are used -by the libravatar.cgi script for those who do not have mod_perl. - -=head1 BUGS - -None known. - -=cut - -use warnings; -use strict; -use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); -use Exporter qw(import); - -use Debbugs::Config qw(:config); -use Debbugs::Common qw(:lock); -use Libravatar::URL; -use CGI::Simple; -use Debbugs::CGI qw(cgi_parameters); -use Digest::MD5 qw(md5_hex); -use File::Temp qw(tempfile); -use File::LibMagic; -use Cwd qw(abs_path); - -use Carp; - -BEGIN{ - ($VERSION) = q$Revision$ =~ /^Revision:\s+([^\s+])/; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - %EXPORT_TAGS = (libravatar => [qw(retrieve_libravatar cache_location)] - ); - @EXPORT_OK = (); - Exporter::export_ok_tags(keys %EXPORT_TAGS); - $EXPORT_TAGS{all} = [@EXPORT_OK]; -} - - -our $magic; - -=over - -=item retrieve_libravatar - - $cache_location = retrieve_libravatar(location => $cache_location, - email => lc($param{email}), - ); - -Returns the cache location where a specific avatar can be loaded. If -there isn't a matching avatar, or there is an error, returns undef. - - -=cut - -sub retrieve_libravatar{ - my %type_mapping = - (jpeg => 'jpg', - png => 'png', - gif => 'png', - tiff => 'png', - tif => 'png', - pjpeg => 'jpg', - jpg => 'jpg' - ); - my %param = @_; - my $cache_location = $param{location}; - my $timestamp; - $cache_location =~ s/\.[^\.\/]+$//; - # take out a lock on the cache location so that if another request - # is made while we are serving this one, we don't do double work - my ($fh,$lockfile,$errors) = - simple_filelock($cache_location.'.lock',20,0.5); - if (not $fh) { - return undef; - } else { - # figure out if the cache is now valid; if it is, return the - # cache location - my $temp_location; - ($temp_location, $timestamp) = cache_location(email => $param{email}); - if ($timestamp) { - return ($temp_location,$timestamp); - } - } - require LWP::UserAgent; - - my $dest_type = 'png'; - eval { - my $uri = libravatar_url(email => $param{email}, - default => 404, - size => 80); - my $ua = LWP::UserAgent->new(agent => 'Debbugs libravatar service (not Mozilla)', - ); - $ua->from($config{maintainer}); - # if we don't get an avatar within 10 seconds, return so we - # don't block forever - $ua->timeout(10); - # if the avatar is bigger than 30K, we don't want it either - $ua->max_size(30*1024); - $ua->default_header('Accept' => 'image/*'); - my $r = $ua->get($uri); - if (not $r->is_success()) { - if ($r->code != 404) { - die "Not successful in request"; - } - # No avatar - cache a negative result - if ($config{libravatar_default_image} =~ m/\.(png|jpg)$/) { - $dest_type = $1; - - system('cp', '-laf', $config{libravatar_default_image}, $cache_location.'.'.$dest_type) == 0 - or die("Cannot copy $config{libravatar_default_image}"); - # Returns from eval {} - return; - } - } - my $aborted = $r->header('Client-Aborted'); - # if we exceeded max size, I'm not sure if we'll be - # successfull or not, but regardless, there will be a - # Client-Aborted header. Stop here if that header is defined. - die "Client aborted header" if defined $aborted; - my $type = $r->header('Content-Type'); - # if there's no content type, or it's not one we like, we won't - # bother going further - if (defined $type) { - die "Wrong content type" if not $type =~ m{^image/([^/]+)$}; - $dest_type = $type_mapping{$1}; - die "No dest type" if not defined $dest_type; - } - # undo any content encoding - $r->decode() or die "Unable to decode content encoding"; - # ok, now we need to convert it from whatever it is into a - # format that we actually like - my ($temp_fh,$temp_fn) = tempfile() or - die "Unable to create temporary file"; - eval { - print {$temp_fh} $r->content() or - die "Unable to print to temp file"; - close ($temp_fh) or - die "Unable to close temp file"; - ### Figure out the actual type from the file - $magic = File::LibMagic->new() if not defined $magic; - $type = $magic->checktype_filename(abs_path($temp_fn)); - die "Wrong content type ($type)" if not $type =~ m{^image/([^/;]+)(?:;|$)}; - $dest_type = $type_mapping{$1}; - die "No dest type for ($1)" if not defined $dest_type; - ### resize all images to 80x80 and strip comments out of - ### them. If convert has a bug, it would be possible for - ### this to be an attack vector, but hopefully minimizing - ### the size above, and requiring proper mime types will - ### minimize that slightly. Doing this will at least make - ### it harder for malicious web images to harm our users - system('convert','-resize','80x80', - '-strip', - $temp_fn, - $cache_location.'.'.$dest_type) == 0 or - die "convert file failed"; - unlink($temp_fn); - }; - if ($@) { - unlink($cache_location.'.'.$dest_type) if -e $cache_location.'.'.$dest_type; - unlink($temp_fn) if -e $temp_fn; - die "Unable to convert image"; - } - }; - if ($@) { - # there was some kind of error; return undef and unlock the - # lock - simple_unlockfile($fh,$lockfile); - return undef; - } - simple_unlockfile($fh,$lockfile); - $timestamp = (stat($cache_location.'.'.$dest_type))[9]; - return ($cache_location.'.'.$dest_type,$timestamp); -} - -sub blocked_libravatar { - my ($email,$md5sum) = @_; - my $blocked = 0; - for my $blocker (@{$config{libravatar_blacklist}||[]}) { - for my $element ($email,$md5sum) { - next unless defined $element; - eval { - if ($element =~ /$blocker/) { - $blocked=1; - } - }; - } - } - return $blocked; -} - -# Returns ($path, $timestamp) -# - For blocked images, $path will be undef -# - If $timestamp is 0 (and $path is not undef), the image should -# be re-fetched. -sub cache_location { - my %param = @_; - my ($md5sum, $stem); - if (exists $param{md5sum}) { - $md5sum = $param{md5sum}; - }elsif (exists $param{email}) { - $md5sum = md5_hex(lc($param{email})); - } else { - croak("cache_location must be called with one of md5sum or email"); - } - return (undef, 0) if blocked_libravatar($param{email},$md5sum); - my $cache_dir = $param{cache_dir} // $config{libravatar_cache_dir}; - $stem = $cache_dir.'/'.$md5sum; - for my $ext ('.png', '.jpg', '') { - my $path = $stem.$ext; - if (-e $path) { - my $timestamp = (time - (stat(_))[9] < 60*60) ? (stat(_))[9] : 0; - return ($path, $timestamp); - } - } - return ($stem, 0); -} - -## the following is mod_perl specific - -BEGIN{ - if (exists $ENV{MOD_PERL_API_VERSION}) { - if ($ENV{MOD_PERL_API_VERSION} == 2) { - require Apache2::RequestIO; - require Apache2::RequestRec; - require Apache2::RequestUtil; - require Apache2::Const; - require APR::Finfo; - require APR::Const; - APR::Const->import(-compile => qw(FINFO_NORM)); - Apache2::Const->import(-compile => qw(OK DECLINED FORBIDDEN NOT_FOUND HTTP_NOT_MODIFIED)); - } else { - die "Unsupported mod perl api; mod_perl 2.0.0 or later is required"; - } - } -} - -sub handler { - die "Calling handler only makes sense if this is running under mod_perl" unless exists $ENV{MOD_PERL_API_VERSION}; - my $r = shift or Apache2::RequestUtil->request; - - # we only want GET or HEAD requests - unless ($r->method eq 'HEAD' or $r->method eq 'GET') { - return Apache2::Const::DECLINED(); - } - $r->headers_out->{"X-Powered-By"} = "Debbugs libravatar"; - - my $uri = $r->uri(); - # subtract out location - my $location = $r->location(); - my ($email) = $uri =~ m/\Q$location\E\/?(.*)$/; - if (not length $email) { - return Apache2::Const::NOT_FOUND(); - } - my $q = CGI::Simple->new(); - my %param = cgi_parameters(query => $q, - single => [qw(avatar)], - default => {avatar => 'yes', - }, - ); - if ($param{avatar} ne 'yes' or not defined $email or not length $email) { - serve_cache_mod_perl('',$r); - return Apache2::Const::DECLINED(); - } - # figure out what the md5sum of the e-mail is. - my ($cache_location, $timestamp) = cache_location(email => $email); - # if we've got it, and it's less than one hour old, return it. - if ($timestamp) { - serve_cache_mod_perl($cache_location,$r); - return Apache2::Const::DECLINED(); - } - ($cache_location,$timestamp) = - retrieve_libravatar(location => $cache_location, - email => $email, - ); - if (not defined $cache_location) { - # failure, serve the default image - serve_cache_mod_perl('',$r,$timestamp); - return Apache2::Const::DECLINED(); - } else { - serve_cache_mod_perl($cache_location,$r,$timestamp); - return Apache2::Const::DECLINED(); - } -} - - - -sub serve_cache_mod_perl { - my ($cache_location,$r,$timestamp) = @_; - if (not defined $cache_location or not length $cache_location) { - # serve the default image - $cache_location = $config{libravatar_default_image}; - } - $magic = File::LibMagic->new() if not defined $magic; - - return Apache2::Const::DECLINED() if not defined $magic; - - $r->content_type($magic->checktype_filename(abs_path($cache_location))); - - $r->filename($cache_location); - $r->path_info(''); - $r->finfo(APR::Finfo::stat($cache_location, APR::Const::FINFO_NORM(), $r->pool)); -} - -=back - -=cut - -1; - - -__END__ diff --git a/Debbugs/Log.pm b/Debbugs/Log.pm deleted file mode 100644 index 710a844..0000000 --- a/Debbugs/Log.pm +++ /dev/null @@ -1,589 +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. -# -# [Other people have contributed to this file; their copyrights should -# go here too.] -# Copyright 2004 by Collin Watson -# Copyright 2007 by Don Armstrong - - -package Debbugs::Log; - -use Mouse; -use strictures 2; -use namespace::clean; -use v5.10; # for state - -use vars qw($VERSION $DEBUG @EXPORT @EXPORT_OK %EXPORT_TAGS); -use Exporter qw(import); - -BEGIN { - $VERSION = 1.00; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - %EXPORT_TAGS = (write => [qw(write_log_records), - ], - read => [qw(read_log_records record_text record_regex), - ], - misc => [qw(escape_log), - ], - ); - @EXPORT_OK = (); - Exporter::export_ok_tags(qw(write read misc)); - $EXPORT_TAGS{all} = [@EXPORT_OK]; -} - -use Carp; - -use Debbugs::Common qw(getbuglocation getbugcomponent make_list); -use Params::Validate qw(:types validate_with); -use Encode qw(encode encode_utf8 is_utf8); -use IO::InnerFile; - -=head1 NAME - -Debbugs::Log - an interface to debbugs .log files - -=head1 DESCRIPTION - -The Debbugs::Log module provides a convenient way for scripts to read and -write the .log files used by debbugs to store the complete textual records -of all bug transactions. - -Debbugs::Log does not decode utf8 into perl's internal encoding or -encode into utf8 from perl's internal encoding. For html records and -all recips, this should probably be done. For other records, this should -not be needed. - -=head2 The .log File Format - -.log files consist of a sequence of records, of one of the following four -types. ^A, ^B, etc. represent those control characters. - -=over 4 - -=item incoming-recv - - ^G - [mail] - ^C - -C<[mail]> must start with /^Received: \(at \S+\) by \S+;/, and is copied to -the output. - -=item autocheck - -Auto-forwarded messages are recorded like this: - - ^A - [mail] - ^C - -C<[mail]> must contain /^X-Debian-Bugs(-\w+)?: This is an autoforward from -\S+/. The first line matching that is removed; all lines in the message body -that begin with 'X' will be copied to the output, minus the 'X'. - -Nothing in debbugs actually generates this record type any more, but it may -still be in old .logs at some sites. - -=item recips - - ^B - [recip]^D[recip]^D[...] OR -t - ^E - [mail] - ^C - -Each [recip] is output after "Message sent"; C<-t> represents the same -sendmail option, indicating that the recipients are taken from the headers -of the message itself. - -=item html - - ^F - [html] - ^C - -[html] is copied unescaped to the output. The record immediately following -this one is considered "boring" and only shown in certain output modes. - -(This is a design flaw in the log format, since it makes it difficult to -change the HTML presentation later, or to present the data in an entirely -different format.) - -=back - -No other types of records are permitted, and the file must end with a ^C -line. - -=cut - -my %states = ( - 1 => 'autocheck', - 2 => 'recips', - 3 => 'kill-end', - 5 => 'go', - 6 => 'html', - 7 => 'incoming-recv', -); - -=head2 Perl Record Representation - -Each record is a hash. The C field is C, C, -C, or C as above; C contains text from C<[mail]> or -C<[html]> as above; C is a reference to an array of recipients -(strings), or undef for C<-t>. - -=head1 FUNCTIONS - -=over 4 - -=item new - -Creates a new log reader based on a .log filehandle. - - my $log = Debbugs::Log->new($logfh); - my $log = Debbugs::Log->new(bug_num => $nnn); - my $log = Debbugs::Log->new(logfh => $logfh); - -Parameters - -=over - -=item bug_num -- bug number - -=item logfh -- log filehandle - -=item log_name -- name of log - -=back - -One of the above options must be passed. - -=cut - -sub BUILD { - my ($self,$args) = @_; - if (not ($self->_has_bug_num or - $self->_has_logfh or - $self->_has_log_name)) { - croak "Exactly one of bug_num, logfh, or log_name ". - "must be passed and must be defined"; - } -} - -has 'bug_num' => - (is => 'ro', - isa => 'Int', - predicate => '_has_bug_num', - ); - -has 'logfh' => - (is => 'ro', - lazy => 1, - builder => '_build_logfh', - predicate => '_has_logfh', - ); - -sub _build_logfh { - my $self = shift; - my $bug_log = - $self->log_name; - my $log_fh; - if ($bug_log =~ m/\.gz$/) { - my $oldpath = $ENV{'PATH'}; - $ENV{'PATH'} = '/bin:/usr/bin'; - open($log_fh,'-|','gzip','-dc',$bug_log) or - die "Unable to open $bug_log for reading: $!"; - $ENV{'PATH'} = $oldpath; - } else { - open($log_fh,'<',$bug_log) or - die "Unable to open $bug_log for reading: $!"; - } - return $log_fh; -} - -has 'log_name' => - (is => 'ro', - isa => 'Str', - lazy => 1, - builder => '_build_log_name', - predicate => '_has_log_name', - ); - -sub _build_log_name { - my $self = shift; - my $location = getbuglocation($self->bug_num,'log'); - return getbugcomponent($self->bug_num,'log',$location); -} - -has 'inner_file' => - (is => 'ro', - isa => 'Bool', - default => 0, - ); - -has 'state' => - (is => 'ro', - isa => 'Str', - default => 'kill-init', - writer => '_state', - ); - -sub state_transition { - my $self = shift; - my $new_state = shift; - my $old_state = $self->state; - local $_ = "$old_state $new_state"; - unless (/^(go|go-nox|html) kill-end$/ or - /^(kill-init|kill-end) (incoming-recv|autocheck|recips|html)$/ or - /^autocheck autowait$/ or - /^autowait go-nox$/ or - /^recips kill-body$/ or - /^(kill-body|incoming-recv) go$/) { - confess "transition from $old_state to $new_state at $self->linenum disallowed"; - } - $self->_state($new_state); -} - -sub increment_linenum { - my $self = shift; - $self->_linenum($self->_linenum+1); -} -has '_linenum' => - (is => 'rw', - isa => 'Int', - default => 0, - ); - -=item read_record - -Reads and returns a single record from a log reader object. At end of file, -returns undef. Throws exceptions using die(), so you may want to wrap this -in an eval(). - -=cut - -sub read_record -{ - my $this = shift; - my $logfh = $this->logfh; - - # This comes from bugreport.cgi, but is much simpler since it doesn't - # worry about the details of output. - - my $record = {}; - - while (defined (my $line = <$logfh>)) { - $record->{start} = $logfh->tell() if not defined $record->{start}; - chomp $line; - $this->increment_linenum; - if (length($line) == 1 and exists $states{ord($line)}) { - # state transitions - $this->state_transition($states{ord($line)}); - if ($this->state =~ /^(autocheck|recips|html|incoming-recv)$/) { - $record->{type} = $this->state; - $record->{start} = $logfh->tell; - $record->{stop} = $logfh->tell; - $record->{inner_file} = $this->inner_file; - } elsif ($this->state eq 'kill-end') { - if ($this->inner_file) { - $record->{fh} = - IO::InnerFile->new($logfh,$record->{start}, - $record->{stop} - $record->{start}) - } - return $record; - } - - next; - } - $record->{stop} = $logfh->tell; - $_ = $line; - if ($this->state eq 'incoming-recv') { - my $pl = $_; - unless (/^Received: \(at \S+\) by \S+;/) { - die "bad line '$pl' in state incoming-recv"; - } - $this->state_transition('go'); - $record->{text} .= "$_\n" unless $this->inner_file; - } elsif ($this->state eq 'html') { - $record->{text} .= "$_\n" unless $this->inner_file; - } elsif ($this->state eq 'go') { - s/^\030//; - $record->{text} .= "$_\n" unless $this->inner_file; - } elsif ($this->state eq 'go-nox') { - $record->{text} .= "$_\n" unless $this->inner_file; - } elsif ($this->state eq 'recips') { - if (/^-t$/) { - undef $record->{recips}; - } else { - # preserve trailing null fields, e.g. #2298 - $record->{recips} = [split /\04/, $_, -1]; - } - $this->state_transition('kill-body'); - $record->{start} = $logfh->tell+2; - $record->{stop} = $logfh->tell+2; - $record->{inner_file} = $this->inner_file; - } elsif ($this->state eq 'autocheck') { - $record->{text} .= "$_\n" unless $this->inner_file; - next if !/^X-Debian-Bugs(-\w+)?: This is an autoforward from (\S+)/; - $this->state_transition('autowait'); - } elsif ($this->state eq 'autowait') { - $record->{text} .= "$_\n" unless $this->inner_file; - next if !/^$/; - $this->state_transition('go-nox'); - } else { - die "state $this->state at line $this->linenum ('$_')"; - } - } - die "state $this->state at end" unless $this->state eq 'kill-end'; - - if (keys %$record) { - return $record; - } else { - return undef; - } -} - -=item rewind - -Rewinds the Debbugs::Log to the beginning - -=cut - -sub rewind { - my $self = shift; - if ($self->_has_log_name) { - $self->_clear_log_fh; - } else { - $self->log_fh->seek(0); - } - $self->_state('kill-init'); - $self->_linenum(0); -} - -=item read_all_records - -Reads all of the Debbugs::Records - -=cut - -sub read_all_records { - my $self = shift; - if ($self->_linenum != 0) { - $self->rewind; - } - my @records; - while (defined(my $record = $self->read_record())) { - push @records, $record; - } - return @records; -} - - -=item read_log_records - -Takes a .log filehandle as input, and returns an array of all records in -that file. Throws exceptions using die(), so you may want to wrap this in an -eval(). - -Uses exactly the same options as Debbugs::Log::new - -=cut - -sub read_log_records -{ - my %param; - if (@_ == 1) { - ($param{logfh}) = @_; - } - else { - %param = validate_with(params => \@_, - spec => {bug_num => {type => SCALAR, - optional => 1, - }, - logfh => {type => HANDLE, - optional => 1, - }, - log_name => {type => SCALAR, - optional => 1, - }, - inner_file => {type => BOOLEAN, - default => 0, - }, - } - ); - } - if (grep({exists $param{$_} and defined $param{$_}} qw(bug_num logfh log_name)) ne 1) { - croak "Exactly one of bug_num, logfh, or log_name must be passed and must be defined"; - } - - my @records; - my $reader = Debbugs::Log->new(%param); - while (defined(my $record = $reader->read_record())) { - push @records, $record; - } - return @records; -} - -=item write_log_records - -Takes a filehandle and a list of records as input, and prints the .log -format representation of those records to that filehandle. - -=back - -=cut - -sub write_log_records -{ - my %param = validate_with(params => \@_, - spec => {bug_num => {type => SCALAR, - optional => 1, - }, - logfh => {type => HANDLE, - optional => 1, - }, - log_name => {type => SCALAR, - optional => 1, - }, - records => {type => HASHREF|ARRAYREF, - }, - }, - ); - if (grep({exists $param{$_} and defined $param{$_}} qw(bug_num logfh log_name)) ne 1) { - croak "Exactly one of bug_num, logfh, or log_name must be passed and must be defined"; - } - my $logfh; - if (exists $param{logfh}) { - $logfh = $param{logfh} - } - elsif (exists $param{log_name}) { - $logfh = IO::File->new(">>$param{log_name}") or - die "Unable to open bug log $param{log_name} for writing: $!"; - } - elsif (exists $param{bug_num}) { - my $location = getbuglocation($param{bug_num},'log'); - my $bug_log = getbugcomponent($param{bug_num},'log',$location); - $logfh = IO::File->new($bug_log, 'r') or - die "Unable to open bug log $bug_log for reading: $!"; - } - my @records = make_list($param{records}); - - for my $record (@records) { - my $type = $record->{type}; - croak "record type '$type' with no text field" unless defined $record->{text}; - # I am not sure if we really want to croak here; but this is - # almost certainly a bug if is_utf8 is on. - my $text = $record->{text}; - if (is_utf8($text)) { - carp('Record text was in the wrong encoding (perl internal instead of utf8 octets)'); - $text = encode_utf8($text) - } - ($text) = escape_log($text); - if ($type eq 'autocheck') { - print {$logfh} "\01\n$text\03\n" or - die "Unable to write to logfile: $!"; - } elsif ($type eq 'recips') { - print {$logfh} "\02\n"; - my $recips = $record->{recips}; - if (defined $recips) { - croak "recips not undef or array" - unless ref($recips) eq 'ARRAY'; - my $wrong_encoding = 0; - my @recips = - map { if (is_utf8($_)) { - $wrong_encoding=1; - encode_utf8($_); - } else { - $_; - }} @$recips; - carp('Recipients was in the wrong encoding (perl internal instead of utf8 octets') if $wrong_encoding; - print {$logfh} join("\04", @$recips) . "\n" or - die "Unable to write to logfile: $!"; - } else { - print {$logfh} "-t\n" or - die "Unable to write to logfile: $!"; - } - #$text =~ s/^([\01-\07\030])/\030$1/gm; - print {$logfh} "\05\n$text\03\n" or - die "Unable to write to logfile: $!"; - } elsif ($type eq 'html') { - print {$logfh} "\06\n$text\03\n" or - die "Unable to write to logfile: $!"; - } elsif ($type eq 'incoming-recv') { - #$text =~ s/^([\01-\07\030])/\030$1/gm; - print {$logfh} "\07\n$text\03\n" or - die "Unable to write to logfile: $!"; - } else { - croak "unknown record type type '$type'"; - } - } - - 1; -} - -=head2 escape_log - - print {$log} escape_log(@log) - -Applies the log escape regex to the passed logfile. - -=cut - -sub escape_log { - my @log = @_; - return map {s/^([\01-\07\030])/\030$1/gm; $_ } @log; -} - - -sub record_text { - my ($record) = @_; - if ($record->{inner_file}) { - local $/; - my $text; - my $t = $record->{fh}; - $text = <$t>; - $record->{fh}->seek(0,0); - return $text; - } else { - return $record->{text}; - } -} - -sub record_regex { - my ($record,$regex) = @_; - if ($record->{inner_file}) { - my @result; - my $fh = $record->{fh}; - while (<$fh>) { - if (@result = $_ =~ m/$regex/) { - $record->{fh}->seek(0,0); - return @result; - } - } - $record->{fh}->seek(0,0); - return (); - } else { - my @result = $record->{text} =~ m/$regex/; - return @result; - } -} - - -=head1 CAVEATS - -This module does none of the formatting that bugreport.cgi et al do. It's -simply a means for extracting and rewriting raw records. - -=cut - -1; - -# Local Variables: -# indent-tabs-mode: nil -# cperl-indent-level: 4 -# End: diff --git a/Debbugs/Log/Spam.pm b/Debbugs/Log/Spam.pm deleted file mode 100644 index e5ed18f..0000000 --- a/Debbugs/Log/Spam.pm +++ /dev/null @@ -1,279 +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 2017 by Don Armstrong . - -package Debbugs::Log::Spam; - -=head1 NAME - -Debbugs::Log::Spam -- an interface to debbugs .log.spam files and .log.spam.d -directories - -=head1 SYNOPSIS - -use Debbugs::Log::Spam; - -my $spam = Debbugs::Log::Spam->new(bug_num => '12345'); - -=head1 DESCRIPTION - -Spam in bugs can be excluded using a .log.spam file and a .log.spam.d directory. -The file contains message ids, one per line, and the directory contains files -named after message ids, one per file. - -=head1 BUGS - -None known. - -=cut - -use warnings; -use strict; -use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); -use base qw(Exporter); - -BEGIN{ - $VERSION = 1; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - %EXPORT_TAGS = (); - @EXPORT_OK = (); - Exporter::export_ok_tags(keys %EXPORT_TAGS); - $EXPORT_TAGS{all} = [@EXPORT_OK]; - -} - -use Carp; -use feature 'state'; -use Params::Validate qw(:types validate_with); -use Debbugs::Common qw(getbuglocation getbugcomponent filelock unfilelock); - -=head1 FUNCTIONS - -=over 4 - -=item new - -Creates a new log spam reader. - - my $spam_log = Debbugs::Log::Spam->new(log_spam_name => "56/123456.log.spam"); - my $spam_log = Debbugs::Log::Spam->new(bug_num => $nnn); - -Parameters - -=over - -=item bug_num -- bug number - -=item log_spam_name -- name of log - -=back - -One of the above options must be passed. - -=cut - -sub new { - my $this = shift; - state $spec = - {bug_num => {type => SCALAR, - optional => 1, - }, - log_spam_name => {type => SCALAR, - optional => 1, - }, - }; - my %param = - validate_with(params => \@_, - spec => $spec - ); - if (grep({exists $param{$_} and - defined $param{$_}} qw(bug_num log_spam_name)) ne 1) { - croak "Exactly one of bug_num or log_spam_name". - "must be passed and must be defined"; - } - - my $class = ref($this) || $this; - my $self = {}; - bless $self, $class; - - if (exists $param{log_spam_name}) { - $self->{name} = $param{log_spam_name}; - } elsif (exists $param{bug_num}) { - my $location = getbuglocation($param{bug_num},'log.spam'); - my $bug_log = getbugcomponent($param{bug_num},'log.spam',$location); - $self->{name} = $bug_log; - } - $self->_init(); - return $self; -} - - -sub _init { - my $self = shift; - - $self->{spam} = {}; - if (-e $self->{name}) { - open(my $fh,'<',$self->{name}) or - croak "Unable to open bug log spam '$self->{name}' for reading: $!"; - binmode($fh,':encoding(UTF-8)'); - while (<$fh>) { - chomp; - if (s/\sham$//) { - $self->{spam}{$_} = '0'; - } else { - $self->{spam}{$_} = '1'; - } - } - close ($fh) or - croak "Unable to close bug log filehandle: $!"; - } - if (-d $self->{name}.'.d') { - opendir(my $d,$self->{name}.'.d') or - croak "Unable to open bug log spamdir '$self->{name}.d' for reading: $!"; - for my $dir (readdir($d)) { - next unless $dir =~ m/([^\.].*)_(\w+)$/; - # .spam overrides .spam.d - next if exists $self->{spam}{$1}; - # set the spam HASH to $dir so we know where this value was set from - $self->{spam}{$1} = $dir; - } - closedir($d) or - croak "Unable to close bug log spamdir: $!"; - } - return $self; -} - -=item save - -C<$spam_log->save();> - -Saves changes to the bug log spam file. - -=cut - -sub save { - my $self = shift; - return unless keys %{$self->{spam}}; - filelock($self->{name}.'.lock'); - open(my $fh,'>',$self->{name}.'.tmp') or - croak "Unable to open bug log spam '$self->{name}.tmp' for writing: $!"; - binmode($fh,':encoding(UTF-8)'); - for my $msgid (keys %{$self->{spam}}) { - # was this message set to spam/ham by .d? If so, don't save it - if ($self->{spam}{$msgid} ne '0' and - $self->{spam}{$msgid} ne '1') { - next; - } - print {$fh} $msgid; - if ($self->{spam}{$msgid} eq '0') { - print {$fh} ' ham'; - } - print {$fh} "\n"; - } - close($fh) or croak "Unable to write to '$self->{name}.tmp': $!"; - rename($self->{name}.'.tmp',$self->{name}); - unfilelock(); -} - -=item is_spam - -Cis_spam('12456@exmaple.com'));> - -Returns 1 if this message id confirms that the message is spam - -Returns 0 if this message is not known to be spam - -=cut -sub is_spam { - my ($self,$msgid) = @_; - return 0 if not defined $msgid or not length $msgid; - $msgid =~ s/^<|>$//; - if (exists $self->{spam}{$msgid} and - $self->{spam}{$msgid} ne '0' - ) { - return 1; - } - return 0; -} - -=item is_ham - - next if ($spam_log->is_ham('12456@exmaple.com')); - -Returns 1 if this message id confirms that the message is ham - -Returns 0 if this message is not known to be ham - -=cut -sub is_ham { - my ($self,$msgid) = @_; - return 0 if not defined $msgid or not length $msgid; - $msgid =~ s/^<|>$//; - if (exists $self->{spam}{$msgid} and - $self->{spam}{$msgid} eq '0' - ) { - return 1; - } - return 0; -} - - -=item add_spam - - $spam_log->add_spam('123456@example.com'); - -Add a message id to the spam listing. - -You must call C<$spam_log->save()> if you wish the changes to be written out to disk. - -=cut - -sub add_spam { - my ($self,$msgid) = @_; - $msgid =~ s/^<|>$//; - $self->{spam}{$msgid} = '1'; -} - -=item add_ham - - $spam_log->add_ham('123456@example.com'); - -Add a message id to the ham listing. - -You must call C<$spam_log->save()> if you wish the changes to be written out to disk. - -=cut - -sub add_ham { - my ($self,$msgid) = @_; - $msgid =~ s/^<|>$//; - $self->{spam}{$msgid} = '0'; -} - -=item remove_message - - $spam_log->remove_message('123456@example.com'); - -Remove a message from the spam/ham listing. - -You must call C<$spam_log->save()> if you wish the changes to be written out to disk. - -=cut - - -1; - -=back - -=cut - -__END__ - -# Local Variables: -# indent-tabs-mode: nil -# cperl-indent-level: 4 -# End: diff --git a/Debbugs/MIME.pm b/Debbugs/MIME.pm deleted file mode 100644 index fec3b6e..0000000 --- a/Debbugs/MIME.pm +++ /dev/null @@ -1,399 +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. -# -# [Other people have contributed to this file; their copyrights should -# go here too.] -# Copyright 2006 by Don Armstrong . - - -package Debbugs::MIME; - -=encoding utf8 - -=head1 NAME - -Debbugs::MIME -- Mime handling routines for debbugs - -=head1 SYNOPSIS - - use Debbugs::MIME qw(parse decode_rfc1522); - -=head1 DESCRIPTION - - -=head1 BUGS - -None known. - -=cut - -use warnings; -use strict; - -use Exporter qw(import); -use vars qw($DEBUG $VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT); - -BEGIN { - $VERSION = 1.00; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - - %EXPORT_TAGS = (mime => [qw(parse create_mime_message getmailbody), - qw(parse_to_mime_entity), - ], - rfc1522 => [qw(decode_rfc1522 encode_rfc1522)], - ); - @EXPORT_OK=(); - Exporter::export_ok_tags(keys %EXPORT_TAGS); - $EXPORT_TAGS{all} = [@EXPORT_OK]; -} - -use File::Path qw(remove_tree); -use File::Temp qw(tempdir); -use MIME::Parser; - -use POSIX qw(strftime); -use List::AllUtils qw(apply); - -# for convert_to_utf8 -use Debbugs::UTF8 qw(convert_to_utf8); - -# for decode_rfc1522 and encode_rfc1522 -use Encode qw(decode encode encode_utf8 decode_utf8 is_utf8); -use MIME::Words qw(); - -sub getmailbody -{ - my $entity = shift; - my $type = $entity->effective_type; - if ($type eq 'text/plain' or - ($type =~ m#text/?# and $type ne 'text/html') or - $type eq 'application/pgp') { - return $entity; - } elsif ($type eq 'multipart/alternative') { - # RFC 2046 says we should use the last part we recognize. - for my $part (reverse $entity->parts) { - my $ret = getmailbody($part); - return $ret if $ret; - } - } else { - # For other multipart types, we just pretend they're - # multipart/mixed and run through in order. - for my $part ($entity->parts) { - my $ret = getmailbody($part); - return $ret if $ret; - } - } - return undef; -} - -=head2 parse_to_mime_entity - - $entity = parse_to_mime_entity($record); - -Returns a MIME::Entity from a record (from Debbugs::Log), a filehandle, or a -scalar mail message. Will die upon failure. - -Intermediate parsing results will be output under a temporary directory which -should be cleaned up upon process exit. - -=cut - -sub parse_to_mime_entity { - my ($record) = @_; - my $parser = MIME::Parser->new(); - my $entity; - # this will be cleaned up once we exit - my $tempdir = File::Temp->newdir(); - $parser->output_dir($tempdir->dirname()); - if (ref($record) eq 'HASH') { - if ($record->{inner_file}) { - $entity = $parser->parse($record->{fh}) or - die "Unable to parse entity"; - } else { - $entity = $parser->parse_data($record->{text}) or - die "Unable to parse entity"; - } - } elsif (ref($record)) { - $entity = $parser->parse($record) or - die "Unable to parse entity"; - } else { - $entity = $parser->parse_data($record) or - die "Unable to parse entity"; - } - return $entity; -} - -sub parse -{ - # header and decoded body respectively - my (@headerlines, @bodylines); - - my $parser = MIME::Parser->new(); - my $tempdir = tempdir(CLEANUP => 1); - $parser->output_under($tempdir); - my $entity = eval { $parser->parse_data($_[0]) }; - - if ($entity and $entity->head->tags) { - @headerlines = @{$entity->head->header}; - chomp @headerlines; - - my $entity_body = getmailbody($entity); - my $entity_body_handle; - my $charset; - if (defined $entity_body) { - $entity_body_handle = $entity_body->bodyhandle(); - $charset = $entity_body->head()->mime_attr('content-type.charset'); - } - @bodylines = $entity_body_handle ? $entity_body_handle->as_lines() : (); - @bodylines = map {convert_to_utf8($_,$charset)} @bodylines; - chomp @bodylines; - } else { - # Legacy pre-MIME code, kept around in case MIME::Parser fails. - my @msg = split /\n/, $_[0]; - my $i; - - # assume us-ascii unless charset is set; probably bad, but we - # really shouldn't get to this point anyway - my $charset = 'us-ascii'; - for ($i = 0; $i <= $#msg; ++$i) { - $_ = $msg[$i]; - last unless length; - while ($msg[$i + 1] =~ /^\s/) { - ++$i; - $_ .= "\n" . $msg[$i]; - } - if (/charset=\"([^\"]+)\"/) { - $charset = $1; - } - push @headerlines, $_; - } - @bodylines = map {convert_to_utf8($_,$charset)} @msg[$i .. $#msg]; - } - - remove_tree($tempdir,{verbose => 0, safe => 1}); - - # Remove blank lines. - shift @bodylines while @bodylines and $bodylines[0] !~ /\S/; - - # Strip off RFC2440-style PGP clearsigning. - if (@bodylines and $bodylines[0] =~ /^-----BEGIN PGP SIGNED/) { - shift @bodylines while @bodylines and - length $bodylines[0] and - # we currently don't strip \r; handle this for the - # time being, though eventually it should be stripped - # too, I think. [See #565981] - $bodylines[0] ne "\r"; - shift @bodylines while @bodylines and $bodylines[0] !~ /\S/; - for my $findsig (0 .. $#bodylines) { - if ($bodylines[$findsig] =~ /^-----BEGIN PGP SIGNATURE/) { - $#bodylines = $findsig - 1; - last; - } - } - map { s/^- // } @bodylines; - } - - return { header => [@headerlines], body => [@bodylines]}; -} - -=head2 create_mime_message - - create_mime_message([To=>'don@debian.org'],$body,[$attach1, $attach2],$include_date); - -Creates a MIME encoded message with headers given by the first -argument, and a message given by the second. - -Optional attachments can be specified in the third arrayref argument. - -Whether to include the date in the header is the final argument; it -defaults to true, setting the Date header if one is not already -present. - -Headers are passed directly to MIME::Entity::build, the message is the -first attachment. - -Each of the elements of the attachment arrayref is attached as an -rfc822 message if it is a scalar or an arrayref; otherwise if it is a -hashref, the contents are passed as an argument to -MIME::Entity::attach - -=cut - -sub create_mime_message{ - my ($headers,$body,$attachments,$include_date) = @_; - $attachments = [] if not defined $attachments; - $include_date = 1 if not defined $include_date; - - die "The first argument to create_mime_message must be an arrayref" unless ref($headers) eq 'ARRAY'; - die "The third argument to create_mime_message must be an arrayref" unless ref($attachments) eq 'ARRAY'; - - if ($include_date) { - my %headers = apply {defined $_ ? lc($_) : ''} @{$headers}; - if (not exists $headers{date}) { - push @{$headers}, - ('Date', - strftime("%a, %d %b %Y %H:%M:%S +0000",gmtime) - ); - } - } - - # Build the message - # MIME::Entity is stupid, and doesn't rfc1522 encode its headers, so we do it for it. - my $msg = MIME::Entity->build('Content-Type' => 'text/plain; charset=utf-8', - 'Encoding' => 'quoted-printable', - (map{encode_rfc1522(encode_utf8(defined $_ ? $_:''))} @{$headers}), - Data => encode_utf8($body), - ); - - # Attach the attachments - for my $attachment (@{$attachments}) { - if (ref($attachment) eq 'HASH') { - $msg->attach(%{$attachment}); - } - else { - # This is *craptacular*, but because various MTAs - # (sendmail and exim4, at least) appear to eat From - # lines in message/rfc822 attachments, we need eat - # the entire From line ourselves so the MTA doesn't - # leave \n detrius around. - if (ref($attachment) eq 'ARRAY' and $attachment->[1] =~ /^From /) { - # make a copy so that we don't screw up anything - # that is expecting this arrayref to stay constant - $attachment = [@{$attachment}]; - # remove the from line - splice @$attachment, 1, 1; - } - elsif (not ref($attachment)) { - # It's a scalar; remove the from line - $attachment =~ s/^(Received:[^\n]+\n)(From [^\n]+\n)/$1/s; - } - $msg->attach(Type => 'message/rfc822', - Data => $attachment, - Encoding => '7bit', - ); - } - } - return $msg->as_string; -} - - - - -=head2 decode_rfc1522 - - decode_rfc1522('=?iso-8859-1?Q?D=F6n_Armstr=F3ng?= ') - -Turn RFC-1522 names into the UTF-8 equivalent. - -=cut - -sub decode_rfc1522 { - my ($string) = @_; - - # this is craptacular, but leading space is hacked off by unmime. - # Save it. - my $leading_space = ''; - $leading_space = $1 if $string =~ s/^(\ +)//; - # we must do this to switch off the utf8 flag before calling decode_mimewords - $string = encode_utf8($string); - my @mime_words = MIME::Words::decode_mimewords($string); - my $tmp = $leading_space . - join('', - (map { - if (@{$_} > 1) { - convert_to_utf8(${$_}[0],${$_}[1]); - } else { - decode_utf8(${$_}[0]); - } - } @mime_words) - ); - return $tmp; -} - -=head2 encode_rfc1522 - - encode_rfc1522('Dön Armströng ') - -Encodes headers according to the RFC1522 standard by calling -MIME::Words::encode_mimeword on distinct words as appropriate. - -=cut - -# We cannot use MIME::Words::encode_mimewords because that function -# does not handle spaces properly at all. - -sub encode_rfc1522 { - my ($rawstr) = @_; - - # handle being passed undef properly - return undef if not defined $rawstr; - - # convert to octets if we are given a string in perl's internal - # encoding - $rawstr= encode_utf8($rawstr) if is_utf8($rawstr); - # We process words in reverse so we can preserve spacing between - # encoded words. This regex splits on word|nonword boundaries and - # nonword|nonword boundaries. We also consider parenthesis and " - # to be nonwords to avoid escaping them in comments in violation - # of RFC1522 - my @words = reverse split /(?:(?<=[\s\n\)\(\"])|(?=[\s\n\)\(\"]))/m, $rawstr; - - my $previous_word_encoded = 0; - my $string = ''; - for my $word (@words) { - if ($word !~ m#[\x00-\x1F\x7F-\xFF]#o and $word ne ' ') { - $string = $word.$string; - $previous_word_encoded=0; - } - elsif ($word =~ /^[\s\n]$/) { - $string = $word.$string; - $previous_word_encoded = 0 if $word eq "\n"; - } - else { - my $encoded = MIME::Words::encode_mimeword($word, 'q', 'UTF-8'); - # RFC 1522 mandates that segments be at most 76 characters - # long. If that's the case, we split the word up into 10 - # character pieces and encode it. We must use the Encode - # magic here to avoid breaking on bit boundaries here. - if (length $encoded > 75) { - # Turn utf8 into the internal perl representation - # so . is a character, not a byte. - my $tempstr = is_utf8($word)?$word:decode_utf8($word,Encode::FB_DEFAULT); - my @encoded; - # Strip it into 10 character long segments, and encode - # the segments - # XXX It's possible that these segments are > 76 characters - while ($tempstr =~ s/(.{1,10})$//) { - # turn the character back into the utf8 representation. - my $tempword = encode_utf8($1); - # It may actually be better to eventually use - # the base64 encoding here, but I'm not sure - # if that's as widely supported as quoted - # printable. - unshift @encoded, MIME::Words::encode_mimeword($tempword,'q','UTF-8'); - } - $encoded = join(" ",@encoded); - # If the previous word was encoded, we must - # include a trailing _ that gets encoded as a - # space. - $encoded =~ s/\?\=$/_\?\=/ if $previous_word_encoded; - $string = $encoded.$string; - } - else { - # If the previous word was encoded, we must - # include a trailing _ that gets encoded as a - # space. - $encoded =~ s/\?\=$/_\?\=/ if $previous_word_encoded; - $string = $encoded.$string; - } - $previous_word_encoded = 1; - } - } - return $string; -} - -1; diff --git a/Debbugs/Mail.pm b/Debbugs/Mail.pm deleted file mode 100644 index e4c8bf7..0000000 --- a/Debbugs/Mail.pm +++ /dev/null @@ -1,552 +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 2004-7 by Don Armstrong . - -package Debbugs::Mail; - -=head1 NAME - -Debbugs::Mail -- Outgoing Mail Handling - -=head1 SYNOPSIS - -use Debbugs::Mail qw(send_mail_message get_addresses); - -my @addresses = get_addresses('blah blah blah foo@bar.com') -send_mail_message(message => <[@addresses]); -To: $addresses[0] -Subject: Testing - -Testing 1 2 3 -END - -=head1 EXPORT TAGS - -=over - -=item :all -- all functions that can be exported - -=back - -=head1 FUNCTIONS - - -=cut - -use warnings; -use strict; -use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); -use Exporter qw(import); - -use IPC::Open3; -use POSIX qw(:sys_wait_h strftime); -use Time::HiRes qw(usleep gettimeofday); -use Mail::Address (); -use Debbugs::MIME qw(encode_rfc1522); -use Debbugs::Config qw(:config); -use Params::Validate qw(:types validate_with); -use Encode qw(encode is_utf8); -use Debbugs::UTF8 qw(encode_utf8_safely convert_to_utf8); - -use Debbugs::Packages; - -BEGIN{ - ($VERSION) = q$Revision: 1.1 $ =~ /^Revision:\s+([^\s+])/; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - %EXPORT_TAGS = (addresses => [qw(get_addresses)], - misc => [qw(rfc822_date)], - mail => [qw(send_mail_message encode_headers default_headers)], - reply => [qw(reply_headers)], - ); - @EXPORT_OK = (); - Exporter::export_ok_tags(keys %EXPORT_TAGS); - $EXPORT_TAGS{all} = [@EXPORT_OK]; -} - -# We set this here so it can be overridden for testing purposes -our $SENDMAIL = $config{sendmail}; - -=head2 get_addresses - - my @addresses = get_addresses('don@debian.org blars@debian.org - kamion@debian.org ajt@debian.org'); - -Given a string containing some e-mail addresses, parses the string -using Mail::Address->parse and returns a list of the addresses. - -=cut - -sub get_addresses { - return map { $_->address() } map { Mail::Address->parse($_) } @_; -} - - -=head2 default_headers - - my @head = default_headers(queue_file => 'foo', - data => $data, - msgid => $header{'message-id'}, - msgtype => 'error', - headers => [...], - ); - create_mime_message(\@headers, - ... - ); - -This function is generally called to generate the headers for -create_mime_message (and anything else that needs a set of default -headers.) - -In list context, returns an array of headers. In scalar context, -returns headers for shoving in a mail message after encoding using -encode_headers. - -=head3 options - -=over - -=item queue_file -- the queue file which will generate this set of -headers (refered to as $nn in lots of the code) - -=item data -- the data of the bug which this message involves; can be -undefined if there is no bug involved. - -=item msgid -- the Message-ID: of the message which will generate this -set of headers - -=item msgtype -- the type of message that this is. - -=item pr_msg -- the pr message field - -=item headers -- a set of headers which will override the default -headers; these headers will be passed through (and may be reordered.) -If a particular header is undef, it overrides the default, but isn't -passed through. - -=back - -=head3 default headers - -=over - -=item X-Loop -- set to the maintainer e-mail - -=item From -- set to the maintainer e-mail - -=item To -- set to Unknown recipients - -=item Subject -- set to Unknown subject - -=item Message-ID -- set appropriately (see code) - -=item Precedence -- set to bulk - -=item References -- set to the full set of message ids that are known -(from data and the msgid option) - -=item In-Reply-To -- set to msg id or the msgid from data - -=item X-Project-PR-Message -- set to pr_msg with the bug number appended - -=item X-Project-PR-Package -- set to the package of the bug - -=item X-Project-PR-Keywords -- set to the keywords of the bug - -=item X-Project-PR-Source -- set to the source of the bug - -=back - -=cut - -sub default_headers { - my %param = validate_with(params => \@_, - spec => {queue_file => {type => SCALAR|UNDEF, - optional => 1, - }, - data => {type => HASHREF, - optional => 1, - }, - msgid => {type => SCALAR|UNDEF, - optional => 1, - }, - msgtype => {type => SCALAR|UNDEF, - default => 'misc', - }, - pr_msg => {type => SCALAR|UNDEF, - default => 'misc', - }, - headers => {type => ARRAYREF, - default => [], - }, - }, - ); - my @header_order = (qw(X-Loop From To subject), - qw(Message-ID In-Reply-To References)); - # handle various things being undefined - if (not exists $param{queue_file} or - not defined $param{queue_file}) { - $param{queue_file} = join('',gettimeofday()) - } - for (qw(msgtype pr_msg)) { - if (not exists $param{$_} or - not defined $param{$_}) { - $param{$_} = 'misc'; - } - } - my %header_order; - @header_order{map {lc $_} @header_order} = 0..$#header_order; - my %set_headers; - my @ordered_headers; - my @temp = @{$param{headers}}; - my @other_headers; - while (my ($header,$value) = splice @temp,0,2) { - if (exists $header_order{lc($header)}) { - push @{$ordered_headers[$header_order{lc($header)}]}, - ($header,$value); - } - else { - push @other_headers,($header,$value); - } - $set_headers{lc($header)} = 1; - } - - # calculate our headers - my $bug_num = exists $param{data} ? $param{data}{bug_num} : 'x'; - my $nn = $param{queue_file}; - # handle the user giving the actual queue filename instead of nn - $nn =~ s/^[a-zA-Z]([a-zA-Z])/$1/; - $nn = lc($nn); - my @msgids; - if (exists $param{msgid} and defined $param{msgid}) { - push @msgids, $param{msgid} - } - elsif (exists $param{data} and defined $param{data}{msgid}) { - push @msgids, $param{data}{msgid} - } - my %default_header; - $default_header{'X-Loop'} = $config{maintainer_email}; - $default_header{From} = "$config{maintainer_email} ($config{project} $config{ubug} Tracking System)"; - $default_header{To} = "Unknown recipients"; - $default_header{Subject} = "Unknown subject"; - $default_header{'Message-ID'} = ""; - if (@msgids) { - $default_header{'In-Reply-To'} = $msgids[0]; - $default_header{'References'} = join(' ',@msgids); - } - $default_header{Precedence} = 'bulk'; - $default_header{"X-$config{project}-PR-Message"} = $param{pr_msg} . (exists $param{data} ? ' '.$param{data}{bug_num}:''); - $default_header{Date} = rfc822_date(); - if (exists $param{data}) { - if (defined $param{data}{keywords}) { - $default_header{"X-$config{project}-PR-Keywords"} = $param{data}{keywords}; - } - if (defined $param{data}{package}) { - $default_header{"X-$config{project}-PR-Package"} = $param{data}{package}; - if ($param{data}{package} =~ /^src:(.+)$/) { - $default_header{"X-$config{project}-PR-Source"} = $1; - } - else { - my $pkg_src = Debbugs::Packages::getpkgsrc(); - $default_header{"X-$config{project}-PR-Source"} = $pkg_src->{$param{data}{package}}; - } - } - } - for my $header (sort keys %default_header) { - next if $set_headers{lc($header)}; - if (exists $header_order{lc($header)}) { - push @{$ordered_headers[$header_order{lc($header)}]}, - ($header,$default_header{$header}); - } - else { - push @other_headers,($header,$default_header{$header}); - } - } - my @headers; - for my $hdr1 (@ordered_headers) { - next if not defined $hdr1; - my @temp = @{$hdr1}; - while (my ($header,$value) = splice @temp,0,2) { - next if not defined $value; - push @headers,($header,$value); - } - } - push @headers,@other_headers; - if (wantarray) { - return @headers; - } - else { - my $headers = ''; - while (my ($header,$value) = splice @headers,0,2) { - $headers .= "${header}: $value\n"; - } - return $headers; - } -} - - - -=head2 send_mail_message - - send_mail_message(message => $message, - recipients => [@recipients], - envelope_from => 'don@debian.org', - ); - - -=over - -=item message -- message to send out - -=item recipients -- recipients to send the message to. If undefed or -an empty arrayref, will use '-t' to parse the message for recipients. - -=item envelope_from -- envelope_from for outgoing messages - -=item encode_headers -- encode headers using RFC1522 (default) - -=item parse_for_recipients -- use -t to parse the message for -recipients in addition to those specified. [Can be used to set Bcc -recipients, for example.] - -=back - -Returns true on success, false on failures. All errors are indicated -using warn. - -=cut - -sub send_mail_message{ - my %param = validate_with(params => \@_, - spec => {sendmail_arguments => {type => ARRAYREF, - default => $config{sendmail_arguments}, - }, - parse_for_recipients => {type => BOOLEAN, - default => 0, - }, - encode_headers => {type => BOOLEAN, - default => 1, - }, - message => {type => SCALAR, - }, - envelope_from => {type => SCALAR, - default => $config{envelope_from}, - }, - recipients => {type => ARRAYREF|UNDEF, - optional => 1, - }, - }, - ); - my @sendmail_arguments = @{$param{sendmail_arguments}}; - push @sendmail_arguments, '-f', $param{envelope_from} if - exists $param{envelope_from} and - defined $param{envelope_from} and - length $param{envelope_from}; - - my @recipients; - @recipients = @{$param{recipients}} if defined $param{recipients} and - ref($param{recipients}) eq 'ARRAY'; - my %recipients; - @recipients{@recipients} = (1) x @recipients; - @recipients = keys %recipients; - # If there are no recipients, use -t to parse the message - if (@recipients == 0) { - $param{parse_for_recipients} = 1 unless exists $param{parse_for_recipients}; - } - # Encode headers if necessary - $param{encode_headers} = 1 if not exists $param{encode_headers}; - if ($param{encode_headers}) { - $param{message} = encode_headers($param{message}); - } - - # First, try to send the message as is. - eval { - _send_message($param{message}, - @sendmail_arguments, - $param{parse_for_recipients}?q(-t):(), - @recipients); - }; - return 1 unless $@; - # If there's only one recipient, there's nothing more we can do, - # so bail out. - warn $@ and return 0 if $@ and @recipients == 0; - # If that fails, try to send the message to each of the - # recipients separately. We also send the -t option separately in - # case one of the @recipients is ok, but the addresses in the - # mail message itself are malformed. - my @errors; - for my $recipient ($param{parse_for_recipients}?q(-t):(),@recipients) { - eval { - _send_message($param{message},@sendmail_arguments,$recipient); - }; - push @errors, "Sending to $recipient failed with $@" if $@; - } - # If it still fails, complain bitterly but don't die. - warn join(qq(\n),@errors) and return 0 if @errors; - return 1; -} - -=head2 encode_headers - - $message = encode_heeaders($message); - -RFC 1522 encodes the headers of a message - -=cut - -sub encode_headers{ - my ($message) = @_; - - my ($header,$body) = split /\n\n/, $message, 2; - $header = encode_rfc1522($header); - return $header . qq(\n\n). encode_utf8_safely($body); -} - -=head2 rfc822_date - - rfc822_date - -Return the current date in RFC822 format in the UTC timezone - -=cut - -sub rfc822_date{ - return scalar strftime "%a, %d %h %Y %T +0000", gmtime; -} - -=head2 reply_headers - - reply_headers(MIME::Parser->new()->parse_data(\$data)); - -Generates suggested headers and a body for replies. Primarily useful -for use in RFC2368 mailto: entries. - -=cut - -sub reply_headers{ - my ($entity) = @_; - - my $head = $entity->head; - # build reply link - my %r_l; - $r_l{subject} = $head->get('Subject'); - $r_l{subject} //= 'Your mail'; - $r_l{subject} = 'Re: '. $r_l{subject} unless $r_l{subject} =~ /(?:^|\s)Re:\s+/; - $r_l{subject} =~ s/(?:^\s*|\s*$)//g; - $r_l{'In-Reply-To'} = $head->get('Message-Id'); - $r_l{'In-Reply-To'} =~ s/(?:^\s*|\s*$)//g if defined $r_l{'In-Reply-To'}; - delete $r_l{'In-Reply-To'} unless defined $r_l{'In-Reply-To'}; - $r_l{References} = ($head->get('References')//''). ' '.($head->get('Message-Id')//''); - $r_l{References} =~ s/(?:^\s*|\s*$)//g; - my $date = $head->get('Date') // 'some date'; - $date =~ s/(?:^\s*|\s*$)//g; - my $who = $head->get('From') // $head->get('Reply-To') // 'someone'; - $who =~ s/(?:^\s*|\s*$)//g; - - my $body = "On $date $who wrote:\n"; - my $i = 60; - my $b_h; - # Default to UTF-8. - my $charset="utf-8"; - ## find the first part which has a defined body handle and appears - ## to be text - if (defined $entity->bodyhandle) { - my $this_charset = - $entity->head->mime_attr("content-type.charset"); - $charset = $this_charset if - defined $this_charset and - length $this_charset; - $b_h = $entity->bodyhandle; - } elsif ($entity->parts) { - my @parts = $entity->parts; - while (defined(my $part = shift @parts)) { - if ($part->parts) { - push @parts,$part->parts; - } - if (defined $part->bodyhandle and - $part->effective_type =~ /text/) { - my $this_charset = - $part->head->mime_attr("content-type.charset"); - $charset = $this_charset if - defined $this_charset and - length $this_charset; - $b_h = $part->bodyhandle; - last; - } - } - } - if (defined $b_h) { - eval { - my $IO = $b_h->open("r"); - while (defined($_ = $IO->getline)) { - $i--; - last if $i < 0; - $body .= '> '. convert_to_utf8($_,$charset); - } - $IO->close(); - }; - } - $r_l{body} = $body; - return \%r_l; -} - -=head1 PRIVATE FUNCTIONS - -=head2 _send_message - - _send_message($message,@sendmail_args); - -Private function that actually calls sendmail with @sendmail_args and -sends message $message. - -dies with errors, so calls to this function in send_mail_message -should be wrapped in eval. - -=cut - -sub _send_message{ - my ($message,@sendmail_args) = @_; - - my ($wfh,$rfh); - my $pid = open3($wfh,$rfh,$rfh,$SENDMAIL,@sendmail_args) - or die "Unable to fork off $SENDMAIL: $!"; - local $SIG{PIPE} = 'IGNORE'; - eval { - print {$wfh} $message or die "Unable to write to $SENDMAIL: $!"; - close $wfh or die "$SENDMAIL exited with $?"; - }; - if ($@) { - local $\; - # Reap the zombie - waitpid($pid,WNOHANG); - # This shouldn't block because the pipe closing is the only - # way this should be triggered. - my $message = <$rfh>; - die "$@$message"; - } - # Wait for sendmail to exit for at most 30 seconds. - my $loop = 0; - while (waitpid($pid, WNOHANG) == 0 or $loop++ >= 600){ - # sleep for a 20th of a second - usleep(50_000); - } - if ($loop >= 600) { - warn "$SENDMAIL didn't exit within 30 seconds"; - } -} - - -1; - - -__END__ - - - - - - diff --git a/Debbugs/OOBase.pm b/Debbugs/OOBase.pm deleted file mode 100644 index 6600e02..0000000 --- a/Debbugs/OOBase.pm +++ /dev/null @@ -1,48 +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::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', - ); - -sub schema_argument { - my $self = shift; - if ($self->has_schema) { - return (schema => $self->schema); - } else { - return (); - } -} - -__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 deleted file mode 100644 index 37473d0..0000000 --- a/Debbugs/OOTypes.pm +++ /dev/null @@ -1,58 +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::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 deleted file mode 100644 index 70f0e35..0000000 --- a/Debbugs/Package.pm +++ /dev/null @@ -1,729 +0,0 @@ -# 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 Mouse; -use strictures 2; -use v5.10; # for state -use namespace::autoclean; - -use List::AllUtils qw(uniq pairmap); -use Debbugs::Config qw(:config); -use Debbugs::Version::Source; -use Debbugs::Version::Binary; - -extends 'Debbugs::OOBase'; - -=head2 name - -Name of the Package - -=head2 qualified_name - -name if binary, name prefixed with C if source - -=cut - -has name => (is => 'ro', isa => 'Str', - required => 1, - ); - -sub qualified_name { - my $self = shift; - return - # src: if source, nothing if binary - ($self->_type eq 'source' ? 'src:':'') . - $self->name; -} - - -=head2 type - -Type of the package; either C or C - -=cut - -has type => (is => 'bare', isa => 'Str', - lazy => 1, - builder => '_build_type', - clearer => '_clear_type', - reader => '_type', - writer => '_set_type', - ); - -sub _build_type { - my $self = shift; - if ($self->name !~ /^src:/) { - return 'binary'; - } -} - -=head2 url - -url to the package - -=cut - -sub url { - my $self = shift; - return $config{web_domain}.'/'.$self->qualified_name; -} - -around BUILDARGS => sub { - my $orig = shift; - my $class = shift; - my %args; - if (@_==1 and ref($_[0]) eq 'HASH') { - %args = %{$_[0]}; - } else { - %args = @_; - } - $args{name} //= '(unknown)'; - if ($args{name} =~ /src:(.+)/) { - $args{name} = $1; - $args{type} = 'source'; - } else { - $args{type} = 'binary' unless - defined $args{type}; - } - return $class->$orig(%args); -}; - -=head2 is_source - -true if the package is a source package - -=head2 is_binary - -true if the package is a binary package - -=cut - -sub is_source { - return $_[0]->_type eq 'source' -} - -sub is_binary { - return $_[0]->_type eq 'binary' -} - -=head2 valid -- true if the package has any valid versions - -=cut - -has valid => (is => 'ro', isa => 'Bool', - lazy => 1, - builder => '_build_valid', - writer => '_set_valid', - ); - -sub _build_valid { - my $self = shift; - if ($self->valid_version_info_count> 0) { - return 1; - } - return 0; -} - -# this contains source name, source version, binary name, binary version, arch, -# and dist which have been selected from the database. It is used to build -# versions and anything else which are known as required. -has 'valid_version_info' => - (is => 'bare', isa => 'ArrayRef', - traits => ['Array'], - lazy => 1, - builder => '_build_valid_version_info', - predicate => '_has_valid_version_info', - clearer => '_clear_valid_version_info', - handles => {'_get_valid_version_info' => 'get', - 'valid_version_info_grep' => 'grep', - '_valid_version_info' => 'elements', - 'valid_version_info_count' => 'count', - }, - ); - -sub _build_valid_version_info { - my $self = shift; - my $pkgs = $self->_get_valid_version_info_from_db; - for my $invalid_version (@{$pkgs->{$self->qualified_name}->{invalid_versions}}) { - $self->_mark_invalid_version($invalid_version,1); - } - return $pkgs->{$self->qualified_name}->{valid_version_info} // []; -} - -state $common_dists = [@{$config{distributions}}]; -sub _get_valid_version_info_from_db { - my $self; - if ((@_ % 2) == 1 and - blessed($_[0])) { - $self = shift; - } - my %args = @_; - my @packages; - my $s; # schema - if (defined $self) { - if ($self->has_schema) { - $s = $self->schema; - } else { - $s = $args{schema}; - } - @packages = $self->qualified_name; - } else { - $s = $args{schema}; - @packages = @{$args{packages}}; - } - if (not defined $s) { - confess("get_info_from_db not implemented without schema"); - } - my %src_packages; - my %src_ver_packages; - my %bin_packages; - my %bin_ver_packages; - # split packages into src/ver, bin/ver, src, and bin so we can select them - # from the database - local $_; - for my $pkg (@packages) { - if (ref($pkg)) { - if ($pkg->[0] =~ /^src:(.+)$/) { - for my $ver (@{$pkg}[1..$#{$pkg}]) { - $src_ver_packages{$1}{$ver} = 0; - } - } else { - for my $ver (@{$pkg}[1..$#{$pkg}]) { - $bin_ver_packages{$pkg->[0]}{$ver} = 0; - } - } - } elsif ($pkg =~ /^src:(.+)$/) { - $src_packages{$1} = 0; - } else { - $bin_packages{$pkg} = 0; - } - } - # calculate searches for packages where we want specific versions. We - # calculate this here so add_result_to_package can stomp over - # %src_ver_packages and %bin_ver_packages - my @src_ver_search; - for my $sp (keys %src_ver_packages) { - push @src_ver_search, - (-and => {'src_pkg.pkg' => $sp, - 'me.ver' => [keys %{$src_ver_packages{$sp}}], - }, - ); - } - my @src_packages = keys %src_packages; - - my @bin_ver_search; - for my $sp (keys %bin_ver_packages) { - push @bin_ver_search, - (-and => {'bin_pkg.pkg' => $sp, - 'me.ver' => [keys %{$bin_ver_packages{$sp}}], - }, - ); - } - my @bin_packages = keys %bin_packages; - my $packages = {}; - sub _default_pkg_info { - return {name => $_[0], - type => $_[1]//'source', - valid => $_[2]//1, - valid_version_info => [], - invalid_versions => {}, - }; - } - sub add_result_to_package { - my ($pkgs,$rs,$svp,$bvp,$sp,$bp) = @_; - while (my $pkg = $rs->next) { - my $n = 'src:'.$pkg->{src_pkg}; - if (not exists $pkgs->{$n}) { - $pkgs->{$n} = - _default_pkg_info($pkg->{src_pkg}); - } - push @{$pkgs->{$n}{valid_version_info}}, - {%$pkg}; - $n = $pkg->{bin_pkg}; - if (not exists $pkgs->{$n}) { - $pkgs->{$n} = - _default_pkg_info($pkg->{bin_pkg},'binary'); - } - push @{$pkgs->{$n}{valid_version_info}}, - {%$pkg}; - # this is a package with a valid src_ver - $svp->{$pkg->{src_pkg}}{$pkg->{src_ver}}++; - $sp->{$pkg->{src_pkg}}++; - # this is a package with a valid bin_ver - $bvp->{$pkg->{bin_pkg}}{$pkg->{bin_ver}}++; - $bp->{$pkg->{bin_pkg}}++; - } - } - if (@src_packages) { - my $src_rs = $s->resultset('SrcVer')-> - search({-or => [-and => {'src_pkg.pkg' => [@src_packages], - -or => {'suite.codename' => $common_dists, - 'suite.suite_name' => $common_dists, - }, - }, - @src_ver_search, - ], - }, - {join => ['src_pkg', - { - 'src_associations' => 'suite'}, - { - 'bin_vers' => ['bin_pkg','arch']}, - 'maintainer', - ], - 'select' => [qw(src_pkg.pkg), - qw(suite.codename), - qw(suite.suite_name), - qw(src_associations.modified), - qw(me.ver), - q(CONCAT(src_pkg.pkg,'/',me.ver)), - qw(bin_vers.ver bin_pkg.pkg arch.arch), - qw(maintainer.name), - ], - 'as' => [qw(src_pkg codename suite_name), - qw(modified_time src_ver src_pkg_ver), - qw(bin_ver bin_pkg arch maintainer), - ], - result_class => 'DBIx::Class::ResultClass::HashRefInflator', - }, - ); - add_result_to_package($packages,$src_rs, - \%src_ver_packages, - \%bin_ver_packages, - \%src_packages, - \%bin_packages, - ); - } - if (@bin_packages) { - my $bin_assoc_rs = - $s->resultset('BinAssociation')-> - search({-and => {'bin_pkg.pkg' => [@bin_packages], - -or => {'suite.codename' => $common_dists, - 'suite.suite_name' => $common_dists, - }, - }}, - {join => [{'bin' => - [{'src_ver' => ['src_pkg', - 'maintainer', - ]}, - 'bin_pkg', - 'arch']}, - 'suite', - ], - 'select' => [qw(src_pkg.pkg), - qw(suite.codename), - qw(suite.suite_name), - qw(me.modified), - qw(src_ver.ver), - q(CONCAT(src_pkg.pkg,'/',src_ver.ver)), - qw(bin.ver bin_pkg.pkg arch.arch), - qw(maintainer.name), - ], - 'as' => [qw(src_pkg codename suite_name), - qw(modified_time src_ver src_pkg_ver), - qw(bin_ver bin_pkg arch maintainer), - ], - result_class => 'DBIx::Class::ResultClass::HashRefInflator', - }, - ); - add_result_to_package($packages,$bin_assoc_rs, - \%src_ver_packages, - \%bin_ver_packages, - \%src_packages, - \%bin_packages, - ); - } - if (@bin_ver_search) { - my $bin_rs = $s->resultset('BinVer')-> - search({-or => [@bin_ver_search, - ], - }, - {join => ['bin_pkg', - { - 'bin_associations' => 'suite'}, - {'src_ver' => ['src_pkg', - 'maintainer', - ]}, - 'arch', - ], - 'select' => [qw(src_pkg.pkg), - qw(suite.codename), - qw(suite.suite_name), - qw(bin_associations.modified), - qw(src_ver.ver), - q(CONCAT(src_pkg.pkg,'/',src_ver.ver)), - qw(me.ver bin_pkg.pkg arch.arch), - qw(maintainer.name), - ], - 'as' => [qw(src_pkg codename suite_name), - qw(modified_time src_ver src_pkg_ver), - qw(bin_ver bin_pkg arch maintainer), - ], - result_class => 'DBIx::Class::ResultClass::HashRefInflator', - }, - ); - add_result_to_package($packages,$bin_rs, - \%src_ver_packages, - \%bin_ver_packages, - \%src_packages, - \%bin_packages, - ); - } - for my $sp (keys %src_ver_packages) { - if (not exists $packages->{'src:'.$sp}) { - $packages->{'src:'.$sp} = - _default_pkg_info($sp,'source',0); - } - for my $sv (keys %{$src_ver_packages{$sp}}) { - next if $src_ver_packages{$sp}{$sv} > 0; - $packages->{'src:'.$sp}{invalid_versions}{$sv} = 1; - } - } - for my $bp (keys %bin_ver_packages) { - if (not exists $packages->{$bp}) { - $packages->{$bp} = - _default_pkg_info($bp,'binary',0); - } - for my $bv (keys %{$bin_ver_packages{$bp}}) { - next if $bin_ver_packages{$bp}{$bv} > 0; - $packages->{$bp}{invalid_versions}{$bv} = 1; - } - } - for my $sp (keys %src_packages) { - next if $src_packages{$sp} > 0; - $packages->{'src:'.$sp} = - _default_pkg_info($sp,'source',0); - } - for my $bp (keys %bin_packages) { - next if $bin_packages{$bp} > 0; - $packages->{$bp} = - _default_pkg_info($bp,'binary',0); - } - return $packages; -} - -has 'source_version_to_info' => - (is => 'bare', isa => 'HashRef', - traits => ['Hash'], - lazy => 1, - builder => '_build_source_version_to_info', - handles => {_get_source_version_to_info => 'get', - }, - ); - -sub _build_source_version_to_info { - my $self = shift; - my $info = {}; - my $i = 0; - for my $v ($self->_valid_version_info) { - push @{$info->{$v->{src_ver}}}, $i; - $i++; - } - return $info; -} - -has 'binary_version_to_info' => - (is => 'bare', isa => 'HashRef', - traits => ['Hash'], - lazy => 1, - builder => '_build_binary_version_to_info', - handles => {_get_binary_version_to_info => 'get', - }, - ); - -sub _build_binary_version_to_info { - my $self = shift; - my $info = {}; - my $i = 0; - for my $v ($self->_valid_version_info) { - push @{$info->{$v->{bin_ver}}}, $i; - $i++; - } - return $info; -} - -has 'dist_to_info' => - (is => 'bare', isa => 'HashRef', - traits => ['Hash'], - lazy => 1, - builder => '_build_dist_to_info', - handles => {_get_dist_to_info => 'get', - }, - ); -sub _build_dist_to_info { - my $self = shift; - my $info = {}; - my $i = 0; - for my $v ($self->_valid_version_info) { - next unless defined $v->{suite_name} and length($v->{suite_name}); - push @{$info->{$v->{suite_name}}}, $i; - $i++; - } - return $info; -} - -# this is a hashref of versions that we know are invalid -has 'invalid_versions' => - (is => 'bare',isa => 'HashRef[Bool]', - lazy => 1, - default => sub {{}}, - clearer => '_clear_invalid_versions', - traits => ['Hash'], - handles => {_invalid_version => 'exists', - _mark_invalid_version => 'set', - }, - ); - -has 'binaries' => (is => 'ro', - isa => 'Debbugs::Collection::Package', - lazy => 1, - builder => '_build_binaries', - predicate => '_has_binaries', - ); - -sub _build_binaries { - my $self = shift; - if ($self->is_binary) { - return $self->package_collection->limit($self->name); - } - # OK, walk through the valid_versions for this package - my @binaries = - uniq map {$_->{bin_pkg}} $self->_valid_version_info; - return $self->package_collection->limit(@binaries); -} - -has 'sources' => (is => 'ro', - isa => 'Debbugs::Collection::Package', - lazy => 1, - builder => '_build_sources', - predicate => '_has_sources', - ); - -sub _build_sources { - my $self = shift; - return $self->package_collection->limit($self->source_names); -} - -sub source_names { - my $self = shift; - - if ($self->is_source) { - return $self->name - } - return uniq map {'src:'.$_->{src_pkg}} $self->_valid_version_info; -} - -=head2 maintainers - -L of the maintainer(s) of the current package - -=cut - -has maintainers => (is => 'ro', - isa => 'Debbugs::Collection::Correspondent', - lazy => 1, - builder => '_build_maintainers', - predicate => '_has_maintainers', - ); - -sub _build_maintainers { - my $self = shift; - my @maintainers; - for my $v ($self->_valid_version_info) { - next unless length($v->{suite_name}) and length($v->{maintainer}); - push @maintainers,$v->{maintainer}; - } - @maintainers = - uniq @maintainers; - return $self->correspondent_collection->limit(@maintainers); -} - -has 'versions' => (is => 'bare', - isa => 'HashRef[Debbugs::Version]', - traits => ['Hash'], - handles => {_exists_version => 'exists', - _get_version => 'get', - _set_version => 'set', - }, - lazy => 1, - builder => '_build_versions', - ); - -sub _build_versions { - my $self = shift; - return {}; -} - -sub _add_version { - my $self = shift; - my @set; - for my $v (@_) { - push @set, - $v->version,$v; - } - $self->_set_version(@set); -} - -sub get_source_version_distribution { - my $self = shift; - - my %src_pkg_vers = @_; - for my $dist (@_) { - my @ver_loc = - grep {defined $_} - $self->_get_dist_to_info($dist); - for my $v ($self-> - _get_valid_version_info(@ver_loc)) { - $src_pkg_vers{$v->{src_pkg_ver}} = 1; - } - } - return $self->package_collection-> - get_source_versions(keys %src_pkg_vers)->members; -} - -# returns the source version(s) corresponding to the version of *this* package; the -# version passed may be binary or source, depending. -sub get_source_version { - my $self = shift; - if ($self->is_source) { - return $self->get_version(@_); - } - my %src_pkg_vers; - for my $ver (@_) { - my %archs; - if (ref $ver) { - my @archs; - ($ver,@archs) = @{$ver}; - @archs{@archs} = (1) x @archs; - } - my @ver_loc = - @{$self->_get_binary_version_to_info($ver)//[]}; - next unless @ver_loc; - my @vers = map {$self-> - _get_valid_version_info($_)} - @ver_loc; - for my $v (@vers) { - if (keys %archs) { - next unless exists $archs{$v->{arch}}; - } - $src_pkg_vers{$v->{src_pkg_ver}} = 1; - } - } - return $self->package_collection-> - get_source_versions(keys %src_pkg_vers)->members; -} - -sub get_version { - my $self = shift; - my @ret; - for my $v (@_) { - if ($self->_exists_version($v)) { - push @ret,$self->_get_version($v); - } else { - push @ret, - $self->_create_version($v); - } - } - return @ret; -} - -sub _create_version { - my $self = shift; - my @versions; - if ($self->is_source) { - for my $v (@_) { - push @versions, - $v, - Debbugs::Version::Source-> - new(pkg => $self, - version => $v, - package_collection => $self->package_collection, - $self->schema_argument, - ); - } - } else { - for my $v (@_) { - push @versions, - $v, - Debbugs::Version::Binary-> - new(pkg => $self, - version => $v, - package_collection => $self->package_collection, - $self->schema_argument, - ); - } - } - $self->_set_version(@versions); -} - -=head2 package_collection - -L to get additional packages required - -=cut - -# gets used to retrieve packages -has 'package_collection' => (is => 'ro', - isa => 'Debbugs::Collection::Package', - builder => '_build_package_collection', - lazy => 1, - ); - -sub _build_package_collection { - my $self = shift; - return Debbugs::Collection::Package->new($self->schema_argument) -} - -=head2 correspondent_collection - -L to get additional maintainers required - -=cut - -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) -} - -sub CARP_TRACE { - my $self = shift; - return 'Debbugs::Package={package='.$self->qualified_name.'}'; -} - -__PACKAGE__->meta->make_immutable; -no Mouse; - -1; - - -__END__ -# Local Variables: -# indent-tabs-mode: nil -# cperl-indent-level: 4 -# End: diff --git a/Debbugs/Packages.pm b/Debbugs/Packages.pm deleted file mode 100644 index b30cfc7..0000000 --- a/Debbugs/Packages.pm +++ /dev/null @@ -1,1096 +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. -# -# [Other people have contributed to this file; their copyrights should -# go here too.] -# Copyright 2007 by Don Armstrong . - -package Debbugs::Packages; - -use warnings; -use strict; - -use Exporter qw(import); -use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT); - -use Carp; - -use Debbugs::Config qw(:config :globals); - -BEGIN { - $VERSION = 1.00; - - @EXPORT = (); - %EXPORT_TAGS = (versions => [qw(getversions get_versions make_source_versions)], - mapping => [qw(getpkgsrc getpkgcomponent getsrcpkgs), - qw(binary_to_source sourcetobinary makesourceversions), - qw(source_to_binary), - ], - ); - @EXPORT_OK = (); - Exporter::export_ok_tags(qw(versions mapping)); - $EXPORT_TAGS{all} = [@EXPORT_OK]; -} - -use Fcntl qw(O_RDONLY); -use MLDBM qw(DB_File Storable); -use Storable qw(dclone); -use Params::Validate qw(validate_with :types); -use Debbugs::Common qw(make_list globify_scalar sort_versions); -use DateTime::Format::Pg; -use List::AllUtils qw(min max uniq); - -use IO::File; - -$MLDBM::DumpMeth = 'portable'; -$MLDBM::RemoveTaint = 1; - -=head1 NAME - -Debbugs::Packages - debbugs binary/source package handling - -=head1 DESCRIPTION - -The Debbugs::Packages module provides support functions to map binary -packages to their corresponding source packages and vice versa. (This makes -sense for software distributions, where developers may work on a single -source package which produces several binary packages for use by users; it -may not make sense in other contexts.) - -=head1 METHODS - -=head2 getpkgsrc - -Returns a reference to a hash of binary package names to their corresponding -source package names. - -=cut - -our $_pkgsrc; -our $_pkgcomponent; -our $_srcpkg; -sub getpkgsrc { - return $_pkgsrc if $_pkgsrc; - return {} unless defined $config{package_source} and - length $config{package_source}; - my %pkgsrc; - my %pkgcomponent; - my %srcpkg; - - my $fh = IO::File->new($config{package_source},'r') - or croak("Unable to open $config{package_source} for reading: $!"); - while(<$fh>) { - next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/; - my ($bin,$cmp,$src)=($1,$2,$3); - $bin = lc($bin); - $pkgsrc{$bin}= $src; - push @{$srcpkg{$src}}, $bin; - $pkgcomponent{$bin}= $cmp; - } - close($fh); - $_pkgsrc = \%pkgsrc; - $_pkgcomponent = \%pkgcomponent; - $_srcpkg = \%srcpkg; - return $_pkgsrc; -} - -=head2 getpkgcomponent - -Returns a reference to a hash of binary package names to the component of -the archive containing those binary packages (e.g. "main", "contrib", -"non-free"). - -=cut - -sub getpkgcomponent { - return $_pkgcomponent if $_pkgcomponent; - getpkgsrc(); - return $_pkgcomponent; -} - -=head2 getsrcpkgs - -Returns a list of the binary packages produced by a given source package. - -=cut - -sub getsrcpkgs { - my $src = shift; - getpkgsrc() if not defined $_srcpkg; - return () if not defined $src or not exists $_srcpkg->{$src}; - return @{$_srcpkg->{$src}}; -} - -=head2 binary_to_source - - binary_to_source(package => 'foo', - version => '1.2.3', - arch => 'i386'); - - -Turn a binary package (at optional version in optional architecture) -into a single (or set) of source packages (optionally) with associated -versions. - -By default, in LIST context, returns a LIST of array refs of source -package, source version pairs corresponding to the binary package(s), -arch(s), and verion(s) passed. - -In SCALAR context, only the corresponding source packages are -returned, concatenated with ', ' if necessary. - -If no source can be found, returns undef in scalar context, or the -empty list in list context. - -=over - -=item binary -- binary package name(s) as a SCALAR or ARRAYREF - -=item version -- binary package version(s) as a SCALAR or ARRAYREF; -optional, defaults to all versions. - -=item arch -- binary package architecture(s) as a SCALAR or ARRAYREF; -optional, defaults to all architectures. - -=item source_only -- return only the source name (forced on if in -SCALAR context), defaults to false. - -=item scalar_only -- return a scalar only (forced true if in SCALAR -context, also causes source_only to be true), defaults to false. - -=item cache -- optional HASHREF to be used to cache results of -binary_to_source. - -=back - -=cut - -# the two global variables below are used to tie the source maps; we -# probably should be retying them in long lived processes. -our %_binarytosource; -sub _tie_binarytosource { - if (not tied %_binarytosource) { - tie %_binarytosource, MLDBM => $config{binary_source_map}, O_RDONLY or - die "Unable to open $config{binary_source_map} for reading"; - } -} -our %_sourcetobinary; -sub _tie_sourcetobinary { - if (not tied %_sourcetobinary) { - tie %_sourcetobinary, MLDBM => $config{source_binary_map}, O_RDONLY or - die "Unable to open $config{source_binary_map} for reading"; - } -} -sub binary_to_source{ - my %param = validate_with(params => \@_, - spec => {binary => {type => SCALAR|ARRAYREF, - }, - version => {type => SCALAR|ARRAYREF, - optional => 1, - }, - arch => {type => SCALAR|ARRAYREF, - optional => 1, - }, - source_only => {default => 0, - }, - scalar_only => {default => 0, - }, - cache => {type => HASHREF, - default => {}, - }, - schema => {type => OBJECT, - optional => 1, - }, - }, - ); - - # TODO: This gets hit a lot, especially from buggyversion() - probably - # need an extra cache for speed here. - return () unless defined $gBinarySourceMap or defined $param{schema}; - - if ($param{scalar_only} or not wantarray) { - $param{source_only} = 1; - $param{scalar_only} = 1; - } - - my @source; - my @binaries = grep {defined $_} make_list(exists $param{binary}?$param{binary}:[]); - my @versions = grep {defined $_} make_list(exists $param{version}?$param{version}:[]); - my @archs = grep {defined $_} make_list(exists $param{arch}?$param{arch}:[]); - return () unless @binaries; - - my $cache_key = join("\1", - join("\0",@binaries), - join("\0",@versions), - join("\0",@archs), - join("\0",@param{qw(source_only scalar_only)})); - if (exists $param{cache}{$cache_key}) { - return $param{scalar_only} ? $param{cache}{$cache_key}[0]: - @{$param{cache}{$cache_key}}; - } - # any src:foo is source package foo with unspecified version - @source = map {/^src:(.+)$/? - [$1,'']:()} @binaries; - @binaries = grep {$_ !~ /^src:/} @binaries; - if ($param{schema}) { - if ($param{source_only}) { - @source = map {$_->[0]} @source; - my $src_rs = $param{schema}->resultset('SrcPkg')-> - search_rs({'bin_pkg.pkg' => [@binaries], - @versions?('bin_vers.ver' => [@versions]):(), - @archs?('arch.arch' => [@archs]):(), - }, - {join => {'src_vers'=> - {'bin_vers'=> ['arch','bin_pkg']} - }, - columns => [qw(pkg)], - order_by => [qw(pkg)], - result_class => 'DBIx::Class::ResultClass::HashRefInflator', - distinct => 1, - }, - ); - push @source, - map {$_->{pkg}} $src_rs->all; - if ($param{scalar_only}) { - @source = join(',',@source); - } - $param{cache}{$cache_key} = \@source; - return $param{scalar_only}?$source[0]:@source; - } - my $src_rs = $param{schema}->resultset('SrcVer')-> - search_rs({'bin_pkg.pkg' => [@binaries], - @versions?('bin_vers.ver' => [@versions]):(), - @archs?('arch.arch' => [@archs]):(), - }, - {join => ['src_pkg', - {'bin_vers' => ['arch','binpkg']}, - ], - columns => ['src_pkg.pkg','src_ver.ver'], - result_class => 'DBIx::Class::ResultClass::HashRefInflator', - order_by => ['src_pkg.pkg','src_ver.ver'], - distinct => 1, - }, - ); - push @source, - map {[$_->{src_pkg}{pkg}, - $_->{src_ver}{ver}, - ]} $src_rs->all; - if (not @source and not @versions and not @archs) { - $src_rs = $param{schema}->resultset('SrcPkg')-> - search_rs({pkg => [@binaries]}, - {join => ['src_vers'], - columns => ['src_pkg.pkg','src_vers.ver'], - distinct => 1, - }, - ); - push @source, - map {[$_->{src_pkg}{pkg}, - $_->{src_vers}{ver}, - ]} $src_rs->all; - } - $param{cache}{$cache_key} = \@source; - return $param{scalar_only}?$source[0]:@source; - } - for my $binary (@binaries) { - _tie_binarytosource; - # avoid autovivification - my $bin = $_binarytosource{$binary}; - next unless defined $bin; - if (not @versions) { - for my $ver (keys %{$bin}) { - for my $ar (keys %{$bin->{$ver}}) { - my $src = $bin->{$ver}{$ar}; - next unless defined $src; - push @source,[$src->[0],$src->[1]]; - } - } - } - else { - for my $version (@versions) { - next unless exists $bin->{$version}; - if (exists $bin->{$version}{all}) { - push @source,dclone($bin->{$version}{all}); - next; - } - my @t_archs; - if (@archs) { - @t_archs = @archs; - } - else { - @t_archs = keys %{$bin->{$version}}; - } - for my $arch (@t_archs) { - push @source,dclone($bin->{$version}{$arch}) if - exists $bin->{$version}{$arch}; - } - } - } - } - - if (not @source and not @versions and not @archs) { - # ok, we haven't found any results at all. If we weren't given - # a specific version and architecture, then we should try - # really hard to figure out the right source - - # if any the packages we've been given are a valid source - # package name, and there's no binary of the same name (we got - # here, so there isn't), return it. - _tie_sourcetobinary(); - for my $maybe_sourcepkg (@binaries) { - if (exists $_sourcetobinary{$maybe_sourcepkg}) { - push @source,[$maybe_sourcepkg,$_] for keys %{$_sourcetobinary{$maybe_sourcepkg}}; - } - } - # if @source is still empty here, it's probably a non-existant - # source package, so don't return anything. - } - - my @result; - - if ($param{source_only}) { - my %uniq; - for my $s (@source) { - # we shouldn't need to do this, but do this temporarily to - # stop the warning. - next unless defined $s->[0]; - $uniq{$s->[0]} = 1; - } - @result = sort keys %uniq; - if ($param{scalar_only}) { - @result = join(', ',@result); - } - } - else { - my %uniq; - for my $s (@source) { - $uniq{$s->[0]}{$s->[1]} = 1; - } - for my $sn (sort keys %uniq) { - push @result, [$sn, $_] for sort keys %{$uniq{$sn}}; - } - } - - # No $gBinarySourceMap, or it didn't have an entry for this name and - # version. - $param{cache}{$cache_key} = \@result; - return $param{scalar_only} ? $result[0] : @result; -} - -=head2 source_to_binary - - source_to_binary(package => 'foo', - version => '1.2.3', - arch => 'i386'); - - -Turn a source package (at optional version) into a single (or set) of all binary -packages (optionally) with associated versions. - -By default, in LIST context, returns a LIST of array refs of binary package, -binary version, architecture triples corresponding to the source package(s) and -verion(s) passed. - -In SCALAR context, only the corresponding binary packages are returned, -concatenated with ', ' if necessary. - -If no binaries can be found, returns undef in scalar context, or the -empty list in list context. - -=over - -=item source -- source package name(s) as a SCALAR or ARRAYREF - -=item version -- binary package version(s) as a SCALAR or ARRAYREF; -optional, defaults to all versions. - -=item dist -- list of distributions to return corresponding binary packages for -as a SCALAR or ARRAYREF. - -=item binary_only -- return only the source name (forced on if in SCALAR -context), defaults to false. [If in LIST context, returns a list of binary -names.] - -=item scalar_only -- return a scalar only (forced true if in SCALAR -context, also causes binary_only to be true), defaults to false. - -=item cache -- optional HASHREF to be used to cache results of -binary_to_source. - -=back - -=cut - -# the two global variables below are used to tie the source maps; we -# probably should be retying them in long lived processes. -sub source_to_binary{ - my %param = validate_with(params => \@_, - spec => {source => {type => SCALAR|ARRAYREF, - }, - version => {type => SCALAR|ARRAYREF, - optional => 1, - }, - dist => {type => SCALAR|ARRAYREF, - optional => 1, - }, - binary_only => {default => 0, - }, - scalar_only => {default => 0, - }, - cache => {type => HASHREF, - default => {}, - }, - schema => {type => OBJECT, - optional => 1, - }, - }, - ); - if (not defined $config{source_binary_map} and - not defined $param{schema} - ) { - return (); - } - - if ($param{scalar_only} or not wantarray) { - $param{binary_only} = 1; - $param{scalar_only} = 1; - } - - my @binaries; - my @sources = sort grep {defined $_} - make_list(exists $param{source}?$param{source}:[]); - my @versions = sort grep {defined $_} - make_list(exists $param{version}?$param{version}:[]); - return () unless @sources; - - # any src:foo is source package foo with unspecified version - @sources = map {s/^src://; $_} @sources; - if ($param{schema}) { - if ($param{binary_only}) { - my $bin_rs = $param{schema}->resultset('BinPkg')-> - search_rs({'src_pkg.pkg' => [@sources], - @versions?('src_ver.ver' => [@versions]):(), - }, - {join => {'bin_vers'=> - {'src_ver'=> 'src_pkg'} - }, - columns => [qw(pkg)], - order_by => [qw(pkg)], - result_class => 'DBIx::Class::ResultClass::HashRefInflator', - distinct => 1, - }, - ); - if (exists $param{dist}) { - $bin_rs = $bin_rs-> - search({-or => - {'suite.codename' => [make_list($param{dist})], - 'suite.suite_name' => [make_list($param{dist})], - }}, - {join => {'bin_vers' => - {'bin_associations' => - 'suite' - }}, - }); - } - push @binaries, - map {$_->{pkg}} $bin_rs->all; - if ($param{scalar_only}) { - return join(', ',@binaries); - } - return @binaries; - - } - my $src_rs = $param{schema}->resultset('BinVer')-> - search_rs({'src_pkg.pkg' => [@sources], - @versions?('src_ver.ver' => [@versions]):(), - }, - {join => ['bin_pkg', - 'arch', - {'src_ver' => ['src_pkg']}, - ], - columns => ['src_pkg.pkg','src_ver.ver','arch.arch'], - order_by => ['src_pkg.pkg','src_ver.ver','arch.arch'], - result_class => 'DBIx::Class::ResultClass::HashRefInflator', - distinct => 1, - }, - ); - push @binaries, - map {[$_->{src_pkg}{pkg}, - $_->{src_ver}{ver}, - $_->{arch}{arch}, - ]} - $src_rs->all; - if (not @binaries and not @versions) { - $src_rs = $param{schema}->resultset('BinPkg')-> - search_rs({pkg => [@sources]}, - {join => {'bin_vers' => - ['arch', - {'src_ver'=>'src_pkg'}], - }, - distinct => 1, - result_class => 'DBIx::Class::ResultClass::HashRefInflator', - columns => ['src_pkg.pkg','src_ver.ver','arch.arch'], - order_by => ['src_pkg.pkg','src_ver.ver','arch.arch'], - }, - ); - push @binaries, - map {[$_->{src_pkg}{pkg}, - $_->{src_ver}{ver}, - $_->{arch}{arch}, - ]} $src_rs->all; - } - return @binaries; - } - my $cache_key = join("\1", - join("\0",@sources), - join("\0",@versions), - join("\0",@param{qw(binary_only scalar_only)})); - if (exists $param{cache}{$cache_key}) { - return $param{scalar_only} ? $param{cache}{$cache_key}[0]: - @{$param{cache}{$cache_key}}; - } - my @return; - my %binaries; - if ($param{binary_only}) { - for my $source (@sources) { - _tie_sourcetobinary; - # avoid autovivification - my $src = $_sourcetobinary{$source}; - if (not defined $src) { - next if @versions; - _tie_binarytosource; - if (exists $_binarytosource{$source}) { - $binaries{$source} = 1; - } - next; - } - my @src_vers = @versions; - if (not @versions) { - @src_vers = keys %{$src}; - } - for my $ver (@src_vers) { - $binaries{$_->[0]} = 1 - foreach @{$src->{$ver}//[]}; - } - } - # return if we have any results. - @return = sort keys %binaries; - if ($param{scalar_only}) { - @return = join(', ',@return); - } - goto RETURN_RESULT; - } - for my $source (@sources) { - _tie_sourcetobinary; - my $src = $_sourcetobinary{$source}; - # there isn't a source package, so return this as a binary packages if a - # version hasn't been specified - if (not defined $src) { - next if @versions; - _tie_binarytosource; - if (exists $_binarytosource{$source}) { - my $bin = $_binarytosource{$source}; - for my $ver (keys %{$bin}) { - for my $arch (keys %{$bin->{$ver}}) { - $binaries{$bin}{$ver}{$arch} = 1; - } - } - } - next; - } - for my $bin_ver_archs (values %{$src}) { - for my $bva (@{$bin_ver_archs}) { - $binaries{$bva->[0]}{$bva->[1]}{$bva->[2]} = 1; - } - } - } - for my $bin (sort keys %binaries) { - for my $ver (sort keys %{$binaries{$bin}}) { - for my $arch (sort keys %{$binaries{$bin}{$ver}}) { - push @return, - [$bin,$ver,$arch]; - } - } - } -RETURN_RESULT: - $param{cache}{$cache_key} = \@return; - return $param{scalar_only} ? $return[0] : @return; -} - - -=head2 sourcetobinary - -Returns a list of references to triplets of binary package names, versions, -and architectures corresponding to a given source package name and version. -If the given source package name and version cannot be found in the database -but the source package name is in the unversioned package-to-source map -file, then a reference to a binary package name and version pair will be -returned, without the architecture. - -=cut - -sub sourcetobinary { - my ($srcname, $srcver) = @_; - _tie_sourcetobinary; - # avoid autovivification - my $source = $_sourcetobinary{$srcname}; - return () unless defined $source; - if (exists $source->{$srcver}) { - my $bin = $source->{$srcver}; - return () unless defined $bin; - return @$bin; - } - # No $gSourceBinaryMap, or it didn't have an entry for this name and - # version. Try $gPackageSource (unversioned) instead. - my @srcpkgs = getsrcpkgs($srcname); - return map [$_, $srcver], @srcpkgs; -} - -=head2 getversions - -Returns versions of the package in a distribution at a specific -architecture - -=cut - -sub getversions { - my ($pkg, $dist, $arch) = @_; - return get_versions(package=>$pkg, - dist => $dist, - defined $arch ? (arch => $arch):(), - ); -} - - - -=head2 get_versions - - get_versions(package=>'foopkg', - dist => 'unstable', - arch => 'i386', - ); - -Returns a list of the versions of package in the distributions and -architectures listed. This routine only returns unique values. - -=over - -=item package -- package to return list of versions - -=item dist -- distribution (unstable, stable, testing); can be an -arrayref - -=item arch -- architecture (i386, source, ...); can be an arrayref - -=item time -- returns a version=>time hash at which the newest package -matching this version was uploaded - -=item source -- returns source/version instead of just versions - -=item no_source_arch -- discards the source architecture when arch is -not passed. [Used for finding the versions of binary packages only.] -Defaults to 0, which does not discard the source architecture. (This -may change in the future, so if you care, please code accordingly.) - -=item return_archs -- returns a version=>[archs] hash indicating which -architectures are at which versions. - -=item largest_source_version_only -- if there is more than one source -version in a particular distribution, discards all versions but the -largest in that distribution. Defaults to 1, as this used to be the -way that the Debian archive worked. - -=back - -When called in scalar context, this function will return hashrefs or -arrayrefs as appropriate, in list context, it will return paired lists -or unpaired lists as appropriate. - -=cut - -our %_versions; -our %_versions_time; - -sub get_versions{ - my %param = validate_with(params => \@_, - spec => {package => {type => SCALAR|ARRAYREF, - }, - dist => {type => SCALAR|ARRAYREF, - default => 'unstable', - }, - arch => {type => SCALAR|ARRAYREF, - optional => 1, - }, - time => {type => BOOLEAN, - default => 0, - }, - source => {type => BOOLEAN, - default => 0, - }, - no_source_arch => {type => BOOLEAN, - default => 0, - }, - return_archs => {type => BOOLEAN, - default => 0, - }, - largest_source_version_only => {type => BOOLEAN, - default => 1, - }, - schema => {type => OBJECT, - optional => 1, - }, - }, - ); - if (defined $param{schema}) { - my @src_packages; - my @bin_packages; - for my $pkg (make_list($param{package})) { - if ($pkg =~ /^src:(.+)/) { - push @src_packages, - $1; - } else { - push @bin_packages,$pkg; - } - } - - my $s = $param{schema}; - my %return; - if (@src_packages) { - my $src_rs = $s->resultset('SrcVer')-> - search({'src_pkg.pkg'=>[@src_packages], - -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'}, - }, - ); - my %completed_dists; - for my $src ($src_rs->all()) { - my $val = 'source'; - if ($param{time}) { - $val = DateTime::Format::Pg-> - parse_datetime($src->{modified_time})-> - epoch(); - } - if ($param{largest_source_version_only}) { - next if $completed_dists{$src->{codename}}; - $completed_dists{$src->{codename}} = 1; - } - if ($param{source}) { - $return{$src->{src_pkg_ver}} = $val; - } else { - $return{$src->{ver}} = $val; - } - } - } - if (@bin_packages) { - my $bin_rs = $s->resultset('BinVer')-> - search({'bin_pkg.pkg' => [@bin_packages], - -or => {'suite.codename' => [make_list($param{dist})], - 'suite.suite_name' => [make_list($param{dist})], - }, - }, - {join => ['bin_pkg', - { - 'src_ver'=>'src_pkg'}, - { - bin_associations => 'suite'}, - 'arch', - ], - '+select' => [qw(bin_pkg.pkg arch.arch suite.codename), - qw(bin_associations.modified), - qw(src_pkg.pkg),q(CONCAT(src_pkg.pkg,'/',me.ver)), - ], - '+as' => ['bin_pkg','arch','codename', - 'modified_time', - 'src_pkg_name','src_pkg_ver'], - result_class => 'DBIx::Class::ResultClass::HashRefInflator', - order_by => {-desc => 'src_ver.ver'}, - }); - if (exists $param{arch}) { - $bin_rs = - $bin_rs->search({'arch.arch' => [make_list($param{arch})]}, - { - join => 'arch'} - ); - } - my %completed_dists; - for my $bin ($bin_rs->all()) { - my $key = $bin->{ver}; - if ($param{source}) { - $key = $bin->{src_pkg_ver}; - } - my $val = $bin->{arch}; - if ($param{time}) { - $val = DateTime::Format::Pg-> - parse_datetime($bin->{modified_time})-> - epoch(); - } - if ($param{largest_source_version_only}) { - if ($completed_dists{$bin->{codename}} and not - exists $return{$key}) { - next; - } - $completed_dists{$bin->{codename}} = 1; - } - push @{$return{$key}}, - $val; - } - } - if ($param{return_archs}) { - if ($param{time} or $param{return_archs}) { - return wantarray?%return :\%return; - } - return wantarray?keys %return :[keys %return]; - } - } - my $versions; - if ($param{time}) { - return () if not defined $gVersionTimeIndex; - unless (tied %_versions_time) { - tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY - or die "can't open versions index $gVersionTimeIndex: $!"; - } - $versions = \%_versions_time; - } - else { - return () if not defined $gVersionIndex; - unless (tied %_versions) { - tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY - or die "can't open versions index $gVersionIndex: $!"; - } - $versions = \%_versions; - } - my %versions; - for my $package (make_list($param{package})) { - my $source_only = 0; - if ($package =~ s/^src://) { - $source_only = 1; - } - my $version = $versions->{$package}; - next unless defined $version; - for my $dist (make_list($param{dist})) { - for my $arch (exists $param{arch}? - make_list($param{arch}): - (grep {not $param{no_source_arch} or - $_ ne 'source' - } $source_only?'source':keys %{$version->{$dist}})) { - next unless defined $version->{$dist}{$arch}; - my @vers = ref $version->{$dist}{$arch} eq 'HASH' ? - keys %{$version->{$dist}{$arch}} : - make_list($version->{$dist}{$arch}); - if ($param{largest_source_version_only} and - $arch eq 'source' and @vers > 1) { - # order the versions, then pick the biggest version number - @vers = sort_versions(@vers); - @vers = $vers[-1]; - } - for my $ver (@vers) { - my $f_ver = $ver; - if ($param{source}) { - ($f_ver) = make_source_versions(package => $package, - arch => $arch, - versions => $ver); - next unless defined $f_ver; - } - if ($param{time}) { - $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver}); - } - else { - push @{$versions{$f_ver}},$arch; - } - } - } - } - } - if ($param{time} or $param{return_archs}) { - return wantarray?%versions :\%versions; - } - return wantarray?keys %versions :[keys %versions]; -} - - -=head2 makesourceversions - - @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}}); - -Canonicalize versions into source versions, which have an explicitly -named source package. This is used to cope with source packages whose -names have changed during their history, and with cases where source -version numbers differ from binary version numbers. - -=cut - -our %_sourceversioncache = (); -sub makesourceversions { - my ($package,$arch,@versions) = @_; - die "Package $package is multiple packages; split on , and call makesourceversions multiple times" - if $package =~ /,/; - return make_source_versions(package => $package, - (defined $arch)?(arch => $arch):(), - versions => \@versions - ); -} - -=head2 make_source_versions - - make_source_versions(package => 'foo', - arch => 'source', - versions => '0.1.1', - guess_source => 1, - warnings => \$warnings, - ); - -An extended version of makesourceversions (which calls this function -internally) that allows for multiple packages, architectures, and -outputs warnings and debugging information to provided SCALARREFs or -HANDLEs. - -The guess_source option determines whether the source package is -guessed at if there is no obviously correct package. Things that use -this function for non-transient output should set this to false, -things that use it for transient output can set this to true. -Currently it defaults to true, but that is not a sane option. - - -=cut - -sub make_source_versions { - my %param = validate_with(params => \@_, - spec => {package => {type => SCALAR|ARRAYREF, - }, - arch => {type => SCALAR|ARRAYREF|UNDEF, - default => '' - }, - versions => {type => SCALAR|ARRAYREF, - default => [], - }, - guess_source => {type => BOOLEAN, - default => 1, - }, - source_version_cache => {type => HASHREF, - optional => 1, - }, - debug => {type => SCALARREF|HANDLE, - optional => 1, - }, - warnings => {type => SCALARREF|HANDLE, - optional => 1, - }, - schema => {type => OBJECT, - optional => 1, - }, - }, - ); - my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef); - - my @packages = grep {defined $_ and length $_ } make_list($param{package}); - my @archs = grep {defined $_ } make_list ($param{arch}); - if (not @archs) { - push @archs, ''; - } - if (not exists $param{source_version_cache}) { - $param{source_version_cache} = \%_sourceversioncache; - } - if (grep {/,/} make_list($param{package})) { - croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages" - } - my %sourceversions; - for my $version (make_list($param{versions})) { - if ($version =~ m{(.+)/([^/]+)$}) { - # Already a source version. - $sourceversions{$version} = 1; - next unless exists $param{warnings}; - # check to see if this source version is even possible - my @bin_versions = sourcetobinary($1,$2); - if (not @bin_versions or - @{$bin_versions[0]} != 3) { - print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n"; - } - } else { - if (not @packages) { - croak "You must provide at least one package if the versions are not fully qualified"; - } - for my $pkg (@packages) { - if ($pkg =~ /^src:(.+)/) { - $sourceversions{"$1/$version"} = 1; - next unless exists $param{warnings}; - # check to see if this source version is even possible - my @bin_versions = sourcetobinary($1,$version); - if (not @bin_versions or - @{$bin_versions[0]} != 3) { - print {$warnings} "The source '$1' and version '$version' do not appear to match any binary packages\n"; - } - next; - } - for my $arch (@archs) { - my $cachearch = (defined $arch) ? $arch : ''; - my $cachekey = "$pkg/$cachearch/$version"; - if (exists($param{source_version_cache}{$cachekey})) { - for my $v (@{$param{source_version_cache}{$cachekey}}) { - $sourceversions{$v} = 1; - } - next; - } - elsif ($param{guess_source} and - exists$param{source_version_cache}{$cachekey.'/guess'}) { - for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) { - $sourceversions{$v} = 1; - } - next; - } - my @srcinfo = binary_to_source(binary => $pkg, - version => $version, - length($arch)?(arch => $arch):()); - if (not @srcinfo) { - # We don't have explicit information about the - # binary-to-source mapping for this version - # (yet). - print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n"; - if ($param{guess_source}) { - # Lets guess it - my $pkgsrc = getpkgsrc(); - if (exists $pkgsrc->{$pkg}) { - @srcinfo = ([$pkgsrc->{$pkg}, $version]); - } elsif (getsrcpkgs($pkg)) { - # If we're looking at a source package - # that doesn't have a binary of the - # same name, just try the same - # version. - @srcinfo = ([$pkg, $version]); - } else { - next; - } - # store guesses in a slightly different location - $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ]; - } - } - else { - # only store this if we didn't have to guess it - $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ]; - } - $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo; - } - } - } - } - return sort keys %sourceversions; -} - - - -1; diff --git a/Debbugs/Recipients.pm b/Debbugs/Recipients.pm deleted file mode 100644 index 29b92f7..0000000 --- a/Debbugs/Recipients.pm +++ /dev/null @@ -1,398 +0,0 @@ -# This module is part of debbugs, and is released -# under the terms of the GPL version 2, or any later version. See the -# file README and COPYING for more information. -# Copyright 2008 by Don Armstrong . -# $Id: perl_module_header.pm 1221 2008-05-19 15:00:40Z don $ - -package Debbugs::Recipients; - -=head1 NAME - -Debbugs::Recipients -- Determine recipients of messages from the bts - -=head1 SYNOPSIS - - -=head1 DESCRIPTION - - -=head1 BUGS - -None known. - -=cut - -use warnings; -use strict; -use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); -use Exporter qw(import); - -BEGIN{ - ($VERSION) = q$Revision: 1221 $ =~ /^Revision:\s+([^\s+])/; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - %EXPORT_TAGS = (add => [qw(add_recipients)], - det => [qw(determine_recipients)], - ); - @EXPORT_OK = (); - Exporter::export_ok_tags(keys %EXPORT_TAGS); - $EXPORT_TAGS{all} = [@EXPORT_OK]; - -} - -use Debbugs::Config qw(:config); -use Params::Validate qw(:types validate_with); -use Debbugs::Common qw(:misc :util); -use Debbugs::Status qw(splitpackages isstrongseverity); - -use Debbugs::Packages qw(binary_to_source); - -use Debbugs::Mail qw(get_addresses); - -use Carp; - -=head2 add_recipients - - add_recipients(data => $data, - recipients => \%recipients; - ); - -Given data (from read_bug or similar) (or an arrayref of data), -calculates the addresses which need to receive mail involving this -bug. - -=over - -=item data -- Data from read_bug or similar; can be an arrayref of data - -=item recipients -- hashref of recipient data structure; pass to -subsequent calls of add_recipients or - -=item debug -- optional - - -=back - -=cut - - -sub add_recipients { - # Data structure is: - # maintainer email address &c -> assoc of packages -> assoc of bug#'s - my %param = validate_with(params => \@_, - spec => {data => {type => HASHREF|ARRAYREF, - }, - recipients => {type => HASHREF, - }, - debug => {type => HANDLE|SCALARREF, - optional => 1, - }, - transcript => {type => HANDLE|SCALARREF, - optional => 1, - }, - actions_taken => {type => HASHREF, - default => {}, - }, - unknown_packages => {type => HASHREF, - default => {}, - }, - }, - ); - - $param{transcript} = globify_scalar($param{transcript}); - $param{debug} = globify_scalar($param{debug}); - if (ref ($param{data}) eq 'ARRAY') { - for my $data (@{$param{data}}) { - add_recipients(data => $data, - map {exists $param{$_}?($_,$param{$_}):()} - qw(recipients debug transcript actions_taken unknown_packages) - ); - } - return; - } - my ($addmaint); - my $ref = $param{data}{bug_num}; - for my $p (splitpackages($param{data}{package})) { - $p = lc($p); - if (defined $config{subscription_domain}) { - my @source_packages = binary_to_source(binary => $p, - source_only => 1, - ); - if (@source_packages) { - for my $source (@source_packages) { - _add_address(recipients => $param{recipients}, - address => "$source\@".$config{subscription_domain}, - reason => $source, - type => 'bcc', - ); - } - } - else { - _add_address(recipients => $param{recipients}, - address => "$p\@".$config{subscription_domain}, - reason => $p, - type => 'bcc', - ); - } - } - if (defined $param{data}{severity} and defined $config{strong_list} and - isstrongseverity($param{data}{severity})) { - _add_address(recipients => $param{recipients}, - address => "$config{strong_list}\@".$config{list_domain}, - reason => $param{data}{severity}, - type => 'bcc', - ); - } - my @maints = package_maintainer(binary => $p); - if (@maints) { - print {$param{debug}} "MR|".join(',',@maints)."|$p|$ref|\n"; - _add_address(recipients => $param{recipients}, - address => \@maints, - reason => $p, - bug_num => $param{data}{bug_num}, - type => 'cc', - ); - print {$param{debug}} "maintainer add >$p|".join(',',@maints)."<\n"; - } - else { - print {$param{debug}} "maintainer none >$p<\n"; - if (not exists $param{unknown_packages}{$p}) { - print {$param{transcript}} "Warning: Unknown package '$p'\n"; - $param{unknown_packages}{$p} = 1; - } - print {$param{debug}} "MR|unknown-package|$p|$ref|\n"; - _add_address(recipients => $param{recipients}, - address => $config{unknown_maintainer_email}, - reason => $p, - bug_num => $param{data}{bug_num}, - type => 'cc', - ) - if defined $config{unknown_maintainer_email} and - length $config{unknown_maintainer_email}; - } - } - if (defined $config{bug_subscription_domain} and - length $config{bug_subscription_domain}) { - _add_address(recipients => $param{recipients}, - address => 'bugs='.$param{data}{bug_num}.'@'. - $config{bug_subscription_domain}, - reason => "bug $param{data}{bug_num}", - bug_num => $param{data}{bug_num}, - type => 'bcc', - ); - } - if (defined $config{cc_all_mails_to_addr} and - length $config{cc_all_mails_to_addr} - ) { - _add_address(recipients => $param{recipients}, - address => $config{cc_all_mails_to}, - reason => "cc_all_mails_to", - bug_num => $param{data}{bug_num}, - type => 'bcc', - ); - } - - if (length $param{data}{owner}) { - $addmaint = $param{data}{owner}; - print {$param{debug}} "MO|$addmaint|$param{data}{package}|$ref|\n"; - _add_address(recipients => $param{recipients}, - address => $addmaint, - reason => "owner of $param{data}{bug_num}", - bug_num => $param{data}{bug_num}, - type => 'cc', - ); - print {$param{debug}} "owner add >$param{data}{package}|$addmaint<\n"; - } - if (exists $param{actions_taken}) { - if (exists $param{actions_taken}{done} and - $param{actions_taken}{done} and - length($config{done_list}) and - length($config{list_domain}) - ) { - _add_address(recipients => $param{recipients}, - type => 'cc', - address => $config{done_list}.'@'.$config{list_domain}, - bug_num => $param{data}{bug_num}, - reason => "bug $param{data}{bug_num} done", - ); - } - if (exists $param{actions_taken}{forwarded} and - $param{actions_taken}{forwarded} and - length($config{forward_list}) and - length($config{list_domain}) - ) { - _add_address(recipients => $param{recipients}, - type => 'cc', - address => $config{forward_list}.'@'.$config{list_domain}, - bug_num => $param{data}{bug_num}, - reason => "bug $param{data}{bug_num} forwarded", - ); - } - } -} - -=head2 determine_recipients - - my @recipients = determine_recipients(recipients => \%recipients, - bcc => 1, - ); - my %recipients => determine_recipients(recipients => \%recipients,); - - # or a crazy example: - send_mail_message(message => $message, - recipients => - [make_list( - values %{{determine_recipients( - recipients => \%recipients) - }}) - ], - ); - -Using the recipient hashref, determines the set of recipients. - -If you specify one of C, C, or C, you will receive only a -LIST of recipients which the main should be Bcc'ed, Cc'ed, or To'ed -respectively. By default, a LIST with keys bcc, cc, and to is returned -with ARRAYREF values corresponding to the users to whom a message -should be sent. - -=over - -=item address_only -- whether to only return mail addresses without reasons or realnamesq - -=back - -Passing more than one of bcc, cc or to is a fatal error. - -=cut - -sub determine_recipients { - my %param = validate_with(params => \@_, - spec => {recipients => {type => HASHREF, - }, - bcc => {type => BOOLEAN, - default => 0, - }, - cc => {type => BOOLEAN, - default => 0, - }, - to => {type => BOOLEAN, - default => 0, - }, - address_only => {type => BOOLEAN, - default => 0, - } - }, - ); - - if (1 < scalar grep {$param{$_}} qw(to cc bcc)) { - croak "Passing more than one of to, cc, or bcc is non-sensical"; - } - - my %final_recipients; - # start with the to recipients - for my $addr (keys %{$param{recipients}}) { - my $level = 'bcc'; - my @reasons; - for my $reason (keys %{$param{recipients}{$addr}}) { - my @bugs; - for my $bug (keys %{$param{recipients}{$addr}{$reason}}) { - push @bugs, $bug; - my $t_level = $param{recipients}{$addr}{$reason}{$bug}; - if ($level eq 'to' or - $t_level eq 'to') { - $level = 'to'; - } - elsif ($t_level eq 'cc') { - $level = 'cc'; - } - } - # RFC 2822 comments cannot contain specials and - # unquoted () or \; there's no reason for us to allow - # insane things here, though, so we restrict this even - # more to 20-7E ( -~) - $reason =~ s/\\/\\\\/g; - $reason =~ s/([\)\(])/\\$1/g; - $reason =~ s/[^\x20-\x7E]//g; - push @reasons, $reason . ' for {'.join(',',@bugs).'}'; - } - if ($param{address_only}) { - push @{$final_recipients{$level}}, get_addresses($addr); - } - else { - push @{$final_recipients{$level}}, $addr . ' ('.join(', ',@reasons).')'; - } - } - for (qw(to cc bcc)) { - if ($param{$_}) { - if (exists $final_recipients{$_}) { - return @{$final_recipients{$_}||[]}; - } - return (); - } - } - return %final_recipients; -} - - -=head1 PRIVATE FUNCTIONS - -=head2 _add_address - - _add_address(recipients => $param{recipients}, - address => $addmaint, - reason => $param{data}{package}, - bug_num => $param{data}{bug_num}, - type => 'cc', - ); - - -=cut - - -sub _add_address { - my %param = validate_with(params => \@_, - spec => {recipients => {type => HASHREF, - }, - bug_num => {type => SCALAR, - regex => qr/^\d*$/, - default => '', - }, - reason => {type => SCALAR, - default => '', - }, - address => {type => SCALAR|ARRAYREF, - }, - type => {type => SCALAR, - default => 'cc', - regex => qr/^(?:b?cc|to)$/i, - }, - }, - ); - for my $addr (make_list($param{address})) { - if (lc($param{type}) eq 'bcc' and - exists $param{recipients}{$addr}{$param{reason}}{$param{bug_num}} - ) { - next; - } - elsif (lc($param{type}) eq 'cc' and - exists $param{recipients}{$addr}{$param{reason}}{$param{bug_num}} - and $param{recipients}{$addr}{$param{reason}}{$param{bug_num}} eq 'to' - ) { - next; - } - $param{recipients}{$addr}{$param{reason}}{$param{bug_num}} = lc($param{type}); - } -} - -1; - - -__END__ - - - - - - diff --git a/Debbugs/SOAP.pm b/Debbugs/SOAP.pm deleted file mode 100644 index a0c3cbf..0000000 --- a/Debbugs/SOAP.pm +++ /dev/null @@ -1,406 +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 2007 by Don Armstrong . - -package Debbugs::SOAP; - -=head1 NAME - -Debbugs::SOAP -- - -=head1 SYNOPSIS - - -=head1 DESCRIPTION - - -=head1 BUGS - -None known. - -=cut - -use warnings; -use strict; -use vars qw($DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); -use Debbugs::SOAP::Server; -use Exporter qw(import); -use base qw(SOAP::Server::Parameters); - -BEGIN{ - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - %EXPORT_TAGS = ( - ); - @EXPORT_OK = (); - Exporter::export_ok_tags(); - $EXPORT_TAGS{all} = [@EXPORT_OK]; - -} - -use IO::File; -use Debbugs::Status qw(get_bug_status); -use Debbugs::Common qw(make_list getbuglocation getbugcomponent); -use Debbugs::UTF8; -use Debbugs::Packages; - -use Storable qw(nstore retrieve dclone); -use Scalar::Util qw(looks_like_number); - - -our $CURRENT_VERSION = 2; - -=head2 get_usertag - - my %ut = get_usertag('don@donarmstrong.com','this-bug-sucks','eat-this-bug'); - my %ut = get_usertag('don@donarmstrong.com'); - -Returns a hashref of bugs which have the specified usertags for the -user set. - -In the second case, returns all of the usertags for the user passed. - -=cut - -use Debbugs::User qw(read_usertags); - -sub get_usertag { - my $VERSION = __populate_version(pop); - my ($self,$email, @tags) = @_; - my %ut = (); - read_usertags(\%ut, $email); - my %tags; - @tags{@tags} = (1) x @tags; - if (keys %tags > 0) { - for my $tag (keys %ut) { - delete $ut{$tag} unless exists $tags{$tag}; - } - } - return encode_utf8_structure(\%ut); -} - - -use Debbugs::Status; - -=head2 get_status - - my @statuses = get_status(@bugs); - my @statuses = get_status([bug => 304234, - dist => 'unstable', - ], - [bug => 304233, - dist => 'unstable', - ], - ) - -Returns an arrayref of hashrefs which output the status for specific -sets of bugs. - -In the first case, no options are passed to -L besides the bug number; in the -second the bug, dist, arch, bugusertags, sourceversions, and version -parameters are passed if they are present. - -As a special case for suboptimal SOAP implementations, if only one -argument is passed to get_status and it is an arrayref which either is -empty, has a number as the first element, or contains an arrayref as -the first element, the outer arrayref is dereferenced, and processed -as in the examples above. - -See L for details. - -=cut - -sub get_status { - my $VERSION = __populate_version(pop); - my ($self,@bugs) = @_; - - if (@bugs == 1 and - ref($bugs[0]) and - (@{$bugs[0]} == 0 or - ref($bugs[0][0]) or - looks_like_number($bugs[0][0]) - ) - ) { - @bugs = @{$bugs[0]}; - } - my %status; - my %binary_to_source_cache; - for my $bug (@bugs) { - my $bug_status; - if (ref($bug)) { - my %param = __collapse_params(@{$bug}); - next unless defined $param{bug}; - $bug = $param{bug}; - $bug_status = get_bug_status(map {(exists $param{$_})?($_,$param{$_}):()} - qw(bug dist arch bugusertags sourceversions version indicatesource), - binary_to_source_cache => \%binary_to_source_cache, - ); - } - else { - $bug_status = get_bug_status(bug => $bug, - binary_to_source_cache => \%binary_to_source_cache, - ); - } - if (defined $bug_status and keys %{$bug_status} > 0) { - $status{$bug} = $bug_status; - } - } -# __prepare_response($self); - return encode_utf8_structure(\%status); -} - -=head2 get_bugs - - my @bugs = get_bugs(...); - my @bugs = get_bugs([...]); - -Returns a list of bugs. In the second case, allows the variable -parameters to be specified as an array reference in case your favorite -language's SOAP implementation is craptacular. - -See L for details on what C<...> actually -means. - -=cut - -use Debbugs::Bugs qw(); - -sub get_bugs{ - my $VERSION = __populate_version(pop); - my ($self,@params) = @_; - # Because some soap implementations suck and can't handle - # variable numbers of arguments we allow get_bugs([]); - if (@params == 1 and ref($params[0]) eq 'ARRAY') { - @params = @{$params[0]}; - } - my %params = __collapse_params(@params); - my @bugs; - @bugs = Debbugs::Bugs::get_bugs(%params); - return encode_utf8_structure(\@bugs); -} - -=head2 newest_bugs - - my @bugs = newest_bugs(5); - -Returns a list of the newest bugs. [Note that all bugs are *not* -guaranteed to exist, but they should in the most common cases.] - -=cut - -sub newest_bugs{ - my $VERSION = __populate_version(pop); - my ($self,$num) = @_; - my $newest_bug = Debbugs::Bugs::newest_bug(); - return encode_utf8_structure([($newest_bug - $num + 1) .. $newest_bug]); - -} - -=head2 get_bug_log - - my $bug_log = get_bug_log($bug); - my $bug_log = get_bug_log($bug,$msg_num); - -Retuns a parsed set of the bug log; this is an array of hashes with -the following - - [{html => '', - header => '', - body => '', - attachments => [], - msg_num => 5, - }, - {html => '', - header => '', - body => '', - attachments => [], - }, - ] - - -Currently $msg_num is completely ignored. - -=cut - -use Debbugs::Log qw(); -use Debbugs::MIME qw(parse); - -sub get_bug_log{ - my $VERSION = __populate_version(pop); - my ($self,$bug,$msg_num) = @_; - - my $log = Debbugs::Log->new(bug_num => $bug) or - die "Debbugs::Log was unable to be initialized"; - - my %seen_msg_ids; - my $current_msg=0; - my @messages; - while (my $record = $log->read_record()) { - $current_msg++; - #next if defined $msg_num and ($current_msg ne $msg_num); - next unless $record->{type} eq 'incoming-recv'; - my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im; - next if defined $msg_id and exists $seen_msg_ids{$msg_id}; - $seen_msg_ids{$msg_id} = 1 if defined $msg_id; - next if defined $msg_id and $msg_id =~ /handler\..+\.ack(?:info)?\@/; - my $message = parse($record->{text}); - my ($header,$body) = map {join("\n",make_list($_))} - @{$message}{qw(header body)}; - push @messages,{header => $header, - body => $body, - attachments => [], - msg_num => $current_msg, - }; - } - return encode_utf8_structure(\@messages); -} - -=head2 binary_to_source - - binary_to_source($binary_name,$binary_version,$binary_architecture) - -Returns a reference to the source package name and version pair -corresponding to a given binary package name, version, and -architecture. If undef is passed as the architecture, returns a list -of references to all possible pairs of source package names and -versions for all architectures, with any duplicates removed. - -As of comaptibility version 2, this has changed to use the more -powerful binary_to_source routine, which allows returning source only, -concatenated scalars, and other useful features. - -See the documentation of L for -details. - -=cut - -sub binary_to_source{ - my $VERSION = __populate_version(pop); - my ($self,@params) = @_; - - if ($VERSION <= 1) { - return encode_utf8_structure([Debbugs::Packages::binary_to_source(binary => $params[0], - (@params > 1)?(version => $params[1]):(), - (@params > 2)?(arch => $params[2]):(), - )]); - } - else { - return encode_utf8_structure([Debbugs::Packages::binary_to_source(@params)]); - } -} - -=head2 source_to_binary - - source_to_binary($source_name,$source_version); - -Returns a reference to an array of references to binary package name, -version, and architecture corresponding to a given source package name -and version. In the case that the given name and version cannot be -found, the unversioned package to source map is consulted, and the -architecture is not returned. - -(This function corresponds to L) - -=cut - -sub source_to_binary { - my $VERSION = __populate_version(pop); - my ($self,@params) = @_; - - return encode_utf8_structure([Debbugs::Packages::sourcetobinary(@params)]); -} - -=head2 get_versions - - get_version(package=>'foopkg', - dist => 'unstable', - arch => 'i386', - ); - -Returns a list of the versions of package in the distributions and -architectures listed. This routine only returns unique values. - -=over - -=item package -- package to return list of versions - -=item dist -- distribution (unstable, stable, testing); can be an -arrayref - -=item arch -- architecture (i386, source, ...); can be an arrayref - -=item time -- returns a version=>time hash at which the newest package -matching this version was uploaded - -=item source -- returns source/version instead of just versions - -=item no_source_arch -- discards the source architecture when arch is -not passed. [Used for finding the versions of binary packages only.] -Defaults to 0, which does not discard the source architecture. (This -may change in the future, so if you care, please code accordingly.) - -=item return_archs -- returns a version=>[archs] hash indicating which -architectures are at which versions. - -=back - -This function corresponds to L - -=cut - -sub get_versions{ - my $VERSION = __populate_version(pop); - my ($self,@params) = @_; - - return encode_utf8_structure(scalar Debbugs::Packages::get_versions(@params)); -} - -=head1 VERSION COMPATIBILITY - -The functionality provided by the SOAP interface will change over time. - -To the greatest extent possible, we will attempt to provide backwards -compatibility with previous versions; however, in order to have -backwards compatibility, you need to specify the version with which -you are compatible. - -=cut - -sub __populate_version{ - my ($request) = @_; - return $request->{___debbugs_soap_version}; -} - -sub __collapse_params{ - my @params = @_; - - my %params; - # Because some clients can't handle passing arrayrefs, we allow - # options to be specified multiple times - while (my ($key,$value) = splice @params,0,2) { - push @{$params{$key}}, make_list($value); - } - # However, for singly specified options, we want to pull them - # back out - for my $key (keys %params) { - if (@{$params{$key}} == 1) { - ($params{$key}) = @{$params{$key}} - } - } - return %params; -} - - -1; - - -__END__ - - - - - - diff --git a/Debbugs/SOAP/Server.pm b/Debbugs/SOAP/Server.pm deleted file mode 100644 index c55267b..0000000 --- a/Debbugs/SOAP/Server.pm +++ /dev/null @@ -1,61 +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 2007 by Don Armstrong . - -package Debbugs::SOAP::Server; - -=head1 NAME - -Debbugs::SOAP::Server -- Server Transport module - -=head1 SYNOPSIS - - -=head1 DESCRIPTION - - -=head1 BUGS - -None known. - -=cut - -use warnings; -use strict; -use vars qw(@ISA); -use SOAP::Transport::HTTP; -BEGIN{ - # Eventually we'll probably change this to just be HTTP::Server and - # have the soap.cgi declare a class which inherits from both - push @ISA,qw(SOAP::Transport::HTTP::CGI); -} - -use Debbugs::SOAP; - -sub find_target { - my ($self,$request) = @_; - - # WTF does this do? - $request->match((ref $request)->method); - my $method_uri = $request->namespaceuriof || 'Debbugs/SOAP'; - my $method_name = $request->dataof->name; - $method_uri =~ s{(?:/?Status/?|/?Usertag/?)}{}; - $method_uri =~ s{(Debbugs/SOAP/)[vV](\d+)/?}{$1}; - my ($soap_version) = $2 if defined $2; - $self->dispatched('Debbugs:::SOAP'); - $request->{___debbugs_soap_version} = $soap_version || ''; - return ('Debbugs::SOAP',$method_uri,$method_name); -} - - -1; - - -__END__ - - - - - - diff --git a/Debbugs/Status.pm b/Debbugs/Status.pm deleted file mode 100644 index f539781..0000000 --- a/Debbugs/Status.pm +++ /dev/null @@ -1,1901 +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. -# -# [Other people have contributed to this file; their copyrights should -# go here too.] -# Copyright 2007-9 by Don Armstrong . - -package Debbugs::Status; - -=head1 NAME - -Debbugs::Status -- Routines for dealing with summary and status files - -=head1 SYNOPSIS - -use Debbugs::Status; - - -=head1 DESCRIPTION - -This module is a replacement for the parts of errorlib.pl which write -and read status and summary files. - -It also contains generic routines for returning information about the -status of a particular bug - -=head1 FUNCTIONS - -=cut - -use warnings; -use strict; - -use feature 'state'; - -use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); -use Exporter qw(import); - -use Params::Validate qw(validate_with :types); -use Debbugs::Common qw(:util :lock :quit :misc); -use Debbugs::UTF8; -use Debbugs::Config qw(:config); -use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522); -use Debbugs::Packages qw(makesourceversions make_source_versions getversions get_versions binary_to_source); -use Debbugs::Versions; -use Debbugs::Versions::Dpkg; -use POSIX qw(ceil); -use File::Copy qw(copy); -use Encode qw(decode encode is_utf8); - -use Storable qw(dclone); -use List::AllUtils qw(min max uniq); -use DateTime::Format::Pg; - -use Carp qw(croak); - -BEGIN{ - $VERSION = 1.00; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable), - qw(isstrongseverity bug_presence split_status_fields), - qw(get_bug_statuses), - ], - read => [qw(readbug read_bug lockreadbug lockreadbugmerge), - qw(lock_read_all_merged_bugs), - ], - write => [qw(writebug makestatus unlockwritebug)], - new => [qw(new_bug)], - versions => [qw(addfoundversions addfixedversions), - qw(removefoundversions removefixedversions) - ], - hook => [qw(bughook bughook_archive)], - indexdb => [qw(generate_index_db_line)], - fields => [qw(%fields)], - ); - @EXPORT_OK = (); - Exporter::export_ok_tags(keys %EXPORT_TAGS); - $EXPORT_TAGS{all} = [@EXPORT_OK]; -} - - -=head2 readbug - - readbug($bug_num,$location) - readbug($bug_num) - -Reads a summary file from the archive given a bug number and a bug -location. Valid locations are those understood by L - -=cut - -# these probably shouldn't be imported by most people, but -# Debbugs::Control needs them, so they're now exportable -our %fields = (originator => 'submitter', - date => 'date', - subject => 'subject', - msgid => 'message-id', - 'package' => 'package', - keywords => 'tags', - done => 'done', - forwarded => 'forwarded-to', - mergedwith => 'merged-with', - severity => 'severity', - owner => 'owner', - found_versions => 'found-in', - found_date => 'found-date', - fixed_versions => 'fixed-in', - fixed_date => 'fixed-date', - blocks => 'blocks', - blockedby => 'blocked-by', - unarchived => 'unarchived', - summary => 'summary', - outlook => 'outlook', - affects => 'affects', - ); - - -# Fields which need to be RFC1522-decoded in format versions earlier than 3. -my @rfc1522_fields = qw(originator subject done forwarded owner); - -sub readbug { - return read_bug(bug => $_[0], - (@_ > 1)?(location => $_[1]):() - ); -} - -=head2 read_bug - - read_bug(bug => $bug_num, - location => 'archive', - ); - read_bug(summary => 'path/to/bugnum.summary'); - read_bug($bug_num); - -A more complete function than readbug; it enables you to pass a full -path to the summary file instead of the bug number and/or location. - -=head3 Options - -=over - -=item bug -- the bug number - -=item location -- optional location which is passed to getbugcomponent - -=item summary -- complete path to the .summary file which will be read - -=item lock -- whether to obtain a lock for the bug to prevent -something modifying it while the bug has been read. You B call -C if something not undef is returned from read_bug. - -=item locks -- hashref of already obtained locks; incremented as new -locks are needed, and decremented as locks are released on particular -files. - -=back - -One of C or C must be passed. This function will return -undef on failure, and will die if improper arguments are passed. - -=cut - -sub read_bug{ - if (@_ == 1) { - unshift @_, 'bug'; - } - state $spec = - {bug => {type => SCALAR, - optional => 1, - # something really stupid passes negative bugnumbers - regex => qr/^-?\d+/, - }, - location => {type => SCALAR|UNDEF, - optional => 1, - }, - summary => {type => SCALAR, - optional => 1, - }, - lock => {type => BOOLEAN, - optional => 1, - }, - locks => {type => HASHREF, - optional => 1, - }, - }; - my %param = validate_with(params => \@_, - spec => $spec, - ); - die "One of bug or summary must be passed to read_bug" - if not exists $param{bug} and not exists $param{summary}; - my $status; - my $log; - my $location; - my $report; - if (not defined $param{summary}) { - my $lref; - ($lref,$location) = @param{qw(bug location)}; - if (not defined $location) { - $location = getbuglocation($lref,'summary'); - return undef if not defined $location; - } - $status = getbugcomponent($lref, 'summary', $location); - $log = getbugcomponent($lref, 'log' , $location); - $report = getbugcomponent($lref, 'report' , $location); - return undef unless defined $status; - return undef if not -e $status; - } - else { - $status = $param{summary}; - $log = $status; - $report = $status; - $log =~ s/\.summary$/.log/; - $report =~ s/\.summary$/.report/; - ($location) = $status =~ m/(db-h|db|archive)/; - ($param{bug}) = $status =~ m/(\d+)\.summary$/; - } - if ($param{lock}) { - filelock("$config{spool_dir}/lock/$param{bug}",exists $param{locks}?$param{locks}:()); - } - my $status_fh = IO::File->new($status, 'r'); - if (not defined $status_fh) { - warn "Unable to open $status for reading: $!"; - if ($param{lock}) { - unfilelock(exists $param{locks}?$param{locks}:()); - } - return undef; - } - binmode($status_fh,':encoding(UTF-8)'); - - my %data; - my @lines; - my $version; - local $_; - - while (<$status_fh>) { - chomp; - push @lines, $_; - if (not defined $version and - /^Format-Version: ([0-9]+)/i - ) { - $version = $1; - } - } - $version = 2 if not defined $version; - # Version 3 is the latest format version currently supported. - if ($version > 3) { - warn "Unsupported status version '$version'"; - if ($param{lock}) { - unfilelock(exists $param{locks}?$param{locks}:()); - } - return undef; - } - - state $namemap = {reverse %fields}; - for my $line (@lines) { - if ($line =~ /(\S+?): (.*)/) { - my ($name, $value) = (lc $1, $2); - # this is a bit of a hack; we should never, ever have \r - # or \n in the fields of status. Kill them off here. - # [Eventually, this should be superfluous.] - $value =~ s/[\r\n]//g; - $data{$namemap->{$name}} = $value if exists $namemap->{$name}; - } - } - for my $field (keys %fields) { - $data{$field} = '' unless exists $data{$field}; - } - if ($version < 3) { - for my $field (@rfc1522_fields) { - $data{$field} = decode_rfc1522($data{$field}); - } - } - $data{severity} = $config{default_severity} if $data{severity} eq ''; - for my $field (qw(found_versions fixed_versions found_date fixed_date)) { - $data{$field} = [split ' ', $data{$field}]; - } - for my $field (qw(found fixed)) { - # create the found/fixed hashes which indicate when a - # particular version was marked found or marked fixed. - @{$data{$field}}{@{$data{"${field}_versions"}}} = - (('') x (@{$data{"${field}_versions"}} - @{$data{"${field}_date"}}), - @{$data{"${field}_date"}}); - } - - my $status_modified = (stat($status))[9]; - # Add log last modified time - $data{log_modified} = (stat($log))[9] // (stat("${log}.gz"))[9]; - my $report_modified = (stat($report))[9] // $data{log_modified}; - $data{last_modified} = max($status_modified,$data{log_modified}); - # if the date isn't set (ancient bug), use the smallest of any of the modified - if (not defined $data{date} or not length($data{date})) { - $data{date} = min($report_modified,$status_modified,$data{log_modified}); - } - $data{location} = $location; - $data{archived} = (defined($location) and ($location eq 'archive'))?1:0; - $data{bug_num} = $param{bug}; - - # mergedwith occasionally is sorted badly. Fix it to always be sorted by <=> - # and not include this bug - if (defined $data{mergedwith} and - $data{mergedwith}) { - $data{mergedwith} = - join(' ', - grep { $_ != $data{bug_num}} - sort { $a <=> $b } - split / /, $data{mergedwith} - ); - } - return \%data; -} - -=head2 split_status_fields - - my @data = split_status_fields(@data); - -Splits splittable status fields (like package, tags, blocks, -blockedby, etc.) into arrayrefs (use make_list on these). Keeps the -passed @data intact using dclone. - -In scalar context, returns only the first element of @data. - -=cut - -our $ditch_empty = sub{ - my @t = @_; - my $splitter = shift @t; - return grep {length $_} map {split $splitter} @t; -}; - -our $sort_and_unique = sub { - 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; - } -}; - -my $ditch_space_unique_and_sort = sub {return &{$sort_and_unique}(&{$ditch_empty}(' ',@_))}; -my %split_fields = - (package => \&splitpackages, - affects => \&splitpackages, - # Ideally we won't have to split source, but because some consumers of - # get_bug_status cannot handle arrayref, we will split it here. - source => \&splitpackages, - blocks => $ditch_space_unique_and_sort, - blockedby => $ditch_space_unique_and_sort, - # this isn't strictly correct, but we'll split both of them for - # the time being until we ditch all use of keywords everywhere - # from the code - keywords => $ditch_space_unique_and_sort, - tags => $ditch_space_unique_and_sort, - found_versions => $ditch_space_unique_and_sort, - fixed_versions => $ditch_space_unique_and_sort, - mergedwith => $ditch_space_unique_and_sort, - ); - -sub split_status_fields { - my @data = @{dclone(\@_)}; - for my $data (@data) { - next if not defined $data; - croak "Passed an element which is not a hashref to split_status_field".ref($data) if - not (ref($data) and ref($data) eq 'HASH'); - for my $field (keys %{$data}) { - next unless defined $data->{$field}; - if (exists $split_fields{$field}) { - next if ref($data->{$field}); - my @elements; - if (ref($split_fields{$field}) eq 'CODE') { - @elements = &{$split_fields{$field}}($data->{$field}); - } - elsif (not ref($split_fields{$field}) or - UNIVERSAL::isa($split_fields{$field},'Regex') - ) { - @elements = split $split_fields{$field}, $data->{$field}; - } - $data->{$field} = \@elements; - } - } - } - return wantarray?@data:$data[0]; -} - -=head2 join_status_fields - - my @data = join_status_fields(@data); - -Handles joining the splitable status fields. (Basically, the inverse -of split_status_fields. - -Primarily called from makestatus, but may be useful for other -functions after calling split_status_fields (or for legacy functions -if we transition to split fields by default). - -=cut - -sub join_status_fields { - my %join_fields = - (package => ', ', - affects => ', ', - blocks => ' ', - blockedby => ' ', - tags => ' ', - found_versions => ' ', - fixed_versions => ' ', - found_date => ' ', - fixed_date => ' ', - mergedwith => ' ', - ); - my @data = @{dclone(\@_)}; - for my $data (@data) { - next if not defined $data; - croak "Passed an element which is not a hashref to split_status_field: ". - ref($data) - if ref($data) ne 'HASH'; - for my $field (keys %{$data}) { - next unless defined $data->{$field}; - next unless ref($data->{$field}) eq 'ARRAY'; - next unless exists $join_fields{$field}; - $data->{$field} = join($join_fields{$field},@{$data->{$field}}); - } - } - return wantarray?@data:$data[0]; -} - - -=head2 lockreadbug - - lockreadbug($bug_num,$location) - -Performs a filelock, then reads the bug; the bug is unlocked if the -return is undefined, otherwise, you need to call unfilelock or -unlockwritebug. - -See readbug above for information on what this returns - -=cut - -sub lockreadbug { - my ($lref, $location) = @_; - return read_bug(bug => $lref, location => $location, lock => 1); -} - -=head2 lockreadbugmerge - - my ($locks, $data) = lockreadbugmerge($bug_num,$location); - -Performs a filelock, then reads the bug. If the bug is merged, locks -the merge lock. Returns a list of the number of locks and the bug -data. - -=cut - -sub lockreadbugmerge { - my $data = lockreadbug(@_); - if (not defined $data) { - return (0,undef); - } - if (not length $data->{mergedwith}) { - return (1,$data); - } - unfilelock(); - filelock("$config{spool_dir}/lock/merge"); - $data = lockreadbug(@_); - if (not defined $data) { - unfilelock(); - return (0,undef); - } - return (2,$data); -} - -=head2 lock_read_all_merged_bugs - - my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location); - -Performs a filelock, then reads the bug passed. If the bug is merged, -locks the merge lock, then reads and locks all of the other merged -bugs. Returns a list of the number of locks and the bug data for all -of the merged bugs. - -Will also return undef if any of the merged bugs failed to be read, -even if all of the others were read properly. - -=cut - -sub lock_read_all_merged_bugs { - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - location => {type => SCALAR, - optional => 1, - }, - locks => {type => HASHREF, - optional => 1, - }, - }, - ); - my $locks = 0; - my @data = read_bug(bug => $param{bug}, - lock => 1, - exists $param{location} ? (location => $param{location}):(), - exists $param{locks} ? (locks => $param{locks}):(), - ); - if (not @data or not defined $data[0]) { - return ($locks,()); - } - $locks++; - if (not length $data[0]->{mergedwith}) { - return ($locks,@data); - } - unfilelock(exists $param{locks}?$param{locks}:()); - $locks--; - filelock("$config{spool_dir}/lock/merge",exists $param{locks}?$param{locks}:()); - $locks++; - @data = read_bug(bug => $param{bug}, - lock => 1, - exists $param{location} ? (location => $param{location}):(), - exists $param{locks} ? (locks => $param{locks}):(), - ); - if (not @data or not defined $data[0]) { - unfilelock(exists $param{locks}?$param{locks}:()); #for merge lock above - $locks--; - return ($locks,()); - } - $locks++; - my @bugs = split / /, $data[0]->{mergedwith}; - push @bugs, $param{bug}; - for my $bug (@bugs) { - my $newdata = undef; - if ($bug != $param{bug}) { - $newdata = - read_bug(bug => $bug, - lock => 1, - exists $param{location} ? (location => $param{location}):(), - exists $param{locks} ? (locks => $param{locks}):(), - ); - if (not defined $newdata) { - for (1..$locks) { - unfilelock(exists $param{locks}?$param{locks}:()); - } - $locks = 0; - warn "Unable to read bug: $bug while handling merged bug: $param{bug}"; - return ($locks,()); - } - $locks++; - push @data,$newdata; - # perform a sanity check to make sure that the merged bugs - # are all merged with eachother - # We do a cmp sort instead of an <=> sort here, because that's - # what merge does - my $expectmerge= - join(' ',grep {$_ != $bug } - sort { $a <=> $b } - @bugs); - if ($newdata->{mergedwith} ne $expectmerge) { - for (1..$locks) { - unfilelock(exists $param{locks}?$param{locks}:()); - } - die "Bug $param{bug} mergedwith differs from bug $bug: ($newdata->{bug_num}: '$newdata->{mergedwith}') vs. ('$expectmerge') (".join(' ',@bugs).")"; - } - } - } - return ($locks,@data); -} - -=head2 new_bug - - my $new_bug_num = new_bug(copy => $data->{bug_num}); - -Creates a new bug and returns the new bug number upon success. - -Dies upon failures. - -=cut - -sub new_bug { - my %param = - validate_with(params => \@_, - spec => {copy => {type => SCALAR, - regex => qr/^\d+/, - optional => 1, - }, - }, - ); - filelock("nextnumber.lock"); - my $nn_fh = IO::File->new("nextnumber",'r') or - die "Unable to open nextnuber for reading: $!"; - local $\; - my $nn = <$nn_fh>; - ($nn) = $nn =~ m/^(\d+)\n$/ or die "Bad format of nextnumber; is not exactly ".'^\d+\n$'; - close $nn_fh; - overwritefile("nextnumber", - ($nn+1)."\n"); - unfilelock(); - my $nn_hash = get_hashname($nn); - if ($param{copy}) { - my $c_hash = get_hashname($param{copy}); - for my $file (qw(log status summary report)) { - copy("db-h/$c_hash/$param{copy}.$file", - "db-h/$nn_hash/${nn}.$file") - } - } - else { - for my $file (qw(log status summary report)) { - overwritefile("db-h/$nn_hash/${nn}.$file", - ""); - } - } - - # this probably needs to be munged to do something more elegant -# &bughook('new', $clone, $data); - - return($nn); -} - - - -my @v1fieldorder = qw(originator date subject msgid package - keywords done forwarded mergedwith severity); - -=head2 makestatus - - my $content = makestatus($status,$version) - my $content = makestatus($status); - -Creates the content for a status file based on the $status hashref -passed. - -Really only useful for writebug - -Currently defaults to version 2 (non-encoded rfc1522 names) but will -eventually default to version 3. If you care, you should specify a -version. - -=cut - -sub makestatus { - my ($data,$version) = @_; - $version = 3 unless defined $version; - - my $contents = ''; - - my %newdata = %$data; - for my $field (qw(found fixed)) { - if (exists $newdata{$field}) { - $newdata{"${field}_date"} = - [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}]; - } - } - %newdata = %{join_status_fields(\%newdata)}; - - %newdata = encode_utf8_structure(%newdata); - - if ($version < 3) { - for my $field (@rfc1522_fields) { - $newdata{$field} = encode_rfc1522($newdata{$field}); - } - } - - # this is a bit of a hack; we should never, ever have \r or \n in - # the fields of status. Kill them off here. [Eventually, this - # should be superfluous.] - for my $field (keys %newdata) { - $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field}; - } - - if ($version == 1) { - for my $field (@v1fieldorder) { - if (exists $newdata{$field} and defined $newdata{$field}) { - $contents .= "$newdata{$field}\n"; - } else { - $contents .= "\n"; - } - } - } elsif ($version == 2 or $version == 3) { - # Version 2 or 3. Add a file format version number for the sake of - # further extensibility in the future. - $contents .= "Format-Version: $version\n"; - for my $field (keys %fields) { - if (exists $newdata{$field} and defined $newdata{$field} - and $newdata{$field} ne '') { - # Output field names in proper case, e.g. 'Merged-With'. - my $properfield = $fields{$field}; - $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g; - my $data = $newdata{$field}; - $contents .= "$properfield: $data\n"; - } - } - } - return $contents; -} - -=head2 writebug - - writebug($bug_num,$status,$location,$minversion,$disablebughook) - -Writes the bug status and summary files out. - -Skips writing out a status file if minversion is 2 - -Does not call bughook if disablebughook is true. - -=cut - -sub writebug { - my ($ref, $data, $location, $minversion, $disablebughook) = @_; - my $change; - - my %outputs = (1 => 'status', 3 => 'summary'); - for my $version (keys %outputs) { - next if defined $minversion and $version < $minversion; - my $status = getbugcomponent($ref, $outputs{$version}, $location); - die "can't find location for $ref" unless defined $status; - my $sfh; - if ($version >= 3) { - open $sfh,">","$status.new" or - die "opening $status.new: $!"; - } - else { - open $sfh,">","$status.new" or - die "opening $status.new: $!"; - } - print {$sfh} makestatus($data, $version) or - die "writing $status.new: $!"; - close($sfh) or die "closing $status.new: $!"; - if (-e $status) { - $change = 'change'; - } else { - $change = 'new'; - } - rename("$status.new",$status) || die "installing new $status: $!"; - } - - # $disablebughook is a bit of a hack to let format migration scripts use - # this function rather than having to duplicate it themselves. - &bughook($change,$ref,$data) unless $disablebughook; -} - -=head2 unlockwritebug - - unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook); - -Writes a bug, then calls unfilelock; see writebug for what these -options mean. - -=cut - -sub unlockwritebug { - writebug(@_); - unfilelock(); -} - -=head1 VERSIONS - -The following functions are exported with the :versions tag - -=head2 addfoundversions - - addfoundversions($status,$package,$version,$isbinary); - -All use of this should be phased out in favor of Debbugs::Control::fixed/found - -=cut - - -sub addfoundversions { - my $data = shift; - my $package = shift; - my $version = shift; - my $isbinary = shift; - return unless defined $version; - undef $package if defined $package and $package =~ m[(?:\s|/)]; - my $source = $package; - if (defined $package and $package =~ s/^src://) { - $isbinary = 0; - $source = $package; - } - - if (defined $package and $isbinary) { - my @srcinfo = binary_to_source(binary => $package, - version => $version); - if (@srcinfo) { - # We know the source package(s). Use a fully-qualified version. - addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo; - return; - } - # Otherwise, an unqualified version will have to do. - undef $source; - } - - # Strip off various kinds of brain-damage. - $version =~ s/;.*//; - $version =~ s/ *\(.*\)//; - $version =~ s/ +[A-Za-z].*//; - - foreach my $ver (split /[,\s]+/, $version) { - my $sver = defined($source) ? "$source/$ver" : ''; - unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) { - push @{$data->{found_versions}}, defined($source) ? $sver : $ver; - } - @{$data->{fixed_versions}} = - grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}}; - } -} - -=head2 removefoundversions - - removefoundversions($data,$package,$versiontoremove) - -Removes found versions from $data - -If a version is fully qualified (contains /) only versions matching -exactly are removed. Otherwise, all versions matching the version -number are removed. - -Currently $package and $isbinary are entirely ignored, but accepted -for backwards compatibility. - -=cut - -sub removefoundversions { - my $data = shift; - my $package = shift; - my $version = shift; - my $isbinary = shift; - return unless defined $version; - - foreach my $ver (split /[,\s]+/, $version) { - if ($ver =~ m{/}) { - # fully qualified version - @{$data->{found_versions}} = - grep {$_ ne $ver} - @{$data->{found_versions}}; - } - else { - # non qualified version; delete all matchers - @{$data->{found_versions}} = - grep {$_ !~ m[(?:^|/)\Q$ver\E$]} - @{$data->{found_versions}}; - } - } -} - - -sub addfixedversions { - my $data = shift; - my $package = shift; - my $version = shift; - my $isbinary = shift; - return unless defined $version; - undef $package if defined $package and $package =~ m[(?:\s|/)]; - my $source = $package; - - if (defined $package and $isbinary) { - my @srcinfo = binary_to_source(binary => $package, - version => $version); - if (@srcinfo) { - # We know the source package(s). Use a fully-qualified version. - addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo; - return; - } - # Otherwise, an unqualified version will have to do. - undef $source; - } - - # Strip off various kinds of brain-damage. - $version =~ s/;.*//; - $version =~ s/ *\(.*\)//; - $version =~ s/ +[A-Za-z].*//; - - foreach my $ver (split /[,\s]+/, $version) { - my $sver = defined($source) ? "$source/$ver" : ''; - unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) { - push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver; - } - @{$data->{found_versions}} = - grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}}; - } -} - -sub removefixedversions { - my $data = shift; - my $package = shift; - my $version = shift; - my $isbinary = shift; - return unless defined $version; - - foreach my $ver (split /[,\s]+/, $version) { - if ($ver =~ m{/}) { - # fully qualified version - @{$data->{fixed_versions}} = - grep {$_ ne $ver} - @{$data->{fixed_versions}}; - } - else { - # non qualified version; delete all matchers - @{$data->{fixed_versions}} = - grep {$_ !~ m[(?:^|/)\Q$ver\E$]} - @{$data->{fixed_versions}}; - } - } -} - - - -=head2 splitpackages - - splitpackages($pkgs) - -Split a package string from the status file into a list of package names. - -=cut - -sub splitpackages { - my $pkgs = shift; - return unless defined $pkgs; - return grep {length $_} map lc, split /[\s,()?]+/, $pkgs; -} - - -=head2 bug_archiveable - - bug_archiveable(bug => $bug_num); - -Options - -=over - -=item bug -- bug number (required) - -=item status -- Status hashref returned by read_bug or get_bug_status (optional) - -=item version -- Debbugs::Version information (optional) - -=item days_until -- return days until the bug can be archived - -=back - -Returns 1 if the bug can be archived -Returns 0 if the bug cannot be archived - -If days_until is true, returns the number of days until the bug can be -archived, -1 if it cannot be archived. 0 means that the bug can be -archived the next time the archiver runs. - -Returns undef on failure. - -=cut - -# This will eventually need to be fixed before we start using mod_perl -our $version_cache = {}; -sub bug_archiveable{ - state $spec = {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - status => {type => HASHREF, - optional => 1, - }, - days_until => {type => BOOLEAN, - default => 0, - }, - ignore_time => {type => BOOLEAN, - default => 0, - }, - schema => {type => OBJECT, - optional => 1, - }, - }; - my %param = validate_with(params => \@_, - spec => $spec, - ); - # This is what we return if the bug cannot be archived. - my $cannot_archive = $param{days_until}?-1:0; - # read the status information - my $status = $param{status}; - if (not exists $param{status} or not defined $status) { - $status = read_bug(bug=>$param{bug}); - if (not defined $status) { - print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG; - return undef; - } - } - # Bugs can be archived if they are - # 1. Closed - if (not defined $status->{done} or not length $status->{done}) { - print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG; - return $cannot_archive - } - # Check to make sure that the bug has none of the unremovable tags set - if (@{$config{removal_unremovable_tags}}) { - for my $tag (split ' ', ($status->{keywords}||'')) { - if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) { - print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG; - return $cannot_archive; - } - } - } - - # If we just are checking if the bug can be archived, we'll not even bother - # checking the versioning information if the bug has been -done for less than 28 days. - my $log_file = getbugcomponent($param{bug},'log'); - if (not defined $log_file or not -e $log_file) { - print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG; - return $cannot_archive; - } - my @log_files = $log_file, (map {my $log = getbugcomponent($_,'log'); - defined $log ? ($log) : (); - } - split / /, $status->{mergedwith}); - my $max_log_age = max(map {-e $_?($config{remove_age} - -M _):0} - @log_files); - if (not $param{days_until} and not $param{ignore_time} - and $max_log_age > 0 - ) { - print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG; - return $cannot_archive; - } - # At this point, we have to get the versioning information for this bug. - # We examine the set of distribution tags. If a bug has no distribution - # tags set, we assume a default set, otherwise we use the tags the bug - # has set. - - # In cases where we are assuming a default set, if the severity - # is strong, we use the strong severity default; otherwise, we - # use the normal default. - - # There must be fixed_versions for us to look at the versioning - # information - my $min_fixed_time = time; - my $min_archive_days = 0; - if (@{$status->{fixed_versions}}) { - my %dist_tags; - @dist_tags{@{$config{removal_distribution_tags}}} = - (1) x @{$config{removal_distribution_tags}}; - my %dists; - for my $tag (split ' ', ($status->{keywords}||'')) { - next unless exists $config{distribution_aliases}{$tag}; - next unless $dist_tags{$config{distribution_aliases}{$tag}}; - $dists{$config{distribution_aliases}{$tag}} = 1; - } - if (not keys %dists) { - if (isstrongseverity($status->{severity})) { - @dists{@{$config{removal_strong_severity_default_distribution_tags}}} = - (1) x @{$config{removal_strong_severity_default_distribution_tags}}; - } - else { - @dists{@{$config{removal_default_distribution_tags}}} = - (1) x @{$config{removal_default_distribution_tags}}; - } - } - my %source_versions; - my @sourceversions = get_versions(package => $status->{package}, - dist => [keys %dists], - source => 1, - hash_slice(%param,'schema'), - ); - @source_versions{@sourceversions} = (1) x @sourceversions; - # If the bug has not been fixed in the versions actually - # distributed, then it cannot be archived. - if ('found' eq max_buggy(bug => $param{bug}, - sourceversions => [keys %source_versions], - found => $status->{found_versions}, - fixed => $status->{fixed_versions}, - version_cache => $version_cache, - package => $status->{package}, - hash_slice(%param,'schema'), - )) { - print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG; - return $cannot_archive; - } - # Since the bug has at least been fixed in the architectures - # that matters, we check to see how long it has been fixed. - - # If $param{ignore_time}, then we should ignore time. - if ($param{ignore_time}) { - return $param{days_until}?0:1; - } - - # To do this, we order the times from most recent to oldest; - # when we come to the first found version, we stop. - # If we run out of versions, we only report the time of the - # last one. - my %time_versions = get_versions(package => $status->{package}, - dist => [keys %dists], - source => 1, - time => 1, - hash_slice(%param,'schema'), - ); - for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) { - my $buggy = buggy(bug => $param{bug}, - version => $version, - found => $status->{found_versions}, - fixed => $status->{fixed_versions}, - version_cache => $version_cache, - package => $status->{package}, - hash_slice(%param,'schema'), - ); - last if $buggy eq 'found'; - $min_fixed_time = min($time_versions{$version},$min_fixed_time); - } - $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24))) - # if there are no versions in the archive at all, then - # we can archive if enough days have passed - if @sourceversions; - } - # If $param{ignore_time}, then we should ignore time. - if ($param{ignore_time}) { - return $param{days_until}?0:1; - } - # 6. at least 28 days have passed since the last action has occured or the bug was closed - my $age = ceil($max_log_age); - if ($age > 0 or $min_archive_days > 0) { - print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG; - return $param{days_until}?max($age,$min_archive_days):0; - } - else { - return $param{days_until}?0:1; - } -} - - -=head2 get_bug_status - - my $status = get_bug_status(bug => $nnn); - - my $status = get_bug_status($bug_num) - -=head3 Options - -=over - -=item bug -- scalar bug number - -=item status -- optional hashref of bug status as returned by readbug -(can be passed to avoid rereading the bug information) - -=item bug_index -- optional tied index of bug status infomration; -currently not correctly implemented. - -=item version -- optional version(s) to check package status at - -=item dist -- optional distribution(s) to check package status at - -=item arch -- optional architecture(s) to check package status at - -=item bugusertags -- optional hashref of bugusertags - -=item sourceversion -- optional arrayref of source/version; overrides -dist, arch, and version. [The entries in this array must be in the -"source/version" format.] Eventually this can be used to for caching. - -=item indicatesource -- if true, indicate which source packages this -bug could belong to (or does belong to in the case of bugs assigned to -a source package). Defaults to true. - -=back - -Note: Currently the version information is cached; this needs to be -changed before using this function in long lived programs. - -=head3 Returns - -Currently returns a hashref of status with the following keys. - -=over - -=item id -- bug number - -=item bug_num -- duplicate of id - -=item keywords -- tags set on the bug, including usertags if bugusertags passed. - -=item tags -- duplicate of keywords - -=item package -- name of package that the bug is assigned to - -=item severity -- severity of the bug - -=item pending -- pending state of the bug; one of following possible -values; values listed later have precedence if multiple conditions are -satisifed: - -=over - -=item pending -- default state - -=item forwarded -- bug has been forwarded - -=item pending-fixed -- bug is tagged pending - -=item fixed -- bug is tagged fixed - -=item absent -- bug does not apply to this distribution/architecture - -=item done -- bug is resolved in this distribution/architecture - -=back - -=item location -- db-h or archive; the location in the filesystem - -=item subject -- title of the bug - -=item last_modified -- epoch that the bug was last modified - -=item date -- epoch that the bug was filed - -=item originator -- bug reporter - -=item log_modified -- epoch that the log file was last modified - -=item msgid -- Message id of the original bug report - -=back - - -Other key/value pairs are returned but are not currently documented here. - -=cut - -sub get_bug_status { - if (@_ == 1) { - unshift @_, 'bug'; - } - state $spec = - {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - status => {type => HASHREF, - optional => 1, - }, - bug_index => {type => OBJECT, - optional => 1, - }, - version => {type => SCALAR|ARRAYREF, - optional => 1, - }, - dist => {type => SCALAR|ARRAYREF, - optional => 1, - }, - arch => {type => SCALAR|ARRAYREF, - optional => 1, - }, - bugusertags => {type => HASHREF, - optional => 1, - }, - sourceversions => {type => ARRAYREF, - optional => 1, - }, - indicatesource => {type => BOOLEAN, - default => 1, - }, - binary_to_source_cache => {type => HASHREF, - optional => 1, - }, - schema => {type => OBJECT, - optional => 1, - }, - }; - my %param = validate_with(params => \@_, - spec => $spec, - ); - my %status; - - if (defined $param{bug_index} and - exists $param{bug_index}{$param{bug}}) { - %status = %{ $param{bug_index}{$param{bug}} }; - $status{pending} = $status{ status }; - $status{id} = $param{bug}; - return \%status; - } - my $statuses = get_bug_statuses(@_); - if (exists $statuses->{$param{bug}}) { - return $statuses->{$param{bug}}; - } else { - return {}; - } -} - -sub get_bug_statuses { - state $spec = - {bug => {type => SCALAR|ARRAYREF, - }, - status => {type => HASHREF, - optional => 1, - }, - bug_index => {type => OBJECT, - optional => 1, - }, - version => {type => SCALAR|ARRAYREF, - optional => 1, - }, - dist => {type => SCALAR|ARRAYREF, - optional => 1, - }, - arch => {type => SCALAR|ARRAYREF, - optional => 1, - }, - bugusertags => {type => HASHREF, - optional => 1, - }, - sourceversions => {type => ARRAYREF, - optional => 1, - }, - indicatesource => {type => BOOLEAN, - default => 1, - }, - binary_to_source_cache => {type => HASHREF, - optional => 1, - }, - schema => {type => OBJECT, - optional => 1, - }, - }; - my %param = validate_with(params => \@_, - spec => $spec, - ); - my $bin_to_src_cache = {}; - if (defined $param{binary_to_source_cache}) { - $bin_to_src_cache = $param{binary_to_source_cache}; - } - my %status; - my %statuses; - if (defined $param{schema}) { - my @bug_statuses = - $param{schema}->resultset('BugStatus')-> - search_rs({id => [make_list($param{bug})]}, - {result_class => 'DBIx::Class::ResultClass::HashRefInflator'})-> - all(); - for my $bug_status (@bug_statuses) { - $statuses{$bug_status->{bug_num}} = - $bug_status; - for my $field (qw(blocks blockedby done), - qw(tags mergedwith affects) - ) { - $bug_status->{$field} //=''; - } - $bug_status->{keywords} = - $bug_status->{tags}; - $bug_status->{location} = $bug_status->{archived}?'archive':'db-h'; - for my $field (qw(found_versions fixed_versions found_date fixed_date)) { - $bug_status->{$field} = [split ' ', $bug_status->{$field} // '']; - } - for my $field (qw(found fixed)) { - # create the found/fixed hashes which indicate when a - # particular version was marked found or marked fixed. - @{$bug_status->{$field}}{@{$bug_status->{"${field}_versions"}}} = - (('') x (@{$bug_status->{"${field}_versions"}} - - @{$bug_status->{"${field}_date"}}), - @{$bug_status->{"${field}_date"}}); - } - $bug_status->{id} = $bug_status->{bug_num}; - } - } else { - for my $bug (make_list($param{bug})) { - if (defined $param{bug_index} and - exists $param{bug_index}{$bug}) { - my %status = %{$param{bug_index}{$bug}}; - $status{pending} = $status{status}; - $status{id} = $bug; - $statuses{$bug} = \%status; - } - elsif (defined $param{status} and - $param{status}{bug_num} == $bug - ) { - $statuses{$bug} = {%{$param{status}}}; - } else { - my $location = getbuglocation($bug, 'summary'); - next if not defined $location or not length $location; - my %status = %{ readbug( $bug, $location ) }; - $status{id} = $bug; - $statuses{$bug} = \%status; - } - } - } - for my $bug (keys %statuses) { - my $status = $statuses{$bug}; - - if (defined $param{bugusertags}{$param{bug}}) { - $status->{keywords} = "" unless defined $status->{keywords}; - $status->{keywords} .= " " unless $status->{keywords} eq ""; - $status->{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}}); - } - $status->{tags} = $status->{keywords}; - my %tags = map { $_ => 1 } split ' ', $status->{tags}; - - $status->{package} = '' if not defined $status->{package}; - $status->{"package"} =~ s/\s*$//; - - $status->{"package"} = 'unknown' if ($status->{"package"} eq ''); - $status->{"severity"} = 'normal' if (not defined $status->{severity} or $status->{"severity"} eq ''); - - $status->{"pending"} = 'pending'; - $status->{"pending"} = 'forwarded' if (length($status->{"forwarded"})); - $status->{"pending"} = 'pending-fixed' if ($tags{pending}); - $status->{"pending"} = 'fixed' if ($tags{fixed}); - - - my $presence = bug_presence(status => $status, - bug => $bug, - map{(exists $param{$_})?($_,$param{$_}):()} - qw(sourceversions arch dist version found fixed package) - ); - if (defined $presence) { - if ($presence eq 'fixed') { - $status->{pending} = 'done'; - } elsif ($presence eq 'absent') { - $status->{pending} = 'absent'; - } - } - } - return \%statuses; -} - -=head2 bug_presence - - my $precence = bug_presence(bug => nnn, - ... - ); - -Returns 'found', 'absent', 'fixed' or undef based on whether the bug -is found, absent, fixed, or no information is available in the -distribution (dist) and/or architecture (arch) specified. - - -=head3 Options - -=over - -=item bug -- scalar bug number - -=item status -- optional hashref of bug status as returned by readbug -(can be passed to avoid rereading the bug information) - -=item bug_index -- optional tied index of bug status infomration; -currently not correctly implemented. - -=item version -- optional version to check package status at - -=item dist -- optional distribution to check package status at - -=item arch -- optional architecture to check package status at - -=item sourceversion -- optional arrayref of source/version; overrides -dist, arch, and version. [The entries in this array must be in the -"source/version" format.] Eventually this can be used to for caching. - -=back - -=cut - -sub bug_presence { - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - status => {type => HASHREF, - optional => 1, - }, - version => {type => SCALAR|ARRAYREF, - optional => 1, - }, - dist => {type => SCALAR|ARRAYREF, - optional => 1, - }, - arch => {type => SCALAR|ARRAYREF, - optional => 1, - }, - sourceversions => {type => ARRAYREF, - optional => 1, - }, - }, - ); - my %status; - if (defined $param{status}) { - %status = %{$param{status}}; - } - else { - my $location = getbuglocation($param{bug}, 'summary'); - return {} if not length $location; - %status = %{ readbug( $param{bug}, $location ) }; - } - - my @sourceversions; - my $pseudo_desc = getpseudodesc(); - if (not exists $param{sourceversions}) { - my %sourceversions; - # pseudopackages do not have source versions by definition. - if (exists $pseudo_desc->{$status{package}}) { - # do nothing. - } - elsif (defined $param{version}) { - foreach my $arch (make_list($param{arch})) { - for my $package (split /\s*,\s*/, $status{package}) { - my @temp = makesourceversions($package, - $arch, - make_list($param{version}) - ); - @sourceversions{@temp} = (1) x @temp; - } - } - } elsif (defined $param{dist}) { - my %affects_distribution_tags; - @affects_distribution_tags{@{$config{affects_distribution_tags}}} = - (1) x @{$config{affects_distribution_tags}}; - my $some_distributions_disallowed = 0; - my %allowed_distributions; - for my $tag (split ' ', ($status{keywords}||'')) { - if (exists $config{distribution_aliases}{$tag} and - exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) { - $some_distributions_disallowed = 1; - $allowed_distributions{$config{distribution_aliases}{$tag}} = 1; - } - elsif (exists $affects_distribution_tags{$tag}) { - $some_distributions_disallowed = 1; - $allowed_distributions{$tag} = 1; - } - } - my @archs = make_list(exists $param{arch}?$param{arch}:()); - GET_SOURCE_VERSIONS: - foreach my $arch (@archs) { - for my $package (split /\s*,\s*/, $status{package}) { - my @versions = (); - my $source = 0; - if ($package =~ /^src:(.+)$/) { - $source = 1; - $package = $1; - } - foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) { - # if some distributions are disallowed, - # and this isn't an allowed - # distribution, then we ignore this - # distribution for the purposees of - # finding versions - if ($some_distributions_disallowed and - not exists $allowed_distributions{$dist}) { - next; - } - push @versions, get_versions(package => $package, - dist => $dist, - ($source?(arch => 'source'): - (defined $arch?(arch => $arch):())), - ); - } - next unless @versions; - my @temp = make_source_versions(package => $package, - arch => $arch, - versions => \@versions, - ); - @sourceversions{@temp} = (1) x @temp; - } - } - # this should really be split out into a subroutine, - # but it'd touch so many things currently, that we fake - # it; it's needed to properly handle bugs which are - # erroneously assigned to the binary package, and we'll - # probably have it go away eventually. - if (not keys %sourceversions and (not @archs or defined $archs[0])) { - @archs = (undef); - goto GET_SOURCE_VERSIONS; - } - } - - # TODO: This should probably be handled further out for efficiency and - # for more ease of distinguishing between pkg= and src= queries. - # DLA: src= queries should just pass arch=source, and they'll be happy. - @sourceversions = keys %sourceversions; - } - else { - @sourceversions = @{$param{sourceversions}}; - } - my $maxbuggy = 'undef'; - if (@sourceversions) { - $maxbuggy = max_buggy(bug => $param{bug}, - sourceversions => \@sourceversions, - found => $status{found_versions}, - fixed => $status{fixed_versions}, - package => $status{package}, - version_cache => $version_cache, - ); - } - elsif (defined $param{dist} and - not exists $pseudo_desc->{$status{package}}) { - return 'absent'; - } - if (length($status{done}) and - (not @sourceversions or not @{$status{fixed_versions}})) { - return 'fixed'; - } - return $maxbuggy; -} - - -=head2 max_buggy - - max_buggy() - -=head3 Options - -=over - -=item bug -- scalar bug number - -=item sourceversion -- optional arrayref of source/version; overrides -dist, arch, and version. [The entries in this array must be in the -"source/version" format.] Eventually this can be used to for caching. - -=back - -Note: Currently the version information is cached; this needs to be -changed before using this function in long lived programs. - - -=cut -sub max_buggy{ - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - sourceversions => {type => ARRAYREF, - default => [], - }, - found => {type => ARRAYREF, - default => [], - }, - fixed => {type => ARRAYREF, - default => [], - }, - package => {type => SCALAR, - }, - version_cache => {type => HASHREF, - default => {}, - }, - schema => {type => OBJECT, - optional => 1, - }, - }, - ); - # Resolve bugginess states (we might be looking at multiple - # architectures, say). Found wins, then fixed, then absent. - my $maxbuggy = 'absent'; - for my $package (split /\s*,\s*/, $param{package}) { - for my $version (@{$param{sourceversions}}) { - my $buggy = buggy(bug => $param{bug}, - version => $version, - found => $param{found}, - fixed => $param{fixed}, - version_cache => $param{version_cache}, - package => $package, - ); - if ($buggy eq 'found') { - return 'found'; - } elsif ($buggy eq 'fixed') { - $maxbuggy = 'fixed'; - } - } - } - return $maxbuggy; -} - - -=head2 buggy - - buggy(bug => nnn, - found => \@found, - fixed => \@fixed, - package => 'foo', - version => '1.0', - ); - -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. - -Caching can be had by using the version_cache, but no attempt to check -to see if the on disk information is more recent than the cache is -made. [This will need to be fixed for long-lived processes.] - -=cut - -sub buggy { - my %param = validate_with(params => \@_, - spec => {bug => {type => SCALAR, - regex => qr/^\d+$/, - }, - found => {type => ARRAYREF, - default => [], - }, - fixed => {type => ARRAYREF, - default => [], - }, - version_cache => {type => HASHREF, - optional => 1, - }, - package => {type => SCALAR, - }, - version => {type => SCALAR, - }, - schema => {type => OBJECT, - optional => 1, - }, - }, - ); - my @found = @{$param{found}}; - my @fixed = @{$param{fixed}}; - if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) { - # We have non-source version versions - @found = makesourceversions($param{package},undef, - @found - ); - @fixed = makesourceversions($param{package},undef, - @fixed - ); - } - if ($param{version} !~ m{/}) { - my ($version) = makesourceversions($param{package},undef, - $param{version} - ); - $param{version} = $version if defined $version; - } - # Figure out which source packages we need - my %sources; - @sources{map {m{(.+)/}; $1} @found} = (1) x @found; - @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed; - @sources{map {m{(.+)/}; $1} $param{version}} = 1 if - $param{version} =~ m{/}; - my $version; - if (not defined $param{version_cache} or - not exists $param{version_cache}{join(',',sort keys %sources)}) { - $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp); - foreach my $source (keys %sources) { - my $srchash = substr $source, 0, 1; - my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r'); - if (not defined $version_fh) { - # We only want to warn if it's a package which actually has a maintainer - my @maint = package_maintainer(source => $source, - hash_slice(%param,'schema'), - ); - next unless @maint; - warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!"; - next; - } - $version->load($version_fh); - } - if (defined $param{version_cache}) { - $param{version_cache}{join(',',sort keys %sources)} = $version; - } - } - else { - $version = $param{version_cache}{join(',',sort keys %sources)}; - } - return $version->buggy($param{version},\@found,\@fixed); -} - -sub isstrongseverity { - my $severity = shift; - $severity = $config{default_severity} if - not defined $severity or $severity eq ''; - return grep { $_ eq $severity } @{$config{strong_severities}}; -} - -=head1 indexdb - -=head2 generate_index_db_line - - my $data = read_bug(bug => $bug, - location => $initialdir); - # generate_index_db_line hasn't been written yet at all. - my $line = generate_index_db_line($data); - -Returns a line for a bug suitable to be written out to index.db. - -=cut - -sub generate_index_db_line { - my ($data,$bug) = @_; - - # just in case someone has given us a split out data - $data = join_status_fields($data); - - my $whendone = "open"; - my $severity = $config{default_severity}; - (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g; - $pkglist =~ s/^,+//; - $pkglist =~ s/,+$//; - $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded}; - $whendone = "done" if defined $data->{done} and length $data->{done}; - $severity = $data->{severity} if length $data->{severity}; - return sprintf "%s %d %d %s [%s] %s %s\n", - $pkglist, $data->{bug_num}//$bug, $data->{date}, $whendone, - $data->{originator}, $severity, $data->{keywords}; -} - - - -=head1 PRIVATE FUNCTIONS - -=cut - -sub update_realtime { - my ($file, %bugs) = @_; - - # update realtime index.db - - return () unless keys %bugs; - my $idx_old = IO::File->new($file,'r') - or die "Couldn't open ${file}: $!"; - my $idx_new = IO::File->new($file.'.new','w') - or die "Couldn't open ${file}.new: $!"; - - binmode($idx_old,':raw:utf8'); - binmode($idx_new,':raw:encoding(UTF-8)'); - my $min_bug = min(keys %bugs); - my $line; - my @line; - my %changed_bugs; - while($line = <$idx_old>) { - @line = split /\s/, $line; - # Two cases; replacing existing line or adding new line - if (exists $bugs{$line[1]}) { - my $new = $bugs{$line[1]}; - delete $bugs{$line[1]}; - $min_bug = min(keys %bugs); - if ($new eq "NOCHANGE") { - print {$idx_new} $line; - $changed_bugs{$line[1]} = $line; - } elsif ($new eq "REMOVE") { - $changed_bugs{$line[1]} = $line; - } else { - print {$idx_new} $new; - $changed_bugs{$line[1]} = $line; - } - } - else { - while ($line[1] > $min_bug) { - print {$idx_new} $bugs{$min_bug}; - delete $bugs{$min_bug}; - last unless keys %bugs; - $min_bug = min(keys %bugs); - } - print {$idx_new} $line; - } - last unless keys %bugs; - } - print {$idx_new} map {$bugs{$_}} sort keys %bugs; - - print {$idx_new} <$idx_old>; - - close($idx_new); - close($idx_old); - - rename("$file.new", $file); - - return %changed_bugs; -} - -sub bughook_archive { - my @refs = @_; - filelock("$config{spool_dir}/debbugs.trace.lock"); - appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n"); - my %bugs = update_realtime("$config{spool_dir}/index.db.realtime", - map{($_,'REMOVE')} @refs); - update_realtime("$config{spool_dir}/index.archive.realtime", - %bugs); - unfilelock(); -} - -sub bughook { - my ( $type, %bugs_temp ) = @_; - filelock("$config{spool_dir}/debbugs.trace.lock"); - - my %bugs; - for my $bug (keys %bugs_temp) { - my $data = $bugs_temp{$bug}; - appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1)); - - $bugs{$bug} = generate_index_db_line($data,$bug); - } - update_realtime("$config{spool_dir}/index.db.realtime", %bugs); - - unfilelock(); -} - - -1; - -__END__ diff --git a/Debbugs/Text.pm b/Debbugs/Text.pm deleted file mode 100644 index 53ecf04..0000000 --- a/Debbugs/Text.pm +++ /dev/null @@ -1,220 +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 2007 by Don Armstrong . - -package Debbugs::Text; - -use warnings; -use strict; - -=head1 NAME - -Debbugs::Text -- General routines for text templates - -=head1 SYNOPSIS - - use Debbugs::Text qw(:templates); - print fill_in_template(template => 'cgi/foo'); - -=head1 DESCRIPTION - -This module is a replacement for parts of common.pl; subroutines in -common.pl will be gradually phased out and replaced with equivalent -(or better) functionality here. - -=head1 BUGS - -None known. - -=cut - - -use vars qw($DEBUG $VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT @ISA); -use Exporter qw(import); - -BEGIN { - $VERSION = 1.00; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - %EXPORT_TAGS = (templates => [qw(fill_in_template)], - ); - @EXPORT_OK = (); - Exporter::export_ok_tags(qw(templates)); - $EXPORT_TAGS{all} = [@EXPORT_OK]; -} - -use Text::Xslate qw(html_builder); - -use Storable qw(dclone); - -use Debbugs::Config qw(:config); - -use Params::Validate qw(:types validate_with); -use Carp; -use IO::File; -use Data::Dumper; - -### for %text_xslate_functions -use POSIX; -use Debbugs::CGI qw(html_escape); -use Scalar::Util; -use Debbugs::Common qw(make_list); -use Debbugs::Status; - -our %tt_templates; -our %filled_templates; -our $language; - - -sub __output_select_options { - my ($options,$value) = @_; - my @options = @{$options}; - my $output = ''; - while (@options) { - my ($o_value) = shift @options; - if (ref($o_value)) { - for (@{$o_value}) { - unshift @options, - ($_,$_); - } - next; - } - my $name = shift @options; - my $selected = ''; - if (defined $value and $o_value eq $value) { - $selected = ' selected'; - } - $output .= q(\n); - } - return $output; -} - -sub __text_xslate_functions { - return - {gm_strftime => sub {POSIX::strftime($_[0],gmtime)}, - package_links => html_builder(\&Debbugs::CGI::package_links), - bug_links => html_builder(\&Debbugs::CGI::bug_links), - looks_like_number => \&Scalar::Util::looks_like_number, - isstrongseverity => \&Debbugs::Status::isstrongseverity, - secs_to_english => \&Debbugs::Common::secs_to_english, - maybelink => \&Debbugs::CGI::maybelink, - # add in a few utility routines - duplicate_array => sub { - my @r = map {($_,$_)} make_list(@{$_[0]}); - return @r; - }, - output_select_options => html_builder(\&__output_select_options), - make_list => \&make_list, - }; -} -sub __text_xslate_functions_text { - return - {bugurl => - sub{ - return "$_[0]: ". - $config{cgi_domain}.'/'. - Debbugs::CGI::bug_links(bug=>$_[0], - links_only => 1, - ); - }, - }; -} - - - -### this function removes leading spaces from line-start code strings and spaces -### before <:- and spaces after -:> -sub __html_template_prefilter { - my $text = shift; - $text =~ s/^\s+:/:/mg; - $text =~ s/((?:^:[^\n]*\n)?)\s*(<:-)/$1$2/mg; - $text =~ s/(-:>)\s+(^:|)/$1.(length($2)?"\n$2":'')/emg; - return $text; -} - - -=head2 fill_in_template - - print fill_in_template(template => 'template_name', - variables => \%variables, - language => '..' - ); - -Reads a template from disk (if it hasn't already been read in) andf -ills the template in. - -=cut - -sub fill_in_template{ - my %param = validate_with(params => \@_, - spec => {template => SCALAR, - variables => {type => HASHREF, - default => {}, - }, - language => {type => SCALAR, - default => 'en_US', - }, - output => {type => HANDLE, - optional => 1, - }, - hole_var => {type => HASHREF, - optional => 1, - }, - output_type => {type => SCALAR, - default => 'html', - }, - }, - ); - # Get the text - my $output_type = $param{output_type}; - my $language = $param{language}; - my $template = $param{template}; - $template .= '.tx' unless $template =~ /\.tx$/; - my $tt; - if (not exists $tt_templates{$output_type}{$language} or - not defined $tt_templates{$output_type}{$language} - ) { - $tt_templates{$output_type}{$language} = - Text::Xslate->new(# cache in template_cache or temp directory - cache_dir => $config{template_cache} // - File::Temp::tempdir(CLEANUP => 1), - # default to the language, but fallback to en_US - path => [$config{template_dir}.'/'.$language.'/', - $config{template_dir}.'/en_US/', - ], - suffix => '.tx', - ## use html or text specific functions - function => - ($output_type eq 'html' ? __text_xslate_functions() : - __text_xslate_functions_text()), - syntax => 'Kolon', - module => ['Text::Xslate::Bridge::Star', - 'Debbugs::Text::XslateBridge', - ], - type => $output_type, - ## use the html-specific pre_process_handler - $output_type eq 'html'? - (pre_process_handler => \&__html_template_prefilter):(), - ) - or die "Unable to create Text::Xslate"; - } - $tt = $tt_templates{$output_type}{$language}; - my $ret = - $tt->render($template, - {time => time, - %{$param{variables}//{}}, - config => \%config, - }); - if (exists $param{output}) { - print {$param{output}} $ret; - return ''; - } - return $ret; -} - -1; diff --git a/Debbugs/Text/XslateBridge.pm b/Debbugs/Text/XslateBridge.pm deleted file mode 100644 index 14652c2..0000000 --- a/Debbugs/Text/XslateBridge.pm +++ /dev/null @@ -1,51 +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::Text::XslateBridge; - -use warnings; -use strict; - -use base qw(Text::Xslate::Bridge); - -=head1 NAME - -Debbugs::Text::XslateBridge -- bridge for Xslate to add in useful functions - -=head1 DESCRIPTION - -This module provides bridge functionality to load functions into -Text::Xslate. It's loosely modeled after -Text::Xslate::Bridge::TT2Like, but with fewer functions. - -=head1 BUGS - -None known. - -=cut - - -use vars qw($VERSION); - -BEGIN { - $VERSION = 1.00; -} - -use Text::Xslate; - -__PACKAGE__-> - bridge(scalar => {length => \&__length, - }, - function => {length => \&__length,} - ); - -sub __length { - length $_[0]; -} - - -1; diff --git a/Debbugs/URI.pm b/Debbugs/URI.pm deleted file mode 100644 index d7cf4f2..0000000 --- a/Debbugs/URI.pm +++ /dev/null @@ -1,105 +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 2007 by Don Armstrong . -# query_form is -# Copyright 1995-2003 Gisle Aas. -# Copyright 1995 Martijn Koster. - - -package Debbugs::URI; - -=head1 NAME - -Debbugs::URI -- Derivative of URI which overrides the query_param - method to use ';' instead of '&' for separators. - -=head1 SYNOPSIS - -use Debbugs::URI; - -=head1 DESCRIPTION - -See L for more information. - -=head1 BUGS - -None known. - -=cut - -use warnings; -use strict; -use base qw(URI URI::_query); - -=head2 query_param - - $uri->query_form( $key1 => $val1, $key2 => $val2, ... ) - -Exactly like query_param in L except query elements are joined by -; instead of &. - -=cut - -{ - - package URI::_query; - - no warnings 'redefine'; - # Handle ...?foo=bar&bar=foo type of query - sub URI::_query::query_form { - my $self = shift; - my $old = $self->query; - if (@_) { - # Try to set query string - my @new = @_; - if (@new == 1) { - my $n = $new[0]; - if (ref($n) eq "ARRAY") { - @new = @$n; - } - elsif (ref($n) eq "HASH") { - @new = %$n; - } - } - my @query; - while (my($key,$vals) = splice(@new, 0, 2)) { - $key = '' unless defined $key; - $key =~ s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/g; - $key =~ s/ /+/g; - $vals = [ref($vals) eq "ARRAY" ? @$vals : $vals]; - for my $val (@$vals) { - $val = '' unless defined $val; - $val =~ s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/g; - $val =~ s/ /+/g; - push(@query, "$key=$val"); - } - } - # We've changed & to a ; here. - $self->query(@query ? join(';', @query) : undef); - } - return if !defined($old) || !length($old) || !defined(wantarray); - return unless $old =~ /=/; # not a form - map { s/\+/ /g; uri_unescape($_) } - # We've also changed the split here to split on ; as well as & - map { /=/ ? split(/=/, $_, 2) : ($_ => '')} split(/[&;]/, $old); - } -} - - - - - - -1; - - -__END__ - - - - - - diff --git a/Debbugs/UTF8.pm b/Debbugs/UTF8.pm deleted file mode 100644 index 01351f3..0000000 --- a/Debbugs/UTF8.pm +++ /dev/null @@ -1,226 +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 2013 by Don Armstrong . - -package Debbugs::UTF8; - -=head1 NAME - -Debbugs::UTF8 -- Routines for handling conversion of charsets to UTF8 - -=head1 SYNOPSIS - -use Debbugs::UTF8; - - -=head1 DESCRIPTION - -This module contains routines which convert from various different -charsets to UTF8. - -=head1 FUNCTIONS - -=cut - -use warnings; -use strict; -use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); -use Exporter qw(import); - -BEGIN{ - $VERSION = 1.00; - $DEBUG = 0 unless defined $DEBUG; - - %EXPORT_TAGS = (utf8 => [qw(encode_utf8_structure encode_utf8_safely), - qw(convert_to_utf8 decode_utf8_safely)], - ); - @EXPORT = (@{$EXPORT_TAGS{utf8}}); - @EXPORT_OK = (); - Exporter::export_ok_tags(keys %EXPORT_TAGS); - $EXPORT_TAGS{all} = [@EXPORT_OK]; -} - -use Carp; -$Carp::Verbose = 1; - -use Encode qw(encode_utf8 is_utf8 decode decode_utf8); -use Text::Iconv; -use Storable qw(dclone); - - -=head1 UTF-8 - -These functions are exported with the :utf8 tag - -=head2 encode_utf8_structure - - %newdata = encode_utf8_structure(%newdata); - -Takes a complex data structure and encodes any strings with is_utf8 -set into their constituent octets. - -=cut - -our $depth = 0; -sub encode_utf8_structure { - ++$depth; - my @ret; - for $_ (@_) { - if (ref($_) eq 'HASH') { - push @ret, {encode_utf8_structure(%{$depth == 1 ? dclone($_):$_})}; - } - elsif (ref($_) eq 'ARRAY') { - push @ret, [encode_utf8_structure(@{$depth == 1 ? dclone($_):$_})]; - } - elsif (ref($_)) { - # we don't know how to handle non hash or non arrays - push @ret,$_; - } - else { - push @ret,encode_utf8_safely($_); - } - } - --$depth; - return @ret; -} - -=head2 encode_utf8_safely - - $octets = encode_utf8_safely($string); - -Given a $string, returns the octet equivalent of $string if $string is -in perl's internal encoding; otherwise returns $string. - -Silently returns REFs without encoding them. [If you want to deeply -encode REFs, see encode_utf8_structure.] - -=cut - - -sub encode_utf8_safely{ - my @ret; - for my $r (@_) { - if (not ref($r) and is_utf8($r)) { - $r = encode_utf8($r); - } - push @ret,$r; - } - return wantarray ? @ret : (@_ > 1 ? @ret : $ret[0]); -} - -=head2 decode_utf8_safely - - $string = decode_utf8_safely($octets); - -Given $octets in UTF8, returns the perl-internal equivalent of $octets -if $octets does not have is_utf8 set; otherwise returns $octets. - -Silently returns REFs without encoding them. - -=cut - - -sub decode_utf8_safely{ - my @ret; - for my $r (@_) { - if (not ref($r) and not is_utf8($r)) { - $r = decode_utf8($r); - } - push @ret, $r; - } - return wantarray ? @ret : (@_ > 1 ? @ret : $ret[0]); -} - - - - -=head2 convert_to_utf8 - - $utf8 = convert_to_utf8("text","charset"); - -=cut - -sub convert_to_utf8 { - my ($data,$charset,$internal_call) = @_; - $internal_call //= 0; - if (is_utf8($data)) { - cluck("utf8 flag is set when calling convert_to_utf8"); - return $data; - } - $charset = uc($charset//'UTF-8'); - if ($charset eq 'RAW') { - croak("Charset must not be raw when calling convert_to_utf8"); - } - ## if the charset is unknown or unknown 8 bit, assume that it's UTF-8. - if ($charset =~ /unknown/i) { - $charset = 'UTF-8' - } - my $iconv_converter; - eval { - $iconv_converter = Text::Iconv->new($charset,"UTF-8") or - die "Unable to create converter for '$charset'"; - }; - if ($@) { - return undef if $internal_call; - warn $@; - # We weren't able to create the converter, so use Encode - # instead - return __fallback_convert_to_utf8($data,$charset); - } - my $converted_data = $iconv_converter->convert($data); - # if the conversion failed, retval will be undefined or perhaps - # -1. - my $retval = $iconv_converter->retval(); - if (not defined $retval or - $retval < 0 - ) { - # try iso8559-1 first - if (not $internal_call) { - my $call_back_data = convert_to_utf8($data,'ISO8859-1',1); - # if there's an à (0xC3), it's probably something - # horrible, and we shouldn't try to convert it. - if (defined $call_back_data and $call_back_data !~ /\x{C3}/) { - return $call_back_data; - } - } - # Fallback to encode, which will probably also fail. - return __fallback_convert_to_utf8($data,$charset); - } - return decode("UTF-8",$converted_data); -} - -# this returns data in perl's internal encoding -sub __fallback_convert_to_utf8 { - my ($data, $charset) = @_; - # raw data just gets returned (that's the charset WordDecorder - # uses when it doesn't know what to do) - return $data if $charset eq 'raw'; - if (not defined $charset and not is_utf8($data)) { - warn ("Undefined charset, and string '$data' is not in perl's internal encoding"); - return $data; - } - # lets assume everything that doesn't have a charset is utf8 - $charset //= 'utf8'; - ## if the charset is unknown, assume it's UTF-8 - if ($charset =~ /unknown/i) { - $charset = 'utf8'; - } - my $result; - eval { - $result = decode($charset,$data,0); - }; - if ($@) { - warn "Unable to decode charset; '$charset' and '$data': $@"; - return $data; - } - return $result; -} - - - -1; - -__END__ diff --git a/Debbugs/User.pm b/Debbugs/User.pm deleted file mode 100644 index 50a0965..0000000 --- a/Debbugs/User.pm +++ /dev/null @@ -1,452 +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. -# -# [Other people have contributed to this file; their copyrights should -# go here too.] -# Copyright 2004 by Anthony Towns -# Copyright 2008 by Don Armstrong - - -package Debbugs::User; - -=head1 NAME - -Debbugs::User -- User settings - -=head1 SYNOPSIS - -use Debbugs::User qw(is_valid_user read_usertags write_usertags); - -Debbugs::User::is_valid_user($userid); - -$u = Debbugs::User::open($userid); -$u = Debbugs::User::open(user => $userid, locked => 0); - -$u = Debbugs::User::open(user => $userid, locked => 1); -$u->write(); - -$u->{"tags"} -$u->{"categories"} -$u->{"is_locked"} -$u->{"name"} - - -read_usertags(\%ut, $userid); -write_usertags(\%ut, $userid); - -=head1 USERTAG FILE FORMAT - -Usertags are in a file which has (roughly) RFC822 format, with stanzas -separated by newlines. For example: - - Tag: search - Bugs: 73671, 392392 - - Value: priority - Bug-73671: 5 - Bug-73487: 2 - - Value: bugzilla - Bug-72341: http://bugzilla/2039471 - Bug-1022: http://bugzilla/230941 - - Category: normal - Cat1: status - Cat2: debbugs.tasks - - Category: debbugs.tasks - Hidden: yes - Cat1: debbugs.tasks - - Cat1Options: - tag=quick - tag=medium - tag=arch - tag=not-for-me - - -=head1 EXPORT TAGS - -=over - -=item :all -- all functions that can be exported - -=back - -=head1 FUNCTIONS - -=cut - -use warnings; -use strict; -use Fcntl ':flock'; -use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); -use Exporter qw(import); - -use Debbugs::Config qw(:config); -use List::AllUtils qw(min); - -use Carp; -use IO::File; - -BEGIN { - ($VERSION) = q$Revision: 1.4 $ =~ /^Revision:\s+([^\s+])/; - $DEBUG = 0 unless defined $DEBUG; - - @EXPORT = (); - @EXPORT_OK = qw(is_valid_user read_usertags write_usertags); - $EXPORT_TAGS{all} = [@EXPORT_OK]; -} - - -####################################################################### -# Helper functions - -sub is_valid_user { - my $u = shift; - return ($u =~ /^[a-zA-Z0-9._+-]+[@][a-z0-9-.]{4,}$/); -} - -=head2 usertag_file_from_email - - my $filename = usertag_file_from_email($email) - -Turns an email into the filename where the usertag can be located. - -=cut - -sub usertag_file_from_email { - my ($email) = @_; - my $email_length = length($email) % 7; - my $escaped_email = $email; - $escaped_email =~ s/([^0-9a-zA-Z_+.-])/sprintf("%%%02X", ord($1))/eg; - return "$config{usertag_dir}/$email_length/$escaped_email"; -} - - -####################################################################### -# The real deal - -sub get_user { - return Debbugs::User->new(@_); -} - -=head2 new - - my $user = Debbugs::User->new('foo@bar.com',$lock); - -Reads the user file associated with 'foo@bar.com' and returns a -Debbugs::User object. - -=cut - -sub new { - my $class = shift; - $class = ref($class) || $class; - my ($email,$need_lock) = @_; - $need_lock ||= 0; - - my $ut = {}; - my $self = {"tags" => $ut, - "categories" => {}, - "visible_cats" => [], - "unknown_stanzas" => [], - values => {}, - bug_tags => {}, - email => $email, - }; - bless $self, $class; - - $self->{filename} = usertag_file_from_email($self->{email}); - if (not -r $self->{filename}) { - return $self; - } - my $uf = IO::File->new($self->{filename},'r') - or die "Unable to open file $self->{filename} for reading: $!"; - if ($need_lock) { - flock($uf, LOCK_EX); - $self->{"locked"} = $uf; - } - - while(1) { - my @stanza = _read_stanza($uf); - last unless @stanza; - if ($stanza[0] eq "Tag") { - my %tag = @stanza; - my $t = $tag{"Tag"}; - $ut->{$t} = [] unless defined $ut->{$t}; - my @bugs = split /\s*,\s*/, $tag{Bugs}; - push @{$ut->{$t}}, @bugs; - for my $bug (@bugs) { - push @{$self->{bug_tags}{$bug}}, - $t; - } - } elsif ($stanza[0] eq "Category") { - my @cat = (); - my %stanza = @stanza; - my $catname = $stanza{"Category"}; - my $i = 0; - while (++$i && defined $stanza{"Cat${i}"}) { - if (defined $stanza{"Cat${i}Options"}) { - # parse into a hash - my %c = ("nam" => $stanza{"Cat${i}"}); - $c{"def"} = $stanza{"Cat${i}Default"} - if defined $stanza{"Cat${i}Default"}; - if (defined $stanza{"Cat${i}Order"}) { - my @temp = split /\s*,\s*/, $stanza{"Cat${i}Order"}; - my %temp; - my $min = min(@temp); - # Order to 0 minimum; strip duplicates - $c{ord} = [map {$temp{$_}++; - $temp{$_}>1?():($_-$min); - } @temp - ]; - } - my @pri; my @ttl; - for my $l (split /\n/, $stanza{"Cat${i}Options"}) { - if ($l =~ m/^\s*(\S+)\s+-\s+(.*\S)\s*$/) { - push @pri, $1; - push @ttl, $2; - } elsif ($l =~ m/^\s*(\S+)\s*$/) { - push @pri, $1; - push @ttl, $1; - } - } - $c{"ttl"} = [@ttl]; - $c{"pri"} = [@pri]; - push @cat, { %c }; - } else { - push @cat, $stanza{"Cat${i}"}; - } - } - $self->{"categories"}->{$catname} = [@cat]; - push @{$self->{"visible_cats"}}, $catname - unless ($stanza{"Hidden"} || "no") eq "yes"; - } - elsif ($stanza[0] eq 'Value') { - my ($value,$value_name,%bug_values) = @stanza; - while (my ($k,$v) = each %bug_values) { - my ($bug) = $k =~ m/^Bug-(\d+)/; - next unless defined $bug; - $self->{values}{$bug}{$value_name} = $v; - } - } - else { - push @{$self->{"unknown_stanzas"}}, [@stanza]; - } - } - - return $self; -} - -sub email { - my $self = shift; - return $self->{email}; -} - -sub tags { - my $self = shift; - - return $self->{"tags"}; -} - -sub tags_on_bug { - my $self = shift; - return map {@{$self->{"bug_tags"}{$_}//[]}} @_; -} - -sub has_bug_tags { - my $self = shift; - return keys %{$self->{bug_tags}} > 0; -} - -sub write { - my $self = shift; - - my $ut = $self->{"tags"}; - my $p = $self->{"filename"}; - - if (not defined $self->{filename} or not - length $self->{filename}) { - carp "Tried to write a usertag with no filename defined"; - return; - } - my $uf = IO::File->new($self->{filename},'w'); - if (not $uf) { - carp "Unable to open $self->{filename} for writing: $!"; - return; - } - - for my $us (@{$self->{"unknown_stanzas"}}) { - my @us = @{$us}; - while (my ($k,$v) = splice (@us,0,2)) { - $v =~ s/\n/\n /g; - print {$uf} "$k: $v\n"; - } - print {$uf} "\n"; - } - - for my $t (keys %{$ut}) { - next if @{$ut->{$t}} == 0; - print {$uf} "Tag: $t\n"; - print {$uf} _wrap_to_length("Bugs: " . join(", ", @{$ut->{$t}}), 77) . "\n"; - print $uf "\n"; - } - - my $uc = $self->{"categories"}; - my %vis = map { $_, 1 } @{$self->{"visible_cats"}}; - for my $c (keys %{$uc}) { - next if @{$uc->{$c}} == 0; - - print $uf "Category: $c\n"; - print $uf "Hidden: yes\n" unless defined $vis{$c}; - my $i = 0; - for my $cat (@{$uc->{$c}}) { - $i++; - if (ref($cat) eq "HASH") { - printf $uf "Cat%d: %s\n", $i, $cat->{"nam"}; - printf $uf "Cat%dOptions:\n", $i; - for my $j (0..$#{$cat->{"pri"}}) { - if (defined $cat->{"ttl"}->[$j]) { - printf $uf " %s - %s\n", - $cat->{"pri"}->[$j], $cat->{"ttl"}->[$j]; - } else { - printf $uf " %s\n", $cat->{"pri"}->[$j]; - } - } - printf $uf "Cat%dDefault: %s\n", $i, $cat->{"def"} - if defined $cat->{"def"}; - printf $uf "Cat%dOrder: %s\n", $i, join(", ", @{$cat->{"ord"}}) - if defined $cat->{"ord"}; - } else { - printf $uf "Cat%d: %s\n", $i, $cat; - } - } - print $uf "\n"; - } - # handle the value stanzas - my %value; - # invert the bug->value hash slightly - for my $bug (keys %{$self->{values}}) { - for my $value (keys %{$self->{values}{$bug}}) { - $value{$value}{$bug} = $self->{values}{$bug}{$value} - } - } - for my $value (keys %value) { - print {$uf} "Value: $value\n"; - for my $bug (keys %{$value{$value}}) { - my $bug_value = $value{$value}{$bug}; - $bug_value =~ s/\n/\n /g; - print {$uf} "Bug-$bug: $bug_value\n"; - } - print {$uf} "\n"; - } - - close($uf); - delete $self->{"locked"}; -} - -=head1 OBSOLETE FUNCTIONS - -=cut - -=head2 read_usertags - - read_usertags($usertags,$email) - - -=cut - -sub read_usertags { - my ($usertags,$email) = @_; - -# carp "read_usertags is deprecated"; - my $user = get_user($email); - for my $tag (keys %{$user->{"tags"}}) { - $usertags->{$tag} = [] unless defined $usertags->{$tag}; - push @{$usertags->{$tag}}, @{$user->{"tags"}->{$tag}}; - } - return $usertags; -} - -=head2 write_usertags - - write_usertags($usertags,$email); - -Gets a lock on the usertags, applies the usertags passed, and writes -them out. - -=cut - -sub write_usertags { - my ($usertags,$email) = @_; - -# carp "write_usertags is deprecated"; - my $user = Debbugs::User->new($email,1); # locked - $user->{"tags"} = { %{$usertags} }; - $user->write(); -} - - -=head1 PRIVATE FUNCTIONS - -=head2 _read_stanza - - my @stanza = _read_stanza($fh); - -Reads a single stanza from a filehandle and returns it - -=cut - -sub _read_stanza { - my ($file_handle) = @_; - my $field = 0; - my @res; - while (<$file_handle>) { - chomp; - last if (m/^$/); - if ($field && m/^ (.*)$/) { - $res[-1] .= "\n" . $1; - } elsif (m/^([^:]+):(\s+(.*))?$/) { - $field = $1; - push @res, ($1, $3||''); - } - } - return @res; -} - - -=head2 _wrap_to_length - - _wrap_to_length - -Wraps a line to a specific length by splitting at commas - -=cut - -sub _wrap_to_length { - my ($content,$line_length) = @_; - my $current_line_length = 0; - my $result = ""; - while ($content =~ m/^([^,]*,\s*)(.*)$/ || $content =~ m/^([^,]+)()$/) { - my $current_word = $1; - $content = $2; - if ($current_line_length != 0 and - $current_line_length + length($current_word) <= $line_length) { - $result .= "\n "; - $current_line_length = 1; - } - $result .= $current_word; - $current_line_length += length($current_word); - } - return $result . $content; -} - - - - -1; - -__END__ diff --git a/Debbugs/Version.pm b/Debbugs/Version.pm deleted file mode 100644 index 71dc008..0000000 --- a/Debbugs/Version.pm +++ /dev/null @@ -1,220 +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::Version; - -=head1 NAME - -Debbugs::Version -- OO interface to Version - -=head1 SYNOPSIS - -This package provides a convenient interface to refer to package versions and -potentially make calculations based upon them - - use Debbugs::Version; - my $v = Debbugs::Version->new(schema => $s,binaries => [qw(foo)],sources => [qw(bar)]); - -=head1 DESCRIPTION - - - -=cut - -use Mouse; -use v5.10; -use strictures 2; -use namespace::autoclean; - -use Debbugs::Config qw(:config); -use Debbugs::Collection::Package; -use Debbugs::OOTypes; -use Carp; - -extends 'Debbugs::OOBase'; - -=head1 Object Creation - -=head2 my $version = Debbugs::Version::Source->new(%params|$param) - -or Cnew(%params|$param)> for a binary version - -=over - -=item schema - -L schema which can be used to look up versions - -=item package - -String representation of the package - -=item pkg - -L which refers to the package given. - -Only one of C or C should be given - -=item package_collection - -L which is used to generate a L -object from the package name - -=back - -=cut - -around BUILDARGS => sub { - my $orig = shift; - my $class = shift; - if ($class eq __PACKAGE__) { - confess("You should not be instantiating Debbugs::Version. ". - "Use Debbugs::Version::Source or ::Binary"); - } - my %args; - if (@_==1 and ref($_[0]) eq 'HASH') { - %args = %{$_[0]}; - } else { - %args = @_; - } - return $class->$orig(%args); -}; - - - -state $strong_severities = - {map {($_,1)} @{$config{strong_severities}}}; - -=head1 Methods - -=head2 version - - $version->version - -Returns the source or binary package version - -=cut - -has version => (is => 'ro', isa => 'Str', - required => 1, - builder => '_build_version', - predicate => '_has_version', - ); - -=head2 type - -Returns 'source' if this is a source version, or 'binary' if this is a binary -version. - -=cut - -=head2 source_version - -Returns the source version for this version; if this is a source version, -returns itself. - -=cut - -=head2 src_pkg_ver - -Returns the fully qualified source_package/version string for this version. - -=cut - -=head2 package - -Returns the name of the package that this version is in - -=cut - -has package => (is => 'ro', - isa => 'Str', - builder => '_build_package', - predicate => '_has_package', - lazy => 1, - ); - -sub _build_package { - my $self = shift; - if ($self->_has_pkg) { - return $self->pkg->name; - } - return '(unknown)'; -} - -=head2 pkg - -Returns a L object corresponding to C. - -=cut - - -has pkg => (is => 'ro', - isa => 'Debbugs::Package', - lazy => 1, - builder => '_build_pkg', - reader => 'pkg', - predicate => '_has_pkg', - ); - -sub _build_pkg { - my $self = shift; - return Debbugs::Package->new(package => $self->package, - type => $self->type, - valid => 0, - package_collection => $self->package_collection, - $self->schema_argument, - ); -} - - -=head2 valid - -Returns 1 if this package is valid, 0 otherwise. - -=cut - -has valid => (is => 'ro', - isa => 'Bool', - reader => 'is_valid', - lazy => 1, - builder => '_build_valid', - ); - -sub _build_valid { - my $self = shift; - return 0; -} - - -=head2 package_collection - -Returns the L which is in use by this version -object. - -=cut - -has 'package_collection' => (is => 'ro', - isa => 'Debbugs::Collection::Package', - builder => '_build_package_collection', - lazy => 1, - ); -sub _build_package_collection { - my $self = shift; - return Debbugs::Collection::Package->new($self->schema_arg) -} - - -__PACKAGE__->meta->make_immutable; -no Mouse; -1; - - -__END__ -# Local Variables: -# indent-tabs-mode: nil -# cperl-indent-level: 4 -# End: diff --git a/Debbugs/Version/Binary.pm b/Debbugs/Version/Binary.pm deleted file mode 100644 index 25d7020..0000000 --- a/Debbugs/Version/Binary.pm +++ /dev/null @@ -1,97 +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::Version::Binary; - -=head1 NAME - -Debbugs::Version::Binary -- OO interface to Version - -=head1 SYNOPSIS - - use Debbugs::Version::Binary; - Debbugs::Version::Binary->new(schema => $s,binaries => [qw(foo)],sources => [qw(bar)]); - -=head1 DESCRIPTION - - - -=cut - -use Mouse; -use v5.10; -use strictures 2; -use namespace::autoclean; - -use Debbugs::Config qw(:config); -use Debbugs::Collection::Package; -use Debbugs::OOTypes; - -extends 'Debbugs::Version'; - -sub type { - return 'binary'; -} - -has source_version => (is => 'ro', - isa => 'Debbugs::Version::Source', - lazy => 1, - builder => '_build_source_version', - ); - -sub _build_source_version { - my $self = shift; - my $source_version = - $self->pkg-> - get_source_version(version => $self->version, - $self->_count_archs?(archs => [$self->_archs]):(), - ); - if (defined $source_version) { - return $source_version; - } - return Debbugs::Version::Source->new(version => $self->version, - package => '(unknown)', - valid => 0, - package_collection => $self->package_collection, - ); -} - -sub src_pkg_ver { - my $self = shift; - return $self->source->src_pkg_ver; -} - -has archs => (is => 'bare', - isa => 'ArrayRef[Str]', - builder => '_build_archs', - traits => ['Array'], - handles => {'_archs' => 'elements', - '_count_archs' => 'count', - }, - ); - -sub _build_archs { - my $self = shift; - # this is wrong, but we'll start like this for now - return ['any']; -} - -sub arch { - my $self = shift; - return $self->_count_archs > 0?join(',',$self->_archs):'any'; -} - - -__PACKAGE__->meta->make_immutable; -no Mouse; -1; - - -__END__ -# Local Variables: -# indent-tabs-mode: nil -# cperl-indent-level: 4 -# End: diff --git a/Debbugs/Version/Source.pm b/Debbugs/Version/Source.pm deleted file mode 100644 index a23959c..0000000 --- a/Debbugs/Version/Source.pm +++ /dev/null @@ -1,71 +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::Version::Source; - -=head1 NAME - -Debbugs::Version::Source -- OO interface to Version - -=head1 SYNOPSIS - - use Debbugs::Version::Source; - Debbugs::Version::Source->new(schema => $s,binaries => [qw(foo)],sources => [qw(bar)]); - -=head1 DESCRIPTION - - - -=cut - -use Mouse; -use v5.10; -use strictures 2; -use namespace::autoclean; - -use Debbugs::Config qw(:config); -use Debbugs::Collection::Package; -use Debbugs::OOTypes; - -extends 'Debbugs::Version'; - -sub type { - return 'source'; -} - -sub source_version { - return $_[0]; -} - -sub src_pkg_ver { - my $self = shift; - return $self->package.'/'.$self->version; -} - -has maintainer => (is => 'ro', - isa => 'Str', - ); - -sub source { - my $self = shift; - return $self->pkg; -} - -sub arch { - return 'source'; -} - - -__PACKAGE__->meta->make_immutable; -no Mouse; -1; - - -__END__ -# Local Variables: -# indent-tabs-mode: nil -# cperl-indent-level: 4 -# End: diff --git a/Debbugs/VersionTree.pm b/Debbugs/VersionTree.pm deleted file mode 100644 index 1231bd8..0000000 --- a/Debbugs/VersionTree.pm +++ /dev/null @@ -1,125 +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::VersionTree; - -=head1 NAME - -Debbugs::VersionTree -- OO interface to Debbugs::Versions - -=head1 SYNOPSIS - - use Debbugs::VersionTree; - my $vt = Debbugs::VersionTree->new(); - -=head1 DESCRIPTION - - - -=cut - -use Mouse; -use v5.10; -use strictures 2; -use namespace::autoclean; - -use Debbugs::Config qw(:config); -use Debbugs::Versions; -use Carp; - -extends 'Debbugs::OOBase'; - -has _versions => (is => 'bare', - isa => 'Debbugs::Versions', - default => sub {Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp)}, - handles => {_isancestor => 'isancestor', - _load => 'load', - _buggy => 'buggy', - _allstates => 'allstates', - }, - ); - -has loaded_src_pkg => (is => 'bare', - isa => 'HashRef[Bool]', - default => sub {{}}, - traits => ['Hash'], - handles => {src_pkg_loaded => 'exists', - _set_src_pkg_loaded => 'set', - }, - ); - -sub _srcify_version { - my @return; - for my $v (@_) { - if (ref($_)) { - push @return, - $v->source_version->src_pkg_ver; - } else { - push @return, - $v; - } - } - return @_ > 1?@return:$return[0]; -} - -sub isancestor { - my ($self,$ancestor,$descendant) = @_; - return $self->_isancestor(_srcify_version($ancestor), - _srcify_version($descendant), - ); -} - -sub buggy { - my $self = shift; - my ($version,$found,$fixed) = @_; - ($version) = _srcify_version($version); - $found = [_srcify_version(@{$found})]; - $fixed = [_srcify_version(@{$fixed})]; - return $self->_buggy($version,$found,$fixed); -} - -sub allstates { - my $self = shift; - my $found = shift; - my $fixed = shift; - my $interested = shift; - return $self->_allstates([_srcify_version(@{$found})], - [_srcify_version(@{$fixed})], - [_srcify_version(@{$interested})], - ); -} - -sub load { - my $self = shift; - for my $src_pkg (@_) { - my $is_valid = 0; - if (ref($src_pkg)) { - $is_valid = $src_pkg->valid; - $src_pkg = $src_pkg->name; - } - next if $self->src_pkg_loaded($src_pkg); - my $srchash = substr $src_pkg, 0, 1; - my $version_fh; - open($version_fh,'<',"$config{version_packages_dir}/$srchash/$src_pkg"); - if (not defined $version_fh) { - carp "No version file for package $src_pkg" if $is_valid; - next; - } - $self->_load($version_fh); - $self->_set_src_pkg_loaded($src_pkg,1); - } -} - -__PACKAGE__->meta->make_immutable; -no Mouse; -1; - - -__END__ -# Local Variables: -# indent-tabs-mode: nil -# cperl-indent-level: 4 -# End: diff --git a/Debbugs/Versions.pm b/Debbugs/Versions.pm deleted file mode 100644 index 5545b48..0000000 --- a/Debbugs/Versions.pm +++ /dev/null @@ -1,394 +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. -# -# [Other people have contributed to this file; their copyrights should -# go here too.] - -package Debbugs::Versions; - -use warnings; - -use strict; - -=head1 NAME - -Debbugs::Versions - debbugs version information processing - -=head1 DESCRIPTION - -The Debbugs::Versions module provides generic support functions for the -implementation of version tracking in debbugs. - -Complex organizations, such as Debian, require the tracking of bugs in -multiple versions of packages. The versioning scheme is frequently branched: -for example, a security update announced by an upstream developer will be -packaged as-is for the unstable distribution while a minimal backport is -made to the stable distribution. In order to report properly on the bugs -open in each distribution, debbugs must be aware of the structure of the -version tree for each package. - -Gathering the version data is beyond the scope of this module: in the case -of Debian it is carried out by mechanical analysis of package changelogs. -Debbugs::Versions takes version data for a package generated by this or any -other means, merges it into a tree structure, and allows the user to perform -queries based on supplied data about the versions in which bugs have been -found and the versions in which they have been fixed. - -=head1 DATA FORMAT - -The data format looks like this (backslashes are not actually there, and -indicate continuation lines): - - 1.5.4 1.5.0 1.5-iwj.0.4 1.5-iwj.0.3 1.5-iwj.0.2 1.5-iwj.0.1 1.4.0 1.3.14 \ - 1.3.13 1.3.12 1.3.11 1.3.10 ... - 1.4.1.6 1.4.1.5 1.4.1.4 1.4.1.3 1.4.1.2 1.4.1.1 1.4.1 1.4.0.31 1.4.0.30 \ - 1.4.0.29 1.4.0.28 1.4.0.27 1.4.0.26.0.1 1.4.0.26 1.4.0.25 1.4.0.24 \ - 1.4.0.23.2 1.4.0.23.1 1.4.0.23 1.4.0.22 1.4.0.21 1.4.0.20 1.4.0.19 \ - 1.4.0.18 1.4.0.17 1.4.0.16 1.4.0.15 1.4.0.14 1.4.0.13 1.4.0.12 \ - 1.4.0.11 1.4.0.10 1.4.0.9 1.4.0.8 1.4.0.7 1.4.0.6 1.4.0.5 1.4.0.4 \ - 1.4.0.3 1.4.0.2 1.4.0.1 1.4.0 \ - 1.4.0.35 1.4.0.34 1.4.0.33 1.4.0.32 1.4.0.31 - -=head1 METHODS - -=over 8 - -=item new - -Constructs a Debbugs::Versions object. The argument is a reference to a -version comparison function, which must be usable by Perl's built-in C -function. - -=cut - -sub new -{ - my $this = shift; - my $class = ref($this) || $this; - my $vercmp = shift; - my $self = { parent => {}, vercmp => $vercmp }; - return bless $self, $class; -} - -=item isancestor - -Takes two arguments, C and C. Returns true if and only -if C is a version on which C is based according to the -version data supplied to this object. (As a degenerate case, this relation -is reflexive: a version is considered to be an ancestor of itself.) - -This method is expected mainly to be used internally by the C method. - -=cut - -sub isancestor -{ - my $self = shift; - my $ancestor = shift; - my $descendant = shift; - - my $parent = $self->{parent}; - for (my $node = $descendant; defined $node; $node = $parent->{$node}) { - return 1 if $node eq $ancestor; - } - - return 0; -} - -=item leaves - -Find the leaves of the version tree, i.e. those versions with no -descendants. - -This method is mainly for internal use. - -=cut - -sub leaves -{ - my $self = shift; - - my $parent = $self->{parent}; - my @vers = keys %$parent; - my %leaf; - @leaf{@vers} = (1) x @vers; - for my $v (@vers) { - delete $leaf{$parent->{$v}} if defined $parent->{$v}; - } - return keys %leaf; -} - -=item merge - -Merges one branch of version data into this object. This branch takes the -form of a list of versions, each of which is to be considered as based on -the next in the list. - -=cut - -sub merge -{ - my $self = shift; - return unless @_; - my $last = $_[0]; - for my $i (1 .. $#_) { - # Detect loops. - next if $self->isancestor($last, $_[$i]); - - # If it's already an ancestor version, don't add it again. This - # keeps the tree correct when we get several partial branches, such - # as '1.4.0 1.3.14 1.3.13 1.3.12' followed by '1.4.0 1.3.12 1.3.10'. - unless ($self->isancestor($_[$i], $last)) { - $self->{parent}{$last} = $_[$i]; - } - - $last = $_[$i]; - } - # Insert undef for the last version so that we can tell a known version - # by seeing if it exists in $self->{parent}. - $self->{parent}{$_[$#_]} = undef unless exists $self->{parent}{$_[$#_]}; -} - -=item load - -Loads version data from the filehandle passed as the argument. Each line of -input is expected to represent one branch, with versions separated by -whitespace. - -=cut - -sub load -{ - my $self = shift; - my $fh = shift; - local $_; - while (<$fh>) { - $self->merge(split); - } -} - -=item save - -Outputs the version tree represented by this object to the filehandle passed -as the argument. The format is the same as that expected by the C -method. - -=cut - -sub save -{ - my $self = shift; - my $fh = shift; - local $_; - my $parent = $self->{parent}; - - # TODO: breaks with tcp-wrappers/1.0-1 tcpd/2.0-1 case - my @leaves = reverse sort { - my ($x, $y) = ($a, $b); - $x =~ s{.*/}{}; - $y =~ s{.*/}{}; - $self->{vercmp}->($x, $y); - } $self->leaves(); - - my %seen; - for my $lf (@leaves) { - print $fh $lf; - $seen{$lf} = 1; - for (my $node = $parent->{$lf}; defined $node; - $node = $parent->{$node}) { - print $fh " $node"; - last if exists $seen{$node}; - $seen{$node} = 1; - } - print $fh "\n"; - } -} - -=item buggy - -Takes three arguments, C, C, and C. Returns true if -and only if C is based on or equal to a version in the list -referenced by C, and not based on or equal to one referenced by -C. - -C attempts to cope with found and fixed versions not in the version -tree by simply checking whether any fixed versions are recorded in the event -that nothing is known about any of the found versions. - -=cut - -sub buggy -{ - my $self = shift; - my $version = shift; - my $found = shift; - my $fixed = shift; - - my %found = map { $_ => 1 } @$found; - my %fixed = map { $_ => 1 } @$fixed; - my $parent = $self->{parent}; - for (my $node = $version; defined $node; $node = $parent->{$node}) { - # The found and fixed tests are this way round because the most - # likely scenario is that somebody thought they'd fixed a bug and - # then it was reopened because it turned out not to have been fixed - # after all. However, tools that build found and fixed lists should - # generally know the order of events and make sure that the two - # lists have no common entries. - return 'found' if $found{$node}; - return 'fixed' if $fixed{$node}; - } - - unless (@$found) { - # We don't know when it was found. Was it fixed in a descendant of - # this version? If so, this one should be considered buggy. - for my $f (@$fixed) { - for (my $node = $f; defined $node; $node = $parent->{$node}) { - return 'found' if $node eq $version; - } - } - } - - # Nothing in the requested version's ancestor chain can be confirmed as - # a version in which the bug was found or fixed. If it was only found or - # fixed on some other branch, then this one isn't buggy. - for my $f (@$found, @$fixed) { - return 'absent' if exists $parent->{$f}; - } - - # Otherwise, we degenerate to checking whether any fixed versions at all - # are recorded. - return 'fixed' if @$fixed; - return 'found'; -} - -=item allstates - -Takes two arguments, C and C, which are interpreted as in -L. Efficiently returns the state of the bug at every known version, -in the form of a hash from versions to states (as returned by L). If -you pass a third argument, C, this method will stop after -determining the state of the bug at all the versions listed therein. - -Whether this is faster than calling L for each version you're -interested in is not altogether clear, and depends rather strongly on the -number of known and interested versions. - -=cut - -sub allstates -{ - my $self = shift; - my $found = shift; - my $fixed = shift; - my $interested = shift; - - my %found = map { $_ => 1 } @$found; - my %fixed = map { $_ => 1 } @$fixed; - my %interested; - if (defined $interested) { - %interested = map { $_ => 1 } @$interested; - } - my $parent = $self->{parent}; - my @leaves = $self->leaves(); - - # Are any of the found or fixed versions known? We'll need this later. - my $known = 0; - for my $f (@$found, @$fixed) { - if (exists $parent->{$f}) { - $known = 1; - last; - } - } - - # Start at each leaf in turn, working our way up and remembering the - # list of versions in the branch. - my %state; - LEAF: for my $lf (@leaves) { - my @branch; - my $fixeddesc = 0; - - for (my $node = $lf; defined $node; $node = $parent->{$node}) { - # If we're about to start a new branch, check whether we know - # the state of every version in which we're interested. If so, - # we can stop now. - if (defined $interested and not @branch) { - my @remove; - for my $interest (keys %interested) { - if (exists $state{$interest}) { - push @remove, $interest; - } - } - delete @interested{@remove}; - last LEAF unless keys %interested; - } - - # We encounter a version whose state we already know. Record the - # branch with the same state as that version, and go on to the - # next leaf. - if (exists $state{$node}) { - $state{$_} = $state{$node} foreach @branch; - last; - } - - push @branch, $node; - - # We encounter a version in the found list. Record the branch as - # 'found', and start a new branch. - if ($found{$node}) { - $state{$_} = 'found' foreach @branch; - @branch = (); - } - - # We encounter a version in the fixed list. Record the branch as - # 'fixed', and start a new branch, remembering that we have a - # fixed descendant. - elsif ($fixed{$node}) { - $state{$_} = 'fixed' foreach @branch; - @branch = (); - $fixeddesc = 1; - } - - # We encounter a root. - elsif (not defined $parent->{$node}) { - # If the found list is empty and we have a fixed descendant, - # record the branch as 'found' (since they probably just - # forgot to report a version when opening the bug). - if (not @$found and $fixeddesc) { - $state{$_} = 'found' foreach @branch; - } - - # If any of the found or fixed versions are known, record - # the branch as 'absent' (since all the activity must have - # happened on some other branch). - elsif ($known) { - $state{$_} = 'absent' foreach @branch; - } - - # If there are any fixed versions at all (but they're - # unknown), then who knows, but we guess at recording the - # branch as 'fixed'. - elsif (@$fixed) { - $state{$_} = 'fixed' foreach @branch; - } - - # Otherwise, fall back to recording the branch as 'found'. - else { - $state{$_} = 'found' foreach @branch; - } - - # In any case, we're done. - last; - } - } - } - - return %state; -} - -=back - -=cut - -1; diff --git a/Debbugs/Versions/Dpkg.pm b/Debbugs/Versions/Dpkg.pm deleted file mode 100644 index aa9d937..0000000 --- a/Debbugs/Versions/Dpkg.pm +++ /dev/null @@ -1,162 +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 Colin Watson -# Copyright Ian Jackson -# Copyright 2007 by Don Armstrong . - - -package Debbugs::Versions::Dpkg; - -use strict; - -=head1 NAME - -Debbugs::Versions::Dpkg - pure-Perl dpkg-style version comparison - -=head1 DESCRIPTION - -The Debbugs::Versions::Dpkg module provides pure-Perl routines to compare -dpkg-style version numbers, as used in Debian packages. If you have the -libapt-pkg Perl bindings available (Debian package libapt-pkg-perl), they -may offer better performance. - -=head1 METHODS - -=over 8 - -=cut - -sub parseversion ($) -{ - my $ver = shift; - my %verhash; - if ($ver =~ /:/) - { - $ver =~ /^(\d+):(.+)/ or die "bad version number '$ver'"; - $verhash{epoch} = $1; - $ver = $2; - } - else - { - $verhash{epoch} = 0; - } - if ($ver =~ /(.+)-(.*)$/) - { - $verhash{version} = $1; - $verhash{revision} = $2; - } - else - { - $verhash{version} = $ver; - $verhash{revision} = 0; - } - return %verhash; -} - -# verrevcmp - -# This function is almost exactly equivalent -# to dpkg's verrevcmp function, including the -# order subroutine which it uses. - -sub verrevcmp($$) -{ - - sub order{ - my ($x) = @_; - ##define order(x) ((x) == '~' ? -1 \ - # : cisdigit((x)) ? 0 \ - # : !(x) ? 0 \ - # : cisalpha((x)) ? (x) \ - # : (x) + 256) - # This comparison is out of dpkg's order to avoid - # comparing things to undef and triggering warnings. - if (not defined $x or not length $x) { - return 0; - } - elsif ($x eq '~') { - return -1; - } - elsif ($x =~ /^\d$/) { - return 0; - } - elsif ($x =~ /^[A-Z]$/i) { - return ord($x); - } - else { - return ord($x) + 256; - } - } - - sub next_elem(\@){ - my $a = shift; - return @{$a} ? shift @{$a} : undef; - } - my ($val, $ref) = @_; - $val = "" if not defined $val; - $ref = "" if not defined $ref; - my @val = split //,$val; - my @ref = split //,$ref; - my $vc = next_elem @val; - my $rc = next_elem @ref; - while (defined $vc or defined $rc) { - my $first_diff = 0; - while ((defined $vc and $vc !~ /^\d$/) or - (defined $rc and $rc !~ /^\d$/)) { - my $vo = order($vc); my $ro = order($rc); - # Unlike dpkg's verrevcmp, we only return 1 or -1 here. - return (($vo - $ro > 0) ? 1 : -1) if $vo != $ro; - $vc = next_elem @val; $rc = next_elem @ref; - } - while (defined $vc and $vc eq '0') { - $vc = next_elem @val; - } - while (defined $rc and $rc eq '0') { - $rc = next_elem @ref; - } - while (defined $vc and $vc =~ /^\d$/ and - defined $rc and $rc =~ /^\d$/) { - $first_diff = ord($vc) - ord($rc) if !$first_diff; - $vc = next_elem @val; $rc = next_elem @ref; - } - return 1 if defined $vc and $vc =~ /^\d$/; - return -1 if defined $rc and $rc =~ /^\d$/; - return (($first_diff > 0) ? 1 : -1) if $first_diff; - } - return 0; -} - -=item vercmp - -Compare the two arguments as dpkg-style version numbers. Returns -1 if the -first argument represents a lower version number than the second, 1 if the -first argument represents a higher version number than the second, and 0 if -the two arguments represent equal version numbers. - -=cut - -sub vercmp ($$) -{ - my %version = parseversion $_[0]; - my %refversion = parseversion $_[1]; - return 1 if $version{epoch} > $refversion{epoch}; - return -1 if $version{epoch} < $refversion{epoch}; - my $r = verrevcmp($version{version}, $refversion{version}); - return $r if $r; - return verrevcmp($version{revision}, $refversion{revision}); -} - -=back - -=head1 AUTHOR - -Don Armstrong and Colin Watson -Ecjwatson@debian.orgE, based on the implementation in -C by Ian Jackson and others. - -=cut - -1; diff --git a/Mail/CrossAssassin.pm b/Mail/CrossAssassin.pm deleted file mode 100644 index b8c676f..0000000 --- a/Mail/CrossAssassin.pm +++ /dev/null @@ -1,98 +0,0 @@ -# CrossAssassin.pm 2004/04/12 blarson - -package Mail::CrossAssassin; - -use strict; -require Exporter; -our @ISA = qw(Exporter); -our @EXPORT = qw(ca_init ca_keys ca_set ca_score ca_expire); -our $VERSION = 0.1; - -use Digest::MD5 qw(md5_base64); -use DB_File; - -our %database; -our $init; -our $addrpat = '\b\d{3,8}(?:-(?:close|done|forwarded|maintonly|submitter|quiet))?\@bugs\.debian\.org'; - -sub ca_init(;$$) { - my $ap = shift; - $addrpat = $ap if(defined $ap); - my $dir = shift; - return if ($init && ! defined($dir)); - $dir = "$ENV{'HOME'}/.crosssassassin" unless (defined($dir)); - (mkdir $dir or die "Could not create \"$dir\"") unless (-d $dir); - untie %database; - tie %database, 'DB_File', "$dir/Crossdb" - or die "Could not initialize crosassasin database \"$dir/Crossdb\": $!"; - $init = 1; -} - -sub ca_keys($) { - my $body = shift; - my @keys; - my $m = join('',@$body); - $m =~ s/\n(?:\s*\n)+/\n/gm; - if (length($m) > 4000) { - my $m2 = $m; - $m2 =~ s/\S\S+/\*/gs; - push @keys, '0'.md5_base64($m2); - } -# $m =~ s/^--.*$/--/m; - $m =~ s/$addrpat/LOCAL\@ADDRESS/iogm; - push @keys, '1'.md5_base64($m); - return join(' ',@keys); -} - -sub ca_set($) { - my @keys = split(' ', $_[0]); - my $now = time; - my $score = 0; - my @scores; - foreach my $k (@keys) { - my ($count,$date) = split(' ',$database{$k}); - $count++; - $score = $count if ($count > $score); - $database{$k} = "$count $now"; - push @scores, $count; - } - return (wantarray ? @scores : $score); -} - -sub ca_score($) { - my @keys = split(' ', $_[0]); - my $score = 0; - my @scores; - my $i = 0; - foreach my $k (@keys) { - my ($count,$date) = split(' ',$database{$k}); - $score = $count if ($count > $score); - $i++; - push @scores, $count; - } - return (wantarray ? @scores : $score); -} - -sub ca_expire($) { - my $when = shift; - my @ret; - my $num = 0; - my $exp = 0; - while (my ($k, $v) = each %database) { - $num++; - my ($count, $date) = split(' ', $v); - if ($date <= $when) { - delete $database{$k}; - $exp++; - } - } - return ($num, $exp); -} - -END { - return unless($init); - untie %database; - undef($init); -} - -1; diff --git a/Makefile b/Makefile index a279aeb..b3e46a6 100644 --- a/Makefile +++ b/Makefile @@ -30,10 +30,10 @@ build: $(MAKE) -C html/logo test: - LC_ALL=$(UTF8_LOCALE) $(PERL) -MTest::Harness -I. -e 'runtests(glob(q(t/*.t)))' + LC_ALL=$(UTF8_LOCALE) $(PERL) -MTest::Harness -Ilib -e 'runtests(glob(q(t/*.t)))' test_%: t/%.t - LC_ALL=$(UTF8_LOCALE) $(PERL) -MTest::Harness -I. -e 'runtests(q($<))' + LC_ALL=$(UTF8_LOCALE) $(PERL) -MTest::Harness -Ilib -e 'runtests(q($<))' testcover: LC_ALL=$(UTF8_LOCALE) PERL5LIB=t/cover_lib/:. cover -test diff --git a/Makefile.PL b/Makefile.PL index 1593964..c1c8f92 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -3,7 +3,6 @@ use ExtUtils::MakeMaker; WriteMakefile(FIRST_MAKEFILE => 'Makefile.perl', - PMLIBDIRS => ['Debbugs','Mail'], EXE_FILES => ['bin/local-debbugs', 'bin/add_bug_to_estraier', ], diff --git a/lib/Debbugs/Bug.pm b/lib/Debbugs/Bug.pm new file mode 100644 index 0000000..21a26e3 --- /dev/null +++ b/lib/Debbugs/Bug.pm @@ -0,0 +1,678 @@ +# 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: diff --git a/lib/Debbugs/Bug/Status.pm b/lib/Debbugs/Bug/Status.pm new file mode 100644 index 0000000..9209485 --- /dev/null +++ b/lib/Debbugs/Bug/Status.pm @@ -0,0 +1,576 @@ +# 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: diff --git a/lib/Debbugs/Bug/Tag.pm b/lib/Debbugs/Bug/Tag.pm new file mode 100644 index 0000000..06dfb3f --- /dev/null +++ b/lib/Debbugs/Bug/Tag.pm @@ -0,0 +1,212 @@ +# 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::User; +use List::AllUtils qw(uniq); +use Debbugs::Config qw(:config); +use Carp qw(croak); + +state $valid_tags = + {map {($_,1)} @{$config{tags}}}; + +state $short_tags = + {%{$config{tags_single_letter}}}; + +extends 'Debbugs::OOBase'; + +around BUILDARGS => sub { + my $orig = shift; + my $class = shift; + if (@_ == 1 && !ref $_[0]) { + return $class->$orig(keywords => $_[0]); + } else { + return $class->$orig(@_); + } +}; + +sub BUILD { + my $self = shift; + my $args = shift; + if (exists $args->{keywords}) { + my @tags; + if (ref($args->{keywords})) { + @tags = @{$args->{keywords}} + } else { + @tags = split /[, ]/,$args->{keywords}; + } + return unless @tags; + $self->_set_tag(map {($_,1)} @tags); + delete $args->{keywords}; + } +} + +has tags => (is => 'ro', + isa => 'HashRef[Str]', + traits => ['Hash'], + lazy => 1, + reader => '_tags', + builder => '_build_tags', + handles => {has_tags => 'count', + _set_tag => 'set', + unset_tag => 'delete', + }, + ); +has usertags => (is => 'ro', + isa => 'HashRef[Str]', + lazy => 1, + traits => ['Hash'], + handles => {unset_usertag => 'delete', + has_usertags => 'count', + }, + reader => '_usertags', + builder => '_build_usertags', + ); + +sub has_any_tags { + my $self = shift; + return ($self->has_tags || $self->has_usertags); +} + +has bug => (is => 'ro', + isa => 'Debbugs::Bug', + required => 1, + ); + +has users => (is => 'ro', + isa => 'ArrayRef[Debbugs::User]', + default => sub {[]}, + ); + +sub _build_tags { + return {}; +} + +sub _build_usertags { + my $self = shift; + local $_; + my $t = {}; + my $id = $self->bug->id; + for my $user (@{$self->users}) { + for my $tag ($user->tags_on_bug($id)) { + $t->{$tag} = $user->email; + } + } + return $t; +} + +sub is_set { + return ($_[0]->tag_is_set($_[1]) or + $_[0]->usertag_is_set($_[1])); +} + +sub tag_is_set { + return exists $_[0]->_tags->{$_[1]} ? 1 : 0; +} + +sub usertag_is_set { + return exists $_[0]->_usertags->{$_[1]} ? 1 : 0; +} + +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 { + my $self = shift; + return $self->join_all(' '); +} + +sub join_all { + my $self = shift; + my $joiner = shift; + $joiner //= ', '; + return join($joiner,$self->all_tags); +} + +sub join_usertags { + my $self = shift; + my $joiner = shift; + $joiner //= ', '; + return join($joiner,$self->usertags); +} + +sub join_tags { + my $self = shift; + my $joiner = shift; + $joiner //= ', '; + return join($joiner,$self->tags); +} + +sub all_tags { + return uniq sort $_[0]->tags,$_[0]->usertags; +} + +sub tags { + return sort keys %{$_[0]->_tags} +} + +sub short_tags { + my $self = shift; + my @r; + for my $tag ($self->tags) { + next unless exists $short_tags->{$tag}; + push @r, + {long => $tag, + short => $short_tags->{$tag}, + }; + } + if (wantarray) { + return @r; + } else { + return [@r]; + } +} + +sub usertags { + return sort keys %{$_[0]->_usertags} +} + +no Mouse; +1; + + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/lib/Debbugs/Bugs.pm b/lib/Debbugs/Bugs.pm new file mode 100644 index 0000000..127e472 --- /dev/null +++ b/lib/Debbugs/Bugs.pm @@ -0,0 +1,959 @@ +# 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 2007 by Don Armstrong . + +package Debbugs::Bugs; + +=head1 NAME + +Debbugs::Bugs -- Bug selection routines for debbugs + +=head1 SYNOPSIS + +use Debbugs::Bugs qw(get_bugs); + + +=head1 DESCRIPTION + +This module is a replacement for all of the various methods of +selecting different types of bugs. + +It implements a single function, get_bugs, which defines the master +interface for selecting bugs. + +It attempts to use subsidiary functions to actually do the selection, +in the order specified in the configuration files. [Unless you're +insane, they should be in order from fastest (and often most +incomplete) to slowest (and most complete).] + +=head1 BUGS + +=head1 FUNCTIONS + +=cut + +use warnings; +use strict; +use feature 'state'; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use Exporter qw(import); + +BEGIN{ + $VERSION = 1.00; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (); + @EXPORT_OK = (qw(get_bugs count_bugs newest_bug bug_filter)); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + +use Debbugs::Config qw(:config); +use Params::Validate qw(validate_with :types); +use IO::File; +use Debbugs::Status qw(splitpackages get_bug_status); +use Debbugs::Packages qw(getsrcpkgs getpkgsrc); +use Debbugs::Common qw(getparsedaddrs package_maintainer getmaintainers make_list hash_slice); +use Fcntl qw(O_RDONLY); +use MLDBM qw(DB_File Storable); +use List::AllUtils qw(first max); +use Carp; + +=head2 get_bugs + + get_bugs() + +=head3 Parameters + +The following parameters can either be a single scalar or a reference +to an array. The parameters are ANDed together, and the elements of +arrayrefs are a parameter are ORed. Future versions of this may allow +for limited regular expressions, and/or more complex expressions. + +=over + +=item package -- name of the binary package + +=item src -- name of the source package + +=item maint -- address of the maintainer + +=item submitter -- address of the submitter + +=item severity -- severity of the bug + +=item status -- status of the bug + +=item tag -- bug tags + +=item owner -- owner of the bug + +=item correspondent -- address of someone who sent mail to the log + +=item affects -- bugs which affect this package + +=item dist -- distribution (I don't know about this one yet) + +=item bugs -- list of bugs to search within + +=item function -- see description below + +=back + +=head3 Special options + +The following options are special options used to modulate how the +searches are performed. + +=over + +=item archive -- whether to search archived bugs or normal bugs; +defaults to false. As a special case, if archive is 'both', but +archived and unarchived bugs are returned. + +=item usertags -- set of usertags and the bugs they are applied to + +=back + + +=head3 Subsidiary routines + +All subsidiary routines get passed exactly the same set of options as +get_bugs. If for some reason they are unable to handle the options +passed (for example, they don't have the right type of index for the +type of selection) they should die as early as possible. [Using +Params::Validate and/or die when files don't exist makes this fairly +trivial.] + +This function will then immediately move on to the next subroutine, +giving it the same arguments. + +=head3 function + +This option allows you to provide an arbitrary function which will be +given the information in the index.db file. This will be super, super +slow, so only do this if there's no other way to write the search. + +You'll be given a list (which you can turn into a hash) like the +following: + + (pkg => ['a','b'], # may be a scalar (most common) + bug => 1234, + status => 'pending', + submitter => 'boo@baz.com', + severity => 'serious', + tags => ['a','b','c'], # may be an empty arrayref + ) + +The function should return 1 if the bug should be included; 0 if the +bug should not. + +=cut + +state $_non_search_key_regex = qr/^(bugs|archive|usertags|schema)$/; + +my %_get_bugs_common_options = + (package => {type => SCALAR|ARRAYREF, + optional => 1, + }, + src => {type => SCALAR|ARRAYREF, + optional => 1, + }, + maint => {type => SCALAR|ARRAYREF, + optional => 1, + }, + submitter => {type => SCALAR|ARRAYREF, + optional => 1, + }, + severity => {type => SCALAR|ARRAYREF, + optional => 1, + }, + status => {type => SCALAR|ARRAYREF, + optional => 1, + }, + tag => {type => SCALAR|ARRAYREF, + optional => 1, + }, + owner => {type => SCALAR|ARRAYREF, + optional => 1, + }, + dist => {type => SCALAR|ARRAYREF, + optional => 1, + }, + correspondent => {type => SCALAR|ARRAYREF, + optional => 1, + }, + affects => {type => SCALAR|ARRAYREF, + optional => 1, + }, + function => {type => CODEREF, + optional => 1, + }, + bugs => {type => SCALAR|ARRAYREF, + optional => 1, + }, + archive => {type => BOOLEAN|SCALAR, + default => 0, + }, + usertags => {type => HASHREF, + optional => 1, + }, + newest => {type => SCALAR|ARRAYREF, + optional => 1, + }, + schema => {type => OBJECT, + optional => 1, + }, + ); + + +state $_get_bugs_options = {%_get_bugs_common_options}; +sub get_bugs{ + my %param = validate_with(params => \@_, + spec => $_get_bugs_options, + ); + + # Normalize options + my %options = %param; + my @bugs; + if ($options{archive} eq 'both') { + push @bugs, get_bugs(%options,archive=>0); + push @bugs, get_bugs(%options,archive=>1); + my %bugs; + @bugs{@bugs} = @bugs; + return keys %bugs; + } + # A configuration option will set an array that we'll use here instead. + for my $routine (qw(Debbugs::Bugs::get_bugs_by_db Debbugs::Bugs::get_bugs_by_idx Debbugs::Bugs::get_bugs_flatfile)) { + my ($package) = $routine =~ m/^(.+)\:\:/; + eval "use $package;"; + if ($@) { + # We output errors here because using an invalid function + # in the configuration file isn't something that should + # be done. + warn "use $package failed with $@"; + next; + } + @bugs = eval "${routine}(\%options)"; + if ($@) { + + # We don't output errors here, because failure here + # via die may be a perfectly normal thing. + print STDERR "$@" if $DEBUG; + next; + } + last; + } + # If no one succeeded, die + if ($@) { + die "$@"; + } + return @bugs; +} + +=head2 count_bugs + + count_bugs(function => sub {...}) + +Uses a subroutine to classify bugs into categories and return the +number of bugs which fall into those categories + +=cut + +sub count_bugs { + my %param = validate_with(params => \@_, + spec => {function => {type => CODEREF, + }, + archive => {type => BOOLEAN, + default => 0, + }, + }, + ); + my $flatfile; + if ($param{archive}) { + $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r') + or die "Unable to open $config{spool_dir}/index.archive for reading: $!"; + } + else { + $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r') + or die "Unable to open $config{spool_dir}/index.db for reading: $!"; + } + my %count = (); + while(<$flatfile>) { + if (m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*([^]]*)\s*\]\s+(\w+)\s+(.*)$/) { + my @x = $param{function}->(pkg => $1, + bug => $2, + status => $4, + submitter => $5, + severity => $6, + tags => $7, + ); + local $_; + $count{$_}++ foreach @x; + } + } + close $flatfile; + return %count; +} + +=head2 newest_bug + + my $bug = newest_bug(); + +Returns the bug number of the newest bug, which is nextnumber-1. + +=cut + +sub newest_bug { + my $nn_fh = IO::File->new("$config{spool_dir}/nextnumber",'r') + or die "Unable to open $config{spool_dir}nextnumber for reading: $!"; + local $/; + my $next_number = <$nn_fh>; + close $nn_fh; + chomp $next_number; + return $next_number-1; +} + +=head2 bug_filter + + bug_filter + +Allows filtering bugs on commonly used criteria + + + +=cut + +sub bug_filter { + my %param = validate_with(params => \@_, + spec => {bug => {type => ARRAYREF|SCALAR, + optional => 1, + }, + status => {type => HASHREF|ARRAYREF, + optional => 1, + }, + seen_merged => {type => HASHREF, + optional => 1, + }, + 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{repeat_merged} and + not $param{repeat_merged} and + not defined $param{seen_merged}) { + croak "repeat_merged false requires seen_merged to be passed"; + } + if (not exists $param{bug} and not exists $param{status}) { + croak "one of bug or status must be passed"; + } + + if (not exists $param{status}) { + my $location = getbuglocation($param{bug}, 'summary'); + return 0 if not defined $location or not length $location; + $param{status} = readbug( $param{bug}, $location ); + return 0 if not defined $param{status}; + } + + if (exists $param{include}) { + return 1 if (!__bug_matches($param{include}, $param{status})); + } + if (exists $param{exclude}) { + return 1 if (__bug_matches($param{exclude}, $param{status})); + } + if (exists $param{repeat_merged} and not $param{repeat_merged}) { + my @merged = sort {$a<=>$b} $param{bug}, split(/ /, $param{status}{mergedwith}); + return 1 if first {defined $_} @{$param{seen_merged}}{@merged}; + @{$param{seen_merged}}{@merged} = (1) x @merged; + } + my $daysold = int((time - $param{status}{date}) / 86400); # seconds to days + if (exists $param{min_days}) { + return 1 unless $param{min_days} <= $daysold; + } + if (exists $param{max_days}) { + return 1 unless $param{max_days} == -1 or + $param{max_days} >= $daysold; + } + return 0; +} + + +=head2 get_bugs_by_idx + +This routine uses the by-$index.idx indicies to try to speed up +searches. + + +=cut + + +state $_get_bugs_by_idx_options = + {hash_slice(%_get_bugs_common_options, + (qw(package submitter severity tag archive), + qw(owner src maint bugs correspondent), + qw(affects usertags newest)) + ) + }; +sub get_bugs_by_idx{ + my %param = validate_with(params => \@_, + spec => $_get_bugs_by_idx_options + ); + my %bugs = (); + + # If we're given an empty maint (unmaintained packages), we can't + # handle it, so bail out here + for my $maint (make_list(exists $param{maint}?$param{maint}:[])) { + if (defined $maint and $maint eq '') { + die "Can't handle empty maint (unmaintained packages) in get_bugs_by_idx"; + } + } + if ($param{newest}) { + my $newest_bug = newest_bug(); + my @bugs = ($newest_bug - max(make_list($param{newest})) + 1) .. $newest_bug; + $param{bugs} = [exists $param{bugs}?make_list($param{bugs}):(), + @bugs, + ]; + } + # We handle src packages, maint and maintenc by mapping to the + # appropriate binary packages, then removing all packages which + # don't match all queries + my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()} + qw(package src maint) + ); + if (exists $param{package} or + exists $param{src} or + exists $param{maint}) { + delete @param{qw(maint src)}; + $param{package} = [@packages]; + } + my $keys = grep {$_ !~ $_non_search_key_regex} keys(%param); + die "Need at least 1 key to search by" unless $keys; + my $arc = $param{archive} ? '-arc':''; + my %idx; + for my $key (grep {$_ !~ $_non_search_key_regex} keys %param) { + my $index = $key; + $index = 'submitter-email' if $key eq 'submitter'; + $index = "$config{spool_dir}/by-${index}${arc}.idx"; + tie(%idx, MLDBM => $index, O_RDONLY) + or die "Unable to open $index: $!"; + my %bug_matching = (); + for my $search (make_list($param{$key})) { + for my $bug (keys %{$idx{$search}||{}}) { + next if $bug_matching{$bug}; + # increment the number of searches that this bug matched + $bugs{$bug}++; + $bug_matching{$bug}=1; + } + if ($search ne lc($search)) { + for my $bug (keys %{$idx{lc($search)}||{}}) { + next if $bug_matching{$bug}; + # increment the number of searches that this bug matched + $bugs{$bug}++; + $bug_matching{$bug}=1; + } + } + } + if ($key eq 'tag' and exists $param{usertags}) { + for my $bug (make_list(grep {defined $_ } @{$param{usertags}}{make_list($param{tag})})) { + next if $bug_matching{$bug}; + $bugs{$bug}++; + $bug_matching{$bug}=1; + } + } + untie %idx or die 'Unable to untie %idx'; + } + if ($param{bugs}) { + $keys++; + for my $bug (make_list($param{bugs})) { + $bugs{$bug}++; + } + } + # Throw out results that do not match all of the search specifications + return map {$keys <= $bugs{$_}?($_):()} keys %bugs; +} + + +=head2 get_bugs_by_db + +This routine uses the database to try to speed up +searches. + + +=cut + +state $_get_bugs_by_db_options = + {hash_slice(%_get_bugs_common_options, + (qw(package submitter severity tag archive), + qw(owner src maint bugs correspondent), + qw(affects usertags newest)) + ), + schema => {type => OBJECT, + }, + }; +sub get_bugs_by_db{ + my %param = validate_with(params => \@_, + spec => $_get_bugs_by_db_options, + ); + my %bugs = (); + + my $s = $param{schema}; + my $keys = grep {$_ !~ $_non_search_key_regex} keys(%param); + die "Need at least 1 key to search by" unless $keys; + my $rs = $s->resultset('Bug'); + if (exists $param{severity}) { + $rs = $rs->search({'severity.severity' => + [make_list($param{severity})], + }, + {join => 'severity'}, + ); + } + for my $key (qw(owner submitter done)) { + if (exists $param{$key}) { + $rs = $rs->search({"${key}.addr" => + [make_list($param{$key})], + }, + {join => $key}, + ); + } + } + if (exists $param{newest}) { + $rs = + $rs->search({}, + {order_by => {-desc => 'me.creation'}, + rows => max(make_list($param{newest})), + }, + ); + } + if (exists $param{correspondent}) { + my $message_rs = + $s->resultset('Message')-> + search({'correspondent.addr' => + [make_list($param{correspondent})], + }, + {join => {message_correspondents => 'correspondent'}, + columns => ['id'], + group_by => ['me.id'], + }, + ); + $rs = $rs->search({'bug_messages.message' => + {-in => $message_rs->get_column('id')->as_query()}, + }, + {join => 'bug_messages', + }, + ); + } + if (exists $param{affects}) { + my @aff_list = make_list($param{affects}); + s/^src:// foreach @aff_list; + $rs = $rs->search({-or => {'bin_pkg.pkg' => + [@aff_list], + 'src_pkg.pkg' => + [@aff_list], + 'me.unknown_affects' => + [@aff_list] + }, + }, + {join => [{bug_affects_binpackages => 'bin_pkg'}, + {bug_affects_srcpackages => 'src_pkg'}, + ], + }, + ); + } + if (exists $param{package}) { + $rs = $rs->search({-or => {'bin_pkg.pkg' => + [make_list($param{package})], + 'me.unknown_packages' => + [make_list($param{package})]}, + }, + {join => {bug_binpackages => 'bin_pkg'}}); + } + if (exists $param{maint}) { + my @maint_list = + map {$_ eq '' ? undef : $_} + make_list($param{maint}); + my $bin_pkgs_rs = + $s->resultset('BinPkg')-> + search({'correspondent.addr' => [@maint_list]}, + {join => {bin_vers => + {src_ver => + {maintainer => 'correspondent'}}}, + columns => ['id'], + group_by => ['me.id'], + }, + ); + my $src_pkgs_rs = + $s->resultset('SrcPkg')-> + search({'correspondent.addr' => [@maint_list]}, + {join => {src_vers => + {maintainer => 'correspondent'}}, + columns => ['id'], + group_by => ['me.id'], + }, + ); + $rs = $rs->search({-or => {'bug_binpackages.bin_pkg' => + { -in => $bin_pkgs_rs->get_column('id')->as_query}, + 'bug_srcpackages.src_pkg' => + { -in => $src_pkgs_rs->get_column('id')->as_query}, + }, + }, + {join => ['bug_binpackages', + 'bug_srcpackages', + ]} + ); + } + if (exists $param{src}) { + # identify all of the srcpackages and binpackages that match first + my $src_pkgs_rs = + $s->resultset('SrcPkg')-> + search({'pkg' => [make_list($param{src})], + }, + { columns => ['id'], + group_by => ['me.id'], + }, + ); + my $bin_pkgs_rs = + $s->resultset('BinPkgSrcPkg')-> + search({'src_pkg.pkg' => [make_list($param{src})], + }, + {columns => ['bin_pkg'], + join => ['src_pkg'], + group_by => ['bin_pkg'], + }); + $rs = $rs->search({-or => {'bug_binpackages.bin_pkg' => + { -in => $bin_pkgs_rs->get_column('bin_pkg')->as_query}, + 'bug_srcpackages.src_pkg' => + { -in => $src_pkgs_rs->get_column('id')->as_query}, + 'me.unknown_packages' => + [make_list($param{src})], + }, + }, + {join => ['bug_binpackages', + 'bug_srcpackages', + ]} + ); + } + # tags are very odd, because we must handle usertags. + if (exists $param{tag}) { + # bugs from usertags which matter + my %bugs_matching_usertags; + for my $bug (make_list(grep {defined $_ } + @{$param{usertags}}{make_list($param{tag})})) { + $bugs_matching_usertags{$bug} = 1; + } + # we want all bugs which either match the tag name given in + # param, or have a usertag set which matches one of the tag + # names given in param. + $rs = $rs->search({-or => {map {('tag.tag' => $_)} + make_list($param{tag}), + map {('me.id' => $_)} + keys %bugs_matching_usertags + }, + }, + {join => {bug_tags => 'tag'}}); + } + if (exists $param{bugs}) { + $rs = $rs->search({-or => {map {('me.id' => $_)} + make_list($param{bugs})} + }); + } + # handle archive + if (defined $param{archive} and $param{archive} ne 'both') { + $rs = $rs->search({'me.archived' => $param{archive}}); + } + return $rs->get_column('id')->all(); +} + + +=head2 get_bugs_flatfile + +This is the fallback search routine. It should be able to complete all +searches. [Or at least, that's the idea.] + +=cut + +state $_get_bugs_flatfile_options = + {hash_slice(%_get_bugs_common_options, + map {$_ eq 'dist'?():($_)} keys %_get_bugs_common_options + ) + }; + +sub get_bugs_flatfile{ + my %param = validate_with(params => \@_, + spec => $_get_bugs_flatfile_options + ); + my $flatfile; + if ($param{newest}) { + my $newest_bug = newest_bug(); + my @bugs = ($newest_bug - max(make_list($param{newest})) + 1) .. $newest_bug; + $param{bugs} = [exists $param{bugs}?make_list($param{bugs}):(), + @bugs, + ]; + } + if ($param{archive}) { + $flatfile = IO::File->new("$config{spool_dir}/index.archive", 'r') + or die "Unable to open $config{spool_dir}/index.archive for reading: $!"; + } + else { + $flatfile = IO::File->new("$config{spool_dir}/index.db", 'r') + or die "Unable to open $config{spool_dir}/index.db for reading: $!"; + } + my %usertag_bugs; + if (exists $param{tag} and exists $param{usertags}) { + # This complex slice makes a hash with the bugs which have the + # usertags passed in $param{tag} set. + @usertag_bugs{make_list(@{$param{usertags}}{make_list($param{tag})}) + } = (1) x make_list(@{$param{usertags}}{make_list($param{tag})}); + } + my $unmaintained_packages = 0; + # unmaintained packages is a special case + my @maints = make_list(exists $param{maint}?$param{maint}:[]); + $param{maint} = []; + for my $maint (@maints) { + if (defined $maint and $maint eq '' and not $unmaintained_packages) { + $unmaintained_packages = 1; + our %maintainers = %{getmaintainers()}; + $param{function} = [(exists $param{function}? + (ref $param{function}?@{$param{function}}:$param{function}):()), + sub {my %d=@_; + foreach my $try (make_list($d{"pkg"})) { + next unless length $try; + ($try) = $try =~ m/^(?:src:)?(.+)/; + return 1 if not exists $maintainers{$try}; + } + return 0; + } + ]; + } + elsif (defined $maint and $maint ne '') { + push @{$param{maint}},$maint; + } + } + # We handle src packages, maint and maintenc by mapping to the + # appropriate binary packages, then removing all packages which + # don't match all queries + my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()} + qw(package src maint) + ); + if (exists $param{package} or + exists $param{src} or + exists $param{maint}) { + delete @param{qw(maint src)}; + $param{package} = [@packages] if @packages; + } + my $grep_bugs = 0; + my %bugs; + if (exists $param{bugs}) { + $bugs{$_} = 1 for make_list($param{bugs}); + $grep_bugs = 1; + } + # These queries have to be handled by get_bugs_by_idx + if (exists $param{owner} + or exists $param{correspondent} + or exists $param{affects}) { + $bugs{$_} = 1 for get_bugs_by_idx(map {exists $param{$_}?($_,$param{$_}):()} + qw(owner correspondent affects), + ); + $grep_bugs = 1; + } + my @bugs; + BUG: while (<$flatfile>) { + next unless m/^(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+\[\s*(.*)\s*\]\s+(\w+)\s+(.*)$/; + my ($pkg,$bug,$time,$status,$submitter,$severity,$tags) = ($1,$2,$3,$4,$5,$6,$7); + next if $grep_bugs and not exists $bugs{$bug}; + if (exists $param{package}) { + my @packages = splitpackages($pkg); + next unless grep { my $pkg_list = $_; + grep {$pkg_list eq $_} make_list($param{package}) + } @packages; + } + if (exists $param{src}) { + my @src_packages = map { getsrcpkgs($_)} make_list($param{src}); + my @packages = splitpackages($pkg); + next unless grep { my $pkg_list = $_; + grep {$pkg_list eq $_} @packages + } @src_packages; + } + if (exists $param{submitter}) { + my @p_addrs = map {lc($_->address)} + map {getparsedaddrs($_)} + make_list($param{submitter}); + my @f_addrs = map {$_->address} + getparsedaddrs($submitter||''); + next unless grep { my $f_addr = $_; + grep {$f_addr eq $_} @p_addrs + } @f_addrs; + } + next if exists $param{severity} and not grep {$severity eq $_} make_list($param{severity}); + next if exists $param{status} and not grep {$status eq $_} make_list($param{status}); + if (exists $param{tag}) { + my $bug_ok = 0; + # either a normal tag, or a usertag must be set + $bug_ok = 1 if exists $param{usertags} and $usertag_bugs{$bug}; + my @bug_tags = split ' ', $tags; + $bug_ok = 1 if grep {my $bug_tag = $_; + grep {$bug_tag eq $_} make_list($param{tag}); + } @bug_tags; + next unless $bug_ok; + } + # We do this last, because a function may be slow... + if (exists $param{function}) { + my @bug_tags = split ' ', $tags; + my @packages = splitpackages($pkg); + my $package = (@packages > 1)?\@packages:$packages[0]; + for my $function (make_list($param{function})) { + next BUG unless + $function->(pkg => $package, + bug => $bug, + status => $status, + submitter => $submitter, + severity => $severity, + tags => \@bug_tags, + ); + } + } + push @bugs, $bug; + } + return @bugs; +} + +=head1 PRIVATE FUNCTIONS + +=head2 __handle_pkg_src_and_maint + + my @packages = __handle_pkg_src_and_maint(map {exists $param{$_}?($_,$param{$_}):()} + qw(package src maint) + ); + +Turn package/src/maint into a list of packages + +=cut + +sub __handle_pkg_src_and_maint{ + my %param = validate_with(params => \@_, + spec => {package => {type => SCALAR|ARRAYREF, + optional => 1, + }, + src => {type => SCALAR|ARRAYREF, + optional => 1, + }, + maint => {type => SCALAR|ARRAYREF, + optional => 1, + }, + }, + allow_extra => 1, + ); + + my @packages; + @packages = make_list($param{package}) if exists $param{package}; + my $package_keys = @packages?1:0; + my %packages; + @packages{@packages} = (1) x @packages; + if (exists $param{src}) { + # We only want to increment the number of keys if there is + # something to match + my $key_inc = 0; + # in case there are binaries with the same name as the + # source + my %_temp_p = (); + for my $package ((map {getsrcpkgs($_)} make_list($param{src}))) { + $packages{$package}++ unless exists $_temp_p{$package}; + $_temp_p{$package} = 1; + $key_inc=1; + } + for my $package (make_list($param{src})) { + $packages{"src:$package"}++ unless exists $_temp_p{"src:$package"}; + $_temp_p{"src:$package"} = 1; + $key_inc=1; + # As a temporary hack, we will also include $param{src} + # in this list for packages passed which do not have a + # corresponding binary package + if (not exists getpkgsrc()->{$package}) { + $packages{$package}++ unless exists $_temp_p{$package}; + $_temp_p{$package} = 1; + } + } + $package_keys += $key_inc; + } + if (exists $param{maint}) { + my $key_inc = 0; + my %_temp_p = (); + for my $package (package_maintainer(maintainer=>$param{maint})) { + $packages{$package}++ unless exists $_temp_p{$package}; + $_temp_p{$package} = 1; + $key_inc = 1; + } + $package_keys += $key_inc; + } + return grep {$packages{$_} >= $package_keys} keys %packages; +} + +state $field_match = { + 'subject' => \&__contains_field_match, + 'tags' => sub { + my ($field, $values, $status) = @_; + my %values = map {$_=>1} @$values; + foreach my $t (split /\s+/, $status->{$field}) { + return 1 if (defined $values{$t}); + } + return 0; + }, + 'severity' => \&__exact_field_match, + 'pending' => \&__exact_field_match, + 'package' => \&__exact_field_match, + 'originator' => \&__contains_field_match, + 'forwarded' => \&__contains_field_match, + 'owner' => \&__contains_field_match, +}; + +sub __bug_matches { + my ($hash, $status) = @_; + foreach my $key( keys( %$hash ) ) { + my $value = $hash->{$key}; + next unless exists $field_match->{$key}; + my $sub = $field_match->{$key}; + if (not defined $sub) { + die "No defined subroutine for key: $key"; + } + return 1 if ($sub->($key, $value, $status)); + } + return 0; +} + +sub __exact_field_match { + my ($field, $values, $status) = @_; + my @values = @$values; + my @ret = grep {$_ eq $status->{$field} } @values; + $#ret != -1; +} + +sub __contains_field_match { + my ($field, $values, $status) = @_; + foreach my $data (@$values) { + return 1 if (index($status->{$field}, $data) > -1); + } + return 0; +} + + + + + +1; + +__END__ diff --git a/lib/Debbugs/CGI.pm b/lib/Debbugs/CGI.pm new file mode 100644 index 0000000..7dabb1e --- /dev/null +++ b/lib/Debbugs/CGI.pm @@ -0,0 +1,1014 @@ +# 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. +# +# [Other people have contributed to this file; their copyrights should +# go here too.] +# Copyright 2007 by Don Armstrong . + +package Debbugs::CGI; + +=head1 NAME + +Debbugs::CGI -- General routines for the cgi scripts + +=head1 SYNOPSIS + +use Debbugs::CGI qw(:url :html); + +=head1 DESCRIPTION + +This module is a replacement for parts of common.pl; subroutines in +common.pl will be gradually phased out and replaced with equivalent +(or better) functionality here. + +=head1 BUGS + +None known. + +=cut + +use warnings; +use strict; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use Exporter qw(import); + +use feature qw(state); + +our %URL_PARAMS = (); + +BEGIN{ + ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (url => [qw(bug_links bug_linklist maybelink), + qw(set_url_params version_url), + qw(submitterurl mainturl munge_url), + qw(package_links bug_links), + ], + html => [qw(html_escape htmlize_bugs htmlize_packagelinks), + qw(maybelink htmlize_addresslinks htmlize_maintlinks), + ], + util => [qw(cgi_parameters quitcgi), + ], + forms => [qw(option_form form_options_and_normal_param)], + usertags => [qw(add_user)], + misc => [qw(maint_decode)], + package_search => [qw(@package_search_key_order %package_search_keys)], + cache => [qw(calculate_etag etag_does_not_match)], + #status => [qw(getbugstatus)], + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + +use Debbugs::URI; +use URI::Escape; +use HTML::Entities; +use Debbugs::Common qw(getparsedaddrs make_list); +use Params::Validate qw(validate_with :types); + +use Debbugs::Config qw(:config); +use Debbugs::Status qw(splitpackages isstrongseverity); +use Debbugs::User qw(); + +use Mail::Address; +use POSIX qw(ceil); +use Storable qw(dclone); +use Scalar::Util qw(looks_like_number); + +use List::AllUtils qw(max); +use File::stat; +use Digest::MD5 qw(md5_hex); +use Carp; + +use Debbugs::Text qw(fill_in_template); + + + +=head2 set_url_params + + set_url_params($uri); + + +Sets the url params which will be used to generate urls. + +=cut + +sub set_url_params{ + if (@_ > 1) { + %URL_PARAMS = @_; + } + else { + my $url = Debbugs::URI->new($_[0]||''); + %URL_PARAMS = %{$url->query_form_hash}; + } +} + + +=head2 munge_url + + my $url = munge_url($url,%params_to_munge); + +Munges a url, replacing parameters with %params_to_munge as appropriate. + +=cut + +sub munge_url { + my $url = shift; + my %params = @_; + my $new_url = Debbugs::URI->new($url); + my @old_param = $new_url->query_form(); + my @new_param; + while (my ($key,$value) = splice @old_param,0,2) { + push @new_param,($key,$value) unless exists $params{$key}; + } + $new_url->query_form(@new_param, + map {($_,$params{$_})} + sort keys %params); + return $new_url->as_string; +} + + +=head2 version_url + + version_url(package => $package,found => $found,fixed => $fixed) + +Creates a link to the version cgi script + +=over + +=item package -- source package whose graph to display + +=item found -- arrayref of found versions + +=item fixed -- arrayref of fixed versions + +=item format -- optional image format override + +=item width -- optional width of graph + +=item height -- optional height of graph + +=item info -- display html info surrounding graph; defaults to 1 if +width and height are not passed. + +=item collapse -- whether to collapse the graph; defaults to 1 if +width and height are passed. + +=back + +=cut + +sub version_url{ + my %params = validate_with(params => \@_, + spec => {package => {type => SCALAR|ARRAYREF, + }, + found => {type => ARRAYREF, + default => [], + }, + fixed => {type => ARRAYREF, + default => [], + }, + format => {type => SCALAR, + optional => 1, + }, + width => {type => SCALAR, + optional => 1, + }, + height => {type => SCALAR, + optional => 1, + }, + absolute => {type => BOOLEAN, + default => 0, + }, + collapse => {type => BOOLEAN, + default => 1, + }, + info => {type => BOOLEAN, + optional => 1, + }, + } + ); + if (not defined $params{width} and not defined $params{height}) { + $params{info} = 1 if not exists $params{info}; + } + my $url = Debbugs::URI->new('version.cgi?'); + $url->query_form(%params); + return $url->as_string; +} + +=head2 html_escape + + html_escape($string) + +Escapes html entities by calling HTML::Entities::encode_entities; + +=cut + +sub html_escape{ + my ($string) = @_; + + return HTML::Entities::encode_entities($string,q(<>&"')); +} + +=head2 cgi_parameters + + cgi_parameters + +Returns all of the cgi_parameters from a CGI script using CGI::Simple + +=cut + +sub cgi_parameters { + my %options = validate_with(params => \@_, + spec => {query => {type => OBJECT, + can => 'param', + }, + single => {type => ARRAYREF, + default => [], + }, + default => {type => HASHREF, + default => {}, + }, + }, + ); + my $q = $options{query}; + my %single; + @single{@{$options{single}}} = (1) x @{$options{single}}; + my %param; + for my $paramname ($q->param) { + if ($single{$paramname}) { + $param{$paramname} = $q->param($paramname); + } + else { + $param{$paramname} = [$q->param($paramname)]; + } + } + for my $default (keys %{$options{default}}) { + if (not exists $param{$default}) { + # We'll clone the reference here to avoid surprises later. + $param{$default} = ref($options{default}{$default})? + dclone($options{default}{$default}):$options{default}{$default}; + } + } + return %param; +} + + +sub quitcgi { + my ($msg, $status) = @_; + $status //= '500 Internal Server Error'; + print "Status: $status\n"; + print "Content-Type: text/html\n\n"; + print fill_in_template(template=>'cgi/quit', + variables => {msg => $msg} + ); + exit 0; +} + + +=head1 HTML + +=head2 htmlize_packagelinks + + htmlize_packagelinks + +Given a scalar containing a list of packages separated by something +that L can separate, returns a +formatted set of links to packages in html. + +=cut + +sub htmlize_packagelinks { + my ($pkgs) = @_; + return '' unless defined $pkgs and $pkgs ne ''; + my @pkglist = splitpackages($pkgs); + + carp "htmlize_packagelinks is deprecated, use package_links instead"; + + return 'Package' . (@pkglist > 1 ? 's' : '') . ': ' . + package_links(package =>\@pkglist, + class => 'submitter' + ); +} + +=head2 package_links + + join(', ', package_links(packages => \@packages)) + +Given a list of packages, return a list of html which links to the package + +=over + +=item package -- arrayref or scalar of package(s) + +=item submitter -- arrayref or scalar of submitter(s) + +=item src -- arrayref or scalar of source(s) + +=item maintainer -- arrayref or scalar of maintainer(s) + +=item links_only -- return only links, not htmlized links, defaults to +returning htmlized links. + +=item class -- class of the a href, defaults to '' + +=back + +=cut + +our @package_search_key_order = (package => 'in package', + tag => 'tagged', + severity => 'with severity', + src => 'in source package', + maint => 'in packages maintained by', + submitter => 'submitted by', + owner => 'owned by', + status => 'with status', + affects => 'which affect package', + correspondent => 'with mail from', + newest => 'newest bugs', + bugs => 'in bug', + ); +our %package_search_keys = @package_search_key_order; +our %package_links_invalid_options = + map {($_,1)} (keys %package_search_keys, + qw(msg att)); + +sub package_links { + state $spec = + {(map { ($_,{type => SCALAR|ARRAYREF, + optional => 1, + }); + } keys %package_search_keys, + ## these are aliases for package + ## search keys + source => {type => SCALAR|ARRAYREF, + optional => 1, + }, + maintainer => {type => SCALAR|ARRAYREF, + optional => 1, + }, + ), + links_only => {type => BOOLEAN, + default => 0, + }, + class => {type => SCALAR, + default => '', + }, + separator => {type => SCALAR, + default => ', ', + }, + options => {type => HASHREF, + default => {}, + }, + }; + my %param = validate_with(params => \@_, + spec => $spec, + ); + my %options = %{$param{options}}; + for (grep {$package_links_invalid_options{$_}} keys %options) { + delete $options{$_}; + } + ## remove aliases for source and maintainer + if (exists $param{source}) { + $param{src} = [exists $param{src}?make_list($param{src}):(), + make_list($param{source}), + ]; + delete $param{source}; + } + if (exists $param{maintainer}) { + $param{maint} = [exists $param{maint}?make_list($param{maint}):(), + make_list($param{maintainer}), + ]; + delete $param{maintainer}; + } + my $has_options = keys %options; + my @links = (); + for my $type (qw(src package)) { + next unless exists $param{$type}; + for my $target (make_list($param{$type})) { + my $t_type = $type; + if ($target =~ s/^src://) { + $t_type = 'source'; + } elsif ($t_type eq 'source') { + $target = 'src:'.$target; + } + if ($has_options) { + push @links, + (munge_url('pkgreport.cgi?', + %options, + $t_type => $target, + ), + $target); + } else { + push @links, + ('pkgreport.cgi?'.$t_type.'='.uri_escape_utf8($target), + $target); + } + } + } + for my $type (qw(maint owner submitter correspondent)) { + next unless exists $param{$type}; + for my $target (make_list($param{$type})) { + if ($has_options) { + push @links, + (munge_url('pkgreport.cgi?', + %options, + $type => $target), + $target); + } else { + push @links, + ('pkgreport.cgi?'. + $type.'='.uri_escape_utf8($target), + $target); + } + } + } + my @return = (); + my ($link,$link_name); + my $class = ''; + if (length $param{class}) { + $class = q( class=").html_escape($param{class}).q("); + } + while (($link,$link_name) = splice(@links,0,2)) { + if ($param{links_only}) { + push @return,$link + } + else { + push @return, + qq(). + html_escape($link_name).q(); + } + } + if (wantarray) { + return @return; + } + else { + return join($param{separator},@return); + } +} + +=head2 bug_links + + join(', ', bug_links(bug => \@packages)) + +Given a list of bugs, return a list of html which links to the bugs + +=over + +=item bug -- arrayref or scalar of bug(s) + +=item links_only -- return only links, not htmlized links, defaults to +returning htmlized links. + +=item class -- class of the a href, defaults to '' + +=back + +=cut + +sub bug_links { + state $spec = {bug => {type => SCALAR|ARRAYREF, + optional => 1, + }, + links_only => {type => BOOLEAN, + default => 0, + }, + class => {type => SCALAR, + default => '', + }, + separator => {type => SCALAR, + default => ', ', + }, + options => {type => HASHREF, + default => {}, + }, + }; + my %param = validate_with(params => \@_, + spec => $spec, + ); + my %options = %{$param{options}}; + + for (qw(bug)) { + delete $options{$_} if exists $options{$_}; + } + my $has_options = keys %options; + my @links; + if ($has_options) { + push @links, map {(munge_url('bugreport.cgi?', + %options, + bug => $_, + ), + $_); + } make_list($param{bug}) if exists $param{bug}; + } else { + push @links, + map {my $b = ceil($_); + ('bugreport.cgi?bug='.$b, + $b)} + grep {looks_like_number($_)} + make_list($param{bug}) if exists $param{bug}; + } + my @return; + my ($link,$link_name); + my $class = ''; + if (length $param{class}) { + $class = q( class=").html_escape($param{class}).q("); + } + while (($link,$link_name) = splice(@links,0,2)) { + if ($param{links_only}) { + push @return,$link + } + else { + push @return, + qq(). + html_escape($link_name).q(); + } + } + if (wantarray) { + return @return; + } + else { + return join($param{separator},@return); + } +} + + + +=head2 maybelink + + maybelink($in); + maybelink('http://foobarbaz,http://bleh',qr/[, ]+/); + maybelink('http://foobarbaz,http://bleh',qr/[, ]+/,', '); + + +In the first form, links the link if it looks like a link. In the +second form, first splits based on the regex, then reassembles the +link, linking things that look like links. In the third form, rejoins +the split links with commas and spaces. + +=cut + +sub maybelink { + my ($links,$regex,$join) = @_; + if (not defined $regex and not defined $join) { + $links =~ s{(.*?)((?:(?:ftp|http|https)://[\S~-]+?/?)?)([\)\'\:\.\,]?(?:\s|\.<|$))} + {html_escape($1).(length $2?q().html_escape($2).q():'').html_escape($3)}geimo; + return $links; + } + $join = ' ' if not defined $join; + my @return; + my @segments; + if (defined $regex) { + @segments = split $regex, $links; + } + else { + @segments = ($links); + } + for my $in (@segments) { + if ($in =~ /^[a-zA-Z0-9+.-]+:/) { # RFC 1738 scheme + push @return, qq{} . html_escape($in) . ''; + } else { + push @return, html_escape($in); + } + } + return @return?join($join,@return):''; +} + + +=head2 htmlize_addresslinks + + htmlize_addresslinks($prefixfunc,$urlfunc,$addresses,$class); + + +Generate a comma-separated list of HTML links to each address given in +$addresses, which should be a comma-separated list of RFC822 +addresses. $urlfunc should be a reference to a function like mainturl +or submitterurl which returns the URL for each individual address. + + +=cut + +sub htmlize_addresslinks { + my ($prefixfunc, $urlfunc, $addresses,$class) = @_; + carp "htmlize_addresslinks is deprecated"; + + $class = defined $class?qq(class="$class" ):''; + if (defined $addresses and $addresses ne '') { + my @addrs = getparsedaddrs($addresses); + my $prefix = (ref $prefixfunc) ? + $prefixfunc->(scalar @addrs):$prefixfunc; + return $prefix . + join(', ', map + { sprintf qq(%s', + $urlfunc->($_->address), + html_escape($_->format) || + '(unknown)' + } @addrs + ); + } + else { + my $prefix = (ref $prefixfunc) ? + $prefixfunc->(1) : $prefixfunc; + return sprintf '%s(unknown)', + $prefix, $urlfunc->(''); + } +} + +sub emailfromrfc822{ + my $addr = getparsedaddrs($_[0] || ""); + $addr = defined $addr?$addr->address:''; + return $addr; +} + +sub mainturl { package_links(maintainer => $_[0], links_only => 1); } +sub submitterurl { package_links(submitter => $_[0], links_only => 1); } +sub htmlize_maintlinks { + my ($prefixfunc, $maints) = @_; + carp "htmlize_maintlinks is deprecated"; + return htmlize_addresslinks($prefixfunc, \&mainturl, $maints); +} + +=head2 bug_linklist + + bug_linklist($separator,$class,@bugs) + +Creates a set of links to C<@bugs> separated by C<$separator> with +link class C<$class>. + +XXX Use L; we want to be able to support query +arguments here too; we should be able to combine bug_links and this +function into one. + +=cut + + +sub bug_linklist{ + my ($sep,$class,@bugs) = @_; + carp "bug_linklist is deprecated; use bug_links instead"; + return scalar bug_links(bug=>\@bugs,class=>$class,separator=>$sep); +} + + +sub add_user { + my ($user,$usertags,$bug_usertags,$seen_users,$cats,$hidden) = @_; + $seen_users = {} if not defined $seen_users; + $bug_usertags = {} if not defined $bug_usertags; + $usertags = {} if not defined $usertags; + $cats = {} if not defined $cats; + $hidden = {} if not defined $hidden; + return if exists $seen_users->{$user}; + $seen_users->{$user} = 1; + + my $u = Debbugs::User::get_user($user); + + my %vis = map { $_, 1 } @{$u->{"visible_cats"}}; + for my $c (keys %{$u->{"categories"}}) { + $cats->{$c} = $u->{"categories"}->{$c}; + $hidden->{$c} = 1 unless defined $vis{$c}; + } + for my $t (keys %{$u->{"tags"}}) { + $usertags->{$t} = [] unless defined $usertags->{$t}; + push @{$usertags->{$t}}, @{$u->{"tags"}->{$t}}; + } + + %{$bug_usertags} = (); + for my $t (keys %{$usertags}) { + for my $b (@{$usertags->{$t}}) { + $bug_usertags->{$b} = [] unless defined $bug_usertags->{$b}; + push @{$bug_usertags->{$b}}, $t; + } + } +} + + + +=head1 Forms + +=cut + +=head2 form_options_and_normal_param + + my ($form_option,$param) = form_options_and_normal_param(\%param) + if $param{form_options}; + my $form_option = form_options_and_normal_param(\%param) + if $param{form_options}; + +Translates from special form_options to a set of parameters which can +be used to run the current page. + +The idea behind this is to allow complex forms to relatively easily +cause options that the existing cgi scripts understand to be set. + +Currently there are two commands which are understood: +combine, and concatenate. + +=head3 combine + +Combine works by entering key,value pairs into the parameters using +the key field option input field, and the value field option input +field. + +For example, you would have + + + +which would combine the _fo_searchkey and _fo_searchvalue input fields, so + + + + +would yield foo=>'bar' in %param. + +=head3 concatenate + +Concatenate concatenates values into a single entry in a parameter + +For example, you would have + + + +which would combine the _fo_searchkey and _fo_searchvalue input fields, so + + + + +would yield foo=>'bar:baz' in %param. + + +=cut + +my $form_option_leader = '_fo_'; +sub form_options_and_normal_param{ + my ($orig_param) = @_; + # all form_option parameters start with _fo_ + my ($param,$form_option) = ({},{}); + for my $key (keys %{$orig_param}) { + if ($key =~ /^\Q$form_option_leader\E/) { + $form_option->{$key} = $orig_param->{$key}; + } + else { + $param->{$key} = $orig_param->{$key}; + } + } + # at this point, we check for commands + COMMAND: for my $key (keys %{$form_option}) { + $key =~ s/^\Q$form_option_leader\E//; + if (my ($key_name,$value_name) = + $key =~ /combine_key(\Q$form_option_leader\E.+) + _value(\Q$form_option_leader\E.+)$/x + ) { + next unless defined $form_option->{$key_name}; + next unless defined $form_option->{$value_name}; + my @keys = make_list($form_option->{$key_name}); + my @values = make_list($form_option->{$value_name}); + for my $i (0 .. $#keys) { + last if $i > $#values; + next if not defined $keys[$i]; + next if not defined $values[$i]; + __add_to_param($param, + $keys[$i], + $values[$i], + ); + } + } + elsif (my ($field,$concatenate_key,$fields) = + $key =~ /concatenate_into_(.+?)((?:_with_[^_])?) + ((?:\Q$form_option_leader\E.+?)+) + $/x + ) { + if (length $concatenate_key) { + $concatenate_key =~ s/_with_//; + } + else { + $concatenate_key = ':'; + } + my @fields = $fields =~ m/(\Q$form_option_leader\E.+?)(?:(?=\Q$form_option_leader\E)|$)/g; + my %field_list; + my $max_num = 0; + for my $f (@fields) { + next COMMAND unless defined $form_option->{$f}; + $field_list{$f} = [make_list($form_option->{$f})]; + $max_num = max($max_num,$#{$field_list{$f}}); + } + for my $i (0 .. $max_num) { + next unless @fields == grep {$i <= $#{$field_list{$_}} and + defined $field_list{$_}[$i]} @fields; + __add_to_param($param, + $field, + join($concatenate_key, + map {$field_list{$_}[$i]} @fields + ) + ); + } + } + } + return wantarray?($form_option,$param):$form_option; +} + +=head2 option_form + + print option_form(template=>'pkgreport_options', + param => \%param, + form_options => $form_options, + ) + + + +=cut + +sub option_form{ + my %param = validate_with(params => \@_, + spec => {template => {type => SCALAR, + }, + variables => {type => HASHREF, + default => {}, + }, + language => {type => SCALAR, + optional => 1, + }, + param => {type => HASHREF, + default => {}, + }, + form_options => {type => HASHREF, + default => {}, + }, + }, + ); + + # First, we need to see if we need to add particular types of + # parameters + my $variables = dclone($param{variables}); + $variables->{param} = dclone($param{param}); + for my $key (keys %{$param{form_option}}) { + # strip out leader; shouldn't be anything here without one, + # but skip stupid things anyway + next unless $key =~ s/^\Q$form_option_leader\E//; + if ($key =~ /^add_(.+)$/) { + # this causes a specific parameter to be added + __add_to_param($variables->{param}, + $1, + '' + ); + } + elsif ($key =~ /^delete_(.+?)(?:_(\d+))?$/) { + next unless exists $variables->{param}{$1}; + if (ref $variables->{param}{$1} eq 'ARRAY' and + defined $2 and + defined $variables->{param}{$1}[$2] + ) { + splice @{$variables->{param}{$1}},$2,1; + } + else { + delete $variables->{param}{$1}; + } + } + # we'll add extra comands here once I figure out what they + # should be + } + # now at this point, we're ready to create the template + return Debbugs::Text::fill_in_template(template=>$param{template}, + (exists $param{language}?(language=>$param{language}):()), + variables => $variables, + hole_var => {'&html_escape' => \&html_escape, + }, + ); +} + +sub __add_to_param{ + my ($param,$key,@values) = @_; + + if (exists $param->{$key} and not + ref $param->{$key}) { + @{$param->{$key}} = [$param->{$key}, + @values + ]; + } + else { + push @{$param->{$key}}, @values; + } +} + + + +=head1 misc + +=cut + +=head2 maint_decode + + maint_decode + +Decodes the funky maintainer encoding. + +Don't ask me what in the world it does. + +=cut + +sub maint_decode { + my @input = @_; + return () unless @input; + my @output; + for my $input (@input) { + my $decoded = $input; + $decoded =~ s/-([^_]+)/-$1_-/g; + $decoded =~ s/_/-20_/g; + $decoded =~ s/^,(.*),(.*),([^,]+)$/$1-40_$2-20_-28_$3-29_/; + $decoded =~ s/^([^,]+),(.*),(.*),/$1-20_-3c_$2-40_$3-3e_/; + $decoded =~ s/\./-2e_/g; + $decoded =~ s/-([0-9a-f]{2})_/pack('H*',$1)/ge; + push @output,$decoded; + } + wantarray ? @output : $output[0]; +} + +=head1 cache + +=head2 calculate_etags + + calculate_etags(files => [qw(list of files)],additional_data => [qw(any additional data)]); + +=cut + +sub calculate_etags { + my %param = + validate_with(params => \@_, + spec => {files => {type => ARRAYREF, + default => [], + }, + additional_data => {type => ARRAYREF, + default => [], + }, + }, + ); + my @additional_data = @{$param{additional_data}}; + for my $file (@{$param{files}}) { + my $st = stat($file) or warn "Unable to stat $file: $!"; + push @additional_data,$st->mtime; + push @additional_data,$st->size; + } + return(md5_hex(join('',sort @additional_data))); +} + +=head2 etag_does_not_match + + etag_does_not_match(cgi=>$q,files=>[qw(list of files)], + additional_data=>[qw(any additional data)]) + + +Checks to see if the CGI request contains an etag which matches the calculated +etag. + +If there wasn't an etag given, or the etag given doesn't match, return the etag. + +If the etag does match, return 0. + +=cut + +sub etag_does_not_match { + my %param = + validate_with(params => \@_, + spec => {files => {type => ARRAYREF, + default => [], + }, + additional_data => {type => ARRAYREF, + default => [], + }, + cgi => {type => OBJECT}, + }, + ); + my $submitted_etag = + $param{cgi}->http('if-none-match'); + my $etag = + calculate_etags(files=>$param{files}, + additional_data=>$param{additional_data}); + if (not defined $submitted_etag or + length($submitted_etag) != 32 + or $etag ne $submitted_etag + ) { + return $etag; + } + if ($etag eq $submitted_etag) { + return 0; + } +} + + +1; + + +__END__ + + + + + + diff --git a/lib/Debbugs/CGI/Bugreport.pm b/lib/Debbugs/CGI/Bugreport.pm new file mode 100644 index 0000000..a606394 --- /dev/null +++ b/lib/Debbugs/CGI/Bugreport.pm @@ -0,0 +1,507 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version. See the +# file README and COPYING for more information. +# +# [Other people have contributed to this file; their copyrights should +# be listed here too.] +# Copyright 2008 by Don Armstrong . + + +package Debbugs::CGI::Bugreport; + +=head1 NAME + +Debbugs::CGI::Bugreport -- specific routines for the bugreport cgi script + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + + +=head1 BUGS + +None known. + +=cut + +use warnings; +use strict; +use utf8; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use Exporter qw(import); + +use IO::Scalar; +use Params::Validate qw(validate_with :types); +use Digest::MD5 qw(md5_hex); +use Debbugs::Mail qw(get_addresses :reply); +use Debbugs::MIME qw(decode_rfc1522 create_mime_message parse_to_mime_entity); +use Debbugs::CGI qw(:url :html :util); +use Debbugs::Common qw(globify_scalar english_join hash_slice); +use Debbugs::UTF8; +use Debbugs::Config qw(:config); +use Debbugs::Log qw(:read); +use POSIX qw(strftime); +use Encode qw(decode_utf8 encode_utf8); +use URI::Escape qw(uri_escape_utf8); +use Scalar::Util qw(blessed); +use List::AllUtils qw(sum); +use File::Temp; + +BEGIN{ + ($VERSION) = q$Revision: 494 $ =~ /^Revision:\s+([^\s+])/; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (); + @EXPORT_OK = (qw(display_entity handle_record handle_email_message)); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + + + +=head2 display_entity + + display_entity(entity => $entity, + bug_num => $ref, + outer => 1, + msg_num => $msg_num, + attachments => \@attachments, + output => \$output); + + +=over + +=item entity -- MIME::Parser entity + +=item bug_num -- Bug number + +=item outer -- Whether this is the outer entity; defaults to 1 + +=item msg_num -- message number in the log + +=item attachments -- arrayref of attachments + +=item output -- scalar reference for output + +=back + +=cut + +sub display_entity { + my %param = validate_with(params => \@_, + spec => {entity => {type => OBJECT, + }, + bug_num => {type => SCALAR, + regex => qr/^\d+$/, + }, + outer => {type => BOOLEAN, + default => 1, + }, + msg_num => {type => SCALAR, + }, + attachments => {type => ARRAYREF, + default => [], + }, + output => {type => SCALARREF|HANDLE, + default => \*STDOUT, + }, + terse => {type => BOOLEAN, + default => 0, + }, + msg => {type => SCALAR, + optional => 1, + }, + att => {type => SCALAR, + optional => 1, + }, + trim_headers => {type => BOOLEAN, + default => 1, + }, + avatars => {type => BOOLEAN, + default => 1, + }, + } + ); + + my $output = globify_scalar($param{output}); + my $entity = $param{entity}; + my $ref = $param{bug_num}; + my $xmessage = $param{msg_num}; + my $attachments = $param{attachments}; + + my $head = $entity->head; + my $disposition = $head->mime_attr('content-disposition'); + $disposition = 'inline' if not defined $disposition or $disposition eq ''; + my $type = $entity->effective_type; + my $filename = $entity->head->recommended_filename; + $filename = '' unless defined $filename; + $filename = decode_rfc1522($filename); + + if ($param{outer} and + not $param{terse} and + not exists $param{att}) { + print {$output} "
    \n"; + if ($param{trim_headers}) { + my @headers; + foreach (qw(From To Cc Subject Date)) { + my $head_field = $head->get($_); + next unless defined $head_field and $head_field ne ''; + chomp $head_field; + if ($_ eq 'From' and $param{avatars}) { + my $libravatar_url = __libravatar_url(decode_rfc1522($head_field)); + if (defined $libravatar_url and length $libravatar_url) { + push @headers,q(\n); + } + } + push @headers, qq(
    $_: ) . html_escape(decode_rfc1522($head_field))."
    \n"; + } + print {$output} join(qq(), @headers); + } else { + print {$output} "
    ".html_escape(decode_rfc1522($entity->head->stringify))."
    \n"; + } + print {$output} "
    \n"; + } + + if (not (($param{outer} and $type =~ m{^text(?:/plain)?(?:;|$)}) + or $type =~ m{^multipart/} + )) { + push @$attachments, $param{entity}; + # output this attachment + if (exists $param{att} and + $param{att} == $#$attachments) { + my $head = $entity->head; + chomp(my $type = $entity->effective_type); + my $body = $entity->stringify_body; + # this attachment has its own content type, so we must not + # try to convert it to UTF-8 or do anything funky. + binmode($output,':raw'); + print {$output} "Content-Type: $type"; + my ($charset) = $head->get('Content-Type:') =~ m/charset\s*=\s*\"?([\w-]+)\"?/i; + print {$output} qq(; charset="$charset") if defined $charset; + print {$output} "\n"; + if ($filename ne '') { + my $qf = $filename; + $qf =~ s/"/\\"/g; + $qf =~ s[.*/][]; + print {$output} qq{Content-Disposition: inline; filename="$qf"\n}; + } + print {$output} "\n"; + my $decoder = MIME::Decoder->new($head->mime_encoding); + $decoder->decode(IO::Scalar->new(\$body), $output); + # we don't reset the layers here, because it makes no + # sense to add anything to the output handle after this + # point. + return(1); + } + elsif (not exists $param{att}) { + my @dlargs = (msg=>$xmessage, att=>$#$attachments); + push @dlargs, (filename=>$filename) if $filename ne ''; + my $printname = $filename; + $printname = 'Message part ' . ($#$attachments + 1) if $filename eq ''; + print {$output} '
    [$printname } .
+				  "($type, $disposition)]
    \n"; + } + } + + return 0 if not $param{outer} and $disposition eq 'attachment' and not exists $param{att}; + return 0 unless (($type =~ m[^text/?] and + $type !~ m[^text/(?:html|enriched)(?:;|$)]) or + $type =~ m[^application/pgp(?:;|$)] or + $entity->parts); + + if ($entity->is_multipart) { + my @parts = $entity->parts; + foreach my $part (@parts) { + my $raw_output = + display_entity(entity => $part, + bug_num => $ref, + outer => 0, + msg_num => $xmessage, + output => $output, + attachments => $attachments, + terse => $param{terse}, + hash_slice(%param,qw(msg att avatars)), + ); + if ($raw_output) { + return $raw_output; + } + # print {$output} "\n"; + } + } elsif ($entity->parts) { + # We must be dealing with a nested message. + if (not exists $param{att}) { + print {$output} "
    \n"; + } + my @parts = $entity->parts; + foreach my $part (@parts) { + display_entity(entity => $part, + bug_num => $ref, + outer => 1, + msg_num => $xmessage, + output => $output, + attachments => $attachments, + terse => $param{terse}, + hash_slice(%param,qw(msg att avatars)), + ); + # print {$output} "\n"; + } + if (not exists $param{att}) { + print {$output} "
    \n"; + } + } elsif (not $param{terse}) { + my $content_type = $entity->head->get('Content-Type:') || "text/html"; + my ($charset) = $content_type =~ m/charset\s*=\s*\"?([\w-]+)\"?/i; + my $body = $entity->bodyhandle->as_string; + $body = convert_to_utf8($body,$charset//'utf8'); + $body = html_escape($body); + my $css_class = "message"; + # Attempt to deal with format=flowed + if ($content_type =~ m/format\s*=\s*\"?flowed\"?/i) { + $body =~ s{^\ }{}mgo; + # we ignore the other things that you can do with + # flowed e-mails cause they don't really matter. + $css_class .= " flowed"; + } + + # if the message is composed entirely of lines which are separated by + # newlines, wrap it. [Allow the signature to have special formatting.] + if ($body =~ /^([^\n]+\n\n)*[^\n]*\n?(-- \n.+)*$/s or + # if the first 20 lines in the message which have any non-space + # characters are larger than 100 characters more often than they + # are not, then use CSS to try to impose sensible wrapping + sum(0,map {length ($_) > 100?1:-1} grep {/\S/} split /\n/,$body,20) > 0 + ) { + $css_class .= " wrapping"; + } + # Add links to URLs + # We don't html escape here because we escape above; + # wierd terminators are because of that + $body =~ s{((?:ftp|http|https|svn|ftps|rsync)://[\S~-]+?/?) # Url + ((?:\>\;)?[)]?(?:'|\&\#39\;|\"\;)?[:.\,]?(?:\s|$)) # terminators + }{$1$2}gox; + # Add links to bug closures + $body =~ s[((?:closes|see):\s* # start of closed/referenced bugs + (?:bug)?\#?\s?\d+\s? # first bug + (?:,?\s*(?:bug)?\#?\s?\d+)* # additional bugs + (?:\s|\n|\)|\]|\}|\.|\,|$)) # ends with a space, newline, end of string, or ); fixes #747267 + ] + [my $temp = $1; + $temp =~ s{(\d+)} + {bug_links(bug=>$1)}ge; + $temp;]gxie; + if (defined $config{cve_tracker} and + length $config{cve_tracker} + ) { + # Add links to CVE vulnerabilities (closes #568464) + $body =~ s{(^|\s|[\(\[])(CVE-\d{4}-\d{4,})(\s|[,.-\[\]\)]|$)} + {$1$2$3}gxm; + } + if (not exists $param{att}) { + print {$output} qq(
    $body
    \n); + } + } + return 0; +} + + +=head2 handle_email_message + + handle_email_message($record->{text}, + ref => $bug_number, + msg_num => $msg_number, + ); + +Returns a decoded e-mail message and displays entities/attachments as +appropriate. + + +=cut + +sub handle_email_message{ + my ($record,%param) = @_; + + my $output; + my $output_fh = globify_scalar(\$output); + my $entity; + my $tempdir; + if (not blessed $record) { + $entity = parse_to_mime_entity($record); + } else { + $entity = $record; + } + my @attachments = (); + my $raw_output = + display_entity(entity => $entity, + bug_num => $param{ref}, + outer => 1, + msg_num => $param{msg_num}, + output => $output_fh, + attachments => \@attachments, + terse => $param{terse}, + hash_slice(%param,qw(msg att trim_headers avatars), + ), + ); + return $raw_output?$output:decode_utf8($output); +} + +=head2 handle_record + + push @log, handle_record($record,$ref,$msg_num); + +Deals with a record in a bug log as returned by +L; returns the log information that +should be output to the browser. + +=cut + +sub handle_record{ + my ($record,$bug_number,$msg_number,$seen_msg_ids,%param) = @_; + + # output needs to have the is_utf8 flag on to avoid double + # encoding + my $output = decode_utf8(''); + local $_ = $record->{type}; + if (/html/) { + # $record->{text} is not in perl's internal encoding; convert it + my $text = decode_rfc1522(decode_utf8(record_text($record))); + my ($time) = $text =~ //; + my $class = $text =~ /^(?:Acknowledgement|Information|Report|Notification)/m ? 'infmessage':'msgreceived'; + $output .= $text; + # Link to forwarded http:// urls in the midst of the report + # (even though these links already exist at the top) + $output =~ s,((?:ftp|http|https)://[\S~-]+?/?)((?:[\)\'\:\.\,]|\&\#39;|\"\;)? + (?:\s|\.<|$)),$1$2,gxo; + # Add links to the cloned bugs + $output =~ s{(Bug )(\d+)( cloned as bugs? )(\d+)(?:\-(\d+)|)}{$1.bug_links(bug=>$2).$3.bug_links(bug=>(defined $5)?[$4..$5]:$4)}eo; + # Add links to merged bugs + $output =~ s{(?<=Merged )([\d\s]+)(?=[\.<])}{join(' ',map {bug_links(bug=>$_)} (split /\s+/, $1))}eo; + # Add links to blocked bugs + $output =~ s{(?<=Blocking bugs)(?:( of )(\d+))?( (?:added|set to|removed):\s+)([\d\s\,]+)} + {(defined $2?$1.bug_links(bug=>$2):'').$3. + english_join([map {bug_links(bug=>$_)} (split /\,?\s+/, $4)])}eo; + $output =~ s{((?:[Aa]dded|[Rr]emoved)\ blocking\ bug(?:\(s\))?)(?:(\ of\ )(\d+))?(:?\s+) + (\d+(?:,\s+\d+)*(?:\,?\s+and\s+\d+)?)} + {$1.(defined $3?$2.bug_links(bug=>$3):'').$4. + english_join([map {bug_links(bug=>$_)} (split /\,?\s+(?:and\s+)?/, $5)])}xeo; + $output =~ s{([Aa]dded|[Rr]emoved)( indication that bug )(\d+)( blocks ?)([\d\s\,]+)} + {$1.$2.(bug_links(bug=>$3)).$4. + english_join([map {bug_links(bug=>$_)} (split /\,?\s+(?:and\s+)?/, $5)])}eo; + # Add links to reassigned packages + $output =~ s{($config{bug}\sreassigned\sfrom\spackage\s(?:[\`']|\&\#39;))([^']+?)((?:'|\&\#39;|\"\;) + \sto\s(?:[\`']|\&\#39;|\"\;))([^']+?)((?:'|\&\#39;|\"\;))} + {$1.package_links(package=>$2).$3. + package_links(package=>$4).$5}exo; + if (defined $time) { + $output .= ' ('.strftime('%a, %d %b %Y %T GMT',gmtime($time)).') '; + } + $output .= qq{(full text, mbox, '. + qq{link).

    }; + + $output = qq(

    \n\n) . $output . "

    \n"; + } + elsif (/recips/) { + my ($msg_id) = record_regex($record,qr/^Message-Id:\s+<(.+)>/i); + if (defined $msg_id and exists $$seen_msg_ids{$msg_id}) { + return (); + } + elsif (defined $msg_id) { + $$seen_msg_ids{$msg_id} = 1; + } + return () if defined $param{spam} and $param{spam}->is_spam($msg_id); + $output .= qq(

    🔗\n); + $output .= 'View this message in rfc822 format

    '; + $output .= handle_email_message($record, + ref => $bug_number, + msg_num => $msg_number, + %param, + ); + } + elsif (/autocheck/) { + # Do nothing + } + elsif (/incoming-recv/) { + my ($msg_id) = record_regex($record,qr/^Message-Id:\s+<(.+)>/i); + if (defined $msg_id and exists $$seen_msg_ids{$msg_id}) { + return (); + } + elsif (defined $msg_id) { + $$seen_msg_ids{$msg_id} = 1; + } + return () if defined $param{spam} and $param{spam}->is_spam($msg_id); + # Incomming Mail Message + my ($received,$hostname) = record_regex($record,qr/Received: \(at (\S+)\) by (\S+)\;/o); + $output .= qq|

    Message #$msg_number received at |. + html_escape("$received\@$hostname") . + q| (full text'. + q|, mbox, '; + my $parser = MIME::Parser->new(); + + # this will be cleaned up once it goes out of scope + my $tempdir = File::Temp->newdir(); + $parser->output_under($tempdir->dirname()); + $parser->filer->ignore_filename(1); + my $entity; + if ($record->{inner_file}) { + $entity = $parser->parse($record->{fh}); + } else { + $entity = $parser->parse_data($record->{text}); + } + my $r_l = reply_headers($entity); + $output .= q(reply); + + $output .= ')'.":

    \n"; + $output .= handle_email_message($entity, + ref => $bug_number, + msg_num => $msg_number, + %param, + ); + } + else { + die "Unknown record type $_"; + } + return $output; +} + + +sub __libravatar_url { + my ($email) = @_; + if (not defined $config{libravatar_uri} or not length $config{libravatar_uri}) { + return undef; + } + ($email) = grep {/\@/} get_addresses($email); + return $config{libravatar_uri}.uri_escape_utf8($email.($config{libravatar_uri_options}//'')); +} + + +1; + + +__END__ +# Local Variables: +# cperl-indent-level: 4 +# indent-tabs-mode: nil +# End: diff --git a/lib/Debbugs/CGI/Pkgreport.pm b/lib/Debbugs/CGI/Pkgreport.pm new file mode 100644 index 0000000..e3dcc12 --- /dev/null +++ b/lib/Debbugs/CGI/Pkgreport.pm @@ -0,0 +1,654 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version. See the +# file README and COPYING for more information. +# +# [Other people have contributed to this file; their copyrights should +# be listed here too.] +# Copyright 2008 by Don Armstrong . + + +package Debbugs::CGI::Pkgreport; + +=head1 NAME + +Debbugs::CGI::Pkgreport -- specific routines for the pkgreport cgi script + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + + +=head1 BUGS + +None known. + +=cut + +use warnings; +use strict; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use Exporter qw(import); + +use IO::Scalar; +use Params::Validate qw(validate_with :types); + +use Debbugs::Collection::Bug; + +use Carp; +use List::AllUtils qw(apply); + +use Debbugs::Config qw(:config :globals); +use Debbugs::CGI qw(:url :html :util); +use Debbugs::Common qw(:misc :util :date); +use Debbugs::Status qw(:status); +use Debbugs::Bugs qw(bug_filter); +use Debbugs::Packages qw(:mapping); + +use Debbugs::Text qw(:templates); +use Encode qw(decode_utf8); + +use POSIX qw(strftime); + + +BEGIN{ + ($VERSION) = q$Revision: 494 $ =~ /^Revision:\s+([^\s+])/; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (html => [qw(short_bug_status_html pkg_htmlizebugs), + ], + misc => [qw(generate_package_info), + qw(determine_ordering), + ], + ); + @EXPORT_OK = (qw()); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + +=head2 generate_package_info + + generate_package_info($srcorbin,$package) + +Generates the informational bits for a package and returns it + +=cut + +sub generate_package_info{ + my %param = validate_with(params => \@_, + spec => {binary => {type => BOOLEAN, + default => 1, + }, + package => {type => SCALAR,#|ARRAYREF, + }, + options => {type => HASHREF, + }, + bugs => {type => ARRAYREF, + }, + schema => {type => OBJECT, + optional => 1, + }, + }, + ); + + my $output_scalar = ''; + my $output = globify_scalar(\$output_scalar); + + my $package = $param{package}; + + my %pkgsrc = %{getpkgsrc()}; + my $srcforpkg = $package; + if ($param{binary}) { + $srcforpkg = + binary_to_source(source_only => 1, + scalar_only => 1, + binary => $package, + hash_slice(%param,qw(schema)), + ); + } + + my $showpkg = html_escape($package); + my @maint = package_maintainer($param{binary}?'binary':'source', + $package, + hash_slice(%param,qw(schema)), + ); + if (@maint) { + print {$output} '

    '; + print {$output} (@maint > 1? "Maintainer for $showpkg is " + : "Maintainers for $showpkg are ") . + package_links(maintainer => \@maint); + print {$output} ".

    \n"; + } + else { + print {$output} "

    There is no maintainer for $showpkg. ". + "This means that this package no longer exists (or never existed). ". + "Please do not report new bugs against this package.

    \n"; + } + my @pkgs = source_to_binary(source => $srcforpkg, + hash_slice(%param,qw(schema)), + binary_only => 1, + # if there are distributions, only bother to + # show packages which are currently in a + # distribution. + @{$config{distributions}//[]} ? + (dist => [@{$config{distributions}}]) : (), + ) if defined $srcforpkg; + @pkgs = grep( !/^\Q$package\E$/, @pkgs ); + if ( @pkgs ) { + @pkgs = sort @pkgs; + if ($param{binary}) { + print {$output} "

    You may want to refer to the following packages that are part of the same source:\n"; + } + else { + print {$output} "

    You may want to refer to the following individual bug pages:\n"; + } + #push @pkgs, $src if ( $src && !grep(/^\Q$src\E$/, @pkgs) ); + print {$output} scalar package_links(package=>[@pkgs]); + print {$output} ".\n"; + } + my @references; + my $pseudodesc = getpseudodesc(); + if ($package and defined($pseudodesc) and exists($pseudodesc->{$package})) { + push @references, "to the ". + "list of other pseudo-packages"; + } + else { + if ($package and defined $config{package_pages} and length $config{package_pages}) { + push @references, sprintf "to the %s package page", + html_escape("$config{package_pages}/$package"), html_escape("$package"); + } + if (defined $config{package_tracking_domain} and + length $config{package_tracking_domain}) { + my $ptslink = $param{binary} ? $srcforpkg : $package; + # the pts only wants the source, and doesn't care about src: (#566089) + $ptslink =~ s/^src://; + push @references, q(to the Package Tracking System); + } + # Only output this if the source listing is non-trivial. + if ($param{binary} and $srcforpkg) { + push @references, + "to the source package ". + package_links(src=>$srcforpkg, + options => $param{options}) . + "'s bug page"; + } + } + if (@references) { + $references[$#references] = "or $references[$#references]" if @references > 1; + print {$output} "

    You might like to refer ", join(", ", @references), ".

    \n"; + } + if (@maint) { + print {$output} "

    If you find a bug not listed here, please\n"; + printf {$output} "report it.

    \n", + html_escape("$config{web_domain}/Reporting$config{html_suffix}"); + } + return decode_utf8($output_scalar); +} + + +=head2 short_bug_status_html + + print short_bug_status_html(status => read_bug(bug => 5), + options => \%param, + ); + +=over + +=item status -- status hashref as returned by read_bug + +=item options -- hashref of options to pass to package_links (defaults +to an empty hashref) + +=item bug_options -- hashref of options to pass to bug_links (default +to an empty hashref) + +=item snippet -- optional snippet of information about the bug to +display below + + +=back + + + +=cut + +sub short_bug_status_html { + my %param = validate_with(params => \@_, + spec => {bug => {type => OBJECT, + isa => 'Debbugs::Bug', + }, + }, + ); + + return fill_in_template(template => 'cgi/short_bug_status', + variables => {bug => $param{bug}, + isstrongseverity => \&Debbugs::Status::isstrongseverity, + html_escape => \&Debbugs::CGI::html_escape, + looks_like_number => \&Scalar::Util::looks_like_number, + }, + hole_var => {'&package_links' => \&Debbugs::CGI::package_links, + '&bug_links' => \&Debbugs::CGI::bug_links, + '&version_url' => \&Debbugs::CGI::version_url, + '&secs_to_english' => \&Debbugs::Common::secs_to_english, + '&strftime' => \&POSIX::strftime, + '&maybelink' => \&Debbugs::CGI::maybelink, + }, + ); +} + + +sub pkg_htmlizebugs { + my %param = validate_with(params => \@_, + spec => {bugs => {type => OBJECT, + }, + names => {type => ARRAYREF, + }, + title => {type => ARRAYREF, + }, + prior => {type => ARRAYREF, + }, + order => {type => ARRAYREF, + }, + ordering => {type => SCALAR, + }, + bugusertags => {type => HASHREF, + default => {}, + }, + bug_rev => {type => BOOLEAN, + default => 0, + }, + bug_order => {type => SCALAR, + }, + repeatmerged => {type => BOOLEAN, + default => 1, + }, + include => {type => ARRAYREF, + default => [], + }, + exclude => {type => ARRAYREF, + default => [], + }, + this => {type => SCALAR, + default => '', + }, + options => {type => HASHREF, + default => {}, + }, + dist => {type => SCALAR, + optional => 1, + }, + schema => {type => OBJECT, + optional => 1, + }, + } + ); + my $bugs = $param{bugs}; + my %count; + my $header = ''; + my $footer = "

    Summary

    \n"; + + if ($bugs->count == 0) { + return "

    No reports found!

    \n"; + } + + my %seenmerged; + + my %common = ( + 'show_list_header' => 1, + 'show_list_footer' => 1, + ); + + my %section = (); + # Make the include/exclude map + my %include; + my %exclude; + for my $include (make_list($param{include})) { + next unless defined $include; + my ($key,$value) = split /\s*:\s*/,$include,2; + unless (defined $value) { + $key = 'tags'; + $value = $include; + } + push @{$include{$key}}, split /\s*,\s*/, $value; + } + for my $exclude (make_list($param{exclude})) { + next unless defined $exclude; + my ($key,$value) = split /\s*:\s*/,$exclude,2; + unless (defined $value) { + $key = 'tags'; + $value = $exclude; + } + push @{$exclude{$key}}, split /\s*,\s*/, $value; + } + + my $sorter = sub {$_[0]->id <=> $_[1]->id}; + if ($param{bug_rev}) { + $sorter = sub {$_[1]->id <=> $_[0]->id} + } + elsif ($param{bug_order} eq 'age') { + $sorter = sub {$_[0]->modified->epoch <=> $_[1]->modified->epoch}; + } + elsif ($param{bug_order} eq 'agerev') { + $sorter = sub {$_[1]->modified->epoch <=> $_[0]->modified->epoch}; + } + my @status; + for my $bug ($bugs->sort($sorter)) { + next if + $bug->filter(repeat_merged => $param{repeatmerged}, + seen_merged => \%seenmerged, + (keys %include ? (include => \%include):()), + (keys %exclude ? (exclude => \%exclude):()), + ); + + my $html = "
  • "; ##%d: %s\n
    ", + $html .= short_bug_status_html(bug => $bug, + ) . "\n"; + push @status, [ $bug, $html ]; + } + # parse bug order indexes into subroutines + my @order_subs = + map { + my $a = $_; + [map {parse_order_statement_to_subroutine($_)} @{$a}]; + } @{$param{prior}}; + for my $entry (@status) { + my $key = ""; + for my $i (0..$#order_subs) { + my $v = get_bug_order_index($order_subs[$i], $entry->[0]); + $count{"g_${i}_${v}"}++; + $key .= "_$v"; + } + $section{$key} .= $entry->[1]; + $count{"_$key"}++; + } + + my $result = ""; + if ($param{ordering} eq "raw") { + $result .= "
      \n" . join("", map( { $_->[ 1 ] } @status ) ) . "
    \n"; + } + else { + $header .= "
    \n
      \n"; + my @keys_in_order = (""); + for my $o (@{$param{order}}) { + push @keys_in_order, "X"; + while ((my $k = shift @keys_in_order) ne "X") { + for my $k2 (@{$o}) { + $k2+=0; + push @keys_in_order, "${k}_${k2}"; + } + } + } + for my $order (@keys_in_order) { + next unless defined $section{$order}; + my @ttl = split /_/, $order; + shift @ttl; + my $title = $param{title}[0]->[$ttl[0]] . " bugs"; + if ($#ttl > 0) { + $title .= " -- "; + $title .= join("; ", grep {($_ || "") ne ""} + map { $param{title}[$_]->[$ttl[$_]] } 1..$#ttl); + } + $title = html_escape($title); + + my $count = $count{"_$order"}; + my $bugs = $count == 1 ? "bug" : "bugs"; + + $header .= "
    • $title ($count $bugs)
      • \n"; + if ($common{show_list_header}) { + my $count = $count{"_$order"}; + my $bugs = $count == 1 ? "bug" : "bugs"; + $result .= "

      $title ($count $bugs)

      \n"; + } + else { + $result .= "

      $title

      \n"; + } + $result .= "
      \n
        \n"; + $result .= "\n\n\n\n"; + $result .= $section{$order}; + $result .= "\n\n\n\n"; + $result .= "
      \n
      \n"; + } + $header .= "
    \n"; + + $footer .= "
    \n
      \n"; + for my $i (0..$#{$param{prior}}) { + my $local_result = ''; + foreach my $key ( @{$param{order}[$i]} ) { + my $count = $count{"g_${i}_$key"}; + next if !$count or !$param{title}[$i]->[$key]; + $local_result .= "
    • $count $param{title}[$i]->[$key]
      • \n"; + } + if ( $local_result ) { + $footer .= "
    • $param{names}[$i]
        \n$local_result
      • \n"; + } + } + $footer .= "
    \n
    \n"; + } + + $result = $header . $result if ( $common{show_list_header} ); + $result .= $footer if ( $common{show_list_footer} ); + return $result; +} + +sub parse_order_statement_to_subroutine { + my ($statement) = @_; + if (not defined $statement or not length $statement) { + return sub {return 1}; + } + croak "invalid statement '$statement'" unless + $statement =~ /^(?:(package|tag|pending|severity) # field + = # equals + ([^=|\&,\+]+(?:,[^=|\&,+])*) #value + (\+|,|$) # joiner or end + )+ # one or more of these statements + /x; + my @sub_bits; + while ($statement =~ /(?^|,|\+) # joiner + (?package|tag|pending|severity) # field + = # equals + (?[^=|\&,\+]+(?:,[^=|\&,\+])*) #value + /xg) { + my $field = $+{field}; + my $value = $+{value}; + my $joiner = $+{joiner} // ''; + my @vals = apply {quotemeta($_)} split /,/,$value; + if (length $joiner) { + if ($joiner eq '+') { + push @sub_bits, ' and '; + } + else { + push @sub_bits, ' or '; + } + } + my @vals_bits; + for my $val (@vals) { + if ($field =~ /package|severity/o) { + push @vals_bits, '$_[0]->status->'.$field. + ' eq q('.$val.')'; + } elsif ($field eq 'tag') { + push @vals_bits, '$_[0]->tags->is_set('. + 'q('.$val.'))'; + } elsif ($field eq 'pending') { + push @vals_bits, '$_[0]->'.$field. + ' eq q('.$val.')'; + } + } + push @sub_bits ,' ('.join(' or ',@vals_bits).') '; + } + # return a subroutine reference which determines whether an order statement + # matches this bug + my $sub = 'sub { return ('.join ("\n",@sub_bits).');};'; + my $subref = eval $sub; + if ($@) { + croak "Unable to generate subroutine: $@; $sub"; + } + return $subref; +} + +sub parse_order_statement_into_boolean { + my ($statement,$status,$tags) = @_; + + if (not defined $tags) { + $tags = {map { $_, 1 } split / /, $status->{"tags"} + } + if defined $status->{"tags"}; + + } + # replace all + with && + $statement =~ s/\+/&&/g; + # replace all , with || + $statement =~ s/,/||/g; + $statement =~ s{([^\&\|\=]+) # field + = + ([^\&\|\=]+) # value + }{ + my $ok = 0; + if ($1 eq 'tag') { + $ok = 1 if defined $tags->{$2}; + } else { + $ok = 1 if defined $status->{$1} and + $status->{$1} eq $2; + } + $ok; + }exg; + # check that the parsed statement is just valid boolean statements + if ($statement =~ /^([01\(\)\&\|]+)$/) { + return eval "$1"; + } else { + # this is an invalid boolean statement + return 0; + } +} + +sub get_bug_order_index { + my ($order,$bug) = @_; + my $pos = 0; + for my $el (@{$order}) { + if ($el->($bug)) { + return $pos; + } + $pos++; + } + return $pos; +} + +# sets: my @names; my @prior; my @title; my @order; + +sub determine_ordering { + my %param = validate_with(params => \@_, + spec => {cats => {type => HASHREF, + }, + param => {type => HASHREF, + }, + ordering => {type => SCALARREF, + }, + names => {type => ARRAYREF, + }, + pend_rev => {type => BOOLEAN, + default => 0, + }, + sev_rev => {type => BOOLEAN, + default => 0, + }, + prior => {type => ARRAYREF, + }, + title => {type => ARRAYREF, + }, + order => {type => ARRAYREF, + }, + }, + ); + $param{cats}{status}[0]{ord} = [ reverse @{$param{cats}{status}[0]{ord}} ] + if ($param{pend_rev}); + $param{cats}{severity}[0]{ord} = [ reverse @{$param{cats}{severity}[0]{ord}} ] + if ($param{sev_rev}); + + my $i; + if (defined $param{param}{"pri0"}) { + my @c = (); + $i = 0; + while (defined $param{param}{"pri$i"}) { + my $h = {}; + + my ($pri) = make_list($param{param}{"pri$i"}); + if ($pri =~ m/^([^:]*):(.*)$/) { + $h->{"nam"} = $1; # overridden later if necesary + $h->{"pri"} = [ map { "$1=$_" } (split /,/, $2) ]; + } + else { + $h->{"pri"} = [ split /,/, $pri ]; + } + + ($h->{"nam"}) = make_list($param{param}{"nam$i"}) + if (defined $param{param}{"nam$i"}); + $h->{"ord"} = [ map {split /\s*,\s*/} make_list($param{param}{"ord$i"}) ] + if (defined $param{param}{"ord$i"}); + $h->{"ttl"} = [ map {split /\s*,\s*/} make_list($param{param}{"ttl$i"}) ] + if (defined $param{param}{"ttl$i"}); + + push @c, $h; + $i++; + } + $param{cats}{"_"} = [@c]; + ${$param{ordering}} = "_"; + } + + ${$param{ordering}} = "normal" unless defined $param{cats}{${$param{ordering}}}; + + sub get_ordering { + my @res; + my $cats = shift; + my $o = shift; + for my $c (@{$cats->{$o}}) { + if (ref($c) eq "HASH") { + push @res, $c; + } + else { + push @res, get_ordering($cats, $c); + } + } + return @res; + } + my @cats = get_ordering($param{cats}, ${$param{ordering}}); + + sub toenglish { + my $expr = shift; + $expr =~ s/[+]/ and /g; + $expr =~ s/[a-z]+=//g; + return $expr; + } + + $i = 0; + for my $c (@cats) { + $i++; + push @{$param{prior}}, $c->{"pri"}; + push @{$param{names}}, ($c->{"nam"} || "Bug attribute #" . $i); + if (defined $c->{"ord"}) { + push @{$param{order}}, $c->{"ord"}; + } + else { + push @{$param{order}}, [ 0..$#{$param{prior}[-1]} ]; + } + my @t = @{ $c->{"ttl"} } if defined $c->{ttl}; + if (@t < $#{$param{prior}[-1]}) { + push @t, map { toenglish($param{prior}[-1][$_]) } @t..($#{$param{prior}[-1]}); + } + push @t, $c->{"def"} || ""; + push @{$param{title}}, [@t]; + } +} + + + + +1; + + +__END__ + + + + + + diff --git a/lib/Debbugs/Collection.pm b/lib/Debbugs/Collection.pm new file mode 100644 index 0000000..6e3d49d --- /dev/null +++ b/lib/Debbugs/Collection.pm @@ -0,0 +1,390 @@ +# 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 + +This base class is designed for holding collections of objects which can be +uniquely identified by a key and added/generated by that same key. + +=head1 DESCRIPTION + + + +=cut + +use Mouse; +use strictures 2; +use namespace::autoclean; +use List::AllUtils qw(pairmap); +use Carp qw(croak); + +extends 'Debbugs::OOBase'; + +=head1 METHODS + +=head2 Debbugs::Collection->new(%params|$params) + +Creates a new Debbugs::Collection object. + +Parameters: + +=over + +=item universe + +To avoid unnecessarily constructing new members, collections have a universe to +which existing members can be obtained from. By default the universe is this +collection. Generally, you should create exactly one universe for each +collection type. + +=item schema + +Optional Debbugs::Schema object + + +=back + +=head2 $collection->members() + +Returns list of members of this collection + +=head2 $collection->members_ref() + +Returns an ARRAYREF of members of this collection + +=head2 $collection->keys_of_members() + +Returns a list of the keys of all members of this collection + +=head2 $collection->member_key($member) + +Given a member, returns the key of that member + +=head2 $collection->exists($member_key) + +Returns true if a member with $member_key exists in the collection + +=head2 $collection->clone() + +Returns a clone of this collection with the same universe as this collection + +=head2 $collection->limit(@member_keys) + +Returns a new collection limited to the list of member keys passed. Will add new +members to the universe if they do not currently exist. + +=head2 $collection->add($member) + +Add a member to this collection + +=head2 $collection->add_by_key($member_key) + +Add a member to this collection by key + +=head2 $collection->combine($collection2) or $collection + $collection2 + +Combines the members of both collections together and returns the new collection + +=head2 $collection->get($member_key) + +Get member(s) by key, returning undef for keys which do not exist in the +collection + +=head2 $collection->get_or_add_by_key($member_key) + +Get or add a member by the member key. + +=head2 $collection->count() + +Return the number of members in this collection + +=head2 $collection->grep({$_ eq 5}) + +Return the members in this collection which satisfy the condition, setting $_ +locally to each member object + +=head2 $collection->join(', ') + +Returns the keys of the members of this collection joined + +=head2 $collection->apply({$_*2}) + +Return the list of applying BLOCK to each member; each member can return 0 or +more results + +=head2 $collection->map({$_*2}) + +Returns the list of applying BLOCK to each member; each member should return +exactly one result + +=head2 $collection->sort({$a <=> $b}) + +Return the list of members sorted by BLOCK + +=cut + +has 'members' => (is => 'bare', + isa => 'ArrayRef', + traits => ['Array'], + default => sub {[]}, + writer => '_set_members', + predicate => '_has_members', + handles => {_add => 'push', + members => 'elements', + count => 'count', + _get_member => 'get', + grep => 'grep', + map => 'map', + sort => 'sort', + }, + ); + +sub apply { + my $self = shift; + my $block = shift; + my @r; + for ($self->members) { + push @r,$block->(); + } + return @r; +} + +sub members_ref { + my $self = shift; + return [$self->members]; +} + +has 'member_hash' => (traits => ['Hash'], + is => 'bare', + # really a HashRef[Int], but type checking is too slow + isa => 'HashRef', + lazy => 1, + reader => '_member_hash', + builder => '_build_member_hash', + clearer => '_clear_member_hash', + predicate => '_has_member_hash', + writer => '_set_member_hash', + handles => {# _add_member_hash => 'set', + _member_key_exists => 'exists', + _get_member_hash => 'get', + }, + ); + +# because _add_member_hash needs to be fast, we are overriding the default set +# method which is very safe but slow, because it makes copies. +sub _add_member_hash { + my ($self,@kv) = @_; + pairmap { + defined($a) + or $self->meta-> + throw_error("Hash keys passed to _add_member_hash must be defined" ); + ($b eq int($b)) or + $self->meta-> + throw_error("Values passed to _add_member_hash must be integer"); + } @kv; + my @return; + while (my ($key, $value) = splice @kv, 0, 2 ) { + push @return, + $self->{member_hash}{$key} = $value + } + wantarray ? return @return: return $return[0]; +} + +=head2 $collection->universe + + +=cut + +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 clone { + my $self = shift; + my $new = bless { %{$self} }, ref $self; + if ($self->_has_members) { + $new->_set_members([$self->members]); + } + if ($self->_has_member_hash) { + $new->_set_member_hash({%{$self->_member_hash}}) + } + return $new; +} + +sub _shallow_clone { + my $self = shift; + return bless { %{$self} }, ref $self; +} + +sub limit { + my $self = shift; + my $limit = $self->_shallow_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_add_by_key(@_)) if @_; + return $limit; +} + +sub get_or_add_by_key { + my $self = shift; + return () unless @_; + 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 object to return + if (ref $_[$i]) { + croak "Passed a reference instead of a key to get_or_add_by_key"; + } + elsif ($self->_member_key_exists($_[$i])) { + push @exists,$i; + } else { + push @need_to_add,$i; + } + } + # create and add by key + if (@need_to_add) { + @return[@need_to_add] = + $self->add_by_key(@_[@need_to_add]); + } + if (@exists) { + @return[@exists] = + $self->get(@_[@exists]); + } + # if we've only been asked to get or create one thing, then it's expected + # that we are returning only one thing + if (@_ == 1) { + return $return[0]; + } + return @return; +} + +has 'constructor_args' => (is => 'rw', + isa => 'ArrayRef', + lazy => 1, + builder => '_build_constructor_args', + ); + +sub _build_constructor_args { + return []; +} + +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_added; + for my $member (@_) { + if (not defined $member) { + confess("Undefined member to add"); + } + push @members_added,$member; + if ($self->exists($member)) { + next; + } + $self->_add($member); + $self->_add_member_hash($self->member_key($member), + $self->count()-1, + ); + } + return @members_added; +} + +use overload '+' => "combine", + '""' => "CARP_TRACE"; + +sub combine { + my $self = shift; + my $return = $self->clone; + $return->add($_->members) for @_; + return $return; +} + +sub get { + my $self = shift; + my @res = map {$self->_get_member($_)} + $self->_get_member_hash(@_); + wantarray?@res:$res[0]; +} + + +sub member_key { + return $_[1]; +} + +sub keys_of_members { + my $self = shift; + return $self->map(sub {$self->member_key($_)}); +} + +sub exists { + my $self = shift; + return $self->_member_key_exists($self->member_key($_[0])); +} + +sub join { + my $self = shift; + my $joiner = shift; + return CORE::join($joiner,$self->keys_of_members); +} + +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; +} + +sub CARP_TRACE { + my $self = shift; + my @members = $self->members; + if (@members > 5) { + @members = map {$self->member_key($_)} + @members[0..4]; + push @members,'...'; + } else { + @members = map {$self->member_key($_)} @members; + } + return __PACKAGE__.'={n_members='.$self->count(). + ',members=('.CORE::join(',',@members).')}'; +} + + +__PACKAGE__->meta->make_immutable; +no Mouse; +1; + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/lib/Debbugs/Collection/Bug.pm b/lib/Debbugs/Collection/Bug.pm new file mode 100644 index 0000000..3f40b0c --- /dev/null +++ b/lib/Debbugs/Collection/Bug.pm @@ -0,0 +1,216 @@ +# 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 + +This collection extends L and contains members of +L. Useful for any field which contains one or more bug or tracking +lists of packages + +=head1 DESCRIPTION + + + +=head1 METHODS + +=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); +use Debbugs::Collection::Package; +use Debbugs::Collection::Correspondent; + +use Debbugs::Bug; + +extends 'Debbugs::Collection'; + +=head2 my $bugs = Debbugs::Collection::Bug->new(%params|$param) + +Parameters in addition to those defined by L + +=over + +=item package_collection + +Optional L which is used to look up packages + + +=item correspondent_collection + +Optional L which is used to look up correspondents + + +=item users + +Optional arrayref of L which set usertags for bugs in this collection + +=back + +=head2 $bugs->package_collection() + +Returns the package collection that this bug collection is using + +=head2 $bugs->correspondent_collection() + +Returns the correspondent collection that this bug collection is using + +=head2 $bugs->users() + +Returns the arrayref of users that this bug collection is using + +=head2 $bugs->add_user($user) + +Add a user to the set of users that this bug collection is using + +=head2 $bugs->load_related_packages_and_versions() + +Preload all of the related packages and versions for the bugs in this bug +collection. You should call this if you plan on calculating whether the bugs in +this collection are present/absent. + +=cut + +has '+members' => (isa => 'ArrayRef[Bug]'); +has 'package_collection' => + (is => 'ro', + isa => 'Debbugs::Collection::Package', + builder => '_build_package_collection', + lazy => 1, + ); + +sub _build_package_collection { + my $self = shift; + return Debbugs::Collection::Package->new($self->has_schema?(schema => $self->schema):()); +} + +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->has_schema?(schema => $self->schema):()); +} + +has 'users' => + (is => 'ro', + isa => 'ArrayRef[Debbugs::User]', + traits => ['Array'], + default => sub {[]}, + handles => {'add_user' => 'push'}, + ); + +sub BUILD { + my $self = shift; + my $args = shift; + if (exists $args->{bugs}) { + $self->add( + $self->_member_constructor(bugs => $args->{bugs} + )); + } +} + +sub _member_constructor { + # handle being called $self->_member_constructor; + my $self = shift; + my %args = @_; + my @return; + my $schema; + $schema = $self->schema if $self->has_schema; + + if (defined $schema) { + my $statuses = get_bug_statuses(bug => [make_list($args{bugs})], + schema => $schema, + ); + # preload as many of the packages as we need + my %packages; + while (my ($bug, $status) = each %{$statuses}) { + if (defined $status->{package}) { + $packages{$_} = 1 for split /,/, $status->{package}; + } + if (defined $status->{source}) { + $packages{$_} = 1 for split /,/, $status->{source}; + } + } + $self->package_collection->universe->add_by_key(keys %packages); + while (my ($bug, $status) = each %{$statuses}) { + push @return, + Debbugs::Bug->new(bug => $bug, + status => + Debbugs::Bug::Status->new(status => $status, + bug => $bug, + status_source => 'db', + ), + schema => $schema, + package_collection => + $self->package_collection->universe, + bug_collection => + $self->universe, + correspondent_collection => + $self->correspondent_collection->universe, + @{$args{constructor_args}//[]}, + ); + } + } else { + for my $bug (make_list($args{bugs})) { + push @return, + Debbugs::Bug->new(bug => $bug, + package_collection => + $self->package_collection->universe, + bug_collection => + $self->universe, + correspondent_collection => + $self->correspondent_collection->universe, + @{$args{constructor_args}//[]}, + ); + } + } + return @return; +} + +around add_by_key => sub { + my $orig = shift; + my $self = shift; + my @members = + $self->_member_constructor(bugs => [@_], + ); + return $self->$orig(@members); +}; + +sub member_key { + return $_[1]->bug; +} + +sub load_related_packages_and_versions { + my $self = shift; + my @related_packages_and_versions = + $self->apply(sub {$_->related_packages_and_versions}); + $self->package_collection-> + add_packages_and_versions(@related_packages_and_versions); +} + +__PACKAGE__->meta->make_immutable; + +1; + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/lib/Debbugs/Collection/Correspondent.pm b/lib/Debbugs/Collection/Correspondent.pm new file mode 100644 index 0000000..43ac8c0 --- /dev/null +++ b/lib/Debbugs/Collection/Correspondent.pm @@ -0,0 +1,83 @@ +# 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::Correspondent; + +=head1 NAME + +Debbugs::Collection::Correspondent -- 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); + +use Debbugs::Correspondent; + +extends 'Debbugs::Collection'; + +has '+members' => (isa => 'ArrayRef[Debbugs::Correspondent]'); + +sub BUILD { + my $self = shift; + my $args = shift; + if (exists $args->{correspondent}) { + $self-> + add($self->_member_constructor(correspondent => + $args->{correspondent})); + } +} + + +sub _member_constructor { + # handle being called $self->_member_constructor; + my $self = shift; + my %args = @_; + my @return; + for my $corr (make_list($args{correspondent})) { + push @return, + Debbugs::Correspondent->new(name => $corr, + $self->schema_argument, + ); + } + return @return; +} + +around add_by_key => sub { + my $orig = shift; + my $self = shift; + my @members = + $self->_member_constructor(correspondent => [@_], + $self->schema_argument, + ); + return $self->$orig(@members); +}; + +sub member_key { + return $_[1]->name; +} + + +__PACKAGE__->meta->make_immutable; + +1; + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/lib/Debbugs/Collection/Package.pm b/lib/Debbugs/Collection/Package.pm new file mode 100644 index 0000000..055cbae --- /dev/null +++ b/lib/Debbugs/Collection/Package.pm @@ -0,0 +1,293 @@ +# 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 + +This collection extends L and contains members of +L. Useful for any field which contains one or more package or +tracking lists of packages + + +=head1 DESCRIPTION + + + +=cut + +use Mouse; +use strictures 2; +use v5.10; # for state +use namespace::autoclean; + +use Carp; +use Debbugs::Common qw(make_list hash_slice); +use Debbugs::Config qw(:config); +use Debbugs::OOTypes; +use Debbugs::Package; + +use List::AllUtils qw(part); + +use Debbugs::Version::Binary; +use Debbugs::Collection::Version; +use Debbugs::Collection::Correspondent; +use Debbugs::VersionTree; + +extends 'Debbugs::Collection'; + +=head1 Object Creation + +=head2 my $packages = Debbugs::Collection::Package->new(%params|$param) + +Parameters in addition to those defined by L + +=over + +=item correspondent_collection + +Optional L which is used to look up correspondents + + +=item versiontree + +Optional L which contains known package source versions + +=back + +=head1 Methods + +=head2 correspondent_collection + + $packages->correspondent_collection + +Returns the L for this package collection + +=head2 versiontree + +Returns the L for this package collection + +=cut + +has '+members' => (isa => 'ArrayRef[Debbugs::Package]'); + +sub BUILD { + my $self = shift; + my $args = shift; + if (exists $args->{packages}) { + $self-> + add($self->_member_constructor(packages => + $args->{packages})); + } +} + +around add_by_key => sub { + my $orig = shift; + my $self = shift; + my @members = + $self->_member_constructor(packages => [@_]); + return $self->$orig(@members); +}; + +sub _member_constructor { + # handle being called $self->_member_constructor; + my $self = shift; + my %args = @_; + my $schema; + if ($self->has_schema) { + $schema = $self->schema; + } + my @return; + if (defined $schema) { + if (not ref($args{packages}) or @{$args{packages}} == 1 and + $self->universe->count() > 0 + ) { + carp("Likely inefficiency; member_constructor called with one argument"); + } + my $packages = + Debbugs::Package::_get_valid_version_info_from_db(packages => $args{packages}, + schema => $schema, + ); + for my $package (keys %{$packages}) { + push @return, + Debbugs::Package->new(%{$packages->{$package}}, + schema => $schema, + package_collection => $self->universe, + correspondent_collection => + $self->correspondent_collection->universe, + ); + } + } else { + for my $package (make_list($args{packages})) { + push @return, + Debbugs::Package->new(name => $package, + package_collection => $self->universe, + correspondent_collection => + $self->correspondent_collection->universe, + ); + } + } + return @return; +} + +sub add_packages_and_versions { + my $self = shift; + $self->add($self->_member_constructor(packages => \@_)); +} + + +sub member_key { + return $_[1]->qualified_name; +} + +has 'correspondent_collection' => + (is => 'ro', + isa => 'Debbugs::Collection::Correspondent', + default => sub {Debbugs::Collection::Correspondent->new()}, + ); + +has 'versiontree' => + (is => 'ro', + isa => 'Debbugs::VersionTree', + lazy => 1, + builder => '_build_versiontree', + ); + +sub _build_versiontree { + my $self = shift; + return Debbugs::VersionTree->new($self->has_schema?(schema => $self->schema):()); +} + +=head2 get_source_versions_distributions + + $packages->get_source_versions_distributions('unstable') + +Given a list of distributions or suites, returns a +L of all of the versions in this package +collection which are known to match. + +Effectively, this calls L for +each package in the collection and merges the results and returns them + +=cut + +sub get_source_versions_distributions { + my $self = shift; + my @return; + push @return, + $self->map(sub {$_->get_source_version_distribution(@_)}); + if (@return > 1) { + return $return[0]->combine($return[1..$#return]); + } + return @return; +} + + +=head2 get_source_versions + + $packages->get_source_versions('1.2.3-1','foo/1.2.3-5') + +Given a list of binary versions or src/versions, returns a +L of all of the versions in this package +collection which are known to match. + +If you give a binary version ('1.2.3-1'), you must have already loaded source +packages into this package collection for it to find an appropriate match. + +If no package is known to match, an version which is invalid will be returned + +For fully qualified versions this loads the appropriate source package into the +universe of this collection and calls L. +For unqualified versions, calls L; if no +valid versions are returned, creates an invalid version. + +=cut + +sub get_source_versions { + my $self = shift; + my @return; + for my $ver (@_) { + my $sv; + if ($ver =~ m{(?.+?)/(?.+)$}) { + my $sp = $self->universe-> + get_or_add_by_key('src:'.$+{src}); + push @return, + $sp->get_source_version($+{ver}); + next; + } else { + my $found_valid = 0; + for my $p ($self->members) { + local $_; + my @vs = + grep {$_->is_valid} + $p->get_source_version($ver); + if (@vs) { + $found_valid = 1; + push @return,@vs; + next; + } + } + if (not $found_valid) { + push @return, + Debbugs::Version::Binary->new(version => $ver, + package_collection => $self->universe, + valid => 0, + $self->schema_argument, + ); + } + } + } + return + Debbugs::Collection::Version->new(members => \@return, + $self->schema_argument, + package_collection => $self->universe, + ); +} + +=head2 source_names + + $packages->source_names() + +Returns a unique list of source names from all members of this collection by +calling L on each member. + +=cut + +sub source_names { + my $self = shift; + local $_; + return uniq map {$_->source_names} $self->members; +} + +=head2 sources + + $packages->sources() + +Returns a L limited to source packages +corresponding to all packages in this collection + +=cut + +sub sources { + my $self = shift; + return $self->universe->limit($self->source_names); +} + + +__PACKAGE__->meta->make_immutable; +no Mouse; + +1; + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/lib/Debbugs/Collection/Version.pm b/lib/Debbugs/Collection/Version.pm new file mode 100644 index 0000000..f461afe --- /dev/null +++ b/lib/Debbugs/Collection/Version.pm @@ -0,0 +1,148 @@ +# 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::Version; + +=head1 NAME + +Debbugs::Collection::Version -- Version generation factory + +=head1 SYNOPSIS + +This collection extends L and contains members of +L. Useful for any field which contains package versions. + + +=head1 DESCRIPTION + + + +=cut + +use Mouse; +use strictures 2; +use v5.10; # for state +use namespace::autoclean; +use Debbugs::Common qw(make_list hash_slice); +use Debbugs::Config qw(:config); +use Debbugs::OOTypes; +use Debbugs::Version; + +use List::AllUtils qw(part); + +extends 'Debbugs::Collection'; + +=head2 my $bugs = Debbugs::Collection::version->new(%params|$param) + +Parameters in addition to those defined by L + +=over + +=item package_collection + +Optional L which is used to look up packages + +=item versions + +Optional arrayref of C string triples + +=back + +=cut + +has '+members' => (isa => 'ArrayRef[Debbugs::Version]'); + +has 'package_collection' => + (is => 'ro', + isa => 'Debbugs::Collection::Package', + builder => '_build_package_collection', + lazy => 1, + ); + +sub _build_package_collection { + my $self = shift; + return Debbugs::Collection::Package->new($self->schema_argument); +} + +sub member_key { + my ($self,$v) = @_; + confess("v not defined") unless defined $v; + return $v->package.'/'.$v->version.'/'.$v->arch; +} + + +around add_by_key => sub { + my $orig = shift; + my $self = shift; + my @members = + $self->_member_constructor(versions => [@_]); + return $self->$orig(@members); +}; + +sub _member_constructor { + my $self = shift; + my %args = @_; + my @return; + for my $pkg_ver_arch (make_list($args{versions})) { + my ($pkg,$ver,$arch) = $pkg_ver_arch =~ m{^([^/]+)/([^/]+)/?([^/]*)$} or + confess("Invalid version key: $pkg_ver_arch"); + if ($pkg =~ s/^src://) { + $arch = 'source'; + } + if (not length $arch) { + $arch = 'any'; + } + if ($arch eq 'source') { + push @return, + Debbugs::Version::Source-> + new($self->schema_argument, + package => $pkg, + version => $ver, + ); + } else { + push @return, + Debbugs::Version::Binary-> + new($self->schema_argument, + package => $pkg, + version => $ver, + arch => [$arch], + ); + } + } + return @return; +} + +=head2 $versions->universe + +Unlike most collections, Debbugs::Collection::Version do not have a universe. + +=cut + +sub universe { + return $_[0]; +} + +=head2 $versions->source + +Returns a (potentially duplicated) list of source packages which are part of +this version collection + +=cut + +sub source { + my $self = shift; + return $self->map(sub{$_->source}); +} + +__PACKAGE__->meta->make_immutable; + +1; + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/lib/Debbugs/Command.pm b/lib/Debbugs/Command.pm new file mode 100644 index 0000000..c68dd70 --- /dev/null +++ b/lib/Debbugs/Command.pm @@ -0,0 +1,101 @@ +# 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 2017 by Don Armstrong . + +package Debbugs::Command; + +=head1 NAME + +Debbugs::Command -- Handle multiple subcommand-style commands + +=head1 SYNOPSIS + + use Debbugs::Command; + +=head1 DESCRIPTION + + +=head1 BUGS + +None known. + +=cut + +use warnings; +use strict; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use base qw(Exporter); + +BEGIN{ + $VERSION = '0.1'; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (commands => [qw(handle_main_arguments), + qw(handle_subcommand_arguments) + ], + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; + +} + +use Getopt::Long qw(:config no_ignore_case); +use Pod::Usage qw(pod2usage); + +=head1 Command processing (:commands) + +Functions which parse arguments for commands (exportable with +C<:commands>) + +=over + +=item handle_main_arguments( + +=cut + +sub handle_main_arguments { + my ($options,@args) = @_; + Getopt::Long::Configure('pass_through'); + GetOptions($options,@args); + Getopt::Long::Configure('default'); + return $options; +} + + + +sub handle_subcommand_arguments { + my ($argv,$args,$subopt) = @_; + $subopt //= {}; + Getopt::Long::GetOptionsFromArray($argv, + $subopt, + keys %{$args}, + ); + my @usage_errors; + for my $arg (keys %{$args}) { + next unless $args->{$arg}; + my $r_arg = $arg; # real argument name + $r_arg =~ s/[=\|].+//g; + if (not defined $subopt->{$r_arg}) { + push @usage_errors, "You must give a $r_arg option"; + } + } + pod2usage(join("\n",@usage_errors)) if @usage_errors; + return $subopt; +} + +=back + +=cut + + +1; + + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/lib/Debbugs/Common.pm b/lib/Debbugs/Common.pm new file mode 100644 index 0000000..b135c42 --- /dev/null +++ b/lib/Debbugs/Common.pm @@ -0,0 +1,1238 @@ +# 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. +# +# [Other people have contributed to this file; their copyrights should +# go here too.] +# Copyright 2007 by Don Armstrong . + +package Debbugs::Common; + +=head1 NAME + +Debbugs::Common -- Common routines for all of Debbugs + +=head1 SYNOPSIS + +use Debbugs::Common qw(:url :html); + + +=head1 DESCRIPTION + +This module is a replacement for the general parts of errorlib.pl. +subroutines in errorlib.pl will be gradually phased out and replaced +with equivalent (or better) functionality here. + +=head1 FUNCTIONS + +=cut + +use warnings; +use strict; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use Exporter qw(import); +use v5.10; + +BEGIN{ + $VERSION = 1.00; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (util => [qw(getbugcomponent getbuglocation getlocationpath get_hashname), + qw(appendfile overwritefile buglog getparsedaddrs getmaintainers), + qw(getsourcemaintainers getsourcemaintainers_reverse), + qw(bug_status), + qw(getmaintainers_reverse), + qw(getpseudodesc), + qw(package_maintainer), + qw(sort_versions), + qw(open_compressed_file), + qw(walk_bugs), + ], + misc => [qw(make_list globify_scalar english_join checkpid), + qw(cleanup_eval_fail), + qw(hash_slice), + ], + date => [qw(secs_to_english)], + quit => [qw(quit)], + lock => [qw(filelock unfilelock lockpid simple_filelock simple_unlockfile)], + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + +#use Debbugs::Config qw(:globals); + +use Carp; +$Carp::Verbose = 1; + +use Debbugs::Config qw(:config); +use IO::File; +use IO::Scalar; +use Debbugs::MIME qw(decode_rfc1522); +use Mail::Address; +use Cwd qw(cwd); +use Storable qw(dclone); +use Time::HiRes qw(usleep); +use File::Path qw(mkpath); +use File::Basename qw(dirname); +use MLDBM qw(DB_File Storable); +$MLDBM::DumpMeth='portable'; +use List::AllUtils qw(natatime); + +use Params::Validate qw(validate_with :types); + +use Fcntl qw(:DEFAULT :flock); +use Encode qw(is_utf8 decode_utf8); + +our $DEBUG_FH = \*STDERR if not defined $DEBUG_FH; + +=head1 UTILITIES + +The following functions are exported by the C<:util> tag + +=head2 getbugcomponent + + my $file = getbugcomponent($bug_number,$extension,$location) + +Returns the path to the bug file in location C<$location>, bug number +C<$bugnumber> and extension C<$extension> + +=cut + +sub getbugcomponent { + my ($bugnum, $ext, $location) = @_; + + if (not defined $location) { + $location = getbuglocation($bugnum, $ext); + # Default to non-archived bugs only for now; CGI scripts want + # archived bugs but most of the backend scripts don't. For now, + # anything that is prepared to accept archived bugs should call + # getbuglocation() directly first. + return undef if defined $location and + ($location ne 'db' and $location ne 'db-h'); + } + my $dir = getlocationpath($location); + return undef if not defined $dir; + if (defined $location and $location eq 'db') { + return "$dir/$bugnum.$ext"; + } else { + my $hash = get_hashname($bugnum); + return "$dir/$hash/$bugnum.$ext"; + } +} + +=head2 getbuglocation + + getbuglocation($bug_number,$extension) + +Returns the the location in which a particular bug exists; valid +locations returned currently are archive, db-h, or db. If the bug does +not exist, returns undef. + +=cut + +sub getbuglocation { + my ($bugnum, $ext) = @_; + my $archdir = get_hashname($bugnum); + return 'archive' if -r getlocationpath('archive')."/$archdir/$bugnum.$ext"; + return 'db-h' if -r getlocationpath('db-h')."/$archdir/$bugnum.$ext"; + return 'db' if -r getlocationpath('db')."/$bugnum.$ext"; + return undef; +} + + +=head2 getlocationpath + + getlocationpath($location) + +Returns the path to a specific location + +=cut + +sub getlocationpath { + my ($location) = @_; + if (defined $location and $location eq 'archive') { + return "$config{spool_dir}/archive"; + } elsif (defined $location and $location eq 'db') { + return "$config{spool_dir}/db"; + } else { + return "$config{spool_dir}/db-h"; + } +} + + +=head2 get_hashname + + get_hashname + +Returns the hash of the bug which is the location within the archive + +=cut + +sub get_hashname { + return "" if ( $_[ 0 ] < 0 ); + return sprintf "%02d", $_[ 0 ] % 100; +} + +=head2 buglog + + buglog($bugnum); + +Returns the path to the logfile corresponding to the bug. + +Returns undef if the bug does not exist. + +=cut + +sub buglog { + my $bugnum = shift; + my $location = getbuglocation($bugnum, 'log'); + return getbugcomponent($bugnum, 'log', $location) if ($location); + $location = getbuglocation($bugnum, 'log.gz'); + return getbugcomponent($bugnum, 'log.gz', $location) if ($location); + return undef; +} + +=head2 bug_status + + bug_status($bugnum) + + +Returns the path to the summary file corresponding to the bug. + +Returns undef if the bug does not exist. + +=cut + +sub bug_status{ + my ($bugnum) = @_; + my $location = getbuglocation($bugnum, 'summary'); + return getbugcomponent($bugnum, 'summary', $location) if ($location); + return undef; +} + +=head2 appendfile + + appendfile($file,'data','to','append'); + +Opens a file for appending and writes data to it. + +=cut + +sub appendfile { + my ($file,@data) = @_; + my $fh = IO::File->new($file,'a') or + die "Unable top open $file for appending: $!"; + print {$fh} @data or die "Unable to write to $file: $!"; + close $fh or die "Unable to close $file: $!"; +} + +=head2 overwritefile + + ovewritefile($file,'data','to','append'); + +Opens file.new, writes data to it, then moves file.new to file. + +=cut + +sub overwritefile { + my ($file,@data) = @_; + my $fh = IO::File->new("${file}.new",'w') or + die "Unable top open ${file}.new for writing: $!"; + print {$fh} @data or die "Unable to write to ${file}.new: $!"; + close $fh or die "Unable to close ${file}.new: $!"; + rename("${file}.new",$file) or + die "Unable to rename ${file}.new to $file: $!"; +} + +=head2 open_compressed_file + + my $fh = open_compressed_file('foo.gz') or + die "Unable to open compressed file: $!"; + + +Opens a file; if the file ends in .gz, .xz, or .bz2, the appropriate +decompression program is forked and output from it is read. + +This routine by default opens the file with UTF-8 encoding; if you want some +other encoding, specify it with the second option. + +=cut +sub open_compressed_file { + my ($file,$encoding) = @_; + $encoding //= ':encoding(UTF-8)'; + my $fh; + my $mode = "<$encoding"; + my @opts; + if ($file =~ /\.gz$/) { + $mode = "-|$encoding"; + push @opts,'gzip','-dc'; + } + if ($file =~ /\.xz$/) { + $mode = "-|$encoding"; + push @opts,'xz','-dc'; + } + if ($file =~ /\.bz2$/) { + $mode = "-|$encoding"; + push @opts,'bzip2','-dc'; + } + open($fh,$mode,@opts,$file); + return $fh; +} + +=head2 walk_bugs + +Walk through directories of bugs, calling a subroutine with a list of bugs +found. + +C sub {print map {qq($_\n)} @_},dirs => [qw(db-h)];> + +=over + +=item callback -- CODEREF of a subroutine to call with a list of bugs + +=item dirs -- ARRAYREF of directories to get bugs from. Like C<[qw(db-h archive)]>. + +=item bugs -- ARRAYREF of bugs to walk through. If both C and C are +provided, both are walked through. + +=item bugs_per_call -- maximum number of bugs to provide to callback + +=item progress_bar -- optional L + +=item bug_file -- bug file to look for (generally C) + +=item logging -- optional filehandle to output logging information + +=back + +=cut + +sub walk_bugs { + state $spec = + {dirs => {type => ARRAYREF, + default => [], + }, + bugs => {type => ARRAYREF, + default => [], + }, + progress_bar => {type => OBJECT|UNDEF, + optional => 1, + }, + bug_file => {type => SCALAR, + default => 'summary', + }, + logging => {type => HANDLE, + optional => 1, + }, + callback => {type => CODEREF, + }, + bugs_per_call => {type => SCALAR, + default => 1, + }, + }; + my %param = validate_with(params => \@_, + spec => $spec + ); + my @dirs = @{$param{dirs}}; + my @initial_bugs = (); + if (@{$param{bugs}}) { + unshift @dirs,''; + @initial_bugs = @{$param{bugs}}; + } + my $tot_dirs = @dirs; + my $done_dirs = 0; + my $avg_subfiles = 0; + my $completed_files = 0; + my $dir; + while ($dir = shift @dirs or defined $dir) { + my @list; + my @subdirs; + if (not length $dir and @initial_bugs) { + push @list,@initial_bugs; + @initial_bugs = (); + } else { + printf {$param{verbose}} "Doing dir %s ...\n", $dir + if defined $param{verbose}; + opendir(my $DIR, "$dir/.") or + die "opendir $dir: $!"; + @subdirs = readdir($DIR) or + die "Unable to readdir $dir: $!"; + closedir($DIR) or + die "Unable to closedir $dir: $!"; + + @list = map { m/^(\d+)\.$param{bug_file}$/?($1):() } @subdirs; + } + $tot_dirs -= @dirs; + push @dirs, map { m/^(\d+)$/ && -d "$dir/$1"?("$dir/$1"):() } @subdirs; + $tot_dirs += @dirs; + if ($param{progress_bar}) { + if ($avg_subfiles == 0) { + $avg_subfiles = @list; + } + $param{progress_bar}-> + target($avg_subfiles*($tot_dirs-$done_dirs)+$completed_files+@list); + $avg_subfiles = ($avg_subfiles * $done_dirs + @list) / ($done_dirs+1); + $done_dirs += 1; + } + + my $it = natatime $param{bugs_per_call},@list; + while (my @bugs = $it->()) { + $param{callback}->(@bugs); + $completed_files += scalar @bugs; + if ($param{progress_bar}) { + $param{progress_bar}->update($completed_files) if $param{progress_bar}; + } + if ($completed_files % 100 == 0 and + defined $param{verbose}) { + print {$param{verbose}} "Up to $completed_files bugs...\n" + } + } + } + $param{progress_bar}->remove() if $param{progress_bar}; +} + + +=head2 getparsedaddrs + + my $address = getparsedaddrs($address); + my @address = getparsedaddrs($address); + +Returns the output from Mail::Address->parse, or the cached output if +this address has been parsed before. In SCALAR context returns the +first address parsed. + +=cut + + +our %_parsedaddrs; +sub getparsedaddrs { + my $addr = shift; + return () unless defined $addr; + return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0] + if exists $_parsedaddrs{$addr}; + { + # don't display the warnings from Mail::Address->parse + local $SIG{__WARN__} = sub { }; + @{$_parsedaddrs{$addr}} = Mail::Address->parse($addr); + } + return wantarray?@{$_parsedaddrs{$addr}}:$_parsedaddrs{$addr}[0]; +} + +=head2 getmaintainers + + my $maintainer = getmaintainers()->{debbugs} + +Returns a hashref of package => maintainer pairs. + +=cut + +our $_maintainer = undef; +our $_maintainer_rev = undef; +sub getmaintainers { + return $_maintainer if defined $_maintainer; + package_maintainer(rehash => 1); + return $_maintainer; +} + +=head2 getmaintainers_reverse + + my @packages = @{getmaintainers_reverse->{'don@debian.org'}||[]}; + +Returns a hashref of maintainer => [qw(list of packages)] pairs. + +=cut + +sub getmaintainers_reverse{ + return $_maintainer_rev if defined $_maintainer_rev; + package_maintainer(rehash => 1); + return $_maintainer_rev; +} + +=head2 getsourcemaintainers + + my $maintainer = getsourcemaintainers()->{debbugs} + +Returns a hashref of src_package => maintainer pairs. + +=cut + +our $_source_maintainer = undef; +our $_source_maintainer_rev = undef; +sub getsourcemaintainers { + return $_source_maintainer if defined $_source_maintainer; + package_maintainer(rehash => 1); + return $_source_maintainer; +} + +=head2 getsourcemaintainers_reverse + + my @src_packages = @{getsourcemaintainers_reverse->{'don@debian.org'}||[]}; + +Returns a hashref of maintainer => [qw(list of source packages)] pairs. + +=cut + +sub getsourcemaintainers_reverse{ + return $_source_maintainer_rev if defined $_source_maintainer_rev; + package_maintainer(rehash => 1); + return $_source_maintainer_rev; +} + +=head2 package_maintainer + + my @s = package_maintainer(source => [qw(foo bar baz)], + binary => [qw(bleh blah)], + ); + +=over + +=item source -- scalar or arrayref of source package names to return +maintainers for, defaults to the empty arrayref. + +=item binary -- scalar or arrayref of binary package names to return +maintainers for; automatically returns source package maintainer if +the package name starts with 'src:', defaults to the empty arrayref. + +=item maintainer -- scalar or arrayref of maintainers to return source packages +for. If given, binary and source cannot be given. + +=item rehash -- whether to reread the maintainer and source maintainer +files; defaults to 0 + +=item schema -- Debbugs::DB schema. If set, uses the database for maintainer +information. + +=back + +=cut + +sub package_maintainer { + my %param = validate_with(params => \@_, + spec => {source => {type => SCALAR|ARRAYREF, + default => [], + }, + binary => {type => SCALAR|ARRAYREF, + default => [], + }, + maintainer => {type => SCALAR|ARRAYREF, + default => [], + }, + rehash => {type => BOOLEAN, + default => 0, + }, + reverse => {type => BOOLEAN, + default => 0, + }, + schema => {type => OBJECT, + optional => 1, + } + }, + ); + my @binary = make_list($param{binary}); + my @source = make_list($param{source}); + my @maintainers = make_list($param{maintainer}); + if ((@binary or @source) and @maintainers) { + croak "It is nonsensical to pass both maintainers and source or binary"; + } + if (@binary) { + @source = grep {/^src:/} @binary; + @binary = grep {!/^src:/} @binary; + } + # remove leading src: from source package names + s/^src:// foreach @source; + if ($param{schema}) { + my $s = $param{schema}; + if (@maintainers) { + my $m_rs = $s->resultset('SrcPkg')-> + search({'correspondent.addr' => [@maintainers]}, + {join => {src_vers => + {maintainer => + 'correspondent'}, + }, + columns => ['pkg'], + group_by => [qw(me.pkg)], + }); + return $m_rs->get_column('pkg')->all(); + } elsif (@binary or @source) { + my $rs = $s->resultset('Maintainer'); + if (@binary) { + $rs = + $rs->search({'bin_pkg.pkg' => [@binary]}, + {join => {src_vers => + {bin_vers => 'bin_pkg'}, + }, + columns => ['name'], + group_by => [qw(me.name)], + } + ); + } + if (@source) { + $rs = + $rs->search({'src_pkg.pkg' => [@source]}, + {join => {src_vers => + 'src_pkg', + }, + columns => ['name'], + group_by => [qw(me.name)], + } + ); + } + return $rs->get_column('name')->all(); + } + return (); + } + if ($param{rehash}) { + $_source_maintainer = undef; + $_source_maintainer_rev = undef; + $_maintainer = undef; + $_maintainer_rev = undef; + } + if (not defined $_source_maintainer or + not defined $_source_maintainer_rev) { + $_source_maintainer = {}; + $_source_maintainer_rev = {}; + if (-e $config{spool_dir}.'/source_maintainers.idx' and + -e $config{spool_dir}.'/source_maintainers_reverse.idx' + ) { + tie %{$_source_maintainer}, + MLDBM => $config{spool_dir}.'/source_maintainers.idx', + O_RDONLY or + die "Unable to tie source maintainers: $!"; + tie %{$_source_maintainer_rev}, + MLDBM => $config{spool_dir}.'/source_maintainers_reverse.idx', + O_RDONLY or + die "Unable to tie source maintainers reverse: $!"; + } else { + for my $fn (@config{('source_maintainer_file', + 'source_maintainer_file_override', + 'pseudo_maint_file')}) { + next unless defined $fn and length $fn; + if (not -e $fn) { + warn "Missing source maintainer file '$fn'"; + next; + } + __add_to_hash($fn,$_source_maintainer, + $_source_maintainer_rev); + } + } + } + if (not defined $_maintainer or + not defined $_maintainer_rev) { + $_maintainer = {}; + $_maintainer_rev = {}; + if (-e $config{spool_dir}.'/maintainers.idx' and + -e $config{spool_dir}.'/maintainers_reverse.idx' + ) { + tie %{$_maintainer}, + MLDBM => $config{spool_dir}.'/binary_maintainers.idx', + O_RDONLY or + die "Unable to tie binary maintainers: $!"; + tie %{$_maintainer_rev}, + MLDBM => $config{spool_dir}.'/binary_maintainers_reverse.idx', + O_RDONLY or + die "Unable to binary maintainers reverse: $!"; + } else { + for my $fn (@config{('maintainer_file', + 'maintainer_file_override', + 'pseudo_maint_file')}) { + next unless defined $fn and length $fn; + if (not -e $fn) { + warn "Missing maintainer file '$fn'"; + next; + } + __add_to_hash($fn,$_maintainer, + $_maintainer_rev); + } + } + } + my @return; + for my $binary (@binary) { + if ($binary =~ /^src:/) { + push @source,$binary; + next; + } + push @return,grep {defined $_} make_list($_maintainer->{$binary}); + } + for my $source (@source) { + $source =~ s/^src://; + push @return,grep {defined $_} make_list($_source_maintainer->{$source}); + } + for my $maintainer (grep {defined $_} @maintainers) { + push @return,grep {defined $_} + make_list($_maintainer_rev->{$maintainer}); + push @return,map {$_ !~ /^src:/?'src:'.$_:$_} + grep {defined $_} + make_list($_source_maintainer_rev->{$maintainer}); + } + return @return; +} + +#=head2 __add_to_hash +# +# __add_to_hash($file,$forward_hash,$reverse_hash,'address'); +# +# Reads a maintainer/source maintainer/pseudo desc file and adds the +# maintainers from it to the forward and reverse hashref; assumes that +# the forward is unique; makes no assumptions of the reverse. +# +#=cut + +sub __add_to_hash { + my ($fn,$forward,$reverse,$type) = @_; + if (ref($forward) ne 'HASH') { + croak "__add_to_hash must be passed a hashref for the forward"; + } + if (defined $reverse and not ref($reverse) eq 'HASH') { + croak "if reverse is passed to __add_to_hash, it must be a hashref"; + } + $type //= 'address'; + my $fh = IO::File->new($fn,'r') or + croak "Unable to open $fn for reading: $!"; + binmode($fh,':encoding(UTF-8)'); + while (<$fh>) { + chomp; + next unless m/^(\S+)\s+(\S.*\S)\s*$/; + my ($key,$value)=($1,$2); + $key = lc $key; + $forward->{$key}= $value; + if (defined $reverse) { + if ($type eq 'address') { + for my $m (map {lc($_->address)} (getparsedaddrs($value))) { + push @{$reverse->{$m}},$key; + } + } + else { + push @{$reverse->{$value}}, $key; + } + } + } +} + + +=head2 getpseudodesc + + my $pseudopkgdesc = getpseudodesc(...); + +Returns the entry for a pseudo package from the +$config{pseudo_desc_file}. In cases where pseudo_desc_file is not +defined, returns an empty arrayref. + +This function can be used to see if a particular package is a +pseudopackage or not. + +=cut + +our $_pseudodesc = undef; +sub getpseudodesc { + return $_pseudodesc if defined $_pseudodesc; + $_pseudodesc = {}; + __add_to_hash($config{pseudo_desc_file},$_pseudodesc) if + defined $config{pseudo_desc_file} and + length $config{pseudo_desc_file}; + return $_pseudodesc; +} + +=head2 sort_versions + + sort_versions('1.0-2','1.1-2'); + +Sorts versions using AptPkg::Versions::compare if it is available, or +Debbugs::Versions::Dpkg::vercmp if it isn't. + +=cut + +our $vercmp; +BEGIN{ + use Debbugs::Versions::Dpkg; + $vercmp=\&Debbugs::Versions::Dpkg::vercmp; + +# eventually we'll use AptPkg:::Version or similar, but the current +# implementation makes this *super* difficult. + +# eval { +# use AptPkg::Version; +# $vercmp=\&AptPkg::Version::compare; +# }; +} + +sub sort_versions{ + return sort {$vercmp->($a,$b)} @_; +} + + +=head1 DATE + + my $english = secs_to_english($seconds); + my ($days,$english) = secs_to_english($seconds); + +XXX This should probably be changed to use Date::Calc + +=cut + +sub secs_to_english{ + my ($seconds) = @_; + + my $days = int($seconds / 86400); + my $years = int($days / 365); + $days %= 365; + my $result; + my @age; + push @age, "1 year" if ($years == 1); + push @age, "$years years" if ($years > 1); + push @age, "1 day" if ($days == 1); + push @age, "$days days" if ($days > 1); + $result .= join(" and ", @age); + + return wantarray?(int($seconds/86400),$result):$result; +} + + +=head1 LOCK + +These functions are exported with the :lock tag + +=head2 filelock + + filelock($lockfile); + filelock($lockfile,$locks); + +FLOCKs the passed file. Use unfilelock to unlock it. + +Can be passed an optional $locks hashref, which is used to track which +files are locked (and how many times they have been locked) to allow +for cooperative locking. + +=cut + +our @filelocks; + +use Carp qw(cluck); + +sub filelock { + # NB - NOT COMPATIBLE WITH `with-lock' + my ($lockfile,$locks) = @_; + if ($lockfile !~ m{^/}) { + $lockfile = cwd().'/'.$lockfile; + } + # This is only here to allow for relocking bugs inside of + # Debbugs::Control. Nothing else should be using it. + if (defined $locks and exists $locks->{locks}{$lockfile} and + $locks->{locks}{$lockfile} >= 1) { + if (exists $locks->{relockable} and + exists $locks->{relockable}{$lockfile}) { + $locks->{locks}{$lockfile}++; + # indicate that the bug for this lockfile needs to be reread + $locks->{relockable}{$lockfile} = 1; + push @{$locks->{lockorder}},$lockfile; + return; + } + else { + use Data::Dumper; + confess "Locking already locked file: $lockfile\n".Data::Dumper->Dump([$lockfile,$locks],[qw(lockfile locks)]); + } + } + my ($fh,$t_lockfile,$errors) = + simple_filelock($lockfile,10,1); + if ($fh) { + push @filelocks, {fh => $fh, file => $lockfile}; + if (defined $locks) { + $locks->{locks}{$lockfile}++; + push @{$locks->{lockorder}},$lockfile; + } + } else { + use Data::Dumper; + croak "failed to get lock on $lockfile -- $errors". + (defined $locks?Data::Dumper->Dump([$locks],[qw(locks)]):''); + } +} + +=head2 simple_filelock + + my ($fh,$t_lockfile,$errors) = + simple_filelock($lockfile,$count,$wait); + +Does a flock of lockfile. If C<$count> is zero, does a blocking lock. +Otherwise, does a non-blocking lock C<$count> times, waiting C<$wait> +seconds in between. + +In list context, returns the lockfile filehandle, lockfile name, and +any errors which occured. + +When the lockfile filehandle is undef, locking failed. + +These lockfiles must be unlocked manually at process end. + + +=cut + +sub simple_filelock { + my ($lockfile,$count,$wait) = @_; + if (not defined $count) { + $count = 10; + } + if ($count < 0) { + $count = 0; + } + if (not defined $wait) { + $wait = 1; + } + my $errors= ''; + my $fh; + while (1) { + $fh = eval { + my $fh2 = IO::File->new($lockfile,'w') + or die "Unable to open $lockfile for writing: $!"; + # Do a blocking lock if count is zero + flock($fh2,LOCK_EX|($count == 0?0:LOCK_NB)) + or die "Unable to lock $lockfile $!"; + return $fh2; + }; + if ($@) { + $errors .= $@; + } + if ($fh) { + last; + } + # use usleep for fractional wait seconds + usleep($wait * 1_000_000); + } continue { + last unless (--$count > 0); + } + if ($fh) { + return wantarray?($fh,$lockfile,$errors):$fh + } + return wantarray?(undef,$lockfile,$errors):undef; +} + +# clean up all outstanding locks at end time +END { + while (@filelocks) { + unfilelock(); + } +} + +=head2 simple_unlockfile + + simple_unlockfile($fh,$lockfile); + + +=cut + +sub simple_unlockfile { + my ($fh,$lockfile) = @_; + flock($fh,LOCK_UN) + or warn "Unable to unlock lockfile $lockfile: $!"; + close($fh) + or warn "Unable to close lockfile $lockfile: $!"; + unlink($lockfile) + or warn "Unable to unlink lockfile $lockfile: $!"; +} + + +=head2 unfilelock + + unfilelock() + unfilelock($locks); + +Unlocks the file most recently locked. + +Note that it is not currently possible to unlock a specific file +locked with filelock. + +=cut + +sub unfilelock { + my ($locks) = @_; + if (@filelocks == 0) { + carp "unfilelock called with no active filelocks!\n"; + return; + } + if (defined $locks and ref($locks) ne 'HASH') { + croak "hash not passsed to unfilelock"; + } + if (defined $locks and exists $locks->{lockorder} and + @{$locks->{lockorder}} and + exists $locks->{locks}{$locks->{lockorder}[-1]}) { + my $lockfile = pop @{$locks->{lockorder}}; + $locks->{locks}{$lockfile}--; + if ($locks->{locks}{$lockfile} > 0) { + return + } + delete $locks->{locks}{$lockfile}; + } + my %fl = %{pop(@filelocks)}; + simple_unlockfile($fl{fh},$fl{file}); +} + + +=head2 lockpid + + lockpid('/path/to/pidfile'); + +Creates a pidfile '/path/to/pidfile' if one doesn't exist or if the +pid in the file does not respond to kill 0. + +Returns 1 on success, false on failure; dies on unusual errors. + +=cut + +sub lockpid { + my ($pidfile) = @_; + if (-e $pidfile) { + my $pid = checkpid($pidfile); + die "Unable to read pidfile $pidfile: $!" if not defined $pid; + return 0 if $pid != 0; + unlink $pidfile or + die "Unable to unlink stale pidfile $pidfile $!"; + } + mkpath(dirname($pidfile)); + my $pidfh = IO::File->new($pidfile,O_CREAT|O_EXCL|O_WRONLY) or + die "Unable to open $pidfile for writing: $!"; + print {$pidfh} $$ or die "Unable to write to $pidfile $!"; + close $pidfh or die "Unable to close $pidfile $!"; + return 1; +} + +=head2 checkpid + + checkpid('/path/to/pidfile'); + +Checks a pid file and determines if the process listed in the pidfile +is still running. Returns the pid if it is, 0 if it isn't running, and +undef if the pidfile doesn't exist or cannot be read. + +=cut + +sub checkpid{ + my ($pidfile) = @_; + if (-e $pidfile) { + my $pidfh = IO::File->new($pidfile, 'r') or + return undef; + local $/; + my $pid = <$pidfh>; + close $pidfh; + ($pid) = $pid =~ /(\d+)/; + if (defined $pid and kill(0,$pid)) { + return $pid; + } + return 0; + } + else { + return undef; + } +} + + +=head1 QUIT + +These functions are exported with the :quit tag. + +=head2 quit + + quit() + +Exits the program by calling die. + +Usage of quit is deprecated; just call die instead. + +=cut + +sub quit { + print {$DEBUG_FH} "quitting >$_[0]<\n" if $DEBUG; + carp "quit() is deprecated; call die directly instead"; +} + + +=head1 MISC + +These functions are exported with the :misc tag + +=head2 make_list + + LIST = make_list(@_); + +Turns a scalar or an arrayref into a list; expands a list of arrayrefs +into a list. + +That is, make_list([qw(a b c)]); returns qw(a b c); make_list([qw(a +b)],[qw(c d)] returns qw(a b c d); + +=cut + +sub make_list { + return map {(ref($_) eq 'ARRAY')?@{$_}:$_} @_; +} + + +=head2 english_join + + print english_join(list => \@list); + print english_join(\@list); + +Joins list properly to make an english phrase. + +=over + +=item normal -- how to separate most values; defaults to ', ' + +=item last -- how to separate the last two values; defaults to ', and ' + +=item only_two -- how to separate only two values; defaults to ' and ' + +=item list -- ARRAYREF values to join; if the first argument is an +ARRAYREF, it's assumed to be the list of values to join + +=back + +In cases where C is empty, returns ''; when there is only one +element, returns that element. + +=cut + +sub english_join { + if (ref $_[0] eq 'ARRAY') { + return english_join(list=>$_[0]); + } + my %param = validate_with(params => \@_, + spec => {normal => {type => SCALAR, + default => ', ', + }, + last => {type => SCALAR, + default => ', and ', + }, + only_two => {type => SCALAR, + default => ' and ', + }, + list => {type => ARRAYREF, + }, + }, + ); + my @list = @{$param{list}}; + if (@list <= 1) { + return @list?$list[0]:''; + } + elsif (@list == 2) { + return join($param{only_two},@list); + } + my $ret = $param{last} . pop(@list); + return join($param{normal},@list) . $ret; +} + + +=head2 globify_scalar + + my $handle = globify_scalar(\$foo); + +if $foo isn't already a glob or a globref, turn it into one using +IO::Scalar. Gives a new handle to /dev/null if $foo isn't defined. + +Will carp if given a scalar which isn't a scalarref or a glob (or +globref), and return /dev/null. May return undef if IO::Scalar or +IO::File fails. (Check $!) + +The scalar will fill with octets, not perl's internal encoding, so you +must use decode_utf8() after on the scalar, and encode_utf8() on it +before. This appears to be a bug in the underlying modules. + +=cut + +our $_NULL_HANDLE; + +sub globify_scalar { + my ($scalar) = @_; + my $handle; + if (defined $scalar) { + if (defined ref($scalar)) { + if (ref($scalar) eq 'SCALAR' and + not UNIVERSAL::isa($scalar,'GLOB')) { + if (is_utf8(${$scalar})) { + ${$scalar} = decode_utf8(${$scalar}); + carp(q(\$scalar must not be in perl's internal encoding)); + } + open $handle, '>:scalar:utf8', $scalar; + return $handle; + } + else { + return $scalar; + } + } + elsif (UNIVERSAL::isa(\$scalar,'GLOB')) { + return $scalar; + } + else { + carp "Given a non-scalar reference, non-glob to globify_scalar; returning /dev/null handle"; + } + } + if (not defined $_NULL_HANDLE or + not $_NULL_HANDLE->opened() + ) { + $_NULL_HANDLE = + IO::File->new('/dev/null','>:encoding(UTF-8)') or + die "Unable to open /dev/null for writing: $!"; + } + return $_NULL_HANDLE; +} + +=head2 cleanup_eval_fail() + + print "Something failed with: ".cleanup_eval_fail($@); + +Does various bits of cleanup on the failure message from an eval (or +any other die message) + +Takes at most two options; the first is the actual failure message +(usually $@ and defaults to $@), the second is the debug level +(defaults to $DEBUG). + +If debug is non-zero, the code at which the failure occured is output. + +=cut + +sub cleanup_eval_fail { + my ($error,$debug) = @_; + if (not defined $error or not @_) { + $error = $@ // 'unknown reason'; + } + if (@_ <= 1) { + $debug = $DEBUG // 0; + } + $debug = 0 if not defined $debug; + + if ($debug > 0) { + return $error; + } + # ditch the "at foo/bar/baz.pm line 5" + $error =~ s/\sat\s\S+\sline\s\d+//; + # ditch croak messages + $error =~ s/^\t+.+\n?//mg; + # ditch trailing multiple periods in case there was a cascade of + # die messages. + $error =~ s/\.+$/\./; + return $error; +} + +=head2 hash_slice + + hash_slice(%hash,qw(key1 key2 key3)) + +For each key, returns matching values and keys of the hash if they exist + +=cut + + +# NB: We use prototypes here SPECIFICALLY so that we can be passed a +# hash without uselessly making a reference to first. DO NOT USE +# PROTOTYPES USELESSLY ELSEWHERE. +sub hash_slice(\%@) { + my ($hashref,@keys) = @_; + return map {exists $hashref->{$_}?($_,$hashref->{$_}):()} @keys; +} + + +1; + +__END__ diff --git a/lib/Debbugs/Config.pm b/lib/Debbugs/Config.pm new file mode 100644 index 0000000..0d0abae --- /dev/null +++ b/lib/Debbugs/Config.pm @@ -0,0 +1,1278 @@ +# 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 2007 by Don Armstrong . + +package Debbugs::Config; + +=head1 NAME + +Debbugs::Config -- Configuration information for debbugs + +=head1 SYNOPSIS + + use Debbugs::Config; + +# to get the compatiblity interface + + use Debbugs::Config qw(:globals); + +=head1 DESCRIPTION + +This module provides configuration variables for all of debbugs. + +=head1 CONFIGURATION FILES + +The default configuration file location is /etc/debbugs/config; this +configuration file location can be set by modifying the +DEBBUGS_CONFIG_FILE env variable to point at a different location. + +=cut + +use warnings; +use strict; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT $USING_GLOBALS %config); +use base qw(Exporter); + +BEGIN { + # set the version for version checking + $VERSION = 1.00; + $DEBUG = 0 unless defined $DEBUG; + $USING_GLOBALS = 0; + + @EXPORT = (); + %EXPORT_TAGS = (globals => [qw($gEmailDomain $gListDomain $gWebHost $gWebHostBugDir), + qw($gWebDomain $gHTMLSuffix $gCGIDomain $gMirrors), + qw($gPackagePages $gSubscriptionDomain $gProject $gProjectTitle), + qw($gMaintainer $gMaintainerWebpage $gMaintainerEmail $gUnknownMaintainerEmail), + qw($gPackageTrackingDomain $gUsertagPackageDomain), + qw($gSubmitList $gMaintList $gQuietList $gForwardList), + qw($gDoneList $gRequestList $gSubmitterList $gControlList), + qw($gStrongList), + qw($gBugSubscriptionDomain), + qw($gPackageVersionRe), + qw($gSummaryList $gMirrorList $gMailer $gBug), + qw($gBugs $gRemoveAge $gSaveOldBugs $gDefaultSeverity), + qw($gShowSeverities $gBounceFroms $gConfigDir $gSpoolDir), + qw($gIncomingDir $gWebDir $gDocDir $gMaintainerFile), + qw($gMaintainerFileOverride $gPseudoMaintFile $gPseudoDescFile $gPackageSource), + qw($gVersionPackagesDir $gVersionIndex $gBinarySourceMap $gSourceBinaryMap), + qw($gVersionTimeIndex), + qw($gSimpleVersioning), + qw($gCVETracker), + qw($gSendmail @gSendmailArguments $gLibPath $gSpamScan @gExcludeFromControl), + qw(%gSeverityDisplay @gTags @gSeverityList @gStrongSeverities), + qw(%gTagsSingleLetter), + qw(%gSearchEstraier), + qw(%gDistributionAliases), + qw(%gObsoleteSeverities), + qw(@gPostProcessall @gRemovalDefaultDistributionTags @gRemovalDistributionTags @gRemovalArchitectures), + qw(@gRemovalStrongSeverityDefaultDistributionTags), + qw(@gAffectsDistributionTags), + qw(@gDefaultArchitectures), + qw($gMachineName), + qw($gTemplateDir), + qw($gDefaultPackage), + qw($gSpamMaxThreads $gSpamSpamsPerThread $gSpamKeepRunning $gSpamScan $gSpamCrossassassinDb), + qw($gDatabase), + ], + text => [qw($gBadEmailPrefix $gHTMLTail $gHTMLExpireNote), + ], + cgi => [qw($gLibravatarUri $gLibravatarCacheDir $gLibravatarUriOptions @gLibravatarBlacklist)], + config => [qw(%config)], + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; + $ENV{HOME} = '' if not defined $ENV{HOME}; +} + +use Sys::Hostname; +use File::Basename qw(dirname); +use IO::File; +use Safe; + +=head1 CONFIGURATION VARIABLES + +=head2 General Configuration + +=over + +=cut + +# read in the files; +%config = (); +# untaint $ENV{DEBBUGS_CONFIG_FILE} if it's owned by us +# This enables us to test things that are -T. +if (exists $ENV{DEBBUGS_CONFIG_FILE}) { +# This causes all sorts of problems for mirrors of debbugs; disable +# it. +# if (${[stat($ENV{DEBBUGS_CONFIG_FILE})]}[4] == $<) { + $ENV{DEBBUGS_CONFIG_FILE} =~ /(.+)/; + $ENV{DEBBUGS_CONFIG_FILE} = $1; +# } +# else { +# die "Environmental variable DEBBUGS_CONFIG_FILE set, and $ENV{DEBBUGS_CONFIG_FILE} is not owned by the user running this script."; +# } +} +read_config(exists $ENV{DEBBUGS_CONFIG_FILE}?$ENV{DEBBUGS_CONFIG_FILE}:'/etc/debbugs/config'); + +=item email_domain $gEmailDomain + +The email domain of the bts + +=cut + +set_default(\%config,'email_domain','bugs.something'); + +=item list_domain $gListDomain + +The list domain of the bts, defaults to the email domain + +=cut + +set_default(\%config,'list_domain',$config{email_domain}); + +=item web_host $gWebHost + +The web host of the bts; defaults to the email domain + +=cut + +set_default(\%config,'web_host',$config{email_domain}); + +=item web_host_bug_dir $gWebHostDir + +The directory of the web host on which bugs are kept, defaults to C<''> + +=cut + +set_default(\%config,'web_host_bug_dir',''); + +=item web_domain $gWebDomain + +Full path of the web domain where bugs are kept including the protocol (http:// +or https://). Defaults to the concatenation of 'http://', L and +L + +=cut + +set_default(\%config,'web_domain','http://'.$config{web_host}.($config{web_host}=~m{/$}?'':'/').$config{web_host_bug_dir}); + +=item html_suffix $gHTMLSuffix + +Suffix of html pages, defaults to .html + +=cut + +set_default(\%config,'html_suffix','.html'); + +=item cgi_domain $gCGIDomain + +Full path of the web domain where cgi scripts are kept. Defaults to +the concatentation of L and cgi. + +=cut + +set_default(\%config,'cgi_domain',$config{web_domain}.($config{web_domain}=~m{/$}?'':'/').'cgi'); + +=item mirrors @gMirrors + +List of mirrors [What these mirrors are used for, no one knows.] + +=cut + + +set_default(\%config,'mirrors',[]); + +=item package_pages $gPackagePages + +Domain where the package pages are kept; links should work in a +package_pages/foopackage manner. Defaults to undef, which means that package +links will not be made. Should be prefixed with the appropriate protocol +(http/https). + +=cut + + +set_default(\%config,'package_pages',undef); + +=item package_tracking_domain $gPackageTrackingDomain + +Domain where the package pages are kept; links should work in a +package_tracking_domain/foopackage manner. Defaults to undef, which means that +package links will not be made. Should be prefixed with the appropriate protocol +(http or https). + +=cut + +set_default(\%config,'package_tracking_domain',undef); + +=item package_pages $gUsertagPackageDomain + +Domain where where usertags of packages belong; defaults to $gPackagePages + +=cut + +set_default(\%config,'usertag_package_domain',map {my $a = $_; defined $a?$a =~ s{https?://}{}:(); $a} $config{package_pages}); + + +=item subscription_domain $gSubscriptionDomain + +Domain where subscriptions to package lists happen + +=cut + +set_default(\%config,'subscription_domain',undef); + + +=item cc_all_mails_to_addr $gCcAllMailsToAddr + +Address to Cc (well, Bcc) all e-mails to + +=cut + +set_default(\%config,'cc_all_mails_to_addr',undef); + + +=item cve_tracker $gCVETracker + +URI to CVE security tracker; in bugreport.cgi, CVE-2001-0002 becomes +linked to $config{cve_tracker}CVE-2001-002 + +Default: https://security-tracker.debian.org/tracker/ + +=cut + +set_default(\%config,'cve_tracker','https://security-tracker.debian.org/tracker/'); + + +=back + +=cut + + +=head2 Project Identification + +=over + +=item project $gProject + +Name of the project + +Default: 'Something' + +=cut + +set_default(\%config,'project','Something'); + +=item project_title $gProjectTitle + +Name of this install of Debbugs, defaults to "L Debbugs Install" + +Default: "$config{project} Debbugs Install" + +=cut + +set_default(\%config,'project_title',"$config{project} Debbugs Install"); + +=item maintainer $gMaintainer + +Name of the maintainer of this debbugs install + +Default: 'Local DebBugs Owner's + +=cut + +set_default(\%config,'maintainer','Local DebBugs Owner'); + +=item maintainer_webpage $gMaintainerWebpage + +Webpage of the maintainer of this install of debbugs + +Default: "$config{web_domain}/~owner" + +=cut + +set_default(\%config,'maintainer_webpage',"$config{web_domain}/~owner"); + +=item maintainer_email $gMaintainerEmail + +Email address of the maintainer of this Debbugs install + +Default: 'root@'.$config{email_domain} + +=cut + +set_default(\%config,'maintainer_email','root@'.$config{email_domain}); + +=item unknown_maintainer_email + +Email address where packages with an unknown maintainer will be sent + +Default: $config{maintainer_email} + +=cut + +set_default(\%config,'unknown_maintainer_email',$config{maintainer_email}); + +=item machine_name + +The name of the machine that this instance of debbugs is running on +(currently used for debbuging purposes and web page output.) + +Default: Sys::Hostname::hostname() + +=back + +=cut + +set_default(\%config,'machine_name',Sys::Hostname::hostname()); + +=head2 BTS Mailing Lists + + +=over + +=item submit_list + +=item maint_list + +=item forward_list + +=item done_list + +=item request_list + +=item submitter_list + +=item control_list + +=item summary_list + +=item mirror_list + +=item strong_list + +=cut + +set_default(\%config, 'submit_list', 'bug-submit-list'); +set_default(\%config, 'maint_list', 'bug-maint-list'); +set_default(\%config, 'quiet_list', 'bug-quiet-list'); +set_default(\%config, 'forward_list', 'bug-forward-list'); +set_default(\%config, 'done_list', 'bug-done-list'); +set_default(\%config, 'request_list', 'bug-request-list'); +set_default(\%config,'submitter_list','bug-submitter-list'); +set_default(\%config, 'control_list', 'bug-control-list'); +set_default(\%config, 'summary_list', 'bug-summary-list'); +set_default(\%config, 'mirror_list', 'bug-mirror-list'); +set_default(\%config, 'strong_list', 'bug-strong-list'); + +=item bug_subscription_domain + +Domain of list for messages regarding a single bug; prefixed with +bug=${bugnum}@ when bugs are actually sent out. Set to undef or '' to +disable sending messages to the bug subscription list. + +Default: list_domain + +=back + +=cut + +set_default(\%config,'bug_subscription_domain',$config{list_domain}); + + + +=head2 Misc Options + +=over + +=item mailer + +Name of the mailer to use + +Default: exim + +=cut + +set_default(\%config,'mailer','exim'); + + +=item bug + +Default: bug + +=item ubug + +Default: ucfirst($config{bug}); + +=item bugs + +Default: bugs + +=item ubugs + +Default: ucfirst($config{ubugs}); + +=cut + +set_default(\%config,'bug','bug'); +set_default(\%config,'ubug',ucfirst($config{bug})); +set_default(\%config,'bugs','bugs'); +set_default(\%config,'ubugs',ucfirst($config{bugs})); + +=item remove_age + +Age at which bugs are archived/removed + +Default: 28 + +=cut + +set_default(\%config,'remove_age',28); + +=item save_old_bugs + +Whether old bugs are saved or deleted + +Default: 1 + +=cut + +set_default(\%config,'save_old_bugs',1); + +=item distribution_aliases + +Map of distribution aliases to the distribution name + +Default: + {experimental => 'experimental', + unstable => 'unstable', + testing => 'testing', + stable => 'stable', + oldstable => 'oldstable', + sid => 'unstable', + lenny => 'testing', + etch => 'stable', + sarge => 'oldstable', + } + +=cut + +set_default(\%config,'distribution_aliases', + {experimental => 'experimental', + unstable => 'unstable', + testing => 'testing', + stable => 'stable', + oldstable => 'oldstable', + sid => 'unstable', + lenny => 'testing', + etch => 'stable', + sarge => 'oldstable', + }, + ); + + + +=item distributions + +List of valid distributions + +Default: The values of the distribution aliases map. + +=cut + +my %_distributions_default; +@_distributions_default{values %{$config{distribution_aliases}}} = values %{$config{distribution_aliases}}; +set_default(\%config,'distributions',[keys %_distributions_default]); + + +=item default_architectures + +List of default architectures to use when architecture(s) are not +specified + +Default: i386 amd64 arm ppc sparc alpha + +=cut + +set_default(\%config,'default_architectures', + [qw(i386 amd64 arm powerpc sparc alpha)] + ); + +=item affects_distribution_tags + +List of tags which restrict the buggy state to a set of distributions. + +The set of distributions that are buggy is the intersection of the set +of distributions that would be buggy without reference to these tags +and the set of these tags that are distributions which are set on a +bug. + +Setting this to [] will remove this feature. + +Default: @{$config{distributions}} + +=cut + +set_default(\%config,'affects_distribution_tags', + [@{$config{distributions}}], + ); + +=item removal_unremovable_tags + +Bugs which have these tags set cannot be archived + +Default: [] + +=cut + +set_default(\%config,'removal_unremovable_tags', + [], + ); + +=item removal_distribution_tags + +Tags which specifiy distributions to check + +Default: @{$config{distributions}} + +=cut + +set_default(\%config,'removal_distribution_tags', + [@{$config{distributions}}]); + +=item removal_default_distribution_tags + +For removal/archival purposes, all bugs are assumed to have these tags +set. + +Default: qw(experimental unstable testing); + +=cut + +set_default(\%config,'removal_default_distribution_tags', + [qw(experimental unstable testing)] + ); + +=item removal_strong_severity_default_distribution_tags + +For removal/archival purposes, all bugs with strong severity are +assumed to have these tags set. + +Default: qw(experimental unstable testing stable); + +=cut + +set_default(\%config,'removal_strong_severity_default_distribution_tags', + [qw(experimental unstable testing stable)] + ); + + +=item removal_architectures + +For removal/archival purposes, these architectures are consulted if +there is more than one architecture applicable. If the bug is in a +package not in any of these architectures, the architecture actually +checked is undefined. + +Default: value of default_architectures + +=cut + +set_default(\%config,'removal_architectures', + $config{default_architectures}, + ); + + +=item package_name_re + +The regex which will match a package name + +Default: '[a-z0-9][a-z0-9\.+-]+' + +=cut + +set_default(\%config,'package_name_re', + '[a-z0-9][a-z0-9\.+-]+'); + +=item package_version_re + +The regex which will match a package version + +Default: '[A-Za-z0-9:+\.-]+' + +=cut + + +set_default(\%config,'package_version_re', + '[A-Za-z0-9:+\.~-]+'); + + +=item default_package + +This is the name of the default package. If set, bugs assigned to +packages without a maintainer and bugs missing a Package: psuedoheader +will be assigned to this package instead. + +Defaults to unset, which is the traditional debbugs behavoir + +=cut + +set_default(\%config,'default_package', + undef + ); + + +=item control_internal_requester + +This address is used by Debbugs::Control as the request address which +sent a control request for faked log messages. + +Default:"Debbugs Internal Request <$config{maintainer_email}>" + +=cut + +set_default(\%config,'control_internal_requester', + "Debbugs Internal Request <$config{maintainer_email}>", + ); + +=item control_internal_request_addr + +This address is used by Debbugs::Control as the address to which a +faked log message request was sent. + +Default: "internal_control\@$config{email_domain}"; + +=cut + +set_default(\%config,'control_internal_request_addr', + 'internal_control@'.$config{email_domain}, + ); + + +=item exclude_from_control + +Addresses which are not allowed to send messages to control + +=cut + +set_default(\%config,'exclude_from_control',[]); + + + +=item default_severity + +The default severity of bugs which have no severity set + +Default: normal + +=cut + +set_default(\%config,'default_severity','normal'); + +=item severity_display + +A hashref of severities and the informative text which describes them. + +Default: + + {critical => "Critical $config{bugs}", + grave => "Grave $config{bugs}", + normal => "Normal $config{bugs}", + wishlist => "Wishlist $config{bugs}", + } + +=cut + +set_default(\%config,'severity_display',{critical => "Critical $config{bugs}", + grave => "Grave $config{bugs}", + serious => "Serious $config{bugs}", + important=> "Important $config{bugs}", + normal => "Normal $config{bugs}", + minor => "Minor $config{bugs}", + wishlist => "Wishlist $config{bugs}", + }); + +=item show_severities + +A scalar list of the severities to show + +Defaults to the concatenation of the keys of the severity_display +hashlist with ', ' above. + +=cut + +set_default(\%config,'show_severities',join(', ',keys %{$config{severity_display}})); + +=item strong_severities + +An arrayref of the serious severities which shoud be emphasized + +Default: [qw(critical grave)] + +=cut + +set_default(\%config,'strong_severities',[qw(critical grave)]); + +=item severity_list + +An arrayref of a list of the severities + +Defaults to the keys of the severity display hashref + +=cut + +set_default(\%config,'severity_list',[keys %{$config{severity_display}}]); + +=item obsolete_severities + +A hashref of obsolete severities with the replacing severity + +Default: {} + +=cut + +set_default(\%config,'obsolete_severities',{}); + +=item tags + +An arrayref of the tags used + +Default: [qw(patch wontfix moreinfo unreproducible fixed)] and also +includes the distributions. + +=cut + +set_default(\%config,'tags',[qw(patch wontfix moreinfo unreproducible fixed), + @{$config{distributions}} + ]); + +set_default(\%config,'tags_single_letter', + {patch => '+', + wontfix => '', + moreinfo => 'M', + unreproducible => 'R', + fixed => 'F', + } + ); + +set_default(\%config,'bounce_froms','^mailer|^da?emon|^post.*mast|^root|^wpuser|^mmdf|^smt.*|'. + '^mrgate|^vmmail|^mail.*system|^uucp|-maiser-|^mal\@|'. + '^mail.*agent|^tcpmail|^bitmail|^mailman'); + +set_default(\%config,'config_dir',dirname(exists $ENV{DEBBUGS_CONFIG_FILE}?$ENV{DEBBUGS_CONFIG_FILE}:'/etc/debbugs/config')); +set_default(\%config,'spool_dir','/var/lib/debbugs/spool'); + +=item usertag_dir + +Directory which contains the usertags + +Default: $config{spool_dir}/user + +=cut + +set_default(\%config,'usertag_dir',$config{spool_dir}.'/user'); +set_default(\%config,'incoming_dir','incoming'); + +=item web_dir $gWebDir + +Directory where base html files are kept. Should normally be the same +as the web server's document root. + +Default: /var/lib/debbugs/www + +=cut + +set_default(\%config,'web_dir','/var/lib/debbugs/www'); +set_default(\%config,'doc_dir','/var/lib/debbugs/www/txt'); +set_default(\%config,'lib_path','/usr/lib/debbugs'); + + +=item template_dir + +directory of templates; defaults to /usr/share/debbugs/templates. + +=cut + +set_default(\%config,'template_dir','/usr/share/debbugs/templates'); + + +set_default(\%config,'maintainer_file',$config{config_dir}.'/Maintainers'); +set_default(\%config,'maintainer_file_override',$config{config_dir}.'/Maintainers.override'); +set_default(\%config,'source_maintainer_file',$config{config_dir}.'/Source_maintainers'); +set_default(\%config,'source_maintainer_file_override',undef); +set_default(\%config,'pseudo_maint_file',$config{config_dir}.'/pseudo-packages.maintainers'); +set_default(\%config,'pseudo_desc_file',$config{config_dir}.'/pseudo-packages.description'); +set_default(\%config,'package_source',$config{config_dir}.'/indices/sources'); + + +=item simple_versioning + +If true this causes debbugs to ignore version information and just +look at whether a bug is done or not done. Primarily of interest for +debbugs installs which don't track versions. defaults to false. + +=cut + +set_default(\%config,'simple_versioning',0); + + +=item version_packages_dir + +Location where the version package information is kept; defaults to +spool_dir/../versions/pkg + +=cut + +set_default(\%config,'version_packages_dir',$config{spool_dir}.'/../versions/pkg'); + +=item version_time_index + +Location of the version/time index file. Defaults to +spool_dir/../versions/idx/versions_time.idx if spool_dir/../versions +exists; otherwise defaults to undef. + +=cut + + +set_default(\%config,'version_time_index', -d $config{spool_dir}.'/../versions' ? $config{spool_dir}.'/../versions/indices/versions_time.idx' : undef); + +=item version_index + +Location of the version index file. Defaults to +spool_dir/../versions/indices/versions.idx if spool_dir/../versions +exists; otherwise defaults to undef. + +=cut + +set_default(\%config,'version_index',-d $config{spool_dir}.'/../versions' ? $config{spool_dir}.'/../versions/indices/versions.idx' : undef); + +=item binary_source_map + +Location of the binary -> source map. Defaults to +spool_dir/../versions/indices/bin2src.idx if spool_dir/../versions +exists; otherwise defaults to undef. + +=cut + +set_default(\%config,'binary_source_map',-d $config{spool_dir}.'/../versions' ? $config{spool_dir}.'/../versions/indices/binsrc.idx' : undef); + +=item source_binary_map + +Location of the source -> binary map. Defaults to +spool_dir/../versions/indices/src2bin.idx if spool_dir/../versions +exists; otherwise defaults to undef. + +=cut + +set_default(\%config,'source_binary_map',-d $config{spool_dir}.'/../versions' ? $config{spool_dir}.'/../versions/indices/srcbin.idx' : undef); + + + +set_default(\%config,'post_processall',[]); + +=item sendmail + +Sets the sendmail binary to execute; defaults to /usr/lib/sendmail + +=cut + +set_default(\%config,'sendmail','/usr/lib/sendmail'); + +=item sendmail_arguments + +Default arguments to pass to sendmail. Defaults to C. + +=cut + +set_default(\%config,'sendmail_arguments',[qw(-oem -oi)]); + +=item envelope_from + +Envelope from to use for sent messages. If not set, whatever sendmail picks is +used. + +=cut + +set_default(\%config,'envelope_from',undef); + +=item spam_scan + +Whether or not spamscan is being used; defaults to 0 (not being used + +=cut + +set_default(\%config,'spam_scan',0); + +=item spam_crossassassin_db + +Location of the crosassassin database, defaults to +spool_dir/../CrossAssassinDb + +=cut + +set_default(\%config,'spam_crossassassin_db',$config{spool_dir}.'/../CrossAssassinDb'); + +=item spam_max_cross + +Maximum number of cross-posted messages + +=cut + +set_default(\%config,'spam_max_cross',6); + + +=item spam_spams_per_thread + +Number of spams for each thread (on average). Defaults to 200 + +=cut + +set_default(\%config,'spam_spams_per_thread',200); + +=item spam_max_threads + +Maximum number of threads to start. Defaults to 20 + +=cut + +set_default(\%config,'spam_max_threads',20); + +=item spam_keep_running + +Maximum number of seconds to run without restarting. Defaults to 3600. + +=cut + +set_default(\%config,'spam_keep_running',3600); + +=item spam_mailbox + +Location to store spam messages; is run through strftime to allow for +%d,%m,%Y, et al. Defaults to 'spool_dir/../mail/spam/assassinated.%Y-%m-%d' + +=cut + +set_default(\%config,'spam_mailbox',$config{spool_dir}.'/../mail/spam/assassinated.%Y-%m-%d'); + +=item spam_crossassassin_mailbox + +Location to store crossassassinated messages; is run through strftime +to allow for %d,%m,%Y, et al. Defaults to +'spool_dir/../mail/spam/crossassassinated.%Y-%m-%d' + +=cut + +set_default(\%config,'spam_crossassassin_mailbox',$config{spool_dir}.'/../mail/spam/crossassassinated.%Y-%m-%d'); + +=item spam_local_tests_only + +Whether only local tests are run, defaults to 0 + +=cut + +set_default(\%config,'spam_local_tests_only',0); + +=item spam_user_prefs + +User preferences for spamassassin, defaults to $ENV{HOME}/.spamassassin/user_prefs + +=cut + +set_default(\%config,'spam_user_prefs',"$ENV{HOME}/.spamassassin/user_prefs"); + +=item spam_rules_dir + +Site rules directory for spamassassin, defaults to +'/usr/share/spamassassin' + +=cut + +set_default(\%config,'spam_rules_dir','/usr/share/spamassassin'); + +=back + +=head2 CGI Options + +=over + +=item libravatar_uri $gLibravatarUri + +URI to a libravatar configuration. If empty or undefined, libravatar +support will be disabled. Defaults to +libravatar.cgi, our internal federated libravatar system. + +=cut + +set_default(\%config,'libravatar_uri',$config{cgi_domain}.'/libravatar.cgi?email='); + +=item libravatar_uri_options $gLibravatarUriOptions + +Options to append to the md5_hex of the e-mail. This sets the default +avatar used when an avatar isn't available. Currently defaults to +'?d=retro', which causes a bitmap-looking avatar to be displayed for +unknown e-mails. + +Other options which make sense include ?d=404, ?d=wavatar, etc. See +the API of libravatar for details. + +=cut + +set_default(\%config,'libravatar_uri_options',''); + +=item libravatar_default_image + +Default image to serve for libravatar if there is no avatar for an +e-mail address. By default, this is a 1x1 png. [This will also be the +image served if someone specifies avatar=no.] + +Default: $config{web_dir}/1x1.png + +=cut + +set_default(\%config,'libravatar_default_image',$config{web_dir}.'/1x1.png'); + +=item libravatar_cache_dir + +Directory where cached libravatar images are stored + +Default: $config{web_dir}/libravatar/ + +=cut + +set_default(\%config,'libravatar_cache_dir',$config{web_dir}.'/libravatar/'); + +=item libravatar_blacklist + +Array of regular expressions to match against emails, domains, or +images to only show the default image + +Default: empty array + +=cut + +set_default(\%config,'libravatar_blacklist',[]); + +=back + +=head2 Database + +=over + +=item database + +Name of debbugs PostgreSQL database service. If you wish to not use a service +file, provide a full DBD::Pg compliant data-source, for example: +C<"dbi:Pg:dbname=dbname"> + +=back + +=cut + +set_default(\%config,'database',undef); + +=head2 Text Fields + +The following are the only text fields in general use in the scripts; +a few additional text fields are defined in text.in, but are only used +in db2html and a few other specialty scripts. + +Earlier versions of debbugs defined these values in /etc/debbugs/text, +but now they are required to be in the configuration file. [Eventually +the longer ones will move out into a fully fledged template system.] + +=cut + +=over + +=item bad_email_prefix + +This prefixes the text of all lines in a bad e-mail message ack. + +=cut + +set_default(\%config,'bad_email_prefix',''); + + +=item text_instructions + +This gives more information about bad e-mails to receive.in + +=cut + +set_default(\%config,'text_instructions',$config{bad_email_prefix}); + +=item html_tail + +This shows up at the end of (most) html pages + +In many pages this has been replaced by the html/tail template. + +=cut + +set_default(\%config,'html_tail',<$config{maintainer} <$config{maintainer_email}>. + Last modified: + + SUBSTITUTE_DTIME + +

    + Debian $config{bug} tracking system
    + Copyright (C) 1999 Darren O. Benham, + 1997,2003 nCipher Corporation Ltd, + 1994-97 Ian Jackson. +

    + +END + + +=item html_expire_note + +This message explains what happens to archive/remove-able bugs + +=cut + +set_default(\%config,'html_expire_note', + "(Closed $config{bugs} are archived $config{remove_age} days after the last related message is received.)"); + +=back + +=cut + + +sub read_config{ + my ($conf_file) = @_; + if (not -e $conf_file) { + print STDERR "configuration file '$conf_file' doesn't exist; skipping it\n" if $DEBUG; + return; + } + # first, figure out what type of file we're reading in. + my $fh = IO::File->new($conf_file,'r') + or die "Unable to open configuration file $conf_file for reading: $!"; + # A new version configuration file must have a comment as its first line + my $first_line = <$fh>; + my ($version) = defined $first_line?$first_line =~ /VERSION:\s*(\d+)/i:undef; + if (defined $version) { + if ($version == 1) { + # Do something here; + die "Version 1 configuration files not implemented yet"; + } + else { + die "Version $version configuration files are not supported"; + } + } + else { + # Ugh. Old configuration file + # What we do here is we create a new Safe compartment + # so fucked up crap in the config file doesn't sink us. + my $cpt = new Safe or die "Unable to create safe compartment"; + # perldoc Opcode; for details + $cpt->permit('require',':filesys_read','entereval','caller','pack','unpack','dofile'); + $cpt->reval(qq(require '$conf_file';)); + die "Error in configuration file: $@" if $@; + # Now what we do is check out the contents of %EXPORT_TAGS to see exactly which variables + # we want to glob in from the configuration file + for my $variable (map {$_ =~ /^(?:config|all)$/ ? () : @{$EXPORT_TAGS{$_}}} keys %EXPORT_TAGS) { + my ($hash_name,$glob_name,$glob_type) = __convert_name($variable); + my $var_glob = $cpt->varglob($glob_name); + my $value; #= $cpt->reval("return $variable"); + # print STDERR "$variable $value",qq(\n); + if (defined $var_glob) {{ + no strict 'refs'; + if ($glob_type eq '%') { + $value = {%{*{$var_glob}}} if defined *{$var_glob}{HASH}; + } + elsif ($glob_type eq '@') { + $value = [@{*{$var_glob}}] if defined *{$var_glob}{ARRAY}; + } + else { + $value = ${*{$var_glob}}; + } + # We punt here, because we can't tell if the value was + # defined intentionally, or if it was just left alone; + # this tries to set sane defaults. + set_default(\%config,$hash_name,$value) if defined $value; + }} + } + } +} + +sub __convert_name{ + my ($variable) = @_; + my $hash_name = $variable; + $hash_name =~ s/^([\$\%\@])g//; + my $glob_type = $1; + my $glob_name = 'g'.$hash_name; + $hash_name =~ s/(HTML|CGI|CVE)/ucfirst(lc($1))/ge; + $hash_name =~ s/^([A-Z]+)/lc($1)/e; + $hash_name =~ s/([A-Z]+)/'_'.lc($1)/ge; + return $hash_name unless wantarray; + return ($hash_name,$glob_name,$glob_type); +} + +# set_default + +# sets the configuration hash to the default value if it's not set, +# otherwise doesn't do anything +# If $USING_GLOBALS, then sets an appropriate global. + +sub set_default{ + my ($config,$option,$value) = @_; + my $varname; + if ($USING_GLOBALS) { + # fix up the variable name + $varname = 'g'.join('',map {ucfirst $_} split /_/, $option); + # Fix stupid HTML names + $varname =~ s/(Html|Cgi)/uc($1)/ge; + } + # update the configuration value + if (not $USING_GLOBALS and not exists $config->{$option}) { + $config->{$option} = $value; + } + elsif ($USING_GLOBALS) {{ + no strict 'refs'; + # Need to check if a value has already been set in a global + if (defined *{"Debbugs::Config::${varname}"}) { + $config->{$option} = *{"Debbugs::Config::${varname}"}; + } + else { + $config->{$option} = $value; + } + }} + if ($USING_GLOBALS) {{ + no strict 'refs'; + *{"Debbugs::Config::${varname}"} = $config->{$option}; + }} +} + + +### import magick + +# All we care about here is whether we've been called with the globals or text option; +# if so, then we need to export some symbols back up. +# In any event, we call exporter. + +sub import { + if (grep /^:(?:text|globals)$/, @_) { + $USING_GLOBALS=1; + for my $variable (map {@$_} @EXPORT_TAGS{map{(/^:(text|globals)$/?($1):())} @_}) { + my $tmp = $variable; + no strict 'refs'; + # Yes, I don't care if these are only used once + no warnings 'once'; + # No, it doesn't bother me that I'm assigning an undefined value to a typeglob + no warnings 'misc'; + my ($hash_name,$glob_name,$glob_type) = __convert_name($variable); + $tmp =~ s/^[\%\$\@]//; + *{"Debbugs::Config::${tmp}"} = ref($config{$hash_name})?$config{$hash_name}:\$config{$hash_name}; + } + } + Debbugs::Config->export_to_level(1,@_); +} + + +1; diff --git a/lib/Debbugs/Control.pm b/lib/Debbugs/Control.pm new file mode 100644 index 0000000..1f8b3aa --- /dev/null +++ b/lib/Debbugs/Control.pm @@ -0,0 +1,3919 @@ +# 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. +# +# [Other people have contributed to this file; their copyrights should +# go here too.] +# Copyright 2007,2008,2009 by Don Armstrong . + +package Debbugs::Control; + +=head1 NAME + +Debbugs::Control -- Routines for modifying the state of bugs + +=head1 SYNOPSIS + +use Debbugs::Control; + + +=head1 DESCRIPTION + +This module is an abstraction of a lot of functions which originally +were only present in service.in, but as time has gone on needed to be +called from elsewhere. + +All of the public functions take the following options: + +=over + +=item debug -- scalar reference to which debbuging information is +appended + +=item transcript -- scalar reference to which transcript information +is appended + +=item affected_bugs -- hashref which is updated with bugs affected by +this function + + +=back + +Functions which should (probably) append to the .log file take the +following options: + +=over + +=item requester -- Email address of the individual who requested the change + +=item request_addr -- Address to which the request was sent + +=item request_nn -- Name of queue file which caused this request + +=item request_msgid -- Message id of message which caused this request + +=item location -- Optional location; currently ignored but may be +supported in the future for updating archived bugs upon archival + +=item message -- The original message which caused the action to be taken + +=item append_log -- Whether or not to append information to the log. + +=back + +B (for most functions) is a special option. When set to +false, no appending to the log is done at all. When it is not present, +the above information is faked, and appended to the log file. When it +is true, the above options must be present, and their values are used. + + +=head1 GENERAL FUNCTIONS + +=cut + +use warnings; +use strict; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use Exporter qw(import); + +BEGIN{ + $VERSION = 1.00; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (done => [qw(set_done)], + submitter => [qw(set_submitter)], + severity => [qw(set_severity)], + affects => [qw(affects)], + summary => [qw(summary)], + outlook => [qw(outlook)], + owner => [qw(owner)], + title => [qw(set_title)], + forward => [qw(set_forwarded)], + found => [qw(set_found set_fixed)], + fixed => [qw(set_found set_fixed)], + package => [qw(set_package)], + block => [qw(set_blocks)], + merge => [qw(set_merged)], + tag => [qw(set_tag)], + clone => [qw(clone_bug)], + archive => [qw(bug_archive bug_unarchive), + ], + limit => [qw(check_limit)], + log => [qw(append_action_to_log), + ], + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + +use Debbugs::Config qw(:config); +use Debbugs::Common qw(:lock buglog :misc get_hashname sort_versions); +use Debbugs::UTF8; +use Debbugs::Status qw(bug_archiveable :read :hook writebug new_bug splitpackages split_status_fields get_bug_status); +use Debbugs::CGI qw(html_escape); +use Debbugs::Log qw(:misc :write); +use Debbugs::Recipients qw(:add); +use Debbugs::Packages qw(:versions :mapping); + +use Data::Dumper qw(); +use Params::Validate qw(validate_with :types); +use File::Path qw(mkpath); +use File::Copy qw(copy); +use IO::File; + +use Debbugs::Text qw(:templates); + +use Debbugs::Mail qw(rfc822_date send_mail_message default_headers encode_headers); +use Debbugs::MIME qw(create_mime_message); + +use Mail::RFC822::Address qw(); + +use POSIX qw(strftime); + +use Storable qw(dclone nfreeze); +use List::AllUtils qw(first max); +use Encode qw(encode_utf8); + +use Carp; + +# These are a set of options which are common to all of these functions + +my %common_options = (debug => {type => SCALARREF|HANDLE, + optional => 1, + }, + transcript => {type => SCALARREF|HANDLE, + optional => 1, + }, + affected_bugs => {type => HASHREF, + optional => 1, + }, + affected_packages => {type => HASHREF, + optional => 1, + }, + recipients => {type => HASHREF, + default => {}, + }, + limit => {type => HASHREF, + default => {}, + }, + show_bug_info => {type => BOOLEAN, + default => 1, + }, + request_subject => {type => SCALAR, + default => 'Unknown Subject', + }, + request_msgid => {type => SCALAR, + default => '', + }, + request_nn => {type => SCALAR, + optional => 1, + }, + request_replyto => {type => SCALAR, + optional => 1, + }, + locks => {type => HASHREF, + optional => 1, + }, + ); + + +my %append_action_options = + (action => {type => SCALAR, + optional => 1, + }, + requester => {type => SCALAR, + optional => 1, + }, + request_addr => {type => SCALAR, + optional => 1, + }, + location => {type => SCALAR, + optional => 1, + }, + message => {type => SCALAR|ARRAYREF, + optional => 1, + }, + append_log => {type => BOOLEAN, + optional => 1, + depends => [qw(requester request_addr), + qw(message), + ], + }, + # locks is both an append_action option, and a common option; + # it's ok for it to be in both places. + locks => {type => HASHREF, + optional => 1, + }, + ); + +our $locks = 0; + + +# this is just a generic stub for Debbugs::Control functions. +# +# =head2 set_foo +# +# eval { +# set_foo(bug => $ref, +# transcript => $transcript, +# ($dl > 0 ? (debug => $transcript):()), +# requester => $header{from}, +# request_addr => $controlrequestaddr, +# message => \@log, +# affected_packages => \%affected_packages, +# recipients => \%recipients, +# summary => undef, +# ); +# }; +# if ($@) { +# $errors++; +# print {$transcript} "Failed to set foo $ref bar: $@"; +# } +# +# Foo frobinates +# +# =cut +# +# sub set_foo { +# my %param = validate_with(params => \@_, +# spec => {bug => {type => SCALAR, +# regex => qr/^\d+$/, +# }, +# # specific options here +# %common_options, +# %append_action_options, +# }, +# ); +# my %info = +# __begin_control(%param, +# command => 'foo' +# ); +# my ($debug,$transcript) = +# @info{qw(debug transcript)}; +# my @data = @{$info{data}}; +# my @bugs = @{$info{bugs}}; +# +# my $action = ''; +# for my $data (@data) { +# append_action_to_log(bug => $data->{bug_num}, +# get_lock => 0, +# __return_append_to_log_options( +# %param, +# action => $action, +# ), +# ) +# if not exists $param{append_log} or $param{append_log}; +# writebug($data->{bug_num},$data); +# print {$transcript} "$action\n"; +# } +# __end_control(%info); +# } + + +=head2 set_blocks + + eval { + set_block(bug => $ref, + transcript => $transcript, + ($dl > 0 ? (debug => $transcript):()), + requester => $header{from}, + request_addr => $controlrequestaddr, + message => \@log, + affected_packages => \%affected_packages, + recipients => \%recipients, + block => [], + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to set blockers of $ref: $@"; + } + +Alters the set of bugs that block this bug from being fixed + +This requires altering both this bug (and those it's merged with) as +well as the bugs that block this bug from being fixed (and those that +it's merged with) + +=over + +=item block -- scalar or arrayref of blocking bugs to set, add or remove + +=item add -- if true, add blocking bugs + +=item remove -- if true, remove blocking bugs + +=back + +=cut + +sub set_blocks { + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + # specific options here + block => {type => SCALAR|ARRAYREF, + default => [], + }, + add => {type => BOOLEAN, + default => 0, + }, + remove => {type => BOOLEAN, + default => 0, + }, + %common_options, + %append_action_options, + }, + ); + if ($param{add} and $param{remove}) { + croak "It's nonsensical to add and remove the same blocking bugs"; + } + if (grep {$_ !~ /^\d+$/} make_list($param{block})) { + croak "Invalid blocking bug(s):". + join(', ',grep {$_ !~ /^\d+$/} make_list($param{block})); + } + my $mode = 'set'; + if ($param{add}) { + $mode = 'add'; + } + elsif ($param{remove}) { + $mode = 'remove'; + } + + my %info = + __begin_control(%param, + command => 'blocks' + ); + my ($debug,$transcript) = + @info{qw(debug transcript)}; + my @data = @{$info{data}}; + my @bugs = @{$info{bugs}}; + + + # The first bit of this code is ugly, and should be cleaned up. + # Its purpose is to populate %removed_blockers and %add_blockers + # with all of the bugs that should be added or removed as blockers + # of all of the bugs which are merged with $param{bug} + my %ok_blockers; + my %bad_blockers; + for my $blocker (make_list($param{block})) { + next if $ok_blockers{$blocker} or $bad_blockers{$blocker}; + my $data = read_bug(bug=>$blocker, + ); + if (defined $data and not $data->{archived}) { + $data = split_status_fields($data); + $ok_blockers{$blocker} = 1; + my @merged_bugs; + push @merged_bugs, make_list($data->{mergedwith}); + @ok_blockers{@merged_bugs} = (1) x @merged_bugs if @merged_bugs; + } + else { + $bad_blockers{$blocker} = 1; + } + } + + # throw an error if we are setting the blockers and there is a bad + # blocker + if (keys %bad_blockers and $mode eq 'set') { + __end_control(%info); + croak "Unknown/archived blocking bug(s):".join(', ',keys %bad_blockers). + keys %ok_blockers?'':" and no good blocking bug(s)"; + } + # if there are no ok blockers and we are not setting the blockers, + # there's an error. + if (not keys %ok_blockers and $mode ne 'set') { + print {$transcript} "No valid blocking bug(s) given; not doing anything\n"; + if (keys %bad_blockers) { + __end_control(%info); + croak "Unknown/archived blocking bug(s):".join(', ',keys %bad_blockers); + } + __end_control(%info); + return; + } + + my @change_blockers = keys %ok_blockers; + + my %removed_blockers; + my %added_blockers; + my $action = ''; + my @blockers = map {split ' ', $_->{blockedby}} @data; + my %blockers; + @blockers{@blockers} = (1) x @blockers; + + # it is nonsensical for a bug to block itself (or a merged + # partner); We currently don't allow removal because we'd possibly + # deadlock + + my %bugs; + @bugs{@bugs} = (1) x @bugs; + for my $blocker (@change_blockers) { + if ($bugs{$blocker}) { + __end_control(%info); + croak "It is nonsensical for a bug to block itself (or a merged partner): $blocker"; + } + } + @blockers = keys %blockers; + if ($param{add}) { + %removed_blockers = (); + for my $blocker (@change_blockers) { + next if exists $blockers{$blocker}; + $blockers{$blocker} = 1; + $added_blockers{$blocker} = 1; + } + } + elsif ($param{remove}) { + %added_blockers = (); + for my $blocker (@change_blockers) { + next if exists $removed_blockers{$blocker}; + delete $blockers{$blocker}; + $removed_blockers{$blocker} = 1; + } + } + else { + @removed_blockers{@blockers} = (1) x @blockers; + %blockers = (); + for my $blocker (@change_blockers) { + next if exists $blockers{$blocker}; + $blockers{$blocker} = 1; + if (exists $removed_blockers{$blocker}) { + delete $removed_blockers{$blocker}; + } + else { + $added_blockers{$blocker} = 1; + } + } + } + for my $data (@data) { + my $old_data = dclone($data); + # remove blockers and/or add new ones as appropriate + if ($data->{blockedby} eq '') { + print {$transcript} "$data->{bug_num} was not blocked by any bugs.\n"; + } else { + print {$transcript} "$data->{bug_num} was blocked by: $data->{blockedby}\n"; + } + if ($data->{blocks} eq '') { + print {$transcript} "$data->{bug_num} was not blocking any bugs.\n"; + } else { + print {$transcript} "$data->{bug_num} was blocking: $data->{blocks}\n"; + } + my @changed; + push @changed, 'added blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %added_blockers]) if keys %added_blockers; + push @changed, 'removed blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %removed_blockers]) if keys %removed_blockers; + $action = ucfirst(join ('; ',@changed)) if @changed; + if (not @changed) { + print {$transcript} "Ignoring request to alter blocking bugs of bug #$data->{bug_num} to the same blocks previously set\n"; + next; + } + $data->{blockedby} = join(' ',keys %blockers); + append_action_to_log(bug => $data->{bug_num}, + command => 'block', + old_data => $old_data, + new_data => $data, + get_lock => 0, + __return_append_to_log_options( + %param, + action => $action, + ), + ) + if not exists $param{append_log} or $param{append_log}; + writebug($data->{bug_num},$data); + print {$transcript} "$action\n"; + } + # we do this bit below to avoid code duplication + my %mungable_blocks; + $mungable_blocks{remove} = \%removed_blockers if keys %removed_blockers; + $mungable_blocks{add} = \%added_blockers if keys %added_blockers; + my $new_locks = 0; + for my $add_remove (keys %mungable_blocks) { + my %munge_blockers; + for my $blocker (keys %{$mungable_blocks{$add_remove}}) { + next if $munge_blockers{$blocker}; + my ($temp_locks, @blocking_data) = + lock_read_all_merged_bugs(bug => $blocker, + ($param{archived}?(location => 'archive'):()), + exists $param{locks}?(locks => $param{locks}):(), + ); + $locks+= $temp_locks; + $new_locks+=$temp_locks; + if (not @blocking_data) { + for (1..$new_locks) { + unfilelock(exists $param{locks}?$param{locks}:()); + $locks--; + } + die "Unable to get file lock while trying to $add_remove blocker '$blocker'"; + } + for (map {$_->{bug_num}} @blocking_data) { + $munge_blockers{$_} = 1; + } + for my $data (@blocking_data) { + my $old_data = dclone($data); + my %blocks; + my @blocks = split ' ', $data->{blocks}; + @blocks{@blocks} = (1) x @blocks; + @blocks = (); + for my $bug (@bugs) { + if ($add_remove eq 'remove') { + next unless exists $blocks{$bug}; + delete $blocks{$bug}; + } + else { + next if exists $blocks{$bug}; + $blocks{$bug} = 1; + } + push @blocks, $bug; + } + $data->{blocks} = join(' ',sort keys %blocks); + my $action = ($add_remove eq 'add'?'Added':'Removed'). + " indication that bug $data->{bug_num} blocks ". + join(',',@blocks); + append_action_to_log(bug => $data->{bug_num}, + command => 'block', + old_data => $old_data, + new_data => $data, + get_lock => 0, + __return_append_to_log_options(%param, + action => $action + ) + ); + writebug($data->{bug_num},$data); + } + __handle_affected_packages(%param,data=>\@blocking_data); + add_recipients(recipients => $param{recipients}, + actions_taken => {blocks => 1}, + data => \@blocking_data, + debug => $debug, + transcript => $transcript, + ); + + for (1..$new_locks) { + unfilelock(exists $param{locks}?$param{locks}:()); + $locks--; + } + } + } + __end_control(%info); +} + + + +=head2 set_tag + + eval { + set_tag(bug => $ref, + transcript => $transcript, + ($dl > 0 ? (debug => $transcript):()), + requester => $header{from}, + request_addr => $controlrequestaddr, + message => \@log, + affected_packages => \%affected_packages, + recipients => \%recipients, + tag => [], + add => 1, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to set tag on $ref: $@"; + } + + +Sets, adds, or removes the specified tags on a bug + +=over + +=item tag -- scalar or arrayref of tags to set, add or remove + +=item add -- if true, add tags + +=item remove -- if true, remove tags + +=item warn_on_bad_tags -- if true (the default) warn if bad tags are +passed. + +=back + +=cut + +sub set_tag { + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + # specific options here + tag => {type => SCALAR|ARRAYREF, + default => [], + }, + add => {type => BOOLEAN, + default => 0, + }, + remove => {type => BOOLEAN, + default => 0, + }, + warn_on_bad_tags => {type => BOOLEAN, + default => 1, + }, + %common_options, + %append_action_options, + }, + ); + if ($param{add} and $param{remove}) { + croak "It's nonsensical to add and remove the same tags"; + } + + my %info = + __begin_control(%param, + command => 'tag' + ); + my $transcript = $info{transcript}; + my @data = @{$info{data}}; + my @tags = make_list($param{tag}); + if (not @tags and ($param{remove} or $param{add})) { + if ($param{remove}) { + print {$transcript} "Requested to remove no tags; doing nothing.\n"; + } + else { + print {$transcript} "Requested to add no tags; doing nothing.\n"; + } + __end_control(%info); + return; + } + # first things first, make the versions fully qualified source + # versions + for my $data (@data) { + my $action = 'Did not alter tags'; + my %tag_added = (); + my %tag_removed = (); + my @old_tags = split /\,?\s+/, $data->{keywords}; + my %tags; + @tags{@old_tags} = (1) x @old_tags; + my $old_data = dclone($data); + if (not $param{add} and not $param{remove}) { + $tag_removed{$_} = 1 for @old_tags; + %tags = (); + } + my @bad_tags = (); + for my $tag (@tags) { + if (not $param{remove} and + not defined first {$_ eq $tag} @{$config{tags}}) { + push @bad_tags, $tag; + next; + } + if ($param{add}) { + if (not exists $tags{$tag}) { + $tags{$tag} = 1; + $tag_added{$tag} = 1; + } + } + elsif ($param{remove}) { + if (exists $tags{$tag}) { + delete $tags{$tag}; + $tag_removed{$tag} = 1; + } + } + else { + if (exists $tag_removed{$tag}) { + delete $tag_removed{$tag}; + } + else { + $tag_added{$tag} = 1; + } + $tags{$tag} = 1; + } + } + if (@bad_tags and $param{warn_on_bad_tags}) { + print {$transcript} "Unknown tag(s): ".join(', ',@bad_tags).".\n"; + print {$transcript} "These tags are recognized: ".join(', ',@{$config{tags}}).".\n"; + } + $data->{keywords} = join(' ',keys %tags); + + my @changed; + push @changed, 'added tag(s) '.english_join([keys %tag_added]) if keys %tag_added; + push @changed, 'removed tag(s) '.english_join([keys %tag_removed]) if keys %tag_removed; + $action = ucfirst(join ('; ',@changed)) if @changed; + if (not @changed) { + print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n"; + next; + } + $action .= '.'; + append_action_to_log(bug => $data->{bug_num}, + get_lock => 0, + command => 'tag', + old_data => $old_data, + new_data => $data, + __return_append_to_log_options( + %param, + action => $action, + ), + ) + if not exists $param{append_log} or $param{append_log}; + writebug($data->{bug_num},$data); + print {$transcript} "$action\n"; + } + __end_control(%info); +} + + + +=head2 set_severity + + eval { + set_severity(bug => $ref, + transcript => $transcript, + ($dl > 0 ? (debug => $transcript):()), + requester => $header{from}, + request_addr => $controlrequestaddr, + message => \@log, + affected_packages => \%affected_packages, + recipients => \%recipients, + severity => 'normal', + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to set the severity of bug $ref: $@"; + } + +Sets the severity of a bug. If severity is not passed, is undefined, +or has zero length, sets the severity to the default severity. + +=cut + +sub set_severity { + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + # specific options here + severity => {type => SCALAR|UNDEF, + default => $config{default_severity}, + }, + %common_options, + %append_action_options, + }, + ); + if (not defined $param{severity} or + not length $param{severity} + ) { + $param{severity} = $config{default_severity}; + } + + # check validity of new severity + if (not defined first {$_ eq $param{severity}} (@{$config{severity_list}},$config{default_severity})) { + die "Severity '$param{severity}' is not a valid severity level"; + } + my %info = + __begin_control(%param, + command => 'severity' + ); + my $transcript = $info{transcript}; + my @data = @{$info{data}}; + + my $action = ''; + for my $data (@data) { + if (not defined $data->{severity}) { + $data->{severity} = $param{severity}; + $action = "Severity set to '$param{severity}'"; + } + else { + if ($data->{severity} eq '') { + $data->{severity} = $config{default_severity}; + } + if ($data->{severity} eq $param{severity}) { + print {$transcript} "Ignoring request to change severity of $config{bug} $data->{bug_num} to the same value.\n"; + next; + } + $action = "Severity set to '$param{severity}' from '$data->{severity}'"; + $data->{severity} = $param{severity}; + } + append_action_to_log(bug => $data->{bug_num}, + get_lock => 0, + __return_append_to_log_options( + %param, + action => $action, + ), + ) + if not exists $param{append_log} or $param{append_log}; + writebug($data->{bug_num},$data); + print {$transcript} "$action\n"; + } + __end_control(%info); +} + + +=head2 set_done + + eval { + set_done(bug => $ref, + transcript => $transcript, + ($dl > 0 ? (debug => $transcript):()), + requester => $header{from}, + request_addr => $controlrequestaddr, + message => \@log, + affected_packages => \%affected_packages, + recipients => \%recipients, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to set foo $ref bar: $@"; + } + +Foo frobinates + +=cut + +sub set_done { + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + reopen => {type => BOOLEAN, + default => 0, + }, + submitter => {type => SCALAR, + optional => 1, + }, + clear_fixed => {type => BOOLEAN, + default => 1, + }, + notify_submitter => {type => BOOLEAN, + default => 1, + }, + original_report => {type => SCALARREF, + optional => 1, + }, + done => {type => SCALAR|UNDEF, + optional => 1, + }, + %common_options, + %append_action_options, + }, + ); + + if (exists $param{submitter} and + not Mail::RFC822::Address::valid($param{submitter})) { + die "New submitter address '$param{submitter}' is not a valid e-mail address"; + } + if (exists $param{done} and defined $param{done} and $param{done} eq 1) { #special case this as using the requester address + $param{done} = $param{requester}; + } + if (exists $param{done} and + (not defined $param{done} or + not length $param{done})) { + delete $param{done}; + $param{reopen} = 1; + } + + my %info = + __begin_control(%param, + command => $param{reopen}?'reopen':'done', + ); + my $transcript = $info{transcript}; + my @data = @{$info{data}}; + my $action =''; + + if ($param{reopen}) { + # avoid warning multiple times if there are fixed versions + my $warn_fixed = 1; + for my $data (@data) { + if (not exists $data->{done} or + not defined $data->{done} or + not length $data->{done}) { + print {$transcript} "Bug $data->{bug_num} is not marked as done; doing nothing.\n"; + __end_control(%info); + return; + } + if (@{$data->{fixed_versions}} and $warn_fixed) { + print {$transcript} "'reopen' may be inappropriate when a bug has been closed with a version;\n"; + print {$transcript} "all fixed versions will be cleared, and you may need to re-add them.\n"; + $warn_fixed = 0; + } + } + $action = "Bug reopened"; + for my $data (@data) { + my $old_data = dclone($data); + $data->{done} = ''; + append_action_to_log(bug => $data->{bug_num}, + command => 'done', + new_data => $data, + old_data => $old_data, + get_lock => 0, + __return_append_to_log_options( + %param, + action => $action, + ), + ) + if not exists $param{append_log} or $param{append_log}; + writebug($data->{bug_num},$data); + } + print {$transcript} "$action\n"; + __end_control(%info); + if (exists $param{submitter}) { + set_submitter(bug => $param{bug}, + submitter => $param{submitter}, + hash_slice(%param, + keys %common_options, + keys %append_action_options) + ); + } + # clear the fixed revisions + if ($param{clear_fixed}) { + set_fixed(fixed => [], + bug => $param{bug}, + reopen => 0, + hash_slice(%param, + keys %common_options, + keys %append_action_options), + ); + } + } + else { + my %submitter_notified; + my $orig_report_set = 0; + for my $data (@data) { + if (exists $data->{done} and + defined $data->{done} and + length $data->{done}) { + print {$transcript} "Bug $data->{bug_num} is already marked as done; not doing anything.\n"; + __end_control(%info); + return; + } + } + for my $data (@data) { + my $old_data = dclone($data); + my $hash = get_hashname($data->{bug_num}); + my $report_fh = IO::File->new("$config{spool_dir}/db-h/$hash/$data->{bug_num}.report",'r') or + die "Unable to open original report $config{spool_dir}/db-h/$hash/$data->{bug_num}.report for reading: $!"; + my $orig_report; + { + local $/; + $orig_report= <$report_fh>; + } + close $report_fh; + if (not $orig_report_set and defined $orig_report and + length $orig_report and + exists $param{original_report}){ + ${$param{original_report}} = $orig_report; + $orig_report_set = 1; + } + + $action = "Marked $config{bug} as done"; + + # set done to the requester + $data->{done} = exists $param{done}?$param{done}:$param{requester}; + append_action_to_log(bug => $data->{bug_num}, + command => 'done', + new_data => $data, + old_data => $old_data, + get_lock => 0, + __return_append_to_log_options( + %param, + action => $action, + ), + ) + if not exists $param{append_log} or $param{append_log}; + writebug($data->{bug_num},$data); + print {$transcript} "$action\n"; + # get the original report + if ($param{notify_submitter}) { + my $submitter_message; + if(not exists $submitter_notified{$data->{originator}}) { + $submitter_message = + create_mime_message([default_headers(queue_file => $param{request_nn}, + data => $data, + msgid => $param{request_msgid}, + msgtype => 'notifdone', + pr_msg => 'they-closed', + headers => + [To => $data->{submitter}, + Subject => "$config{ubug}#$data->{bug_num} ". + "closed by $param{requester} ".(defined $param{request_subject}?"($param{request_subject})":""), + ], + ) + ], + __message_body_template('mail/process_your_bug_done', + {data => $data, + replyto => (exists $param{request_replyto} ? + $param{request_replyto} : + $param{requester} || 'Unknown'), + markedby => $param{requester}, + subject => $param{request_subject}, + messageid => $param{request_msgid}, + config => \%config, + }), + [join('',make_list($param{message})),$orig_report] + ); + send_mail_message(message => $submitter_message, + recipients => $old_data->{submitter}, + ); + $submitter_notified{$data->{originator}} = $submitter_message; + } + else { + $submitter_message = $submitter_notified{$data->{originator}}; + } + append_action_to_log(bug => $data->{bug_num}, + action => "Notification sent", + requester => '', + request_addr => $data->{originator}, + desc => "$config{bug} acknowledged by developer.", + recips => [$data->{originator}], + message => $submitter_message, + get_lock => 0, + ); + } + } + __end_control(%info); + if (exists $param{fixed}) { + set_fixed(fixed => $param{fixed}, + bug => $param{bug}, + reopen => 0, + hash_slice(%param, + keys %common_options, + keys %append_action_options + ), + ); + } + } +} + + +=head2 set_submitter + + eval { + set_submitter(bug => $ref, + transcript => $transcript, + ($dl > 0 ? (debug => $transcript):()), + requester => $header{from}, + request_addr => $controlrequestaddr, + message => \@log, + affected_packages => \%affected_packages, + recipients => \%recipients, + submitter => $new_submitter, + notify_submitter => 1, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to set the forwarded-to-address of $ref: $@"; + } + +Sets the submitter of a bug. If notify_submitter is true (the +default), notifies the old submitter of a bug on changes + +=cut + +sub set_submitter { + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + # specific options here + submitter => {type => SCALAR, + }, + notify_submitter => {type => BOOLEAN, + default => 1, + }, + %common_options, + %append_action_options, + }, + ); + if (not Mail::RFC822::Address::valid($param{submitter})) { + die "New submitter address $param{submitter} is not a valid e-mail address"; + } + my %info = + __begin_control(%param, + command => 'submitter' + ); + my ($debug,$transcript) = + @info{qw(debug transcript)}; + my @data = @{$info{data}}; + my $action = ''; + # here we only concern ourselves with the first of the merged bugs + for my $data ($data[0]) { + my $notify_old_submitter = 0; + my $old_data = dclone($data); + print {$debug} "Going to change bug submitter\n"; + if (((not defined $param{submitter} or not length $param{submitter}) and + (not defined $data->{originator} or not length $data->{originator})) or + (defined $param{submitter} and defined $data->{originator} and + $param{submitter} eq $data->{originator})) { + print {$transcript} "Ignoring request to change the submitter of bug#$data->{bug_num} to the same value\n"; + next; + } + else { + if (defined $data->{originator} and length($data->{originator})) { + $action= "Changed $config{bug} submitter to '$param{submitter}' from '$data->{originator}'."; + $notify_old_submitter = 1; + } + else { + $action= "Set $config{bug} submitter to '$param{submitter}'."; + } + $data->{originator} = $param{submitter}; + } + append_action_to_log(bug => $data->{bug_num}, + command => 'submitter', + new_data => $data, + old_data => $old_data, + get_lock => 0, + __return_append_to_log_options( + %param, + action => $action, + ), + ) + if not exists $param{append_log} or $param{append_log}; + writebug($data->{bug_num},$data); + print {$transcript} "$action\n"; + # notify old submitter + if ($notify_old_submitter and $param{notify_submitter}) { + send_mail_message(message => + create_mime_message([default_headers(queue_file => $param{request_nn}, + data => $data, + msgid => $param{request_msgid}, + msgtype => 'ack', + pr_msg => 'submitter-changed', + headers => + [To => $old_data->{submitter}, + Subject => "$config{ubug}#$data->{bug_num} submitter addressed changed ($param{request_subject})", + ], + ) + ], + __message_body_template('mail/submitter_changed', + {old_data => $old_data, + data => $data, + replyto => exists $param{header}{'reply-to'} ? $param{request_replyto} : $param{requester} || 'Unknown', + config => \%config, + }) + ), + recipients => $old_data->{submitter}, + ); + } + } + __end_control(%info); +} + + + +=head2 set_forwarded + + eval { + set_forwarded(bug => $ref, + transcript => $transcript, + ($dl > 0 ? (debug => $transcript):()), + requester => $header{from}, + request_addr => $controlrequestaddr, + message => \@log, + affected_packages => \%affected_packages, + recipients => \%recipients, + forwarded => $forward_to, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to set the forwarded-to-address of $ref: $@"; + } + +Sets the location to which a bug is forwarded. Given an undef +forwarded, unsets forwarded. + + +=cut + +sub set_forwarded { + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + # specific options here + forwarded => {type => SCALAR|UNDEF, + }, + %common_options, + %append_action_options, + }, + ); + if (defined $param{forwarded} and $param{forwarded} =~ /[^[:print:]]/) { + die "Non-printable characters are not allowed in the forwarded field"; + } + $param{forwarded} = undef if defined $param{forwarded} and not length $param{forwarded}; + my %info = + __begin_control(%param, + command => 'forwarded' + ); + my ($debug,$transcript) = + @info{qw(debug transcript)}; + my @data = @{$info{data}}; + my $action = ''; + for my $data (@data) { + my $old_data = dclone($data); + print {$debug} "Going to change bug forwarded\n"; + if (__all_undef_or_equal($param{forwarded},$data->{forwarded}) or + (not defined $param{forwarded} and + defined $data->{forwarded} and not length $data->{forwarded})) { + print {$transcript} "Ignoring request to change the forwarded-to-address of bug#$data->{bug_num} to the same value\n"; + next; + } + else { + if (not defined $param{forwarded}) { + $action= "Unset $config{bug} forwarded-to-address"; + } + elsif (defined $data->{forwarded} and length($data->{forwarded})) { + $action= "Changed $config{bug} forwarded-to-address to '$param{forwarded}' from '$data->{forwarded}'."; + } + else { + $action= "Set $config{bug} forwarded-to-address to '$param{forwarded}'."; + } + $data->{forwarded} = $param{forwarded}; + } + append_action_to_log(bug => $data->{bug_num}, + command => 'forwarded', + new_data => $data, + old_data => $old_data, + get_lock => 0, + __return_append_to_log_options( + %param, + action => $action, + ), + ) + if not exists $param{append_log} or $param{append_log}; + writebug($data->{bug_num},$data); + print {$transcript} "$action\n"; + } + __end_control(%info); +} + + + + +=head2 set_title + + eval { + set_title(bug => $ref, + transcript => $transcript, + ($dl > 0 ? (debug => $transcript):()), + requester => $header{from}, + request_addr => $controlrequestaddr, + message => \@log, + affected_packages => \%affected_packages, + recipients => \%recipients, + title => $new_title, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to set the title of $ref: $@"; + } + +Sets the title of a specific bug + + +=cut + +sub set_title { + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + # specific options here + title => {type => SCALAR, + }, + %common_options, + %append_action_options, + }, + ); + if ($param{title} =~ /[^[:print:]]/) { + die "Non-printable characters are not allowed in bug titles"; + } + + my %info = __begin_control(%param, + command => 'title', + ); + my ($debug,$transcript) = + @info{qw(debug transcript)}; + my @data = @{$info{data}}; + my $action = ''; + for my $data (@data) { + my $old_data = dclone($data); + print {$debug} "Going to change bug title\n"; + if (defined $data->{subject} and length($data->{subject}) and + $data->{subject} eq $param{title}) { + print {$transcript} "Ignoring request to change the title of bug#$data->{bug_num} to the same title\n"; + next; + } + else { + if (defined $data->{subject} and length($data->{subject})) { + $action= "Changed $config{bug} title to '$param{title}' from '$data->{subject}'."; + } else { + $action= "Set $config{bug} title to '$param{title}'."; + } + $data->{subject} = $param{title}; + } + append_action_to_log(bug => $data->{bug_num}, + command => 'title', + new_data => $data, + old_data => $old_data, + get_lock => 0, + __return_append_to_log_options( + %param, + action => $action, + ), + ) + if not exists $param{append_log} or $param{append_log}; + writebug($data->{bug_num},$data); + print {$transcript} "$action\n"; + } + __end_control(%info); +} + + +=head2 set_package + + eval { + set_package(bug => $ref, + transcript => $transcript, + ($dl > 0 ? (debug => $transcript):()), + requester => $header{from}, + request_addr => $controlrequestaddr, + message => \@log, + affected_packages => \%affected_packages, + recipients => \%recipients, + package => $new_package, + is_source => 0, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to assign or reassign $ref to a package: $@"; + } + +Indicates that a bug is in a particular package. If is_source is true, +indicates that the package is a source package. [Internally, this +causes src: to be prepended to the package name.] + +The default for is_source is 0. As a special case, if the package +starts with 'src:', it is assumed to be a source package and is_source +is overridden. + +The package option must match the package_name_re regex. + +=cut + +sub set_package { + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + # specific options here + package => {type => SCALAR|ARRAYREF, + }, + is_source => {type => BOOLEAN, + default => 0, + }, + %common_options, + %append_action_options, + }, + ); + my @new_packages = map {splitpackages($_)} make_list($param{package}); + if (grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages) { + croak "Invalid package name '". + join(',',grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages). + "'"; + } + my %info = __begin_control(%param, + command => 'package', + ); + my ($debug,$transcript) = + @info{qw(debug transcript)}; + my @data = @{$info{data}}; + # clean up the new package + my $new_package = + join(',', + map {my $temp = $_; + ($temp =~ s/^src:// or + $param{is_source}) ? 'src:'.$temp:$temp; + } @new_packages); + + my $action = ''; + my $package_reassigned = 0; + for my $data (@data) { + my $old_data = dclone($data); + print {$debug} "Going to change assigned package\n"; + if (defined $data->{package} and length($data->{package}) and + $data->{package} eq $new_package) { + print {$transcript} "Ignoring request to reassign bug #$data->{bug_num} to the same package\n"; + next; + } + else { + if (defined $data->{package} and length($data->{package})) { + $package_reassigned = 1; + $action= "$config{bug} reassigned from package '$data->{package}'". + " to '$new_package'."; + } else { + $action= "$config{bug} assigned to package '$new_package'."; + } + $data->{package} = $new_package; + } + append_action_to_log(bug => $data->{bug_num}, + command => 'package', + new_data => $data, + old_data => $old_data, + get_lock => 0, + __return_append_to_log_options( + %param, + action => $action, + ), + ) + if not exists $param{append_log} or $param{append_log}; + writebug($data->{bug_num},$data); + print {$transcript} "$action\n"; + } + __end_control(%info); + # Only clear the fixed/found versions if the package has been + # reassigned + if ($package_reassigned) { + my @params_for_found_fixed = + map {exists $param{$_}?($_,$param{$_}):()} + ('bug', + keys %common_options, + keys %append_action_options, + ); + set_found(found => [], + @params_for_found_fixed, + ); + set_fixed(fixed => [], + @params_for_found_fixed, + ); + } +} + +=head2 set_found + + eval { + set_found(bug => $ref, + transcript => $transcript, + ($dl > 0 ? (debug => $transcript):()), + requester => $header{from}, + request_addr => $controlrequestaddr, + message => \@log, + affected_packages => \%affected_packages, + recipients => \%recipients, + found => [], + add => 1, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to set found on $ref: $@"; + } + + +Sets, adds, or removes the specified found versions of a package + +If the version list is empty, and the bug is currently not "done", +causes the done field to be cleared. + +If any of the versions added to found are greater than any version in +which the bug is fixed (or when the bug is found and there are no +fixed versions) the done field is cleared. + +=cut + +sub set_found { + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + # specific options here + found => {type => SCALAR|ARRAYREF, + default => [], + }, + add => {type => BOOLEAN, + default => 0, + }, + remove => {type => BOOLEAN, + default => 0, + }, + %common_options, + %append_action_options, + }, + ); + if ($param{add} and $param{remove}) { + croak "It's nonsensical to add and remove the same versions"; + } + + my %info = + __begin_control(%param, + command => 'found' + ); + my ($debug,$transcript) = + @info{qw(debug transcript)}; + my @data = @{$info{data}}; + my %versions; + for my $version (make_list($param{found})) { + next unless defined $version; + $versions{$version} = + [make_source_versions(package => [splitpackages($data[0]{package})], + warnings => $transcript, + debug => $debug, + guess_source => 0, + versions => $version, + ) + ]; + # This is really ugly, but it's what we have to do + if (not @{$versions{$version}}) { + print {$transcript} "Unable to make a source version for version '$version'\n"; + } + } + if (not keys %versions and ($param{remove} or $param{add})) { + if ($param{remove}) { + print {$transcript} "Requested to remove no versions; doing nothing.\n"; + } + else { + print {$transcript} "Requested to add no versions; doing nothing.\n"; + } + __end_control(%info); + return; + } + # first things first, make the versions fully qualified source + # versions + for my $data (@data) { + # The 'done' field gets a bit weird with version tracking, + # because a bug may be closed by multiple people in different + # branches. Until we have something more flexible, we set it + # every time a bug is fixed, and clear it when a bug is found + # in a version greater than any version in which the bug is + # fixed or when a bug is found and there is no fixed version + my $action = 'Did not alter found versions'; + my %found_added = (); + my %found_removed = (); + my %fixed_removed = (); + my $reopened = 0; + my $old_data = dclone($data); + if (not $param{add} and not $param{remove}) { + $found_removed{$_} = 1 for @{$data->{found_versions}}; + $data->{found_versions} = []; + } + my %found_versions; + @found_versions{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}}; + my %fixed_versions; + @fixed_versions{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}}; + for my $version (keys %versions) { + if ($param{add}) { + my @svers = @{$versions{$version}}; + if (not @svers) { + @svers = $version; + } + elsif (not grep {$version eq $_} @svers) { + # The $version was not equal to one of the source + # versions, so it's probably unqualified (or just + # wrong). Delete it, and use the source versions + # instead. + if (exists $found_versions{$version}) { + delete $found_versions{$version}; + $found_removed{$version} = 1; + } + } + for my $sver (@svers) { + if (not exists $found_versions{$sver}) { + $found_versions{$sver} = 1; + $found_added{$sver} = 1; + } + # if the found we are adding matches any fixed + # versions, remove them + my @temp = grep m{(^|/)\Q$sver\E$}, keys %fixed_versions; + delete $fixed_versions{$_} for @temp; + $fixed_removed{$_} = 1 for @temp; + } + + # We only care about reopening the bug if the bug is + # not done + if (defined $data->{done} and length $data->{done}) { + my @svers_order = sort_versions(map {m{([^/]+)$}; $1;} + @svers); + # determine if we need to reopen + my @fixed_order = sort_versions(map {m{([^/]+)$}; $1;} + keys %fixed_versions); + if (not @fixed_order or + (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) { + $reopened = 1; + $data->{done} = ''; + } + } + } + elsif ($param{remove}) { + # in the case of removal, we only concern ourself with + # the version passed, not the source version it maps + # to + my @temp = grep m{(?:^|/)\Q$version\E$}, keys %found_versions; + delete $found_versions{$_} for @temp; + $found_removed{$_} = 1 for @temp; + } + else { + # set the keys to exactly these values + my @svers = @{$versions{$version}}; + if (not @svers) { + @svers = $version; + } + for my $sver (@svers) { + if (not exists $found_versions{$sver}) { + $found_versions{$sver} = 1; + if (exists $found_removed{$sver}) { + delete $found_removed{$sver}; + } + else { + $found_added{$sver} = 1; + } + } + } + } + } + + $data->{found_versions} = [keys %found_versions]; + $data->{fixed_versions} = [keys %fixed_versions]; + + my @changed; + push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added; + push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed; +# push @changed, 'marked as fixed in versions '.english_join([keys %fixed_addded]) if keys %fixed_added; + push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed; + $action = ucfirst(join ('; ',@changed)) if @changed; + if ($reopened) { + $action .= " and reopened" + } + if (not $reopened and not @changed) { + print {$transcript} "Ignoring request to alter found versions of bug #$data->{bug_num} to the same values previously set\n"; + next; + } + $action .= '.'; + append_action_to_log(bug => $data->{bug_num}, + get_lock => 0, + command => 'found', + old_data => $old_data, + new_data => $data, + __return_append_to_log_options( + %param, + action => $action, + ), + ) + if not exists $param{append_log} or $param{append_log}; + writebug($data->{bug_num},$data); + print {$transcript} "$action\n"; + } + __end_control(%info); +} + +=head2 set_fixed + + eval { + set_fixed(bug => $ref, + transcript => $transcript, + ($dl > 0 ? (debug => $transcript):()), + requester => $header{from}, + request_addr => $controlrequestaddr, + message => \@log, + affected_packages => \%affected_packages, + recipients => \%recipients, + fixed => [], + add => 1, + reopen => 0, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to set fixed on $ref: $@"; + } + + +Sets, adds, or removes the specified fixed versions of a package + +If the fixed versions are empty (or end up being empty after this +call) or the greatest fixed version is less than the greatest found +version and the reopen option is true, the bug is reopened. + +This function is also called by the reopen function, which causes all +of the fixed versions to be cleared. + +=cut + +sub set_fixed { + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + # specific options here + fixed => {type => SCALAR|ARRAYREF, + default => [], + }, + add => {type => BOOLEAN, + default => 0, + }, + remove => {type => BOOLEAN, + default => 0, + }, + reopen => {type => BOOLEAN, + default => 0, + }, + %common_options, + %append_action_options, + }, + ); + if ($param{add} and $param{remove}) { + croak "It's nonsensical to add and remove the same versions"; + } + my %info = + __begin_control(%param, + command => 'fixed' + ); + my ($debug,$transcript) = + @info{qw(debug transcript)}; + my @data = @{$info{data}}; + my %versions; + for my $version (make_list($param{fixed})) { + next unless defined $version; + $versions{$version} = + [make_source_versions(package => [splitpackages($data[0]{package})], + warnings => $transcript, + debug => $debug, + guess_source => 0, + versions => $version, + ) + ]; + # This is really ugly, but it's what we have to do + if (not @{$versions{$version}}) { + print {$transcript} "Unable to make a source version for version '$version'\n"; + } + } + if (not keys %versions and ($param{remove} or $param{add})) { + if ($param{remove}) { + print {$transcript} "Requested to remove no versions; doing nothing.\n"; + } + else { + print {$transcript} "Requested to add no versions; doing nothing.\n"; + } + __end_control(%info); + return; + } + # first things first, make the versions fully qualified source + # versions + for my $data (@data) { + my $old_data = dclone($data); + # The 'done' field gets a bit weird with version tracking, + # because a bug may be closed by multiple people in different + # branches. Until we have something more flexible, we set it + # every time a bug is fixed, and clear it when a bug is found + # in a version greater than any version in which the bug is + # fixed or when a bug is found and there is no fixed version + my $action = 'Did not alter fixed versions'; + my %found_added = (); + my %found_removed = (); + my %fixed_added = (); + my %fixed_removed = (); + my $reopened = 0; + if (not $param{add} and not $param{remove}) { + $fixed_removed{$_} = 1 for @{$data->{fixed_versions}}; + $data->{fixed_versions} = []; + } + my %found_versions; + @found_versions{@{$data->{found_versions}||[]}} = (1) x @{$data->{found_versions}||[]}; + my %fixed_versions; + @fixed_versions{@{$data->{fixed_versions}||[]}} = (1) x @{$data->{fixed_versions}||[]}; + for my $version (keys %versions) { + if ($param{add}) { + my @svers = @{$versions{$version}}; + if (not @svers) { + @svers = $version; + } + else { + if (exists $fixed_versions{$version}) { + $fixed_removed{$version} = 1; + delete $fixed_versions{$version}; + } + } + for my $sver (@svers) { + if (not exists $fixed_versions{$sver}) { + $fixed_versions{$sver} = 1; + $fixed_added{$sver} = 1; + } + } + } + elsif ($param{remove}) { + # in the case of removal, we only concern ourself with + # the version passed, not the source version it maps + # to + my @temp = grep m{(?:^|\/)\Q$version\E$}, keys %fixed_versions; + delete $fixed_versions{$_} for @temp; + $fixed_removed{$_} = 1 for @temp; + } + else { + # set the keys to exactly these values + my @svers = @{$versions{$version}}; + if (not @svers) { + @svers = $version; + } + for my $sver (@svers) { + if (not exists $fixed_versions{$sver}) { + $fixed_versions{$sver} = 1; + if (exists $fixed_removed{$sver}) { + delete $fixed_removed{$sver}; + } + else { + $fixed_added{$sver} = 1; + } + } + } + } + } + + $data->{found_versions} = [keys %found_versions]; + $data->{fixed_versions} = [keys %fixed_versions]; + + # If we're supposed to consider reopening, reopen if the + # fixed versions are empty or the greatest found version + # is greater than the greatest fixed version + if ($param{reopen} and defined $data->{done} + and length $data->{done}) { + my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);} + map {m{([^/]+)$}; $1;} @{$data->{found_versions}}; + # determine if we need to reopen + my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);} + map {m{([^/]+)$}; $1;} @{$data->{fixed_versions}}; + if (not @fixed_order or + (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) { + $reopened = 1; + $data->{done} = ''; + } + } + + my @changed; + push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added; + push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed; + push @changed, 'marked as fixed in versions '.english_join([keys %fixed_added]) if keys %fixed_added; + push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed; + $action = ucfirst(join ('; ',@changed)) if @changed; + if ($reopened) { + $action .= " and reopened" + } + if (not $reopened and not @changed) { + print {$transcript} "Ignoring request to alter fixed versions of bug #$data->{bug_num} to the same values previously set\n"; + next; + } + $action .= '.'; + append_action_to_log(bug => $data->{bug_num}, + command => 'fixed', + new_data => $data, + old_data => $old_data, + get_lock => 0, + __return_append_to_log_options( + %param, + action => $action, + ), + ) + if not exists $param{append_log} or $param{append_log}; + writebug($data->{bug_num},$data); + print {$transcript} "$action\n"; + } + __end_control(%info); +} + + +=head2 set_merged + + eval { + set_merged(bug => $ref, + transcript => $transcript, + ($dl > 0 ? (debug => $transcript):()), + requester => $header{from}, + request_addr => $controlrequestaddr, + message => \@log, + affected_packages => \%affected_packages, + recipients => \%recipients, + merge_with => 12345, + add => 1, + force => 1, + allow_reassign => 1, + reassign_same_source_only => 1, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to set merged on $ref: $@"; + } + + +Sets, adds, or removes the specified merged bugs of a bug + +By default, requires + +=cut + +sub set_merged { + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + # specific options here + merge_with => {type => ARRAYREF|SCALAR, + optional => 1, + }, + remove => {type => BOOLEAN, + default => 0, + }, + force => {type => BOOLEAN, + default => 0, + }, + masterbug => {type => BOOLEAN, + default => 0, + }, + allow_reassign => {type => BOOLEAN, + default => 0, + }, + reassign_different_sources => {type => BOOLEAN, + default => 1, + }, + %common_options, + %append_action_options, + }, + ); + my @merging = exists $param{merge_with} ? make_list($param{merge_with}):(); + my %merging; + @merging{@merging} = (1) x @merging; + if (grep {$_ !~ /^\d+$/} @merging) { + croak "Requested to merge with a non-numeric bug: ".join(',',map {qq('$_');} @merging); + } + $param{locks} = {} if not exists $param{locks}; + my %info = + __begin_control(%param, + command => 'merge' + ); + my ($debug,$transcript) = + @info{qw(debug transcript)}; + if (not @merging and exists $param{merge_with}) { + print {$transcript} "Requested to merge with no additional bugs; not doing anything\n"; + __end_control(%info); + return; + } + my @data = @{$info{data}}; + my %data; + my %merged_bugs; + for my $data (@data) { + $data{$data->{bug_num}} = $data; + my @merged_bugs = split / /, $data->{mergedwith}; + @merged_bugs{@merged_bugs} = (1) x @merged_bugs; + } + # handle unmerging + my $new_locks = 0; + if (not exists $param{merge_with}) { + delete $merged_bugs{$param{bug}}; + if (not keys %merged_bugs) { + print {$transcript} "Ignoring request to unmerge a bug which is not merged with any others.\n"; + __end_control(%info); + return; + } + my $action = "Disconnected #$param{bug} from all other report(s)."; + for my $data (@data) { + my $old_data = dclone($data); + if ($data->{bug_num} == $param{bug}) { + $data->{mergedwith} = ''; + } + else { + $data->{mergedwith} = + join(' ', + sort {$a <=> $b} + grep {$_ != $data->{bug_num}} + keys %merged_bugs); + } + append_action_to_log(bug => $data->{bug_num}, + command => 'merge', + new_data => $data, + old_data => $old_data, + get_lock => 0, + __return_append_to_log_options(%param, + action => $action, + ), + ) + if not exists $param{append_log} or $param{append_log}; + writebug($data->{bug_num},$data); + } + print {$transcript} "$action\n"; + __end_control(%info); + return; + } + # lock and load all of the bugs we need + my ($data,$n_locks) = + __lock_and_load_merged_bugs(bugs_to_load => [keys %merging], + data => \@data, + locks => $param{locks}, + debug => $debug, + ); + $new_locks += $n_locks; + %data = %{$data}; + @data = values %data; + if (not check_limit(data => [@data], + exists $param{limit}?(limit => $param{limit}):(), + transcript => $transcript, + )) { + die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data); + } + for my $data (@data) { + $data{$data->{bug_num}} = $data; + $merged_bugs{$data->{bug_num}} = 1; + my @merged_bugs = split / /, $data->{mergedwith}; + @merged_bugs{@merged_bugs} = (1) x @merged_bugs; + if (exists $param{affected_bugs}) { + $param{affected_bugs}{$data->{bug_num}} = 1; + } + } + __handle_affected_packages(%param,data => [@data]); + my %bug_info_shown; # which bugs have had information shown + $bug_info_shown{$param{bug}} = 1; + add_recipients(data => [@data], + recipients => $param{recipients}, + (exists $param{command}?(actions_taken => {$param{command} => 1}):()), + debug => $debug, + (__internal_request()?(transcript => $transcript):()), + ); + + # Figure out what the ideal state is for the bug, + my ($merge_status,$bugs_to_merge) = + __calculate_merge_status(\@data,\%data,$param{bug}); + # find out if we actually have any bugs to merge + if (not $bugs_to_merge) { + print {$transcript} "Requested to merge with no additional bugs; not doing anything\n"; + for (1..$new_locks) { + unfilelock($param{locks}); + $locks--; + } + __end_control(%info); + return; + } + # see what changes need to be made to merge the bugs + # check to make sure that the set of changes we need to make is allowed + my ($disallowed_changes,$changes) = + __calculate_merge_changes(\@data,$merge_status,\%param); + # at this point, stop if there are disallowed changes, otherwise + # make the allowed changes, and then reread the bugs in question + # to get the new data, then recaculate the merges; repeat + # reloading and recalculating until we try too many times or there + # are no changes to make. + + my $attempts = 0; + # we will allow at most 4 times through this; more than 1 + # shouldn't really happen. + my %bug_changed; + while ($attempts < 4 and (@{$disallowed_changes} or keys %{$changes})) { + if ($attempts > 1) { + print {$transcript} "Unable to complete merge on previous attempt; trying again (retry: $attempts)\n"; + } + if (@{$disallowed_changes}) { + # figure out the problems + print {$transcript} "Unable to merge bugs because:\n"; + for my $change (@{$disallowed_changes}) { + print {$transcript} "$change->{field} of #$change->{bug} is '$change->{text_orig_value}' not '$change->{text_value}'\n"; + } + if ($attempts > 0) { + __end_control(%info); + croak "Some bugs were altered while attempting to merge"; + } + else { + __end_control(%info); + croak "Did not alter merged bugs"; + } + } + my @bugs_to_change = keys %{$changes}; + for my $change_bug (@bugs_to_change) { + next unless exists $changes->{$change_bug}; + $bug_changed{$change_bug}++; + print {$transcript} __bug_info($data{$change_bug}) if + $param{show_bug_info} and not __internal_request(1); + $bug_info_shown{$change_bug} = 1; + __allow_relocking($param{locks},[keys %data]); + eval { + for my $change (@{$changes->{$change_bug}}) { + if ($change->{field} eq 'blockedby' or $change->{field} eq 'blocks') { + my %target_blockedby; + @target_blockedby{@{$change->{func_value}}} = (1) x @{$change->{func_value}}; + my %unhandled_targets = %target_blockedby; + for my $key (split / /,$change->{orig_value}) { + delete $unhandled_targets{$key}; + next if exists $target_blockedby{$key}; + set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug}, + block => $change->{field} eq 'blocks' ? $change->{bug} : $key, + remove => 1, + hash_slice(%param, + keys %common_options, + keys %append_action_options), + ); + } + for my $key (keys %unhandled_targets) { + set_blocks(bug => $change->{field} eq 'blocks' ? $key : $change->{bug}, + block => $change->{field} eq 'blocks' ? $change->{bug} : $key, + add => 1, + hash_slice(%param, + keys %common_options, + keys %append_action_options), + ); + } + } + else { + $change->{function}->(bug => $change->{bug}, + $change->{key}, $change->{func_value}, + exists $change->{options}?@{$change->{options}}:(), + hash_slice(%param, + keys %common_options, + keys %append_action_options), + ); + } + } + }; + if ($@) { + __disallow_relocking($param{locks}); + __end_control(%info); + croak "Failure while trying to adjust bugs, please report this as a bug: $@"; + } + __disallow_relocking($param{locks}); + my ($data,$n_locks) = + __lock_and_load_merged_bugs(bugs_to_load => [keys %merging], + data => \@data, + locks => $param{locks}, + debug => $debug, + reload_all => 1, + ); + $new_locks += $n_locks; + $locks += $n_locks; + %data = %{$data}; + @data = values %data; + ($merge_status,$bugs_to_merge) = + __calculate_merge_status(\@data,\%data,$param{bug},$merge_status); + ($disallowed_changes,$changes) = + __calculate_merge_changes(\@data,$merge_status,\%param); + $attempts = max(values %bug_changed); + } + } + if ($param{show_bug_info} and not __internal_request(1)) { + for my $data (sort {$a->{bug_num} <=> $b->{bug_num}} @data) { + next if $bug_info_shown{$data->{bug_num}}; + print {$transcript} __bug_info($data); + } + } + if (keys %{$changes} or @{$disallowed_changes}) { + print {$transcript} "After four attempts, the following changes were unable to be made:\n"; + for (1..$new_locks) { + unfilelock($param{locks}); + $locks--; + } + __end_control(%info); + for my $change ((map {@{$_}} values %{$changes}), @{$disallowed_changes}) { + print {$transcript} "$change->{field} of #$change->{bug} is '$change->{text_orig_value}' not '$change->{text_value}'\n"; + } + die "Unable to modify bugs so they could be merged"; + return; + } + + # finally, we can merge the bugs + my $action = "Merged ".join(' ',sort { $a <=> $b } keys %merged_bugs); + for my $data (@data) { + my $old_data = dclone($data); + $data->{mergedwith} = + join(' ', + sort { $a <=> $b } + grep {$_ != $data->{bug_num}} + keys %merged_bugs); + append_action_to_log(bug => $data->{bug_num}, + command => 'merge', + new_data => $data, + old_data => $old_data, + get_lock => 0, + __return_append_to_log_options(%param, + action => $action, + ), + ) + if not exists $param{append_log} or $param{append_log}; + writebug($data->{bug_num},$data); + } + print {$transcript} "$action\n"; + # unlock the extra locks that we got earlier + for (1..$new_locks) { + unfilelock($param{locks}); + $locks--; + } + __end_control(%info); +} + +sub __allow_relocking{ + my ($locks,$bugs) = @_; + + my @locks = (@{$bugs},'merge'); + for my $lock (@locks) { + my @lockfiles = grep {m{/\Q$lock\E$}} keys %{$locks->{locks}}; + next unless @lockfiles; + $locks->{relockable}{$lockfiles[0]} = 0; + } +} + +sub __disallow_relocking{ + my ($locks) = @_; + delete $locks->{relockable}; +} + +sub __lock_and_load_merged_bugs{ + my %param = + validate_with(params => \@_, + spec => + {bugs_to_load => {type => ARRAYREF, + default => sub {[]}, + }, + data => {type => HASHREF|ARRAYREF, + }, + locks => {type => HASHREF, + default => sub {{};}, + }, + reload_all => {type => BOOLEAN, + default => 0, + }, + debug => {type => HANDLE, + }, + }, + ); + my %data; + my $new_locks = 0; + if (ref($param{data}) eq 'ARRAY') { + for my $data (@{$param{data}}) { + $data{$data->{bug_num}} = dclone($data); + } + } + else { + %data = %{dclone($param{data})}; + } + my @bugs_to_load = @{$param{bugs_to_load}}; + if ($param{reload_all}) { + push @bugs_to_load, keys %data; + } + my %temp; + @temp{@bugs_to_load} = (1) x @bugs_to_load; + @bugs_to_load = keys %temp; + my %loaded_this_time; + my $bug_to_load; + while ($bug_to_load = shift @bugs_to_load) { + if (not $param{reload_all}) { + next if exists $data{$bug_to_load}; + } + else { + next if $loaded_this_time{$bug_to_load}; + } + my $lock_bug = 1; + if ($param{reload_all}) { + if (exists $data{$bug_to_load}) { + $lock_bug = 0; + } + } + my $data = + read_bug(bug => $bug_to_load, + lock => $lock_bug, + locks => $param{locks}, + ) or + die "Unable to load bug $bug_to_load"; + print {$param{debug}} "read bug $bug_to_load\n"; + $data{$data->{bug_num}} = $data; + $new_locks += $lock_bug; + $loaded_this_time{$data->{bug_num}} = 1; + push @bugs_to_load, + grep {not exists $data{$_}} + split / /,$data->{mergedwith}; + } + return (\%data,$new_locks); +} + + +sub __calculate_merge_status{ + my ($data_a,$data_h,$master_bug,$merge_status) = @_; + my %merge_status = %{$merge_status // {}}; + my %merged_bugs; + my $bugs_to_merge = 0; + for my $data (@{$data_a}) { + # check to see if this bug is unmerged in the set + if (not length $data->{mergedwith} or + grep {not exists $merged_bugs{$_}} split / /,$data->{mergedwith}) { + $merged_bugs{$data->{bug_num}} = 1; + $bugs_to_merge = 1; + } + } + for my $data (@{$data_a}) { + # the master_bug is the bug that every other bug is made to + # look like. However, if merge is set, tags, fixed and found + # are merged. + if ($data->{bug_num} == $master_bug) { + for (qw(package forwarded severity done owner summary outlook affects)) { + $merge_status{$_} = $data->{$_} + } + # bugs which are in the newly merged set and are also + # blocks/blockedby must be removed before merging + for (qw(blocks blockedby)) { + $merge_status{$_} = + join(' ',grep {not exists $merged_bugs{$_}} + split / /,$data->{$_}); + } + } + if (defined $merge_status) { + next unless $data->{bug_num} == $master_bug; + } + $merge_status{tag} = {} if not exists $merge_status{tag}; + for my $tag (split /\s+/, $data->{keywords}) { + $merge_status{tag}{$tag} = 1; + } + $merge_status{keywords} = join(' ',sort keys %{$merge_status{tag}}); + for (qw(fixed found)) { + @{$merge_status{"${_}_versions"}}{@{$data->{"${_}_versions"}}} = (1) x @{$data->{"${_}_versions"}}; + } + } + # if there is a non-source qualified version with a corresponding + # source qualified version, we only want to merge the source + # qualified version(s) + for (qw(fixed found)) { + my @unqualified_versions = grep {m{/}?0:1} keys %{$merge_status{"${_}_versions"}}; + for my $unqualified_version (@unqualified_versions) { + if (grep {m{/\Q$unqualified_version\E}} keys %{$merge_status{"${_}_versions"}}) { + delete $merge_status{"${_}_versions"}{$unqualified_version}; + } + } + } + return (\%merge_status,$bugs_to_merge); +} + + + +sub __calculate_merge_changes{ + my ($datas,$merge_status,$param) = @_; + my %changes; + my @disallowed_changes; + for my $data (@{$datas}) { + # things that can be forced + # + # * func is the function to set the new value + # + # * key is the key of the function to set the value, + + # * modify_value is a function which is called to modify the new + # value so that the function will accept it + + # * options is an ARRAYREF of options to pass to the function + + # * allowed is a BOOLEAN which controls whether this setting + # is allowed to be different by default. + my %force_functions = + (forwarded => {func => \&set_forwarded, + key => 'forwarded', + options => [], + }, + severity => {func => \&set_severity, + key => 'severity', + options => [], + }, + blocks => {func => \&set_blocks, + modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]}, + key => 'block', + options => [], + }, + blockedby => {func => \&set_blocks, + modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]}, + key => 'block', + options => [], + }, + done => {func => \&set_done, + key => 'done', + options => [], + }, + owner => {func => \&owner, + key => 'owner', + options => [], + }, + summary => {func => \&summary, + key => 'summary', + options => [], + }, + outlook => {func => \&outlook, + key => 'outlook', + options => [], + }, + affects => {func => \&affects, + key => 'package', + options => [], + }, + package => {func => \&set_package, + key => 'package', + options => [], + }, + keywords => {func => \&set_tag, + key => 'tag', + modify_value => sub {defined $_[0]?[sort split /\s+/,$_[0]]:[]}, + allowed => 1, + }, + fixed_versions => {func => \&set_fixed, + key => 'fixed', + modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]}, + allowed => 1, + }, + found_versions => {func => \&set_found, + key => 'found', + modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]}, + allowed => 1, + }, + ); + for my $field (qw(forwarded severity blocks blockedby done owner summary outlook affects package fixed_versions found_versions keywords)) { + # if the ideal bug already has the field set properly, we + # continue on. + if ($field eq 'keywords'){ + next if join(' ',sort split /\s+/,$data->{keywords}) eq + join(' ',sort keys %{$merge_status->{tag}}); + } + elsif ($field =~ /^(?:fixed|found)_versions$/) { + next if join(' ', sort @{$data->{$field}}) eq + join(' ',sort keys %{$merge_status->{$field}}); + } + elsif ($field eq 'done') { + # for done, we only care if the bug is done or not + # done, not the value it's set to. + if (defined $merge_status->{$field} and length $merge_status->{$field} and + defined $data->{$field} and length $data->{$field}) { + next; + } + elsif ((not defined $merge_status->{$field} or not length $merge_status->{$field}) and + (not defined $data->{$field} or not length $data->{$field}) + ) { + next; + } + } + elsif ($merge_status->{$field} eq $data->{$field}) { + next; + } + my $change = + {field => $field, + bug => $data->{bug_num}, + orig_value => $data->{$field}, + func_value => + (exists $force_functions{$field}{modify_value} ? + $force_functions{$field}{modify_value}->($merge_status->{$field}): + $merge_status->{$field}), + value => $merge_status->{$field}, + function => $force_functions{$field}{func}, + key => $force_functions{$field}{key}, + options => $force_functions{$field}{options}, + allowed => exists $force_functions{$field}{allowed} ? $force_functions{$field}{allowed} : 0, + }; + $change->{text_value} = ref($change->{func_value}) eq 'ARRAY'?join(' ',@{$change->{func_value}}):$change->{func_value}; + $change->{text_orig_value} = ref($change->{orig_value}) eq 'ARRAY'?join(' ',@{$change->{orig_value}}):$change->{orig_value}; + if ($param->{force} or $change->{allowed}) { + if ($field ne 'package' or $change->{allowed}) { + push @{$changes{$data->{bug_num}}},$change; + next; + } + if ($param->{allow_reassign}) { + if ($param->{reassign_different_sources}) { + push @{$changes{$data->{bug_num}}},$change; + next; + } + # allow reassigning if binary_to_source returns at + # least one of the same source packages + my @merge_status_source = + binary_to_source(package => $merge_status->{package}, + source_only => 1, + ); + my @other_bug_source = + binary_to_source(package => $data->{package}, + source_only => 1, + ); + my %merge_status_sources; + @merge_status_sources{@merge_status_source} = + (1) x @merge_status_source; + if (grep {$merge_status_sources{$_}} @other_bug_source) { + push @{$changes{$data->{bug_num}}},$change; + next; + } + } + } + push @disallowed_changes,$change; + } + # blocks and blocked by are weird; we have to go through and + # set blocks to the other half of the merged bugs + } + return (\@disallowed_changes,\%changes); +} + +=head2 affects + + eval { + affects(bug => $ref, + transcript => $transcript, + ($dl > 0 ? (debug => $transcript):()), + requester => $header{from}, + request_addr => $controlrequestaddr, + message => \@log, + affected_packages => \%affected_packages, + recipients => \%recipients, + packages => undef, + add => 1, + remove => 0, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to mark $ref as affecting $packages: $@"; + } + +This marks a bug as affecting packages which the bug is not actually +in. This should only be used in cases where fixing the bug instantly +resolves the problem in the other packages. + +By default, the packages are set to the list of packages passed. +However, if you pass add => 1 or remove => 1, the list of packages +passed are added or removed from the affects list, respectively. + +=cut + +sub affects { + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + # specific options here + package => {type => SCALAR|ARRAYREF|UNDEF, + default => [], + }, + add => {type => BOOLEAN, + default => 0, + }, + remove => {type => BOOLEAN, + default => 0, + }, + %common_options, + %append_action_options, + }, + ); + if ($param{add} and $param{remove}) { + croak "Asking to both add and remove affects is nonsensical"; + } + if (not defined $param{package}) { + $param{package} = []; + } + my %info = + __begin_control(%param, + command => 'affects' + ); + my ($debug,$transcript) = + @info{qw(debug transcript)}; + my @data = @{$info{data}}; + my $action = ''; + for my $data (@data) { + $action = ''; + print {$debug} "Going to change affects\n"; + my @packages = splitpackages($data->{affects}); + my %packages; + @packages{@packages} = (1) x @packages; + if ($param{add}) { + my @added = (); + for my $package (make_list($param{package})) { + next unless defined $package and length $package; + if (not $packages{$package}) { + $packages{$package} = 1; + push @added,$package; + } + } + if (@added) { + $action = "Added indication that $data->{bug_num} affects ". + english_join(\@added); + } + } + elsif ($param{remove}) { + my @removed = (); + for my $package (make_list($param{package})) { + if ($packages{$package}) { + next unless defined $package and length $package; + delete $packages{$package}; + push @removed,$package; + } + } + $action = "Removed indication that $data->{bug_num} affects " . + english_join(\@removed); + } + else { + my %added_packages = (); + my %removed_packages = %packages; + %packages = (); + for my $package (make_list($param{package})) { + next unless defined $package and length $package; + $packages{$package} = 1; + delete $removed_packages{$package}; + $added_packages{$package} = 1; + } + if (keys %removed_packages) { + $action = "Removed indication that $data->{bug_num} affects ". + english_join([keys %removed_packages]); + $action .= "\n" if keys %added_packages; + } + if (keys %added_packages) { + $action .= "Added indication that $data->{bug_num} affects " . + english_join([keys %added_packages]); + } + } + if (not length $action) { + print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n"; + next; + } + my $old_data = dclone($data); + $data->{affects} = join(',',keys %packages); + append_action_to_log(bug => $data->{bug_num}, + get_lock => 0, + command => 'affects', + new_data => $data, + old_data => $old_data, + __return_append_to_log_options( + %param, + action => $action, + ), + ) + if not exists $param{append_log} or $param{append_log}; + writebug($data->{bug_num},$data); + print {$transcript} "$action\n"; + } + __end_control(%info); +} + + +=head1 SUMMARY FUNCTIONS + +=head2 summary + + eval { + summary(bug => $ref, + transcript => $transcript, + ($dl > 0 ? (debug => $transcript):()), + requester => $header{from}, + request_addr => $controlrequestaddr, + message => \@log, + affected_packages => \%affected_packages, + recipients => \%recipients, + summary => undef, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to mark $ref with summary foo: $@"; + } + +Handles all setting of summary fields + +If summary is undef, unsets the summary + +If summary is 0 or -1, sets the summary to the first paragraph contained in +the message passed. + +If summary is a positive integer, sets the summary to the message specified. + +Otherwise, sets summary to the value passed. + +=cut + + +sub summary { + # outlook and summary are exactly the same, basically + return _summary('summary',@_); +} + +=head1 OUTLOOK FUNCTIONS + +=head2 outlook + + eval { + outlook(bug => $ref, + transcript => $transcript, + ($dl > 0 ? (debug => $transcript):()), + requester => $header{from}, + request_addr => $controlrequestaddr, + message => \@log, + affected_packages => \%affected_packages, + recipients => \%recipients, + outlook => undef, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to mark $ref with outlook foo: $@"; + } + +Handles all setting of outlook fields + +If outlook is undef, unsets the outlook + +If outlook is 0, sets the outlook to the first paragraph contained in +the message passed. + +If outlook is a positive integer, sets the outlook to the message specified. + +Otherwise, sets outlook to the value passed. + +=cut + + +sub outlook { + return _summary('outlook',@_); +} + +sub _summary { + my ($cmd,@params) = @_; + my %param = validate_with(params => \@params, + spec => {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + # specific options here + $cmd , {type => SCALAR|UNDEF, + default => 0, + }, + %common_options, + %append_action_options, + }, + ); + my %info = + __begin_control(%param, + command => $cmd, + ); + my ($debug,$transcript) = + @info{qw(debug transcript)}; + my @data = @{$info{data}}; + # figure out the log that we're going to use + my $summary = ''; + my $summary_msg = ''; + my $action = ''; + if (not defined $param{$cmd}) { + # do nothing + print {$debug} "Removing $cmd fields\n"; + $action = "Removed $cmd"; + } + elsif ($param{$cmd} =~ /^-?\d+$/) { + my $log = []; + my @records = Debbugs::Log::read_log_records(bug_num => $param{bug}); + if ($param{$cmd} == 0 or $param{$cmd} == -1) { + $log = $param{message}; + $summary_msg = @records + 1; + } + else { + if (($param{$cmd} - 1 ) > $#records) { + die "Message number '$param{$cmd}' exceeds the maximum message '$#records'"; + } + my $record = $records[($param{$cmd} - 1 )]; + if ($record->{type} !~ /incoming-recv|recips/) { + die "Message number '$param{$cmd}' is a invalid message type '$record->{type}'"; + } + $summary_msg = $param{$cmd}; + $log = [$record->{text}]; + } + my $p_o = Debbugs::MIME::parse(join('',@{$log})); + my $body = $p_o->{body}; + my $in_pseudoheaders = 0; + my $paragraph = ''; + # walk through body until we get non-blank lines + for my $line (@{$body}) { + if ($line =~ /^\s*$/) { + if (length $paragraph) { + if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) { + $paragraph = ''; + next; + } + last; + } + $in_pseudoheaders = 0; + next; + } + # skip a paragraph if it looks like it's control or + # pseudo-headers + if ($line =~ m{^\s*(?:Package|Source|Version|User|Tag|Severity|Control)\:\s+\S}xi or #pseudo headers + $line =~ m{^(?:package:?|(?:no|)owner|severity|tags?|summary| #control + \#|reopen|close|(?:not|)(?:fixed|found)|clone| + debug|(?:not|)forwarded|priority| + (?:un|)block|limit|(?:un|)archive| + reassign|retitle|affects|package| + outlook| + (?:un|force|)merge|user(?:category|tags?|) + )\s+\S}xis) { + if (not length $paragraph) { + print {$debug} "Found control/pseudo-headers and skiping them\n"; + $in_pseudoheaders = 1; + next; + } + } + next if $in_pseudoheaders; + $paragraph .= $line ." \n"; + } + print {$debug} ucfirst($cmd)." is going to be '$paragraph'\n"; + $summary = $paragraph; + $summary =~ s/[\n\r]/ /g; + if (not length $summary) { + die "Unable to find $cmd message to use"; + } + # trim off a trailing spaces + $summary =~ s/\ *$//; + } + else { + $summary = $param{$cmd}; + } + for my $data (@data) { + print {$debug} "Going to change $cmd\n"; + if (((not defined $summary or not length $summary) and + (not defined $data->{$cmd} or not length $data->{$cmd})) or + $summary eq $data->{$cmd}) { + print {$transcript} "Ignoring request to change the $cmd of bug $param{bug} to the same value\n"; + next; + } + if (length $summary) { + if (length $data->{$cmd}) { + $action = ucfirst($cmd)." replaced with message bug $param{bug} message $summary_msg"; + } + else { + $action = ucfirst($cmd)." recorded from message bug $param{bug} message $summary_msg"; + } + } + my $old_data = dclone($data); + $data->{$cmd} = $summary; + append_action_to_log(bug => $data->{bug_num}, + command => $cmd, + old_data => $old_data, + new_data => $data, + get_lock => 0, + __return_append_to_log_options( + %param, + action => $action, + ), + ) + if not exists $param{append_log} or $param{append_log}; + writebug($data->{bug_num},$data); + print {$transcript} "$action\n"; + } + __end_control(%info); +} + + + +=head2 clone_bug + + eval { + clone_bug(bug => $ref, + transcript => $transcript, + ($dl > 0 ? (debug => $transcript):()), + requester => $header{from}, + request_addr => $controlrequestaddr, + message => \@log, + affected_packages => \%affected_packages, + recipients => \%recipients, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to clone bug $ref bar: $@"; + } + +Clones the given bug. + +We currently don't support cloning merged bugs, but this could be +handled by internally unmerging, cloning, then remerging the bugs. + +=cut + +sub clone_bug { + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + new_bugs => {type => ARRAYREF, + }, + new_clones => {type => HASHREF, + default => {}, + }, + %common_options, + %append_action_options, + }, + ); + my %info = + __begin_control(%param, + command => 'clone' + ); + my $transcript = $info{transcript}; + my @data = @{$info{data}}; + + my $action = ''; + for my $data (@data) { + if (length($data->{mergedwith})) { + die "Bug is marked as being merged with others. Use an existing clone.\n"; + } + } + if (@data != 1) { + die "Not exactly one bug‽ This shouldn't happen."; + } + my $data = $data[0]; + my %clones; + for my $newclone_id (@{$param{new_bugs}}) { + my $new_bug_num = new_bug(copy => $data->{bug_num}); + $param{new_clones}{$newclone_id} = $new_bug_num; + $clones{$newclone_id} = $new_bug_num; + } + my @new_bugs = sort values %clones; + my @collapsed_ids; + for my $new_bug (@new_bugs) { + # no collapsed ids or the higher collapsed id is not one less + # than the next highest new bug + if (not @collapsed_ids or + $collapsed_ids[-1][1]+1 != $new_bug) { + push @collapsed_ids,[$new_bug,$new_bug]; + } + else { + $collapsed_ids[-1][1] = $new_bug; + } + } + my @collapsed; + for my $ci (@collapsed_ids) { + if ($ci->[0] == $ci->[1]) { + push @collapsed,$ci->[0]; + } + else { + push @collapsed,$ci->[0].'-'.$ci->[1] + } + } + my $collapsed_str = english_join(\@collapsed); + $action = "Bug $data->{bug_num} cloned as bug".(@new_bugs > 1?'s':'').' '.$collapsed_str; + for my $new_bug (@new_bugs) { + append_action_to_log(bug => $new_bug, + get_lock => 1, + __return_append_to_log_options( + %param, + action => $action, + ), + ) + if not exists $param{append_log} or $param{append_log}; + } + append_action_to_log(bug => $data->{bug_num}, + get_lock => 0, + __return_append_to_log_options( + %param, + action => $action, + ), + ) + if not exists $param{append_log} or $param{append_log}; + writebug($data->{bug_num},$data); + print {$transcript} "$action\n"; + __end_control(%info); + # bugs that this bug is blocking are also blocked by the new clone(s) + for my $bug (split ' ', $data->{blocks}) { + for my $new_bug (@new_bugs) { + set_blocks(bug => $bug, + block => $new_bug, + add => 1, + hash_slice(%param, + keys %common_options, + keys %append_action_options), + ); + } + } + # bugs that are blocking this bug are also blocking the new clone(s) + for my $bug (split ' ', $data->{blockedby}) { + for my $new_bug (@new_bugs) { + set_blocks(bug => $new_bug, + block => $bug, + add => 1, + hash_slice(%param, + keys %common_options, + keys %append_action_options), + ); + } + } +} + + + +=head1 OWNER FUNCTIONS + +=head2 owner + + eval { + owner(bug => $ref, + transcript => $transcript, + ($dl > 0 ? (debug => $transcript):()), + requester => $header{from}, + request_addr => $controlrequestaddr, + message => \@log, + recipients => \%recipients, + owner => undef, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to mark $ref as having an owner: $@"; + } + +Handles all setting of the owner field; given an owner of undef or of +no length, indicates that a bug is not owned by anyone. + +=cut + +sub owner { + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + owner => {type => SCALAR|UNDEF, + }, + %common_options, + %append_action_options, + }, + ); + my %info = + __begin_control(%param, + command => 'owner', + ); + my ($debug,$transcript) = + @info{qw(debug transcript)}; + my @data = @{$info{data}}; + my $action = ''; + for my $data (@data) { + print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n"; + print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n"; + if (not defined $param{owner} or not length $param{owner}) { + if (not defined $data->{owner} or not length $data->{owner}) { + print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n"; + next; + } + $param{owner} = ''; + $action = "Removed annotation that $config{bug} was owned by " . + "$data->{owner}."; + } + else { + if ($data->{owner} eq $param{owner}) { + print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n"; + next; + } + if (length $data->{owner}) { + $action = "Owner changed from $data->{owner} to $param{owner}."; + } + else { + $action = "Owner recorded as $param{owner}." + } + } + my $old_data = dclone($data); + $data->{owner} = $param{owner}; + append_action_to_log(bug => $data->{bug_num}, + command => 'owner', + new_data => $data, + old_data => $old_data, + get_lock => 0, + __return_append_to_log_options( + %param, + action => $action, + ), + ) + if not exists $param{append_log} or $param{append_log}; + writebug($data->{bug_num},$data); + print {$transcript} "$action\n"; + } + __end_control(%info); +} + + +=head1 ARCHIVE FUNCTIONS + + +=head2 bug_archive + + my $error = ''; + eval { + bug_archive(bug => $bug_num, + debug => \$debug, + transcript => \$transcript, + ); + }; + if ($@) { + $errors++; + transcript("Unable to archive $bug_num\n"); + warn $@; + } + transcript($transcript); + + +This routine archives a bug + +=over + +=item bug -- bug number + +=item check_archiveable -- check wether a bug is archiveable before +archiving; defaults to 1 + +=item archive_unarchived -- whether to archive bugs which have not +previously been archived; defaults to 1. [Set to 0 when used from +control@] + +=item ignore_time -- whether to ignore time constraints when archiving +a bug; defaults to 0. + +=back + +=cut + +sub bug_archive { + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + check_archiveable => {type => BOOLEAN, + default => 1, + }, + archive_unarchived => {type => BOOLEAN, + default => 1, + }, + ignore_time => {type => BOOLEAN, + default => 0, + }, + %common_options, + %append_action_options, + }, + ); + my %info = __begin_control(%param, + command => 'archive', + ); + my ($debug,$transcript) = @info{qw(debug transcript)}; + my @data = @{$info{data}}; + my @bugs = @{$info{bugs}}; + my $action = "$config{bug} archived."; + if ($param{check_archiveable} and + not bug_archiveable(bug=>$param{bug}, + ignore_time => $param{ignore_time}, + )) { + print {$transcript} "Bug $param{bug} cannot be archived\n"; + die "Bug $param{bug} cannot be archived"; + } + if (not $param{archive_unarchived} and + not exists $data[0]{unarchived} + ) { + print {$transcript} "$param{bug} has not been archived previously\n"; + die "$param{bug} has not been archived previously"; + } + add_recipients(recipients => $param{recipients}, + data => \@data, + debug => $debug, + transcript => $transcript, + ); + print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n"; + for my $bug (@bugs) { + if ($param{check_archiveable}) { + die "Bug $bug cannot be archived (but $param{bug} can?)" + unless bug_archiveable(bug=>$bug, + ignore_time => $param{ignore_time}, + ); + } + } + # If we get here, we can archive/remove this bug + print {$debug} "$param{bug} removing\n"; + for my $bug (@bugs) { + #print "$param{bug} removing $bug\n" if $debug; + my $dir = get_hashname($bug); + # First indicate that this bug is being archived + append_action_to_log(bug => $bug, + get_lock => 0, + command => 'archive', + # we didn't actually change the data + # when we archived, so we don't pass + # a real new_data or old_data + new_data => {}, + old_data => {}, + __return_append_to_log_options( + %param, + action => $action, + ) + ) + if not exists $param{append_log} or $param{append_log}; + my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*"); + if ($config{save_old_bugs}) { + mkpath("$config{spool_dir}/archive/$dir"); + foreach my $file (@files_to_remove) { + link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or + copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or + # we need to bail out here if things have + # gone horribly wrong to avoid removing a + # bug altogether + die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!"; + } + + print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n"; + } + unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove); + print {$debug} "deleted $bug (from $param{bug})\n"; + } + bughook_archive(@bugs); + __end_control(%info); +} + +=head2 bug_unarchive + + my $error = ''; + eval { + bug_unarchive(bug => $bug_num, + debug => \$debug, + transcript => \$transcript, + ); + }; + if ($@) { + $errors++; + transcript("Unable to archive bug: $bug_num"); + } + transcript($transcript); + +This routine unarchives a bug + +=cut + +sub bug_unarchive { + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+/, + }, + %common_options, + %append_action_options, + }, + ); + + my %info = __begin_control(%param, + archived=>1, + command=>'unarchive'); + my ($debug,$transcript) = + @info{qw(debug transcript)}; + my @bugs = @{$info{bugs}}; + my $action = "$config{bug} unarchived."; + my @files_to_remove; + ## error out if we're unarchiving unarchived bugs + for my $data (@{$info{data}}) { + if (not defined $data->{archived} or + not $data->{archived} + ) { + __end_control(%info); + croak("Bug $data->{bug_num} was not archived; not unarchiving it."); + } + } + for my $bug (@bugs) { + print {$debug} "$param{bug} removing $bug\n"; + my $dir = get_hashname($bug); + my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*"); + mkpath("archive/$dir"); + foreach my $file (@files_to_copy) { + # die'ing here sucks + link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or + copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or + die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file"; + } + push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy; + print {$transcript} "Unarchived $config{bug} $bug\n"; + } + unlink(@files_to_remove) or die "Unable to unlink bugs"; + # Indicate that this bug has been archived previously + for my $bug (@bugs) { + my $newdata = readbug($bug); + my $old_data = dclone($newdata); + if (not defined $newdata) { + print {$transcript} "$config{bug} $bug disappeared!\n"; + die "Bug $bug disappeared!"; + } + $newdata->{unarchived} = time; + append_action_to_log(bug => $bug, + get_lock => 0, + command => 'unarchive', + new_data => $newdata, + old_data => $old_data, + __return_append_to_log_options( + %param, + action => $action, + ) + ) + if not exists $param{append_log} or $param{append_log}; + writebug($bug,$newdata); + } + __end_control(%info); +} + +=head2 append_action_to_log + + append_action_to_log + +This should probably be moved to Debbugs::Log; have to think that out +some more. + +=cut + +sub append_action_to_log{ + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+/, + }, + new_data => {type => HASHREF, + optional => 1, + }, + old_data => {type => HASHREF, + optional => 1, + }, + command => {type => SCALAR, + optional => 1, + }, + action => {type => SCALAR, + }, + requester => {type => SCALAR, + default => '', + }, + request_addr => {type => SCALAR, + default => '', + }, + location => {type => SCALAR, + optional => 1, + }, + message => {type => SCALAR|ARRAYREF, + default => '', + }, + recips => {type => SCALAR|ARRAYREF, + optional => 1 + }, + desc => {type => SCALAR, + default => '', + }, + get_lock => {type => BOOLEAN, + default => 1, + }, + locks => {type => HASHREF, + optional => 1, + }, + # we don't use + # append_action_options here + # because some of these + # options aren't actually + # optional, even though the + # original function doesn't + # require them + }, + ); + # Fix this to use $param{location} + my $log_location = buglog($param{bug}); + die "Unable to find .log for $param{bug}" + if not defined $log_location; + if ($param{get_lock}) { + filelock("lock/$param{bug}",exists $param{locks}?$param{locks}:()); + $locks++; + } + my @records; + my $logfh = IO::File->new(">>$log_location") or + die "Unable to open $log_location for appending: $!"; + # determine difference between old and new + my $data_diff = ''; + if (exists $param{old_data} and exists $param{new_data}) { + my $old_data = dclone($param{old_data}); + my $new_data = dclone($param{new_data}); + for my $key (keys %{$old_data}) { + if (not exists $Debbugs::Status::fields{$key}) { + delete $old_data->{$key}; + next; + } + next unless exists $new_data->{$key}; + next unless defined $new_data->{$key}; + if (not defined $old_data->{$key}) { + delete $old_data->{$key}; + next; + } + if (ref($new_data->{$key}) and + ref($old_data->{$key}) and + ref($new_data->{$key}) eq ref($old_data->{$key})) { + local $Storable::canonical = 1; + if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) { + delete $new_data->{$key}; + delete $old_data->{$key}; + } + } + elsif ($new_data->{$key} eq $old_data->{$key}) { + delete $new_data->{$key}; + delete $old_data->{$key}; + } + } + for my $key (keys %{$new_data}) { + if (not exists $Debbugs::Status::fields{$key}) { + delete $new_data->{$key}; + next; + } + next unless exists $old_data->{$key}; + next unless defined $old_data->{$key}; + if (not defined $new_data->{$key} or + not exists $Debbugs::Status::fields{$key}) { + delete $new_data->{$key}; + next; + } + if (ref($new_data->{$key}) and + ref($old_data->{$key}) and + ref($new_data->{$key}) eq ref($old_data->{$key})) { + local $Storable::canonical = 1; + if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) { + delete $new_data->{$key}; + delete $old_data->{$key}; + } + } + elsif ($new_data->{$key} eq $old_data->{$key}) { + delete $new_data->{$key}; + delete $old_data->{$key}; + } + } + $data_diff .= "\n"; + $data_diff .= "\n"; + } + my $msg = join('', + (exists $param{command} ? + "\n":"" + ), + (length $param{requester} ? + "\n":"" + ), + (length $param{request_addr} ? + "\n":"" + ), + "\n", + $data_diff, + "".html_escape(encode_utf8_safely($param{action}))."\n"); + if (length $param{requester}) { + $msg .= "Request was from ".html_escape(encode_utf8_safely($param{requester}))."\n"; + } + if (length $param{request_addr}) { + $msg .= "to ".html_escape(encode_utf8_safely($param{request_addr})).""; + } + if (length $param{desc}) { + $msg .= ":
    \n".encode_utf8_safely($param{desc})."\n"; + } + else { + $msg .= ".\n"; + } + push @records, {type => 'html', + text => $msg, + }; + $msg = ''; + if ((ref($param{message}) and @{$param{message}}) or length($param{message})) { + push @records, {type => exists $param{recips}?'recips':'incoming-recv', + exists $param{recips}?(recips => [map {encode_utf8_safely($_)} make_list($param{recips})]):(), + text => join('',make_list($param{message})), + }; + } + write_log_records(logfh=>$logfh, + records => \@records, + ); + close $logfh or die "Unable to close $log_location: $!"; + if ($param{get_lock}) { + unfilelock(exists $param{locks}?$param{locks}:()); + $locks--; + } + + +} + + +=head1 PRIVATE FUNCTIONS + +=head2 __handle_affected_packages + + __handle_affected_packages(affected_packages => {}, + data => [@data], + ) + + + +=cut + +sub __handle_affected_packages{ + my %param = validate_with(params => \@_, + spec => {%common_options, + data => {type => ARRAYREF|HASHREF + }, + }, + allow_extra => 1, + ); + for my $data (make_list($param{data})) { + next unless exists $data->{package} and defined $data->{package}; + my @packages = split /\s*,\s*/,$data->{package}; + @{$param{affected_packages}}{@packages} = (1) x @packages; + } +} + +=head2 __handle_debug_transcript + + my ($debug,$transcript) = __handle_debug_transcript(%param); + +Returns a debug and transcript filehandle + + +=cut + +sub __handle_debug_transcript{ + my %param = validate_with(params => \@_, + spec => {%common_options}, + allow_extra => 1, + ); + my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef); + my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef); + return ($debug,$transcript); +} + +=head2 __bug_info + + __bug_info($data) + +Produces a small bit of bug information to kick out to the transcript + +=cut + +sub __bug_info{ + my $return = ''; + for my $data (@_) { + next unless defined $data and exists $data->{bug_num}; + $return .= "Bug #".($data->{bug_num}||''). + ((defined $data->{done} and length $data->{done})? + " {Done: $data->{done}}":'' + ). + " [".($data->{package}||'(no package)'). "] ". + ($data->{subject}||'(no subject)')."\n"; + } + return $return; +} + + +=head2 __internal_request + + __internal_request() + __internal_request($level) + +Returns true if the caller of the function calling __internal_request +belongs to __PACKAGE__ + +This allows us to be magical, and don't bother to print bug info if +the second caller is from this package, amongst other things. + +An optional level is allowed, which increments the number of levels to +check by the given value. [This is basically for use by internal +functions like __begin_control which are always called by +C<__PACKAGE__>. + +=cut + +sub __internal_request{ + my ($l) = @_; + $l = 0 if not defined $l; + if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) { + return 1; + } + return 0; +} + +sub __return_append_to_log_options{ + my %param = @_; + my $action = $param{action} if exists $param{action}; + if (not exists $param{requester}) { + $param{requester} = $config{control_internal_requester}; + } + if (not exists $param{request_addr}) { + $param{request_addr} = $config{control_internal_request_addr}; + } + if (not exists $param{message}) { + my $date = rfc822_date(); + $param{message} = + encode_headers(fill_in_template(template => 'mail/fake_control_message', + variables => {request_addr => $param{request_addr}, + requester => $param{requester}, + date => $date, + action => $action + }, + )); + } + if (not defined $action) { + carp "Undefined action!"; + $action = "unknown action"; + } + return (action => $action, + hash_slice(%param,keys %append_action_options), + ); +} + +=head2 __begin_control + + my %info = __begin_control(%param, + archived=>1, + command=>'unarchive'); + my ($debug,$transcript) = @info{qw(debug transcript)}; + my @data = @{$info{data}}; + my @bugs = @{$info{bugs}}; + + +Starts the process of modifying a bug; handles all of the generic +things that almost every control request needs + +Returns a hash containing + +=over + +=item new_locks -- number of new locks taken out by this call + +=item debug -- the debug file handle + +=item transcript -- the transcript file handle + +=item data -- an arrayref containing the data of the bugs +corresponding to this request + +=item bugs -- an arrayref containing the bug numbers of the bugs +corresponding to this request + +=back + +=cut + +our $lockhash; + +sub __begin_control { + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+/, + }, + archived => {type => BOOLEAN, + default => 0, + }, + command => {type => SCALAR, + optional => 1, + }, + %common_options, + }, + allow_extra => 1, + ); + my $new_locks; + my ($debug,$transcript) = __handle_debug_transcript(@_); + print {$debug} "considering bug $param{bug} for ".(exists $param{command}?$param{command}:scalar caller())."\n"; +# print {$debug} Data::Dumper->Dump([[caller(1)],\%param],[qw(caller param)])."\n"; + $lockhash = $param{locks} if exists $param{locks}; + my @data = (); + my $old_die = $SIG{__DIE__}; + $SIG{__DIE__} = *sig_die{CODE}; + + ($new_locks, @data) = + lock_read_all_merged_bugs(bug => $param{bug}, + $param{archived}?(location => 'archive'):(), + exists $param{locks} ? (locks => $param{locks}):(), + ); + $locks += $new_locks; + if (not @data) { + die "Unable to read any bugs successfully."; + } + if (not $param{archived}) { + for my $data (@data) { + if ($data->{archived}) { + die "Not altering archived bugs; see unarchive."; + } + } + } + if (not check_limit(data => \@data, + exists $param{limit}?(limit => $param{limit}):(), + transcript => $transcript, + )) { + die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data); + } + + __handle_affected_packages(%param,data => \@data); + print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1); + print {$debug} "$param{bug} read $locks locks\n"; + if (not @data or not defined $data[0]) { + print {$transcript} "No bug found for $param{bug}\n"; + die "No bug found for $param{bug}"; + } + + add_recipients(data => \@data, + recipients => $param{recipients}, + (exists $param{command}?(actions_taken => {$param{command} => 1}):()), + debug => $debug, + (__internal_request()?(transcript => $transcript):()), + ); + + print {$debug} "$param{bug} read done\n"; + my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data; + print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n"; + return (data => \@data, + bugs => \@bugs, + old_die => $old_die, + new_locks => $new_locks, + debug => $debug, + transcript => $transcript, + param => \%param, + exists $param{locks}?(locks => $param{locks}):(), + ); +} + +=head2 __end_control + + __end_control(%info); + +Handles tearing down from a control request + +=cut + +sub __end_control { + my %info = @_; + if (exists $info{new_locks} and $info{new_locks} > 0) { + print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n"; + for (1..$info{new_locks}) { + unfilelock(exists $info{locks}?$info{locks}:()); + $locks--; + } + } + $SIG{__DIE__} = $info{old_die}; + if (exists $info{param}{affected_bugs}) { + @{$info{param}{affected_bugs}}{@{$info{bugs}}} = (1) x @{$info{bugs}}; + } + add_recipients(recipients => $info{param}{recipients}, + (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()), + data => $info{data}, + debug => $info{debug}, + transcript => $info{transcript}, + ); + __handle_affected_packages(%{$info{param}},data=>$info{data}); +} + + +=head2 check_limit + + check_limit(data => \@data, limit => $param{limit}); + + +Checks to make sure that bugs match any limits; each entry of @data +much satisfy the limit. + +Returns true if there are no entries in data, or there are no keys in +limit; returns false (0) if there are any entries which do not match. + +The limit hashref elements can contain an arrayref of scalars to +match; regexes are also acccepted. At least one of the entries in each +element needs to match the corresponding field in all data for the +limit to succeed. + +=cut + + +sub check_limit{ + my %param = validate_with(params => \@_, + spec => {data => {type => ARRAYREF|HASHREF, + }, + limit => {type => HASHREF|UNDEF, + }, + transcript => {type => SCALARREF|HANDLE, + optional => 1, + }, + }, + ); + my @data = make_list($param{data}); + if (not @data or + not defined $param{limit} or + not keys %{$param{limit}}) { + return 1; + } + my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef); + my $going_to_fail = 0; + for my $data (@data) { + $data = split_status_fields(get_bug_status(bug => $data->{bug_num}, + status => dclone($data), + )); + for my $field (keys %{$param{limit}}) { + next unless exists $param{limit}{$field}; + my $match = 0; + my @data_fields = make_list($data->{$field}); +LIMIT: for my $limit (make_list($param{limit}{$field})) { + if (not ref $limit) { + for my $data_field (@data_fields) { + if ($data_field eq $limit) { + $match = 1; + last LIMIT; + } + } + } + elsif (ref($limit) eq 'Regexp') { + for my $data_field (@data_fields) { + if ($data_field =~ $limit) { + $match = 1; + last LIMIT; + } + } + } + else { + warn "Unknown type of reference: '".ref($limit)."' in key '$field'"; + } + } + if (not $match) { + $going_to_fail = 1; + print {$transcript} qq($field: ').join(', ',map{qq("$_")} make_list($data->{$field})). + "' does not match at least one of ". + join(', ',map {ref($_)?'(regex)':qq("$_")} make_list($param{limit}{$field}))."\n"; + } + } + } + return $going_to_fail?0:1; +} + + +=head2 die + + sig_die "foo" + +We override die to specially handle unlocking files in the cases where +we are called via eval. [If we're not called via eval, it doesn't +matter.] + +=cut + +sub sig_die{ + if ($^S) { # in eval + if ($locks) { + for (1..$locks) { unfilelock(defined $lockhash?$lockhash:()); } + $locks = 0; + } + } +} + + +# =head2 __message_body_template +# +# message_body_template('mail/ack',{ref=>'foo'}); +# +# Creates a message body using a template +# +# =cut + +sub __message_body_template{ + my ($template,$extra_var) = @_; + $extra_var ||={}; + my $hole_var = {'&bugurl' => + sub{"$_[0]: ". + $config{cgi_domain}.'/'. + Debbugs::CGI::bug_links(bug => $_[0], + links_only => 1, + ); + } + }; + + my $body = fill_in_template(template => $template, + variables => {config => \%config, + %{$extra_var}, + }, + hole_var => $hole_var, + ); + return fill_in_template(template => 'mail/message_body', + variables => {config => \%config, + %{$extra_var}, + body => $body, + }, + hole_var => $hole_var, + ); +} + +sub __all_undef_or_equal { + my @values = @_; + return 1 if @values == 1 or @values == 0; + my $not_def = grep {not defined $_} @values; + if ($not_def == @values) { + return 1; + } + if ($not_def > 0 and $not_def != @values) { + return 0; + } + my $first_val = shift @values; + for my $val (@values) { + if ($first_val ne $val) { + return 0; + } + } + return 1; +} + + +1; + +__END__ diff --git a/lib/Debbugs/Control/Service.pm b/lib/Debbugs/Control/Service.pm new file mode 100644 index 0000000..52d7d10 --- /dev/null +++ b/lib/Debbugs/Control/Service.pm @@ -0,0 +1,728 @@ +# 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. +# +# [Other people have contributed to this file; their copyrights should +# go here too.] +# Copyright 2007,2008,2009 by Don Armstrong . + +package Debbugs::Control::Service; + +=head1 NAME + +Debbugs::Control::Service -- Handles the modification parts of scripts/service by calling Debbugs::Control + +=head1 SYNOPSIS + +use Debbugs::Control::Service; + + +=head1 DESCRIPTION + +This module contains the code to implement the grammar of control@. It +is abstracted here so that it can be called from process at submit +time. + +All of the public functions take the following options: + +=over + +=item debug -- scalar reference to which debbuging information is +appended + +=item transcript -- scalar reference to which transcript information +is appended + +=item affected_bugs -- hashref which is updated with bugs affected by +this function + + +=back + +Functions which should (probably) append to the .log file take the +following options: + +=over + +=item requester -- Email address of the individual who requested the change + +=item request_addr -- Address to which the request was sent + +=item request_nn -- Name of queue file which caused this request + +=item request_msgid -- Message id of message which caused this request + +=item location -- Optional location; currently ignored but may be +supported in the future for updating archived bugs upon archival + +=item message -- The original message which caused the action to be taken + +=item append_log -- Whether or not to append information to the log. + +=back + +B (for most functions) is a special option. When set to +false, no appending to the log is done at all. When it is not present, +the above information is faked, and appended to the log file. When it +is true, the above options must be present, and their values are used. + + +=head1 GENERAL FUNCTIONS + +=cut + +use warnings; +use strict; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use Exporter qw(import); + +BEGIN{ + $VERSION = 1.00; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (control => [qw(control_line valid_control)], + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + +use Debbugs::Config qw(:config); +use Debbugs::Common qw(cleanup_eval_fail); +use Debbugs::Control qw(:all); +use Debbugs::Status qw(splitpackages); +use Params::Validate qw(:types validate_with); +use List::AllUtils qw(first); + +my $bug_num_re = '-?\d+'; +my %control_grammar = + (close => qr/(?i)^close\s+\#?($bug_num_re)(?:\s+(\d.*))?$/, + reassign => qr/(?i)^reassign\s+\#?($bug_num_re)\s+ # bug and command + (?:(?:((?:src:|source:)?$config{package_name_re}) # new package + (?:\s+((?:$config{package_name_re}\/)? + $config{package_version_re}))?)| # optional version + ((?:src:|source:)?$config{package_name_re} # multiple package form + (?:\s*\,\s*(?:src:|source:)?$config{package_name_re})+)) + \s*$/x, + reopen => qr/(?i)^reopen\s+\#?($bug_num_re)(?:\s+([\=\!]|(?:\S.*\S)))?$/, + found => qr{^(?:(?i)found)\s+\#?($bug_num_re) + (?:\s+((?:$config{package_name_re}\/)? + $config{package_version_re} + # allow for multiple packages + (?:\s*,\s*(?:$config{package_name_re}\/)? + $config{package_version_re})*) + )?$}x, + notfound => qr{^(?:(?i)notfound)\s+\#?($bug_num_re) + \s+((?:$config{package_name_re}\/)? + $config{package_version_re} + # allow for multiple packages + (?:\s*,\s*(?:$config{package_name_re}\/)? + $config{package_version_re})* + )$}x, + fixed => qr{^(?:(?i)fixed)\s+\#?($bug_num_re) + \s+((?:$config{package_name_re}\/)? + $config{package_version_re} + # allow for multiple packages + (?:\s*,\s*(?:$config{package_name_re}\/)? + $config{package_version_re})*) + \s*$}x, + notfixed => qr{^(?:(?i)notfixed)\s+\#?($bug_num_re) + \s+((?:$config{package_name_re}\/)? + $config{package_version_re} + # allow for multiple packages + (?:\s*,\s*(?:$config{package_name_re}\/)? + $config{package_version_re})*) + \s*$}x, + submitter => qr/(?i)^submitter\s+\#?($bug_num_re)\s+(\!|\S.*\S)$/, + forwarded => qr/(?i)^forwarded\s+\#?($bug_num_re)\s+(\S.*\S)$/, + notforwarded => qr/(?i)^notforwarded\s+\#?($bug_num_re)$/, + severity => qr/(?i)^(?:severity|priority)\s+\#?($bug_num_re)\s+([-0-9a-z]+)$/, + tag => qr/(?i)^tags?\s+\#?($bug_num_re)\s+(\S.*)$/, + block => qr/(?i)^(un)?block\s+\#?($bug_num_re)\s+(?:by|with)\s+(\S.*)?$/, + retitle => qr/(?i)^retitle\s+\#?($bug_num_re)\s+(\S.*\S)\s*$/, + unmerge => qr/(?i)^unmerge\s+\#?($bug_num_re)$/, + merge => qr/(?i)^merge\s+#?($bug_num_re(\s+#?$bug_num_re)+)\s*$/, + forcemerge => qr/(?i)^forcemerge\s+\#?($bug_num_re(?:\s+\#?$bug_num_re)+)\s*$/, + clone => qr/(?i)^clone\s+#?($bug_num_re)\s+((?:$bug_num_re\s+)*$bug_num_re)\s*$/, + package => qr/(?i)^package\:?\s+(\S.*\S)?\s*$/, + limit => qr/(?i)^limit\:?\s+(\S.*\S)\s*$/, + affects => qr/(?i)^affects?\s+\#?($bug_num_re)(?:\s+((?:[=+-])?)\s*(\S.*)?)?\s*$/, + summary => qr/(?i)^summary\s+\#?($bug_num_re)\s*(.*)\s*$/, + outlook => qr/(?i)^outlook\s+\#?($bug_num_re)\s*(.*)\s*$/, + owner => qr/(?i)^owner\s+\#?($bug_num_re)\s+((?:\S.*\S)|\!)\s*$/, + noowner => qr/(?i)^noowner\s+\#?($bug_num_re)\s*$/, + unarchive => qr/(?i)^unarchive\s+#?($bug_num_re)$/, + archive => qr/(?i)^archive\s+#?($bug_num_re)$/, + ); + +sub valid_control { + my ($line,$matches) = @_; + my @matches; + for my $ctl (keys %control_grammar) { + if (@matches = $line =~ $control_grammar{$ctl}) { + @{$matches} = @matches if defined $matches and ref($matches) eq 'ARRAY'; + return $ctl; + } + } + @{$matches} = () if defined $matches and ref($matches) eq 'ARRAY'; + return undef; +} + +sub control_line { + my %param = + validate_with(params => \@_, + spec => {line => {type => SCALAR, + }, + clonebugs => {type => HASHREF, + }, + common_control_options => {type => ARRAYREF, + }, + errors => {type => SCALARREF, + }, + transcript => {type => HANDLE, + }, + debug => {type => SCALAR, + default => 0, + }, + ok => {type => SCALARREF, + }, + limit => {type => HASHREF, + }, + replyto => {type => SCALAR, + }, + }, + ); + my $line = $param{line}; + my @matches; + my $ctl = valid_control($line,\@matches); + my $transcript = $param{transcript}; + my $debug = $param{debug}; + if (not defined $ctl) { + ${$param{errors}}++; + print {$param{transcript}} "Unknown command or invalid options to control\n"; + return; + } + # in almost all cases, the first match is the bug; the exception + # to this is block. + my $ref = $matches[0]; + if (defined $ref) { + $ref = $param{clonebugs}{$ref} if exists $param{clonebugs}{$ref}; + } + ${$param{ok}}++; + my $errors = 0; + my $terminate_control = 0; + + if ($ctl eq 'close') { + if (defined $matches[1]) { + eval { + set_fixed(@{$param{common_control_options}}, + bug => $ref, + fixed => $matches[1], + add => 1, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to add fixed version '$matches[1]' to $ref: ".cleanup_eval_fail($@,$debug)."\n"; + } + } + eval { + set_done(@{$param{common_control_options}}, + done => 1, + bug => $ref, + reopen => 0, + notify_submitter => 1, + clear_fixed => 0, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to mark $ref as done: ".cleanup_eval_fail($@,$debug)."\n"; + } + } elsif ($ctl eq 'reassign') { + my @new_packages; + if (not defined $matches[1]) { + push @new_packages, split /\s*\,\s*/,$matches[3]; + } + else { + push @new_packages, $matches[1]; + } + @new_packages = map {y/A-Z/a-z/; s/^(?:src|source):/src:/; $_;} @new_packages; + my $version= $matches[2]; + eval { + set_package(@{$param{common_control_options}}, + bug => $ref, + package => \@new_packages, + ); + # if there is a version passed, we make an internal call + # to set_found + if (defined($version) && length $version) { + set_found(@{$param{common_control_options}}, + bug => $ref, + found => $version, + ); + } + }; + if ($@) { + $errors++; + print {$transcript} "Failed to clear fixed versions and reopen on $ref: ".cleanup_eval_fail($@,$debug)."\n"; + } + } elsif ($ctl eq 'reopen') { + my $new_submitter = $matches[1]; + if (defined $new_submitter) { + if ($new_submitter eq '=') { + undef $new_submitter; + } + elsif ($new_submitter eq '!') { + $new_submitter = $param{replyto}; + } + } + eval { + set_done(@{$param{common_control_options}}, + bug => $ref, + reopen => 1, + defined $new_submitter? (submitter => $new_submitter):(), + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to reopen $ref: ".cleanup_eval_fail($@,$debug)."\n"; + } + } elsif ($ctl eq 'found') { + my @versions; + if (defined $matches[1]) { + @versions = split /\s*,\s*/,$matches[1]; + eval { + set_found(@{$param{common_control_options}}, + bug => $ref, + found => \@versions, + add => 1, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to add found on $ref: ".cleanup_eval_fail($@,$debug)."\n"; + } + } + else { + eval { + set_fixed(@{$param{common_control_options}}, + bug => $ref, + fixed => [], + reopen => 1, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to clear fixed versions and reopen on $ref: ".cleanup_eval_fail($@,$debug)."\n"; + } + } + } + elsif ($ctl eq 'notfound') { + my @versions; + @versions = split /\s*,\s*/,$matches[1]; + eval { + set_found(@{$param{common_control_options}}, + bug => $ref, + found => \@versions, + remove => 1, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to remove found on $ref: ".cleanup_eval_fail($@,$debug)."\n"; + } + } + elsif ($ctl eq 'fixed') { + my @versions; + @versions = split /\s*,\s*/,$matches[1]; + eval { + set_fixed(@{$param{common_control_options}}, + bug => $ref, + fixed => \@versions, + add => 1, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to add fixed on $ref: ".cleanup_eval_fail($@,$debug)."\n"; + } + } + elsif ($ctl eq 'notfixed') { + my @versions; + @versions = split /\s*,\s*/,$matches[1]; + eval { + set_fixed(@{$param{common_control_options}}, + bug => $ref, + fixed => \@versions, + remove => 1, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to remove fixed on $ref: ".cleanup_eval_fail($@,$debug)."\n"; + } + } + elsif ($ctl eq 'submitter') { + my $newsubmitter = $matches[1] eq '!' ? $param{replyto} : $matches[1]; + if (not Mail::RFC822::Address::valid($newsubmitter)) { + print {$transcript} "$newsubmitter is not a valid e-mail address; not changing submitter\n"; + $errors++; + } + else { + eval { + set_submitter(@{$param{common_control_options}}, + bug => $ref, + submitter => $newsubmitter, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to set submitter on $ref: ".cleanup_eval_fail($@,$debug)."\n"; + } + } + } elsif ($ctl eq 'forwarded') { + my $forward_to= $matches[1]; + eval { + set_forwarded(@{$param{common_control_options}}, + bug => $ref, + forwarded => $forward_to, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to set the forwarded-to-address of $ref: ".cleanup_eval_fail($@,$debug)."\n"; + } + } elsif ($ctl eq 'notforwarded') { + eval { + set_forwarded(@{$param{common_control_options}}, + bug => $ref, + forwarded => undef, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to clear the forwarded-to-address of $ref: ".cleanup_eval_fail($@,$debug)."\n"; + } + } elsif ($ctl eq 'severity') { + my $newseverity= $matches[1]; + if (exists $config{obsolete_severities}{$newseverity}) { + print {$transcript} "Severity level \`$newseverity' is obsolete. " . + "Use $config{obsolete_severities}{$newseverity} instead.\n\n"; + $errors++; + } elsif (not defined first {$_ eq $newseverity} + (@{$config{severity_list}}, $config{default_severity})) { + print {$transcript} "Severity level \`$newseverity' is not known.\n". + "Recognized are: $config{show_severities}.\n\n"; + $errors++; + } else { + eval { + set_severity(@{$param{common_control_options}}, + bug => $ref, + severity => $newseverity, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to set severity of $config{bug} $ref to $newseverity: ".cleanup_eval_fail($@,$debug)."\n"; + } + } + } elsif ($ctl eq 'tag') { + my $tags = $matches[1]; + my @tags = map {m/^([+=-])(.+)/ ? ($1,$2):($_)} split /[\s,]+/, $tags; + # this is an array of hashrefs which contain two elements, the + # first of which is the array of tags, the second is the + # option to pass to set_tag (we use a hashref here to make it + # more obvious what is happening) + my @tag_operations; + my @badtags; + for my $tag (@tags) { + if ($tag =~ /^[=+-]$/) { + if ($tag eq '=') { + @tag_operations = {tags => [], + option => [], + }; + } + elsif ($tag eq '-') { + push @tag_operations, + {tags => [], + option => [remove => 1], + }; + } + elsif ($tag eq '+') { + push @tag_operations, + {tags => [], + option => [add => 1], + }; + } + next; + } + if (not defined first {$_ eq $tag} @{$config{tags}}) { + push @badtags, $tag; + next; + } + if (not @tag_operations) { + @tag_operations = {tags => [], + option => [add => 1], + }; + } + push @{$tag_operations[-1]{tags}},$tag; + } + if (@badtags) { + print {$transcript} "Unknown tag/s: ".join(', ', @badtags).".\n". + "Recognized are: ".join(' ', @{$config{tags}}).".\n\n"; + $errors++; + } + eval { + for my $operation (@tag_operations) { + set_tag(@{$param{common_control_options}}, + bug => $ref, + tag => [@{$operation->{tags}}], + warn_on_bad_tags => 0, # don't warn on bad tags, + # 'cause we do that above + @{$operation->{option}}, + ); + } + }; + if ($@) { + # we intentionally have two errors here if there is a bad + # tag and the above fails for some reason + $errors++; + print {$transcript} "Failed to alter tags of $config{bug} $ref: ".cleanup_eval_fail($@,$debug)."\n"; + } + } elsif ($ctl eq 'block') { + my $add_remove = defined $matches[0] && $matches[0] eq 'un'; + $ref = $matches[1]; + $ref = exists $param{clonebugs}{$ref} ? $param{clonebugs}{$ref} : $ref; + my @blockers = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_} split /[\s,]+/, $matches[2]; + eval { + set_blocks(@{$param{common_control_options}}, + bug => $ref, + block => \@blockers, + $add_remove ? (remove => 1):(add => 1), + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to set blocking bugs of $ref: ".cleanup_eval_fail($@,$debug)."\n"; + } + } elsif ($ctl eq 'retitle') { + my $newtitle= $matches[1]; + eval { + set_title(@{$param{common_control_options}}, + bug => $ref, + title => $newtitle, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to set the title of $ref: ".cleanup_eval_fail($@,$debug)."\n"; + } + } elsif ($ctl eq 'unmerge') { + eval { + set_merged(@{$param{common_control_options}}, + bug => $ref, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to unmerge $ref: ".cleanup_eval_fail($@,$debug)."\n"; + } + } elsif ($ctl eq 'merge') { + my @tomerge; + ($ref,@tomerge) = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_} + split(/\s+#?/,$matches[0]); + eval { + set_merged(@{$param{common_control_options}}, + bug => $ref, + merge_with => \@tomerge, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to merge $ref: ".cleanup_eval_fail($@,$debug)."\n"; + } + } elsif ($ctl eq 'forcemerge') { + my @tomerge; + ($ref,@tomerge) = map {exists $param{clonebugs}{$_}?$param{clonebugs}{$_}:$_} + split(/\s+#?/,$matches[0]); + eval { + set_merged(@{$param{common_control_options}}, + bug => $ref, + merge_with => \@tomerge, + force => 1, + masterbug => 1, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to forcibly merge $ref: ".cleanup_eval_fail($@,$debug)."\n"; + } + } elsif ($ctl eq 'clone') { + my @newclonedids = split /\s+/, $matches[1]; + + eval { + my %new_clones; + clone_bug(@{$param{common_control_options}}, + bug => $ref, + new_bugs => \@newclonedids, + new_clones => \%new_clones, + ); + %{$param{clonebugs}} = (%{$param{clonebugs}}, + %new_clones); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to clone $ref: ".cleanup_eval_fail($@,$debug)."\n"; + } + } elsif ($ctl eq 'package') { + my @pkgs = split /\s+/, $matches[0]; + if (scalar(@pkgs) > 0) { + $param{limit}{package} = [@pkgs]; + print {$transcript} "Limiting to bugs with field 'package' containing at least one of ".join(', ',map {qq('$_')} @pkgs)."\n"; + print {$transcript} "Limit currently set to"; + for my $limit_field (keys %{$param{limit}}) { + print {$transcript} " '$limit_field':".join(', ',map {qq('$_')} @{$param{limit}{$limit_field}})."\n"; + } + print {$transcript} "\n"; + } else { + $param{limit}{package} = []; + print {$transcript} "Limit cleared.\n\n"; + } + } elsif ($ctl eq 'limit') { + my ($field,@options) = split /\s+/, $matches[0]; + $field = lc($field); + if ($field =~ /^(?:clear|unset|blank)$/) { + %{$param{limit}} = (); + print {$transcript} "Limit cleared.\n\n"; + } + elsif (exists $Debbugs::Status::fields{$field} or $field eq 'source') { + # %{$param{limit}} can actually contain regexes, but because they're + # not evaluated in Safe, DO NOT allow them through without + # fixing this. + $param{limit}{$field} = [@options]; + print {$transcript} "Limiting to bugs with field '$field' containing at least one of ".join(', ',map {qq('$_')} @options)."\n"; + print {$transcript} "Limit currently set to"; + for my $limit_field (keys %{$param{limit}}) { + print {$transcript} " '$limit_field':".join(', ',map {qq('$_')} @{$param{limit}{$limit_field}})."\n"; + } + print {$transcript} "\n"; + } + else { + print {$transcript} "Limit key $field not understood. Stopping processing here.\n\n"; + $errors++; + # this needs to be fixed + syntax error for fixing it + last; + } + } elsif ($ctl eq 'affects') { + my $add_remove = $matches[1]; + my $packages = $matches[2]; + # if there isn't a package given, assume that we should unset + # affects; otherwise default to adding + if (not defined $packages or + not length $packages) { + $packages = ''; + $add_remove ||= '='; + } + elsif (not defined $add_remove or + not length $add_remove) { + $add_remove = '+'; + } + eval { + affects(@{$param{common_control_options}}, + bug => $ref, + package => [splitpackages($packages)], + ($add_remove eq '+'?(add => 1):()), + ($add_remove eq '-'?(remove => 1):()), + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to mark $ref as affecting package(s): ".cleanup_eval_fail($@,$debug)."\n"; + } + + } elsif ($ctl eq 'summary') { + my $summary_msg = length($matches[1])?$matches[1]:undef; + eval { + summary(@{$param{common_control_options}}, + bug => $ref, + summary => $summary_msg, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to give $ref a summary: ".cleanup_eval_fail($@,$debug)."\n"; + } + + } elsif ($ctl eq 'outlook') { + my $outlook_msg = length($matches[1])?$matches[1]:undef; + eval { + outlook(@{$param{common_control_options}}, + bug => $ref, + outlook => $outlook_msg, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to give $ref a outlook: ".cleanup_eval_fail($@,$debug)."\n"; + } + + } elsif ($ctl eq 'owner') { + my $newowner = $matches[1]; + if ($newowner eq '!') { + $newowner = $param{replyto}; + } + eval { + owner(@{$param{common_control_options}}, + bug => $ref, + owner => $newowner, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to mark $ref as having an owner: ".cleanup_eval_fail($@,$debug)."\n"; + } + } elsif ($ctl eq 'noowner') { + eval { + owner(@{$param{common_control_options}}, + bug => $ref, + owner => undef, + ); + }; + if ($@) { + $errors++; + print {$transcript} "Failed to mark $ref as not having an owner: ".cleanup_eval_fail($@,$debug)."\n"; + } + } elsif ($ctl eq 'unarchive') { + eval { + bug_unarchive(@{$param{common_control_options}}, + bug => $ref, + ); + }; + if ($@) { + $errors++; + } + } elsif ($ctl eq 'archive') { + eval { + bug_archive(@{$param{common_control_options}}, + bug => $ref, + ignore_time => 1, + archive_unarchived => 0, + ); + }; + if ($@) { + $errors++; + } + } + if ($errors) { + ${$param{errors}}+=$errors; + } + return($errors,$terminate_control); +} + +1; + +__END__ diff --git a/lib/Debbugs/Correspondent.pm b/lib/Debbugs/Correspondent.pm new file mode 100644 index 0000000..0044347 --- /dev/null +++ b/lib/Debbugs/Correspondent.pm @@ -0,0 +1,99 @@ +# 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::Correspondent; + +=head1 NAME + +Debbugs::Correspondent -- OO interface to bugs + +=head1 SYNOPSIS + + use Debbugs::Correspondent; + Debbugs::Correspondent->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 Mail::Address; +use Debbugs::OOTypes; +use Debbugs::Config qw(:config); + +use Carp; + +extends 'Debbugs::OOBase'; + +has name => (is => 'ro', isa => 'Str', + required => 1, + writer => '_set_name', + ); + +has _mail_address => (is => 'bare', isa => 'Mail::Address', + lazy => 1, + handles => [qw(address phrase comment)], + builder => '_build_mail_address', + ); + +sub _build_mail_address { + my @addr = Mail::Address->parse($_[0]->name) or + confess("unable to parse mail address"); + if (@addr > 1) { + warn("Multiple addresses to Debbugs::Correspondent"); + } + return $addr[0]; +} + +sub email { + my $email = $_[0]->address; + warn "No email" unless defined $email; + return $email; +} + +sub url { + my $self = shift; + return $config{web_domain}.'/correspondent:'.$self->email; +} + +sub maintainer_url { + my $self = shift; + return $config{web_domain}.'/maintainer:'.$self->email; +} + +sub owner_url { + my $self = shift; + return $config{web_domain}.'/owner:'.$self->email; +} + +sub submitter_url { + my $self = shift; + return $config{web_domain}.'/submitter:'.$self->email; +} + +sub CARP_TRACE { + my $self = shift; + return 'Debbugs::Correspondent={name='.$self->name.'}'; +} + + +__PACKAGE__->meta->make_immutable; + +no Mouse; +1; + + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/lib/Debbugs/DB.pm b/lib/Debbugs/DB.pm new file mode 100644 index 0000000..5f6bd04 --- /dev/null +++ b/lib/Debbugs/DB.pm @@ -0,0 +1,33 @@ +use utf8; +package Debbugs::DB; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +use strict; +use warnings; + +use base 'DBIx::Class::Schema'; + +__PACKAGE__->load_namespaces; + + +# Created by DBIx::Class::Schema::Loader v0.07025 @ 2012-07-17 10:25:29 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:wiMg1t5hFUhnyufL3yT5fQ + +# This version must be incremented any time the schema changes so that +# DBIx::Class::DeploymentHandler can do its work +our $VERSION=12; + +# You can replace this text with custom code or comments, and it will be preserved on regeneration + +# override connect to handle just passing a bare service +sub connect { + my ($self,@rem) = @_; + if ($rem[0] !~ /:/) { + $rem[0] = 'dbi:Pg:service='.$rem[0]; + } + $self->clone->connection(@rem); +} + +1; diff --git a/lib/Debbugs/DB/Load.pm b/lib/Debbugs/DB/Load.pm new file mode 100644 index 0000000..03ab770 --- /dev/null +++ b/lib/Debbugs/DB/Load.pm @@ -0,0 +1,771 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version. See the +# file README and COPYING for more information. +# Copyright 2013 by Don Armstrong . + +package Debbugs::DB::Load; + +=head1 NAME + +Debbugs::DB::Load -- Utility routines for loading the database + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + + +=head1 BUGS + +None known. + +=cut + +use warnings; +use strict; +use v5.10; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use base qw(Exporter); + +BEGIN{ + ($VERSION) = q$Revision$ =~ /^Revision:\s+([^\s+])/; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (load_bug => [qw(load_bug handle_load_bug_queue load_bug_log)], + load_debinfo => [qw(load_debinfo)], + load_package => [qw(load_packages)], + load_suite => [qw(load_suite)], + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + +use Params::Validate qw(validate_with :types); +use List::AllUtils qw(natatime); + +use Debbugs::Status qw(read_bug split_status_fields); +use Debbugs::DB; +use DateTime; +use Debbugs::Common qw(make_list getparsedaddrs); +use Debbugs::Config qw(:config); +use Debbugs::MIME qw(parse_to_mime_entity decode_rfc1522); +use DateTime::Format::Mail; +use Carp; + +=head2 Bug loading + +Routines to load bug; exported with :load_bug + +=over + +=item load_bug + + load_bug(db => $schema, + data => split_status_fields($data), + tags => \%tags, + queue => \%queue); + +Loads a bug's metadata into the database. (Does not load any messages) + +=over + +=item db -- Debbugs::DB object + +=item data -- Bug data (from read_bug) which has been split with split_status_fields + +=item tags -- tag cache (hashref); optional + +=item queue -- queue of operations to perform after bug is loaded; optional. + +=back + +=cut + +sub load_bug { + my %param = validate_with(params => \@_, + spec => {db => {type => OBJECT, + }, + data => {type => HASHREF, + optional => 1, + }, + bug => {type => SCALAR, + optional => 1, + }, + tags => {type => HASHREF, + default => sub {return {}}, + optional => 1}, + severities => {type => HASHREF, + default => sub {return {}}, + optional => 1, + }, + queue => {type => HASHREF, + optional => 1}, + packages => {type => HASHREF, + default => sub {return {}}, + optional => 1, + }, + }); + my $s = $param{db}; + if (not exists $param{data} and not exists $param{bug}) { + croak "One of data or bug must be provided to load_bug"; + } + if (not exists $param{data}) { + $param{data} = read_bug(bug => $param{bug}); + } + my $data = $param{data}; + my $tags = $param{tags}; + my $queue = $param{queue}; + my $severities = $param{severities}; + my $can_queue = 1; + if (not defined $queue) { + $can_queue = 0; + $queue = {}; + } + my %tags; + $data = split_status_fields($data); + for my $tag (make_list($data->{keywords})) { + next unless defined $tag and length $tag; + # this allows for invalid tags. But we'll use this to try to + # find those bugs and clean them up + if (not exists $tags->{$tag}) { + $tags->{$tag} = $s->resultset('Tag')-> + find_or_create({tag => $tag}); + } + $tags{$tag} = $tags->{$tag}; + } + my $severity = length($data->{severity}) ? $data->{severity} : + $config{default_severity}; + if (not exists $severities->{$severity}) { + $severities->{$severity} = + $s->resultset('Severity')-> + find_or_create({severity => $severity}, + ); + } + $severity = $severities->{$severity}; + my $bug = + {id => $data->{bug_num}, + creation => DateTime->from_epoch(epoch => $data->{date}), + log_modified => DateTime->from_epoch(epoch => $data->{log_modified}), + last_modified => DateTime->from_epoch(epoch => $data->{last_modified}), + archived => $data->{archived}, + (defined $data->{unarchived} and length($data->{unarchived}))? + (unarchived => DateTime->from_epoch(epoch => $data->{unarchived})):(), + forwarded => $data->{forwarded} // '', + summary => $data->{summary} // '', + outlook => $data->{outlook} // '', + subject => $data->{subject} // '', + done_full => $data->{done} // '', + severity => $severity, + owner_full => $data->{owner} // '', + submitter_full => $data->{originator} // '', + }; + my %addr_map = + (done => 'done', + owner => 'owner', + submitter => 'originator', + ); + for my $addr_type (keys %addr_map) { + $bug->{$addr_type} = undef; + next unless defined $data->{$addr_map{$addr_type}} and + length($data->{$addr_map{$addr_type}}); + $bug->{$addr_type} = + $s->resultset('Correspondent')-> + get_correspondent_id($data->{$addr_map{$addr_type}}) + } + my $b = $s->resultset('Bug')->update_or_create($bug) or + die "Unable to update or create bug $bug->{id}"; + $s->txn_do(sub { + my @unknown_packages; + my @unknown_affects_packages; + push @unknown_packages, + $b->set_related_packages('binpackages', + [grep {defined $_ and + length $_ and $_ !~ /^src:/} + make_list($data->{package})], + $param{packages}, + ); + push @unknown_packages, + $b->set_related_packages('srcpackages', + [map {s/src://; + $_} + grep {defined $_ and + $_ =~ /^src:/} + make_list($data->{package})], + $param{packages}, + ); + push @unknown_affects_packages, + $b->set_related_packages('affects_binpackages', + [grep {defined $_ and + length $_ and $_ !~ /^src:/} + make_list($data->{affects}) + ], + $param{packages}, + ); + push @unknown_affects_packages, + $b->set_related_packages('affects_srcpackages', + [map {s/src://; + $_} + grep {defined $_ and + $_ =~ /^src:/} + make_list($data->{affects})], + $param{packages}, + ); + $b->unknown_packages(join(', ',@unknown_packages)); + $b->unknown_affects(join(', ',@unknown_affects_packages)); + $b->update(); + for my $ff (qw(found fixed)) { + my @elements = $s->resultset('BugVer')->search({bug => $data->{bug_num}, + found => $ff eq 'found'?1:0, + }); + my %elements_to_delete = map {($elements[$_]->ver_string(), + $elements[$_])} 0..$#elements; + my %elements_to_add; + my @elements_to_keep; + for my $version (@{$data->{"${ff}_versions"}}) { + if (exists $elements_to_delete{$version}) { + push @elements_to_keep,$version; + } else { + $elements_to_add{$version} = 1; + } + } + for my $version (@elements_to_keep) { + delete $elements_to_delete{$version}; + } + for my $element (keys %elements_to_delete) { + $elements_to_delete{$element}->delete(); + } + for my $element (keys %elements_to_add) { + # find source package and source version id + my $ne = $s->resultset('BugVer')->new_result({bug => $data->{bug_num}, + ver_string => $element, + found => $ff eq 'found'?1:0, + } + ); + if (my ($src_pkg,$src_ver) = $element =~ m{^([^\/]+)/(.+)$}) { + my $src_pkg_e = $s->resultset('SrcPkg')->single({pkg => $src_pkg}); + if (defined $src_pkg_e) { + $ne->src_pkg($src_pkg_e->id()); + my $src_ver_e = $s->resultset('SrcVer')->single({src_pkg => $src_pkg_e->id(), + ver => $src_ver + }); + $ne->src_ver($src_ver_e->id()) if defined $src_ver_e; + } + } + $ne->insert(); + } + } + }); + ### set bug tags + $s->txn_do(sub {$b->set_tags([values %tags ] )}); + # because these bugs reference other bugs which might not exist + # yet, we can't handle them until we've loaded all bugs. queue + # them up. + for my $merge_block (qw(mergedwith blocks)) { + my $count = 0; + if (@{$data->{$merge_block}}) { + $count = + $s->resultset('Bug')-> + search({id => [@{$data->{$merge_block}}]})-> + count(); + } + # if all of the bugs exist, immediately fix the merge/blocks + if ($count == @{$data->{$merge_block}}) { + handle_load_bug_queue(db=>$s, + queue => {$merge_block, + {$data->{bug_num},[@{$data->{$merge_block}}]} + }); + } else { + $queue->{$merge_block}{$data->{bug_num}} = [@{$data->{$merge_block}}]; + } + } + + if (not $can_queue and keys %{$queue}) { + handle_load_bug_queue(db => $s,queue => $queue); + } + + # still need to handle merges, versions, etc. +} + +=item handle_load_bug_queue + + handle_load_bug_queue(db => $schema,queue => $queue); + +Handles a queue of operations created by load bug. [These operations +are used to handle cases where a bug referenced by a loaded bug may +not exist yet. In cases where the bugs should exist, the queue is +cleared automatically by load_bug if queue is undefined. + +=cut + +sub handle_load_bug_queue{ + my %param = validate_with(params => \@_, + spec => {db => {type => OBJECT, + }, + queue => {type => HASHREF, + }, + }); + my $s = $param{db}; + my $queue = $param{queue}; + my %queue_types = + (mergedwith => {set => 'BugMerged', + columns => [qw(bug merged)], + bug => 'bug', + }, + blocks => {set => 'BugBlock', + columns => [qw(bug blocks)], + bug => 'bug', + }, + ); + for my $queue_type (keys %queue_types) { + my $qt = $queue_types{$queue_type}; + my @bugs = keys %{$queue->{$queue_type}}; + next unless @bugs; + my @entries; + for my $bug (@bugs) { + push @entries, + map {[$bug,$_]} + @{$queue->{$queue_type}{$bug}}; + } + $s->txn_do(sub { + $s->resultset($qt->{set})-> + search({$qt->{bug}=>\@bugs})->delete(); + $s->resultset($qt->{set})-> + populate([[@{$qt->{columns}}], + @entries]) if @entries; + } + ); + } +} + +=item load_bug_log -- load bug logs + + load_bug_log(db => $s, + bug => $bug); + + +=over + +=item db -- database + +=item bug -- bug whose log should be loaded + +=back + +=cut + +sub load_bug_log { + my %param = validate_with(params => \@_, + spec => {db => {type => OBJECT, + }, + bug => {type => SCALAR, + }, + queue => {type => HASHREF, + optional => 1}, + }); + my $s = $param{db}; + my $msg_num=0; + my %seen_msg_ids; + my $log = Debbugs::Log->new(bug_num => $param{bug}) or + die "Unable to open log for $param{bug} for reading: $!"; + while (my $record = $log->read_record()) { + next unless $record->{type} eq 'incoming-recv'; + my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im; + next if defined $msg_id and exists $seen_msg_ids{$msg_id}; + $seen_msg_ids{$msg_id} = 1 if defined $msg_id; + next if defined $msg_id and $msg_id =~ /handler\..+\.ack(?:info)?\@/; + my $entity = parse_to_mime_entity($record); + # search for a message with this message id in the database + $msg_id = $entity->head->get('Message-Id') // + $entity->head->get('Resent-Message-ID') // + ''; + $msg_id =~ s/^\s*\\s*$//; + # check to see if the subject, to, and from match. if so, it's + # probably the same message. + my $subject = decode_rfc1522($entity->head->get('Subject')//''); + $subject =~ s/\n(?:(\s)\s*|\s*$)//g; + my $to = decode_rfc1522($entity->head->get('To')//''); + $to =~ s/\n(?:(\s)\s*|\s*$)//g; + my $from = decode_rfc1522($entity->head->get('From')//''); + $from =~ s/\n(?:(\s)\s*|\s*$)//g; + my $m = $s->resultset('Message')-> + find({msgid => $msg_id, + from_complete => $from, + to_complete => $to, + subject => $subject + }); + if (not defined $m) { + # if not, create a new message + $m = $s->resultset('Message')-> + find_or_create({msgid => $msg_id, + from_complete => $from, + to_complete => $to, + subject => $subject + }); + eval { + my $date = DateTime::Format::Mail-> + parse_datetime($entity->head->get('Date',0)); + if (abs($date->offset) >= 60 * 60 * 12) { + $date = $date->set_time_zone('UTC'); + } + $m->sent_date($date); + }; + my $spam = $entity->head->get('X-Spam-Status',0)//''; + if ($spam=~ /score=([\d\.]+)/) { + $m->spam_score($1); + } + my %corr; + @{$corr{from}} = getparsedaddrs($from); + @{$corr{to}} = getparsedaddrs($to); + @{$corr{cc}} = getparsedaddrs($entity->head->get('Cc')); + # add correspondents if necessary + my @cors; + for my $type (keys %corr) { + for my $addr (@{$corr{$type}}) { + my $cor = $s->resultset('Correspondent')-> + get_correspondent_id($addr); + next unless defined $cor; + push @cors, + {correspondent => $cor, + correspondent_type => $type, + }; + } + } + $m->update(); + $s->txn_do(sub { + $m->message_correspondents()->delete(); + $m->add_to_message_correspondents(@cors) if + @cors; + } + ); + } + my $recv; + if ($entity->head->get('Received',0) + =~ /via spool by (\S+)/) { + $recv = $s->resultset('Correspondent')-> + get_correspondent_id($1); + $m->add_to_message_correspondents({correspondent=>$recv, + correspondent_type => 'recv'}); + } + # link message to bugs if necessary + $m->find_or_create_related('bug_messages', + {bug=>$param{bug}, + message_number => $msg_num}); + } + +} + +=back + +=head2 Debinfo + +Commands to handle src and package version loading from debinfo files + +=over + +=item load_debinfo + + load_debinfo($schema,$binname, $binver, $binarch, $srcname, $srcver); + + + +=cut + +sub load_debinfo { + my ($s,$binname, $binver, $binarch, $srcname, $srcver,$ct_date,$cache) = @_; + $cache //= {}; + my $sp; + if (not defined $cache->{sp}{$srcname}) { + $cache->{sp}{$srcname} = + $s->resultset('SrcPkg')->find_or_create({pkg => $srcname}); + } + $sp = $cache->{sp}{$srcname}; + # update the creation date if the data we have is earlier + if (defined $ct_date and + (not defined $sp->creation or + $ct_date < $sp->creation)) { + $sp->creation($ct_date); + $sp->last_modified(DateTime->now); + $sp->update; + } + my $sv; + if (not defined $cache->{sv}{$srcname}{$srcver}) { + $cache->{sv}{$srcname}{$srcver} = + $s->resultset('SrcVer')-> + find_or_create({src_pkg =>$sp->id(), + ver => $srcver}); + } + $sv = $cache->{sv}{$srcname}{$srcver}; + if (defined $ct_date and + (not defined $sv->upload_date() or $ct_date < $sv->upload_date())) { + $sv->upload_date($ct_date); + $sv->update; + } + my $arch; + if (not defined $cache->{arch}{$binarch}) { + $cache->{arch}{$binarch} = + $s->resultset('Arch')-> + find_or_create({arch => $binarch}, + )->id(); + } + $arch = $cache->{arch}{$binarch}; + my $bp; + if (not defined $cache->{bp}{$binname}) { + $cache->{bp}{$binname} = + $s->resultset('BinPkg')-> + get_or_create_bin_pkg_id($binname); + } + $bp = $cache->{bp}{$binname}; + $s->resultset('BinVer')-> + get_bin_ver_id($bp,$binver,$arch,$sv->id()); +} + + +=back + +=head2 Packages + +=over + +=item load_package + + load_package($schema,$suite,$component,$arch,$pkg) + +=cut + +sub load_packages { + my ($schema,$suite,$pkgs,$p) = @_; + my $suite_id = $schema->resultset('Suite')-> + find_or_create({codename => $suite})->id; + my %maint_cache; + my %arch_cache; + my %source_cache; + my $src_max_last_modified = $schema->resultset('SrcAssociation')-> + search_rs({suite => $suite_id}, + {order_by => {-desc => ['me.modified']}, + rows => 1, + page => 1 + } + )->single(); + my $bin_max_last_modified = $schema->resultset('BinAssociation')-> + search_rs({suite => $suite_id}, + {order_by => {-desc => ['me.modified']}, + rows => 1, + page => 1 + } + )->single(); + my %maints; + my %sources; + my %bins; + for my $pkg_tuple (@{$pkgs}) { + my ($arch,$component,$pkg) = @{$pkg_tuple}; + $maints{$pkg->{Maintainer}} = $pkg->{Maintainer}; + if ($arch eq 'source') { + my $source = $pkg->{Package}; + my $source_ver = $pkg->{Version}; + $sources{$source}{$source_ver} = $pkg->{Maintainer}; + } else { + my $source = $pkg->{Source} // $pkg->{Package}; + my $source_ver = $pkg->{Version}; + if ($source =~ /^\s*(\S+) \(([^\)]+)\)\s*$/) { + ($source,$source_ver) = ($1,$2); + } + $sources{$source}{$source_ver} = $pkg->{Maintainer}; + $bins{$arch}{$pkg->{Package}} = + {arch => $arch, + bin => $pkg->{Package}, + bin_ver => $pkg->{Version}, + src_ver => $source_ver, + source => $source, + maint => $pkg->{Maintainer}, + }; + } + } + # Retrieve and Insert new maintainers + my $maints = + $schema->resultset('Maintainer')-> + get_maintainers(keys %maints); + my $archs = + $schema->resultset('Arch')-> + get_archs(keys %bins); + # We want all of the source package/versions which are in this suite to + # start with + my @sa_to_add; + my @sa_to_del; + my %included_sa; + # Calculate which source packages are no longer in this suite + for my $s ($schema->resultset('SrcPkg')-> + src_pkg_and_ver_in_suite($suite)) { + if (not exists $sources{$s->{pkg}} or + not exists $sources{$s->{pkg}}{$s->{src_vers}{ver}} + ) { + push @sa_to_del, + $s->{src_associations}{id}; + } + $included_sa{$s->{pkg}}{$s->{src_vers}} = 1; + } + # Calculate which source packages are newly in this suite + for my $s (keys %sources) { + for my $v (keys %{$sources{$s}}) { + if (not exists $included_sa{$s} and + not $included_sa{$s}{$v}) { + push @sa_to_add, + [$s,$v,$sources{$s}{$v}]; + } else { + $p->update() if defined $p; + } + } + } + # add new source packages + my $it = natatime 100, @sa_to_add; + while (my @v = $it->()) { + $schema->txn_do( + sub { + for my $svm (@_) { + my $s_id = $schema->resultset('SrcPkg')-> + get_or_create_src_pkg_id($svm->[0]); + my $sv_id = $schema->resultset('SrcVer')-> + get_src_ver_id($s_id,$svm->[1],$maints->{$svm->[2]}); + $schema->resultset('SrcAssociation')-> + insert_suite_src_ver_association($suite_id,$sv_id); + } + }, + @v + ); + $p->update($p->last_update()+ + scalar @v) if defined $p; + } + # remove associations for packages not in this suite + if (@sa_to_del) { + $it = natatime 1000, @sa_to_del; + while (my @v = $it->()) { + $schema-> + txn_do(sub { + $schema->resultset('SrcAssociation')-> + search_rs({id => \@v})-> + delete(); + }); + } + } + # update packages in this suite to have a modification time of now + $schema->resultset('SrcAssociation')-> + search_rs({suite => $suite_id})-> + update({modified => 'NOW()'}); + ## Handle binary packages + my @bin_to_del; + my @bin_to_add; + my %included_bin; + # calculate which binary packages are no longer in this suite + for my $b ($schema->resultset('BinPkg')-> + bin_pkg_and_ver_in_suite($suite)) { + if (not exists $bins{$b->{arch}{arch}} or + not exists $bins{$b->{arch}{arch}}{$b->{pkg}} or + ($bins{$b->{arch}{arch}}{$b->{pkg}}{bin_ver} ne + $b->{bin_vers}{ver} + ) + ) { + push @bin_to_del, + $b->{bin_associations}{id}; + } + $included_bin{$b->{arch}{arch}}{$b->{pkg}} = + $b->{bin_vers}{ver}; + } + # calculate which binary packages are newly in this suite + for my $a (keys %bins) { + for my $pkg (keys %{$bins{$a}}) { + if (not exists $included_bin{$a} or + not exists $included_bin{$a}{$pkg} or + $bins{$a}{$pkg}{bin_ver} ne + $included_bin{$a}{$pkg}) { + push @bin_to_add, + $bins{$a}{$pkg}; + } else { + $p->update() if defined $p; + } + } + } + $it = natatime 100, @bin_to_add; + while (my @v = $it->()) { + $schema->txn_do( + sub { + for my $bvm (@_) { + my $s_id = $schema->resultset('SrcPkg')-> + get_or_create_src_pkg_id($bvm->{source}); + my $sv_id = $schema->resultset('SrcVer')-> + get_src_ver_id($s_id,$bvm->{src_ver},$maints->{$bvm->{maint}}); + my $b_id = $schema->resultset('BinPkg')-> + get_or_create_bin_pkg_id($bvm->{bin}); + my $bv_id = $schema->resultset('BinVer')-> + get_bin_ver_id($b_id,$bvm->{bin_ver}, + $archs->{$bvm->{arch}},$sv_id); + $schema->resultset('BinAssociation')-> + insert_suite_bin_ver_association($suite_id,$bv_id); + } + }, + @v + ); + $p->update($p->last_update()+ + scalar @v) if defined $p; + } + if (@bin_to_del) { + $it = natatime 1000, @bin_to_del; + while (my @v = $it->()) { + $schema-> + txn_do(sub { + $schema->resultset('BinAssociation')-> + search_rs({id => \@v})-> + delete(); + }); + } + } + $schema->resultset('BinAssociation')-> + search_rs({suite => $suite_id})-> + update({modified => 'NOW()'}); + +} + + +=back + +=cut + +=head2 Suites + +=over + +=item load_suite + + load_suite($schema,$codename,$suite,$version,$active); + +=cut + +sub load_suite { + my ($schema,$codename,$suite,$version,$active) = @_; + if (ref($codename)) { + ($codename,$suite,$version) = + @{$codename}{qw(Codename Suite Version)}; + $active = 1; + } + my $s = $schema->resultset('Suite')->find_or_create({codename => $codename}); + $s->suite_name($suite); + $s->version($version); + $s->active($active); + $s->update(); + return $s; + +} + +=back + +=cut + +1; + + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/lib/Debbugs/DB/Result/.gitignore b/lib/Debbugs/DB/Result/.gitignore new file mode 100644 index 0000000..5a4e08f --- /dev/null +++ b/lib/Debbugs/DB/Result/.gitignore @@ -0,0 +1,2 @@ +ColumnComment.pm +TableComment.pm diff --git a/lib/Debbugs/DB/Result/Arch.pm b/lib/Debbugs/DB/Result/Arch.pm new file mode 100644 index 0000000..3045047 --- /dev/null +++ b/lib/Debbugs/DB/Result/Arch.pm @@ -0,0 +1,134 @@ +use utf8; +package Debbugs::DB::Result::Arch; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::Arch - Architectures + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("arch"); + +=head1 ACCESSORS + +=head2 id + + data_type: 'integer' + is_auto_increment: 1 + is_nullable: 0 + sequence: 'arch_id_seq' + +Architecture id + +=head2 arch + + data_type: 'text' + is_nullable: 0 + +Architecture name + +=cut + +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "arch_id_seq", + }, + "arch", + { data_type => "text", is_nullable => 0 }, +); + +=head1 PRIMARY KEY + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->set_primary_key("id"); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("arch_arch_key", ["arch"]); + +=head1 RELATIONS + +=head2 bin_vers + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bin_vers", + "Debbugs::DB::Result::BinVer", + { "foreign.arch" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bug_status_caches + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_status_caches", + "Debbugs::DB::Result::BugStatusCache", + { "foreign.arch" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07042 @ 2014-11-30 21:56:51 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:9pDiZg68Odz66DpCB9GpsA + + +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/lib/Debbugs/DB/Result/BinAssociation.pm b/lib/Debbugs/DB/Result/BinAssociation.pm new file mode 100644 index 0000000..7ae23fa --- /dev/null +++ b/lib/Debbugs/DB/Result/BinAssociation.pm @@ -0,0 +1,179 @@ +use utf8; +package Debbugs::DB::Result::BinAssociation; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::BinAssociation - Binary <-> suite associations + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("bin_associations"); + +=head1 ACCESSORS + +=head2 id + + data_type: 'integer' + is_auto_increment: 1 + is_nullable: 0 + sequence: 'bin_associations_id_seq' + +Binary <-> suite association id + +=head2 suite + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Suite id (matches suite) + +=head2 bin + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Binary version id (matches bin_ver) + +=head2 created + + data_type: 'timestamp with time zone' + default_value: current_timestamp + is_nullable: 0 + original: {default_value => \"now()"} + +Time this binary package entered this suite + +=head2 modified + + data_type: 'timestamp with time zone' + default_value: current_timestamp + is_nullable: 0 + original: {default_value => \"now()"} + +Time this entry was modified + +=cut + +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "bin_associations_id_seq", + }, + "suite", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "bin", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "created", + { + data_type => "timestamp with time zone", + default_value => \"current_timestamp", + is_nullable => 0, + original => { default_value => \"now()" }, + }, + "modified", + { + data_type => "timestamp with time zone", + default_value => \"current_timestamp", + is_nullable => 0, + original => { default_value => \"now()" }, + }, +); + +=head1 PRIMARY KEY + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->set_primary_key("id"); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("bin_associations_bin_suite", ["bin", "suite"]); + +=head1 RELATIONS + +=head2 bin + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "bin", + "Debbugs::DB::Result::BinVer", + { id => "bin" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + +=head2 suite + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "suite", + "Debbugs::DB::Result::Suite", + { id => "suite" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07045 @ 2016-11-24 09:00:00 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:3F77iWjlJrHs/98TOfroAA + + +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/lib/Debbugs/DB/Result/BinPkg.pm b/lib/Debbugs/DB/Result/BinPkg.pm new file mode 100644 index 0000000..0e0c554 --- /dev/null +++ b/lib/Debbugs/DB/Result/BinPkg.pm @@ -0,0 +1,164 @@ +use utf8; +package Debbugs::DB::Result::BinPkg; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::BinPkg - Binary packages + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("bin_pkg"); + +=head1 ACCESSORS + +=head2 id + + data_type: 'integer' + is_auto_increment: 1 + is_nullable: 0 + sequence: 'bin_pkg_id_seq' + +Binary package id + +=head2 pkg + + data_type: 'text' + is_nullable: 0 + +Binary package name + +=cut + +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "bin_pkg_id_seq", + }, + "pkg", + { data_type => "text", is_nullable => 0 }, +); + +=head1 PRIMARY KEY + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->set_primary_key("id"); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("bin_pkg_pkg_key", ["pkg"]); + +=head1 RELATIONS + +=head2 bin_pkg_src_pkgs + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bin_pkg_src_pkgs", + "Debbugs::DB::Result::BinPkgSrcPkg", + { "foreign.bin_pkg" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bin_vers + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bin_vers", + "Debbugs::DB::Result::BinVer", + { "foreign.bin_pkg" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bug_affects_binpackages + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_affects_binpackages", + "Debbugs::DB::Result::BugAffectsBinpackage", + { "foreign.bin_pkg" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bug_binpackages + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_binpackages", + "Debbugs::DB::Result::BugBinpackage", + { "foreign.bin_pkg" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07049 @ 2019-07-05 20:56:47 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:VH/9QrwjZx0r7FLaEWGYMg + + +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/lib/Debbugs/DB/Result/BinPkgSrcPkg.pm b/lib/Debbugs/DB/Result/BinPkgSrcPkg.pm new file mode 100644 index 0000000..4836b05 --- /dev/null +++ b/lib/Debbugs/DB/Result/BinPkgSrcPkg.pm @@ -0,0 +1,198 @@ +use utf8; +package Debbugs::DB::Result::BinPkgSrcPkg; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::BinPkgSrcPkg - Binary package <-> source package mapping sumpmary table + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("bin_pkg_src_pkg"); + +=head1 ACCESSORS + +=head2 bin_pkg + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Binary package id (matches bin_pkg) + +=head2 src_pkg + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Source package id (matches src_pkg) + +=cut + +__PACKAGE__->add_columns( + "bin_pkg", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "src_pkg", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, +); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("bin_pkg_src_pkg_bin_pkg_src_pkg", ["bin_pkg", "src_pkg"]); + +=head2 C + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("bin_pkg_src_pkg_src_pkg_bin_pkg", ["src_pkg", "bin_pkg"]); + +=head1 RELATIONS + +=head2 bin_pkg + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "bin_pkg", + "Debbugs::DB::Result::BinPkg", + { id => "bin_pkg" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + +=head2 src_pkg + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "src_pkg", + "Debbugs::DB::Result::SrcPkg", + { id => "src_pkg" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07048 @ 2018-04-18 16:55:56 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:O/v5RtjJF9SgxXEy76U/xw + +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + $sqlt_table->schema-> + add_procedure(name => 'bin_ver_to_src_pkg', + sql => <<'EOF', +CREATE OR REPLACE FUNCTION bin_ver_to_src_pkg(bin_ver INT) RETURNS INT + AS $src_pkg_from_bin_ver$ + DECLARE + src_pkg int; + BEGIN + SELECT sv.src_pkg INTO STRICT src_pkg + FROM bin_ver bv JOIN src_ver sv ON bv.src_ver=sv.id + WHERE bv.id=bin_ver; + RETURN src_pkg; + END + $src_pkg_from_bin_ver$ LANGUAGE plpgsql; +EOF + ); + $sqlt_table->schema-> + add_procedure(name => 'src_ver_to_src_pkg', + sql => <<'EOF', +CREATE OR REPLACE FUNCTION src_ver_to_src_pkg(src_ver INT) RETURNS INT + AS $src_ver_to_src_pkg$ + DECLARE + src_pkg int; + BEGIN + SELECT sv.src_pkg INTO STRICT src_pkg + FROM src_ver sv WHERE sv.id=src_ver; + RETURN src_pkg; + END + $src_ver_to_src_pkg$ LANGUAGE plpgsql; +EOF + ); + $sqlt_table->schema-> + add_procedure(name => 'update_bin_pkg_src_pkg_bin_ver', + sql => <<'EOF', +CREATE OR REPLACE FUNCTION update_bin_pkg_src_pkg_bin_ver () RETURNS TRIGGER + AS $update_bin_pkg_src_pkg_bin_ver$ + DECLARE + src_ver_rows integer; + BEGIN + IF (TG_OP = 'DELETE' OR TG_OP = 'UPDATE' ) THEN + -- if there is still a bin_ver with this src_pkg, then do nothing + PERFORM * FROM bin_ver bv JOIN src_ver sv ON bv.src_ver = sv.id + WHERE sv.id = OLD.src_ver LIMIT 2; + GET DIAGNOSTICS src_ver_rows = ROW_COUNT; + IF (src_ver_rows <= 1) THEN + DELETE FROM bin_pkg_src_pkg + WHERE bin_pkg=OLD.bin_pkg AND + src_pkg=src_ver_to_src_pkg(OLD.src_ver); + END IF; + END IF; + IF (TG_OP = 'INSERT' OR TG_OP = 'UPDATE') THEN + BEGIN + INSERT INTO bin_pkg_src_pkg (bin_pkg,src_pkg) + VALUES (NEW.bin_pkg,src_ver_to_src_pkg(NEW.src_ver)) + ON CONFLICT (bin_pkg,src_pkg) DO NOTHING; + END; + END IF; + RETURN NULL; + END + $update_bin_pkg_src_pkg_bin_ver$ LANGUAGE plpgsql; +EOF + ); + +} + +1; diff --git a/lib/Debbugs/DB/Result/BinVer.pm b/lib/Debbugs/DB/Result/BinVer.pm new file mode 100644 index 0000000..9eb144b --- /dev/null +++ b/lib/Debbugs/DB/Result/BinVer.pm @@ -0,0 +1,264 @@ +use utf8; +package Debbugs::DB::Result::BinVer; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::BinVer - Binary versions + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("bin_ver"); + +=head1 ACCESSORS + +=head2 id + + data_type: 'integer' + is_auto_increment: 1 + is_nullable: 0 + sequence: 'bin_ver_id_seq' + +Binary version id + +=head2 bin_pkg + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Binary package id (matches bin_pkg) + +=head2 src_ver + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Source version (matchines src_ver) + +=head2 arch + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Architecture id (matches arch) + +=head2 ver + + data_type: 'debversion' + is_nullable: 0 + +Binary version + +=cut + +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "bin_ver_id_seq", + }, + "bin_pkg", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "src_ver", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "arch", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "ver", + { data_type => "debversion", is_nullable => 0 }, +); + +=head1 PRIMARY KEY + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->set_primary_key("id"); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("bin_ver_bin_pkg_id_arch_idx", ["bin_pkg", "arch", "ver"]); + +=head1 RELATIONS + +=head2 arch + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "arch", + "Debbugs::DB::Result::Arch", + { id => "arch" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + +=head2 bin_associations + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bin_associations", + "Debbugs::DB::Result::BinAssociation", + { "foreign.bin" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bin_pkg + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "bin_pkg", + "Debbugs::DB::Result::BinPkg", + { id => "bin_pkg" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + +=head2 src_ver + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "src_ver", + "Debbugs::DB::Result::SrcVer", + { id => "src_ver" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07045 @ 2016-11-24 09:08:27 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:DzTzZbPkilT8WMhXoZv9xw + + +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + for my $idx (qw(ver bin_pkg src_ver)) { + $sqlt_table->add_index(name => 'bin_ver_'.$idx.'_id_idx', + fields => [$idx]); + } + $sqlt_table->add_index(name => 'bin_ver_src_ver_id_arch_idx', + fields => [qw(src_ver arch)] + ); + $sqlt_table->schema-> + add_procedure(name => 'bin_ver_to_src_pkg', + sql => <<'EOF', +CREATE OR REPLACE FUNCTION bin_ver_to_src_pkg(bin_ver INT) RETURNS INT + AS $src_pkg_from_bin_ver$ + DECLARE + src_pkg int; + BEGIN + SELECT sv.src_pkg INTO STRICT src_pkg + FROM bin_ver bv JOIN src_ver sv ON bv.src_ver=sv.id + WHERE bv.id=bin_ver; + RETURN src_pkg; + END + $src_pkg_from_bin_ver$ LANGUAGE plpgsql; +EOF + ); + $sqlt_table->schema-> + add_procedure(name => 'update_bin_pkg_src_pkg_bin_ver', + sql => <<'EOF', +CREATE OR REPLACE FUNCTION update_bin_pkg_src_pkg_bin_ver () RETURNS TRIGGER + AS $update_bin_pkg_src_pkg_bin_ver$ + DECLARE + src_ver_rows integer; + BEGIN + IF (TG_OP = 'DELETE' OR TG_OP = 'UPDATE' ) THEN + -- if there is still a bin_ver with this src_pkg, then do nothing + PERFORM * FROM bin_ver bv JOIN src_ver sv ON bv.src_ver = sv.id + WHERE sv.id = OLD.src_ver LIMIT 2; + GET DIAGNOSTICS src_ver_rows = ROW_COUNT; + IF (src_ver_rows <= 1) THEN + DELETE FROM bin_pkg_src_pkg + WHERE bin_pkg=OLD.bin_pkg AND + src_pkg=src_ver_to_src_pkg(OLD.src_ver); + END IF; + END IF; + IF (TG_OP = 'INSERT' OR TG_OP = 'UPDATE') THEN + BEGIN + INSERT INTO bin_pkg_src_pkg (bin_pkg,src_pkg) + VALUES (NEW.bin_pkg,src_ver_to_src_pkg(NEW.src_ver)) + ON CONFLICT (bin_pkg,src_pkg) DO NOTHING; + END; + END IF; + RETURN NULL; + END + $update_bin_pkg_src_pkg_bin_ver$ LANGUAGE plpgsql; +EOF + ); +# $sqlt_table->schema-> +# add_trigger(name => 'bin_ver_update_bin_pkg_src_pkg', +# perform_action_when => 'after', +# database_events => [qw(INSERT UPDATE DELETE)], +# on_table => 'bin_ver', +# action => <<'EOF', +# FOR EACH ROW EXECUTE PROCEDURE update_bin_pkg_src_pkg_bin_ver(); +# EOF +# ); +} + +1; diff --git a/lib/Debbugs/DB/Result/BinaryVersion.pm b/lib/Debbugs/DB/Result/BinaryVersion.pm new file mode 100644 index 0000000..426b725 --- /dev/null +++ b/lib/Debbugs/DB/Result/BinaryVersion.pm @@ -0,0 +1,112 @@ +use utf8; +package Debbugs::DB::Result::BinaryVersion; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::BinaryVersion + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); +__PACKAGE__->table_class("DBIx::Class::ResultSource::View"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("binary_versions"); +__PACKAGE__->result_source_instance->view_definition(" SELECT sp.pkg AS src_pkg,\n sv.ver AS src_ver,\n bp.pkg AS bin_pkg,\n a.arch,\n b.ver AS bin_ver,\n svb.ver AS src_ver_based_on,\n spb.pkg AS src_pkg_based_on\n FROM ((((((bin_ver b\n JOIN arch a ON ((b.arch = a.id)))\n JOIN bin_pkg bp ON ((b.bin_pkg = bp.id)))\n JOIN src_ver sv ON ((b.src_ver = sv.id)))\n JOIN src_pkg sp ON ((sv.src_pkg = sp.id)))\n LEFT JOIN src_ver svb ON ((sv.based_on = svb.id)))\n LEFT JOIN src_pkg spb ON ((spb.id = svb.src_pkg)))"); + +=head1 ACCESSORS + +=head2 src_pkg + + data_type: 'text' + is_nullable: 1 + +=head2 src_ver + + data_type: 'debversion' + is_nullable: 1 + +=head2 bin_pkg + + data_type: 'text' + is_nullable: 1 + +=head2 arch + + data_type: 'text' + is_nullable: 1 + +=head2 bin_ver + + data_type: 'debversion' + is_nullable: 1 + +=head2 src_ver_based_on + + data_type: 'debversion' + is_nullable: 1 + +=head2 src_pkg_based_on + + data_type: 'text' + is_nullable: 1 + +=cut + +__PACKAGE__->add_columns( + "src_pkg", + { data_type => "text", is_nullable => 1 }, + "src_ver", + { data_type => "debversion", is_nullable => 1 }, + "bin_pkg", + { data_type => "text", is_nullable => 1 }, + "arch", + { data_type => "text", is_nullable => 1 }, + "bin_ver", + { data_type => "debversion", is_nullable => 1 }, + "src_ver_based_on", + { data_type => "debversion", is_nullable => 1 }, + "src_pkg_based_on", + { data_type => "text", is_nullable => 1 }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-04 10:59:03 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:0MeJnGxBc8gdEoPE6Sn6Sw + +__PACKAGE__->result_source_instance->view_definition(< + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("bug"); + +=head1 ACCESSORS + +=head2 id + + data_type: 'integer' + is_nullable: 0 + +Bug number + +=head2 creation + + data_type: 'timestamp with time zone' + default_value: current_timestamp + is_nullable: 0 + original: {default_value => \"now()"} + +Time bug created + +=head2 log_modified + + data_type: 'timestamp with time zone' + default_value: current_timestamp + is_nullable: 0 + original: {default_value => \"now()"} + +Time bug log was last modified + +=head2 last_modified + + data_type: 'timestamp with time zone' + default_value: current_timestamp + is_nullable: 0 + original: {default_value => \"now()"} + +Time bug status was last modified + +=head2 archived + + data_type: 'boolean' + default_value: false + is_nullable: 0 + +True if bug has been archived + +=head2 unarchived + + data_type: 'timestamp with time zone' + is_nullable: 1 + +Time bug was last unarchived; null if bug has never been unarchived + +=head2 forwarded + + data_type: 'text' + default_value: (empty string) + is_nullable: 0 + +Where bug has been forwarded to; empty if it has not been forwarded + +=head2 summary + + data_type: 'text' + default_value: (empty string) + is_nullable: 0 + +Summary of the bug; empty if it has no summary + +=head2 outlook + + data_type: 'text' + default_value: (empty string) + is_nullable: 0 + +Outlook of the bug; empty if it has no outlook + +=head2 subject + + data_type: 'text' + is_nullable: 0 + +Subject of the bug + +=head2 severity + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +=head2 done + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 1 + +Individual who did the -done; empty if it has never been -done + +=head2 done_full + + data_type: 'text' + default_value: (empty string) + is_nullable: 0 + +=head2 owner + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 1 + +Individual who owns this bug; empty if no one owns it + +=head2 owner_full + + data_type: 'text' + default_value: (empty string) + is_nullable: 0 + +=head2 submitter + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 1 + +Individual who submitted this bug; empty if there is no submitter + +=head2 submitter_full + + data_type: 'text' + default_value: (empty string) + is_nullable: 0 + +=head2 unknown_packages + + data_type: 'text' + default_value: (empty string) + is_nullable: 0 + +Package name if the package is not known + +=head2 unknown_affects + + data_type: 'text' + default_value: (empty string) + is_nullable: 0 + +Package name if the affected package is not known + +=cut + +__PACKAGE__->add_columns( + "id", + { data_type => "integer", is_nullable => 0 }, + "creation", + { + data_type => "timestamp with time zone", + default_value => \"current_timestamp", + is_nullable => 0, + original => { default_value => \"now()" }, + }, + "log_modified", + { + data_type => "timestamp with time zone", + default_value => \"current_timestamp", + is_nullable => 0, + original => { default_value => \"now()" }, + }, + "last_modified", + { + data_type => "timestamp with time zone", + default_value => \"current_timestamp", + is_nullable => 0, + original => { default_value => \"now()" }, + }, + "archived", + { data_type => "boolean", default_value => \"false", is_nullable => 0 }, + "unarchived", + { data_type => "timestamp with time zone", is_nullable => 1 }, + "forwarded", + { data_type => "text", default_value => "", is_nullable => 0 }, + "summary", + { data_type => "text", default_value => "", is_nullable => 0 }, + "outlook", + { data_type => "text", default_value => "", is_nullable => 0 }, + "subject", + { data_type => "text", is_nullable => 0 }, + "severity", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "done", + { data_type => "integer", is_foreign_key => 1, is_nullable => 1 }, + "done_full", + { data_type => "text", default_value => "", is_nullable => 0 }, + "owner", + { data_type => "integer", is_foreign_key => 1, is_nullable => 1 }, + "owner_full", + { data_type => "text", default_value => "", is_nullable => 0 }, + "submitter", + { data_type => "integer", is_foreign_key => 1, is_nullable => 1 }, + "submitter_full", + { data_type => "text", default_value => "", is_nullable => 0 }, + "unknown_packages", + { data_type => "text", default_value => "", is_nullable => 0 }, + "unknown_affects", + { data_type => "text", default_value => "", is_nullable => 0 }, +); + +=head1 PRIMARY KEY + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->set_primary_key("id"); + +=head1 RELATIONS + +=head2 bug_affects_binpackages + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_affects_binpackages", + "Debbugs::DB::Result::BugAffectsBinpackage", + { "foreign.bug" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bug_affects_srcpackages + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_affects_srcpackages", + "Debbugs::DB::Result::BugAffectsSrcpackage", + { "foreign.bug" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bug_binpackages + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_binpackages", + "Debbugs::DB::Result::BugBinpackage", + { "foreign.bug" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bug_blocks_blocks + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_blocks_blocks", + "Debbugs::DB::Result::BugBlock", + { "foreign.blocks" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bug_blocks_bugs + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_blocks_bugs", + "Debbugs::DB::Result::BugBlock", + { "foreign.bug" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bug_merged_bugs + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_merged_bugs", + "Debbugs::DB::Result::BugMerged", + { "foreign.bug" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bug_mergeds_merged + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_mergeds_merged", + "Debbugs::DB::Result::BugMerged", + { "foreign.merged" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bug_messages + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_messages", + "Debbugs::DB::Result::BugMessage", + { "foreign.bug" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bug_srcpackages + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_srcpackages", + "Debbugs::DB::Result::BugSrcpackage", + { "foreign.bug" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bug_status_caches + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_status_caches", + "Debbugs::DB::Result::BugStatusCache", + { "foreign.bug" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bug_tags + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_tags", + "Debbugs::DB::Result::BugTag", + { "foreign.bug" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bug_user_tags + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_user_tags", + "Debbugs::DB::Result::BugUserTag", + { "foreign.bug" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bug_vers + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_vers", + "Debbugs::DB::Result::BugVer", + { "foreign.bug" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 done + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "done", + "Debbugs::DB::Result::Correspondent", + { id => "done" }, + { + is_deferrable => 0, + join_type => "LEFT", + on_delete => "NO ACTION", + on_update => "NO ACTION", + }, +); + +=head2 owner + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "owner", + "Debbugs::DB::Result::Correspondent", + { id => "owner" }, + { + is_deferrable => 0, + join_type => "LEFT", + on_delete => "NO ACTION", + on_update => "NO ACTION", + }, +); + +=head2 severity + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "severity", + "Debbugs::DB::Result::Severity", + { id => "severity" }, + { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, +); + +=head2 submitter + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "submitter", + "Debbugs::DB::Result::Correspondent", + { id => "submitter" }, + { + is_deferrable => 0, + join_type => "LEFT", + on_delete => "NO ACTION", + on_update => "NO ACTION", + }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07048 @ 2018-04-11 13:06:55 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:qxkLXbv8JGoV9reebbOUEw + +use Carp; +use List::AllUtils qw(uniq); + +__PACKAGE__->many_to_many(tags => 'bug_tags','tag'); +__PACKAGE__->many_to_many(user_tags => 'bug_user_tags','user_tag'); +__PACKAGE__->many_to_many(srcpackages => 'bug_srcpackages','src_pkg'); +__PACKAGE__->many_to_many(binpackages => 'bug_binpackages','bin_pkg'); +__PACKAGE__->many_to_many(affects_binpackages => 'bug_affects_binpackages','bin_pkg'); +__PACKAGE__->many_to_many(affects_srcpackages => 'bug_affects_srcpackages','src_pkg'); +__PACKAGE__->many_to_many(messages => 'bug_messages','message'); + +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + # CREATE INDEX bug_idx_owner ON bug(owner); + # CREATE INDEX bug_idx_submitter ON bug(submitter); + # CREATE INDEX bug_idx_done ON bug(done); + # CREATE INDEX bug_idx_forwarded ON bug(forwarded); + # CREATE INDEX bug_idx_last_modified ON bug(last_modified); + # CREATE INDEX bug_idx_severity ON bug(severity); + # CREATE INDEX bug_idx_creation ON bug(creation); + # CREATE INDEX bug_idx_log_modified ON bug(log_modified); + for my $idx (qw(owner submitter done forwarded last_modified), + qw(severity creation log_modified), + ) { + $sqlt_table->add_index(name => 'bug_idx'.$idx, + fields => [$idx]); + } +} + +=head1 Utility Functions + +=cut + +=head2 set_related_packages + + $b->set_related_packages($relationship, + \@packages, + $package_cache , + ); + +Set bug-related packages. + +=cut + +sub set_related_packages { + my ($self,$relationship,$pkgs,$pkg_cache) = @_; + + my @unset_packages; + my @pkg_ids; + if ($relationship =~ /binpackages/) { + for my $pkg (@{$pkgs}) { + my $pkg_id = + $self->result_source->schema->resultset('BinPkg')-> + get_bin_pkg_id($pkg); + if (not defined $pkg_id) { + push @unset_packages,$pkg; + } else { + push @pkg_ids, $pkg_id; + } + } + } elsif ($relationship =~ /srcpackages/) { + for my $pkg (@{$pkgs}) { + my $pkg_id = + $self->result_source->schema->resultset('SrcPkg')-> + get_src_pkg_id($pkg); + if (not defined $pkg_id) { + push @unset_packages,$pkg; + } else { + push @pkg_ids,$pkg_id; + } + } + } else { + croak "Unsupported relationship $relationship"; + } + @pkg_ids = uniq @pkg_ids; + if ($relationship eq 'binpackages') { + $self->set_binpackages([map {{id => $_}} @pkg_ids]); + } elsif ($relationship eq 'srcpackages') { + $self->set_srcpackages([map {{id => $_}} @pkg_ids]); + } elsif ($relationship eq 'affects_binpackages') { + $self->set_affects_binpackages([map {{id => $_}} @pkg_ids]); + } elsif ($relationship eq 'affects_srcpackages') { + $self->set_affects_srcpackages([map {{id => $_}} @pkg_ids]); + } else { + croak "Unsupported relationship $relationship"; + } + return @unset_packages +} +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/lib/Debbugs/DB/Result/BugAffectsBinpackage.pm b/lib/Debbugs/DB/Result/BugAffectsBinpackage.pm new file mode 100644 index 0000000..ce4b57e --- /dev/null +++ b/lib/Debbugs/DB/Result/BugAffectsBinpackage.pm @@ -0,0 +1,119 @@ +use utf8; +package Debbugs::DB::Result::BugAffectsBinpackage; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::BugAffectsBinpackage - Bug <-> binary package mapping + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("bug_affects_binpackage"); + +=head1 ACCESSORS + +=head2 bug + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Bug id (matches bug) + +=head2 bin_pkg + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Binary package id (matches bin_pkg) + +=cut + +__PACKAGE__->add_columns( + "bug", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "bin_pkg", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, +); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("bug_affects_binpackage_id_pkg", ["bug", "bin_pkg"]); + +=head1 RELATIONS + +=head2 bin_pkg + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "bin_pkg", + "Debbugs::DB::Result::BinPkg", + { id => "bin_pkg" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + +=head2 bug + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "bug", + "Debbugs::DB::Result::Bug", + { id => "bug" }, + { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-04 10:59:03 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:qPJSly5VwC8Fl9hchBtB1Q + + +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/lib/Debbugs/DB/Result/BugAffectsSrcpackage.pm b/lib/Debbugs/DB/Result/BugAffectsSrcpackage.pm new file mode 100644 index 0000000..e25fa60 --- /dev/null +++ b/lib/Debbugs/DB/Result/BugAffectsSrcpackage.pm @@ -0,0 +1,119 @@ +use utf8; +package Debbugs::DB::Result::BugAffectsSrcpackage; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::BugAffectsSrcpackage - Bug <-> source package mapping + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("bug_affects_srcpackage"); + +=head1 ACCESSORS + +=head2 bug + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Bug id (matches bug) + +=head2 src_pkg + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Source package id (matches src_pkg) + +=cut + +__PACKAGE__->add_columns( + "bug", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "src_pkg", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, +); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("bug_affects_srcpackage_id_pkg", ["bug", "src_pkg"]); + +=head1 RELATIONS + +=head2 bug + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "bug", + "Debbugs::DB::Result::Bug", + { id => "bug" }, + { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, +); + +=head2 src_pkg + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "src_pkg", + "Debbugs::DB::Result::SrcPkg", + { id => "src_pkg" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-04 10:59:03 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:1TkTacVNBhXOnzV1ttCF2A + + +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/lib/Debbugs/DB/Result/BugBinpackage.pm b/lib/Debbugs/DB/Result/BugBinpackage.pm new file mode 100644 index 0000000..2f2a29d --- /dev/null +++ b/lib/Debbugs/DB/Result/BugBinpackage.pm @@ -0,0 +1,139 @@ +use utf8; +package Debbugs::DB::Result::BugBinpackage; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::BugBinpackage - Bug <-> binary package mapping + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("bug_binpackage"); + +=head1 ACCESSORS + +=head2 bug + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Bug id (matches bug) + +=head2 bin_pkg + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Binary package id (matches bin_pkg) + +=cut + +__PACKAGE__->add_columns( + "bug", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "bin_pkg", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, +); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("bug_binpackage_bin_pkg_bug_idx", ["bin_pkg", "bug"]); + +=head2 C + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("bug_binpackage_id_pkg", ["bug", "bin_pkg"]); + +=head1 RELATIONS + +=head2 bin_pkg + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "bin_pkg", + "Debbugs::DB::Result::BinPkg", + { id => "bin_pkg" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + +=head2 bug + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "bug", + "Debbugs::DB::Result::Bug", + { id => "bug" }, + { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07049 @ 2019-07-05 21:00:23 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:STaqCap5Dk4AORK6ghGnPg + + +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + $sqlt_table->add_index(name => 'bug_binpackage_bin_pkg_idx', + fields => [qw(bin_pkg)], + ); +} + +1; diff --git a/lib/Debbugs/DB/Result/BugBlock.pm b/lib/Debbugs/DB/Result/BugBlock.pm new file mode 100644 index 0000000..0200a31 --- /dev/null +++ b/lib/Debbugs/DB/Result/BugBlock.pm @@ -0,0 +1,152 @@ +use utf8; +package Debbugs::DB::Result::BugBlock; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::BugBlock - Bugs which block other bugs + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("bug_blocks"); + +=head1 ACCESSORS + +=head2 id + + data_type: 'integer' + is_auto_increment: 1 + is_nullable: 0 + sequence: 'bug_blocks_id_seq' + +=head2 bug + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Bug number + +=head2 blocks + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Bug number which is blocked by bug + +=cut + +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "bug_blocks_id_seq", + }, + "bug", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "blocks", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, +); + +=head1 PRIMARY KEY + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->set_primary_key("id"); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("bug_blocks_bug_id_blocks_idx", ["bug", "blocks"]); + +=head1 RELATIONS + +=head2 block + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "block", + "Debbugs::DB::Result::Bug", + { id => "blocks" }, + { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, +); + +=head2 bug + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "bug", + "Debbugs::DB::Result::Bug", + { id => "bug" }, + { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07042 @ 2014-11-30 21:56:51 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:Rkt0XlA4r2YFX0KnUZmS6A + + +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + for my $idx (qw(bug blocks)) { + $sqlt_table->add_index(name => 'bug_blocks_'.$idx.'_idx', + fields => [$idx]); + } +} + +1; diff --git a/lib/Debbugs/DB/Result/BugMerged.pm b/lib/Debbugs/DB/Result/BugMerged.pm new file mode 100644 index 0000000..477919b --- /dev/null +++ b/lib/Debbugs/DB/Result/BugMerged.pm @@ -0,0 +1,151 @@ +use utf8; +package Debbugs::DB::Result::BugMerged; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::BugMerged - Bugs which are merged with other bugs + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("bug_merged"); + +=head1 ACCESSORS + +=head2 id + + data_type: 'integer' + is_auto_increment: 1 + is_nullable: 0 + sequence: 'bug_merged_id_seq' + +=head2 bug + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Bug number + +=head2 merged + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Bug number which is merged with bug + +=cut + +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "bug_merged_id_seq", + }, + "bug", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "merged", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, +); + +=head1 PRIMARY KEY + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->set_primary_key("id"); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("bug_merged_bug_id_merged_idx", ["bug", "merged"]); + +=head1 RELATIONS + +=head2 bug + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "bug", + "Debbugs::DB::Result::Bug", + { id => "bug" }, + { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, +); + +=head2 merged + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "merged", + "Debbugs::DB::Result::Bug", + { id => "merged" }, + { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07042 @ 2014-11-30 21:56:51 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:HdGeCb1Fh2cU08+TTQVi/Q + +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + for my $idx (qw(bug merged)) { + $sqlt_table->add_index(name => 'bug_merged_'.$idx.'_idx', + fields => [$idx]); + } +} + +1; diff --git a/lib/Debbugs/DB/Result/BugMessage.pm b/lib/Debbugs/DB/Result/BugMessage.pm new file mode 100644 index 0000000..b5fccc5 --- /dev/null +++ b/lib/Debbugs/DB/Result/BugMessage.pm @@ -0,0 +1,150 @@ +use utf8; +package Debbugs::DB::Result::BugMessage; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::BugMessage + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("bug_message"); + +=head1 ACCESSORS + +=head2 bug + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Bug id (matches bug) + +=head2 message + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Message id (matches message) + +=head2 message_number + + data_type: 'integer' + is_nullable: 0 + +Message number in the bug log + +=head2 bug_log_offset + + data_type: 'integer' + is_nullable: 1 + +Byte offset in the bug log + +=head2 offset_valid + + data_type: 'timestamp with time zone' + is_nullable: 1 + +Time offset was valid + +=cut + +__PACKAGE__->add_columns( + "bug", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "message", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "message_number", + { data_type => "integer", is_nullable => 0 }, + "bug_log_offset", + { data_type => "integer", is_nullable => 1 }, + "offset_valid", + { data_type => "timestamp with time zone", is_nullable => 1 }, +); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("bug_message_bug_message_idx", ["bug", "message"]); + +=head1 RELATIONS + +=head2 bug + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "bug", + "Debbugs::DB::Result::Bug", + { id => "bug" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + +=head2 message + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "message", + "Debbugs::DB::Result::Message", + { id => "message" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-04 10:59:03 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:BRbN9C6P/wvWWmSmjNGjLA + +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + $sqlt_table->add_index(name => 'bug_message_idx_bug_message_number', + fields => [qw(bug message_number)], + ); +} +1; diff --git a/lib/Debbugs/DB/Result/BugPackage.pm b/lib/Debbugs/DB/Result/BugPackage.pm new file mode 100644 index 0000000..db6f200 --- /dev/null +++ b/lib/Debbugs/DB/Result/BugPackage.pm @@ -0,0 +1,86 @@ +use utf8; +package Debbugs::DB::Result::BugPackage; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::BugPackage + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); +__PACKAGE__->table_class("DBIx::Class::ResultSource::View"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("bug_package"); +__PACKAGE__->result_source_instance->view_definition(" SELECT b.bug,\n b.bin_pkg AS pkg_id,\n 'binary'::text AS pkg_type,\n bp.pkg AS package\n FROM (bug_binpackage b\n JOIN bin_pkg bp ON ((bp.id = b.bin_pkg)))\nUNION\n SELECT s.bug,\n s.src_pkg AS pkg_id,\n 'source'::text AS pkg_type,\n sp.pkg AS package\n FROM (bug_srcpackage s\n JOIN src_pkg sp ON ((sp.id = s.src_pkg)))\nUNION\n SELECT b.bug,\n b.bin_pkg AS pkg_id,\n 'binary_affects'::text AS pkg_type,\n bp.pkg AS package\n FROM (bug_affects_binpackage b\n JOIN bin_pkg bp ON ((bp.id = b.bin_pkg)))\nUNION\n SELECT s.bug,\n s.src_pkg AS pkg_id,\n 'source_affects'::text AS pkg_type,\n sp.pkg AS package\n FROM (bug_affects_srcpackage s\n JOIN src_pkg sp ON ((sp.id = s.src_pkg)))"); + +=head1 ACCESSORS + +=head2 bug + + data_type: 'integer' + is_nullable: 1 + +=head2 pkg_id + + data_type: 'integer' + is_nullable: 1 + +=head2 pkg_type + + data_type: 'text' + is_nullable: 1 + +=head2 package + + data_type: 'text' + is_nullable: 1 + +=cut + +__PACKAGE__->add_columns( + "bug", + { data_type => "integer", is_nullable => 1 }, + "pkg_id", + { data_type => "integer", is_nullable => 1 }, + "pkg_type", + { data_type => "text", is_nullable => 1 }, + "package", + { data_type => "text", is_nullable => 1 }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-04-13 11:30:02 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:2Nrl+KO8b94gK5GcCkdNcw + +__PACKAGE__->result_source_instance->view_definition(< source package mapping + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("bug_srcpackage"); + +=head1 ACCESSORS + +=head2 bug + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Bug id (matches bug) + +=head2 src_pkg + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Source package id (matches src_pkg) + +=cut + +__PACKAGE__->add_columns( + "bug", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "src_pkg", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, +); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("bug_srcpackage_id_pkg", ["bug", "src_pkg"]); + +=head1 RELATIONS + +=head2 bug + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "bug", + "Debbugs::DB::Result::Bug", + { id => "bug" }, + { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, +); + +=head2 src_pkg + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "src_pkg", + "Debbugs::DB::Result::SrcPkg", + { id => "src_pkg" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-04 10:59:03 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:5SduyMaGHABDrX19Cxg4fg + +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + $sqlt_table->add_index(name => 'bug_srcpackage_src_pkg_idx', + fields => [qw(src_pkg)], + ); +} + +1; diff --git a/lib/Debbugs/DB/Result/BugStatus.pm b/lib/Debbugs/DB/Result/BugStatus.pm new file mode 100644 index 0000000..ee3efc8 --- /dev/null +++ b/lib/Debbugs/DB/Result/BugStatus.pm @@ -0,0 +1,179 @@ +use utf8; +package Debbugs::DB::Result::BugStatus; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::BugStatus + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); +__PACKAGE__->table_class("DBIx::Class::ResultSource::View"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("bug_status"); +__PACKAGE__->result_source_instance->view_definition(" SELECT b.id,\n b.id AS bug_num,\n string_agg(t.tag, ','::text) AS tags,\n b.subject,\n ( SELECT s.severity\n FROM severity s\n WHERE (s.id = b.severity)) AS severity,\n ( SELECT string_agg(package.package, ','::text ORDER BY package.package) AS string_agg\n FROM ( SELECT bp.pkg AS package\n FROM (bug_binpackage bbp\n JOIN bin_pkg bp ON ((bbp.bin_pkg = bp.id)))\n WHERE (bbp.bug = b.id)\n UNION\n SELECT concat('src:', sp.pkg) AS package\n FROM (bug_srcpackage bsp\n JOIN src_pkg sp ON ((bsp.src_pkg = sp.id)))\n WHERE (bsp.bug = b.id)) package) AS package,\n ( SELECT string_agg(affects.affects, ','::text ORDER BY affects.affects) AS string_agg\n FROM ( SELECT bp.pkg AS affects\n FROM (bug_affects_binpackage bbp\n JOIN bin_pkg bp ON ((bbp.bin_pkg = bp.id)))\n WHERE (bbp.bug = b.id)\n UNION\n SELECT concat('src:', sp.pkg) AS affects\n FROM (bug_affects_srcpackage bsp\n JOIN src_pkg sp ON ((bsp.src_pkg = sp.id)))\n WHERE (bsp.bug = b.id)) affects) AS affects,\n ( SELECT m.msgid\n FROM (message m\n LEFT JOIN bug_message bm ON ((bm.message = m.id)))\n WHERE (bm.bug = b.id)\n ORDER BY m.sent_date\n LIMIT 1) AS message_id,\n b.submitter_full AS originator,\n date_part('epoch'::text, b.log_modified) AS log_modified,\n date_part('epoch'::text, b.creation) AS date,\n date_part('epoch'::text, b.last_modified) AS last_modified,\n b.done_full AS done,\n string_agg((bb.blocks)::text, ' '::text ORDER BY bb.blocks) AS blocks,\n string_agg((bbb.bug)::text, ' '::text ORDER BY bbb.bug) AS blockedby,\n ( SELECT string_agg((bug.bug)::text, ' '::text ORDER BY bug.bug) AS string_agg\n FROM ( SELECT bm.merged AS bug\n FROM bug_merged bm\n WHERE (bm.bug = b.id)\n UNION\n SELECT bm.bug\n FROM bug_merged bm\n WHERE (bm.merged = b.id)) bug) AS mergedwith,\n ( SELECT string_agg(bv.ver_string, ' '::text) AS string_agg\n FROM bug_ver bv\n WHERE ((bv.bug = b.id) AND (bv.found IS TRUE))) AS found_versions,\n ( SELECT string_agg(bv.ver_string, ' '::text) AS string_agg\n FROM bug_ver bv\n WHERE ((bv.bug = b.id) AND (bv.found IS FALSE))) AS fixed_versions\n FROM ((((bug b\n LEFT JOIN bug_tag bt ON ((bt.bug = b.id)))\n LEFT JOIN tag t ON ((bt.tag = t.id)))\n LEFT JOIN bug_blocks bb ON ((bb.bug = b.id)))\n LEFT JOIN bug_blocks bbb ON ((bbb.blocks = b.id)))\n GROUP BY b.id"); + +=head1 ACCESSORS + +=head2 id + + data_type: 'integer' + is_nullable: 1 + +=head2 bug_num + + data_type: 'integer' + is_nullable: 1 + +=head2 tags + + data_type: 'text' + is_nullable: 1 + +=head2 subject + + data_type: 'text' + is_nullable: 1 + +=head2 severity + + data_type: 'text' + is_nullable: 1 + +=head2 package + + data_type: 'text' + is_nullable: 1 + +=head2 affects + + data_type: 'text' + is_nullable: 1 + +=head2 message_id + + data_type: 'text' + is_nullable: 1 + +=head2 originator + + data_type: 'text' + is_nullable: 1 + +=head2 log_modified + + data_type: 'double precision' + is_nullable: 1 + +=head2 date + + data_type: 'double precision' + is_nullable: 1 + +=head2 last_modified + + data_type: 'double precision' + is_nullable: 1 + +=head2 done + + data_type: 'text' + is_nullable: 1 + +=head2 blocks + + data_type: 'text' + is_nullable: 1 + +=head2 blockedby + + data_type: 'text' + is_nullable: 1 + +=head2 mergedwith + + data_type: 'text' + is_nullable: 1 + +=head2 found_versions + + data_type: 'text' + is_nullable: 1 + +=head2 fixed_versions + + data_type: 'text' + is_nullable: 1 + +=cut + +__PACKAGE__->add_columns( + "id", + { data_type => "integer", is_nullable => 1 }, + "bug_num", + { data_type => "integer", is_nullable => 1 }, + "tags", + { data_type => "text", is_nullable => 1 }, + "subject", + { data_type => "text", is_nullable => 1 }, + "severity", + { data_type => "text", is_nullable => 1 }, + "package", + { data_type => "text", is_nullable => 1 }, + "affects", + { data_type => "text", is_nullable => 1 }, + "message_id", + { data_type => "text", is_nullable => 1 }, + "originator", + { data_type => "text", is_nullable => 1 }, + "log_modified", + { data_type => "double precision", is_nullable => 1 }, + "date", + { data_type => "double precision", is_nullable => 1 }, + "last_modified", + { data_type => "double precision", is_nullable => 1 }, + "done", + { data_type => "text", is_nullable => 1 }, + "blocks", + { data_type => "text", is_nullable => 1 }, + "blockedby", + { data_type => "text", is_nullable => 1 }, + "mergedwith", + { data_type => "text", is_nullable => 1 }, + "found_versions", + { data_type => "text", is_nullable => 1 }, + "fixed_versions", + { data_type => "text", is_nullable => 1 }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07049 @ 2019-07-05 20:55:00 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:xkAEshcLIPrG/6hoRbSsrw + + +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/lib/Debbugs/DB/Result/BugStatusCache.pm b/lib/Debbugs/DB/Result/BugStatusCache.pm new file mode 100644 index 0000000..26b850e --- /dev/null +++ b/lib/Debbugs/DB/Result/BugStatusCache.pm @@ -0,0 +1,220 @@ +use utf8; +package Debbugs::DB::Result::BugStatusCache; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::BugStatusCache - Bug Status Cache + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("bug_status_cache"); + +=head1 ACCESSORS + +=head2 bug + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Bug number (matches bug) + +=head2 suite + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 1 + +Suite id (matches suite) + +=head2 arch + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 1 + +Architecture id (matches arch) + +=head2 status + + data_type: 'enum' + extra: {custom_type_name => "bug_status_type",list => ["absent","found","fixed","undef"]} + is_nullable: 0 + +Status (bug status) + +=head2 modified + + data_type: 'timestamp with time zone' + default_value: current_timestamp + is_nullable: 0 + original: {default_value => \"now()"} + +Time that this status was last modified + +=head2 asof + + data_type: 'timestamp with time zone' + default_value: current_timestamp + is_nullable: 0 + original: {default_value => \"now()"} + +Time that this status was last calculated + +=cut + +__PACKAGE__->add_columns( + "bug", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "suite", + { data_type => "integer", is_foreign_key => 1, is_nullable => 1 }, + "arch", + { data_type => "integer", is_foreign_key => 1, is_nullable => 1 }, + "status", + { + data_type => "enum", + extra => { + custom_type_name => "bug_status_type", + list => ["absent", "found", "fixed", "undef"], + }, + is_nullable => 0, + }, + "modified", + { + data_type => "timestamp with time zone", + default_value => \"current_timestamp", + is_nullable => 0, + original => { default_value => \"now()" }, + }, + "asof", + { + data_type => "timestamp with time zone", + default_value => \"current_timestamp", + is_nullable => 0, + original => { default_value => \"now()" }, + }, +); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint( + "bug_status_cache_bug_suite_arch_idx", + ["bug", "suite", "arch"], +); + +=head1 RELATIONS + +=head2 arch + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "arch", + "Debbugs::DB::Result::Arch", + { id => "arch" }, + { + is_deferrable => 0, + join_type => "LEFT", + on_delete => "CASCADE", + on_update => "CASCADE", + }, +); + +=head2 bug + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "bug", + "Debbugs::DB::Result::Bug", + { id => "bug" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + +=head2 suite + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "suite", + "Debbugs::DB::Result::Suite", + { id => "suite" }, + { + is_deferrable => 0, + join_type => "LEFT", + on_delete => "CASCADE", + on_update => "CASCADE", + }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-08-07 09:58:56 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:RNAken/j2+82FVCyCTnvQw + +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; +# $sqlt_table->add_index(name => 'bug_status_cache_bug_suite_arch_idx', +# fields => ['bug', +# q{COALESCE(suite,0)}, +# q{COALESCE(arch,0)},] +# ); + for my $f (qw(bug status arch suite asof)) { + $sqlt_table->add_index(name => 'bug_status_cache_idx_'.$f, + fields => [$f], + ); + } +} + +1; diff --git a/lib/Debbugs/DB/Result/BugTag.pm b/lib/Debbugs/DB/Result/BugTag.pm new file mode 100644 index 0000000..f5c6c24 --- /dev/null +++ b/lib/Debbugs/DB/Result/BugTag.pm @@ -0,0 +1,125 @@ +use utf8; +package Debbugs::DB::Result::BugTag; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::BugTag - Bug <-> tag mapping + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("bug_tag"); + +=head1 ACCESSORS + +=head2 bug + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Bug id (matches bug) + +=head2 tag + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Tag id (matches tag) + +=cut + +__PACKAGE__->add_columns( + "bug", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "tag", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, +); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("bug_tag_bug_tag", ["bug", "tag"]); + +=head1 RELATIONS + +=head2 bug + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "bug", + "Debbugs::DB::Result::Bug", + { id => "bug" }, + { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, +); + +=head2 tag + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "tag", + "Debbugs::DB::Result::Tag", + { id => "tag" }, + { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-04 10:59:03 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:yyHP5f8zAxn/AdjOCr8WAg + + +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + $sqlt_table->add_index(name => 'bug_tag_tag', + fields => [qw(tag)], + ); +} + +1; diff --git a/lib/Debbugs/DB/Result/BugUserTag.pm b/lib/Debbugs/DB/Result/BugUserTag.pm new file mode 100644 index 0000000..6d83c63 --- /dev/null +++ b/lib/Debbugs/DB/Result/BugUserTag.pm @@ -0,0 +1,123 @@ +use utf8; +package Debbugs::DB::Result::BugUserTag; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::BugUserTag - Bug <-> user tag mapping + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("bug_user_tag"); + +=head1 ACCESSORS + +=head2 bug + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Bug id (matches bug) + +=head2 user_tag + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +=cut + +__PACKAGE__->add_columns( + "bug", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "user_tag", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, +); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("bug_user_tag_bug_tag", ["bug", "user_tag"]); + +=head1 RELATIONS + +=head2 bug + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "bug", + "Debbugs::DB::Result::Bug", + { id => "bug" }, + { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, +); + +=head2 user_tag + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "user_tag", + "Debbugs::DB::Result::UserTag", + { id => "user_tag" }, + { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-04 10:59:03 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:jZngUCQ1eBBcfXd/jWCKGA + + +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + $sqlt_table->add_index(name => 'bug_user_tag_tag', + fields => [qw(user_tag)], + ); +} + +1; diff --git a/lib/Debbugs/DB/Result/BugVer.pm b/lib/Debbugs/DB/Result/BugVer.pm new file mode 100644 index 0000000..472a1df --- /dev/null +++ b/lib/Debbugs/DB/Result/BugVer.pm @@ -0,0 +1,247 @@ +use utf8; +package Debbugs::DB::Result::BugVer; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::BugVer - Bug versions + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("bug_ver"); + +=head1 ACCESSORS + +=head2 id + + data_type: 'integer' + is_auto_increment: 1 + is_nullable: 0 + sequence: 'bug_ver_id_seq' + +Bug version id + +=head2 bug + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Bug number + +=head2 ver_string + + data_type: 'text' + is_nullable: 1 + +Version string + +=head2 src_pkg + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 1 + +Source package id (matches src_pkg table) + +=head2 src_ver + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 1 + +Source package version id (matches src_ver table) + +=head2 found + + data_type: 'boolean' + default_value: true + is_nullable: 0 + +True if this is a found version; false if this is a fixed version + +=head2 creation + + data_type: 'timestamp with time zone' + default_value: current_timestamp + is_nullable: 0 + original: {default_value => \"now()"} + +Time that this entry was created + +=head2 last_modified + + data_type: 'timestamp with time zone' + default_value: current_timestamp + is_nullable: 0 + original: {default_value => \"now()"} + +Time that this entry was modified + +=cut + +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "bug_ver_id_seq", + }, + "bug", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "ver_string", + { data_type => "text", is_nullable => 1 }, + "src_pkg", + { data_type => "integer", is_foreign_key => 1, is_nullable => 1 }, + "src_ver", + { data_type => "integer", is_foreign_key => 1, is_nullable => 1 }, + "found", + { data_type => "boolean", default_value => \"true", is_nullable => 0 }, + "creation", + { + data_type => "timestamp with time zone", + default_value => \"current_timestamp", + is_nullable => 0, + original => { default_value => \"now()" }, + }, + "last_modified", + { + data_type => "timestamp with time zone", + default_value => \"current_timestamp", + is_nullable => 0, + original => { default_value => \"now()" }, + }, +); + +=head1 PRIMARY KEY + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->set_primary_key("id"); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint( + "bug_ver_bug_ver_string_found_idx", + ["bug", "ver_string", "found"], +); + +=head1 RELATIONS + +=head2 bug + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "bug", + "Debbugs::DB::Result::Bug", + { id => "bug" }, + { is_deferrable => 0, on_delete => "RESTRICT", on_update => "CASCADE" }, +); + +=head2 src_pkg + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "src_pkg", + "Debbugs::DB::Result::SrcPkg", + { id => "src_pkg" }, + { + is_deferrable => 0, + join_type => "LEFT", + on_delete => "SET NULL", + on_update => "CASCADE", + }, +); + +=head2 src_ver + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "src_ver", + "Debbugs::DB::Result::SrcVer", + { id => "src_ver" }, + { + is_deferrable => 0, + join_type => "LEFT", + on_delete => "SET NULL", + on_update => "CASCADE", + }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07042 @ 2014-11-30 21:56:51 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:cvdjFL2o+rBg2PfcintuNA + + +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + for my $idx (qw(src_pkg src_ver)) { + $sqlt_table->add_index(name => 'bug_ver_'.$idx.'_id_idx', + fields => [$idx]); + } + $sqlt_table->add_index(name => 'bug_ver_src_pkg_id_src_ver_id_idx', + fields => [qw(src_pkg src_ver)], + ); +} +1; diff --git a/lib/Debbugs/DB/Result/Correspondent.pm b/lib/Debbugs/DB/Result/Correspondent.pm new file mode 100644 index 0000000..b0a57ae --- /dev/null +++ b/lib/Debbugs/DB/Result/Correspondent.pm @@ -0,0 +1,209 @@ +use utf8; +package Debbugs::DB::Result::Correspondent; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::Correspondent - Individual who has corresponded with the BTS + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("correspondent"); + +=head1 ACCESSORS + +=head2 id + + data_type: 'integer' + is_auto_increment: 1 + is_nullable: 0 + sequence: 'correspondent_id_seq' + +Correspondent ID + +=head2 addr + + data_type: 'text' + is_nullable: 0 + +Correspondent address + +=cut + +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "correspondent_id_seq", + }, + "addr", + { data_type => "text", is_nullable => 0 }, +); + +=head1 PRIMARY KEY + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->set_primary_key("id"); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("correspondent_addr_idx", ["addr"]); + +=head1 RELATIONS + +=head2 bug_owners + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_owners", + "Debbugs::DB::Result::Bug", + { "foreign.owner" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bug_submitters + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_submitters", + "Debbugs::DB::Result::Bug", + { "foreign.submitter" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bugs_done + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bugs_done", + "Debbugs::DB::Result::Bug", + { "foreign.done" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 correspondent_full_names + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "correspondent_full_names", + "Debbugs::DB::Result::CorrespondentFullName", + { "foreign.correspondent" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 maintainers + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "maintainers", + "Debbugs::DB::Result::Maintainer", + { "foreign.correspondent" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 message_correspondents + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "message_correspondents", + "Debbugs::DB::Result::MessageCorrespondent", + { "foreign.correspondent" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 user_tags + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "user_tags", + "Debbugs::DB::Result::UserTag", + { "foreign.correspondent" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07045 @ 2016-09-24 14:51:07 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:CUVcqt94wCYJOPbiPt00+Q + + +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/lib/Debbugs/DB/Result/CorrespondentFullName.pm b/lib/Debbugs/DB/Result/CorrespondentFullName.pm new file mode 100644 index 0000000..a5be283 --- /dev/null +++ b/lib/Debbugs/DB/Result/CorrespondentFullName.pm @@ -0,0 +1,126 @@ +use utf8; +package Debbugs::DB::Result::CorrespondentFullName; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::CorrespondentFullName - Full names of BTS correspondents + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("correspondent_full_name"); + +=head1 ACCESSORS + +=head2 correspondent + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Correspondent ID (matches correspondent) + +=head2 full_name + + data_type: 'text' + is_nullable: 0 + +Correspondent full name (includes e-mail address) + +=head2 last_seen + + data_type: 'timestamp' + default_value: current_timestamp + is_nullable: 0 + original: {default_value => \"now()"} + +=cut + +__PACKAGE__->add_columns( + "correspondent", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "full_name", + { data_type => "text", is_nullable => 0 }, + "last_seen", + { + data_type => "timestamp", + default_value => \"current_timestamp", + is_nullable => 0, + original => { default_value => \"now()" }, + }, +); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint( + "correspondent_full_name_correspondent_full_name_idx", + ["correspondent", "full_name"], +); + +=head1 RELATIONS + +=head2 correspondent + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "correspondent", + "Debbugs::DB::Result::Correspondent", + { id => "correspondent" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-04 10:59:03 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:2Ac8mrDV2IsE/11YsYoqQQ + +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + for my $idx (qw(full_name last_seen)) { + $sqlt_table->add_index(name => 'correspondent_full_name_idx_'.$idx, + fields => [$idx]); + } +} + +1; diff --git a/lib/Debbugs/DB/Result/Maintainer.pm b/lib/Debbugs/DB/Result/Maintainer.pm new file mode 100644 index 0000000..d8c04ec --- /dev/null +++ b/lib/Debbugs/DB/Result/Maintainer.pm @@ -0,0 +1,181 @@ +use utf8; +package Debbugs::DB::Result::Maintainer; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::Maintainer - Package maintainer names + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("maintainer"); + +=head1 ACCESSORS + +=head2 id + + data_type: 'integer' + is_auto_increment: 1 + is_nullable: 0 + sequence: 'maintainer_id_seq' + +Package maintainer id + +=head2 name + + data_type: 'text' + is_nullable: 0 + +Name of package maintainer + +=head2 correspondent + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Correspondent ID + +=head2 created + + data_type: 'timestamp with time zone' + default_value: current_timestamp + is_nullable: 0 + original: {default_value => \"now()"} + +Time maintainer record created + +=head2 modified + + data_type: 'timestamp with time zone' + default_value: current_timestamp + is_nullable: 0 + original: {default_value => \"now()"} + +Time maintainer record modified + +=cut + +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "maintainer_id_seq", + }, + "name", + { data_type => "text", is_nullable => 0 }, + "correspondent", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "created", + { + data_type => "timestamp with time zone", + default_value => \"current_timestamp", + is_nullable => 0, + original => { default_value => \"now()" }, + }, + "modified", + { + data_type => "timestamp with time zone", + default_value => \"current_timestamp", + is_nullable => 0, + original => { default_value => \"now()" }, + }, +); + +=head1 PRIMARY KEY + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->set_primary_key("id"); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("maintainer_name_idx", ["name"]); + +=head1 RELATIONS + +=head2 correspondent + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "correspondent", + "Debbugs::DB::Result::Correspondent", + { id => "correspondent" }, + { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, +); + +=head2 src_vers + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "src_vers", + "Debbugs::DB::Result::SrcVer", + { "foreign.maintainer" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07042 @ 2014-11-30 21:56:51 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:rkpgeXltH2wiC1Us7FIijw + +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + $sqlt_table->add_index(name => 'maintainer_idx_correspondent', + fields => [qw(correspondent)], + ); +} + +1; diff --git a/lib/Debbugs/DB/Result/Message.pm b/lib/Debbugs/DB/Result/Message.pm new file mode 100644 index 0000000..cd42f48 --- /dev/null +++ b/lib/Debbugs/DB/Result/Message.pm @@ -0,0 +1,255 @@ +use utf8; +package Debbugs::DB::Result::Message; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::Message - Messages sent to bugs + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("message"); + +=head1 ACCESSORS + +=head2 id + + data_type: 'integer' + is_auto_increment: 1 + is_nullable: 0 + sequence: 'message_id_seq' + +Message id + +=head2 msgid + + data_type: 'text' + default_value: (empty string) + is_nullable: 0 + +Message id header + +=head2 from_complete + + data_type: 'text' + default_value: (empty string) + is_nullable: 0 + +Complete from header of message + +=head2 to_complete + + data_type: 'text' + default_value: (empty string) + is_nullable: 0 + +Complete to header of message + +=head2 subject + + data_type: 'text' + default_value: (empty string) + is_nullable: 0 + +Subject of the message + +=head2 sent_date + + data_type: 'timestamp with time zone' + is_nullable: 1 + +Time/date message was sent (from Date header) + +=head2 refs + + data_type: 'text' + default_value: (empty string) + is_nullable: 0 + +Contents of References: header + +=head2 spam_score + + data_type: 'double precision' + default_value: 0 + is_nullable: 0 + +Spam score from spamassassin + +=head2 is_spam + + data_type: 'boolean' + default_value: false + is_nullable: 0 + +True if this message was spam and should not be shown + +=cut + +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "message_id_seq", + }, + "msgid", + { data_type => "text", default_value => "", is_nullable => 0 }, + "from_complete", + { data_type => "text", default_value => "", is_nullable => 0 }, + "to_complete", + { data_type => "text", default_value => "", is_nullable => 0 }, + "subject", + { data_type => "text", default_value => "", is_nullable => 0 }, + "sent_date", + { data_type => "timestamp with time zone", is_nullable => 1 }, + "refs", + { data_type => "text", default_value => "", is_nullable => 0 }, + "spam_score", + { data_type => "double precision", default_value => 0, is_nullable => 0 }, + "is_spam", + { data_type => "boolean", default_value => \"false", is_nullable => 0 }, +); + +=head1 PRIMARY KEY + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->set_primary_key("id"); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint( + "message_msgid_from_complete_to_complete_subject_idx", + ["msgid", "from_complete", "to_complete", "subject"], +); + +=head1 RELATIONS + +=head2 bug_messages + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_messages", + "Debbugs::DB::Result::BugMessage", + { "foreign.message" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 message_correspondents + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "message_correspondents", + "Debbugs::DB::Result::MessageCorrespondent", + { "foreign.message" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 message_refs_messages + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "message_refs_messages", + "Debbugs::DB::Result::MessageRef", + { "foreign.message" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 message_refs_refs + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "message_refs_refs", + "Debbugs::DB::Result::MessageRef", + { "foreign.refs" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-07 19:03:32 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:n8U0vD9R8M5wFoeoLlIWeQ + +__PACKAGE__->many_to_many(bugs => 'bug_messages','bug'); +__PACKAGE__->many_to_many(correspondents => 'message_correspondents','correspondent'); +__PACKAGE__->many_to_many(references => 'message_refs_message','message'); +__PACKAGE__->many_to_many(referenced_by => 'message_refs_refs','message'); + + +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + for my $idx (qw(msgid subject)) { + $sqlt_table->add_index(name => 'message_'.$idx.'_idx', + fields => [$idx]); + } +} + +1; diff --git a/lib/Debbugs/DB/Result/MessageCorrespondent.pm b/lib/Debbugs/DB/Result/MessageCorrespondent.pm new file mode 100644 index 0000000..ddc79d1 --- /dev/null +++ b/lib/Debbugs/DB/Result/MessageCorrespondent.pm @@ -0,0 +1,150 @@ +use utf8; +package Debbugs::DB::Result::MessageCorrespondent; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::MessageCorrespondent - Linkage between correspondent and message + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("message_correspondent"); + +=head1 ACCESSORS + +=head2 message + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Message id (matches message) + +=head2 correspondent + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Correspondent (matches correspondent) + +=head2 correspondent_type + + data_type: 'enum' + default_value: 'to' + extra: {custom_type_name => "message_correspondent_type",list => ["to","from","envfrom","cc","recv"]} + is_nullable: 0 + +Type of correspondent (to, from, envfrom, cc, etc.) + +=cut + +__PACKAGE__->add_columns( + "message", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "correspondent", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "correspondent_type", + { + data_type => "enum", + default_value => "to", + extra => { + custom_type_name => "message_correspondent_type", + list => ["to", "from", "envfrom", "cc", "recv"], + }, + is_nullable => 0, + }, +); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint( + "message_correspondent_message_correspondent_correspondent_t_idx", + ["message", "correspondent", "correspondent_type"], +); + +=head1 RELATIONS + +=head2 correspondent + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "correspondent", + "Debbugs::DB::Result::Correspondent", + { id => "correspondent" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + +=head2 message + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "message", + "Debbugs::DB::Result::Message", + { id => "message" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-07 19:03:32 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:kIhya7skj4ZNM3DkC+gAPw + + +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + for my $idx (qw(correspondent message)) { + $sqlt_table->add_index(name => 'message_correspondent_idx'.$idx, + fields => [$idx]); + } +} + +1; diff --git a/lib/Debbugs/DB/Result/MessageRef.pm b/lib/Debbugs/DB/Result/MessageRef.pm new file mode 100644 index 0000000..98e2a2d --- /dev/null +++ b/lib/Debbugs/DB/Result/MessageRef.pm @@ -0,0 +1,145 @@ +use utf8; +package Debbugs::DB::Result::MessageRef; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::MessageRef - Message references + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("message_refs"); + +=head1 ACCESSORS + +=head2 message + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Message id (matches message) + +=head2 refs + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Reference id (matches message) + +=head2 inferred + + data_type: 'boolean' + default_value: false + is_nullable: 1 + +TRUE if this message reference was reconstructed; primarily of use for messages which lack In-Reply-To: or References: headers + +=head2 primary_ref + + data_type: 'boolean' + default_value: false + is_nullable: 1 + +TRUE if this message->ref came from In-Reply-To: or similar. + +=cut + +__PACKAGE__->add_columns( + "message", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "refs", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "inferred", + { data_type => "boolean", default_value => \"false", is_nullable => 1 }, + "primary_ref", + { data_type => "boolean", default_value => \"false", is_nullable => 1 }, +); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("message_refs_message_refs_idx", ["message", "refs"]); + +=head1 RELATIONS + +=head2 message + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "message", + "Debbugs::DB::Result::Message", + { id => "message" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + +=head2 ref + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "ref", + "Debbugs::DB::Result::Message", + { id => "refs" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07046 @ 2017-03-04 10:59:03 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:0YaAP/sB5N2Xr2rAFNK1lg + +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + for my $idx (qw(refs message)) { + $sqlt_table->add_index(name => 'message_refs_idx_'.$idx, + fields => [$idx]); + } +} + +1; diff --git a/lib/Debbugs/DB/Result/Severity.pm b/lib/Debbugs/DB/Result/Severity.pm new file mode 100644 index 0000000..edea9a9 --- /dev/null +++ b/lib/Debbugs/DB/Result/Severity.pm @@ -0,0 +1,154 @@ +use utf8; +package Debbugs::DB::Result::Severity; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::Severity - Bug severity + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("severity"); + +=head1 ACCESSORS + +=head2 id + + data_type: 'integer' + is_auto_increment: 1 + is_nullable: 0 + sequence: 'severity_id_seq' + +Severity id + +=head2 severity + + data_type: 'text' + is_nullable: 0 + +Severity name + +=head2 ordering + + data_type: 'integer' + default_value: 5 + is_nullable: 0 + +Severity ordering (more severe severities have higher numbers) + +=head2 strong + + data_type: 'boolean' + default_value: false + is_nullable: 1 + +True if severity is a strong severity + +=head2 obsolete + + data_type: 'boolean' + default_value: false + is_nullable: 1 + +Whether a severity level is obsolete (should not be set on new bugs) + +=cut + +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "severity_id_seq", + }, + "severity", + { data_type => "text", is_nullable => 0 }, + "ordering", + { data_type => "integer", default_value => 5, is_nullable => 0 }, + "strong", + { data_type => "boolean", default_value => \"false", is_nullable => 1 }, + "obsolete", + { data_type => "boolean", default_value => \"false", is_nullable => 1 }, +); + +=head1 PRIMARY KEY + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->set_primary_key("id"); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("severity_severity_idx", ["severity"]); + +=head1 RELATIONS + +=head2 bugs + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bugs", + "Debbugs::DB::Result::Bug", + { "foreign.severity" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07042 @ 2014-11-30 21:56:51 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:nI4ZqWa6IW7LgWuG7S1Gog + +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + $sqlt_table->add_index(name => 'severity_ordering_idx', + fields => [qw(ordering)], + ); +} + +1; diff --git a/lib/Debbugs/DB/Result/SrcAssociation.pm b/lib/Debbugs/DB/Result/SrcAssociation.pm new file mode 100644 index 0000000..01ac4bd --- /dev/null +++ b/lib/Debbugs/DB/Result/SrcAssociation.pm @@ -0,0 +1,179 @@ +use utf8; +package Debbugs::DB::Result::SrcAssociation; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::SrcAssociation - Source <-> suite associations + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("src_associations"); + +=head1 ACCESSORS + +=head2 id + + data_type: 'integer' + is_auto_increment: 1 + is_nullable: 0 + sequence: 'src_associations_id_seq' + +Source <-> suite association id + +=head2 suite + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Suite id (matches suite) + +=head2 source + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Source version id (matches src_ver) + +=head2 created + + data_type: 'timestamp with time zone' + default_value: current_timestamp + is_nullable: 0 + original: {default_value => \"now()"} + +Time this source package entered this suite + +=head2 modified + + data_type: 'timestamp with time zone' + default_value: current_timestamp + is_nullable: 0 + original: {default_value => \"now()"} + +Time this entry was modified + +=cut + +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "src_associations_id_seq", + }, + "suite", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "source", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "created", + { + data_type => "timestamp with time zone", + default_value => \"current_timestamp", + is_nullable => 0, + original => { default_value => \"now()" }, + }, + "modified", + { + data_type => "timestamp with time zone", + default_value => \"current_timestamp", + is_nullable => 0, + original => { default_value => \"now()" }, + }, +); + +=head1 PRIMARY KEY + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->set_primary_key("id"); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("src_associations_source_suite", ["source", "suite"]); + +=head1 RELATIONS + +=head2 source + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "source", + "Debbugs::DB::Result::SrcVer", + { id => "source" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + +=head2 suite + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "suite", + "Debbugs::DB::Result::Suite", + { id => "suite" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07045 @ 2016-11-24 08:52:49 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:B3gOeYD0JxOUtV92mBocZQ + + +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/lib/Debbugs/DB/Result/SrcPkg.pm b/lib/Debbugs/DB/Result/SrcPkg.pm new file mode 100644 index 0000000..26e56a4 --- /dev/null +++ b/lib/Debbugs/DB/Result/SrcPkg.pm @@ -0,0 +1,287 @@ +use utf8; +package Debbugs::DB::Result::SrcPkg; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::SrcPkg - Source packages + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("src_pkg"); + +=head1 ACCESSORS + +=head2 id + + data_type: 'integer' + is_auto_increment: 1 + is_nullable: 0 + sequence: 'src_pkg_id_seq' + +Source package id + +=head2 pkg + + data_type: 'text' + is_nullable: 0 + +Source package name + +=head2 pseduopkg + + data_type: 'boolean' + default_value: false + is_nullable: 0 + +=head2 alias_of + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 1 + +Source package id which this source package is an alias of + +=head2 creation + + data_type: 'timestamp with time zone' + default_value: current_timestamp + is_nullable: 0 + original: {default_value => \"now()"} + +=head2 disabled + + data_type: 'timestamp with time zone' + default_value: infinity + is_nullable: 0 + +=head2 last_modified + + data_type: 'timestamp with time zone' + default_value: current_timestamp + is_nullable: 0 + original: {default_value => \"now()"} + +=head2 obsolete + + data_type: 'boolean' + default_value: false + is_nullable: 0 + +=cut + +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "src_pkg_id_seq", + }, + "pkg", + { data_type => "text", is_nullable => 0 }, + "pseduopkg", + { data_type => "boolean", default_value => \"false", is_nullable => 0 }, + "alias_of", + { data_type => "integer", is_foreign_key => 1, is_nullable => 1 }, + "creation", + { + data_type => "timestamp with time zone", + default_value => \"current_timestamp", + is_nullable => 0, + original => { default_value => \"now()" }, + }, + "disabled", + { + data_type => "timestamp with time zone", + default_value => "infinity", + is_nullable => 0, + }, + "last_modified", + { + data_type => "timestamp with time zone", + default_value => \"current_timestamp", + is_nullable => 0, + original => { default_value => \"now()" }, + }, + "obsolete", + { data_type => "boolean", default_value => \"false", is_nullable => 0 }, +); + +=head1 PRIMARY KEY + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->set_primary_key("id"); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("src_pkg_pkg_disabled", ["pkg", "disabled"]); + +=head1 RELATIONS + +=head2 alias_of + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "alias_of", + "Debbugs::DB::Result::SrcPkg", + { id => "alias_of" }, + { + is_deferrable => 0, + join_type => "LEFT", + on_delete => "CASCADE", + on_update => "CASCADE", + }, +); + +=head2 bin_pkg_src_pkgs + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bin_pkg_src_pkgs", + "Debbugs::DB::Result::BinPkgSrcPkg", + { "foreign.src_pkg" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bug_affects_srcpackages + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_affects_srcpackages", + "Debbugs::DB::Result::BugAffectsSrcpackage", + { "foreign.src_pkg" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bug_srcpackages + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_srcpackages", + "Debbugs::DB::Result::BugSrcpackage", + { "foreign.src_pkg" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bug_vers + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_vers", + "Debbugs::DB::Result::BugVer", + { "foreign.src_pkg" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 src_pkgs + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "src_pkgs", + "Debbugs::DB::Result::SrcPkg", + { "foreign.alias_of" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 src_vers + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "src_vers", + "Debbugs::DB::Result::SrcVer", + { "foreign.src_pkg" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07049 @ 2019-07-05 20:56:47 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:G2uhLQ7coWRoAHFiDkF5cQ + + +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + $sqlt_table->add_index(name => 'src_pkg_pkg', + fields => 'pkg', + ); +} +1; diff --git a/lib/Debbugs/DB/Result/SrcVer.pm b/lib/Debbugs/DB/Result/SrcVer.pm new file mode 100644 index 0000000..4181c1e --- /dev/null +++ b/lib/Debbugs/DB/Result/SrcVer.pm @@ -0,0 +1,285 @@ +use utf8; +package Debbugs::DB::Result::SrcVer; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::SrcVer - Source Package versions + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("src_ver"); + +=head1 ACCESSORS + +=head2 id + + data_type: 'integer' + is_auto_increment: 1 + is_nullable: 0 + sequence: 'src_ver_id_seq' + +Source package version id + +=head2 src_pkg + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +Source package id (matches src_pkg table) + +=head2 ver + + data_type: 'debversion' + is_nullable: 0 + +Version of the source package + +=head2 maintainer + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 1 + +Maintainer id (matches maintainer table) + +=head2 upload_date + + data_type: 'timestamp with time zone' + default_value: current_timestamp + is_nullable: 0 + original: {default_value => \"now()"} + +Date this version of the source package was uploaded + +=head2 based_on + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 1 + +Source package version this version is based on + +=cut + +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "src_ver_id_seq", + }, + "src_pkg", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, + "ver", + { data_type => "debversion", is_nullable => 0 }, + "maintainer", + { data_type => "integer", is_foreign_key => 1, is_nullable => 1 }, + "upload_date", + { + data_type => "timestamp with time zone", + default_value => \"current_timestamp", + is_nullable => 0, + original => { default_value => \"now()" }, + }, + "based_on", + { data_type => "integer", is_foreign_key => 1, is_nullable => 1 }, +); + +=head1 PRIMARY KEY + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->set_primary_key("id"); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("src_ver_src_pkg_id_ver", ["src_pkg", "ver"]); + +=head1 RELATIONS + +=head2 based_on + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "based_on", + "Debbugs::DB::Result::SrcVer", + { id => "based_on" }, + { + is_deferrable => 0, + join_type => "LEFT", + on_delete => "CASCADE", + on_update => "CASCADE", + }, +); + +=head2 bin_vers + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bin_vers", + "Debbugs::DB::Result::BinVer", + { "foreign.src_ver" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bug_vers + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_vers", + "Debbugs::DB::Result::BugVer", + { "foreign.src_ver" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 maintainer + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "maintainer", + "Debbugs::DB::Result::Maintainer", + { id => "maintainer" }, + { + is_deferrable => 0, + join_type => "LEFT", + on_delete => "SET NULL", + on_update => "CASCADE", + }, +); + +=head2 src_associations + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "src_associations", + "Debbugs::DB::Result::SrcAssociation", + { "foreign.source" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 src_pkg + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "src_pkg", + "Debbugs::DB::Result::SrcPkg", + { id => "src_pkg" }, + { is_deferrable => 0, on_delete => "CASCADE", on_update => "CASCADE" }, +); + +=head2 src_vers + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "src_vers", + "Debbugs::DB::Result::SrcVer", + { "foreign.based_on" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07042 @ 2014-11-30 21:56:51 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:gY5LidUaQeuJ5AnN06CfKQ + + +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + $sqlt_table->schema-> + add_procedure(name => 'src_ver_to_src_pkg', + sql => <<'EOF', +CREATE OR REPLACE FUNCTION src_ver_to_src_pkg(src_ver INT) RETURNS INT + AS $src_ver_to_src_pkg$ + DECLARE + src_pkg int; + BEGIN + SELECT sv.src_pkg INTO STRICT src_pkg + FROM src_ver sv WHERE sv.id=src_ver; + RETURN src_pkg; + END + $src_ver_to_src_pkg$ LANGUAGE plpgsql; +EOF + ); +} +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/lib/Debbugs/DB/Result/Suite.pm b/lib/Debbugs/DB/Result/Suite.pm new file mode 100644 index 0000000..37c875c --- /dev/null +++ b/lib/Debbugs/DB/Result/Suite.pm @@ -0,0 +1,201 @@ +use utf8; +package Debbugs::DB::Result::Suite; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::Suite - Debian Release Suite (stable, testing, etc.) + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("suite"); + +=head1 ACCESSORS + +=head2 id + + data_type: 'integer' + is_auto_increment: 1 + is_nullable: 0 + sequence: 'suite_id_seq' + +Suite id + +=head2 codename + + data_type: 'text' + is_nullable: 0 + +Suite codename (sid, squeeze, etc.) + +=head2 suite_name + + data_type: 'text' + is_nullable: 1 + +Suite name (testing, stable, etc.) + +=head2 version + + data_type: 'text' + is_nullable: 1 + +Suite version; NULL if there is no appropriate version + +=head2 active + + data_type: 'boolean' + default_value: true + is_nullable: 1 + +TRUE if the suite is still accepting uploads + +=cut + +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "suite_id_seq", + }, + "codename", + { data_type => "text", is_nullable => 0 }, + "suite_name", + { data_type => "text", is_nullable => 1 }, + "version", + { data_type => "text", is_nullable => 1 }, + "active", + { data_type => "boolean", default_value => \"true", is_nullable => 1 }, +); + +=head1 PRIMARY KEY + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->set_primary_key("id"); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("suite_idx_codename", ["codename"]); + +=head2 C + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("suite_idx_version", ["version"]); + +=head2 C + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("suite_suite_name_key", ["suite_name"]); + +=head1 RELATIONS + +=head2 bin_associations + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bin_associations", + "Debbugs::DB::Result::BinAssociation", + { "foreign.suite" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 bug_status_caches + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_status_caches", + "Debbugs::DB::Result::BugStatusCache", + { "foreign.suite" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 src_associations + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "src_associations", + "Debbugs::DB::Result::SrcAssociation", + { "foreign.suite" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07045 @ 2016-11-24 08:52:49 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:nXoQCYZhM9cFgC1x+RY9rA + + +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/lib/Debbugs/DB/Result/Tag.pm b/lib/Debbugs/DB/Result/Tag.pm new file mode 100644 index 0000000..c8d5397 --- /dev/null +++ b/lib/Debbugs/DB/Result/Tag.pm @@ -0,0 +1,129 @@ +use utf8; +package Debbugs::DB::Result::Tag; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::Tag - Bug tags + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("tag"); + +=head1 ACCESSORS + +=head2 id + + data_type: 'integer' + is_auto_increment: 1 + is_nullable: 0 + sequence: 'tag_id_seq' + +Tag id + +=head2 tag + + data_type: 'text' + is_nullable: 0 + +Tag name + +=head2 obsolete + + data_type: 'boolean' + default_value: false + is_nullable: 1 + +Whether a tag is obsolete (should not be set on new bugs) + +=cut + +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "tag_id_seq", + }, + "tag", + { data_type => "text", is_nullable => 0 }, + "obsolete", + { data_type => "boolean", default_value => \"false", is_nullable => 1 }, +); + +=head1 PRIMARY KEY + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->set_primary_key("id"); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("tag_tag_key", ["tag"]); + +=head1 RELATIONS + +=head2 bug_tags + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_tags", + "Debbugs::DB::Result::BugTag", + { "foreign.tag" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07042 @ 2014-11-30 21:56:51 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:HH2aKSj4xl+co6qffSdrrQ + + +# You can replace this text with custom code or comments, and it will be preserved on regeneration +1; diff --git a/lib/Debbugs/DB/Result/UserTag.pm b/lib/Debbugs/DB/Result/UserTag.pm new file mode 100644 index 0000000..0883a2e --- /dev/null +++ b/lib/Debbugs/DB/Result/UserTag.pm @@ -0,0 +1,151 @@ +use utf8; +package Debbugs::DB::Result::UserTag; + +# Created by DBIx::Class::Schema::Loader +# DO NOT MODIFY THE FIRST PART OF THIS FILE + +=head1 NAME + +Debbugs::DB::Result::UserTag - User bug tags + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::Core'; + +=head1 COMPONENTS LOADED + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->load_components("InflateColumn::DateTime", "TimeStamp"); + +=head1 TABLE: C + +=cut + +__PACKAGE__->table("user_tag"); + +=head1 ACCESSORS + +=head2 id + + data_type: 'integer' + is_auto_increment: 1 + is_nullable: 0 + sequence: 'user_tag_id_seq' + +User bug tag id + +=head2 tag + + data_type: 'text' + is_nullable: 0 + +User bug tag name + +=head2 correspondent + + data_type: 'integer' + is_foreign_key: 1 + is_nullable: 0 + +User bug tag correspondent + +=cut + +__PACKAGE__->add_columns( + "id", + { + data_type => "integer", + is_auto_increment => 1, + is_nullable => 0, + sequence => "user_tag_id_seq", + }, + "tag", + { data_type => "text", is_nullable => 0 }, + "correspondent", + { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, +); + +=head1 PRIMARY KEY + +=over 4 + +=item * L + +=back + +=cut + +__PACKAGE__->set_primary_key("id"); + +=head1 UNIQUE CONSTRAINTS + +=head2 C + +=over 4 + +=item * L + +=item * L + +=back + +=cut + +__PACKAGE__->add_unique_constraint("user_tag_tag_correspondent", ["tag", "correspondent"]); + +=head1 RELATIONS + +=head2 bug_user_tags + +Type: has_many + +Related object: L + +=cut + +__PACKAGE__->has_many( + "bug_user_tags", + "Debbugs::DB::Result::BugUserTag", + { "foreign.user_tag" => "self.id" }, + { cascade_copy => 0, cascade_delete => 0 }, +); + +=head2 correspondent + +Type: belongs_to + +Related object: L + +=cut + +__PACKAGE__->belongs_to( + "correspondent", + "Debbugs::DB::Result::Correspondent", + { id => "correspondent" }, + { is_deferrable => 0, on_delete => "NO ACTION", on_update => "NO ACTION" }, +); + + +# Created by DBIx::Class::Schema::Loader v0.07045 @ 2016-09-24 14:51:07 +# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:ZPmTBeTue62dG2NdQdPrQg + +sub sqlt_deploy_hook { + my ($self, $sqlt_table) = @_; + $sqlt_table->add_index(name => 'user_tag_correspondent', + fields => [qw(correspondent)], + ); +} + +1; diff --git a/lib/Debbugs/DB/ResultSet/Arch.pm b/lib/Debbugs/DB/ResultSet/Arch.pm new file mode 100644 index 0000000..572ed0a --- /dev/null +++ b/lib/Debbugs/DB/ResultSet/Arch.pm @@ -0,0 +1,55 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version. See the +# file README and COPYING for more information. +# Copyright 2016 by Don Armstrong . +use utf8; +package Debbugs::DB::ResultSet::Arch; + +=head1 NAME + +Debbugs::DB::ResultSet::Arch - Architecture result set operations + +=head1 SYNOPSIS + + + +=head1 DESCRIPTION + + + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::ResultSet'; + +# required for hash slices +use v5.20; + +sub get_archs { + my ($self,@archs) = @_; + my %archs; + for my $a ($self->result_source->schema->resultset('Arch')-> + search(undef, + {result_class => 'DBIx::Class::ResultClass::HashRefInflator', + columns => [qw[id arch]], + })->all()) { + $archs{$a->{arch}} = $a->{id}; + } + for my $a (grep {not exists $archs{$_}} @archs) { + $archs{$a} = + $self->result_source->schema->resultset('Arch')-> + find_or_create({arch => $a}, + {columns => [qw[id arch]], + } + )->id; + } + + return {%archs{@archs}}; +} + + +1; + +__END__ diff --git a/lib/Debbugs/DB/ResultSet/BinAssociation.pm b/lib/Debbugs/DB/ResultSet/BinAssociation.pm new file mode 100644 index 0000000..5756199 --- /dev/null +++ b/lib/Debbugs/DB/ResultSet/BinAssociation.pm @@ -0,0 +1,48 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version. See the +# file README and COPYING for more information. +# Copyright 2017 by Don Armstrong . +use utf8; +package Debbugs::DB::ResultSet::BinAssociation; + +=head1 NAME + +Debbugs::DB::ResultSet::BinAssociation - Binary/Suite Associations + +=head1 SYNOPSIS + + + +=head1 DESCRIPTION + + + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::ResultSet'; + +use Debbugs::DB::Util qw(select_one); + + +sub insert_suite_bin_ver_association { + my ($self,$suite_id,$bin_ver_id) = @_; + return $self->result_source->schema->storage-> + dbh_do(sub { + my ($s,$dbh,$s_id,$bv_id) = @_; + return select_one($dbh,<<'SQL',$s_id,$bv_id); +INSERT INTO bin_associations (suite,bin) + VALUES (?,?) ON CONFLICT (suite,bin) DO + UPDATE SET modified = NOW() + RETURNING id; +SQL + }, + $suite_id,$bin_ver_id + ); +} + +1; + +__END__ diff --git a/lib/Debbugs/DB/ResultSet/BinPkg.pm b/lib/Debbugs/DB/ResultSet/BinPkg.pm new file mode 100644 index 0000000..e938cda --- /dev/null +++ b/lib/Debbugs/DB/ResultSet/BinPkg.pm @@ -0,0 +1,78 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version. See the +# file README and COPYING for more information. +# Copyright 2017 by Don Armstrong . +use utf8; +package Debbugs::DB::ResultSet::BinPkg; + +=head1 NAME + +Debbugs::DB::ResultSet::BinPkg - Source Package + +=head1 SYNOPSIS + + + +=head1 DESCRIPTION + + + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::ResultSet'; + +use Debbugs::DB::Util qw(select_one); + +sub bin_pkg_and_ver_in_suite { + my ($self,$suite) = @_; + $suite = $self->result_source->schema-> + resultset('Suite')->get_suite_id($suite); + return + $self->search_rs({'bin_associations.suite' => $suite, + }, + {join => {bin_vers => ['bin_associations','arch']}, + result_class => 'DBIx::Class::ResultClass::HashRefInflator', + columns => [qw(me.pkg bin_vers.ver arch.arch bin_associations.id)] + }, + )->all; +} + + +sub get_bin_pkg_id { + my ($self,$pkg) = @_; + return $self->result_source->schema->storage-> + dbh_do(sub { + my ($s,$dbh,$bin_pkg) = @_; + return select_one($dbh,<<'SQL',$bin_pkg); +SELECT id FROM bin_pkg where pkg = ?; +SQL + }, + $pkg + ); +} +sub get_or_create_bin_pkg_id { + my ($self,$pkg) = @_; + return $self->result_source->schema->storage-> + dbh_do(sub { + my ($s,$dbh,$bin_pkg) = @_; + return select_one($dbh,<<'SQL',$bin_pkg,$bin_pkg); +WITH ins AS ( +INSERT INTO bin_pkg (pkg) +VALUES (?) ON CONFLICT (pkg) DO NOTHING RETURNING id +) +SELECT id FROM ins +UNION ALL +SELECT id FROM bin_pkg where pkg = ? +LIMIT 1; +SQL + }, + $pkg + ); +} + +1; + +__END__ diff --git a/lib/Debbugs/DB/ResultSet/BinVer.pm b/lib/Debbugs/DB/ResultSet/BinVer.pm new file mode 100644 index 0000000..fcd8b59 --- /dev/null +++ b/lib/Debbugs/DB/ResultSet/BinVer.pm @@ -0,0 +1,56 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version. See the +# file README and COPYING for more information. +# Copyright 2017 by Don Armstrong . +use utf8; +package Debbugs::DB::ResultSet::BinVer; + +=head1 NAME + +Debbugs::DB::ResultSet::BinVer - Source Version association + +=head1 SYNOPSIS + + + +=head1 DESCRIPTION + + + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::ResultSet'; + +use Debbugs::DB::Util qw(select_one); + + +sub get_bin_ver_id { + my ($self,$bin_pkg_id,$bin_ver,$arch_id,$src_ver_id) = @_; + return $self->result_source->schema->storage-> + dbh_do(sub { + my ($s,$dbh,$bp_id,$bv,$a_id,$sv_id) = @_; + return select_one($dbh,<<'SQL', +WITH ins AS ( +INSERT INTO bin_ver (bin_pkg,src_ver,arch,ver) +VALUES (?,?,?,?) ON CONFLICT (bin_pkg,arch,ver) DO NOTHING RETURNING id +) +SELECT id FROM ins +UNION ALL +SELECT id FROM bin_ver WHERE bin_pkg = ? AND arch = ? AND ver = ? +LIMIT 1; +SQL + $bp_id,$sv_id, + $a_id,$bv, + $bp_id,$a_id, + $bv); + }, + $bin_pkg_id,$bin_ver,$arch_id,$src_ver_id + ); +} + +1; + +__END__ diff --git a/lib/Debbugs/DB/ResultSet/Bug.pm b/lib/Debbugs/DB/ResultSet/Bug.pm new file mode 100644 index 0000000..265d4d9 --- /dev/null +++ b/lib/Debbugs/DB/ResultSet/Bug.pm @@ -0,0 +1,92 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version. See the +# file README and COPYING for more information. +# Copyright 2017 by Don Armstrong . +use utf8; +package Debbugs::DB::ResultSet::Bug; + +=head1 NAME + +Debbugs::DB::ResultSet::Bug - Bug result set operations + +=head1 SYNOPSIS + + + +=head1 DESCRIPTION + + + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::ResultSet'; + +use Debbugs::DB::Util qw(select_one); + +use List::AllUtils qw(natatime); + + +=over + +=item quick_insert_bugs + + $s->result_set('Bug')->quick_insert_bugs(@bugs); + +Quickly insert a set of bugs (without any useful information, like subject, +etc). This should probably only be called when inserting bugs in the database +for first time. + +=cut + + +sub quick_insert_bugs { + my ($self,@bugs) = @_; + + my $it = natatime 2000, @bugs; + + while (my @b = $it->()) { + $self->result_source->schema-> + txn_do(sub{ + for my $b (@b) { + $self->quick_insert_bug($b); + } + }); + } +} + +=item quick_insert_bug + + $s->result_set('Bug')->quick_insert_bug($bug); + +Quickly insert a single bug (called by quick_insert_bugs). You should probably +actually be calling C instead of this function. + +=cut + +sub quick_insert_bug { + my ($self,$bug) = @_; + return $self->result_source->schema->storage-> + dbh_do(sub { + my ($s,$dbh,$b) = @_; + select_one($dbh,<<'SQL',$b); +INSERT INTO bug (id,subject,severity) VALUES (?,'',1) +ON CONFLICT (id) DO NOTHING RETURNING id; +SQL + }, + $bug + ); + +} + + +=back + +=cut + + +1; + +__END__ diff --git a/lib/Debbugs/DB/ResultSet/BugStatusCache.pm b/lib/Debbugs/DB/ResultSet/BugStatusCache.pm new file mode 100644 index 0000000..7ad8f0e --- /dev/null +++ b/lib/Debbugs/DB/ResultSet/BugStatusCache.pm @@ -0,0 +1,74 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version. See the +# file README and COPYING for more information. +# Copyright 2017 by Don Armstrong . +use utf8; +package Debbugs::DB::ResultSet::BugStatusCache; + +=head1 NAME + +Debbugs::DB::ResultSet::BugStatusCache - Bug result set operations + +=head1 SYNOPSIS + + + +=head1 DESCRIPTION + + + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::ResultSet'; + +use Debbugs::DB::Util qw(select_one); + +use List::AllUtils qw(natatime); + + +=over + +=item update_bug_status + + $s->resultset('BugStatusCache')-> + update_bug_status($bug->id, + $suite->{id}, + undef, + $presence, + ); + +Update the status information for a particular bug at a particular suite + +=cut + +sub update_bug_status { + my ($self,@args) = @_; + return $self->result_source->schema->storage-> + dbh_do(sub { + my ($s,$dbh,$bug,$suite,$arch,$status,$modified,$asof) = @_; + select_one($dbh,<<'SQL',$bug,$suite,$arch,$status,$status); +INSERT INTO bug_status_cache AS bsc +(bug,suite,arch,status,modified,asof) +VALUES (?,?,?,?,NOW(),NOW()) +ON CONFLICT (bug,COALESCE(suite,0),COALESCE(arch,0)) DO +UPDATE + SET asof=NOW(),modified=CASE WHEN bsc.status=? THEN bsc.modified ELSE NOW() END +RETURNING status; +SQL + }, + @args + ); +} + + +=back + +=cut + + +1; + +__END__ diff --git a/lib/Debbugs/DB/ResultSet/Correspondent.pm b/lib/Debbugs/DB/ResultSet/Correspondent.pm new file mode 100644 index 0000000..d722a5f --- /dev/null +++ b/lib/Debbugs/DB/ResultSet/Correspondent.pm @@ -0,0 +1,92 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version. See the +# file README and COPYING for more information. +# Copyright 2017 by Don Armstrong . +use utf8; +package Debbugs::DB::ResultSet::Correspondent; + +=head1 NAME + +Debbugs::DB::ResultSet::Correspondent - Correspondent table actions + +=head1 SYNOPSIS + + + +=head1 DESCRIPTION + + + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::ResultSet'; + +use Debbugs::DB::Util qw(select_one); + +use Debbugs::Common qw(getparsedaddrs); +use Debbugs::DB::Util qw(select_one); +use Scalar::Util qw(blessed); + +sub get_correspondent_id { + my ($self,$addr) = @_; + my $full_name; + if (blessed($addr)) { + $full_name = $addr->phrase(); + $addr = $addr->address(); + } elsif ($addr =~ /phrase(); + $addr = $addr->address(); + } + if (defined $full_name) { + $full_name =~ s/^\"|\"$//g; + $full_name =~ s/^\s+|\s+$//g; + } + my $rs = + $self-> + search({addr => $addr}, + {result_class => 'DBIx::Class::ResultClass::HashRefInflator', + } + )->first(); + if (defined $rs) { + return $rs->{id}; + } + return $self->result_source->schema->storage-> + dbh_do(sub { + my ($s,$dbh,$addr,$full_name) = @_; + my $ci = select_one($dbh,<<'SQL',$addr,$addr); +WITH ins AS ( +INSERT INTO correspondent (addr) VALUES (?) + ON CONFLICT (addr) DO NOTHING RETURNING id +) +SELECT id FROM ins +UNION ALL +SELECT id FROM correspondent WHERE addr = ? +LIMIT 1; +SQL + if (defined $full_name) { + select_one($dbh,<<'SQL',$ci,$full_name); +WITH ins AS ( +INSERT INTO correspondent_full_name (correspondent,full_name) + VALUES (?,?) ON CONFLICT (correspondent,full_name) DO NOTHING RETURNING 1 +) SELECT 1 FROM ins +UNION ALL +SELECT 1; +SQL + } + return $ci; +}, + $addr, + $full_name + ); + +} + + + +1; + +__END__ diff --git a/lib/Debbugs/DB/ResultSet/Maintainer.pm b/lib/Debbugs/DB/ResultSet/Maintainer.pm new file mode 100644 index 0000000..7c889f3 --- /dev/null +++ b/lib/Debbugs/DB/ResultSet/Maintainer.pm @@ -0,0 +1,117 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version. See the +# file README and COPYING for more information. +# Copyright 2016 by Don Armstrong . +use utf8; +package Debbugs::DB::ResultSet::Maintainer; + +=head1 NAME + +Debbugs::DB::ResultSet::Maintainer - Package maintainer result set operations + +=head1 SYNOPSIS + + + +=head1 DESCRIPTION + + + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::ResultSet'; + +use Debbugs::DB::Util qw(select_one); + + +=over + +=item get_maintainers + + $s->resultset('Maintainers')->get_maintainers(); + + $s->resultset('Maintainers')->get_maintainers(@maints); + +Retrieve a HASHREF of all maintainers with the maintainer name as the key and +the id of the database as the value. If given an optional list of maintainers, +adds those maintainers to the database if they do not already exist in the +database. + +=cut +sub get_maintainers { + my ($self,@maints) = @_; + my %maints; + for my $m ($self->result_source->schema->resultset('Maintainer')-> + search(undef, + {result_class => 'DBIx::Class::ResultClass::HashRefInflator', + columns => [qw[id name] ] + })->all()) { + $maints{$m->{name}} = $m->{id}; + } + my @maint_names = grep {not exists $maints{$_}} @maints; + my @maint_ids = $self->result_source->schema-> + txn_do(sub { + my @ids; + for my $name (@_) { + push @ids, + $self->result_source->schema-> + resultset('Maintainer')->get_maintainer_id($name); + } + return @ids; + },@maint_names); + @maints{@maint_names} = @maint_ids; + return \%maints; +} + +=item get_maintainer_id + + $s->resultset('Maintainer')->get_maintainer_id('Foo Bar ') + +Given a maintainer name returns the maintainer id, possibly inserting the +maintainer (and correspondent) if either do not exist in the database. + + +=cut + +sub get_maintainer_id { + my ($self,$maint) = @_; + my $rs = + $self-> + search({name => $maint}, + {result_class => 'DBIx::Class::ResultClass::HashRefInflator', + } + )->first(); + if (defined $rs) { + return $rs->{id}; + } + my $ci = + $self->result_source->schema->resultset('Correspondent')-> + get_correspondent_id($maint); + return $self->result_source->schema->storage-> + dbh_do(sub { + my ($s,$dbh,$maint,$ci) = @_; + return select_one($dbh,<<'SQL',$maint,$ci,$maint); +WITH ins AS ( +INSERT INTO maintainer (name,correspondent) VALUES (?,?) +ON CONFLICT (name) DO NOTHING RETURNING id +) +SELECT id FROM ins +UNION ALL +SELECT id FROM maintainer WHERE name = ? +LIMIT 1; +SQL + }, + $maint,$ci + ); +} + +=back + +=cut + +1; + +__END__ diff --git a/lib/Debbugs/DB/ResultSet/Message.pm b/lib/Debbugs/DB/ResultSet/Message.pm new file mode 100644 index 0000000..08509ce --- /dev/null +++ b/lib/Debbugs/DB/ResultSet/Message.pm @@ -0,0 +1,56 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version. See the +# file README and COPYING for more information. +# Copyright 2017 by Don Armstrong . +use utf8; +package Debbugs::DB::ResultSet::Message; + +=head1 NAME + +Debbugs::DB::ResultSet::Message - Message table actions + +=head1 SYNOPSIS + + + +=head1 DESCRIPTION + + + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::ResultSet'; + +use Debbugs::DB::Util qw(select_one); + +sub get_message_id { + my ($self,$msg_id,$from,$to,$subject) = @_; + return $self->result_source->schema->storage-> + dbh_do(sub { + my ($dbh,$msg_id,$from,$to,$subject) = @_; + my $mi = select_one($dbh,<<'SQL',@_[1..$#_],@_[1..$#_]); +WITH ins AS ( +INSERT INTO message (msgid,from_complete,to_complete,subject) VALUES (?,?,?,?) + ON CONFLICT (msgid,from_complete,to_complete,subject) DO NOTHING RETURNING id +) +SELECT id FROM ins +UNION ALL +SELECT id FROM correspondent WHERE msgid=? AND from_complete = ? +AND to_complete = ? AND subject = ? +LIMIT 1; +SQL + return $mi; +}, + @_[1..$#_] + ); + +} + + + +1; + +__END__ diff --git a/lib/Debbugs/DB/ResultSet/SrcAssociation.pm b/lib/Debbugs/DB/ResultSet/SrcAssociation.pm new file mode 100644 index 0000000..047c54d --- /dev/null +++ b/lib/Debbugs/DB/ResultSet/SrcAssociation.pm @@ -0,0 +1,48 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version. See the +# file README and COPYING for more information. +# Copyright 2017 by Don Armstrong . +use utf8; +package Debbugs::DB::ResultSet::SrcAssociation; + +=head1 NAME + +Debbugs::DB::ResultSet::SrcAssociation - Source/Suite Associations + +=head1 SYNOPSIS + + + +=head1 DESCRIPTION + + + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::ResultSet'; + +use Debbugs::DB::Util qw(select_one); + + +sub insert_suite_src_ver_association { + my ($self,$suite_id,$src_ver_id) = @_; + return $self->result_source->schema->storage-> + dbh_do(sub { + my ($s,$dbh,$suite_id,$src_ver_id) = @_; + return select_one($dbh,<<'SQL',$suite_id,$src_ver_id); +INSERT INTO src_associations (suite,source) + VALUES (?,?) ON CONFLICT (suite,source) DO + UPDATE SET modified = NOW() +RETURNING id; +SQL + }, + $suite_id,$src_ver_id + ); +} + +1; + +__END__ diff --git a/lib/Debbugs/DB/ResultSet/SrcPkg.pm b/lib/Debbugs/DB/ResultSet/SrcPkg.pm new file mode 100644 index 0000000..36fab13 --- /dev/null +++ b/lib/Debbugs/DB/ResultSet/SrcPkg.pm @@ -0,0 +1,95 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version. See the +# file README and COPYING for more information. +# Copyright 2017 by Don Armstrong . +use utf8; +package Debbugs::DB::ResultSet::SrcPkg; + +=head1 NAME + +Debbugs::DB::ResultSet::SrcPkg - Source Package + +=head1 SYNOPSIS + + + +=head1 DESCRIPTION + + + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::ResultSet'; + +use Debbugs::DB::Util qw(select_one); + +sub src_pkg_and_ver_in_suite { + my ($self,$suite) = @_; + if (ref($suite)) { + if (ref($suite) eq 'HASH') { + $suite = $suite->{id} + } else { + $suite = $suite->id(); + } + } else { + if ($suite !~ /^\d+$/) { + $suite = $self->result_source->schema-> + resultset('Suite')-> + search_rs({codename => $suite}, + {result_class => 'DBIx::Class::ResultClass::HashRefInflator', + })->first(); + if (defined $suite) { + $suite = $suite->{id}; + } + } + } + return + $self->search_rs({'src_associations.suite' => $suite, + }, + {join => {src_vers => 'src_associations'}, + result_class => 'DBIx::Class::ResultClass::HashRefInflator', + columns => [qw(me.pkg src_vers.ver src_associations.id)] + }, + )->all; +} + + +sub get_src_pkg_id { + my ($self,$source) = @_; + return $self->result_source->schema->storage-> + dbh_do(sub { + my ($s,$dbh,$src_pkg) = @_; + return select_one($dbh,<<'SQL',$src_pkg); +SELECT id FROM src_pkg where pkg = ?; +SQL + }, + $source + ); +} + +sub get_or_create_src_pkg_id { + my ($self,$source) = @_; + return $self->result_source->schema->storage-> + dbh_do(sub { + my ($s,$dbh,$source) = @_; + return select_one($dbh,<<'SQL',$source,$source); +WITH ins AS ( +INSERT INTO src_pkg (pkg) + VALUES (?) ON CONFLICT (pkg,disabled) DO NOTHING RETURNING id +) +SELECT id FROM ins +UNION ALL +SELECT id FROM src_pkg where pkg = ? AND disabled = 'infinity'::timestamptz +LIMIT 1; +SQL + }, + $source + ); +} + +1; + +__END__ diff --git a/lib/Debbugs/DB/ResultSet/SrcVer.pm b/lib/Debbugs/DB/ResultSet/SrcVer.pm new file mode 100644 index 0000000..254816c --- /dev/null +++ b/lib/Debbugs/DB/ResultSet/SrcVer.pm @@ -0,0 +1,50 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version. See the +# file README and COPYING for more information. +# Copyright 2017 by Don Armstrong . +use utf8; +package Debbugs::DB::ResultSet::SrcVer; + +=head1 NAME + +Debbugs::DB::ResultSet::SrcVer - Source Version association + +=head1 SYNOPSIS + + + +=head1 DESCRIPTION + + + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::ResultSet'; + +use Debbugs::DB::Util qw(select_one); + + +sub get_src_ver_id { + my ($self,$src_pkg_id,$src_ver,$maint_id) = @_; + return $self->result_source->schema->storage-> + dbh_do(sub { + my ($s,$dbh,$src_pkg_id,$src_ver,$maint_id) = @_; + return select_one($dbh,<<'SQL', +INSERT INTO src_ver (src_pkg,ver,maintainer) + VALUES (?,?,?) ON CONFLICT (src_pkg,ver) DO + UPDATE SET maintainer = ? + RETURNING id; +SQL + $src_pkg_id,$src_ver, + $maint_id,$maint_id); + }, + $src_pkg_id,$src_ver,$maint_id + ); +} + +1; + +__END__ diff --git a/lib/Debbugs/DB/ResultSet/Suite.pm b/lib/Debbugs/DB/ResultSet/Suite.pm new file mode 100644 index 0000000..c920080 --- /dev/null +++ b/lib/Debbugs/DB/ResultSet/Suite.pm @@ -0,0 +1,53 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version. See the +# file README and COPYING for more information. +# Copyright 2017 by Don Armstrong . +use utf8; +package Debbugs::DB::ResultSet::Suite; + +=head1 NAME + +Debbugs::DB::ResultSet::Suite - Suite table actions + +=head1 SYNOPSIS + + + +=head1 DESCRIPTION + + + +=cut + +use strict; +use warnings; + +use base 'DBIx::Class::ResultSet'; + +sub get_suite_id { + my ($self,$suite) = @_; + if (ref($suite)) { + if (ref($suite) eq 'HASH') { + $suite = $suite->{id} + } else { + $suite = $suite->id(); + } + } + else { + if ($suite !~ /^\d+$/) { + $suite = $self->result_source->schema-> + resultset('Suite')-> + search_rs({codename => $suite}, + {result_class => 'DBIx::Class::ResultClass::HashRefInflator', + })->first(); + if (defined $suite) { + $suite = $suite->{id}; + } + } + } + return $suite; +} + +1; + +__END__ diff --git a/lib/Debbugs/DB/Util.pm b/lib/Debbugs/DB/Util.pm new file mode 100644 index 0000000..d241f33 --- /dev/null +++ b/lib/Debbugs/DB/Util.pm @@ -0,0 +1,96 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version. See the +# file README and COPYING for more information. +# Copyright 2017 by Don Armstrong . + +package Debbugs::DB::Util; + +=head1 NAME + +Debbugs::DB::Util -- Utility routines for the database + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + + +=head1 BUGS + +None known. + +=cut + +use warnings; +use strict; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use base qw(Exporter); + +BEGIN{ + ($VERSION) = q$Revision$ =~ /^Revision:\s+([^\s+])/; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (select => [qw(select_one)], + execute => [qw(prepare_execute)] + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + +=head2 select + +Routines for select requests + +=over + +=item select_one + + select_one($dbh,$sql,@bind_vals) + +Returns the first column from the first row returned from a select statement + +=cut + +sub select_one { + my ($dbh,$sql,@bind_vals) = @_; + my $sth = $dbh-> + prepare_cached($sql, + {dbi_dummy => __FILE__.__LINE__ }) + or die "Unable to prepare statement: $sql"; + $sth->execute(@bind_vals) or + die "Unable to select one: ".$dbh->errstr(); + my $results = $sth->fetchall_arrayref([0]); + $sth->finish(); + return (ref($results) and ref($results->[0]))?$results->[0][0]:undef; +} + +=item prepare_execute + + prepare_execute($dbh,$sql,@bind_vals) + +Prepares and executes a statement + +=cut + +sub prepare_execute { + my ($dbh,$sql,@bind_vals) = @_; + my $sth = $dbh-> + prepare_cached($sql, + {dbi_dummy => __FILE__.__LINE__ }) + or die "Unable to prepare statement: $sql"; + $sth->execute(@bind_vals) or + die "Unable to execute statement: ".$dbh->errstr(); + $sth->finish(); +} + + +=back + +=cut + +1; + + +__END__ diff --git a/lib/Debbugs/DebArchive.pm b/lib/Debbugs/DebArchive.pm new file mode 100644 index 0000000..ccb321a --- /dev/null +++ b/lib/Debbugs/DebArchive.pm @@ -0,0 +1,204 @@ +# 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 2017 by Don Armstrong . + +package Debbugs::DebArchive; + +use warnings; +use strict; + +=head1 NAME + +Debbugs::DebArchive -- Routines for reading files from Debian archives + +=head1 SYNOPSIS + +use Debbugs::DebArchive; + + read_packages('/srv/mirrors/ftp.debian.org/ftp/dist', + sub { print map {qq($_\n)} @_ }, + Term::ProgressBar->new(), + ); + + +=head1 DESCRIPTION + +This module implements a set of routines for reading Packages.gz, Sources.gz and +Release files from the dists directory of a Debian archive. + +=head1 BUGS + +None known. + +=cut + + +use vars qw($DEBUG $VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT); +use base qw(Exporter); + +BEGIN { + $VERSION = 1.00; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (read => [qw(read_release_file read_packages), + ], + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + +use File::Spec qw(); +use File::Basename; +use Debbugs::Config qw(:config); +use Debbugs::Common qw(open_compressed_file make_list); +use IO::Dir; + +use Carp; + +=over + +=item read_release_file + + read_release_file('stable/Release') + +Reads a Debian release file and returns a hashref of information about the +release file, including the Packages and Sources files for that distribution + +=cut + +sub read_release_file { + my ($file) = @_; + # parse release + my $rfh = open_compressed_file($file) or + die "Unable to open $file for reading: $!"; + my %dist_info; + my $in_sha1; + my %p_f; + while (<$rfh>) { + chomp; + if (s/^(\S+):\s*//) { + if ($1 eq 'SHA1'or $1 eq 'SHA256') { + $in_sha1 = 1; + next; + } + $dist_info{$1} = $_; + } elsif ($in_sha1) { + s/^\s//; + my ($sha,$size,$f) = split /\s+/,$_; + next unless $f =~ /(?:Packages|Sources)(?:\.gz|\.xz)$/; + next unless $f =~ m{^([^/]+)/([^/]+)/([^/]+)$}; + my ($component,$arch,$package_source) = ($1,$2,$3); + $arch =~ s/binary-//; + next if exists $p_f{$component}{$arch} and + $p_f{$component}{$arch} =~ /\.xz$/; + $p_f{$component}{$arch} = File::Spec->catfile(dirname($file),$f); + } + } + return (\%dist_info,\%p_f); +} + +=item read_packages + + read_packages($dist_dir,$callback,$progress) + +=over + +=item dist_dir + +Path to dists directory + +=item callback + +Function which is called with key, value pairs of suite, arch, component, +Package, Source, Version, and Maintainer information for each package in the +Packages file. + +=item progress + +Optional Term::ProgressBar object to output progress while reading packages. + +=back + + +=cut + +sub read_packages { + my ($dist_dir,$callback,$p) = @_; + + my %s_p; + my $tot = 0; + for my $dist (make_list($dist_dir)) { + my $dist_dir_h = IO::Dir->new($dist); + my @dist_names = + grep { $_ !~ /^\./ and + -d $dist.'/'.$_ and + not -l $dist.'/'.$_ + } $dist_dir_h->read or + die "Unable to read from dir: $!"; + $dist_dir_h->close or + die "Unable to close dir: $!"; + while (my $dist = shift @dist_names) { + my $dir = $dist_dir.'/'.$dist; + my ($dist_info,$package_files) = + read_release_file(File::Spec->catfile($dist_dir, + $dist, + 'Release')); + $s_p{$dist_info->{Codename}} = $package_files; + } + for my $suite (keys %s_p) { + for my $component (keys %{$s_p{$suite}}) { + $tot += scalar keys %{$s_p{$suite}{$component}}; + } + } + } + $p->target($tot) if $p; + my $done_archs = 0; + # parse packages files + for my $suite (keys %s_p) { + my $pkgs = 0; + for my $component (keys %{$s_p{$suite}}) { + my @archs = keys %{$s_p{$suite}{$component}}; + if (grep {$_ eq 'source'} @archs) { + @archs = ('source',grep {$_ ne 'source'} @archs); + } + for my $arch (@archs) { + my $pfh = open_compressed_file($s_p{$suite}{$component}{$arch}) or + die "Unable to open $s_p{$suite}{$component}{$arch} for reading: $!"; + local $_; + local $/ = ''; # paragraph mode + while (<$pfh>) { + my %pkg; + for my $field (qw(Package Maintainer Version Source)) { + /^\Q$field\E: (.*)/m; + $pkg{$field} = $1; + } + next unless defined $pkg{Package} and + defined $pkg{Version}; + $pkg{suite} = $suite; + $pkg{arch} = $arch; + $pkg{component} = $component; + $callback->(%pkg); + } + $p->update(++$done_archs) if $p; + } + } + } + $p->remove() if $p; +} + +=back + +=cut + +1; + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/lib/Debbugs/Estraier.pm b/lib/Debbugs/Estraier.pm new file mode 100644 index 0000000..174ad4c --- /dev/null +++ b/lib/Debbugs/Estraier.pm @@ -0,0 +1,177 @@ +# 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 2007 by Don Armstrong . + +package Debbugs::Estraier; + +=head1 NAME + +Debbugs::Estraier -- Routines for interfacing bugs to HyperEstraier + +=head1 SYNOPSIS + +use Debbugs::Estraier; + + +=head1 DESCRIPTION + + +=head1 BUGS + +None known. + +=cut + +use warnings; +use strict; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use Exporter qw(import); +use Debbugs::Log; +use Search::Estraier; +use Debbugs::Common qw(getbuglocation getbugcomponent make_list); +use Debbugs::Status qw(readbug); +use Debbugs::MIME qw(parse); +use Encode qw(encode_utf8); + +BEGIN{ + ($VERSION) = q$Revision: 1.3 $ =~ /^Revision:\s+([^\s+])/; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (add => [qw(add_bug_log add_bug_message)], + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(qw(add)); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + + +sub add_bug_log{ + my ($est,$bug_num) = @_; + + # We want to read the entire bug log, pulling out individual + # messages, and shooting them through hyper estraier + + my $location = getbuglocation($bug_num,'log'); + my $bug_log = getbugcomponent($bug_num,'log',$location); + my $log_fh = new IO::File $bug_log, 'r' or + die "Unable to open bug log $bug_log for reading: $!"; + + my $log = Debbugs::Log->new($log_fh) or + die "Debbugs::Log was unable to be initialized"; + + my %seen_msg_ids; + my $msg_num=0; + my $status = {}; + if (my $location = getbuglocation($bug_num,'summary')) { + $status = readbug($bug_num,$location); + } + while (my $record = $log->read_record()) { + $msg_num++; + next unless $record->{type} eq 'incoming-recv'; + my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im; + next if defined $msg_id and exists $seen_msg_ids{$msg_id}; + $seen_msg_ids{$msg_id} = 1 if defined $msg_id; + next if defined $msg_id and $msg_id =~ /handler\..+\.ack(?:info)?\@/; + add_bug_message($est,$record->{text},$bug_num,$msg_num,$status) + } + return $msg_num; +} + +=head2 remove_old_message + + remove_old_message($est,300000,50); + +Removes all messages which are no longer in the log + +=cut + +sub remove_old_messages{ + my ($est,$bug_num,$max_message) = @_; + # remove records which are no longer present in the log (uri > $msg_num) + my $cond = new Search::Estraier::Condition; + $cond->add_attr('@uri STRBW '.$bug_num.'/'); + $cond->set_max(50); + my $nres; + while ($nres = $est->search($cond,0) and $nres->doc_num > 0){ + for my $rdoc (map {$nres->get_doc($_)} 0..($nres->doc_num-1)) { + my $uri = $rdoc->uri; + my ($this_message) = $uri =~ m{/(\d+)$}; + next unless $this_message > $max_message; + $est->out_doc_by_uri($uri); + } + last unless $nres->doc_num >= $cond->max; + $cond->set_skip($cond->skip+$cond->max); + } + +} + +sub add_bug_message{ + my ($est,$bug_message,$bug_num, + $msg_num,$status) = @_; + + my $doc; + my $uri = "$bug_num/$msg_num"; + $doc = $est->get_doc_by_uri($uri); + $doc = new Search::Estraier::Document if not defined $doc; + + my $message = parse($bug_message); + $doc->add_text(encode_utf8(join("\n",make_list(values %{$message})))); + + # * @id : the ID number determined automatically when the document is registered. + # * @uri : the location of a document which any document should have. + # * @digest : the message digest calculated automatically when the document is registered. + # * @cdate : the creation date. + # * @mdate : the last modification date. + # * @adate : the last access date. + # * @title : the title used as a headline in the search result. + # * @author : the author. + # * @type : the media type. + # * @lang : the language. + # * @genre : the genre. + # * @size : the size. + # * @weight : the scoring weight. + # * @misc : miscellaneous information. + my @attr = qw(status subject date submitter package tags severity); + # parse the date + my ($date) = $bug_message =~ /^Date:\s+(.+?)\s*$/mi; + $doc->add_attr('@cdate' => encode_utf8($date)) if defined $date; + # parse the title + my ($subject) = $bug_message =~ /^Subject:\s+(.+?)\s*$/mi; + $doc->add_attr('@title' => encode_utf8($subject)) if defined $subject; + # parse the author + my ($author) = $bug_message =~ /^From:\s+(.+?)\s*$/mi; + $doc->add_attr('@author' => encode_utf8($author)) if defined $author; + # create the uri + $doc->add_attr('@uri' => encode_utf8($uri)); + foreach my $attr (@attr) { + $doc->add_attr($attr => encode_utf8($status->{$attr})) if defined $status->{$attr}; + } + print STDERR "adding $uri\n" if $DEBUG; + # Try a bit harder if estraier is returning timeouts + my $attempt = 5; + while ($attempt > 0) { + $est->put_doc($doc) and last; + my $status = $est->status; + $attempt--; + print STDERR "Failed to add $uri\n".$status."\n"; + last unless $status =~ /^5/; + sleep 20; + } + +} + + +1; + + +__END__ + + + + + + diff --git a/lib/Debbugs/Libravatar.pm b/lib/Debbugs/Libravatar.pm new file mode 100644 index 0000000..373a9f5 --- /dev/null +++ b/lib/Debbugs/Libravatar.pm @@ -0,0 +1,333 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version. See the +# file README and COPYING for more information. +# Copyright 2013 by Don Armstrong . + +package Debbugs::Libravatar; + +=head1 NAME + +Debbugs::Libravatar -- Libravatar service handler (mod_perl) + +=head1 SYNOPSIS + + + SetHandler perl-script + PerlResponseHandler Debbugs::Libravatar + + +=head1 DESCRIPTION + +Debbugs::Libravatar is a libravatar service handler which will serve +libravatar requests. It also contains utility routines which are used +by the libravatar.cgi script for those who do not have mod_perl. + +=head1 BUGS + +None known. + +=cut + +use warnings; +use strict; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use Exporter qw(import); + +use Debbugs::Config qw(:config); +use Debbugs::Common qw(:lock); +use Libravatar::URL; +use CGI::Simple; +use Debbugs::CGI qw(cgi_parameters); +use Digest::MD5 qw(md5_hex); +use File::Temp qw(tempfile); +use File::LibMagic; +use Cwd qw(abs_path); + +use Carp; + +BEGIN{ + ($VERSION) = q$Revision$ =~ /^Revision:\s+([^\s+])/; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (libravatar => [qw(retrieve_libravatar cache_location)] + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + + +our $magic; + +=over + +=item retrieve_libravatar + + $cache_location = retrieve_libravatar(location => $cache_location, + email => lc($param{email}), + ); + +Returns the cache location where a specific avatar can be loaded. If +there isn't a matching avatar, or there is an error, returns undef. + + +=cut + +sub retrieve_libravatar{ + my %type_mapping = + (jpeg => 'jpg', + png => 'png', + gif => 'png', + tiff => 'png', + tif => 'png', + pjpeg => 'jpg', + jpg => 'jpg' + ); + my %param = @_; + my $cache_location = $param{location}; + my $timestamp; + $cache_location =~ s/\.[^\.\/]+$//; + # take out a lock on the cache location so that if another request + # is made while we are serving this one, we don't do double work + my ($fh,$lockfile,$errors) = + simple_filelock($cache_location.'.lock',20,0.5); + if (not $fh) { + return undef; + } else { + # figure out if the cache is now valid; if it is, return the + # cache location + my $temp_location; + ($temp_location, $timestamp) = cache_location(email => $param{email}); + if ($timestamp) { + return ($temp_location,$timestamp); + } + } + require LWP::UserAgent; + + my $dest_type = 'png'; + eval { + my $uri = libravatar_url(email => $param{email}, + default => 404, + size => 80); + my $ua = LWP::UserAgent->new(agent => 'Debbugs libravatar service (not Mozilla)', + ); + $ua->from($config{maintainer}); + # if we don't get an avatar within 10 seconds, return so we + # don't block forever + $ua->timeout(10); + # if the avatar is bigger than 30K, we don't want it either + $ua->max_size(30*1024); + $ua->default_header('Accept' => 'image/*'); + my $r = $ua->get($uri); + if (not $r->is_success()) { + if ($r->code != 404) { + die "Not successful in request"; + } + # No avatar - cache a negative result + if ($config{libravatar_default_image} =~ m/\.(png|jpg)$/) { + $dest_type = $1; + + system('cp', '-laf', $config{libravatar_default_image}, $cache_location.'.'.$dest_type) == 0 + or die("Cannot copy $config{libravatar_default_image}"); + # Returns from eval {} + return; + } + } + my $aborted = $r->header('Client-Aborted'); + # if we exceeded max size, I'm not sure if we'll be + # successfull or not, but regardless, there will be a + # Client-Aborted header. Stop here if that header is defined. + die "Client aborted header" if defined $aborted; + my $type = $r->header('Content-Type'); + # if there's no content type, or it's not one we like, we won't + # bother going further + if (defined $type) { + die "Wrong content type" if not $type =~ m{^image/([^/]+)$}; + $dest_type = $type_mapping{$1}; + die "No dest type" if not defined $dest_type; + } + # undo any content encoding + $r->decode() or die "Unable to decode content encoding"; + # ok, now we need to convert it from whatever it is into a + # format that we actually like + my ($temp_fh,$temp_fn) = tempfile() or + die "Unable to create temporary file"; + eval { + print {$temp_fh} $r->content() or + die "Unable to print to temp file"; + close ($temp_fh) or + die "Unable to close temp file"; + ### Figure out the actual type from the file + $magic = File::LibMagic->new() if not defined $magic; + $type = $magic->checktype_filename(abs_path($temp_fn)); + die "Wrong content type ($type)" if not $type =~ m{^image/([^/;]+)(?:;|$)}; + $dest_type = $type_mapping{$1}; + die "No dest type for ($1)" if not defined $dest_type; + ### resize all images to 80x80 and strip comments out of + ### them. If convert has a bug, it would be possible for + ### this to be an attack vector, but hopefully minimizing + ### the size above, and requiring proper mime types will + ### minimize that slightly. Doing this will at least make + ### it harder for malicious web images to harm our users + system('convert','-resize','80x80', + '-strip', + $temp_fn, + $cache_location.'.'.$dest_type) == 0 or + die "convert file failed"; + unlink($temp_fn); + }; + if ($@) { + unlink($cache_location.'.'.$dest_type) if -e $cache_location.'.'.$dest_type; + unlink($temp_fn) if -e $temp_fn; + die "Unable to convert image"; + } + }; + if ($@) { + # there was some kind of error; return undef and unlock the + # lock + simple_unlockfile($fh,$lockfile); + return undef; + } + simple_unlockfile($fh,$lockfile); + $timestamp = (stat($cache_location.'.'.$dest_type))[9]; + return ($cache_location.'.'.$dest_type,$timestamp); +} + +sub blocked_libravatar { + my ($email,$md5sum) = @_; + my $blocked = 0; + for my $blocker (@{$config{libravatar_blacklist}||[]}) { + for my $element ($email,$md5sum) { + next unless defined $element; + eval { + if ($element =~ /$blocker/) { + $blocked=1; + } + }; + } + } + return $blocked; +} + +# Returns ($path, $timestamp) +# - For blocked images, $path will be undef +# - If $timestamp is 0 (and $path is not undef), the image should +# be re-fetched. +sub cache_location { + my %param = @_; + my ($md5sum, $stem); + if (exists $param{md5sum}) { + $md5sum = $param{md5sum}; + }elsif (exists $param{email}) { + $md5sum = md5_hex(lc($param{email})); + } else { + croak("cache_location must be called with one of md5sum or email"); + } + return (undef, 0) if blocked_libravatar($param{email},$md5sum); + my $cache_dir = $param{cache_dir} // $config{libravatar_cache_dir}; + $stem = $cache_dir.'/'.$md5sum; + for my $ext ('.png', '.jpg', '') { + my $path = $stem.$ext; + if (-e $path) { + my $timestamp = (time - (stat(_))[9] < 60*60) ? (stat(_))[9] : 0; + return ($path, $timestamp); + } + } + return ($stem, 0); +} + +## the following is mod_perl specific + +BEGIN{ + if (exists $ENV{MOD_PERL_API_VERSION}) { + if ($ENV{MOD_PERL_API_VERSION} == 2) { + require Apache2::RequestIO; + require Apache2::RequestRec; + require Apache2::RequestUtil; + require Apache2::Const; + require APR::Finfo; + require APR::Const; + APR::Const->import(-compile => qw(FINFO_NORM)); + Apache2::Const->import(-compile => qw(OK DECLINED FORBIDDEN NOT_FOUND HTTP_NOT_MODIFIED)); + } else { + die "Unsupported mod perl api; mod_perl 2.0.0 or later is required"; + } + } +} + +sub handler { + die "Calling handler only makes sense if this is running under mod_perl" unless exists $ENV{MOD_PERL_API_VERSION}; + my $r = shift or Apache2::RequestUtil->request; + + # we only want GET or HEAD requests + unless ($r->method eq 'HEAD' or $r->method eq 'GET') { + return Apache2::Const::DECLINED(); + } + $r->headers_out->{"X-Powered-By"} = "Debbugs libravatar"; + + my $uri = $r->uri(); + # subtract out location + my $location = $r->location(); + my ($email) = $uri =~ m/\Q$location\E\/?(.*)$/; + if (not length $email) { + return Apache2::Const::NOT_FOUND(); + } + my $q = CGI::Simple->new(); + my %param = cgi_parameters(query => $q, + single => [qw(avatar)], + default => {avatar => 'yes', + }, + ); + if ($param{avatar} ne 'yes' or not defined $email or not length $email) { + serve_cache_mod_perl('',$r); + return Apache2::Const::DECLINED(); + } + # figure out what the md5sum of the e-mail is. + my ($cache_location, $timestamp) = cache_location(email => $email); + # if we've got it, and it's less than one hour old, return it. + if ($timestamp) { + serve_cache_mod_perl($cache_location,$r); + return Apache2::Const::DECLINED(); + } + ($cache_location,$timestamp) = + retrieve_libravatar(location => $cache_location, + email => $email, + ); + if (not defined $cache_location) { + # failure, serve the default image + serve_cache_mod_perl('',$r,$timestamp); + return Apache2::Const::DECLINED(); + } else { + serve_cache_mod_perl($cache_location,$r,$timestamp); + return Apache2::Const::DECLINED(); + } +} + + + +sub serve_cache_mod_perl { + my ($cache_location,$r,$timestamp) = @_; + if (not defined $cache_location or not length $cache_location) { + # serve the default image + $cache_location = $config{libravatar_default_image}; + } + $magic = File::LibMagic->new() if not defined $magic; + + return Apache2::Const::DECLINED() if not defined $magic; + + $r->content_type($magic->checktype_filename(abs_path($cache_location))); + + $r->filename($cache_location); + $r->path_info(''); + $r->finfo(APR::Finfo::stat($cache_location, APR::Const::FINFO_NORM(), $r->pool)); +} + +=back + +=cut + +1; + + +__END__ diff --git a/lib/Debbugs/Log.pm b/lib/Debbugs/Log.pm new file mode 100644 index 0000000..710a844 --- /dev/null +++ b/lib/Debbugs/Log.pm @@ -0,0 +1,589 @@ +# 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. +# +# [Other people have contributed to this file; their copyrights should +# go here too.] +# Copyright 2004 by Collin Watson +# Copyright 2007 by Don Armstrong + + +package Debbugs::Log; + +use Mouse; +use strictures 2; +use namespace::clean; +use v5.10; # for state + +use vars qw($VERSION $DEBUG @EXPORT @EXPORT_OK %EXPORT_TAGS); +use Exporter qw(import); + +BEGIN { + $VERSION = 1.00; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (write => [qw(write_log_records), + ], + read => [qw(read_log_records record_text record_regex), + ], + misc => [qw(escape_log), + ], + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(qw(write read misc)); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + +use Carp; + +use Debbugs::Common qw(getbuglocation getbugcomponent make_list); +use Params::Validate qw(:types validate_with); +use Encode qw(encode encode_utf8 is_utf8); +use IO::InnerFile; + +=head1 NAME + +Debbugs::Log - an interface to debbugs .log files + +=head1 DESCRIPTION + +The Debbugs::Log module provides a convenient way for scripts to read and +write the .log files used by debbugs to store the complete textual records +of all bug transactions. + +Debbugs::Log does not decode utf8 into perl's internal encoding or +encode into utf8 from perl's internal encoding. For html records and +all recips, this should probably be done. For other records, this should +not be needed. + +=head2 The .log File Format + +.log files consist of a sequence of records, of one of the following four +types. ^A, ^B, etc. represent those control characters. + +=over 4 + +=item incoming-recv + + ^G + [mail] + ^C + +C<[mail]> must start with /^Received: \(at \S+\) by \S+;/, and is copied to +the output. + +=item autocheck + +Auto-forwarded messages are recorded like this: + + ^A + [mail] + ^C + +C<[mail]> must contain /^X-Debian-Bugs(-\w+)?: This is an autoforward from +\S+/. The first line matching that is removed; all lines in the message body +that begin with 'X' will be copied to the output, minus the 'X'. + +Nothing in debbugs actually generates this record type any more, but it may +still be in old .logs at some sites. + +=item recips + + ^B + [recip]^D[recip]^D[...] OR -t + ^E + [mail] + ^C + +Each [recip] is output after "Message sent"; C<-t> represents the same +sendmail option, indicating that the recipients are taken from the headers +of the message itself. + +=item html + + ^F + [html] + ^C + +[html] is copied unescaped to the output. The record immediately following +this one is considered "boring" and only shown in certain output modes. + +(This is a design flaw in the log format, since it makes it difficult to +change the HTML presentation later, or to present the data in an entirely +different format.) + +=back + +No other types of records are permitted, and the file must end with a ^C +line. + +=cut + +my %states = ( + 1 => 'autocheck', + 2 => 'recips', + 3 => 'kill-end', + 5 => 'go', + 6 => 'html', + 7 => 'incoming-recv', +); + +=head2 Perl Record Representation + +Each record is a hash. The C field is C, C, +C, or C as above; C contains text from C<[mail]> or +C<[html]> as above; C is a reference to an array of recipients +(strings), or undef for C<-t>. + +=head1 FUNCTIONS + +=over 4 + +=item new + +Creates a new log reader based on a .log filehandle. + + my $log = Debbugs::Log->new($logfh); + my $log = Debbugs::Log->new(bug_num => $nnn); + my $log = Debbugs::Log->new(logfh => $logfh); + +Parameters + +=over + +=item bug_num -- bug number + +=item logfh -- log filehandle + +=item log_name -- name of log + +=back + +One of the above options must be passed. + +=cut + +sub BUILD { + my ($self,$args) = @_; + if (not ($self->_has_bug_num or + $self->_has_logfh or + $self->_has_log_name)) { + croak "Exactly one of bug_num, logfh, or log_name ". + "must be passed and must be defined"; + } +} + +has 'bug_num' => + (is => 'ro', + isa => 'Int', + predicate => '_has_bug_num', + ); + +has 'logfh' => + (is => 'ro', + lazy => 1, + builder => '_build_logfh', + predicate => '_has_logfh', + ); + +sub _build_logfh { + my $self = shift; + my $bug_log = + $self->log_name; + my $log_fh; + if ($bug_log =~ m/\.gz$/) { + my $oldpath = $ENV{'PATH'}; + $ENV{'PATH'} = '/bin:/usr/bin'; + open($log_fh,'-|','gzip','-dc',$bug_log) or + die "Unable to open $bug_log for reading: $!"; + $ENV{'PATH'} = $oldpath; + } else { + open($log_fh,'<',$bug_log) or + die "Unable to open $bug_log for reading: $!"; + } + return $log_fh; +} + +has 'log_name' => + (is => 'ro', + isa => 'Str', + lazy => 1, + builder => '_build_log_name', + predicate => '_has_log_name', + ); + +sub _build_log_name { + my $self = shift; + my $location = getbuglocation($self->bug_num,'log'); + return getbugcomponent($self->bug_num,'log',$location); +} + +has 'inner_file' => + (is => 'ro', + isa => 'Bool', + default => 0, + ); + +has 'state' => + (is => 'ro', + isa => 'Str', + default => 'kill-init', + writer => '_state', + ); + +sub state_transition { + my $self = shift; + my $new_state = shift; + my $old_state = $self->state; + local $_ = "$old_state $new_state"; + unless (/^(go|go-nox|html) kill-end$/ or + /^(kill-init|kill-end) (incoming-recv|autocheck|recips|html)$/ or + /^autocheck autowait$/ or + /^autowait go-nox$/ or + /^recips kill-body$/ or + /^(kill-body|incoming-recv) go$/) { + confess "transition from $old_state to $new_state at $self->linenum disallowed"; + } + $self->_state($new_state); +} + +sub increment_linenum { + my $self = shift; + $self->_linenum($self->_linenum+1); +} +has '_linenum' => + (is => 'rw', + isa => 'Int', + default => 0, + ); + +=item read_record + +Reads and returns a single record from a log reader object. At end of file, +returns undef. Throws exceptions using die(), so you may want to wrap this +in an eval(). + +=cut + +sub read_record +{ + my $this = shift; + my $logfh = $this->logfh; + + # This comes from bugreport.cgi, but is much simpler since it doesn't + # worry about the details of output. + + my $record = {}; + + while (defined (my $line = <$logfh>)) { + $record->{start} = $logfh->tell() if not defined $record->{start}; + chomp $line; + $this->increment_linenum; + if (length($line) == 1 and exists $states{ord($line)}) { + # state transitions + $this->state_transition($states{ord($line)}); + if ($this->state =~ /^(autocheck|recips|html|incoming-recv)$/) { + $record->{type} = $this->state; + $record->{start} = $logfh->tell; + $record->{stop} = $logfh->tell; + $record->{inner_file} = $this->inner_file; + } elsif ($this->state eq 'kill-end') { + if ($this->inner_file) { + $record->{fh} = + IO::InnerFile->new($logfh,$record->{start}, + $record->{stop} - $record->{start}) + } + return $record; + } + + next; + } + $record->{stop} = $logfh->tell; + $_ = $line; + if ($this->state eq 'incoming-recv') { + my $pl = $_; + unless (/^Received: \(at \S+\) by \S+;/) { + die "bad line '$pl' in state incoming-recv"; + } + $this->state_transition('go'); + $record->{text} .= "$_\n" unless $this->inner_file; + } elsif ($this->state eq 'html') { + $record->{text} .= "$_\n" unless $this->inner_file; + } elsif ($this->state eq 'go') { + s/^\030//; + $record->{text} .= "$_\n" unless $this->inner_file; + } elsif ($this->state eq 'go-nox') { + $record->{text} .= "$_\n" unless $this->inner_file; + } elsif ($this->state eq 'recips') { + if (/^-t$/) { + undef $record->{recips}; + } else { + # preserve trailing null fields, e.g. #2298 + $record->{recips} = [split /\04/, $_, -1]; + } + $this->state_transition('kill-body'); + $record->{start} = $logfh->tell+2; + $record->{stop} = $logfh->tell+2; + $record->{inner_file} = $this->inner_file; + } elsif ($this->state eq 'autocheck') { + $record->{text} .= "$_\n" unless $this->inner_file; + next if !/^X-Debian-Bugs(-\w+)?: This is an autoforward from (\S+)/; + $this->state_transition('autowait'); + } elsif ($this->state eq 'autowait') { + $record->{text} .= "$_\n" unless $this->inner_file; + next if !/^$/; + $this->state_transition('go-nox'); + } else { + die "state $this->state at line $this->linenum ('$_')"; + } + } + die "state $this->state at end" unless $this->state eq 'kill-end'; + + if (keys %$record) { + return $record; + } else { + return undef; + } +} + +=item rewind + +Rewinds the Debbugs::Log to the beginning + +=cut + +sub rewind { + my $self = shift; + if ($self->_has_log_name) { + $self->_clear_log_fh; + } else { + $self->log_fh->seek(0); + } + $self->_state('kill-init'); + $self->_linenum(0); +} + +=item read_all_records + +Reads all of the Debbugs::Records + +=cut + +sub read_all_records { + my $self = shift; + if ($self->_linenum != 0) { + $self->rewind; + } + my @records; + while (defined(my $record = $self->read_record())) { + push @records, $record; + } + return @records; +} + + +=item read_log_records + +Takes a .log filehandle as input, and returns an array of all records in +that file. Throws exceptions using die(), so you may want to wrap this in an +eval(). + +Uses exactly the same options as Debbugs::Log::new + +=cut + +sub read_log_records +{ + my %param; + if (@_ == 1) { + ($param{logfh}) = @_; + } + else { + %param = validate_with(params => \@_, + spec => {bug_num => {type => SCALAR, + optional => 1, + }, + logfh => {type => HANDLE, + optional => 1, + }, + log_name => {type => SCALAR, + optional => 1, + }, + inner_file => {type => BOOLEAN, + default => 0, + }, + } + ); + } + if (grep({exists $param{$_} and defined $param{$_}} qw(bug_num logfh log_name)) ne 1) { + croak "Exactly one of bug_num, logfh, or log_name must be passed and must be defined"; + } + + my @records; + my $reader = Debbugs::Log->new(%param); + while (defined(my $record = $reader->read_record())) { + push @records, $record; + } + return @records; +} + +=item write_log_records + +Takes a filehandle and a list of records as input, and prints the .log +format representation of those records to that filehandle. + +=back + +=cut + +sub write_log_records +{ + my %param = validate_with(params => \@_, + spec => {bug_num => {type => SCALAR, + optional => 1, + }, + logfh => {type => HANDLE, + optional => 1, + }, + log_name => {type => SCALAR, + optional => 1, + }, + records => {type => HASHREF|ARRAYREF, + }, + }, + ); + if (grep({exists $param{$_} and defined $param{$_}} qw(bug_num logfh log_name)) ne 1) { + croak "Exactly one of bug_num, logfh, or log_name must be passed and must be defined"; + } + my $logfh; + if (exists $param{logfh}) { + $logfh = $param{logfh} + } + elsif (exists $param{log_name}) { + $logfh = IO::File->new(">>$param{log_name}") or + die "Unable to open bug log $param{log_name} for writing: $!"; + } + elsif (exists $param{bug_num}) { + my $location = getbuglocation($param{bug_num},'log'); + my $bug_log = getbugcomponent($param{bug_num},'log',$location); + $logfh = IO::File->new($bug_log, 'r') or + die "Unable to open bug log $bug_log for reading: $!"; + } + my @records = make_list($param{records}); + + for my $record (@records) { + my $type = $record->{type}; + croak "record type '$type' with no text field" unless defined $record->{text}; + # I am not sure if we really want to croak here; but this is + # almost certainly a bug if is_utf8 is on. + my $text = $record->{text}; + if (is_utf8($text)) { + carp('Record text was in the wrong encoding (perl internal instead of utf8 octets)'); + $text = encode_utf8($text) + } + ($text) = escape_log($text); + if ($type eq 'autocheck') { + print {$logfh} "\01\n$text\03\n" or + die "Unable to write to logfile: $!"; + } elsif ($type eq 'recips') { + print {$logfh} "\02\n"; + my $recips = $record->{recips}; + if (defined $recips) { + croak "recips not undef or array" + unless ref($recips) eq 'ARRAY'; + my $wrong_encoding = 0; + my @recips = + map { if (is_utf8($_)) { + $wrong_encoding=1; + encode_utf8($_); + } else { + $_; + }} @$recips; + carp('Recipients was in the wrong encoding (perl internal instead of utf8 octets') if $wrong_encoding; + print {$logfh} join("\04", @$recips) . "\n" or + die "Unable to write to logfile: $!"; + } else { + print {$logfh} "-t\n" or + die "Unable to write to logfile: $!"; + } + #$text =~ s/^([\01-\07\030])/\030$1/gm; + print {$logfh} "\05\n$text\03\n" or + die "Unable to write to logfile: $!"; + } elsif ($type eq 'html') { + print {$logfh} "\06\n$text\03\n" or + die "Unable to write to logfile: $!"; + } elsif ($type eq 'incoming-recv') { + #$text =~ s/^([\01-\07\030])/\030$1/gm; + print {$logfh} "\07\n$text\03\n" or + die "Unable to write to logfile: $!"; + } else { + croak "unknown record type type '$type'"; + } + } + + 1; +} + +=head2 escape_log + + print {$log} escape_log(@log) + +Applies the log escape regex to the passed logfile. + +=cut + +sub escape_log { + my @log = @_; + return map {s/^([\01-\07\030])/\030$1/gm; $_ } @log; +} + + +sub record_text { + my ($record) = @_; + if ($record->{inner_file}) { + local $/; + my $text; + my $t = $record->{fh}; + $text = <$t>; + $record->{fh}->seek(0,0); + return $text; + } else { + return $record->{text}; + } +} + +sub record_regex { + my ($record,$regex) = @_; + if ($record->{inner_file}) { + my @result; + my $fh = $record->{fh}; + while (<$fh>) { + if (@result = $_ =~ m/$regex/) { + $record->{fh}->seek(0,0); + return @result; + } + } + $record->{fh}->seek(0,0); + return (); + } else { + my @result = $record->{text} =~ m/$regex/; + return @result; + } +} + + +=head1 CAVEATS + +This module does none of the formatting that bugreport.cgi et al do. It's +simply a means for extracting and rewriting raw records. + +=cut + +1; + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/lib/Debbugs/Log/Spam.pm b/lib/Debbugs/Log/Spam.pm new file mode 100644 index 0000000..e5ed18f --- /dev/null +++ b/lib/Debbugs/Log/Spam.pm @@ -0,0 +1,279 @@ +# 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 2017 by Don Armstrong . + +package Debbugs::Log::Spam; + +=head1 NAME + +Debbugs::Log::Spam -- an interface to debbugs .log.spam files and .log.spam.d +directories + +=head1 SYNOPSIS + +use Debbugs::Log::Spam; + +my $spam = Debbugs::Log::Spam->new(bug_num => '12345'); + +=head1 DESCRIPTION + +Spam in bugs can be excluded using a .log.spam file and a .log.spam.d directory. +The file contains message ids, one per line, and the directory contains files +named after message ids, one per file. + +=head1 BUGS + +None known. + +=cut + +use warnings; +use strict; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use base qw(Exporter); + +BEGIN{ + $VERSION = 1; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (); + @EXPORT_OK = (); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; + +} + +use Carp; +use feature 'state'; +use Params::Validate qw(:types validate_with); +use Debbugs::Common qw(getbuglocation getbugcomponent filelock unfilelock); + +=head1 FUNCTIONS + +=over 4 + +=item new + +Creates a new log spam reader. + + my $spam_log = Debbugs::Log::Spam->new(log_spam_name => "56/123456.log.spam"); + my $spam_log = Debbugs::Log::Spam->new(bug_num => $nnn); + +Parameters + +=over + +=item bug_num -- bug number + +=item log_spam_name -- name of log + +=back + +One of the above options must be passed. + +=cut + +sub new { + my $this = shift; + state $spec = + {bug_num => {type => SCALAR, + optional => 1, + }, + log_spam_name => {type => SCALAR, + optional => 1, + }, + }; + my %param = + validate_with(params => \@_, + spec => $spec + ); + if (grep({exists $param{$_} and + defined $param{$_}} qw(bug_num log_spam_name)) ne 1) { + croak "Exactly one of bug_num or log_spam_name". + "must be passed and must be defined"; + } + + my $class = ref($this) || $this; + my $self = {}; + bless $self, $class; + + if (exists $param{log_spam_name}) { + $self->{name} = $param{log_spam_name}; + } elsif (exists $param{bug_num}) { + my $location = getbuglocation($param{bug_num},'log.spam'); + my $bug_log = getbugcomponent($param{bug_num},'log.spam',$location); + $self->{name} = $bug_log; + } + $self->_init(); + return $self; +} + + +sub _init { + my $self = shift; + + $self->{spam} = {}; + if (-e $self->{name}) { + open(my $fh,'<',$self->{name}) or + croak "Unable to open bug log spam '$self->{name}' for reading: $!"; + binmode($fh,':encoding(UTF-8)'); + while (<$fh>) { + chomp; + if (s/\sham$//) { + $self->{spam}{$_} = '0'; + } else { + $self->{spam}{$_} = '1'; + } + } + close ($fh) or + croak "Unable to close bug log filehandle: $!"; + } + if (-d $self->{name}.'.d') { + opendir(my $d,$self->{name}.'.d') or + croak "Unable to open bug log spamdir '$self->{name}.d' for reading: $!"; + for my $dir (readdir($d)) { + next unless $dir =~ m/([^\.].*)_(\w+)$/; + # .spam overrides .spam.d + next if exists $self->{spam}{$1}; + # set the spam HASH to $dir so we know where this value was set from + $self->{spam}{$1} = $dir; + } + closedir($d) or + croak "Unable to close bug log spamdir: $!"; + } + return $self; +} + +=item save + +C<$spam_log->save();> + +Saves changes to the bug log spam file. + +=cut + +sub save { + my $self = shift; + return unless keys %{$self->{spam}}; + filelock($self->{name}.'.lock'); + open(my $fh,'>',$self->{name}.'.tmp') or + croak "Unable to open bug log spam '$self->{name}.tmp' for writing: $!"; + binmode($fh,':encoding(UTF-8)'); + for my $msgid (keys %{$self->{spam}}) { + # was this message set to spam/ham by .d? If so, don't save it + if ($self->{spam}{$msgid} ne '0' and + $self->{spam}{$msgid} ne '1') { + next; + } + print {$fh} $msgid; + if ($self->{spam}{$msgid} eq '0') { + print {$fh} ' ham'; + } + print {$fh} "\n"; + } + close($fh) or croak "Unable to write to '$self->{name}.tmp': $!"; + rename($self->{name}.'.tmp',$self->{name}); + unfilelock(); +} + +=item is_spam + +Cis_spam('12456@exmaple.com'));> + +Returns 1 if this message id confirms that the message is spam + +Returns 0 if this message is not known to be spam + +=cut +sub is_spam { + my ($self,$msgid) = @_; + return 0 if not defined $msgid or not length $msgid; + $msgid =~ s/^<|>$//; + if (exists $self->{spam}{$msgid} and + $self->{spam}{$msgid} ne '0' + ) { + return 1; + } + return 0; +} + +=item is_ham + + next if ($spam_log->is_ham('12456@exmaple.com')); + +Returns 1 if this message id confirms that the message is ham + +Returns 0 if this message is not known to be ham + +=cut +sub is_ham { + my ($self,$msgid) = @_; + return 0 if not defined $msgid or not length $msgid; + $msgid =~ s/^<|>$//; + if (exists $self->{spam}{$msgid} and + $self->{spam}{$msgid} eq '0' + ) { + return 1; + } + return 0; +} + + +=item add_spam + + $spam_log->add_spam('123456@example.com'); + +Add a message id to the spam listing. + +You must call C<$spam_log->save()> if you wish the changes to be written out to disk. + +=cut + +sub add_spam { + my ($self,$msgid) = @_; + $msgid =~ s/^<|>$//; + $self->{spam}{$msgid} = '1'; +} + +=item add_ham + + $spam_log->add_ham('123456@example.com'); + +Add a message id to the ham listing. + +You must call C<$spam_log->save()> if you wish the changes to be written out to disk. + +=cut + +sub add_ham { + my ($self,$msgid) = @_; + $msgid =~ s/^<|>$//; + $self->{spam}{$msgid} = '0'; +} + +=item remove_message + + $spam_log->remove_message('123456@example.com'); + +Remove a message from the spam/ham listing. + +You must call C<$spam_log->save()> if you wish the changes to be written out to disk. + +=cut + + +1; + +=back + +=cut + +__END__ + +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/lib/Debbugs/MIME.pm b/lib/Debbugs/MIME.pm new file mode 100644 index 0000000..fec3b6e --- /dev/null +++ b/lib/Debbugs/MIME.pm @@ -0,0 +1,399 @@ +# 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. +# +# [Other people have contributed to this file; their copyrights should +# go here too.] +# Copyright 2006 by Don Armstrong . + + +package Debbugs::MIME; + +=encoding utf8 + +=head1 NAME + +Debbugs::MIME -- Mime handling routines for debbugs + +=head1 SYNOPSIS + + use Debbugs::MIME qw(parse decode_rfc1522); + +=head1 DESCRIPTION + + +=head1 BUGS + +None known. + +=cut + +use warnings; +use strict; + +use Exporter qw(import); +use vars qw($DEBUG $VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT); + +BEGIN { + $VERSION = 1.00; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + + %EXPORT_TAGS = (mime => [qw(parse create_mime_message getmailbody), + qw(parse_to_mime_entity), + ], + rfc1522 => [qw(decode_rfc1522 encode_rfc1522)], + ); + @EXPORT_OK=(); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + +use File::Path qw(remove_tree); +use File::Temp qw(tempdir); +use MIME::Parser; + +use POSIX qw(strftime); +use List::AllUtils qw(apply); + +# for convert_to_utf8 +use Debbugs::UTF8 qw(convert_to_utf8); + +# for decode_rfc1522 and encode_rfc1522 +use Encode qw(decode encode encode_utf8 decode_utf8 is_utf8); +use MIME::Words qw(); + +sub getmailbody +{ + my $entity = shift; + my $type = $entity->effective_type; + if ($type eq 'text/plain' or + ($type =~ m#text/?# and $type ne 'text/html') or + $type eq 'application/pgp') { + return $entity; + } elsif ($type eq 'multipart/alternative') { + # RFC 2046 says we should use the last part we recognize. + for my $part (reverse $entity->parts) { + my $ret = getmailbody($part); + return $ret if $ret; + } + } else { + # For other multipart types, we just pretend they're + # multipart/mixed and run through in order. + for my $part ($entity->parts) { + my $ret = getmailbody($part); + return $ret if $ret; + } + } + return undef; +} + +=head2 parse_to_mime_entity + + $entity = parse_to_mime_entity($record); + +Returns a MIME::Entity from a record (from Debbugs::Log), a filehandle, or a +scalar mail message. Will die upon failure. + +Intermediate parsing results will be output under a temporary directory which +should be cleaned up upon process exit. + +=cut + +sub parse_to_mime_entity { + my ($record) = @_; + my $parser = MIME::Parser->new(); + my $entity; + # this will be cleaned up once we exit + my $tempdir = File::Temp->newdir(); + $parser->output_dir($tempdir->dirname()); + if (ref($record) eq 'HASH') { + if ($record->{inner_file}) { + $entity = $parser->parse($record->{fh}) or + die "Unable to parse entity"; + } else { + $entity = $parser->parse_data($record->{text}) or + die "Unable to parse entity"; + } + } elsif (ref($record)) { + $entity = $parser->parse($record) or + die "Unable to parse entity"; + } else { + $entity = $parser->parse_data($record) or + die "Unable to parse entity"; + } + return $entity; +} + +sub parse +{ + # header and decoded body respectively + my (@headerlines, @bodylines); + + my $parser = MIME::Parser->new(); + my $tempdir = tempdir(CLEANUP => 1); + $parser->output_under($tempdir); + my $entity = eval { $parser->parse_data($_[0]) }; + + if ($entity and $entity->head->tags) { + @headerlines = @{$entity->head->header}; + chomp @headerlines; + + my $entity_body = getmailbody($entity); + my $entity_body_handle; + my $charset; + if (defined $entity_body) { + $entity_body_handle = $entity_body->bodyhandle(); + $charset = $entity_body->head()->mime_attr('content-type.charset'); + } + @bodylines = $entity_body_handle ? $entity_body_handle->as_lines() : (); + @bodylines = map {convert_to_utf8($_,$charset)} @bodylines; + chomp @bodylines; + } else { + # Legacy pre-MIME code, kept around in case MIME::Parser fails. + my @msg = split /\n/, $_[0]; + my $i; + + # assume us-ascii unless charset is set; probably bad, but we + # really shouldn't get to this point anyway + my $charset = 'us-ascii'; + for ($i = 0; $i <= $#msg; ++$i) { + $_ = $msg[$i]; + last unless length; + while ($msg[$i + 1] =~ /^\s/) { + ++$i; + $_ .= "\n" . $msg[$i]; + } + if (/charset=\"([^\"]+)\"/) { + $charset = $1; + } + push @headerlines, $_; + } + @bodylines = map {convert_to_utf8($_,$charset)} @msg[$i .. $#msg]; + } + + remove_tree($tempdir,{verbose => 0, safe => 1}); + + # Remove blank lines. + shift @bodylines while @bodylines and $bodylines[0] !~ /\S/; + + # Strip off RFC2440-style PGP clearsigning. + if (@bodylines and $bodylines[0] =~ /^-----BEGIN PGP SIGNED/) { + shift @bodylines while @bodylines and + length $bodylines[0] and + # we currently don't strip \r; handle this for the + # time being, though eventually it should be stripped + # too, I think. [See #565981] + $bodylines[0] ne "\r"; + shift @bodylines while @bodylines and $bodylines[0] !~ /\S/; + for my $findsig (0 .. $#bodylines) { + if ($bodylines[$findsig] =~ /^-----BEGIN PGP SIGNATURE/) { + $#bodylines = $findsig - 1; + last; + } + } + map { s/^- // } @bodylines; + } + + return { header => [@headerlines], body => [@bodylines]}; +} + +=head2 create_mime_message + + create_mime_message([To=>'don@debian.org'],$body,[$attach1, $attach2],$include_date); + +Creates a MIME encoded message with headers given by the first +argument, and a message given by the second. + +Optional attachments can be specified in the third arrayref argument. + +Whether to include the date in the header is the final argument; it +defaults to true, setting the Date header if one is not already +present. + +Headers are passed directly to MIME::Entity::build, the message is the +first attachment. + +Each of the elements of the attachment arrayref is attached as an +rfc822 message if it is a scalar or an arrayref; otherwise if it is a +hashref, the contents are passed as an argument to +MIME::Entity::attach + +=cut + +sub create_mime_message{ + my ($headers,$body,$attachments,$include_date) = @_; + $attachments = [] if not defined $attachments; + $include_date = 1 if not defined $include_date; + + die "The first argument to create_mime_message must be an arrayref" unless ref($headers) eq 'ARRAY'; + die "The third argument to create_mime_message must be an arrayref" unless ref($attachments) eq 'ARRAY'; + + if ($include_date) { + my %headers = apply {defined $_ ? lc($_) : ''} @{$headers}; + if (not exists $headers{date}) { + push @{$headers}, + ('Date', + strftime("%a, %d %b %Y %H:%M:%S +0000",gmtime) + ); + } + } + + # Build the message + # MIME::Entity is stupid, and doesn't rfc1522 encode its headers, so we do it for it. + my $msg = MIME::Entity->build('Content-Type' => 'text/plain; charset=utf-8', + 'Encoding' => 'quoted-printable', + (map{encode_rfc1522(encode_utf8(defined $_ ? $_:''))} @{$headers}), + Data => encode_utf8($body), + ); + + # Attach the attachments + for my $attachment (@{$attachments}) { + if (ref($attachment) eq 'HASH') { + $msg->attach(%{$attachment}); + } + else { + # This is *craptacular*, but because various MTAs + # (sendmail and exim4, at least) appear to eat From + # lines in message/rfc822 attachments, we need eat + # the entire From line ourselves so the MTA doesn't + # leave \n detrius around. + if (ref($attachment) eq 'ARRAY' and $attachment->[1] =~ /^From /) { + # make a copy so that we don't screw up anything + # that is expecting this arrayref to stay constant + $attachment = [@{$attachment}]; + # remove the from line + splice @$attachment, 1, 1; + } + elsif (not ref($attachment)) { + # It's a scalar; remove the from line + $attachment =~ s/^(Received:[^\n]+\n)(From [^\n]+\n)/$1/s; + } + $msg->attach(Type => 'message/rfc822', + Data => $attachment, + Encoding => '7bit', + ); + } + } + return $msg->as_string; +} + + + + +=head2 decode_rfc1522 + + decode_rfc1522('=?iso-8859-1?Q?D=F6n_Armstr=F3ng?= ') + +Turn RFC-1522 names into the UTF-8 equivalent. + +=cut + +sub decode_rfc1522 { + my ($string) = @_; + + # this is craptacular, but leading space is hacked off by unmime. + # Save it. + my $leading_space = ''; + $leading_space = $1 if $string =~ s/^(\ +)//; + # we must do this to switch off the utf8 flag before calling decode_mimewords + $string = encode_utf8($string); + my @mime_words = MIME::Words::decode_mimewords($string); + my $tmp = $leading_space . + join('', + (map { + if (@{$_} > 1) { + convert_to_utf8(${$_}[0],${$_}[1]); + } else { + decode_utf8(${$_}[0]); + } + } @mime_words) + ); + return $tmp; +} + +=head2 encode_rfc1522 + + encode_rfc1522('Dön Armströng ') + +Encodes headers according to the RFC1522 standard by calling +MIME::Words::encode_mimeword on distinct words as appropriate. + +=cut + +# We cannot use MIME::Words::encode_mimewords because that function +# does not handle spaces properly at all. + +sub encode_rfc1522 { + my ($rawstr) = @_; + + # handle being passed undef properly + return undef if not defined $rawstr; + + # convert to octets if we are given a string in perl's internal + # encoding + $rawstr= encode_utf8($rawstr) if is_utf8($rawstr); + # We process words in reverse so we can preserve spacing between + # encoded words. This regex splits on word|nonword boundaries and + # nonword|nonword boundaries. We also consider parenthesis and " + # to be nonwords to avoid escaping them in comments in violation + # of RFC1522 + my @words = reverse split /(?:(?<=[\s\n\)\(\"])|(?=[\s\n\)\(\"]))/m, $rawstr; + + my $previous_word_encoded = 0; + my $string = ''; + for my $word (@words) { + if ($word !~ m#[\x00-\x1F\x7F-\xFF]#o and $word ne ' ') { + $string = $word.$string; + $previous_word_encoded=0; + } + elsif ($word =~ /^[\s\n]$/) { + $string = $word.$string; + $previous_word_encoded = 0 if $word eq "\n"; + } + else { + my $encoded = MIME::Words::encode_mimeword($word, 'q', 'UTF-8'); + # RFC 1522 mandates that segments be at most 76 characters + # long. If that's the case, we split the word up into 10 + # character pieces and encode it. We must use the Encode + # magic here to avoid breaking on bit boundaries here. + if (length $encoded > 75) { + # Turn utf8 into the internal perl representation + # so . is a character, not a byte. + my $tempstr = is_utf8($word)?$word:decode_utf8($word,Encode::FB_DEFAULT); + my @encoded; + # Strip it into 10 character long segments, and encode + # the segments + # XXX It's possible that these segments are > 76 characters + while ($tempstr =~ s/(.{1,10})$//) { + # turn the character back into the utf8 representation. + my $tempword = encode_utf8($1); + # It may actually be better to eventually use + # the base64 encoding here, but I'm not sure + # if that's as widely supported as quoted + # printable. + unshift @encoded, MIME::Words::encode_mimeword($tempword,'q','UTF-8'); + } + $encoded = join(" ",@encoded); + # If the previous word was encoded, we must + # include a trailing _ that gets encoded as a + # space. + $encoded =~ s/\?\=$/_\?\=/ if $previous_word_encoded; + $string = $encoded.$string; + } + else { + # If the previous word was encoded, we must + # include a trailing _ that gets encoded as a + # space. + $encoded =~ s/\?\=$/_\?\=/ if $previous_word_encoded; + $string = $encoded.$string; + } + $previous_word_encoded = 1; + } + } + return $string; +} + +1; diff --git a/lib/Debbugs/Mail.pm b/lib/Debbugs/Mail.pm new file mode 100644 index 0000000..e4c8bf7 --- /dev/null +++ b/lib/Debbugs/Mail.pm @@ -0,0 +1,552 @@ +# 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 2004-7 by Don Armstrong . + +package Debbugs::Mail; + +=head1 NAME + +Debbugs::Mail -- Outgoing Mail Handling + +=head1 SYNOPSIS + +use Debbugs::Mail qw(send_mail_message get_addresses); + +my @addresses = get_addresses('blah blah blah foo@bar.com') +send_mail_message(message => <[@addresses]); +To: $addresses[0] +Subject: Testing + +Testing 1 2 3 +END + +=head1 EXPORT TAGS + +=over + +=item :all -- all functions that can be exported + +=back + +=head1 FUNCTIONS + + +=cut + +use warnings; +use strict; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use Exporter qw(import); + +use IPC::Open3; +use POSIX qw(:sys_wait_h strftime); +use Time::HiRes qw(usleep gettimeofday); +use Mail::Address (); +use Debbugs::MIME qw(encode_rfc1522); +use Debbugs::Config qw(:config); +use Params::Validate qw(:types validate_with); +use Encode qw(encode is_utf8); +use Debbugs::UTF8 qw(encode_utf8_safely convert_to_utf8); + +use Debbugs::Packages; + +BEGIN{ + ($VERSION) = q$Revision: 1.1 $ =~ /^Revision:\s+([^\s+])/; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (addresses => [qw(get_addresses)], + misc => [qw(rfc822_date)], + mail => [qw(send_mail_message encode_headers default_headers)], + reply => [qw(reply_headers)], + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + +# We set this here so it can be overridden for testing purposes +our $SENDMAIL = $config{sendmail}; + +=head2 get_addresses + + my @addresses = get_addresses('don@debian.org blars@debian.org + kamion@debian.org ajt@debian.org'); + +Given a string containing some e-mail addresses, parses the string +using Mail::Address->parse and returns a list of the addresses. + +=cut + +sub get_addresses { + return map { $_->address() } map { Mail::Address->parse($_) } @_; +} + + +=head2 default_headers + + my @head = default_headers(queue_file => 'foo', + data => $data, + msgid => $header{'message-id'}, + msgtype => 'error', + headers => [...], + ); + create_mime_message(\@headers, + ... + ); + +This function is generally called to generate the headers for +create_mime_message (and anything else that needs a set of default +headers.) + +In list context, returns an array of headers. In scalar context, +returns headers for shoving in a mail message after encoding using +encode_headers. + +=head3 options + +=over + +=item queue_file -- the queue file which will generate this set of +headers (refered to as $nn in lots of the code) + +=item data -- the data of the bug which this message involves; can be +undefined if there is no bug involved. + +=item msgid -- the Message-ID: of the message which will generate this +set of headers + +=item msgtype -- the type of message that this is. + +=item pr_msg -- the pr message field + +=item headers -- a set of headers which will override the default +headers; these headers will be passed through (and may be reordered.) +If a particular header is undef, it overrides the default, but isn't +passed through. + +=back + +=head3 default headers + +=over + +=item X-Loop -- set to the maintainer e-mail + +=item From -- set to the maintainer e-mail + +=item To -- set to Unknown recipients + +=item Subject -- set to Unknown subject + +=item Message-ID -- set appropriately (see code) + +=item Precedence -- set to bulk + +=item References -- set to the full set of message ids that are known +(from data and the msgid option) + +=item In-Reply-To -- set to msg id or the msgid from data + +=item X-Project-PR-Message -- set to pr_msg with the bug number appended + +=item X-Project-PR-Package -- set to the package of the bug + +=item X-Project-PR-Keywords -- set to the keywords of the bug + +=item X-Project-PR-Source -- set to the source of the bug + +=back + +=cut + +sub default_headers { + my %param = validate_with(params => \@_, + spec => {queue_file => {type => SCALAR|UNDEF, + optional => 1, + }, + data => {type => HASHREF, + optional => 1, + }, + msgid => {type => SCALAR|UNDEF, + optional => 1, + }, + msgtype => {type => SCALAR|UNDEF, + default => 'misc', + }, + pr_msg => {type => SCALAR|UNDEF, + default => 'misc', + }, + headers => {type => ARRAYREF, + default => [], + }, + }, + ); + my @header_order = (qw(X-Loop From To subject), + qw(Message-ID In-Reply-To References)); + # handle various things being undefined + if (not exists $param{queue_file} or + not defined $param{queue_file}) { + $param{queue_file} = join('',gettimeofday()) + } + for (qw(msgtype pr_msg)) { + if (not exists $param{$_} or + not defined $param{$_}) { + $param{$_} = 'misc'; + } + } + my %header_order; + @header_order{map {lc $_} @header_order} = 0..$#header_order; + my %set_headers; + my @ordered_headers; + my @temp = @{$param{headers}}; + my @other_headers; + while (my ($header,$value) = splice @temp,0,2) { + if (exists $header_order{lc($header)}) { + push @{$ordered_headers[$header_order{lc($header)}]}, + ($header,$value); + } + else { + push @other_headers,($header,$value); + } + $set_headers{lc($header)} = 1; + } + + # calculate our headers + my $bug_num = exists $param{data} ? $param{data}{bug_num} : 'x'; + my $nn = $param{queue_file}; + # handle the user giving the actual queue filename instead of nn + $nn =~ s/^[a-zA-Z]([a-zA-Z])/$1/; + $nn = lc($nn); + my @msgids; + if (exists $param{msgid} and defined $param{msgid}) { + push @msgids, $param{msgid} + } + elsif (exists $param{data} and defined $param{data}{msgid}) { + push @msgids, $param{data}{msgid} + } + my %default_header; + $default_header{'X-Loop'} = $config{maintainer_email}; + $default_header{From} = "$config{maintainer_email} ($config{project} $config{ubug} Tracking System)"; + $default_header{To} = "Unknown recipients"; + $default_header{Subject} = "Unknown subject"; + $default_header{'Message-ID'} = ""; + if (@msgids) { + $default_header{'In-Reply-To'} = $msgids[0]; + $default_header{'References'} = join(' ',@msgids); + } + $default_header{Precedence} = 'bulk'; + $default_header{"X-$config{project}-PR-Message"} = $param{pr_msg} . (exists $param{data} ? ' '.$param{data}{bug_num}:''); + $default_header{Date} = rfc822_date(); + if (exists $param{data}) { + if (defined $param{data}{keywords}) { + $default_header{"X-$config{project}-PR-Keywords"} = $param{data}{keywords}; + } + if (defined $param{data}{package}) { + $default_header{"X-$config{project}-PR-Package"} = $param{data}{package}; + if ($param{data}{package} =~ /^src:(.+)$/) { + $default_header{"X-$config{project}-PR-Source"} = $1; + } + else { + my $pkg_src = Debbugs::Packages::getpkgsrc(); + $default_header{"X-$config{project}-PR-Source"} = $pkg_src->{$param{data}{package}}; + } + } + } + for my $header (sort keys %default_header) { + next if $set_headers{lc($header)}; + if (exists $header_order{lc($header)}) { + push @{$ordered_headers[$header_order{lc($header)}]}, + ($header,$default_header{$header}); + } + else { + push @other_headers,($header,$default_header{$header}); + } + } + my @headers; + for my $hdr1 (@ordered_headers) { + next if not defined $hdr1; + my @temp = @{$hdr1}; + while (my ($header,$value) = splice @temp,0,2) { + next if not defined $value; + push @headers,($header,$value); + } + } + push @headers,@other_headers; + if (wantarray) { + return @headers; + } + else { + my $headers = ''; + while (my ($header,$value) = splice @headers,0,2) { + $headers .= "${header}: $value\n"; + } + return $headers; + } +} + + + +=head2 send_mail_message + + send_mail_message(message => $message, + recipients => [@recipients], + envelope_from => 'don@debian.org', + ); + + +=over + +=item message -- message to send out + +=item recipients -- recipients to send the message to. If undefed or +an empty arrayref, will use '-t' to parse the message for recipients. + +=item envelope_from -- envelope_from for outgoing messages + +=item encode_headers -- encode headers using RFC1522 (default) + +=item parse_for_recipients -- use -t to parse the message for +recipients in addition to those specified. [Can be used to set Bcc +recipients, for example.] + +=back + +Returns true on success, false on failures. All errors are indicated +using warn. + +=cut + +sub send_mail_message{ + my %param = validate_with(params => \@_, + spec => {sendmail_arguments => {type => ARRAYREF, + default => $config{sendmail_arguments}, + }, + parse_for_recipients => {type => BOOLEAN, + default => 0, + }, + encode_headers => {type => BOOLEAN, + default => 1, + }, + message => {type => SCALAR, + }, + envelope_from => {type => SCALAR, + default => $config{envelope_from}, + }, + recipients => {type => ARRAYREF|UNDEF, + optional => 1, + }, + }, + ); + my @sendmail_arguments = @{$param{sendmail_arguments}}; + push @sendmail_arguments, '-f', $param{envelope_from} if + exists $param{envelope_from} and + defined $param{envelope_from} and + length $param{envelope_from}; + + my @recipients; + @recipients = @{$param{recipients}} if defined $param{recipients} and + ref($param{recipients}) eq 'ARRAY'; + my %recipients; + @recipients{@recipients} = (1) x @recipients; + @recipients = keys %recipients; + # If there are no recipients, use -t to parse the message + if (@recipients == 0) { + $param{parse_for_recipients} = 1 unless exists $param{parse_for_recipients}; + } + # Encode headers if necessary + $param{encode_headers} = 1 if not exists $param{encode_headers}; + if ($param{encode_headers}) { + $param{message} = encode_headers($param{message}); + } + + # First, try to send the message as is. + eval { + _send_message($param{message}, + @sendmail_arguments, + $param{parse_for_recipients}?q(-t):(), + @recipients); + }; + return 1 unless $@; + # If there's only one recipient, there's nothing more we can do, + # so bail out. + warn $@ and return 0 if $@ and @recipients == 0; + # If that fails, try to send the message to each of the + # recipients separately. We also send the -t option separately in + # case one of the @recipients is ok, but the addresses in the + # mail message itself are malformed. + my @errors; + for my $recipient ($param{parse_for_recipients}?q(-t):(),@recipients) { + eval { + _send_message($param{message},@sendmail_arguments,$recipient); + }; + push @errors, "Sending to $recipient failed with $@" if $@; + } + # If it still fails, complain bitterly but don't die. + warn join(qq(\n),@errors) and return 0 if @errors; + return 1; +} + +=head2 encode_headers + + $message = encode_heeaders($message); + +RFC 1522 encodes the headers of a message + +=cut + +sub encode_headers{ + my ($message) = @_; + + my ($header,$body) = split /\n\n/, $message, 2; + $header = encode_rfc1522($header); + return $header . qq(\n\n). encode_utf8_safely($body); +} + +=head2 rfc822_date + + rfc822_date + +Return the current date in RFC822 format in the UTC timezone + +=cut + +sub rfc822_date{ + return scalar strftime "%a, %d %h %Y %T +0000", gmtime; +} + +=head2 reply_headers + + reply_headers(MIME::Parser->new()->parse_data(\$data)); + +Generates suggested headers and a body for replies. Primarily useful +for use in RFC2368 mailto: entries. + +=cut + +sub reply_headers{ + my ($entity) = @_; + + my $head = $entity->head; + # build reply link + my %r_l; + $r_l{subject} = $head->get('Subject'); + $r_l{subject} //= 'Your mail'; + $r_l{subject} = 'Re: '. $r_l{subject} unless $r_l{subject} =~ /(?:^|\s)Re:\s+/; + $r_l{subject} =~ s/(?:^\s*|\s*$)//g; + $r_l{'In-Reply-To'} = $head->get('Message-Id'); + $r_l{'In-Reply-To'} =~ s/(?:^\s*|\s*$)//g if defined $r_l{'In-Reply-To'}; + delete $r_l{'In-Reply-To'} unless defined $r_l{'In-Reply-To'}; + $r_l{References} = ($head->get('References')//''). ' '.($head->get('Message-Id')//''); + $r_l{References} =~ s/(?:^\s*|\s*$)//g; + my $date = $head->get('Date') // 'some date'; + $date =~ s/(?:^\s*|\s*$)//g; + my $who = $head->get('From') // $head->get('Reply-To') // 'someone'; + $who =~ s/(?:^\s*|\s*$)//g; + + my $body = "On $date $who wrote:\n"; + my $i = 60; + my $b_h; + # Default to UTF-8. + my $charset="utf-8"; + ## find the first part which has a defined body handle and appears + ## to be text + if (defined $entity->bodyhandle) { + my $this_charset = + $entity->head->mime_attr("content-type.charset"); + $charset = $this_charset if + defined $this_charset and + length $this_charset; + $b_h = $entity->bodyhandle; + } elsif ($entity->parts) { + my @parts = $entity->parts; + while (defined(my $part = shift @parts)) { + if ($part->parts) { + push @parts,$part->parts; + } + if (defined $part->bodyhandle and + $part->effective_type =~ /text/) { + my $this_charset = + $part->head->mime_attr("content-type.charset"); + $charset = $this_charset if + defined $this_charset and + length $this_charset; + $b_h = $part->bodyhandle; + last; + } + } + } + if (defined $b_h) { + eval { + my $IO = $b_h->open("r"); + while (defined($_ = $IO->getline)) { + $i--; + last if $i < 0; + $body .= '> '. convert_to_utf8($_,$charset); + } + $IO->close(); + }; + } + $r_l{body} = $body; + return \%r_l; +} + +=head1 PRIVATE FUNCTIONS + +=head2 _send_message + + _send_message($message,@sendmail_args); + +Private function that actually calls sendmail with @sendmail_args and +sends message $message. + +dies with errors, so calls to this function in send_mail_message +should be wrapped in eval. + +=cut + +sub _send_message{ + my ($message,@sendmail_args) = @_; + + my ($wfh,$rfh); + my $pid = open3($wfh,$rfh,$rfh,$SENDMAIL,@sendmail_args) + or die "Unable to fork off $SENDMAIL: $!"; + local $SIG{PIPE} = 'IGNORE'; + eval { + print {$wfh} $message or die "Unable to write to $SENDMAIL: $!"; + close $wfh or die "$SENDMAIL exited with $?"; + }; + if ($@) { + local $\; + # Reap the zombie + waitpid($pid,WNOHANG); + # This shouldn't block because the pipe closing is the only + # way this should be triggered. + my $message = <$rfh>; + die "$@$message"; + } + # Wait for sendmail to exit for at most 30 seconds. + my $loop = 0; + while (waitpid($pid, WNOHANG) == 0 or $loop++ >= 600){ + # sleep for a 20th of a second + usleep(50_000); + } + if ($loop >= 600) { + warn "$SENDMAIL didn't exit within 30 seconds"; + } +} + + +1; + + +__END__ + + + + + + diff --git a/lib/Debbugs/OOBase.pm b/lib/Debbugs/OOBase.pm new file mode 100644 index 0000000..6600e02 --- /dev/null +++ b/lib/Debbugs/OOBase.pm @@ -0,0 +1,48 @@ +# 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', + ); + +sub schema_argument { + my $self = shift; + if ($self->has_schema) { + return (schema => $self->schema); + } else { + return (); + } +} + +__PACKAGE__->meta->make_immutable; + +1; + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/lib/Debbugs/OOTypes.pm b/lib/Debbugs/OOTypes.pm new file mode 100644 index 0000000..37473d0 --- /dev/null +++ b/lib/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/lib/Debbugs/Package.pm b/lib/Debbugs/Package.pm new file mode 100644 index 0000000..70f0e35 --- /dev/null +++ b/lib/Debbugs/Package.pm @@ -0,0 +1,729 @@ +# 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 Mouse; +use strictures 2; +use v5.10; # for state +use namespace::autoclean; + +use List::AllUtils qw(uniq pairmap); +use Debbugs::Config qw(:config); +use Debbugs::Version::Source; +use Debbugs::Version::Binary; + +extends 'Debbugs::OOBase'; + +=head2 name + +Name of the Package + +=head2 qualified_name + +name if binary, name prefixed with C if source + +=cut + +has name => (is => 'ro', isa => 'Str', + required => 1, + ); + +sub qualified_name { + my $self = shift; + return + # src: if source, nothing if binary + ($self->_type eq 'source' ? 'src:':'') . + $self->name; +} + + +=head2 type + +Type of the package; either C or C + +=cut + +has type => (is => 'bare', isa => 'Str', + lazy => 1, + builder => '_build_type', + clearer => '_clear_type', + reader => '_type', + writer => '_set_type', + ); + +sub _build_type { + my $self = shift; + if ($self->name !~ /^src:/) { + return 'binary'; + } +} + +=head2 url + +url to the package + +=cut + +sub url { + my $self = shift; + return $config{web_domain}.'/'.$self->qualified_name; +} + +around BUILDARGS => sub { + my $orig = shift; + my $class = shift; + my %args; + if (@_==1 and ref($_[0]) eq 'HASH') { + %args = %{$_[0]}; + } else { + %args = @_; + } + $args{name} //= '(unknown)'; + if ($args{name} =~ /src:(.+)/) { + $args{name} = $1; + $args{type} = 'source'; + } else { + $args{type} = 'binary' unless + defined $args{type}; + } + return $class->$orig(%args); +}; + +=head2 is_source + +true if the package is a source package + +=head2 is_binary + +true if the package is a binary package + +=cut + +sub is_source { + return $_[0]->_type eq 'source' +} + +sub is_binary { + return $_[0]->_type eq 'binary' +} + +=head2 valid -- true if the package has any valid versions + +=cut + +has valid => (is => 'ro', isa => 'Bool', + lazy => 1, + builder => '_build_valid', + writer => '_set_valid', + ); + +sub _build_valid { + my $self = shift; + if ($self->valid_version_info_count> 0) { + return 1; + } + return 0; +} + +# this contains source name, source version, binary name, binary version, arch, +# and dist which have been selected from the database. It is used to build +# versions and anything else which are known as required. +has 'valid_version_info' => + (is => 'bare', isa => 'ArrayRef', + traits => ['Array'], + lazy => 1, + builder => '_build_valid_version_info', + predicate => '_has_valid_version_info', + clearer => '_clear_valid_version_info', + handles => {'_get_valid_version_info' => 'get', + 'valid_version_info_grep' => 'grep', + '_valid_version_info' => 'elements', + 'valid_version_info_count' => 'count', + }, + ); + +sub _build_valid_version_info { + my $self = shift; + my $pkgs = $self->_get_valid_version_info_from_db; + for my $invalid_version (@{$pkgs->{$self->qualified_name}->{invalid_versions}}) { + $self->_mark_invalid_version($invalid_version,1); + } + return $pkgs->{$self->qualified_name}->{valid_version_info} // []; +} + +state $common_dists = [@{$config{distributions}}]; +sub _get_valid_version_info_from_db { + my $self; + if ((@_ % 2) == 1 and + blessed($_[0])) { + $self = shift; + } + my %args = @_; + my @packages; + my $s; # schema + if (defined $self) { + if ($self->has_schema) { + $s = $self->schema; + } else { + $s = $args{schema}; + } + @packages = $self->qualified_name; + } else { + $s = $args{schema}; + @packages = @{$args{packages}}; + } + if (not defined $s) { + confess("get_info_from_db not implemented without schema"); + } + my %src_packages; + my %src_ver_packages; + my %bin_packages; + my %bin_ver_packages; + # split packages into src/ver, bin/ver, src, and bin so we can select them + # from the database + local $_; + for my $pkg (@packages) { + if (ref($pkg)) { + if ($pkg->[0] =~ /^src:(.+)$/) { + for my $ver (@{$pkg}[1..$#{$pkg}]) { + $src_ver_packages{$1}{$ver} = 0; + } + } else { + for my $ver (@{$pkg}[1..$#{$pkg}]) { + $bin_ver_packages{$pkg->[0]}{$ver} = 0; + } + } + } elsif ($pkg =~ /^src:(.+)$/) { + $src_packages{$1} = 0; + } else { + $bin_packages{$pkg} = 0; + } + } + # calculate searches for packages where we want specific versions. We + # calculate this here so add_result_to_package can stomp over + # %src_ver_packages and %bin_ver_packages + my @src_ver_search; + for my $sp (keys %src_ver_packages) { + push @src_ver_search, + (-and => {'src_pkg.pkg' => $sp, + 'me.ver' => [keys %{$src_ver_packages{$sp}}], + }, + ); + } + my @src_packages = keys %src_packages; + + my @bin_ver_search; + for my $sp (keys %bin_ver_packages) { + push @bin_ver_search, + (-and => {'bin_pkg.pkg' => $sp, + 'me.ver' => [keys %{$bin_ver_packages{$sp}}], + }, + ); + } + my @bin_packages = keys %bin_packages; + my $packages = {}; + sub _default_pkg_info { + return {name => $_[0], + type => $_[1]//'source', + valid => $_[2]//1, + valid_version_info => [], + invalid_versions => {}, + }; + } + sub add_result_to_package { + my ($pkgs,$rs,$svp,$bvp,$sp,$bp) = @_; + while (my $pkg = $rs->next) { + my $n = 'src:'.$pkg->{src_pkg}; + if (not exists $pkgs->{$n}) { + $pkgs->{$n} = + _default_pkg_info($pkg->{src_pkg}); + } + push @{$pkgs->{$n}{valid_version_info}}, + {%$pkg}; + $n = $pkg->{bin_pkg}; + if (not exists $pkgs->{$n}) { + $pkgs->{$n} = + _default_pkg_info($pkg->{bin_pkg},'binary'); + } + push @{$pkgs->{$n}{valid_version_info}}, + {%$pkg}; + # this is a package with a valid src_ver + $svp->{$pkg->{src_pkg}}{$pkg->{src_ver}}++; + $sp->{$pkg->{src_pkg}}++; + # this is a package with a valid bin_ver + $bvp->{$pkg->{bin_pkg}}{$pkg->{bin_ver}}++; + $bp->{$pkg->{bin_pkg}}++; + } + } + if (@src_packages) { + my $src_rs = $s->resultset('SrcVer')-> + search({-or => [-and => {'src_pkg.pkg' => [@src_packages], + -or => {'suite.codename' => $common_dists, + 'suite.suite_name' => $common_dists, + }, + }, + @src_ver_search, + ], + }, + {join => ['src_pkg', + { + 'src_associations' => 'suite'}, + { + 'bin_vers' => ['bin_pkg','arch']}, + 'maintainer', + ], + 'select' => [qw(src_pkg.pkg), + qw(suite.codename), + qw(suite.suite_name), + qw(src_associations.modified), + qw(me.ver), + q(CONCAT(src_pkg.pkg,'/',me.ver)), + qw(bin_vers.ver bin_pkg.pkg arch.arch), + qw(maintainer.name), + ], + 'as' => [qw(src_pkg codename suite_name), + qw(modified_time src_ver src_pkg_ver), + qw(bin_ver bin_pkg arch maintainer), + ], + result_class => 'DBIx::Class::ResultClass::HashRefInflator', + }, + ); + add_result_to_package($packages,$src_rs, + \%src_ver_packages, + \%bin_ver_packages, + \%src_packages, + \%bin_packages, + ); + } + if (@bin_packages) { + my $bin_assoc_rs = + $s->resultset('BinAssociation')-> + search({-and => {'bin_pkg.pkg' => [@bin_packages], + -or => {'suite.codename' => $common_dists, + 'suite.suite_name' => $common_dists, + }, + }}, + {join => [{'bin' => + [{'src_ver' => ['src_pkg', + 'maintainer', + ]}, + 'bin_pkg', + 'arch']}, + 'suite', + ], + 'select' => [qw(src_pkg.pkg), + qw(suite.codename), + qw(suite.suite_name), + qw(me.modified), + qw(src_ver.ver), + q(CONCAT(src_pkg.pkg,'/',src_ver.ver)), + qw(bin.ver bin_pkg.pkg arch.arch), + qw(maintainer.name), + ], + 'as' => [qw(src_pkg codename suite_name), + qw(modified_time src_ver src_pkg_ver), + qw(bin_ver bin_pkg arch maintainer), + ], + result_class => 'DBIx::Class::ResultClass::HashRefInflator', + }, + ); + add_result_to_package($packages,$bin_assoc_rs, + \%src_ver_packages, + \%bin_ver_packages, + \%src_packages, + \%bin_packages, + ); + } + if (@bin_ver_search) { + my $bin_rs = $s->resultset('BinVer')-> + search({-or => [@bin_ver_search, + ], + }, + {join => ['bin_pkg', + { + 'bin_associations' => 'suite'}, + {'src_ver' => ['src_pkg', + 'maintainer', + ]}, + 'arch', + ], + 'select' => [qw(src_pkg.pkg), + qw(suite.codename), + qw(suite.suite_name), + qw(bin_associations.modified), + qw(src_ver.ver), + q(CONCAT(src_pkg.pkg,'/',src_ver.ver)), + qw(me.ver bin_pkg.pkg arch.arch), + qw(maintainer.name), + ], + 'as' => [qw(src_pkg codename suite_name), + qw(modified_time src_ver src_pkg_ver), + qw(bin_ver bin_pkg arch maintainer), + ], + result_class => 'DBIx::Class::ResultClass::HashRefInflator', + }, + ); + add_result_to_package($packages,$bin_rs, + \%src_ver_packages, + \%bin_ver_packages, + \%src_packages, + \%bin_packages, + ); + } + for my $sp (keys %src_ver_packages) { + if (not exists $packages->{'src:'.$sp}) { + $packages->{'src:'.$sp} = + _default_pkg_info($sp,'source',0); + } + for my $sv (keys %{$src_ver_packages{$sp}}) { + next if $src_ver_packages{$sp}{$sv} > 0; + $packages->{'src:'.$sp}{invalid_versions}{$sv} = 1; + } + } + for my $bp (keys %bin_ver_packages) { + if (not exists $packages->{$bp}) { + $packages->{$bp} = + _default_pkg_info($bp,'binary',0); + } + for my $bv (keys %{$bin_ver_packages{$bp}}) { + next if $bin_ver_packages{$bp}{$bv} > 0; + $packages->{$bp}{invalid_versions}{$bv} = 1; + } + } + for my $sp (keys %src_packages) { + next if $src_packages{$sp} > 0; + $packages->{'src:'.$sp} = + _default_pkg_info($sp,'source',0); + } + for my $bp (keys %bin_packages) { + next if $bin_packages{$bp} > 0; + $packages->{$bp} = + _default_pkg_info($bp,'binary',0); + } + return $packages; +} + +has 'source_version_to_info' => + (is => 'bare', isa => 'HashRef', + traits => ['Hash'], + lazy => 1, + builder => '_build_source_version_to_info', + handles => {_get_source_version_to_info => 'get', + }, + ); + +sub _build_source_version_to_info { + my $self = shift; + my $info = {}; + my $i = 0; + for my $v ($self->_valid_version_info) { + push @{$info->{$v->{src_ver}}}, $i; + $i++; + } + return $info; +} + +has 'binary_version_to_info' => + (is => 'bare', isa => 'HashRef', + traits => ['Hash'], + lazy => 1, + builder => '_build_binary_version_to_info', + handles => {_get_binary_version_to_info => 'get', + }, + ); + +sub _build_binary_version_to_info { + my $self = shift; + my $info = {}; + my $i = 0; + for my $v ($self->_valid_version_info) { + push @{$info->{$v->{bin_ver}}}, $i; + $i++; + } + return $info; +} + +has 'dist_to_info' => + (is => 'bare', isa => 'HashRef', + traits => ['Hash'], + lazy => 1, + builder => '_build_dist_to_info', + handles => {_get_dist_to_info => 'get', + }, + ); +sub _build_dist_to_info { + my $self = shift; + my $info = {}; + my $i = 0; + for my $v ($self->_valid_version_info) { + next unless defined $v->{suite_name} and length($v->{suite_name}); + push @{$info->{$v->{suite_name}}}, $i; + $i++; + } + return $info; +} + +# this is a hashref of versions that we know are invalid +has 'invalid_versions' => + (is => 'bare',isa => 'HashRef[Bool]', + lazy => 1, + default => sub {{}}, + clearer => '_clear_invalid_versions', + traits => ['Hash'], + handles => {_invalid_version => 'exists', + _mark_invalid_version => 'set', + }, + ); + +has 'binaries' => (is => 'ro', + isa => 'Debbugs::Collection::Package', + lazy => 1, + builder => '_build_binaries', + predicate => '_has_binaries', + ); + +sub _build_binaries { + my $self = shift; + if ($self->is_binary) { + return $self->package_collection->limit($self->name); + } + # OK, walk through the valid_versions for this package + my @binaries = + uniq map {$_->{bin_pkg}} $self->_valid_version_info; + return $self->package_collection->limit(@binaries); +} + +has 'sources' => (is => 'ro', + isa => 'Debbugs::Collection::Package', + lazy => 1, + builder => '_build_sources', + predicate => '_has_sources', + ); + +sub _build_sources { + my $self = shift; + return $self->package_collection->limit($self->source_names); +} + +sub source_names { + my $self = shift; + + if ($self->is_source) { + return $self->name + } + return uniq map {'src:'.$_->{src_pkg}} $self->_valid_version_info; +} + +=head2 maintainers + +L of the maintainer(s) of the current package + +=cut + +has maintainers => (is => 'ro', + isa => 'Debbugs::Collection::Correspondent', + lazy => 1, + builder => '_build_maintainers', + predicate => '_has_maintainers', + ); + +sub _build_maintainers { + my $self = shift; + my @maintainers; + for my $v ($self->_valid_version_info) { + next unless length($v->{suite_name}) and length($v->{maintainer}); + push @maintainers,$v->{maintainer}; + } + @maintainers = + uniq @maintainers; + return $self->correspondent_collection->limit(@maintainers); +} + +has 'versions' => (is => 'bare', + isa => 'HashRef[Debbugs::Version]', + traits => ['Hash'], + handles => {_exists_version => 'exists', + _get_version => 'get', + _set_version => 'set', + }, + lazy => 1, + builder => '_build_versions', + ); + +sub _build_versions { + my $self = shift; + return {}; +} + +sub _add_version { + my $self = shift; + my @set; + for my $v (@_) { + push @set, + $v->version,$v; + } + $self->_set_version(@set); +} + +sub get_source_version_distribution { + my $self = shift; + + my %src_pkg_vers = @_; + for my $dist (@_) { + my @ver_loc = + grep {defined $_} + $self->_get_dist_to_info($dist); + for my $v ($self-> + _get_valid_version_info(@ver_loc)) { + $src_pkg_vers{$v->{src_pkg_ver}} = 1; + } + } + return $self->package_collection-> + get_source_versions(keys %src_pkg_vers)->members; +} + +# returns the source version(s) corresponding to the version of *this* package; the +# version passed may be binary or source, depending. +sub get_source_version { + my $self = shift; + if ($self->is_source) { + return $self->get_version(@_); + } + my %src_pkg_vers; + for my $ver (@_) { + my %archs; + if (ref $ver) { + my @archs; + ($ver,@archs) = @{$ver}; + @archs{@archs} = (1) x @archs; + } + my @ver_loc = + @{$self->_get_binary_version_to_info($ver)//[]}; + next unless @ver_loc; + my @vers = map {$self-> + _get_valid_version_info($_)} + @ver_loc; + for my $v (@vers) { + if (keys %archs) { + next unless exists $archs{$v->{arch}}; + } + $src_pkg_vers{$v->{src_pkg_ver}} = 1; + } + } + return $self->package_collection-> + get_source_versions(keys %src_pkg_vers)->members; +} + +sub get_version { + my $self = shift; + my @ret; + for my $v (@_) { + if ($self->_exists_version($v)) { + push @ret,$self->_get_version($v); + } else { + push @ret, + $self->_create_version($v); + } + } + return @ret; +} + +sub _create_version { + my $self = shift; + my @versions; + if ($self->is_source) { + for my $v (@_) { + push @versions, + $v, + Debbugs::Version::Source-> + new(pkg => $self, + version => $v, + package_collection => $self->package_collection, + $self->schema_argument, + ); + } + } else { + for my $v (@_) { + push @versions, + $v, + Debbugs::Version::Binary-> + new(pkg => $self, + version => $v, + package_collection => $self->package_collection, + $self->schema_argument, + ); + } + } + $self->_set_version(@versions); +} + +=head2 package_collection + +L to get additional packages required + +=cut + +# gets used to retrieve packages +has 'package_collection' => (is => 'ro', + isa => 'Debbugs::Collection::Package', + builder => '_build_package_collection', + lazy => 1, + ); + +sub _build_package_collection { + my $self = shift; + return Debbugs::Collection::Package->new($self->schema_argument) +} + +=head2 correspondent_collection + +L to get additional maintainers required + +=cut + +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) +} + +sub CARP_TRACE { + my $self = shift; + return 'Debbugs::Package={package='.$self->qualified_name.'}'; +} + +__PACKAGE__->meta->make_immutable; +no Mouse; + +1; + + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/lib/Debbugs/Packages.pm b/lib/Debbugs/Packages.pm new file mode 100644 index 0000000..b30cfc7 --- /dev/null +++ b/lib/Debbugs/Packages.pm @@ -0,0 +1,1096 @@ +# 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. +# +# [Other people have contributed to this file; their copyrights should +# go here too.] +# Copyright 2007 by Don Armstrong . + +package Debbugs::Packages; + +use warnings; +use strict; + +use Exporter qw(import); +use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT); + +use Carp; + +use Debbugs::Config qw(:config :globals); + +BEGIN { + $VERSION = 1.00; + + @EXPORT = (); + %EXPORT_TAGS = (versions => [qw(getversions get_versions make_source_versions)], + mapping => [qw(getpkgsrc getpkgcomponent getsrcpkgs), + qw(binary_to_source sourcetobinary makesourceversions), + qw(source_to_binary), + ], + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(qw(versions mapping)); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + +use Fcntl qw(O_RDONLY); +use MLDBM qw(DB_File Storable); +use Storable qw(dclone); +use Params::Validate qw(validate_with :types); +use Debbugs::Common qw(make_list globify_scalar sort_versions); +use DateTime::Format::Pg; +use List::AllUtils qw(min max uniq); + +use IO::File; + +$MLDBM::DumpMeth = 'portable'; +$MLDBM::RemoveTaint = 1; + +=head1 NAME + +Debbugs::Packages - debbugs binary/source package handling + +=head1 DESCRIPTION + +The Debbugs::Packages module provides support functions to map binary +packages to their corresponding source packages and vice versa. (This makes +sense for software distributions, where developers may work on a single +source package which produces several binary packages for use by users; it +may not make sense in other contexts.) + +=head1 METHODS + +=head2 getpkgsrc + +Returns a reference to a hash of binary package names to their corresponding +source package names. + +=cut + +our $_pkgsrc; +our $_pkgcomponent; +our $_srcpkg; +sub getpkgsrc { + return $_pkgsrc if $_pkgsrc; + return {} unless defined $config{package_source} and + length $config{package_source}; + my %pkgsrc; + my %pkgcomponent; + my %srcpkg; + + my $fh = IO::File->new($config{package_source},'r') + or croak("Unable to open $config{package_source} for reading: $!"); + while(<$fh>) { + next unless m/^(\S+)\s+(\S+)\s+(\S.*\S)\s*$/; + my ($bin,$cmp,$src)=($1,$2,$3); + $bin = lc($bin); + $pkgsrc{$bin}= $src; + push @{$srcpkg{$src}}, $bin; + $pkgcomponent{$bin}= $cmp; + } + close($fh); + $_pkgsrc = \%pkgsrc; + $_pkgcomponent = \%pkgcomponent; + $_srcpkg = \%srcpkg; + return $_pkgsrc; +} + +=head2 getpkgcomponent + +Returns a reference to a hash of binary package names to the component of +the archive containing those binary packages (e.g. "main", "contrib", +"non-free"). + +=cut + +sub getpkgcomponent { + return $_pkgcomponent if $_pkgcomponent; + getpkgsrc(); + return $_pkgcomponent; +} + +=head2 getsrcpkgs + +Returns a list of the binary packages produced by a given source package. + +=cut + +sub getsrcpkgs { + my $src = shift; + getpkgsrc() if not defined $_srcpkg; + return () if not defined $src or not exists $_srcpkg->{$src}; + return @{$_srcpkg->{$src}}; +} + +=head2 binary_to_source + + binary_to_source(package => 'foo', + version => '1.2.3', + arch => 'i386'); + + +Turn a binary package (at optional version in optional architecture) +into a single (or set) of source packages (optionally) with associated +versions. + +By default, in LIST context, returns a LIST of array refs of source +package, source version pairs corresponding to the binary package(s), +arch(s), and verion(s) passed. + +In SCALAR context, only the corresponding source packages are +returned, concatenated with ', ' if necessary. + +If no source can be found, returns undef in scalar context, or the +empty list in list context. + +=over + +=item binary -- binary package name(s) as a SCALAR or ARRAYREF + +=item version -- binary package version(s) as a SCALAR or ARRAYREF; +optional, defaults to all versions. + +=item arch -- binary package architecture(s) as a SCALAR or ARRAYREF; +optional, defaults to all architectures. + +=item source_only -- return only the source name (forced on if in +SCALAR context), defaults to false. + +=item scalar_only -- return a scalar only (forced true if in SCALAR +context, also causes source_only to be true), defaults to false. + +=item cache -- optional HASHREF to be used to cache results of +binary_to_source. + +=back + +=cut + +# the two global variables below are used to tie the source maps; we +# probably should be retying them in long lived processes. +our %_binarytosource; +sub _tie_binarytosource { + if (not tied %_binarytosource) { + tie %_binarytosource, MLDBM => $config{binary_source_map}, O_RDONLY or + die "Unable to open $config{binary_source_map} for reading"; + } +} +our %_sourcetobinary; +sub _tie_sourcetobinary { + if (not tied %_sourcetobinary) { + tie %_sourcetobinary, MLDBM => $config{source_binary_map}, O_RDONLY or + die "Unable to open $config{source_binary_map} for reading"; + } +} +sub binary_to_source{ + my %param = validate_with(params => \@_, + spec => {binary => {type => SCALAR|ARRAYREF, + }, + version => {type => SCALAR|ARRAYREF, + optional => 1, + }, + arch => {type => SCALAR|ARRAYREF, + optional => 1, + }, + source_only => {default => 0, + }, + scalar_only => {default => 0, + }, + cache => {type => HASHREF, + default => {}, + }, + schema => {type => OBJECT, + optional => 1, + }, + }, + ); + + # TODO: This gets hit a lot, especially from buggyversion() - probably + # need an extra cache for speed here. + return () unless defined $gBinarySourceMap or defined $param{schema}; + + if ($param{scalar_only} or not wantarray) { + $param{source_only} = 1; + $param{scalar_only} = 1; + } + + my @source; + my @binaries = grep {defined $_} make_list(exists $param{binary}?$param{binary}:[]); + my @versions = grep {defined $_} make_list(exists $param{version}?$param{version}:[]); + my @archs = grep {defined $_} make_list(exists $param{arch}?$param{arch}:[]); + return () unless @binaries; + + my $cache_key = join("\1", + join("\0",@binaries), + join("\0",@versions), + join("\0",@archs), + join("\0",@param{qw(source_only scalar_only)})); + if (exists $param{cache}{$cache_key}) { + return $param{scalar_only} ? $param{cache}{$cache_key}[0]: + @{$param{cache}{$cache_key}}; + } + # any src:foo is source package foo with unspecified version + @source = map {/^src:(.+)$/? + [$1,'']:()} @binaries; + @binaries = grep {$_ !~ /^src:/} @binaries; + if ($param{schema}) { + if ($param{source_only}) { + @source = map {$_->[0]} @source; + my $src_rs = $param{schema}->resultset('SrcPkg')-> + search_rs({'bin_pkg.pkg' => [@binaries], + @versions?('bin_vers.ver' => [@versions]):(), + @archs?('arch.arch' => [@archs]):(), + }, + {join => {'src_vers'=> + {'bin_vers'=> ['arch','bin_pkg']} + }, + columns => [qw(pkg)], + order_by => [qw(pkg)], + result_class => 'DBIx::Class::ResultClass::HashRefInflator', + distinct => 1, + }, + ); + push @source, + map {$_->{pkg}} $src_rs->all; + if ($param{scalar_only}) { + @source = join(',',@source); + } + $param{cache}{$cache_key} = \@source; + return $param{scalar_only}?$source[0]:@source; + } + my $src_rs = $param{schema}->resultset('SrcVer')-> + search_rs({'bin_pkg.pkg' => [@binaries], + @versions?('bin_vers.ver' => [@versions]):(), + @archs?('arch.arch' => [@archs]):(), + }, + {join => ['src_pkg', + {'bin_vers' => ['arch','binpkg']}, + ], + columns => ['src_pkg.pkg','src_ver.ver'], + result_class => 'DBIx::Class::ResultClass::HashRefInflator', + order_by => ['src_pkg.pkg','src_ver.ver'], + distinct => 1, + }, + ); + push @source, + map {[$_->{src_pkg}{pkg}, + $_->{src_ver}{ver}, + ]} $src_rs->all; + if (not @source and not @versions and not @archs) { + $src_rs = $param{schema}->resultset('SrcPkg')-> + search_rs({pkg => [@binaries]}, + {join => ['src_vers'], + columns => ['src_pkg.pkg','src_vers.ver'], + distinct => 1, + }, + ); + push @source, + map {[$_->{src_pkg}{pkg}, + $_->{src_vers}{ver}, + ]} $src_rs->all; + } + $param{cache}{$cache_key} = \@source; + return $param{scalar_only}?$source[0]:@source; + } + for my $binary (@binaries) { + _tie_binarytosource; + # avoid autovivification + my $bin = $_binarytosource{$binary}; + next unless defined $bin; + if (not @versions) { + for my $ver (keys %{$bin}) { + for my $ar (keys %{$bin->{$ver}}) { + my $src = $bin->{$ver}{$ar}; + next unless defined $src; + push @source,[$src->[0],$src->[1]]; + } + } + } + else { + for my $version (@versions) { + next unless exists $bin->{$version}; + if (exists $bin->{$version}{all}) { + push @source,dclone($bin->{$version}{all}); + next; + } + my @t_archs; + if (@archs) { + @t_archs = @archs; + } + else { + @t_archs = keys %{$bin->{$version}}; + } + for my $arch (@t_archs) { + push @source,dclone($bin->{$version}{$arch}) if + exists $bin->{$version}{$arch}; + } + } + } + } + + if (not @source and not @versions and not @archs) { + # ok, we haven't found any results at all. If we weren't given + # a specific version and architecture, then we should try + # really hard to figure out the right source + + # if any the packages we've been given are a valid source + # package name, and there's no binary of the same name (we got + # here, so there isn't), return it. + _tie_sourcetobinary(); + for my $maybe_sourcepkg (@binaries) { + if (exists $_sourcetobinary{$maybe_sourcepkg}) { + push @source,[$maybe_sourcepkg,$_] for keys %{$_sourcetobinary{$maybe_sourcepkg}}; + } + } + # if @source is still empty here, it's probably a non-existant + # source package, so don't return anything. + } + + my @result; + + if ($param{source_only}) { + my %uniq; + for my $s (@source) { + # we shouldn't need to do this, but do this temporarily to + # stop the warning. + next unless defined $s->[0]; + $uniq{$s->[0]} = 1; + } + @result = sort keys %uniq; + if ($param{scalar_only}) { + @result = join(', ',@result); + } + } + else { + my %uniq; + for my $s (@source) { + $uniq{$s->[0]}{$s->[1]} = 1; + } + for my $sn (sort keys %uniq) { + push @result, [$sn, $_] for sort keys %{$uniq{$sn}}; + } + } + + # No $gBinarySourceMap, or it didn't have an entry for this name and + # version. + $param{cache}{$cache_key} = \@result; + return $param{scalar_only} ? $result[0] : @result; +} + +=head2 source_to_binary + + source_to_binary(package => 'foo', + version => '1.2.3', + arch => 'i386'); + + +Turn a source package (at optional version) into a single (or set) of all binary +packages (optionally) with associated versions. + +By default, in LIST context, returns a LIST of array refs of binary package, +binary version, architecture triples corresponding to the source package(s) and +verion(s) passed. + +In SCALAR context, only the corresponding binary packages are returned, +concatenated with ', ' if necessary. + +If no binaries can be found, returns undef in scalar context, or the +empty list in list context. + +=over + +=item source -- source package name(s) as a SCALAR or ARRAYREF + +=item version -- binary package version(s) as a SCALAR or ARRAYREF; +optional, defaults to all versions. + +=item dist -- list of distributions to return corresponding binary packages for +as a SCALAR or ARRAYREF. + +=item binary_only -- return only the source name (forced on if in SCALAR +context), defaults to false. [If in LIST context, returns a list of binary +names.] + +=item scalar_only -- return a scalar only (forced true if in SCALAR +context, also causes binary_only to be true), defaults to false. + +=item cache -- optional HASHREF to be used to cache results of +binary_to_source. + +=back + +=cut + +# the two global variables below are used to tie the source maps; we +# probably should be retying them in long lived processes. +sub source_to_binary{ + my %param = validate_with(params => \@_, + spec => {source => {type => SCALAR|ARRAYREF, + }, + version => {type => SCALAR|ARRAYREF, + optional => 1, + }, + dist => {type => SCALAR|ARRAYREF, + optional => 1, + }, + binary_only => {default => 0, + }, + scalar_only => {default => 0, + }, + cache => {type => HASHREF, + default => {}, + }, + schema => {type => OBJECT, + optional => 1, + }, + }, + ); + if (not defined $config{source_binary_map} and + not defined $param{schema} + ) { + return (); + } + + if ($param{scalar_only} or not wantarray) { + $param{binary_only} = 1; + $param{scalar_only} = 1; + } + + my @binaries; + my @sources = sort grep {defined $_} + make_list(exists $param{source}?$param{source}:[]); + my @versions = sort grep {defined $_} + make_list(exists $param{version}?$param{version}:[]); + return () unless @sources; + + # any src:foo is source package foo with unspecified version + @sources = map {s/^src://; $_} @sources; + if ($param{schema}) { + if ($param{binary_only}) { + my $bin_rs = $param{schema}->resultset('BinPkg')-> + search_rs({'src_pkg.pkg' => [@sources], + @versions?('src_ver.ver' => [@versions]):(), + }, + {join => {'bin_vers'=> + {'src_ver'=> 'src_pkg'} + }, + columns => [qw(pkg)], + order_by => [qw(pkg)], + result_class => 'DBIx::Class::ResultClass::HashRefInflator', + distinct => 1, + }, + ); + if (exists $param{dist}) { + $bin_rs = $bin_rs-> + search({-or => + {'suite.codename' => [make_list($param{dist})], + 'suite.suite_name' => [make_list($param{dist})], + }}, + {join => {'bin_vers' => + {'bin_associations' => + 'suite' + }}, + }); + } + push @binaries, + map {$_->{pkg}} $bin_rs->all; + if ($param{scalar_only}) { + return join(', ',@binaries); + } + return @binaries; + + } + my $src_rs = $param{schema}->resultset('BinVer')-> + search_rs({'src_pkg.pkg' => [@sources], + @versions?('src_ver.ver' => [@versions]):(), + }, + {join => ['bin_pkg', + 'arch', + {'src_ver' => ['src_pkg']}, + ], + columns => ['src_pkg.pkg','src_ver.ver','arch.arch'], + order_by => ['src_pkg.pkg','src_ver.ver','arch.arch'], + result_class => 'DBIx::Class::ResultClass::HashRefInflator', + distinct => 1, + }, + ); + push @binaries, + map {[$_->{src_pkg}{pkg}, + $_->{src_ver}{ver}, + $_->{arch}{arch}, + ]} + $src_rs->all; + if (not @binaries and not @versions) { + $src_rs = $param{schema}->resultset('BinPkg')-> + search_rs({pkg => [@sources]}, + {join => {'bin_vers' => + ['arch', + {'src_ver'=>'src_pkg'}], + }, + distinct => 1, + result_class => 'DBIx::Class::ResultClass::HashRefInflator', + columns => ['src_pkg.pkg','src_ver.ver','arch.arch'], + order_by => ['src_pkg.pkg','src_ver.ver','arch.arch'], + }, + ); + push @binaries, + map {[$_->{src_pkg}{pkg}, + $_->{src_ver}{ver}, + $_->{arch}{arch}, + ]} $src_rs->all; + } + return @binaries; + } + my $cache_key = join("\1", + join("\0",@sources), + join("\0",@versions), + join("\0",@param{qw(binary_only scalar_only)})); + if (exists $param{cache}{$cache_key}) { + return $param{scalar_only} ? $param{cache}{$cache_key}[0]: + @{$param{cache}{$cache_key}}; + } + my @return; + my %binaries; + if ($param{binary_only}) { + for my $source (@sources) { + _tie_sourcetobinary; + # avoid autovivification + my $src = $_sourcetobinary{$source}; + if (not defined $src) { + next if @versions; + _tie_binarytosource; + if (exists $_binarytosource{$source}) { + $binaries{$source} = 1; + } + next; + } + my @src_vers = @versions; + if (not @versions) { + @src_vers = keys %{$src}; + } + for my $ver (@src_vers) { + $binaries{$_->[0]} = 1 + foreach @{$src->{$ver}//[]}; + } + } + # return if we have any results. + @return = sort keys %binaries; + if ($param{scalar_only}) { + @return = join(', ',@return); + } + goto RETURN_RESULT; + } + for my $source (@sources) { + _tie_sourcetobinary; + my $src = $_sourcetobinary{$source}; + # there isn't a source package, so return this as a binary packages if a + # version hasn't been specified + if (not defined $src) { + next if @versions; + _tie_binarytosource; + if (exists $_binarytosource{$source}) { + my $bin = $_binarytosource{$source}; + for my $ver (keys %{$bin}) { + for my $arch (keys %{$bin->{$ver}}) { + $binaries{$bin}{$ver}{$arch} = 1; + } + } + } + next; + } + for my $bin_ver_archs (values %{$src}) { + for my $bva (@{$bin_ver_archs}) { + $binaries{$bva->[0]}{$bva->[1]}{$bva->[2]} = 1; + } + } + } + for my $bin (sort keys %binaries) { + for my $ver (sort keys %{$binaries{$bin}}) { + for my $arch (sort keys %{$binaries{$bin}{$ver}}) { + push @return, + [$bin,$ver,$arch]; + } + } + } +RETURN_RESULT: + $param{cache}{$cache_key} = \@return; + return $param{scalar_only} ? $return[0] : @return; +} + + +=head2 sourcetobinary + +Returns a list of references to triplets of binary package names, versions, +and architectures corresponding to a given source package name and version. +If the given source package name and version cannot be found in the database +but the source package name is in the unversioned package-to-source map +file, then a reference to a binary package name and version pair will be +returned, without the architecture. + +=cut + +sub sourcetobinary { + my ($srcname, $srcver) = @_; + _tie_sourcetobinary; + # avoid autovivification + my $source = $_sourcetobinary{$srcname}; + return () unless defined $source; + if (exists $source->{$srcver}) { + my $bin = $source->{$srcver}; + return () unless defined $bin; + return @$bin; + } + # No $gSourceBinaryMap, or it didn't have an entry for this name and + # version. Try $gPackageSource (unversioned) instead. + my @srcpkgs = getsrcpkgs($srcname); + return map [$_, $srcver], @srcpkgs; +} + +=head2 getversions + +Returns versions of the package in a distribution at a specific +architecture + +=cut + +sub getversions { + my ($pkg, $dist, $arch) = @_; + return get_versions(package=>$pkg, + dist => $dist, + defined $arch ? (arch => $arch):(), + ); +} + + + +=head2 get_versions + + get_versions(package=>'foopkg', + dist => 'unstable', + arch => 'i386', + ); + +Returns a list of the versions of package in the distributions and +architectures listed. This routine only returns unique values. + +=over + +=item package -- package to return list of versions + +=item dist -- distribution (unstable, stable, testing); can be an +arrayref + +=item arch -- architecture (i386, source, ...); can be an arrayref + +=item time -- returns a version=>time hash at which the newest package +matching this version was uploaded + +=item source -- returns source/version instead of just versions + +=item no_source_arch -- discards the source architecture when arch is +not passed. [Used for finding the versions of binary packages only.] +Defaults to 0, which does not discard the source architecture. (This +may change in the future, so if you care, please code accordingly.) + +=item return_archs -- returns a version=>[archs] hash indicating which +architectures are at which versions. + +=item largest_source_version_only -- if there is more than one source +version in a particular distribution, discards all versions but the +largest in that distribution. Defaults to 1, as this used to be the +way that the Debian archive worked. + +=back + +When called in scalar context, this function will return hashrefs or +arrayrefs as appropriate, in list context, it will return paired lists +or unpaired lists as appropriate. + +=cut + +our %_versions; +our %_versions_time; + +sub get_versions{ + my %param = validate_with(params => \@_, + spec => {package => {type => SCALAR|ARRAYREF, + }, + dist => {type => SCALAR|ARRAYREF, + default => 'unstable', + }, + arch => {type => SCALAR|ARRAYREF, + optional => 1, + }, + time => {type => BOOLEAN, + default => 0, + }, + source => {type => BOOLEAN, + default => 0, + }, + no_source_arch => {type => BOOLEAN, + default => 0, + }, + return_archs => {type => BOOLEAN, + default => 0, + }, + largest_source_version_only => {type => BOOLEAN, + default => 1, + }, + schema => {type => OBJECT, + optional => 1, + }, + }, + ); + if (defined $param{schema}) { + my @src_packages; + my @bin_packages; + for my $pkg (make_list($param{package})) { + if ($pkg =~ /^src:(.+)/) { + push @src_packages, + $1; + } else { + push @bin_packages,$pkg; + } + } + + my $s = $param{schema}; + my %return; + if (@src_packages) { + my $src_rs = $s->resultset('SrcVer')-> + search({'src_pkg.pkg'=>[@src_packages], + -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'}, + }, + ); + my %completed_dists; + for my $src ($src_rs->all()) { + my $val = 'source'; + if ($param{time}) { + $val = DateTime::Format::Pg-> + parse_datetime($src->{modified_time})-> + epoch(); + } + if ($param{largest_source_version_only}) { + next if $completed_dists{$src->{codename}}; + $completed_dists{$src->{codename}} = 1; + } + if ($param{source}) { + $return{$src->{src_pkg_ver}} = $val; + } else { + $return{$src->{ver}} = $val; + } + } + } + if (@bin_packages) { + my $bin_rs = $s->resultset('BinVer')-> + search({'bin_pkg.pkg' => [@bin_packages], + -or => {'suite.codename' => [make_list($param{dist})], + 'suite.suite_name' => [make_list($param{dist})], + }, + }, + {join => ['bin_pkg', + { + 'src_ver'=>'src_pkg'}, + { + bin_associations => 'suite'}, + 'arch', + ], + '+select' => [qw(bin_pkg.pkg arch.arch suite.codename), + qw(bin_associations.modified), + qw(src_pkg.pkg),q(CONCAT(src_pkg.pkg,'/',me.ver)), + ], + '+as' => ['bin_pkg','arch','codename', + 'modified_time', + 'src_pkg_name','src_pkg_ver'], + result_class => 'DBIx::Class::ResultClass::HashRefInflator', + order_by => {-desc => 'src_ver.ver'}, + }); + if (exists $param{arch}) { + $bin_rs = + $bin_rs->search({'arch.arch' => [make_list($param{arch})]}, + { + join => 'arch'} + ); + } + my %completed_dists; + for my $bin ($bin_rs->all()) { + my $key = $bin->{ver}; + if ($param{source}) { + $key = $bin->{src_pkg_ver}; + } + my $val = $bin->{arch}; + if ($param{time}) { + $val = DateTime::Format::Pg-> + parse_datetime($bin->{modified_time})-> + epoch(); + } + if ($param{largest_source_version_only}) { + if ($completed_dists{$bin->{codename}} and not + exists $return{$key}) { + next; + } + $completed_dists{$bin->{codename}} = 1; + } + push @{$return{$key}}, + $val; + } + } + if ($param{return_archs}) { + if ($param{time} or $param{return_archs}) { + return wantarray?%return :\%return; + } + return wantarray?keys %return :[keys %return]; + } + } + my $versions; + if ($param{time}) { + return () if not defined $gVersionTimeIndex; + unless (tied %_versions_time) { + tie %_versions_time, 'MLDBM', $gVersionTimeIndex, O_RDONLY + or die "can't open versions index $gVersionTimeIndex: $!"; + } + $versions = \%_versions_time; + } + else { + return () if not defined $gVersionIndex; + unless (tied %_versions) { + tie %_versions, 'MLDBM', $gVersionIndex, O_RDONLY + or die "can't open versions index $gVersionIndex: $!"; + } + $versions = \%_versions; + } + my %versions; + for my $package (make_list($param{package})) { + my $source_only = 0; + if ($package =~ s/^src://) { + $source_only = 1; + } + my $version = $versions->{$package}; + next unless defined $version; + for my $dist (make_list($param{dist})) { + for my $arch (exists $param{arch}? + make_list($param{arch}): + (grep {not $param{no_source_arch} or + $_ ne 'source' + } $source_only?'source':keys %{$version->{$dist}})) { + next unless defined $version->{$dist}{$arch}; + my @vers = ref $version->{$dist}{$arch} eq 'HASH' ? + keys %{$version->{$dist}{$arch}} : + make_list($version->{$dist}{$arch}); + if ($param{largest_source_version_only} and + $arch eq 'source' and @vers > 1) { + # order the versions, then pick the biggest version number + @vers = sort_versions(@vers); + @vers = $vers[-1]; + } + for my $ver (@vers) { + my $f_ver = $ver; + if ($param{source}) { + ($f_ver) = make_source_versions(package => $package, + arch => $arch, + versions => $ver); + next unless defined $f_ver; + } + if ($param{time}) { + $versions{$f_ver} = max($versions{$f_ver}||0,$version->{$dist}{$arch}{$ver}); + } + else { + push @{$versions{$f_ver}},$arch; + } + } + } + } + } + if ($param{time} or $param{return_archs}) { + return wantarray?%versions :\%versions; + } + return wantarray?keys %versions :[keys %versions]; +} + + +=head2 makesourceversions + + @{$cgi_var{found}} = makesourceversions($cgi_var{package},undef,@{$cgi_var{found}}); + +Canonicalize versions into source versions, which have an explicitly +named source package. This is used to cope with source packages whose +names have changed during their history, and with cases where source +version numbers differ from binary version numbers. + +=cut + +our %_sourceversioncache = (); +sub makesourceversions { + my ($package,$arch,@versions) = @_; + die "Package $package is multiple packages; split on , and call makesourceversions multiple times" + if $package =~ /,/; + return make_source_versions(package => $package, + (defined $arch)?(arch => $arch):(), + versions => \@versions + ); +} + +=head2 make_source_versions + + make_source_versions(package => 'foo', + arch => 'source', + versions => '0.1.1', + guess_source => 1, + warnings => \$warnings, + ); + +An extended version of makesourceversions (which calls this function +internally) that allows for multiple packages, architectures, and +outputs warnings and debugging information to provided SCALARREFs or +HANDLEs. + +The guess_source option determines whether the source package is +guessed at if there is no obviously correct package. Things that use +this function for non-transient output should set this to false, +things that use it for transient output can set this to true. +Currently it defaults to true, but that is not a sane option. + + +=cut + +sub make_source_versions { + my %param = validate_with(params => \@_, + spec => {package => {type => SCALAR|ARRAYREF, + }, + arch => {type => SCALAR|ARRAYREF|UNDEF, + default => '' + }, + versions => {type => SCALAR|ARRAYREF, + default => [], + }, + guess_source => {type => BOOLEAN, + default => 1, + }, + source_version_cache => {type => HASHREF, + optional => 1, + }, + debug => {type => SCALARREF|HANDLE, + optional => 1, + }, + warnings => {type => SCALARREF|HANDLE, + optional => 1, + }, + schema => {type => OBJECT, + optional => 1, + }, + }, + ); + my ($warnings) = globify_scalar(exists $param{warnings}?$param{warnings}:undef); + + my @packages = grep {defined $_ and length $_ } make_list($param{package}); + my @archs = grep {defined $_ } make_list ($param{arch}); + if (not @archs) { + push @archs, ''; + } + if (not exists $param{source_version_cache}) { + $param{source_version_cache} = \%_sourceversioncache; + } + if (grep {/,/} make_list($param{package})) { + croak "Package names contain ,; split on /,/ and call make_source_versions with an arrayref of packages" + } + my %sourceversions; + for my $version (make_list($param{versions})) { + if ($version =~ m{(.+)/([^/]+)$}) { + # Already a source version. + $sourceversions{$version} = 1; + next unless exists $param{warnings}; + # check to see if this source version is even possible + my @bin_versions = sourcetobinary($1,$2); + if (not @bin_versions or + @{$bin_versions[0]} != 3) { + print {$warnings} "The source $1 and version $2 do not appear to match any binary packages\n"; + } + } else { + if (not @packages) { + croak "You must provide at least one package if the versions are not fully qualified"; + } + for my $pkg (@packages) { + if ($pkg =~ /^src:(.+)/) { + $sourceversions{"$1/$version"} = 1; + next unless exists $param{warnings}; + # check to see if this source version is even possible + my @bin_versions = sourcetobinary($1,$version); + if (not @bin_versions or + @{$bin_versions[0]} != 3) { + print {$warnings} "The source '$1' and version '$version' do not appear to match any binary packages\n"; + } + next; + } + for my $arch (@archs) { + my $cachearch = (defined $arch) ? $arch : ''; + my $cachekey = "$pkg/$cachearch/$version"; + if (exists($param{source_version_cache}{$cachekey})) { + for my $v (@{$param{source_version_cache}{$cachekey}}) { + $sourceversions{$v} = 1; + } + next; + } + elsif ($param{guess_source} and + exists$param{source_version_cache}{$cachekey.'/guess'}) { + for my $v (@{$param{source_version_cache}{$cachekey.'/guess'}}) { + $sourceversions{$v} = 1; + } + next; + } + my @srcinfo = binary_to_source(binary => $pkg, + version => $version, + length($arch)?(arch => $arch):()); + if (not @srcinfo) { + # We don't have explicit information about the + # binary-to-source mapping for this version + # (yet). + print {$warnings} "There is no source info for the package '$pkg' at version '$version' with architecture '$arch'\n"; + if ($param{guess_source}) { + # Lets guess it + my $pkgsrc = getpkgsrc(); + if (exists $pkgsrc->{$pkg}) { + @srcinfo = ([$pkgsrc->{$pkg}, $version]); + } elsif (getsrcpkgs($pkg)) { + # If we're looking at a source package + # that doesn't have a binary of the + # same name, just try the same + # version. + @srcinfo = ([$pkg, $version]); + } else { + next; + } + # store guesses in a slightly different location + $param{source_version_cache}{$cachekey.'/guess'} = [ map { "$_->[0]/$_->[1]" } @srcinfo ]; + } + } + else { + # only store this if we didn't have to guess it + $param{source_version_cache}{$cachekey} = [ map { "$_->[0]/$_->[1]" } @srcinfo ]; + } + $sourceversions{"$_->[0]/$_->[1]"} = 1 foreach @srcinfo; + } + } + } + } + return sort keys %sourceversions; +} + + + +1; diff --git a/lib/Debbugs/Recipients.pm b/lib/Debbugs/Recipients.pm new file mode 100644 index 0000000..29b92f7 --- /dev/null +++ b/lib/Debbugs/Recipients.pm @@ -0,0 +1,398 @@ +# This module is part of debbugs, and is released +# under the terms of the GPL version 2, or any later version. See the +# file README and COPYING for more information. +# Copyright 2008 by Don Armstrong . +# $Id: perl_module_header.pm 1221 2008-05-19 15:00:40Z don $ + +package Debbugs::Recipients; + +=head1 NAME + +Debbugs::Recipients -- Determine recipients of messages from the bts + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + + +=head1 BUGS + +None known. + +=cut + +use warnings; +use strict; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use Exporter qw(import); + +BEGIN{ + ($VERSION) = q$Revision: 1221 $ =~ /^Revision:\s+([^\s+])/; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (add => [qw(add_recipients)], + det => [qw(determine_recipients)], + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; + +} + +use Debbugs::Config qw(:config); +use Params::Validate qw(:types validate_with); +use Debbugs::Common qw(:misc :util); +use Debbugs::Status qw(splitpackages isstrongseverity); + +use Debbugs::Packages qw(binary_to_source); + +use Debbugs::Mail qw(get_addresses); + +use Carp; + +=head2 add_recipients + + add_recipients(data => $data, + recipients => \%recipients; + ); + +Given data (from read_bug or similar) (or an arrayref of data), +calculates the addresses which need to receive mail involving this +bug. + +=over + +=item data -- Data from read_bug or similar; can be an arrayref of data + +=item recipients -- hashref of recipient data structure; pass to +subsequent calls of add_recipients or + +=item debug -- optional + + +=back + +=cut + + +sub add_recipients { + # Data structure is: + # maintainer email address &c -> assoc of packages -> assoc of bug#'s + my %param = validate_with(params => \@_, + spec => {data => {type => HASHREF|ARRAYREF, + }, + recipients => {type => HASHREF, + }, + debug => {type => HANDLE|SCALARREF, + optional => 1, + }, + transcript => {type => HANDLE|SCALARREF, + optional => 1, + }, + actions_taken => {type => HASHREF, + default => {}, + }, + unknown_packages => {type => HASHREF, + default => {}, + }, + }, + ); + + $param{transcript} = globify_scalar($param{transcript}); + $param{debug} = globify_scalar($param{debug}); + if (ref ($param{data}) eq 'ARRAY') { + for my $data (@{$param{data}}) { + add_recipients(data => $data, + map {exists $param{$_}?($_,$param{$_}):()} + qw(recipients debug transcript actions_taken unknown_packages) + ); + } + return; + } + my ($addmaint); + my $ref = $param{data}{bug_num}; + for my $p (splitpackages($param{data}{package})) { + $p = lc($p); + if (defined $config{subscription_domain}) { + my @source_packages = binary_to_source(binary => $p, + source_only => 1, + ); + if (@source_packages) { + for my $source (@source_packages) { + _add_address(recipients => $param{recipients}, + address => "$source\@".$config{subscription_domain}, + reason => $source, + type => 'bcc', + ); + } + } + else { + _add_address(recipients => $param{recipients}, + address => "$p\@".$config{subscription_domain}, + reason => $p, + type => 'bcc', + ); + } + } + if (defined $param{data}{severity} and defined $config{strong_list} and + isstrongseverity($param{data}{severity})) { + _add_address(recipients => $param{recipients}, + address => "$config{strong_list}\@".$config{list_domain}, + reason => $param{data}{severity}, + type => 'bcc', + ); + } + my @maints = package_maintainer(binary => $p); + if (@maints) { + print {$param{debug}} "MR|".join(',',@maints)."|$p|$ref|\n"; + _add_address(recipients => $param{recipients}, + address => \@maints, + reason => $p, + bug_num => $param{data}{bug_num}, + type => 'cc', + ); + print {$param{debug}} "maintainer add >$p|".join(',',@maints)."<\n"; + } + else { + print {$param{debug}} "maintainer none >$p<\n"; + if (not exists $param{unknown_packages}{$p}) { + print {$param{transcript}} "Warning: Unknown package '$p'\n"; + $param{unknown_packages}{$p} = 1; + } + print {$param{debug}} "MR|unknown-package|$p|$ref|\n"; + _add_address(recipients => $param{recipients}, + address => $config{unknown_maintainer_email}, + reason => $p, + bug_num => $param{data}{bug_num}, + type => 'cc', + ) + if defined $config{unknown_maintainer_email} and + length $config{unknown_maintainer_email}; + } + } + if (defined $config{bug_subscription_domain} and + length $config{bug_subscription_domain}) { + _add_address(recipients => $param{recipients}, + address => 'bugs='.$param{data}{bug_num}.'@'. + $config{bug_subscription_domain}, + reason => "bug $param{data}{bug_num}", + bug_num => $param{data}{bug_num}, + type => 'bcc', + ); + } + if (defined $config{cc_all_mails_to_addr} and + length $config{cc_all_mails_to_addr} + ) { + _add_address(recipients => $param{recipients}, + address => $config{cc_all_mails_to}, + reason => "cc_all_mails_to", + bug_num => $param{data}{bug_num}, + type => 'bcc', + ); + } + + if (length $param{data}{owner}) { + $addmaint = $param{data}{owner}; + print {$param{debug}} "MO|$addmaint|$param{data}{package}|$ref|\n"; + _add_address(recipients => $param{recipients}, + address => $addmaint, + reason => "owner of $param{data}{bug_num}", + bug_num => $param{data}{bug_num}, + type => 'cc', + ); + print {$param{debug}} "owner add >$param{data}{package}|$addmaint<\n"; + } + if (exists $param{actions_taken}) { + if (exists $param{actions_taken}{done} and + $param{actions_taken}{done} and + length($config{done_list}) and + length($config{list_domain}) + ) { + _add_address(recipients => $param{recipients}, + type => 'cc', + address => $config{done_list}.'@'.$config{list_domain}, + bug_num => $param{data}{bug_num}, + reason => "bug $param{data}{bug_num} done", + ); + } + if (exists $param{actions_taken}{forwarded} and + $param{actions_taken}{forwarded} and + length($config{forward_list}) and + length($config{list_domain}) + ) { + _add_address(recipients => $param{recipients}, + type => 'cc', + address => $config{forward_list}.'@'.$config{list_domain}, + bug_num => $param{data}{bug_num}, + reason => "bug $param{data}{bug_num} forwarded", + ); + } + } +} + +=head2 determine_recipients + + my @recipients = determine_recipients(recipients => \%recipients, + bcc => 1, + ); + my %recipients => determine_recipients(recipients => \%recipients,); + + # or a crazy example: + send_mail_message(message => $message, + recipients => + [make_list( + values %{{determine_recipients( + recipients => \%recipients) + }}) + ], + ); + +Using the recipient hashref, determines the set of recipients. + +If you specify one of C, C, or C, you will receive only a +LIST of recipients which the main should be Bcc'ed, Cc'ed, or To'ed +respectively. By default, a LIST with keys bcc, cc, and to is returned +with ARRAYREF values corresponding to the users to whom a message +should be sent. + +=over + +=item address_only -- whether to only return mail addresses without reasons or realnamesq + +=back + +Passing more than one of bcc, cc or to is a fatal error. + +=cut + +sub determine_recipients { + my %param = validate_with(params => \@_, + spec => {recipients => {type => HASHREF, + }, + bcc => {type => BOOLEAN, + default => 0, + }, + cc => {type => BOOLEAN, + default => 0, + }, + to => {type => BOOLEAN, + default => 0, + }, + address_only => {type => BOOLEAN, + default => 0, + } + }, + ); + + if (1 < scalar grep {$param{$_}} qw(to cc bcc)) { + croak "Passing more than one of to, cc, or bcc is non-sensical"; + } + + my %final_recipients; + # start with the to recipients + for my $addr (keys %{$param{recipients}}) { + my $level = 'bcc'; + my @reasons; + for my $reason (keys %{$param{recipients}{$addr}}) { + my @bugs; + for my $bug (keys %{$param{recipients}{$addr}{$reason}}) { + push @bugs, $bug; + my $t_level = $param{recipients}{$addr}{$reason}{$bug}; + if ($level eq 'to' or + $t_level eq 'to') { + $level = 'to'; + } + elsif ($t_level eq 'cc') { + $level = 'cc'; + } + } + # RFC 2822 comments cannot contain specials and + # unquoted () or \; there's no reason for us to allow + # insane things here, though, so we restrict this even + # more to 20-7E ( -~) + $reason =~ s/\\/\\\\/g; + $reason =~ s/([\)\(])/\\$1/g; + $reason =~ s/[^\x20-\x7E]//g; + push @reasons, $reason . ' for {'.join(',',@bugs).'}'; + } + if ($param{address_only}) { + push @{$final_recipients{$level}}, get_addresses($addr); + } + else { + push @{$final_recipients{$level}}, $addr . ' ('.join(', ',@reasons).')'; + } + } + for (qw(to cc bcc)) { + if ($param{$_}) { + if (exists $final_recipients{$_}) { + return @{$final_recipients{$_}||[]}; + } + return (); + } + } + return %final_recipients; +} + + +=head1 PRIVATE FUNCTIONS + +=head2 _add_address + + _add_address(recipients => $param{recipients}, + address => $addmaint, + reason => $param{data}{package}, + bug_num => $param{data}{bug_num}, + type => 'cc', + ); + + +=cut + + +sub _add_address { + my %param = validate_with(params => \@_, + spec => {recipients => {type => HASHREF, + }, + bug_num => {type => SCALAR, + regex => qr/^\d*$/, + default => '', + }, + reason => {type => SCALAR, + default => '', + }, + address => {type => SCALAR|ARRAYREF, + }, + type => {type => SCALAR, + default => 'cc', + regex => qr/^(?:b?cc|to)$/i, + }, + }, + ); + for my $addr (make_list($param{address})) { + if (lc($param{type}) eq 'bcc' and + exists $param{recipients}{$addr}{$param{reason}}{$param{bug_num}} + ) { + next; + } + elsif (lc($param{type}) eq 'cc' and + exists $param{recipients}{$addr}{$param{reason}}{$param{bug_num}} + and $param{recipients}{$addr}{$param{reason}}{$param{bug_num}} eq 'to' + ) { + next; + } + $param{recipients}{$addr}{$param{reason}}{$param{bug_num}} = lc($param{type}); + } +} + +1; + + +__END__ + + + + + + diff --git a/lib/Debbugs/SOAP.pm b/lib/Debbugs/SOAP.pm new file mode 100644 index 0000000..a0c3cbf --- /dev/null +++ b/lib/Debbugs/SOAP.pm @@ -0,0 +1,406 @@ +# 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 2007 by Don Armstrong . + +package Debbugs::SOAP; + +=head1 NAME + +Debbugs::SOAP -- + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + + +=head1 BUGS + +None known. + +=cut + +use warnings; +use strict; +use vars qw($DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use Debbugs::SOAP::Server; +use Exporter qw(import); +use base qw(SOAP::Server::Parameters); + +BEGIN{ + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = ( + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(); + $EXPORT_TAGS{all} = [@EXPORT_OK]; + +} + +use IO::File; +use Debbugs::Status qw(get_bug_status); +use Debbugs::Common qw(make_list getbuglocation getbugcomponent); +use Debbugs::UTF8; +use Debbugs::Packages; + +use Storable qw(nstore retrieve dclone); +use Scalar::Util qw(looks_like_number); + + +our $CURRENT_VERSION = 2; + +=head2 get_usertag + + my %ut = get_usertag('don@donarmstrong.com','this-bug-sucks','eat-this-bug'); + my %ut = get_usertag('don@donarmstrong.com'); + +Returns a hashref of bugs which have the specified usertags for the +user set. + +In the second case, returns all of the usertags for the user passed. + +=cut + +use Debbugs::User qw(read_usertags); + +sub get_usertag { + my $VERSION = __populate_version(pop); + my ($self,$email, @tags) = @_; + my %ut = (); + read_usertags(\%ut, $email); + my %tags; + @tags{@tags} = (1) x @tags; + if (keys %tags > 0) { + for my $tag (keys %ut) { + delete $ut{$tag} unless exists $tags{$tag}; + } + } + return encode_utf8_structure(\%ut); +} + + +use Debbugs::Status; + +=head2 get_status + + my @statuses = get_status(@bugs); + my @statuses = get_status([bug => 304234, + dist => 'unstable', + ], + [bug => 304233, + dist => 'unstable', + ], + ) + +Returns an arrayref of hashrefs which output the status for specific +sets of bugs. + +In the first case, no options are passed to +L besides the bug number; in the +second the bug, dist, arch, bugusertags, sourceversions, and version +parameters are passed if they are present. + +As a special case for suboptimal SOAP implementations, if only one +argument is passed to get_status and it is an arrayref which either is +empty, has a number as the first element, or contains an arrayref as +the first element, the outer arrayref is dereferenced, and processed +as in the examples above. + +See L for details. + +=cut + +sub get_status { + my $VERSION = __populate_version(pop); + my ($self,@bugs) = @_; + + if (@bugs == 1 and + ref($bugs[0]) and + (@{$bugs[0]} == 0 or + ref($bugs[0][0]) or + looks_like_number($bugs[0][0]) + ) + ) { + @bugs = @{$bugs[0]}; + } + my %status; + my %binary_to_source_cache; + for my $bug (@bugs) { + my $bug_status; + if (ref($bug)) { + my %param = __collapse_params(@{$bug}); + next unless defined $param{bug}; + $bug = $param{bug}; + $bug_status = get_bug_status(map {(exists $param{$_})?($_,$param{$_}):()} + qw(bug dist arch bugusertags sourceversions version indicatesource), + binary_to_source_cache => \%binary_to_source_cache, + ); + } + else { + $bug_status = get_bug_status(bug => $bug, + binary_to_source_cache => \%binary_to_source_cache, + ); + } + if (defined $bug_status and keys %{$bug_status} > 0) { + $status{$bug} = $bug_status; + } + } +# __prepare_response($self); + return encode_utf8_structure(\%status); +} + +=head2 get_bugs + + my @bugs = get_bugs(...); + my @bugs = get_bugs([...]); + +Returns a list of bugs. In the second case, allows the variable +parameters to be specified as an array reference in case your favorite +language's SOAP implementation is craptacular. + +See L for details on what C<...> actually +means. + +=cut + +use Debbugs::Bugs qw(); + +sub get_bugs{ + my $VERSION = __populate_version(pop); + my ($self,@params) = @_; + # Because some soap implementations suck and can't handle + # variable numbers of arguments we allow get_bugs([]); + if (@params == 1 and ref($params[0]) eq 'ARRAY') { + @params = @{$params[0]}; + } + my %params = __collapse_params(@params); + my @bugs; + @bugs = Debbugs::Bugs::get_bugs(%params); + return encode_utf8_structure(\@bugs); +} + +=head2 newest_bugs + + my @bugs = newest_bugs(5); + +Returns a list of the newest bugs. [Note that all bugs are *not* +guaranteed to exist, but they should in the most common cases.] + +=cut + +sub newest_bugs{ + my $VERSION = __populate_version(pop); + my ($self,$num) = @_; + my $newest_bug = Debbugs::Bugs::newest_bug(); + return encode_utf8_structure([($newest_bug - $num + 1) .. $newest_bug]); + +} + +=head2 get_bug_log + + my $bug_log = get_bug_log($bug); + my $bug_log = get_bug_log($bug,$msg_num); + +Retuns a parsed set of the bug log; this is an array of hashes with +the following + + [{html => '', + header => '', + body => '', + attachments => [], + msg_num => 5, + }, + {html => '', + header => '', + body => '', + attachments => [], + }, + ] + + +Currently $msg_num is completely ignored. + +=cut + +use Debbugs::Log qw(); +use Debbugs::MIME qw(parse); + +sub get_bug_log{ + my $VERSION = __populate_version(pop); + my ($self,$bug,$msg_num) = @_; + + my $log = Debbugs::Log->new(bug_num => $bug) or + die "Debbugs::Log was unable to be initialized"; + + my %seen_msg_ids; + my $current_msg=0; + my @messages; + while (my $record = $log->read_record()) { + $current_msg++; + #next if defined $msg_num and ($current_msg ne $msg_num); + next unless $record->{type} eq 'incoming-recv'; + my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im; + next if defined $msg_id and exists $seen_msg_ids{$msg_id}; + $seen_msg_ids{$msg_id} = 1 if defined $msg_id; + next if defined $msg_id and $msg_id =~ /handler\..+\.ack(?:info)?\@/; + my $message = parse($record->{text}); + my ($header,$body) = map {join("\n",make_list($_))} + @{$message}{qw(header body)}; + push @messages,{header => $header, + body => $body, + attachments => [], + msg_num => $current_msg, + }; + } + return encode_utf8_structure(\@messages); +} + +=head2 binary_to_source + + binary_to_source($binary_name,$binary_version,$binary_architecture) + +Returns a reference to the source package name and version pair +corresponding to a given binary package name, version, and +architecture. If undef is passed as the architecture, returns a list +of references to all possible pairs of source package names and +versions for all architectures, with any duplicates removed. + +As of comaptibility version 2, this has changed to use the more +powerful binary_to_source routine, which allows returning source only, +concatenated scalars, and other useful features. + +See the documentation of L for +details. + +=cut + +sub binary_to_source{ + my $VERSION = __populate_version(pop); + my ($self,@params) = @_; + + if ($VERSION <= 1) { + return encode_utf8_structure([Debbugs::Packages::binary_to_source(binary => $params[0], + (@params > 1)?(version => $params[1]):(), + (@params > 2)?(arch => $params[2]):(), + )]); + } + else { + return encode_utf8_structure([Debbugs::Packages::binary_to_source(@params)]); + } +} + +=head2 source_to_binary + + source_to_binary($source_name,$source_version); + +Returns a reference to an array of references to binary package name, +version, and architecture corresponding to a given source package name +and version. In the case that the given name and version cannot be +found, the unversioned package to source map is consulted, and the +architecture is not returned. + +(This function corresponds to L) + +=cut + +sub source_to_binary { + my $VERSION = __populate_version(pop); + my ($self,@params) = @_; + + return encode_utf8_structure([Debbugs::Packages::sourcetobinary(@params)]); +} + +=head2 get_versions + + get_version(package=>'foopkg', + dist => 'unstable', + arch => 'i386', + ); + +Returns a list of the versions of package in the distributions and +architectures listed. This routine only returns unique values. + +=over + +=item package -- package to return list of versions + +=item dist -- distribution (unstable, stable, testing); can be an +arrayref + +=item arch -- architecture (i386, source, ...); can be an arrayref + +=item time -- returns a version=>time hash at which the newest package +matching this version was uploaded + +=item source -- returns source/version instead of just versions + +=item no_source_arch -- discards the source architecture when arch is +not passed. [Used for finding the versions of binary packages only.] +Defaults to 0, which does not discard the source architecture. (This +may change in the future, so if you care, please code accordingly.) + +=item return_archs -- returns a version=>[archs] hash indicating which +architectures are at which versions. + +=back + +This function corresponds to L + +=cut + +sub get_versions{ + my $VERSION = __populate_version(pop); + my ($self,@params) = @_; + + return encode_utf8_structure(scalar Debbugs::Packages::get_versions(@params)); +} + +=head1 VERSION COMPATIBILITY + +The functionality provided by the SOAP interface will change over time. + +To the greatest extent possible, we will attempt to provide backwards +compatibility with previous versions; however, in order to have +backwards compatibility, you need to specify the version with which +you are compatible. + +=cut + +sub __populate_version{ + my ($request) = @_; + return $request->{___debbugs_soap_version}; +} + +sub __collapse_params{ + my @params = @_; + + my %params; + # Because some clients can't handle passing arrayrefs, we allow + # options to be specified multiple times + while (my ($key,$value) = splice @params,0,2) { + push @{$params{$key}}, make_list($value); + } + # However, for singly specified options, we want to pull them + # back out + for my $key (keys %params) { + if (@{$params{$key}} == 1) { + ($params{$key}) = @{$params{$key}} + } + } + return %params; +} + + +1; + + +__END__ + + + + + + diff --git a/lib/Debbugs/SOAP/Server.pm b/lib/Debbugs/SOAP/Server.pm new file mode 100644 index 0000000..c55267b --- /dev/null +++ b/lib/Debbugs/SOAP/Server.pm @@ -0,0 +1,61 @@ +# 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 2007 by Don Armstrong . + +package Debbugs::SOAP::Server; + +=head1 NAME + +Debbugs::SOAP::Server -- Server Transport module + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + + +=head1 BUGS + +None known. + +=cut + +use warnings; +use strict; +use vars qw(@ISA); +use SOAP::Transport::HTTP; +BEGIN{ + # Eventually we'll probably change this to just be HTTP::Server and + # have the soap.cgi declare a class which inherits from both + push @ISA,qw(SOAP::Transport::HTTP::CGI); +} + +use Debbugs::SOAP; + +sub find_target { + my ($self,$request) = @_; + + # WTF does this do? + $request->match((ref $request)->method); + my $method_uri = $request->namespaceuriof || 'Debbugs/SOAP'; + my $method_name = $request->dataof->name; + $method_uri =~ s{(?:/?Status/?|/?Usertag/?)}{}; + $method_uri =~ s{(Debbugs/SOAP/)[vV](\d+)/?}{$1}; + my ($soap_version) = $2 if defined $2; + $self->dispatched('Debbugs:::SOAP'); + $request->{___debbugs_soap_version} = $soap_version || ''; + return ('Debbugs::SOAP',$method_uri,$method_name); +} + + +1; + + +__END__ + + + + + + diff --git a/lib/Debbugs/Status.pm b/lib/Debbugs/Status.pm new file mode 100644 index 0000000..f539781 --- /dev/null +++ b/lib/Debbugs/Status.pm @@ -0,0 +1,1901 @@ +# 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. +# +# [Other people have contributed to this file; their copyrights should +# go here too.] +# Copyright 2007-9 by Don Armstrong . + +package Debbugs::Status; + +=head1 NAME + +Debbugs::Status -- Routines for dealing with summary and status files + +=head1 SYNOPSIS + +use Debbugs::Status; + + +=head1 DESCRIPTION + +This module is a replacement for the parts of errorlib.pl which write +and read status and summary files. + +It also contains generic routines for returning information about the +status of a particular bug + +=head1 FUNCTIONS + +=cut + +use warnings; +use strict; + +use feature 'state'; + +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use Exporter qw(import); + +use Params::Validate qw(validate_with :types); +use Debbugs::Common qw(:util :lock :quit :misc); +use Debbugs::UTF8; +use Debbugs::Config qw(:config); +use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522); +use Debbugs::Packages qw(makesourceversions make_source_versions getversions get_versions binary_to_source); +use Debbugs::Versions; +use Debbugs::Versions::Dpkg; +use POSIX qw(ceil); +use File::Copy qw(copy); +use Encode qw(decode encode is_utf8); + +use Storable qw(dclone); +use List::AllUtils qw(min max uniq); +use DateTime::Format::Pg; + +use Carp qw(croak); + +BEGIN{ + $VERSION = 1.00; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (status => [qw(splitpackages get_bug_status buggy bug_archiveable), + qw(isstrongseverity bug_presence split_status_fields), + qw(get_bug_statuses), + ], + read => [qw(readbug read_bug lockreadbug lockreadbugmerge), + qw(lock_read_all_merged_bugs), + ], + write => [qw(writebug makestatus unlockwritebug)], + new => [qw(new_bug)], + versions => [qw(addfoundversions addfixedversions), + qw(removefoundversions removefixedversions) + ], + hook => [qw(bughook bughook_archive)], + indexdb => [qw(generate_index_db_line)], + fields => [qw(%fields)], + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + + +=head2 readbug + + readbug($bug_num,$location) + readbug($bug_num) + +Reads a summary file from the archive given a bug number and a bug +location. Valid locations are those understood by L + +=cut + +# these probably shouldn't be imported by most people, but +# Debbugs::Control needs them, so they're now exportable +our %fields = (originator => 'submitter', + date => 'date', + subject => 'subject', + msgid => 'message-id', + 'package' => 'package', + keywords => 'tags', + done => 'done', + forwarded => 'forwarded-to', + mergedwith => 'merged-with', + severity => 'severity', + owner => 'owner', + found_versions => 'found-in', + found_date => 'found-date', + fixed_versions => 'fixed-in', + fixed_date => 'fixed-date', + blocks => 'blocks', + blockedby => 'blocked-by', + unarchived => 'unarchived', + summary => 'summary', + outlook => 'outlook', + affects => 'affects', + ); + + +# Fields which need to be RFC1522-decoded in format versions earlier than 3. +my @rfc1522_fields = qw(originator subject done forwarded owner); + +sub readbug { + return read_bug(bug => $_[0], + (@_ > 1)?(location => $_[1]):() + ); +} + +=head2 read_bug + + read_bug(bug => $bug_num, + location => 'archive', + ); + read_bug(summary => 'path/to/bugnum.summary'); + read_bug($bug_num); + +A more complete function than readbug; it enables you to pass a full +path to the summary file instead of the bug number and/or location. + +=head3 Options + +=over + +=item bug -- the bug number + +=item location -- optional location which is passed to getbugcomponent + +=item summary -- complete path to the .summary file which will be read + +=item lock -- whether to obtain a lock for the bug to prevent +something modifying it while the bug has been read. You B call +C if something not undef is returned from read_bug. + +=item locks -- hashref of already obtained locks; incremented as new +locks are needed, and decremented as locks are released on particular +files. + +=back + +One of C or C must be passed. This function will return +undef on failure, and will die if improper arguments are passed. + +=cut + +sub read_bug{ + if (@_ == 1) { + unshift @_, 'bug'; + } + state $spec = + {bug => {type => SCALAR, + optional => 1, + # something really stupid passes negative bugnumbers + regex => qr/^-?\d+/, + }, + location => {type => SCALAR|UNDEF, + optional => 1, + }, + summary => {type => SCALAR, + optional => 1, + }, + lock => {type => BOOLEAN, + optional => 1, + }, + locks => {type => HASHREF, + optional => 1, + }, + }; + my %param = validate_with(params => \@_, + spec => $spec, + ); + die "One of bug or summary must be passed to read_bug" + if not exists $param{bug} and not exists $param{summary}; + my $status; + my $log; + my $location; + my $report; + if (not defined $param{summary}) { + my $lref; + ($lref,$location) = @param{qw(bug location)}; + if (not defined $location) { + $location = getbuglocation($lref,'summary'); + return undef if not defined $location; + } + $status = getbugcomponent($lref, 'summary', $location); + $log = getbugcomponent($lref, 'log' , $location); + $report = getbugcomponent($lref, 'report' , $location); + return undef unless defined $status; + return undef if not -e $status; + } + else { + $status = $param{summary}; + $log = $status; + $report = $status; + $log =~ s/\.summary$/.log/; + $report =~ s/\.summary$/.report/; + ($location) = $status =~ m/(db-h|db|archive)/; + ($param{bug}) = $status =~ m/(\d+)\.summary$/; + } + if ($param{lock}) { + filelock("$config{spool_dir}/lock/$param{bug}",exists $param{locks}?$param{locks}:()); + } + my $status_fh = IO::File->new($status, 'r'); + if (not defined $status_fh) { + warn "Unable to open $status for reading: $!"; + if ($param{lock}) { + unfilelock(exists $param{locks}?$param{locks}:()); + } + return undef; + } + binmode($status_fh,':encoding(UTF-8)'); + + my %data; + my @lines; + my $version; + local $_; + + while (<$status_fh>) { + chomp; + push @lines, $_; + if (not defined $version and + /^Format-Version: ([0-9]+)/i + ) { + $version = $1; + } + } + $version = 2 if not defined $version; + # Version 3 is the latest format version currently supported. + if ($version > 3) { + warn "Unsupported status version '$version'"; + if ($param{lock}) { + unfilelock(exists $param{locks}?$param{locks}:()); + } + return undef; + } + + state $namemap = {reverse %fields}; + for my $line (@lines) { + if ($line =~ /(\S+?): (.*)/) { + my ($name, $value) = (lc $1, $2); + # this is a bit of a hack; we should never, ever have \r + # or \n in the fields of status. Kill them off here. + # [Eventually, this should be superfluous.] + $value =~ s/[\r\n]//g; + $data{$namemap->{$name}} = $value if exists $namemap->{$name}; + } + } + for my $field (keys %fields) { + $data{$field} = '' unless exists $data{$field}; + } + if ($version < 3) { + for my $field (@rfc1522_fields) { + $data{$field} = decode_rfc1522($data{$field}); + } + } + $data{severity} = $config{default_severity} if $data{severity} eq ''; + for my $field (qw(found_versions fixed_versions found_date fixed_date)) { + $data{$field} = [split ' ', $data{$field}]; + } + for my $field (qw(found fixed)) { + # create the found/fixed hashes which indicate when a + # particular version was marked found or marked fixed. + @{$data{$field}}{@{$data{"${field}_versions"}}} = + (('') x (@{$data{"${field}_versions"}} - @{$data{"${field}_date"}}), + @{$data{"${field}_date"}}); + } + + my $status_modified = (stat($status))[9]; + # Add log last modified time + $data{log_modified} = (stat($log))[9] // (stat("${log}.gz"))[9]; + my $report_modified = (stat($report))[9] // $data{log_modified}; + $data{last_modified} = max($status_modified,$data{log_modified}); + # if the date isn't set (ancient bug), use the smallest of any of the modified + if (not defined $data{date} or not length($data{date})) { + $data{date} = min($report_modified,$status_modified,$data{log_modified}); + } + $data{location} = $location; + $data{archived} = (defined($location) and ($location eq 'archive'))?1:0; + $data{bug_num} = $param{bug}; + + # mergedwith occasionally is sorted badly. Fix it to always be sorted by <=> + # and not include this bug + if (defined $data{mergedwith} and + $data{mergedwith}) { + $data{mergedwith} = + join(' ', + grep { $_ != $data{bug_num}} + sort { $a <=> $b } + split / /, $data{mergedwith} + ); + } + return \%data; +} + +=head2 split_status_fields + + my @data = split_status_fields(@data); + +Splits splittable status fields (like package, tags, blocks, +blockedby, etc.) into arrayrefs (use make_list on these). Keeps the +passed @data intact using dclone. + +In scalar context, returns only the first element of @data. + +=cut + +our $ditch_empty = sub{ + my @t = @_; + my $splitter = shift @t; + return grep {length $_} map {split $splitter} @t; +}; + +our $sort_and_unique = sub { + 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; + } +}; + +my $ditch_space_unique_and_sort = sub {return &{$sort_and_unique}(&{$ditch_empty}(' ',@_))}; +my %split_fields = + (package => \&splitpackages, + affects => \&splitpackages, + # Ideally we won't have to split source, but because some consumers of + # get_bug_status cannot handle arrayref, we will split it here. + source => \&splitpackages, + blocks => $ditch_space_unique_and_sort, + blockedby => $ditch_space_unique_and_sort, + # this isn't strictly correct, but we'll split both of them for + # the time being until we ditch all use of keywords everywhere + # from the code + keywords => $ditch_space_unique_and_sort, + tags => $ditch_space_unique_and_sort, + found_versions => $ditch_space_unique_and_sort, + fixed_versions => $ditch_space_unique_and_sort, + mergedwith => $ditch_space_unique_and_sort, + ); + +sub split_status_fields { + my @data = @{dclone(\@_)}; + for my $data (@data) { + next if not defined $data; + croak "Passed an element which is not a hashref to split_status_field".ref($data) if + not (ref($data) and ref($data) eq 'HASH'); + for my $field (keys %{$data}) { + next unless defined $data->{$field}; + if (exists $split_fields{$field}) { + next if ref($data->{$field}); + my @elements; + if (ref($split_fields{$field}) eq 'CODE') { + @elements = &{$split_fields{$field}}($data->{$field}); + } + elsif (not ref($split_fields{$field}) or + UNIVERSAL::isa($split_fields{$field},'Regex') + ) { + @elements = split $split_fields{$field}, $data->{$field}; + } + $data->{$field} = \@elements; + } + } + } + return wantarray?@data:$data[0]; +} + +=head2 join_status_fields + + my @data = join_status_fields(@data); + +Handles joining the splitable status fields. (Basically, the inverse +of split_status_fields. + +Primarily called from makestatus, but may be useful for other +functions after calling split_status_fields (or for legacy functions +if we transition to split fields by default). + +=cut + +sub join_status_fields { + my %join_fields = + (package => ', ', + affects => ', ', + blocks => ' ', + blockedby => ' ', + tags => ' ', + found_versions => ' ', + fixed_versions => ' ', + found_date => ' ', + fixed_date => ' ', + mergedwith => ' ', + ); + my @data = @{dclone(\@_)}; + for my $data (@data) { + next if not defined $data; + croak "Passed an element which is not a hashref to split_status_field: ". + ref($data) + if ref($data) ne 'HASH'; + for my $field (keys %{$data}) { + next unless defined $data->{$field}; + next unless ref($data->{$field}) eq 'ARRAY'; + next unless exists $join_fields{$field}; + $data->{$field} = join($join_fields{$field},@{$data->{$field}}); + } + } + return wantarray?@data:$data[0]; +} + + +=head2 lockreadbug + + lockreadbug($bug_num,$location) + +Performs a filelock, then reads the bug; the bug is unlocked if the +return is undefined, otherwise, you need to call unfilelock or +unlockwritebug. + +See readbug above for information on what this returns + +=cut + +sub lockreadbug { + my ($lref, $location) = @_; + return read_bug(bug => $lref, location => $location, lock => 1); +} + +=head2 lockreadbugmerge + + my ($locks, $data) = lockreadbugmerge($bug_num,$location); + +Performs a filelock, then reads the bug. If the bug is merged, locks +the merge lock. Returns a list of the number of locks and the bug +data. + +=cut + +sub lockreadbugmerge { + my $data = lockreadbug(@_); + if (not defined $data) { + return (0,undef); + } + if (not length $data->{mergedwith}) { + return (1,$data); + } + unfilelock(); + filelock("$config{spool_dir}/lock/merge"); + $data = lockreadbug(@_); + if (not defined $data) { + unfilelock(); + return (0,undef); + } + return (2,$data); +} + +=head2 lock_read_all_merged_bugs + + my ($locks,@bug_data) = lock_read_all_merged_bugs($bug_num,$location); + +Performs a filelock, then reads the bug passed. If the bug is merged, +locks the merge lock, then reads and locks all of the other merged +bugs. Returns a list of the number of locks and the bug data for all +of the merged bugs. + +Will also return undef if any of the merged bugs failed to be read, +even if all of the others were read properly. + +=cut + +sub lock_read_all_merged_bugs { + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + location => {type => SCALAR, + optional => 1, + }, + locks => {type => HASHREF, + optional => 1, + }, + }, + ); + my $locks = 0; + my @data = read_bug(bug => $param{bug}, + lock => 1, + exists $param{location} ? (location => $param{location}):(), + exists $param{locks} ? (locks => $param{locks}):(), + ); + if (not @data or not defined $data[0]) { + return ($locks,()); + } + $locks++; + if (not length $data[0]->{mergedwith}) { + return ($locks,@data); + } + unfilelock(exists $param{locks}?$param{locks}:()); + $locks--; + filelock("$config{spool_dir}/lock/merge",exists $param{locks}?$param{locks}:()); + $locks++; + @data = read_bug(bug => $param{bug}, + lock => 1, + exists $param{location} ? (location => $param{location}):(), + exists $param{locks} ? (locks => $param{locks}):(), + ); + if (not @data or not defined $data[0]) { + unfilelock(exists $param{locks}?$param{locks}:()); #for merge lock above + $locks--; + return ($locks,()); + } + $locks++; + my @bugs = split / /, $data[0]->{mergedwith}; + push @bugs, $param{bug}; + for my $bug (@bugs) { + my $newdata = undef; + if ($bug != $param{bug}) { + $newdata = + read_bug(bug => $bug, + lock => 1, + exists $param{location} ? (location => $param{location}):(), + exists $param{locks} ? (locks => $param{locks}):(), + ); + if (not defined $newdata) { + for (1..$locks) { + unfilelock(exists $param{locks}?$param{locks}:()); + } + $locks = 0; + warn "Unable to read bug: $bug while handling merged bug: $param{bug}"; + return ($locks,()); + } + $locks++; + push @data,$newdata; + # perform a sanity check to make sure that the merged bugs + # are all merged with eachother + # We do a cmp sort instead of an <=> sort here, because that's + # what merge does + my $expectmerge= + join(' ',grep {$_ != $bug } + sort { $a <=> $b } + @bugs); + if ($newdata->{mergedwith} ne $expectmerge) { + for (1..$locks) { + unfilelock(exists $param{locks}?$param{locks}:()); + } + die "Bug $param{bug} mergedwith differs from bug $bug: ($newdata->{bug_num}: '$newdata->{mergedwith}') vs. ('$expectmerge') (".join(' ',@bugs).")"; + } + } + } + return ($locks,@data); +} + +=head2 new_bug + + my $new_bug_num = new_bug(copy => $data->{bug_num}); + +Creates a new bug and returns the new bug number upon success. + +Dies upon failures. + +=cut + +sub new_bug { + my %param = + validate_with(params => \@_, + spec => {copy => {type => SCALAR, + regex => qr/^\d+/, + optional => 1, + }, + }, + ); + filelock("nextnumber.lock"); + my $nn_fh = IO::File->new("nextnumber",'r') or + die "Unable to open nextnuber for reading: $!"; + local $\; + my $nn = <$nn_fh>; + ($nn) = $nn =~ m/^(\d+)\n$/ or die "Bad format of nextnumber; is not exactly ".'^\d+\n$'; + close $nn_fh; + overwritefile("nextnumber", + ($nn+1)."\n"); + unfilelock(); + my $nn_hash = get_hashname($nn); + if ($param{copy}) { + my $c_hash = get_hashname($param{copy}); + for my $file (qw(log status summary report)) { + copy("db-h/$c_hash/$param{copy}.$file", + "db-h/$nn_hash/${nn}.$file") + } + } + else { + for my $file (qw(log status summary report)) { + overwritefile("db-h/$nn_hash/${nn}.$file", + ""); + } + } + + # this probably needs to be munged to do something more elegant +# &bughook('new', $clone, $data); + + return($nn); +} + + + +my @v1fieldorder = qw(originator date subject msgid package + keywords done forwarded mergedwith severity); + +=head2 makestatus + + my $content = makestatus($status,$version) + my $content = makestatus($status); + +Creates the content for a status file based on the $status hashref +passed. + +Really only useful for writebug + +Currently defaults to version 2 (non-encoded rfc1522 names) but will +eventually default to version 3. If you care, you should specify a +version. + +=cut + +sub makestatus { + my ($data,$version) = @_; + $version = 3 unless defined $version; + + my $contents = ''; + + my %newdata = %$data; + for my $field (qw(found fixed)) { + if (exists $newdata{$field}) { + $newdata{"${field}_date"} = + [map {$newdata{$field}{$_}||''} keys %{$newdata{$field}}]; + } + } + %newdata = %{join_status_fields(\%newdata)}; + + %newdata = encode_utf8_structure(%newdata); + + if ($version < 3) { + for my $field (@rfc1522_fields) { + $newdata{$field} = encode_rfc1522($newdata{$field}); + } + } + + # this is a bit of a hack; we should never, ever have \r or \n in + # the fields of status. Kill them off here. [Eventually, this + # should be superfluous.] + for my $field (keys %newdata) { + $newdata{$field} =~ s/[\r\n]//g if defined $newdata{$field}; + } + + if ($version == 1) { + for my $field (@v1fieldorder) { + if (exists $newdata{$field} and defined $newdata{$field}) { + $contents .= "$newdata{$field}\n"; + } else { + $contents .= "\n"; + } + } + } elsif ($version == 2 or $version == 3) { + # Version 2 or 3. Add a file format version number for the sake of + # further extensibility in the future. + $contents .= "Format-Version: $version\n"; + for my $field (keys %fields) { + if (exists $newdata{$field} and defined $newdata{$field} + and $newdata{$field} ne '') { + # Output field names in proper case, e.g. 'Merged-With'. + my $properfield = $fields{$field}; + $properfield =~ s/(?:^|(?<=-))([a-z])/\u$1/g; + my $data = $newdata{$field}; + $contents .= "$properfield: $data\n"; + } + } + } + return $contents; +} + +=head2 writebug + + writebug($bug_num,$status,$location,$minversion,$disablebughook) + +Writes the bug status and summary files out. + +Skips writing out a status file if minversion is 2 + +Does not call bughook if disablebughook is true. + +=cut + +sub writebug { + my ($ref, $data, $location, $minversion, $disablebughook) = @_; + my $change; + + my %outputs = (1 => 'status', 3 => 'summary'); + for my $version (keys %outputs) { + next if defined $minversion and $version < $minversion; + my $status = getbugcomponent($ref, $outputs{$version}, $location); + die "can't find location for $ref" unless defined $status; + my $sfh; + if ($version >= 3) { + open $sfh,">","$status.new" or + die "opening $status.new: $!"; + } + else { + open $sfh,">","$status.new" or + die "opening $status.new: $!"; + } + print {$sfh} makestatus($data, $version) or + die "writing $status.new: $!"; + close($sfh) or die "closing $status.new: $!"; + if (-e $status) { + $change = 'change'; + } else { + $change = 'new'; + } + rename("$status.new",$status) || die "installing new $status: $!"; + } + + # $disablebughook is a bit of a hack to let format migration scripts use + # this function rather than having to duplicate it themselves. + &bughook($change,$ref,$data) unless $disablebughook; +} + +=head2 unlockwritebug + + unlockwritebug($bug_num,$status,$location,$minversion,$disablebughook); + +Writes a bug, then calls unfilelock; see writebug for what these +options mean. + +=cut + +sub unlockwritebug { + writebug(@_); + unfilelock(); +} + +=head1 VERSIONS + +The following functions are exported with the :versions tag + +=head2 addfoundversions + + addfoundversions($status,$package,$version,$isbinary); + +All use of this should be phased out in favor of Debbugs::Control::fixed/found + +=cut + + +sub addfoundversions { + my $data = shift; + my $package = shift; + my $version = shift; + my $isbinary = shift; + return unless defined $version; + undef $package if defined $package and $package =~ m[(?:\s|/)]; + my $source = $package; + if (defined $package and $package =~ s/^src://) { + $isbinary = 0; + $source = $package; + } + + if (defined $package and $isbinary) { + my @srcinfo = binary_to_source(binary => $package, + version => $version); + if (@srcinfo) { + # We know the source package(s). Use a fully-qualified version. + addfoundversions($data, $_->[0], $_->[1], '') foreach @srcinfo; + return; + } + # Otherwise, an unqualified version will have to do. + undef $source; + } + + # Strip off various kinds of brain-damage. + $version =~ s/;.*//; + $version =~ s/ *\(.*\)//; + $version =~ s/ +[A-Za-z].*//; + + foreach my $ver (split /[,\s]+/, $version) { + my $sver = defined($source) ? "$source/$ver" : ''; + unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{found_versions}}) { + push @{$data->{found_versions}}, defined($source) ? $sver : $ver; + } + @{$data->{fixed_versions}} = + grep { $_ ne $ver and $_ ne $sver } @{$data->{fixed_versions}}; + } +} + +=head2 removefoundversions + + removefoundversions($data,$package,$versiontoremove) + +Removes found versions from $data + +If a version is fully qualified (contains /) only versions matching +exactly are removed. Otherwise, all versions matching the version +number are removed. + +Currently $package and $isbinary are entirely ignored, but accepted +for backwards compatibility. + +=cut + +sub removefoundversions { + my $data = shift; + my $package = shift; + my $version = shift; + my $isbinary = shift; + return unless defined $version; + + foreach my $ver (split /[,\s]+/, $version) { + if ($ver =~ m{/}) { + # fully qualified version + @{$data->{found_versions}} = + grep {$_ ne $ver} + @{$data->{found_versions}}; + } + else { + # non qualified version; delete all matchers + @{$data->{found_versions}} = + grep {$_ !~ m[(?:^|/)\Q$ver\E$]} + @{$data->{found_versions}}; + } + } +} + + +sub addfixedversions { + my $data = shift; + my $package = shift; + my $version = shift; + my $isbinary = shift; + return unless defined $version; + undef $package if defined $package and $package =~ m[(?:\s|/)]; + my $source = $package; + + if (defined $package and $isbinary) { + my @srcinfo = binary_to_source(binary => $package, + version => $version); + if (@srcinfo) { + # We know the source package(s). Use a fully-qualified version. + addfixedversions($data, $_->[0], $_->[1], '') foreach @srcinfo; + return; + } + # Otherwise, an unqualified version will have to do. + undef $source; + } + + # Strip off various kinds of brain-damage. + $version =~ s/;.*//; + $version =~ s/ *\(.*\)//; + $version =~ s/ +[A-Za-z].*//; + + foreach my $ver (split /[,\s]+/, $version) { + my $sver = defined($source) ? "$source/$ver" : ''; + unless (grep { $_ eq $ver or $_ eq $sver } @{$data->{fixed_versions}}) { + push @{$data->{fixed_versions}}, defined($source) ? $sver : $ver; + } + @{$data->{found_versions}} = + grep { $_ ne $ver and $_ ne $sver } @{$data->{found_versions}}; + } +} + +sub removefixedversions { + my $data = shift; + my $package = shift; + my $version = shift; + my $isbinary = shift; + return unless defined $version; + + foreach my $ver (split /[,\s]+/, $version) { + if ($ver =~ m{/}) { + # fully qualified version + @{$data->{fixed_versions}} = + grep {$_ ne $ver} + @{$data->{fixed_versions}}; + } + else { + # non qualified version; delete all matchers + @{$data->{fixed_versions}} = + grep {$_ !~ m[(?:^|/)\Q$ver\E$]} + @{$data->{fixed_versions}}; + } + } +} + + + +=head2 splitpackages + + splitpackages($pkgs) + +Split a package string from the status file into a list of package names. + +=cut + +sub splitpackages { + my $pkgs = shift; + return unless defined $pkgs; + return grep {length $_} map lc, split /[\s,()?]+/, $pkgs; +} + + +=head2 bug_archiveable + + bug_archiveable(bug => $bug_num); + +Options + +=over + +=item bug -- bug number (required) + +=item status -- Status hashref returned by read_bug or get_bug_status (optional) + +=item version -- Debbugs::Version information (optional) + +=item days_until -- return days until the bug can be archived + +=back + +Returns 1 if the bug can be archived +Returns 0 if the bug cannot be archived + +If days_until is true, returns the number of days until the bug can be +archived, -1 if it cannot be archived. 0 means that the bug can be +archived the next time the archiver runs. + +Returns undef on failure. + +=cut + +# This will eventually need to be fixed before we start using mod_perl +our $version_cache = {}; +sub bug_archiveable{ + state $spec = {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + status => {type => HASHREF, + optional => 1, + }, + days_until => {type => BOOLEAN, + default => 0, + }, + ignore_time => {type => BOOLEAN, + default => 0, + }, + schema => {type => OBJECT, + optional => 1, + }, + }; + my %param = validate_with(params => \@_, + spec => $spec, + ); + # This is what we return if the bug cannot be archived. + my $cannot_archive = $param{days_until}?-1:0; + # read the status information + my $status = $param{status}; + if (not exists $param{status} or not defined $status) { + $status = read_bug(bug=>$param{bug}); + if (not defined $status) { + print STDERR "Cannot archive $param{bug} because it does not exist\n" if $DEBUG; + return undef; + } + } + # Bugs can be archived if they are + # 1. Closed + if (not defined $status->{done} or not length $status->{done}) { + print STDERR "Cannot archive $param{bug} because it is not done\n" if $DEBUG; + return $cannot_archive + } + # Check to make sure that the bug has none of the unremovable tags set + if (@{$config{removal_unremovable_tags}}) { + for my $tag (split ' ', ($status->{keywords}||'')) { + if (grep {$tag eq $_} @{$config{removal_unremovable_tags}}) { + print STDERR "Cannot archive $param{bug} because it has an unremovable tag '$tag'\n" if $DEBUG; + return $cannot_archive; + } + } + } + + # If we just are checking if the bug can be archived, we'll not even bother + # checking the versioning information if the bug has been -done for less than 28 days. + my $log_file = getbugcomponent($param{bug},'log'); + if (not defined $log_file or not -e $log_file) { + print STDERR "Cannot archive $param{bug} because the log doesn't exist\n" if $DEBUG; + return $cannot_archive; + } + my @log_files = $log_file, (map {my $log = getbugcomponent($_,'log'); + defined $log ? ($log) : (); + } + split / /, $status->{mergedwith}); + my $max_log_age = max(map {-e $_?($config{remove_age} - -M _):0} + @log_files); + if (not $param{days_until} and not $param{ignore_time} + and $max_log_age > 0 + ) { + print STDERR "Cannot archive $param{bug} because of time\n" if $DEBUG; + return $cannot_archive; + } + # At this point, we have to get the versioning information for this bug. + # We examine the set of distribution tags. If a bug has no distribution + # tags set, we assume a default set, otherwise we use the tags the bug + # has set. + + # In cases where we are assuming a default set, if the severity + # is strong, we use the strong severity default; otherwise, we + # use the normal default. + + # There must be fixed_versions for us to look at the versioning + # information + my $min_fixed_time = time; + my $min_archive_days = 0; + if (@{$status->{fixed_versions}}) { + my %dist_tags; + @dist_tags{@{$config{removal_distribution_tags}}} = + (1) x @{$config{removal_distribution_tags}}; + my %dists; + for my $tag (split ' ', ($status->{keywords}||'')) { + next unless exists $config{distribution_aliases}{$tag}; + next unless $dist_tags{$config{distribution_aliases}{$tag}}; + $dists{$config{distribution_aliases}{$tag}} = 1; + } + if (not keys %dists) { + if (isstrongseverity($status->{severity})) { + @dists{@{$config{removal_strong_severity_default_distribution_tags}}} = + (1) x @{$config{removal_strong_severity_default_distribution_tags}}; + } + else { + @dists{@{$config{removal_default_distribution_tags}}} = + (1) x @{$config{removal_default_distribution_tags}}; + } + } + my %source_versions; + my @sourceversions = get_versions(package => $status->{package}, + dist => [keys %dists], + source => 1, + hash_slice(%param,'schema'), + ); + @source_versions{@sourceversions} = (1) x @sourceversions; + # If the bug has not been fixed in the versions actually + # distributed, then it cannot be archived. + if ('found' eq max_buggy(bug => $param{bug}, + sourceversions => [keys %source_versions], + found => $status->{found_versions}, + fixed => $status->{fixed_versions}, + version_cache => $version_cache, + package => $status->{package}, + hash_slice(%param,'schema'), + )) { + print STDERR "Cannot archive $param{bug} because it's found\n" if $DEBUG; + return $cannot_archive; + } + # Since the bug has at least been fixed in the architectures + # that matters, we check to see how long it has been fixed. + + # If $param{ignore_time}, then we should ignore time. + if ($param{ignore_time}) { + return $param{days_until}?0:1; + } + + # To do this, we order the times from most recent to oldest; + # when we come to the first found version, we stop. + # If we run out of versions, we only report the time of the + # last one. + my %time_versions = get_versions(package => $status->{package}, + dist => [keys %dists], + source => 1, + time => 1, + hash_slice(%param,'schema'), + ); + for my $version (sort {$time_versions{$b} <=> $time_versions{$a}} keys %time_versions) { + my $buggy = buggy(bug => $param{bug}, + version => $version, + found => $status->{found_versions}, + fixed => $status->{fixed_versions}, + version_cache => $version_cache, + package => $status->{package}, + hash_slice(%param,'schema'), + ); + last if $buggy eq 'found'; + $min_fixed_time = min($time_versions{$version},$min_fixed_time); + } + $min_archive_days = max($min_archive_days,ceil($config{remove_age} - (time - $min_fixed_time)/(60*60*24))) + # if there are no versions in the archive at all, then + # we can archive if enough days have passed + if @sourceversions; + } + # If $param{ignore_time}, then we should ignore time. + if ($param{ignore_time}) { + return $param{days_until}?0:1; + } + # 6. at least 28 days have passed since the last action has occured or the bug was closed + my $age = ceil($max_log_age); + if ($age > 0 or $min_archive_days > 0) { + print STDERR "Cannot archive $param{bug} because not enough days have passed\n" if $DEBUG; + return $param{days_until}?max($age,$min_archive_days):0; + } + else { + return $param{days_until}?0:1; + } +} + + +=head2 get_bug_status + + my $status = get_bug_status(bug => $nnn); + + my $status = get_bug_status($bug_num) + +=head3 Options + +=over + +=item bug -- scalar bug number + +=item status -- optional hashref of bug status as returned by readbug +(can be passed to avoid rereading the bug information) + +=item bug_index -- optional tied index of bug status infomration; +currently not correctly implemented. + +=item version -- optional version(s) to check package status at + +=item dist -- optional distribution(s) to check package status at + +=item arch -- optional architecture(s) to check package status at + +=item bugusertags -- optional hashref of bugusertags + +=item sourceversion -- optional arrayref of source/version; overrides +dist, arch, and version. [The entries in this array must be in the +"source/version" format.] Eventually this can be used to for caching. + +=item indicatesource -- if true, indicate which source packages this +bug could belong to (or does belong to in the case of bugs assigned to +a source package). Defaults to true. + +=back + +Note: Currently the version information is cached; this needs to be +changed before using this function in long lived programs. + +=head3 Returns + +Currently returns a hashref of status with the following keys. + +=over + +=item id -- bug number + +=item bug_num -- duplicate of id + +=item keywords -- tags set on the bug, including usertags if bugusertags passed. + +=item tags -- duplicate of keywords + +=item package -- name of package that the bug is assigned to + +=item severity -- severity of the bug + +=item pending -- pending state of the bug; one of following possible +values; values listed later have precedence if multiple conditions are +satisifed: + +=over + +=item pending -- default state + +=item forwarded -- bug has been forwarded + +=item pending-fixed -- bug is tagged pending + +=item fixed -- bug is tagged fixed + +=item absent -- bug does not apply to this distribution/architecture + +=item done -- bug is resolved in this distribution/architecture + +=back + +=item location -- db-h or archive; the location in the filesystem + +=item subject -- title of the bug + +=item last_modified -- epoch that the bug was last modified + +=item date -- epoch that the bug was filed + +=item originator -- bug reporter + +=item log_modified -- epoch that the log file was last modified + +=item msgid -- Message id of the original bug report + +=back + + +Other key/value pairs are returned but are not currently documented here. + +=cut + +sub get_bug_status { + if (@_ == 1) { + unshift @_, 'bug'; + } + state $spec = + {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + status => {type => HASHREF, + optional => 1, + }, + bug_index => {type => OBJECT, + optional => 1, + }, + version => {type => SCALAR|ARRAYREF, + optional => 1, + }, + dist => {type => SCALAR|ARRAYREF, + optional => 1, + }, + arch => {type => SCALAR|ARRAYREF, + optional => 1, + }, + bugusertags => {type => HASHREF, + optional => 1, + }, + sourceversions => {type => ARRAYREF, + optional => 1, + }, + indicatesource => {type => BOOLEAN, + default => 1, + }, + binary_to_source_cache => {type => HASHREF, + optional => 1, + }, + schema => {type => OBJECT, + optional => 1, + }, + }; + my %param = validate_with(params => \@_, + spec => $spec, + ); + my %status; + + if (defined $param{bug_index} and + exists $param{bug_index}{$param{bug}}) { + %status = %{ $param{bug_index}{$param{bug}} }; + $status{pending} = $status{ status }; + $status{id} = $param{bug}; + return \%status; + } + my $statuses = get_bug_statuses(@_); + if (exists $statuses->{$param{bug}}) { + return $statuses->{$param{bug}}; + } else { + return {}; + } +} + +sub get_bug_statuses { + state $spec = + {bug => {type => SCALAR|ARRAYREF, + }, + status => {type => HASHREF, + optional => 1, + }, + bug_index => {type => OBJECT, + optional => 1, + }, + version => {type => SCALAR|ARRAYREF, + optional => 1, + }, + dist => {type => SCALAR|ARRAYREF, + optional => 1, + }, + arch => {type => SCALAR|ARRAYREF, + optional => 1, + }, + bugusertags => {type => HASHREF, + optional => 1, + }, + sourceversions => {type => ARRAYREF, + optional => 1, + }, + indicatesource => {type => BOOLEAN, + default => 1, + }, + binary_to_source_cache => {type => HASHREF, + optional => 1, + }, + schema => {type => OBJECT, + optional => 1, + }, + }; + my %param = validate_with(params => \@_, + spec => $spec, + ); + my $bin_to_src_cache = {}; + if (defined $param{binary_to_source_cache}) { + $bin_to_src_cache = $param{binary_to_source_cache}; + } + my %status; + my %statuses; + if (defined $param{schema}) { + my @bug_statuses = + $param{schema}->resultset('BugStatus')-> + search_rs({id => [make_list($param{bug})]}, + {result_class => 'DBIx::Class::ResultClass::HashRefInflator'})-> + all(); + for my $bug_status (@bug_statuses) { + $statuses{$bug_status->{bug_num}} = + $bug_status; + for my $field (qw(blocks blockedby done), + qw(tags mergedwith affects) + ) { + $bug_status->{$field} //=''; + } + $bug_status->{keywords} = + $bug_status->{tags}; + $bug_status->{location} = $bug_status->{archived}?'archive':'db-h'; + for my $field (qw(found_versions fixed_versions found_date fixed_date)) { + $bug_status->{$field} = [split ' ', $bug_status->{$field} // '']; + } + for my $field (qw(found fixed)) { + # create the found/fixed hashes which indicate when a + # particular version was marked found or marked fixed. + @{$bug_status->{$field}}{@{$bug_status->{"${field}_versions"}}} = + (('') x (@{$bug_status->{"${field}_versions"}} - + @{$bug_status->{"${field}_date"}}), + @{$bug_status->{"${field}_date"}}); + } + $bug_status->{id} = $bug_status->{bug_num}; + } + } else { + for my $bug (make_list($param{bug})) { + if (defined $param{bug_index} and + exists $param{bug_index}{$bug}) { + my %status = %{$param{bug_index}{$bug}}; + $status{pending} = $status{status}; + $status{id} = $bug; + $statuses{$bug} = \%status; + } + elsif (defined $param{status} and + $param{status}{bug_num} == $bug + ) { + $statuses{$bug} = {%{$param{status}}}; + } else { + my $location = getbuglocation($bug, 'summary'); + next if not defined $location or not length $location; + my %status = %{ readbug( $bug, $location ) }; + $status{id} = $bug; + $statuses{$bug} = \%status; + } + } + } + for my $bug (keys %statuses) { + my $status = $statuses{$bug}; + + if (defined $param{bugusertags}{$param{bug}}) { + $status->{keywords} = "" unless defined $status->{keywords}; + $status->{keywords} .= " " unless $status->{keywords} eq ""; + $status->{keywords} .= join(" ", @{$param{bugusertags}{$param{bug}}}); + } + $status->{tags} = $status->{keywords}; + my %tags = map { $_ => 1 } split ' ', $status->{tags}; + + $status->{package} = '' if not defined $status->{package}; + $status->{"package"} =~ s/\s*$//; + + $status->{"package"} = 'unknown' if ($status->{"package"} eq ''); + $status->{"severity"} = 'normal' if (not defined $status->{severity} or $status->{"severity"} eq ''); + + $status->{"pending"} = 'pending'; + $status->{"pending"} = 'forwarded' if (length($status->{"forwarded"})); + $status->{"pending"} = 'pending-fixed' if ($tags{pending}); + $status->{"pending"} = 'fixed' if ($tags{fixed}); + + + my $presence = bug_presence(status => $status, + bug => $bug, + map{(exists $param{$_})?($_,$param{$_}):()} + qw(sourceversions arch dist version found fixed package) + ); + if (defined $presence) { + if ($presence eq 'fixed') { + $status->{pending} = 'done'; + } elsif ($presence eq 'absent') { + $status->{pending} = 'absent'; + } + } + } + return \%statuses; +} + +=head2 bug_presence + + my $precence = bug_presence(bug => nnn, + ... + ); + +Returns 'found', 'absent', 'fixed' or undef based on whether the bug +is found, absent, fixed, or no information is available in the +distribution (dist) and/or architecture (arch) specified. + + +=head3 Options + +=over + +=item bug -- scalar bug number + +=item status -- optional hashref of bug status as returned by readbug +(can be passed to avoid rereading the bug information) + +=item bug_index -- optional tied index of bug status infomration; +currently not correctly implemented. + +=item version -- optional version to check package status at + +=item dist -- optional distribution to check package status at + +=item arch -- optional architecture to check package status at + +=item sourceversion -- optional arrayref of source/version; overrides +dist, arch, and version. [The entries in this array must be in the +"source/version" format.] Eventually this can be used to for caching. + +=back + +=cut + +sub bug_presence { + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + status => {type => HASHREF, + optional => 1, + }, + version => {type => SCALAR|ARRAYREF, + optional => 1, + }, + dist => {type => SCALAR|ARRAYREF, + optional => 1, + }, + arch => {type => SCALAR|ARRAYREF, + optional => 1, + }, + sourceversions => {type => ARRAYREF, + optional => 1, + }, + }, + ); + my %status; + if (defined $param{status}) { + %status = %{$param{status}}; + } + else { + my $location = getbuglocation($param{bug}, 'summary'); + return {} if not length $location; + %status = %{ readbug( $param{bug}, $location ) }; + } + + my @sourceversions; + my $pseudo_desc = getpseudodesc(); + if (not exists $param{sourceversions}) { + my %sourceversions; + # pseudopackages do not have source versions by definition. + if (exists $pseudo_desc->{$status{package}}) { + # do nothing. + } + elsif (defined $param{version}) { + foreach my $arch (make_list($param{arch})) { + for my $package (split /\s*,\s*/, $status{package}) { + my @temp = makesourceversions($package, + $arch, + make_list($param{version}) + ); + @sourceversions{@temp} = (1) x @temp; + } + } + } elsif (defined $param{dist}) { + my %affects_distribution_tags; + @affects_distribution_tags{@{$config{affects_distribution_tags}}} = + (1) x @{$config{affects_distribution_tags}}; + my $some_distributions_disallowed = 0; + my %allowed_distributions; + for my $tag (split ' ', ($status{keywords}||'')) { + if (exists $config{distribution_aliases}{$tag} and + exists $affects_distribution_tags{$config{distribution_aliases}{$tag}}) { + $some_distributions_disallowed = 1; + $allowed_distributions{$config{distribution_aliases}{$tag}} = 1; + } + elsif (exists $affects_distribution_tags{$tag}) { + $some_distributions_disallowed = 1; + $allowed_distributions{$tag} = 1; + } + } + my @archs = make_list(exists $param{arch}?$param{arch}:()); + GET_SOURCE_VERSIONS: + foreach my $arch (@archs) { + for my $package (split /\s*,\s*/, $status{package}) { + my @versions = (); + my $source = 0; + if ($package =~ /^src:(.+)$/) { + $source = 1; + $package = $1; + } + foreach my $dist (make_list(exists $param{dist}?$param{dist}:[])) { + # if some distributions are disallowed, + # and this isn't an allowed + # distribution, then we ignore this + # distribution for the purposees of + # finding versions + if ($some_distributions_disallowed and + not exists $allowed_distributions{$dist}) { + next; + } + push @versions, get_versions(package => $package, + dist => $dist, + ($source?(arch => 'source'): + (defined $arch?(arch => $arch):())), + ); + } + next unless @versions; + my @temp = make_source_versions(package => $package, + arch => $arch, + versions => \@versions, + ); + @sourceversions{@temp} = (1) x @temp; + } + } + # this should really be split out into a subroutine, + # but it'd touch so many things currently, that we fake + # it; it's needed to properly handle bugs which are + # erroneously assigned to the binary package, and we'll + # probably have it go away eventually. + if (not keys %sourceversions and (not @archs or defined $archs[0])) { + @archs = (undef); + goto GET_SOURCE_VERSIONS; + } + } + + # TODO: This should probably be handled further out for efficiency and + # for more ease of distinguishing between pkg= and src= queries. + # DLA: src= queries should just pass arch=source, and they'll be happy. + @sourceversions = keys %sourceversions; + } + else { + @sourceversions = @{$param{sourceversions}}; + } + my $maxbuggy = 'undef'; + if (@sourceversions) { + $maxbuggy = max_buggy(bug => $param{bug}, + sourceversions => \@sourceversions, + found => $status{found_versions}, + fixed => $status{fixed_versions}, + package => $status{package}, + version_cache => $version_cache, + ); + } + elsif (defined $param{dist} and + not exists $pseudo_desc->{$status{package}}) { + return 'absent'; + } + if (length($status{done}) and + (not @sourceversions or not @{$status{fixed_versions}})) { + return 'fixed'; + } + return $maxbuggy; +} + + +=head2 max_buggy + + max_buggy() + +=head3 Options + +=over + +=item bug -- scalar bug number + +=item sourceversion -- optional arrayref of source/version; overrides +dist, arch, and version. [The entries in this array must be in the +"source/version" format.] Eventually this can be used to for caching. + +=back + +Note: Currently the version information is cached; this needs to be +changed before using this function in long lived programs. + + +=cut +sub max_buggy{ + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + sourceversions => {type => ARRAYREF, + default => [], + }, + found => {type => ARRAYREF, + default => [], + }, + fixed => {type => ARRAYREF, + default => [], + }, + package => {type => SCALAR, + }, + version_cache => {type => HASHREF, + default => {}, + }, + schema => {type => OBJECT, + optional => 1, + }, + }, + ); + # Resolve bugginess states (we might be looking at multiple + # architectures, say). Found wins, then fixed, then absent. + my $maxbuggy = 'absent'; + for my $package (split /\s*,\s*/, $param{package}) { + for my $version (@{$param{sourceversions}}) { + my $buggy = buggy(bug => $param{bug}, + version => $version, + found => $param{found}, + fixed => $param{fixed}, + version_cache => $param{version_cache}, + package => $package, + ); + if ($buggy eq 'found') { + return 'found'; + } elsif ($buggy eq 'fixed') { + $maxbuggy = 'fixed'; + } + } + } + return $maxbuggy; +} + + +=head2 buggy + + buggy(bug => nnn, + found => \@found, + fixed => \@fixed, + package => 'foo', + version => '1.0', + ); + +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. + +Caching can be had by using the version_cache, but no attempt to check +to see if the on disk information is more recent than the cache is +made. [This will need to be fixed for long-lived processes.] + +=cut + +sub buggy { + my %param = validate_with(params => \@_, + spec => {bug => {type => SCALAR, + regex => qr/^\d+$/, + }, + found => {type => ARRAYREF, + default => [], + }, + fixed => {type => ARRAYREF, + default => [], + }, + version_cache => {type => HASHREF, + optional => 1, + }, + package => {type => SCALAR, + }, + version => {type => SCALAR, + }, + schema => {type => OBJECT, + optional => 1, + }, + }, + ); + my @found = @{$param{found}}; + my @fixed = @{$param{fixed}}; + if (grep {$_ !~ m{/}} (@{$param{found}}, @{$param{fixed}})) { + # We have non-source version versions + @found = makesourceversions($param{package},undef, + @found + ); + @fixed = makesourceversions($param{package},undef, + @fixed + ); + } + if ($param{version} !~ m{/}) { + my ($version) = makesourceversions($param{package},undef, + $param{version} + ); + $param{version} = $version if defined $version; + } + # Figure out which source packages we need + my %sources; + @sources{map {m{(.+)/}; $1} @found} = (1) x @found; + @sources{map {m{(.+)/}; $1} @fixed} = (1) x @fixed; + @sources{map {m{(.+)/}; $1} $param{version}} = 1 if + $param{version} =~ m{/}; + my $version; + if (not defined $param{version_cache} or + not exists $param{version_cache}{join(',',sort keys %sources)}) { + $version = Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp); + foreach my $source (keys %sources) { + my $srchash = substr $source, 0, 1; + my $version_fh = IO::File->new("$config{version_packages_dir}/$srchash/$source", 'r'); + if (not defined $version_fh) { + # We only want to warn if it's a package which actually has a maintainer + my @maint = package_maintainer(source => $source, + hash_slice(%param,'schema'), + ); + next unless @maint; + warn "Bug $param{bug}: unable to open $config{version_packages_dir}/$srchash/$source: $!"; + next; + } + $version->load($version_fh); + } + if (defined $param{version_cache}) { + $param{version_cache}{join(',',sort keys %sources)} = $version; + } + } + else { + $version = $param{version_cache}{join(',',sort keys %sources)}; + } + return $version->buggy($param{version},\@found,\@fixed); +} + +sub isstrongseverity { + my $severity = shift; + $severity = $config{default_severity} if + not defined $severity or $severity eq ''; + return grep { $_ eq $severity } @{$config{strong_severities}}; +} + +=head1 indexdb + +=head2 generate_index_db_line + + my $data = read_bug(bug => $bug, + location => $initialdir); + # generate_index_db_line hasn't been written yet at all. + my $line = generate_index_db_line($data); + +Returns a line for a bug suitable to be written out to index.db. + +=cut + +sub generate_index_db_line { + my ($data,$bug) = @_; + + # just in case someone has given us a split out data + $data = join_status_fields($data); + + my $whendone = "open"; + my $severity = $config{default_severity}; + (my $pkglist = $data->{package}) =~ s/[,\s]+/,/g; + $pkglist =~ s/^,+//; + $pkglist =~ s/,+$//; + $whendone = "forwarded" if defined $data->{forwarded} and length $data->{forwarded}; + $whendone = "done" if defined $data->{done} and length $data->{done}; + $severity = $data->{severity} if length $data->{severity}; + return sprintf "%s %d %d %s [%s] %s %s\n", + $pkglist, $data->{bug_num}//$bug, $data->{date}, $whendone, + $data->{originator}, $severity, $data->{keywords}; +} + + + +=head1 PRIVATE FUNCTIONS + +=cut + +sub update_realtime { + my ($file, %bugs) = @_; + + # update realtime index.db + + return () unless keys %bugs; + my $idx_old = IO::File->new($file,'r') + or die "Couldn't open ${file}: $!"; + my $idx_new = IO::File->new($file.'.new','w') + or die "Couldn't open ${file}.new: $!"; + + binmode($idx_old,':raw:utf8'); + binmode($idx_new,':raw:encoding(UTF-8)'); + my $min_bug = min(keys %bugs); + my $line; + my @line; + my %changed_bugs; + while($line = <$idx_old>) { + @line = split /\s/, $line; + # Two cases; replacing existing line or adding new line + if (exists $bugs{$line[1]}) { + my $new = $bugs{$line[1]}; + delete $bugs{$line[1]}; + $min_bug = min(keys %bugs); + if ($new eq "NOCHANGE") { + print {$idx_new} $line; + $changed_bugs{$line[1]} = $line; + } elsif ($new eq "REMOVE") { + $changed_bugs{$line[1]} = $line; + } else { + print {$idx_new} $new; + $changed_bugs{$line[1]} = $line; + } + } + else { + while ($line[1] > $min_bug) { + print {$idx_new} $bugs{$min_bug}; + delete $bugs{$min_bug}; + last unless keys %bugs; + $min_bug = min(keys %bugs); + } + print {$idx_new} $line; + } + last unless keys %bugs; + } + print {$idx_new} map {$bugs{$_}} sort keys %bugs; + + print {$idx_new} <$idx_old>; + + close($idx_new); + close($idx_old); + + rename("$file.new", $file); + + return %changed_bugs; +} + +sub bughook_archive { + my @refs = @_; + filelock("$config{spool_dir}/debbugs.trace.lock"); + appendfile("$config{spool_dir}/debbugs.trace","archive ".join(',',@refs)."\n"); + my %bugs = update_realtime("$config{spool_dir}/index.db.realtime", + map{($_,'REMOVE')} @refs); + update_realtime("$config{spool_dir}/index.archive.realtime", + %bugs); + unfilelock(); +} + +sub bughook { + my ( $type, %bugs_temp ) = @_; + filelock("$config{spool_dir}/debbugs.trace.lock"); + + my %bugs; + for my $bug (keys %bugs_temp) { + my $data = $bugs_temp{$bug}; + appendfile("$config{spool_dir}/debbugs.trace","$type $bug\n",makestatus($data, 1)); + + $bugs{$bug} = generate_index_db_line($data,$bug); + } + update_realtime("$config{spool_dir}/index.db.realtime", %bugs); + + unfilelock(); +} + + +1; + +__END__ diff --git a/lib/Debbugs/Text.pm b/lib/Debbugs/Text.pm new file mode 100644 index 0000000..53ecf04 --- /dev/null +++ b/lib/Debbugs/Text.pm @@ -0,0 +1,220 @@ +# 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 2007 by Don Armstrong . + +package Debbugs::Text; + +use warnings; +use strict; + +=head1 NAME + +Debbugs::Text -- General routines for text templates + +=head1 SYNOPSIS + + use Debbugs::Text qw(:templates); + print fill_in_template(template => 'cgi/foo'); + +=head1 DESCRIPTION + +This module is a replacement for parts of common.pl; subroutines in +common.pl will be gradually phased out and replaced with equivalent +(or better) functionality here. + +=head1 BUGS + +None known. + +=cut + + +use vars qw($DEBUG $VERSION @EXPORT_OK %EXPORT_TAGS @EXPORT @ISA); +use Exporter qw(import); + +BEGIN { + $VERSION = 1.00; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + %EXPORT_TAGS = (templates => [qw(fill_in_template)], + ); + @EXPORT_OK = (); + Exporter::export_ok_tags(qw(templates)); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + +use Text::Xslate qw(html_builder); + +use Storable qw(dclone); + +use Debbugs::Config qw(:config); + +use Params::Validate qw(:types validate_with); +use Carp; +use IO::File; +use Data::Dumper; + +### for %text_xslate_functions +use POSIX; +use Debbugs::CGI qw(html_escape); +use Scalar::Util; +use Debbugs::Common qw(make_list); +use Debbugs::Status; + +our %tt_templates; +our %filled_templates; +our $language; + + +sub __output_select_options { + my ($options,$value) = @_; + my @options = @{$options}; + my $output = ''; + while (@options) { + my ($o_value) = shift @options; + if (ref($o_value)) { + for (@{$o_value}) { + unshift @options, + ($_,$_); + } + next; + } + my $name = shift @options; + my $selected = ''; + if (defined $value and $o_value eq $value) { + $selected = ' selected'; + } + $output .= q(\n); + } + return $output; +} + +sub __text_xslate_functions { + return + {gm_strftime => sub {POSIX::strftime($_[0],gmtime)}, + package_links => html_builder(\&Debbugs::CGI::package_links), + bug_links => html_builder(\&Debbugs::CGI::bug_links), + looks_like_number => \&Scalar::Util::looks_like_number, + isstrongseverity => \&Debbugs::Status::isstrongseverity, + secs_to_english => \&Debbugs::Common::secs_to_english, + maybelink => \&Debbugs::CGI::maybelink, + # add in a few utility routines + duplicate_array => sub { + my @r = map {($_,$_)} make_list(@{$_[0]}); + return @r; + }, + output_select_options => html_builder(\&__output_select_options), + make_list => \&make_list, + }; +} +sub __text_xslate_functions_text { + return + {bugurl => + sub{ + return "$_[0]: ". + $config{cgi_domain}.'/'. + Debbugs::CGI::bug_links(bug=>$_[0], + links_only => 1, + ); + }, + }; +} + + + +### this function removes leading spaces from line-start code strings and spaces +### before <:- and spaces after -:> +sub __html_template_prefilter { + my $text = shift; + $text =~ s/^\s+:/:/mg; + $text =~ s/((?:^:[^\n]*\n)?)\s*(<:-)/$1$2/mg; + $text =~ s/(-:>)\s+(^:|)/$1.(length($2)?"\n$2":'')/emg; + return $text; +} + + +=head2 fill_in_template + + print fill_in_template(template => 'template_name', + variables => \%variables, + language => '..' + ); + +Reads a template from disk (if it hasn't already been read in) andf +ills the template in. + +=cut + +sub fill_in_template{ + my %param = validate_with(params => \@_, + spec => {template => SCALAR, + variables => {type => HASHREF, + default => {}, + }, + language => {type => SCALAR, + default => 'en_US', + }, + output => {type => HANDLE, + optional => 1, + }, + hole_var => {type => HASHREF, + optional => 1, + }, + output_type => {type => SCALAR, + default => 'html', + }, + }, + ); + # Get the text + my $output_type = $param{output_type}; + my $language = $param{language}; + my $template = $param{template}; + $template .= '.tx' unless $template =~ /\.tx$/; + my $tt; + if (not exists $tt_templates{$output_type}{$language} or + not defined $tt_templates{$output_type}{$language} + ) { + $tt_templates{$output_type}{$language} = + Text::Xslate->new(# cache in template_cache or temp directory + cache_dir => $config{template_cache} // + File::Temp::tempdir(CLEANUP => 1), + # default to the language, but fallback to en_US + path => [$config{template_dir}.'/'.$language.'/', + $config{template_dir}.'/en_US/', + ], + suffix => '.tx', + ## use html or text specific functions + function => + ($output_type eq 'html' ? __text_xslate_functions() : + __text_xslate_functions_text()), + syntax => 'Kolon', + module => ['Text::Xslate::Bridge::Star', + 'Debbugs::Text::XslateBridge', + ], + type => $output_type, + ## use the html-specific pre_process_handler + $output_type eq 'html'? + (pre_process_handler => \&__html_template_prefilter):(), + ) + or die "Unable to create Text::Xslate"; + } + $tt = $tt_templates{$output_type}{$language}; + my $ret = + $tt->render($template, + {time => time, + %{$param{variables}//{}}, + config => \%config, + }); + if (exists $param{output}) { + print {$param{output}} $ret; + return ''; + } + return $ret; +} + +1; diff --git a/lib/Debbugs/Text/XslateBridge.pm b/lib/Debbugs/Text/XslateBridge.pm new file mode 100644 index 0000000..14652c2 --- /dev/null +++ b/lib/Debbugs/Text/XslateBridge.pm @@ -0,0 +1,51 @@ +# 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::Text::XslateBridge; + +use warnings; +use strict; + +use base qw(Text::Xslate::Bridge); + +=head1 NAME + +Debbugs::Text::XslateBridge -- bridge for Xslate to add in useful functions + +=head1 DESCRIPTION + +This module provides bridge functionality to load functions into +Text::Xslate. It's loosely modeled after +Text::Xslate::Bridge::TT2Like, but with fewer functions. + +=head1 BUGS + +None known. + +=cut + + +use vars qw($VERSION); + +BEGIN { + $VERSION = 1.00; +} + +use Text::Xslate; + +__PACKAGE__-> + bridge(scalar => {length => \&__length, + }, + function => {length => \&__length,} + ); + +sub __length { + length $_[0]; +} + + +1; diff --git a/lib/Debbugs/URI.pm b/lib/Debbugs/URI.pm new file mode 100644 index 0000000..d7cf4f2 --- /dev/null +++ b/lib/Debbugs/URI.pm @@ -0,0 +1,105 @@ +# 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 2007 by Don Armstrong . +# query_form is +# Copyright 1995-2003 Gisle Aas. +# Copyright 1995 Martijn Koster. + + +package Debbugs::URI; + +=head1 NAME + +Debbugs::URI -- Derivative of URI which overrides the query_param + method to use ';' instead of '&' for separators. + +=head1 SYNOPSIS + +use Debbugs::URI; + +=head1 DESCRIPTION + +See L for more information. + +=head1 BUGS + +None known. + +=cut + +use warnings; +use strict; +use base qw(URI URI::_query); + +=head2 query_param + + $uri->query_form( $key1 => $val1, $key2 => $val2, ... ) + +Exactly like query_param in L except query elements are joined by +; instead of &. + +=cut + +{ + + package URI::_query; + + no warnings 'redefine'; + # Handle ...?foo=bar&bar=foo type of query + sub URI::_query::query_form { + my $self = shift; + my $old = $self->query; + if (@_) { + # Try to set query string + my @new = @_; + if (@new == 1) { + my $n = $new[0]; + if (ref($n) eq "ARRAY") { + @new = @$n; + } + elsif (ref($n) eq "HASH") { + @new = %$n; + } + } + my @query; + while (my($key,$vals) = splice(@new, 0, 2)) { + $key = '' unless defined $key; + $key =~ s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/g; + $key =~ s/ /+/g; + $vals = [ref($vals) eq "ARRAY" ? @$vals : $vals]; + for my $val (@$vals) { + $val = '' unless defined $val; + $val =~ s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/g; + $val =~ s/ /+/g; + push(@query, "$key=$val"); + } + } + # We've changed & to a ; here. + $self->query(@query ? join(';', @query) : undef); + } + return if !defined($old) || !length($old) || !defined(wantarray); + return unless $old =~ /=/; # not a form + map { s/\+/ /g; uri_unescape($_) } + # We've also changed the split here to split on ; as well as & + map { /=/ ? split(/=/, $_, 2) : ($_ => '')} split(/[&;]/, $old); + } +} + + + + + + +1; + + +__END__ + + + + + + diff --git a/lib/Debbugs/UTF8.pm b/lib/Debbugs/UTF8.pm new file mode 100644 index 0000000..01351f3 --- /dev/null +++ b/lib/Debbugs/UTF8.pm @@ -0,0 +1,226 @@ +# 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 2013 by Don Armstrong . + +package Debbugs::UTF8; + +=head1 NAME + +Debbugs::UTF8 -- Routines for handling conversion of charsets to UTF8 + +=head1 SYNOPSIS + +use Debbugs::UTF8; + + +=head1 DESCRIPTION + +This module contains routines which convert from various different +charsets to UTF8. + +=head1 FUNCTIONS + +=cut + +use warnings; +use strict; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use Exporter qw(import); + +BEGIN{ + $VERSION = 1.00; + $DEBUG = 0 unless defined $DEBUG; + + %EXPORT_TAGS = (utf8 => [qw(encode_utf8_structure encode_utf8_safely), + qw(convert_to_utf8 decode_utf8_safely)], + ); + @EXPORT = (@{$EXPORT_TAGS{utf8}}); + @EXPORT_OK = (); + Exporter::export_ok_tags(keys %EXPORT_TAGS); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + +use Carp; +$Carp::Verbose = 1; + +use Encode qw(encode_utf8 is_utf8 decode decode_utf8); +use Text::Iconv; +use Storable qw(dclone); + + +=head1 UTF-8 + +These functions are exported with the :utf8 tag + +=head2 encode_utf8_structure + + %newdata = encode_utf8_structure(%newdata); + +Takes a complex data structure and encodes any strings with is_utf8 +set into their constituent octets. + +=cut + +our $depth = 0; +sub encode_utf8_structure { + ++$depth; + my @ret; + for $_ (@_) { + if (ref($_) eq 'HASH') { + push @ret, {encode_utf8_structure(%{$depth == 1 ? dclone($_):$_})}; + } + elsif (ref($_) eq 'ARRAY') { + push @ret, [encode_utf8_structure(@{$depth == 1 ? dclone($_):$_})]; + } + elsif (ref($_)) { + # we don't know how to handle non hash or non arrays + push @ret,$_; + } + else { + push @ret,encode_utf8_safely($_); + } + } + --$depth; + return @ret; +} + +=head2 encode_utf8_safely + + $octets = encode_utf8_safely($string); + +Given a $string, returns the octet equivalent of $string if $string is +in perl's internal encoding; otherwise returns $string. + +Silently returns REFs without encoding them. [If you want to deeply +encode REFs, see encode_utf8_structure.] + +=cut + + +sub encode_utf8_safely{ + my @ret; + for my $r (@_) { + if (not ref($r) and is_utf8($r)) { + $r = encode_utf8($r); + } + push @ret,$r; + } + return wantarray ? @ret : (@_ > 1 ? @ret : $ret[0]); +} + +=head2 decode_utf8_safely + + $string = decode_utf8_safely($octets); + +Given $octets in UTF8, returns the perl-internal equivalent of $octets +if $octets does not have is_utf8 set; otherwise returns $octets. + +Silently returns REFs without encoding them. + +=cut + + +sub decode_utf8_safely{ + my @ret; + for my $r (@_) { + if (not ref($r) and not is_utf8($r)) { + $r = decode_utf8($r); + } + push @ret, $r; + } + return wantarray ? @ret : (@_ > 1 ? @ret : $ret[0]); +} + + + + +=head2 convert_to_utf8 + + $utf8 = convert_to_utf8("text","charset"); + +=cut + +sub convert_to_utf8 { + my ($data,$charset,$internal_call) = @_; + $internal_call //= 0; + if (is_utf8($data)) { + cluck("utf8 flag is set when calling convert_to_utf8"); + return $data; + } + $charset = uc($charset//'UTF-8'); + if ($charset eq 'RAW') { + croak("Charset must not be raw when calling convert_to_utf8"); + } + ## if the charset is unknown or unknown 8 bit, assume that it's UTF-8. + if ($charset =~ /unknown/i) { + $charset = 'UTF-8' + } + my $iconv_converter; + eval { + $iconv_converter = Text::Iconv->new($charset,"UTF-8") or + die "Unable to create converter for '$charset'"; + }; + if ($@) { + return undef if $internal_call; + warn $@; + # We weren't able to create the converter, so use Encode + # instead + return __fallback_convert_to_utf8($data,$charset); + } + my $converted_data = $iconv_converter->convert($data); + # if the conversion failed, retval will be undefined or perhaps + # -1. + my $retval = $iconv_converter->retval(); + if (not defined $retval or + $retval < 0 + ) { + # try iso8559-1 first + if (not $internal_call) { + my $call_back_data = convert_to_utf8($data,'ISO8859-1',1); + # if there's an à (0xC3), it's probably something + # horrible, and we shouldn't try to convert it. + if (defined $call_back_data and $call_back_data !~ /\x{C3}/) { + return $call_back_data; + } + } + # Fallback to encode, which will probably also fail. + return __fallback_convert_to_utf8($data,$charset); + } + return decode("UTF-8",$converted_data); +} + +# this returns data in perl's internal encoding +sub __fallback_convert_to_utf8 { + my ($data, $charset) = @_; + # raw data just gets returned (that's the charset WordDecorder + # uses when it doesn't know what to do) + return $data if $charset eq 'raw'; + if (not defined $charset and not is_utf8($data)) { + warn ("Undefined charset, and string '$data' is not in perl's internal encoding"); + return $data; + } + # lets assume everything that doesn't have a charset is utf8 + $charset //= 'utf8'; + ## if the charset is unknown, assume it's UTF-8 + if ($charset =~ /unknown/i) { + $charset = 'utf8'; + } + my $result; + eval { + $result = decode($charset,$data,0); + }; + if ($@) { + warn "Unable to decode charset; '$charset' and '$data': $@"; + return $data; + } + return $result; +} + + + +1; + +__END__ diff --git a/lib/Debbugs/User.pm b/lib/Debbugs/User.pm new file mode 100644 index 0000000..50a0965 --- /dev/null +++ b/lib/Debbugs/User.pm @@ -0,0 +1,452 @@ +# 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. +# +# [Other people have contributed to this file; their copyrights should +# go here too.] +# Copyright 2004 by Anthony Towns +# Copyright 2008 by Don Armstrong + + +package Debbugs::User; + +=head1 NAME + +Debbugs::User -- User settings + +=head1 SYNOPSIS + +use Debbugs::User qw(is_valid_user read_usertags write_usertags); + +Debbugs::User::is_valid_user($userid); + +$u = Debbugs::User::open($userid); +$u = Debbugs::User::open(user => $userid, locked => 0); + +$u = Debbugs::User::open(user => $userid, locked => 1); +$u->write(); + +$u->{"tags"} +$u->{"categories"} +$u->{"is_locked"} +$u->{"name"} + + +read_usertags(\%ut, $userid); +write_usertags(\%ut, $userid); + +=head1 USERTAG FILE FORMAT + +Usertags are in a file which has (roughly) RFC822 format, with stanzas +separated by newlines. For example: + + Tag: search + Bugs: 73671, 392392 + + Value: priority + Bug-73671: 5 + Bug-73487: 2 + + Value: bugzilla + Bug-72341: http://bugzilla/2039471 + Bug-1022: http://bugzilla/230941 + + Category: normal + Cat1: status + Cat2: debbugs.tasks + + Category: debbugs.tasks + Hidden: yes + Cat1: debbugs.tasks + + Cat1Options: + tag=quick + tag=medium + tag=arch + tag=not-for-me + + +=head1 EXPORT TAGS + +=over + +=item :all -- all functions that can be exported + +=back + +=head1 FUNCTIONS + +=cut + +use warnings; +use strict; +use Fcntl ':flock'; +use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use Exporter qw(import); + +use Debbugs::Config qw(:config); +use List::AllUtils qw(min); + +use Carp; +use IO::File; + +BEGIN { + ($VERSION) = q$Revision: 1.4 $ =~ /^Revision:\s+([^\s+])/; + $DEBUG = 0 unless defined $DEBUG; + + @EXPORT = (); + @EXPORT_OK = qw(is_valid_user read_usertags write_usertags); + $EXPORT_TAGS{all} = [@EXPORT_OK]; +} + + +####################################################################### +# Helper functions + +sub is_valid_user { + my $u = shift; + return ($u =~ /^[a-zA-Z0-9._+-]+[@][a-z0-9-.]{4,}$/); +} + +=head2 usertag_file_from_email + + my $filename = usertag_file_from_email($email) + +Turns an email into the filename where the usertag can be located. + +=cut + +sub usertag_file_from_email { + my ($email) = @_; + my $email_length = length($email) % 7; + my $escaped_email = $email; + $escaped_email =~ s/([^0-9a-zA-Z_+.-])/sprintf("%%%02X", ord($1))/eg; + return "$config{usertag_dir}/$email_length/$escaped_email"; +} + + +####################################################################### +# The real deal + +sub get_user { + return Debbugs::User->new(@_); +} + +=head2 new + + my $user = Debbugs::User->new('foo@bar.com',$lock); + +Reads the user file associated with 'foo@bar.com' and returns a +Debbugs::User object. + +=cut + +sub new { + my $class = shift; + $class = ref($class) || $class; + my ($email,$need_lock) = @_; + $need_lock ||= 0; + + my $ut = {}; + my $self = {"tags" => $ut, + "categories" => {}, + "visible_cats" => [], + "unknown_stanzas" => [], + values => {}, + bug_tags => {}, + email => $email, + }; + bless $self, $class; + + $self->{filename} = usertag_file_from_email($self->{email}); + if (not -r $self->{filename}) { + return $self; + } + my $uf = IO::File->new($self->{filename},'r') + or die "Unable to open file $self->{filename} for reading: $!"; + if ($need_lock) { + flock($uf, LOCK_EX); + $self->{"locked"} = $uf; + } + + while(1) { + my @stanza = _read_stanza($uf); + last unless @stanza; + if ($stanza[0] eq "Tag") { + my %tag = @stanza; + my $t = $tag{"Tag"}; + $ut->{$t} = [] unless defined $ut->{$t}; + my @bugs = split /\s*,\s*/, $tag{Bugs}; + push @{$ut->{$t}}, @bugs; + for my $bug (@bugs) { + push @{$self->{bug_tags}{$bug}}, + $t; + } + } elsif ($stanza[0] eq "Category") { + my @cat = (); + my %stanza = @stanza; + my $catname = $stanza{"Category"}; + my $i = 0; + while (++$i && defined $stanza{"Cat${i}"}) { + if (defined $stanza{"Cat${i}Options"}) { + # parse into a hash + my %c = ("nam" => $stanza{"Cat${i}"}); + $c{"def"} = $stanza{"Cat${i}Default"} + if defined $stanza{"Cat${i}Default"}; + if (defined $stanza{"Cat${i}Order"}) { + my @temp = split /\s*,\s*/, $stanza{"Cat${i}Order"}; + my %temp; + my $min = min(@temp); + # Order to 0 minimum; strip duplicates + $c{ord} = [map {$temp{$_}++; + $temp{$_}>1?():($_-$min); + } @temp + ]; + } + my @pri; my @ttl; + for my $l (split /\n/, $stanza{"Cat${i}Options"}) { + if ($l =~ m/^\s*(\S+)\s+-\s+(.*\S)\s*$/) { + push @pri, $1; + push @ttl, $2; + } elsif ($l =~ m/^\s*(\S+)\s*$/) { + push @pri, $1; + push @ttl, $1; + } + } + $c{"ttl"} = [@ttl]; + $c{"pri"} = [@pri]; + push @cat, { %c }; + } else { + push @cat, $stanza{"Cat${i}"}; + } + } + $self->{"categories"}->{$catname} = [@cat]; + push @{$self->{"visible_cats"}}, $catname + unless ($stanza{"Hidden"} || "no") eq "yes"; + } + elsif ($stanza[0] eq 'Value') { + my ($value,$value_name,%bug_values) = @stanza; + while (my ($k,$v) = each %bug_values) { + my ($bug) = $k =~ m/^Bug-(\d+)/; + next unless defined $bug; + $self->{values}{$bug}{$value_name} = $v; + } + } + else { + push @{$self->{"unknown_stanzas"}}, [@stanza]; + } + } + + return $self; +} + +sub email { + my $self = shift; + return $self->{email}; +} + +sub tags { + my $self = shift; + + return $self->{"tags"}; +} + +sub tags_on_bug { + my $self = shift; + return map {@{$self->{"bug_tags"}{$_}//[]}} @_; +} + +sub has_bug_tags { + my $self = shift; + return keys %{$self->{bug_tags}} > 0; +} + +sub write { + my $self = shift; + + my $ut = $self->{"tags"}; + my $p = $self->{"filename"}; + + if (not defined $self->{filename} or not + length $self->{filename}) { + carp "Tried to write a usertag with no filename defined"; + return; + } + my $uf = IO::File->new($self->{filename},'w'); + if (not $uf) { + carp "Unable to open $self->{filename} for writing: $!"; + return; + } + + for my $us (@{$self->{"unknown_stanzas"}}) { + my @us = @{$us}; + while (my ($k,$v) = splice (@us,0,2)) { + $v =~ s/\n/\n /g; + print {$uf} "$k: $v\n"; + } + print {$uf} "\n"; + } + + for my $t (keys %{$ut}) { + next if @{$ut->{$t}} == 0; + print {$uf} "Tag: $t\n"; + print {$uf} _wrap_to_length("Bugs: " . join(", ", @{$ut->{$t}}), 77) . "\n"; + print $uf "\n"; + } + + my $uc = $self->{"categories"}; + my %vis = map { $_, 1 } @{$self->{"visible_cats"}}; + for my $c (keys %{$uc}) { + next if @{$uc->{$c}} == 0; + + print $uf "Category: $c\n"; + print $uf "Hidden: yes\n" unless defined $vis{$c}; + my $i = 0; + for my $cat (@{$uc->{$c}}) { + $i++; + if (ref($cat) eq "HASH") { + printf $uf "Cat%d: %s\n", $i, $cat->{"nam"}; + printf $uf "Cat%dOptions:\n", $i; + for my $j (0..$#{$cat->{"pri"}}) { + if (defined $cat->{"ttl"}->[$j]) { + printf $uf " %s - %s\n", + $cat->{"pri"}->[$j], $cat->{"ttl"}->[$j]; + } else { + printf $uf " %s\n", $cat->{"pri"}->[$j]; + } + } + printf $uf "Cat%dDefault: %s\n", $i, $cat->{"def"} + if defined $cat->{"def"}; + printf $uf "Cat%dOrder: %s\n", $i, join(", ", @{$cat->{"ord"}}) + if defined $cat->{"ord"}; + } else { + printf $uf "Cat%d: %s\n", $i, $cat; + } + } + print $uf "\n"; + } + # handle the value stanzas + my %value; + # invert the bug->value hash slightly + for my $bug (keys %{$self->{values}}) { + for my $value (keys %{$self->{values}{$bug}}) { + $value{$value}{$bug} = $self->{values}{$bug}{$value} + } + } + for my $value (keys %value) { + print {$uf} "Value: $value\n"; + for my $bug (keys %{$value{$value}}) { + my $bug_value = $value{$value}{$bug}; + $bug_value =~ s/\n/\n /g; + print {$uf} "Bug-$bug: $bug_value\n"; + } + print {$uf} "\n"; + } + + close($uf); + delete $self->{"locked"}; +} + +=head1 OBSOLETE FUNCTIONS + +=cut + +=head2 read_usertags + + read_usertags($usertags,$email) + + +=cut + +sub read_usertags { + my ($usertags,$email) = @_; + +# carp "read_usertags is deprecated"; + my $user = get_user($email); + for my $tag (keys %{$user->{"tags"}}) { + $usertags->{$tag} = [] unless defined $usertags->{$tag}; + push @{$usertags->{$tag}}, @{$user->{"tags"}->{$tag}}; + } + return $usertags; +} + +=head2 write_usertags + + write_usertags($usertags,$email); + +Gets a lock on the usertags, applies the usertags passed, and writes +them out. + +=cut + +sub write_usertags { + my ($usertags,$email) = @_; + +# carp "write_usertags is deprecated"; + my $user = Debbugs::User->new($email,1); # locked + $user->{"tags"} = { %{$usertags} }; + $user->write(); +} + + +=head1 PRIVATE FUNCTIONS + +=head2 _read_stanza + + my @stanza = _read_stanza($fh); + +Reads a single stanza from a filehandle and returns it + +=cut + +sub _read_stanza { + my ($file_handle) = @_; + my $field = 0; + my @res; + while (<$file_handle>) { + chomp; + last if (m/^$/); + if ($field && m/^ (.*)$/) { + $res[-1] .= "\n" . $1; + } elsif (m/^([^:]+):(\s+(.*))?$/) { + $field = $1; + push @res, ($1, $3||''); + } + } + return @res; +} + + +=head2 _wrap_to_length + + _wrap_to_length + +Wraps a line to a specific length by splitting at commas + +=cut + +sub _wrap_to_length { + my ($content,$line_length) = @_; + my $current_line_length = 0; + my $result = ""; + while ($content =~ m/^([^,]*,\s*)(.*)$/ || $content =~ m/^([^,]+)()$/) { + my $current_word = $1; + $content = $2; + if ($current_line_length != 0 and + $current_line_length + length($current_word) <= $line_length) { + $result .= "\n "; + $current_line_length = 1; + } + $result .= $current_word; + $current_line_length += length($current_word); + } + return $result . $content; +} + + + + +1; + +__END__ diff --git a/lib/Debbugs/Version.pm b/lib/Debbugs/Version.pm new file mode 100644 index 0000000..71dc008 --- /dev/null +++ b/lib/Debbugs/Version.pm @@ -0,0 +1,220 @@ +# 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 + +This package provides a convenient interface to refer to package versions and +potentially make calculations based upon them + + use Debbugs::Version; + my $v = Debbugs::Version->new(schema => $s,binaries => [qw(foo)],sources => [qw(bar)]); + +=head1 DESCRIPTION + + + +=cut + +use Mouse; +use v5.10; +use strictures 2; +use namespace::autoclean; + +use Debbugs::Config qw(:config); +use Debbugs::Collection::Package; +use Debbugs::OOTypes; +use Carp; + +extends 'Debbugs::OOBase'; + +=head1 Object Creation + +=head2 my $version = Debbugs::Version::Source->new(%params|$param) + +or Cnew(%params|$param)> for a binary version + +=over + +=item schema + +L schema which can be used to look up versions + +=item package + +String representation of the package + +=item pkg + +L which refers to the package given. + +Only one of C or C should be given + +=item package_collection + +L which is used to generate a L +object from the package name + +=back + +=cut + +around BUILDARGS => sub { + my $orig = shift; + my $class = shift; + if ($class eq __PACKAGE__) { + confess("You should not be instantiating Debbugs::Version. ". + "Use Debbugs::Version::Source or ::Binary"); + } + my %args; + if (@_==1 and ref($_[0]) eq 'HASH') { + %args = %{$_[0]}; + } else { + %args = @_; + } + return $class->$orig(%args); +}; + + + +state $strong_severities = + {map {($_,1)} @{$config{strong_severities}}}; + +=head1 Methods + +=head2 version + + $version->version + +Returns the source or binary package version + +=cut + +has version => (is => 'ro', isa => 'Str', + required => 1, + builder => '_build_version', + predicate => '_has_version', + ); + +=head2 type + +Returns 'source' if this is a source version, or 'binary' if this is a binary +version. + +=cut + +=head2 source_version + +Returns the source version for this version; if this is a source version, +returns itself. + +=cut + +=head2 src_pkg_ver + +Returns the fully qualified source_package/version string for this version. + +=cut + +=head2 package + +Returns the name of the package that this version is in + +=cut + +has package => (is => 'ro', + isa => 'Str', + builder => '_build_package', + predicate => '_has_package', + lazy => 1, + ); + +sub _build_package { + my $self = shift; + if ($self->_has_pkg) { + return $self->pkg->name; + } + return '(unknown)'; +} + +=head2 pkg + +Returns a L object corresponding to C. + +=cut + + +has pkg => (is => 'ro', + isa => 'Debbugs::Package', + lazy => 1, + builder => '_build_pkg', + reader => 'pkg', + predicate => '_has_pkg', + ); + +sub _build_pkg { + my $self = shift; + return Debbugs::Package->new(package => $self->package, + type => $self->type, + valid => 0, + package_collection => $self->package_collection, + $self->schema_argument, + ); +} + + +=head2 valid + +Returns 1 if this package is valid, 0 otherwise. + +=cut + +has valid => (is => 'ro', + isa => 'Bool', + reader => 'is_valid', + lazy => 1, + builder => '_build_valid', + ); + +sub _build_valid { + my $self = shift; + return 0; +} + + +=head2 package_collection + +Returns the L which is in use by this version +object. + +=cut + +has 'package_collection' => (is => 'ro', + isa => 'Debbugs::Collection::Package', + builder => '_build_package_collection', + lazy => 1, + ); +sub _build_package_collection { + my $self = shift; + return Debbugs::Collection::Package->new($self->schema_arg) +} + + +__PACKAGE__->meta->make_immutable; +no Mouse; +1; + + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/lib/Debbugs/Version/Binary.pm b/lib/Debbugs/Version/Binary.pm new file mode 100644 index 0000000..25d7020 --- /dev/null +++ b/lib/Debbugs/Version/Binary.pm @@ -0,0 +1,97 @@ +# 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::Binary; + +=head1 NAME + +Debbugs::Version::Binary -- OO interface to Version + +=head1 SYNOPSIS + + use Debbugs::Version::Binary; + Debbugs::Version::Binary->new(schema => $s,binaries => [qw(foo)],sources => [qw(bar)]); + +=head1 DESCRIPTION + + + +=cut + +use Mouse; +use v5.10; +use strictures 2; +use namespace::autoclean; + +use Debbugs::Config qw(:config); +use Debbugs::Collection::Package; +use Debbugs::OOTypes; + +extends 'Debbugs::Version'; + +sub type { + return 'binary'; +} + +has source_version => (is => 'ro', + isa => 'Debbugs::Version::Source', + lazy => 1, + builder => '_build_source_version', + ); + +sub _build_source_version { + my $self = shift; + my $source_version = + $self->pkg-> + get_source_version(version => $self->version, + $self->_count_archs?(archs => [$self->_archs]):(), + ); + if (defined $source_version) { + return $source_version; + } + return Debbugs::Version::Source->new(version => $self->version, + package => '(unknown)', + valid => 0, + package_collection => $self->package_collection, + ); +} + +sub src_pkg_ver { + my $self = shift; + return $self->source->src_pkg_ver; +} + +has archs => (is => 'bare', + isa => 'ArrayRef[Str]', + builder => '_build_archs', + traits => ['Array'], + handles => {'_archs' => 'elements', + '_count_archs' => 'count', + }, + ); + +sub _build_archs { + my $self = shift; + # this is wrong, but we'll start like this for now + return ['any']; +} + +sub arch { + my $self = shift; + return $self->_count_archs > 0?join(',',$self->_archs):'any'; +} + + +__PACKAGE__->meta->make_immutable; +no Mouse; +1; + + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/lib/Debbugs/Version/Source.pm b/lib/Debbugs/Version/Source.pm new file mode 100644 index 0000000..a23959c --- /dev/null +++ b/lib/Debbugs/Version/Source.pm @@ -0,0 +1,71 @@ +# 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::Source; + +=head1 NAME + +Debbugs::Version::Source -- OO interface to Version + +=head1 SYNOPSIS + + use Debbugs::Version::Source; + Debbugs::Version::Source->new(schema => $s,binaries => [qw(foo)],sources => [qw(bar)]); + +=head1 DESCRIPTION + + + +=cut + +use Mouse; +use v5.10; +use strictures 2; +use namespace::autoclean; + +use Debbugs::Config qw(:config); +use Debbugs::Collection::Package; +use Debbugs::OOTypes; + +extends 'Debbugs::Version'; + +sub type { + return 'source'; +} + +sub source_version { + return $_[0]; +} + +sub src_pkg_ver { + my $self = shift; + return $self->package.'/'.$self->version; +} + +has maintainer => (is => 'ro', + isa => 'Str', + ); + +sub source { + my $self = shift; + return $self->pkg; +} + +sub arch { + return 'source'; +} + + +__PACKAGE__->meta->make_immutable; +no Mouse; +1; + + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/lib/Debbugs/VersionTree.pm b/lib/Debbugs/VersionTree.pm new file mode 100644 index 0000000..1231bd8 --- /dev/null +++ b/lib/Debbugs/VersionTree.pm @@ -0,0 +1,125 @@ +# 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::VersionTree; + +=head1 NAME + +Debbugs::VersionTree -- OO interface to Debbugs::Versions + +=head1 SYNOPSIS + + use Debbugs::VersionTree; + my $vt = Debbugs::VersionTree->new(); + +=head1 DESCRIPTION + + + +=cut + +use Mouse; +use v5.10; +use strictures 2; +use namespace::autoclean; + +use Debbugs::Config qw(:config); +use Debbugs::Versions; +use Carp; + +extends 'Debbugs::OOBase'; + +has _versions => (is => 'bare', + isa => 'Debbugs::Versions', + default => sub {Debbugs::Versions->new(\&Debbugs::Versions::Dpkg::vercmp)}, + handles => {_isancestor => 'isancestor', + _load => 'load', + _buggy => 'buggy', + _allstates => 'allstates', + }, + ); + +has loaded_src_pkg => (is => 'bare', + isa => 'HashRef[Bool]', + default => sub {{}}, + traits => ['Hash'], + handles => {src_pkg_loaded => 'exists', + _set_src_pkg_loaded => 'set', + }, + ); + +sub _srcify_version { + my @return; + for my $v (@_) { + if (ref($_)) { + push @return, + $v->source_version->src_pkg_ver; + } else { + push @return, + $v; + } + } + return @_ > 1?@return:$return[0]; +} + +sub isancestor { + my ($self,$ancestor,$descendant) = @_; + return $self->_isancestor(_srcify_version($ancestor), + _srcify_version($descendant), + ); +} + +sub buggy { + my $self = shift; + my ($version,$found,$fixed) = @_; + ($version) = _srcify_version($version); + $found = [_srcify_version(@{$found})]; + $fixed = [_srcify_version(@{$fixed})]; + return $self->_buggy($version,$found,$fixed); +} + +sub allstates { + my $self = shift; + my $found = shift; + my $fixed = shift; + my $interested = shift; + return $self->_allstates([_srcify_version(@{$found})], + [_srcify_version(@{$fixed})], + [_srcify_version(@{$interested})], + ); +} + +sub load { + my $self = shift; + for my $src_pkg (@_) { + my $is_valid = 0; + if (ref($src_pkg)) { + $is_valid = $src_pkg->valid; + $src_pkg = $src_pkg->name; + } + next if $self->src_pkg_loaded($src_pkg); + my $srchash = substr $src_pkg, 0, 1; + my $version_fh; + open($version_fh,'<',"$config{version_packages_dir}/$srchash/$src_pkg"); + if (not defined $version_fh) { + carp "No version file for package $src_pkg" if $is_valid; + next; + } + $self->_load($version_fh); + $self->_set_src_pkg_loaded($src_pkg,1); + } +} + +__PACKAGE__->meta->make_immutable; +no Mouse; +1; + + +__END__ +# Local Variables: +# indent-tabs-mode: nil +# cperl-indent-level: 4 +# End: diff --git a/lib/Debbugs/Versions.pm b/lib/Debbugs/Versions.pm new file mode 100644 index 0000000..5545b48 --- /dev/null +++ b/lib/Debbugs/Versions.pm @@ -0,0 +1,394 @@ +# 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. +# +# [Other people have contributed to this file; their copyrights should +# go here too.] + +package Debbugs::Versions; + +use warnings; + +use strict; + +=head1 NAME + +Debbugs::Versions - debbugs version information processing + +=head1 DESCRIPTION + +The Debbugs::Versions module provides generic support functions for the +implementation of version tracking in debbugs. + +Complex organizations, such as Debian, require the tracking of bugs in +multiple versions of packages. The versioning scheme is frequently branched: +for example, a security update announced by an upstream developer will be +packaged as-is for the unstable distribution while a minimal backport is +made to the stable distribution. In order to report properly on the bugs +open in each distribution, debbugs must be aware of the structure of the +version tree for each package. + +Gathering the version data is beyond the scope of this module: in the case +of Debian it is carried out by mechanical analysis of package changelogs. +Debbugs::Versions takes version data for a package generated by this or any +other means, merges it into a tree structure, and allows the user to perform +queries based on supplied data about the versions in which bugs have been +found and the versions in which they have been fixed. + +=head1 DATA FORMAT + +The data format looks like this (backslashes are not actually there, and +indicate continuation lines): + + 1.5.4 1.5.0 1.5-iwj.0.4 1.5-iwj.0.3 1.5-iwj.0.2 1.5-iwj.0.1 1.4.0 1.3.14 \ + 1.3.13 1.3.12 1.3.11 1.3.10 ... + 1.4.1.6 1.4.1.5 1.4.1.4 1.4.1.3 1.4.1.2 1.4.1.1 1.4.1 1.4.0.31 1.4.0.30 \ + 1.4.0.29 1.4.0.28 1.4.0.27 1.4.0.26.0.1 1.4.0.26 1.4.0.25 1.4.0.24 \ + 1.4.0.23.2 1.4.0.23.1 1.4.0.23 1.4.0.22 1.4.0.21 1.4.0.20 1.4.0.19 \ + 1.4.0.18 1.4.0.17 1.4.0.16 1.4.0.15 1.4.0.14 1.4.0.13 1.4.0.12 \ + 1.4.0.11 1.4.0.10 1.4.0.9 1.4.0.8 1.4.0.7 1.4.0.6 1.4.0.5 1.4.0.4 \ + 1.4.0.3 1.4.0.2 1.4.0.1 1.4.0 \ + 1.4.0.35 1.4.0.34 1.4.0.33 1.4.0.32 1.4.0.31 + +=head1 METHODS + +=over 8 + +=item new + +Constructs a Debbugs::Versions object. The argument is a reference to a +version comparison function, which must be usable by Perl's built-in C +function. + +=cut + +sub new +{ + my $this = shift; + my $class = ref($this) || $this; + my $vercmp = shift; + my $self = { parent => {}, vercmp => $vercmp }; + return bless $self, $class; +} + +=item isancestor + +Takes two arguments, C and C. Returns true if and only +if C is a version on which C is based according to the +version data supplied to this object. (As a degenerate case, this relation +is reflexive: a version is considered to be an ancestor of itself.) + +This method is expected mainly to be used internally by the C method. + +=cut + +sub isancestor +{ + my $self = shift; + my $ancestor = shift; + my $descendant = shift; + + my $parent = $self->{parent}; + for (my $node = $descendant; defined $node; $node = $parent->{$node}) { + return 1 if $node eq $ancestor; + } + + return 0; +} + +=item leaves + +Find the leaves of the version tree, i.e. those versions with no +descendants. + +This method is mainly for internal use. + +=cut + +sub leaves +{ + my $self = shift; + + my $parent = $self->{parent}; + my @vers = keys %$parent; + my %leaf; + @leaf{@vers} = (1) x @vers; + for my $v (@vers) { + delete $leaf{$parent->{$v}} if defined $parent->{$v}; + } + return keys %leaf; +} + +=item merge + +Merges one branch of version data into this object. This branch takes the +form of a list of versions, each of which is to be considered as based on +the next in the list. + +=cut + +sub merge +{ + my $self = shift; + return unless @_; + my $last = $_[0]; + for my $i (1 .. $#_) { + # Detect loops. + next if $self->isancestor($last, $_[$i]); + + # If it's already an ancestor version, don't add it again. This + # keeps the tree correct when we get several partial branches, such + # as '1.4.0 1.3.14 1.3.13 1.3.12' followed by '1.4.0 1.3.12 1.3.10'. + unless ($self->isancestor($_[$i], $last)) { + $self->{parent}{$last} = $_[$i]; + } + + $last = $_[$i]; + } + # Insert undef for the last version so that we can tell a known version + # by seeing if it exists in $self->{parent}. + $self->{parent}{$_[$#_]} = undef unless exists $self->{parent}{$_[$#_]}; +} + +=item load + +Loads version data from the filehandle passed as the argument. Each line of +input is expected to represent one branch, with versions separated by +whitespace. + +=cut + +sub load +{ + my $self = shift; + my $fh = shift; + local $_; + while (<$fh>) { + $self->merge(split); + } +} + +=item save + +Outputs the version tree represented by this object to the filehandle passed +as the argument. The format is the same as that expected by the C +method. + +=cut + +sub save +{ + my $self = shift; + my $fh = shift; + local $_; + my $parent = $self->{parent}; + + # TODO: breaks with tcp-wrappers/1.0-1 tcpd/2.0-1 case + my @leaves = reverse sort { + my ($x, $y) = ($a, $b); + $x =~ s{.*/}{}; + $y =~ s{.*/}{}; + $self->{vercmp}->($x, $y); + } $self->leaves(); + + my %seen; + for my $lf (@leaves) { + print $fh $lf; + $seen{$lf} = 1; + for (my $node = $parent->{$lf}; defined $node; + $node = $parent->{$node}) { + print $fh " $node"; + last if exists $seen{$node}; + $seen{$node} = 1; + } + print $fh "\n"; + } +} + +=item buggy + +Takes three arguments, C, C, and C. Returns true if +and only if C is based on or equal to a version in the list +referenced by C, and not based on or equal to one referenced by +C. + +C attempts to cope with found and fixed versions not in the version +tree by simply checking whether any fixed versions are recorded in the event +that nothing is known about any of the found versions. + +=cut + +sub buggy +{ + my $self = shift; + my $version = shift; + my $found = shift; + my $fixed = shift; + + my %found = map { $_ => 1 } @$found; + my %fixed = map { $_ => 1 } @$fixed; + my $parent = $self->{parent}; + for (my $node = $version; defined $node; $node = $parent->{$node}) { + # The found and fixed tests are this way round because the most + # likely scenario is that somebody thought they'd fixed a bug and + # then it was reopened because it turned out not to have been fixed + # after all. However, tools that build found and fixed lists should + # generally know the order of events and make sure that the two + # lists have no common entries. + return 'found' if $found{$node}; + return 'fixed' if $fixed{$node}; + } + + unless (@$found) { + # We don't know when it was found. Was it fixed in a descendant of + # this version? If so, this one should be considered buggy. + for my $f (@$fixed) { + for (my $node = $f; defined $node; $node = $parent->{$node}) { + return 'found' if $node eq $version; + } + } + } + + # Nothing in the requested version's ancestor chain can be confirmed as + # a version in which the bug was found or fixed. If it was only found or + # fixed on some other branch, then this one isn't buggy. + for my $f (@$found, @$fixed) { + return 'absent' if exists $parent->{$f}; + } + + # Otherwise, we degenerate to checking whether any fixed versions at all + # are recorded. + return 'fixed' if @$fixed; + return 'found'; +} + +=item allstates + +Takes two arguments, C and C, which are interpreted as in +L. Efficiently returns the state of the bug at every known version, +in the form of a hash from versions to states (as returned by L). If +you pass a third argument, C, this method will stop after +determining the state of the bug at all the versions listed therein. + +Whether this is faster than calling L for each version you're +interested in is not altogether clear, and depends rather strongly on the +number of known and interested versions. + +=cut + +sub allstates +{ + my $self = shift; + my $found = shift; + my $fixed = shift; + my $interested = shift; + + my %found = map { $_ => 1 } @$found; + my %fixed = map { $_ => 1 } @$fixed; + my %interested; + if (defined $interested) { + %interested = map { $_ => 1 } @$interested; + } + my $parent = $self->{parent}; + my @leaves = $self->leaves(); + + # Are any of the found or fixed versions known? We'll need this later. + my $known = 0; + for my $f (@$found, @$fixed) { + if (exists $parent->{$f}) { + $known = 1; + last; + } + } + + # Start at each leaf in turn, working our way up and remembering the + # list of versions in the branch. + my %state; + LEAF: for my $lf (@leaves) { + my @branch; + my $fixeddesc = 0; + + for (my $node = $lf; defined $node; $node = $parent->{$node}) { + # If we're about to start a new branch, check whether we know + # the state of every version in which we're interested. If so, + # we can stop now. + if (defined $interested and not @branch) { + my @remove; + for my $interest (keys %interested) { + if (exists $state{$interest}) { + push @remove, $interest; + } + } + delete @interested{@remove}; + last LEAF unless keys %interested; + } + + # We encounter a version whose state we already know. Record the + # branch with the same state as that version, and go on to the + # next leaf. + if (exists $state{$node}) { + $state{$_} = $state{$node} foreach @branch; + last; + } + + push @branch, $node; + + # We encounter a version in the found list. Record the branch as + # 'found', and start a new branch. + if ($found{$node}) { + $state{$_} = 'found' foreach @branch; + @branch = (); + } + + # We encounter a version in the fixed list. Record the branch as + # 'fixed', and start a new branch, remembering that we have a + # fixed descendant. + elsif ($fixed{$node}) { + $state{$_} = 'fixed' foreach @branch; + @branch = (); + $fixeddesc = 1; + } + + # We encounter a root. + elsif (not defined $parent->{$node}) { + # If the found list is empty and we have a fixed descendant, + # record the branch as 'found' (since they probably just + # forgot to report a version when opening the bug). + if (not @$found and $fixeddesc) { + $state{$_} = 'found' foreach @branch; + } + + # If any of the found or fixed versions are known, record + # the branch as 'absent' (since all the activity must have + # happened on some other branch). + elsif ($known) { + $state{$_} = 'absent' foreach @branch; + } + + # If there are any fixed versions at all (but they're + # unknown), then who knows, but we guess at recording the + # branch as 'fixed'. + elsif (@$fixed) { + $state{$_} = 'fixed' foreach @branch; + } + + # Otherwise, fall back to recording the branch as 'found'. + else { + $state{$_} = 'found' foreach @branch; + } + + # In any case, we're done. + last; + } + } + } + + return %state; +} + +=back + +=cut + +1; diff --git a/lib/Debbugs/Versions/Dpkg.pm b/lib/Debbugs/Versions/Dpkg.pm new file mode 100644 index 0000000..aa9d937 --- /dev/null +++ b/lib/Debbugs/Versions/Dpkg.pm @@ -0,0 +1,162 @@ +# 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 Colin Watson +# Copyright Ian Jackson +# Copyright 2007 by Don Armstrong . + + +package Debbugs::Versions::Dpkg; + +use strict; + +=head1 NAME + +Debbugs::Versions::Dpkg - pure-Perl dpkg-style version comparison + +=head1 DESCRIPTION + +The Debbugs::Versions::Dpkg module provides pure-Perl routines to compare +dpkg-style version numbers, as used in Debian packages. If you have the +libapt-pkg Perl bindings available (Debian package libapt-pkg-perl), they +may offer better performance. + +=head1 METHODS + +=over 8 + +=cut + +sub parseversion ($) +{ + my $ver = shift; + my %verhash; + if ($ver =~ /:/) + { + $ver =~ /^(\d+):(.+)/ or die "bad version number '$ver'"; + $verhash{epoch} = $1; + $ver = $2; + } + else + { + $verhash{epoch} = 0; + } + if ($ver =~ /(.+)-(.*)$/) + { + $verhash{version} = $1; + $verhash{revision} = $2; + } + else + { + $verhash{version} = $ver; + $verhash{revision} = 0; + } + return %verhash; +} + +# verrevcmp + +# This function is almost exactly equivalent +# to dpkg's verrevcmp function, including the +# order subroutine which it uses. + +sub verrevcmp($$) +{ + + sub order{ + my ($x) = @_; + ##define order(x) ((x) == '~' ? -1 \ + # : cisdigit((x)) ? 0 \ + # : !(x) ? 0 \ + # : cisalpha((x)) ? (x) \ + # : (x) + 256) + # This comparison is out of dpkg's order to avoid + # comparing things to undef and triggering warnings. + if (not defined $x or not length $x) { + return 0; + } + elsif ($x eq '~') { + return -1; + } + elsif ($x =~ /^\d$/) { + return 0; + } + elsif ($x =~ /^[A-Z]$/i) { + return ord($x); + } + else { + return ord($x) + 256; + } + } + + sub next_elem(\@){ + my $a = shift; + return @{$a} ? shift @{$a} : undef; + } + my ($val, $ref) = @_; + $val = "" if not defined $val; + $ref = "" if not defined $ref; + my @val = split //,$val; + my @ref = split //,$ref; + my $vc = next_elem @val; + my $rc = next_elem @ref; + while (defined $vc or defined $rc) { + my $first_diff = 0; + while ((defined $vc and $vc !~ /^\d$/) or + (defined $rc and $rc !~ /^\d$/)) { + my $vo = order($vc); my $ro = order($rc); + # Unlike dpkg's verrevcmp, we only return 1 or -1 here. + return (($vo - $ro > 0) ? 1 : -1) if $vo != $ro; + $vc = next_elem @val; $rc = next_elem @ref; + } + while (defined $vc and $vc eq '0') { + $vc = next_elem @val; + } + while (defined $rc and $rc eq '0') { + $rc = next_elem @ref; + } + while (defined $vc and $vc =~ /^\d$/ and + defined $rc and $rc =~ /^\d$/) { + $first_diff = ord($vc) - ord($rc) if !$first_diff; + $vc = next_elem @val; $rc = next_elem @ref; + } + return 1 if defined $vc and $vc =~ /^\d$/; + return -1 if defined $rc and $rc =~ /^\d$/; + return (($first_diff > 0) ? 1 : -1) if $first_diff; + } + return 0; +} + +=item vercmp + +Compare the two arguments as dpkg-style version numbers. Returns -1 if the +first argument represents a lower version number than the second, 1 if the +first argument represents a higher version number than the second, and 0 if +the two arguments represent equal version numbers. + +=cut + +sub vercmp ($$) +{ + my %version = parseversion $_[0]; + my %refversion = parseversion $_[1]; + return 1 if $version{epoch} > $refversion{epoch}; + return -1 if $version{epoch} < $refversion{epoch}; + my $r = verrevcmp($version{version}, $refversion{version}); + return $r if $r; + return verrevcmp($version{revision}, $refversion{revision}); +} + +=back + +=head1 AUTHOR + +Don Armstrong and Colin Watson +Ecjwatson@debian.orgE, based on the implementation in +C by Ian Jackson and others. + +=cut + +1; diff --git a/lib/Mail/CrossAssassin.pm b/lib/Mail/CrossAssassin.pm new file mode 100644 index 0000000..b8c676f --- /dev/null +++ b/lib/Mail/CrossAssassin.pm @@ -0,0 +1,98 @@ +# CrossAssassin.pm 2004/04/12 blarson + +package Mail::CrossAssassin; + +use strict; +require Exporter; +our @ISA = qw(Exporter); +our @EXPORT = qw(ca_init ca_keys ca_set ca_score ca_expire); +our $VERSION = 0.1; + +use Digest::MD5 qw(md5_base64); +use DB_File; + +our %database; +our $init; +our $addrpat = '\b\d{3,8}(?:-(?:close|done|forwarded|maintonly|submitter|quiet))?\@bugs\.debian\.org'; + +sub ca_init(;$$) { + my $ap = shift; + $addrpat = $ap if(defined $ap); + my $dir = shift; + return if ($init && ! defined($dir)); + $dir = "$ENV{'HOME'}/.crosssassassin" unless (defined($dir)); + (mkdir $dir or die "Could not create \"$dir\"") unless (-d $dir); + untie %database; + tie %database, 'DB_File', "$dir/Crossdb" + or die "Could not initialize crosassasin database \"$dir/Crossdb\": $!"; + $init = 1; +} + +sub ca_keys($) { + my $body = shift; + my @keys; + my $m = join('',@$body); + $m =~ s/\n(?:\s*\n)+/\n/gm; + if (length($m) > 4000) { + my $m2 = $m; + $m2 =~ s/\S\S+/\*/gs; + push @keys, '0'.md5_base64($m2); + } +# $m =~ s/^--.*$/--/m; + $m =~ s/$addrpat/LOCAL\@ADDRESS/iogm; + push @keys, '1'.md5_base64($m); + return join(' ',@keys); +} + +sub ca_set($) { + my @keys = split(' ', $_[0]); + my $now = time; + my $score = 0; + my @scores; + foreach my $k (@keys) { + my ($count,$date) = split(' ',$database{$k}); + $count++; + $score = $count if ($count > $score); + $database{$k} = "$count $now"; + push @scores, $count; + } + return (wantarray ? @scores : $score); +} + +sub ca_score($) { + my @keys = split(' ', $_[0]); + my $score = 0; + my @scores; + my $i = 0; + foreach my $k (@keys) { + my ($count,$date) = split(' ',$database{$k}); + $score = $count if ($count > $score); + $i++; + push @scores, $count; + } + return (wantarray ? @scores : $score); +} + +sub ca_expire($) { + my $when = shift; + my @ret; + my $num = 0; + my $exp = 0; + while (my ($k, $v) = each %database) { + $num++; + my ($count, $date) = split(' ', $v); + if ($date <= $when) { + delete $database{$k}; + $exp++; + } + } + return ($num, $exp); +} + +END { + return unless($init); + untie %database; + undef($init); +} + +1; diff --git a/t/01_pod.t b/t/01_pod.t index 2f1d2df..13c053a 100644 --- a/t/01_pod.t +++ b/t/01_pod.t @@ -2,6 +2,6 @@ use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; -all_pod_files_ok(grep {$_ !~ /[~#]$/} all_pod_files((-e 'blib'?'blib':(qw(Debbugs Mail))), +all_pod_files_ok(grep {$_ !~ /[~#]$/} all_pod_files((-e 'blib'?'blib':(qw(lib))), (qw(bin cgi scripts)) )); diff --git a/t/07_bugreport.t b/t/07_bugreport.t index dfc1650..fbbb09f 100644 --- a/t/07_bugreport.t +++ b/t/07_bugreport.t @@ -48,7 +48,7 @@ my $bugreport_cgi_handler = sub { # I do not understand why this is necessary. $ENV{DEBBUGS_CONFIG_FILE} = "$config{config_dir}/debbugs_config"; my $fh; - open($fh,'-|',-e './cgi/version.cgi'? 'perl -I. -T ./cgi/bugreport.cgi' : 'perl -I. -T ../cgi/bugreport.cgi'); + open($fh,'-|',-e './cgi/version.cgi'? 'perl -Ilib -T ./cgi/bugreport.cgi' : 'perl -Ilib -T ../cgi/bugreport.cgi'); my $headers; my $status = 200; while (<$fh>) { diff --git a/t/08_pkgreport.t b/t/08_pkgreport.t index eabee52..5a33390 100644 --- a/t/08_pkgreport.t +++ b/t/08_pkgreport.t @@ -46,7 +46,7 @@ EOF my $pkgreport_cgi_handler = sub { # I do not understand why this is necessary. $ENV{DEBBUGS_CONFIG_FILE} = "$config{config_dir}/debbugs_config"; - my $content = qx(perl -I. -T cgi/pkgreport.cgi); + my $content = qx(perl -Ilib -T cgi/pkgreport.cgi); # Strip off the Content-Type: stuff $content =~ s/^\s*Content-Type:[^\n]+\n*//si; print $content; diff --git a/t/11_blocks.t b/t/11_blocks.t index 72f7c35..95d4de6 100644 --- a/t/11_blocks.t +++ b/t/11_blocks.t @@ -156,7 +156,7 @@ ok($status->{blockedby} eq '5','bug 3 is blocked by exactly 5'); my $bugreport_cgi_handler = sub { # I do not understand why this is necessary. $ENV{DEBBUGS_CONFIG_FILE} = "$config{config_dir}/debbugs_config"; - my $content = qx(perl -I. -T cgi/bugreport.cgi); + my $content = qx(perl -Ilib -T cgi/bugreport.cgi); $content =~ s/^\s*Content-Type:[^\n]+\n*//si; print $content; }; diff --git a/t/lib/DebbugsTest.pm b/t/lib/DebbugsTest.pm index 152bd58..463b710 100644 --- a/t/lib/DebbugsTest.pm +++ b/t/lib/DebbugsTest.pm @@ -78,7 +78,7 @@ sub create_debbugs_configuration { $ENV{DEBBUGS_CONFIG_FILE} ="$config_dir/debbugs_config"; - $ENV{PERL5LIB} = getcwd(); + $ENV{PERL5LIB} = getcwd().'/lib/'; $ENV{SENDMAIL_TESTDIR} = $sendmail_dir; eval { my $sendmail_tester = getcwd().'/t/sendmail_tester';